From f07bffb83b782658e1490353b8f5149fb5c82f42 Mon Sep 17 00:00:00 2001 From: Mats Bentsen Date: Thu, 23 Sep 2021 16:17:55 +0200 Subject: [PATCH 001/366] Reverted changes to mod_vcoord.F90 in commit 4f31a2f "CVMix scheme is added as submodule". --- phy/mod_vcoord.F90 | 41 ++++++++++++++--------------------------- 1 file changed, 14 insertions(+), 27 deletions(-) diff --git a/phy/mod_vcoord.F90 b/phy/mod_vcoord.F90 index d89dd3ec..bc4ffbfb 100644 --- a/phy/mod_vcoord.F90 +++ b/phy/mod_vcoord.F90 @@ -60,9 +60,8 @@ module mod_vcoord velocity_pc_upper_bndr = .true., & velocity_pc_lower_bndr = .false. real(r8) :: & - dpmin_surface = 1.5_r8, & - dpmin_inflation_factor = 1._r8, & - dpmin_interior = .1_r8 + dpmin_surface = 1.5_r8, & + dpmin_interior = .1_r8 ! Options derived from string options. integer :: & @@ -110,7 +109,7 @@ subroutine readnml_vcoord 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 + dpmin_surface, dpmin_interior ! Read variables in the namelist group 'vcoord'. if (mnproc == 1) then @@ -151,7 +150,6 @@ subroutine readnml_vcoord 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) endif if (mnproc == 1) then @@ -173,7 +171,6 @@ subroutine readnml_vcoord write (lp,*) ' velocity_pc_upper_bndr = ', velocity_pc_upper_bndr write (lp,*) ' velocity_pc_lower_bndr = ', velocity_pc_lower_bndr write (lp,*) ' dpmin_surface = ', dpmin_surface - write (lp,*) ' dpmin_inflation_factor = ', dpmin_inflation_factor write (lp,*) ' dpmin_interior = ', dpmin_interior endif @@ -279,7 +276,7 @@ subroutine cntiso_hybrid_regrid_remap(m, n, mm, nn, k1m, k1n) real(r8), dimension(kdm + 1) :: p_1d, prgrd_1d, sigmar_1d real(r8), dimension(kdm) :: temp_1d, saln_1d, sigma_1d real(r8) :: beta, sdpsum, smean, dpmin_max, dpmin, pku, pku_test, & - pmin, dpt, pt, ptu1, ptl1, ptu2, ptl2, w1, x + pmin, dpt, ptup, ptlo, x integer :: i, j, k, l, kn, nt, ks, ke, kl, ku, errstat logical :: thin_layers, layer_added #ifdef TRC @@ -517,29 +514,19 @@ subroutine cntiso_hybrid_regrid_remap(m, n, mm, nn, k1m, k1n) ! layer thickness towards the surface is maintained. A smooth ! transition between modified and unmodified interfaces is sought. dpmin = min(dpmin_max, dpmin_surface) - pmin = p_1d(1) + dpmin - dpt = dpmin do k = 2, ke - dpmin = dpmin*dpmin_inflation_factor - dpt = max(prgrd_1d(k + 1) - prgrd_1d(k), dpt, dpmin) - pt = max(prgrd_1d(k), pmin) - ptu1 = pmin - dpt - ptl1 = pmin + dpt - ptu2 = pmin - ptl2 = pmin + 2._r8*dpt - w1 = min(1._r8,(prgrd_1d(k) - p_1d(1))/(pmin - p_1d(1))) - if (prgrd_1d(k) > ptu1 .and. prgrd_1d(k) < ptl1) then - x = .5_r8*(prgrd_1d(k) - ptu1)/dpt - pt = pmin + dpt*x*x + pmin = p_1d(1) + dpmin*(k - 1) + dpt = max(prgrd_1d(k + 1) - prgrd_1d(k), 3._r8*dpmin) + ptup = max(p_1d(1), pmin + dpmin - dpt) + ptlo = min(p_1d(ke + 1), 2._r8*pmin - ptup) + ptup = 2._r8*pmin - ptlo + if (prgrd_1d(k) > ptup .and. prgrd_1d(k) < ptlo) then + x = (prgrd_1d(k) - ptup)/(ptlo - ptup) + pmin = pmin + .5_r8*(ptlo - ptup)*x*x endif - if (prgrd_1d(k + 1) > ptu2 .and. prgrd_1d(k + 1) < ptl2) then - x = .5_r8*(prgrd_1d(k + 1) - ptu2)/dpt - pt = w1*pt + (1._r8 - w1)*(pmin + dpt*x*x) - endif - prgrd_1d(k) = min(p_1d(ke + 1), pt) - pmin = pmin + dpmin + prgrd_1d(k) = min(p_1d(ke + 1), max(prgrd_1d(k), pmin)) enddo - + ! Prepare remapping to layer structure with regridded interface ! pressures. errstat = prepare_remapping(rcs, prgrd_1d, rms) From 1ba50ea6e1bdaca85f4877524657b3a65efe02c4 Mon Sep 17 00:00:00 2001 From: Mats Bentsen Date: Thu, 23 Sep 2021 16:20:08 +0200 Subject: [PATCH 002/366] Modified the transition between isopycnic and constant pressure interfaces for hybrid vertical coordinate. --- phy/mod_vcoord.F90 | 28 ++++++++++++++++++---------- 1 file changed, 18 insertions(+), 10 deletions(-) diff --git a/phy/mod_vcoord.F90 b/phy/mod_vcoord.F90 index bc4ffbfb..9f0bb1d6 100644 --- a/phy/mod_vcoord.F90 +++ b/phy/mod_vcoord.F90 @@ -276,7 +276,7 @@ subroutine cntiso_hybrid_regrid_remap(m, n, mm, nn, k1m, k1n) real(r8), dimension(kdm + 1) :: p_1d, prgrd_1d, sigmar_1d real(r8), dimension(kdm) :: temp_1d, saln_1d, sigma_1d real(r8) :: beta, sdpsum, smean, dpmin_max, dpmin, pku, pku_test, & - pmin, dpt, ptup, ptlo, x + pmin, dpt, pt, ptu1, ptl1, ptu2, ptl2, w1, x integer :: i, j, k, l, kn, nt, ks, ke, kl, ku, errstat logical :: thin_layers, layer_added #ifdef TRC @@ -514,19 +514,27 @@ subroutine cntiso_hybrid_regrid_remap(m, n, mm, nn, k1m, k1n) ! layer thickness towards the surface is maintained. A smooth ! transition between modified and unmodified interfaces is sought. dpmin = min(dpmin_max, dpmin_surface) + dpt = dpmin do k = 2, ke pmin = p_1d(1) + dpmin*(k - 1) - dpt = max(prgrd_1d(k + 1) - prgrd_1d(k), 3._r8*dpmin) - ptup = max(p_1d(1), pmin + dpmin - dpt) - ptlo = min(p_1d(ke + 1), 2._r8*pmin - ptup) - ptup = 2._r8*pmin - ptlo - if (prgrd_1d(k) > ptup .and. prgrd_1d(k) < ptlo) then - x = (prgrd_1d(k) - ptup)/(ptlo - ptup) - pmin = pmin + .5_r8*(ptlo - ptup)*x*x + dpt = max(prgrd_1d(k + 1) - prgrd_1d(k), dpt) + pt = max(prgrd_1d(k), pmin) + ptu1 = pmin - dpt + ptl1 = pmin + dpt + ptu2 = pmin + ptl2 = pmin + 2._r8*dpt + w1 = min(1._r8,(prgrd_1d(k) - p_1d(1))/(pmin - p_1d(1))) + if (prgrd_1d(k) > ptu1 .and. prgrd_1d(k) < ptl1) then + x = .5_r8*(prgrd_1d(k) - ptu1)/dpt + pt = pmin + dpt*x*x endif - prgrd_1d(k) = min(p_1d(ke + 1), max(prgrd_1d(k), pmin)) + if (prgrd_1d(k + 1) > ptu2 .and. prgrd_1d(k + 1) < ptl2) then + x = .5_r8*(prgrd_1d(k + 1) - ptu2)/dpt + pt = w1*pt + (1._r8 - w1)*(pmin + dpt*x*x) + endif + prgrd_1d(k) = min(p_1d(ke + 1), pt) enddo - + ! Prepare remapping to layer structure with regridded interface ! pressures. errstat = prepare_remapping(rcs, prgrd_1d, rms) From 85d8d863f2603765a75651734aace17b8595699f Mon Sep 17 00:00:00 2001 From: Mats Bentsen Date: Thu, 23 Sep 2021 16:21:55 +0200 Subject: [PATCH 003/366] Added an inflation factor for gradually increasing the minimum thickness with depth of constant pressure interfaces when using hybrid vertical coordinate. --- phy/mod_vcoord.F90 | 15 ++++++++++----- 1 file changed, 10 insertions(+), 5 deletions(-) diff --git a/phy/mod_vcoord.F90 b/phy/mod_vcoord.F90 index 9f0bb1d6..d89dd3ec 100644 --- a/phy/mod_vcoord.F90 +++ b/phy/mod_vcoord.F90 @@ -60,8 +60,9 @@ module mod_vcoord velocity_pc_upper_bndr = .true., & velocity_pc_lower_bndr = .false. real(r8) :: & - dpmin_surface = 1.5_r8, & - dpmin_interior = .1_r8 + dpmin_surface = 1.5_r8, & + dpmin_inflation_factor = 1._r8, & + dpmin_interior = .1_r8 ! Options derived from string options. integer :: & @@ -109,7 +110,7 @@ subroutine readnml_vcoord 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_interior + dpmin_surface, dpmin_inflation_factor, dpmin_interior ! Read variables in the namelist group 'vcoord'. if (mnproc == 1) then @@ -150,6 +151,7 @@ subroutine readnml_vcoord 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) endif if (mnproc == 1) then @@ -171,6 +173,7 @@ subroutine readnml_vcoord write (lp,*) ' velocity_pc_upper_bndr = ', velocity_pc_upper_bndr write (lp,*) ' velocity_pc_lower_bndr = ', velocity_pc_lower_bndr write (lp,*) ' dpmin_surface = ', dpmin_surface + write (lp,*) ' dpmin_inflation_factor = ', dpmin_inflation_factor write (lp,*) ' dpmin_interior = ', dpmin_interior endif @@ -514,10 +517,11 @@ subroutine cntiso_hybrid_regrid_remap(m, n, mm, nn, k1m, k1n) ! layer thickness towards the surface is maintained. A smooth ! transition between modified and unmodified interfaces is sought. dpmin = min(dpmin_max, dpmin_surface) + pmin = p_1d(1) + dpmin dpt = dpmin do k = 2, ke - pmin = p_1d(1) + dpmin*(k - 1) - dpt = max(prgrd_1d(k + 1) - prgrd_1d(k), dpt) + dpmin = dpmin*dpmin_inflation_factor + dpt = max(prgrd_1d(k + 1) - prgrd_1d(k), dpt, dpmin) pt = max(prgrd_1d(k), pmin) ptu1 = pmin - dpt ptl1 = pmin + dpt @@ -533,6 +537,7 @@ subroutine cntiso_hybrid_regrid_remap(m, n, mm, nn, k1m, k1n) pt = w1*pt + (1._r8 - w1)*(pmin + dpt*x*x) endif prgrd_1d(k) = min(p_1d(ke + 1), pt) + pmin = pmin + dpmin enddo ! Prepare remapping to layer structure with regridded interface From 0aedc34d9c178ca50fd8f2efd2d192bb0af91a3a Mon Sep 17 00:00:00 2001 From: Mats Bentsen Date: Tue, 28 Sep 2021 23:46:14 +0200 Subject: [PATCH 004/366] Added diagnostics of vertical momentum, heat and salt diffusivities. --- phy/mod_dia.F | 1406 +++++++++++++++++++++++++++++++------------------ phy/rdlim.F | 209 +++++--- 2 files changed, 1017 insertions(+), 598 deletions(-) diff --git a/phy/mod_dia.F b/phy/mod_dia.F index 00b6d85e..f77cac2d 100644 --- a/phy/mod_dia.F +++ b/phy/mod_dia.F @@ -18,7 +18,7 @@ ! along with BLOM. If not, see . ! ------------------------------------------------------------------------------ - module mod_dia + module mod_dia c use mod_types, only: i2 use mod_config, only: expcnf, runid, inst_suffix @@ -27,7 +27,7 @@ module mod_dia . nday_of_year, time, time0, baclin, dlt use mod_constants, only: g, spcifh, t0deg, alpha0, epsil, spval, . onem, onecm, onemm - use mod_xc + use mod_xc use mod_nctools use netcdf, only : nf90_fill_double use mod_vcoord, only: sigmar @@ -41,6 +41,7 @@ module mod_dia use mod_mxlayr, only: mtkeus, mtkeni, mtkebf, mtkers, mtkepe, . mtkeke, pbrnda use mod_diffusion, only: difint, difiso, difdia, + . Kvisc_m, Kdiff_t, Kdiff_s, . umfltd, vmfltd, utfltd, vtfltd, utflld, . vtflld, usfltd, vsfltd, usflld, vsflld use mod_cmnfld, only: bfsql @@ -79,24 +80,24 @@ module mod_dia c c --- Copies of BLOM variables that are used for HAMOCC diagnostics real, save, dimension(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy) :: - . pbath,ubath,vbath - integer, save :: nstepinday - -c --- 2d and 3d diagnostic variables - integer, save :: nphyh2d,nphylyr,nphylvl + . pbath,ubath,vbath + integer, save :: nstepinday +c +c --- 2d and 3d diagnostic variables + integer, save :: nphyh2d,nphylyr,nphylvl real, save, allocatable, dimension(:,:,:) :: phyh2d - real, save, allocatable, dimension(:,:,:,:) :: phylyr,phylvl + real, save, allocatable, dimension(:,:,:,:) :: phylyr,phylvl c -c --- Levitus levels -#ifndef LEVITUS2X +c --- Levitus levels +#ifndef LEVITUS2X integer, parameter :: ddm=35,k350=12 real, parameter :: w350=1. real, parameter, dimension(ddm) :: depthslev=(/ - . 0000.0,0010.0,0020.0,0030.0,0050.0,0075.0,0100.0,0125.0,0150.0, - . 0200.0,0250.0,0300.0,0400.0,0500.0,0600.0,0700.0,0800.0,0900.0, - . 1000.0,1100.0,1200.0,1300.0,1400.0,1500.0,1750.0,2000.0,2500.0, + . 0000.0,0010.0,0020.0,0030.0,0050.0,0075.0,0100.0,0125.0,0150.0, + . 0200.0,0250.0,0300.0,0400.0,0500.0,0600.0,0700.0,0800.0,0900.0, + . 1000.0,1100.0,1200.0,1300.0,1400.0,1500.0,1750.0,2000.0,2500.0, . 3000.0,3500.0,4000.0,4500.0,5000.0,5500.0,6000.0,6500.0/) - real, parameter, dimension(2,ddm) :: + real, parameter, dimension(2,ddm) :: . depthslev_bnds=reshape((/ . 0000.0,0005.0,0005.0,0015.0,0015.0,0025.0,0025.0,0040.0,0040.0, . 0062.5,0062.5,0087.5,0087.5,0112.5,0112.5,0137.5,0137.5,0175.0, @@ -106,39 +107,39 @@ module mod_dia . 1450.0,1450.0,1625.0,1625.0,1875.0,1875.0,2250.0,2250.0,2750.0, . 2750.0,3250.0,3250.0,3750.0,3750.0,4250.0,4250.0,4750.0,4750.0, . 5250.0,5250.0,5750.0,5750.0,6250.0,6250.0,8000.0/),(/2,ddm/)) -#else +#else integer, parameter :: ddm=70,k350=25 real, parameter :: w350=0.5 real, parameter, dimension(ddm) :: depthslev=(/ - . 0000.0,0005.0,0010.0,0015.0,0020.0,0025.0,0030.0,0040.0,0050.0, - . 0062.5,0075.0,0087.5,0100.0,0112.5,0125.0,0137.5,0150.0,0175.0, - . 0200.0,0225.0,0250.0,0275.0,0300.0,0350.0,0400.0,0450.0,0500.0, - . 0550.0,0600.0,0650.0,0700.0,0750.0,0800.0,0850.0,0900.0,0950.0, - . 1000.0,1050.0,1100.0,1150.0,1200.0,1250.0,1300.0,1350.0,1400.0, - . 1450.0,1500.0,1625.0,1750.0,1875.0,2000.0,2250.0,2500.0,2750.0, - . 3000.0,3250.0,3500.0,3750.0,4000.0,4250.0,4500.0,4750.0,5000.0, + . 0000.0,0005.0,0010.0,0015.0,0020.0,0025.0,0030.0,0040.0,0050.0, + . 0062.5,0075.0,0087.5,0100.0,0112.5,0125.0,0137.5,0150.0,0175.0, + . 0200.0,0225.0,0250.0,0275.0,0300.0,0350.0,0400.0,0450.0,0500.0, + . 0550.0,0600.0,0650.0,0700.0,0750.0,0800.0,0850.0,0900.0,0950.0, + . 1000.0,1050.0,1100.0,1150.0,1200.0,1250.0,1300.0,1350.0,1400.0, + . 1450.0,1500.0,1625.0,1750.0,1875.0,2000.0,2250.0,2500.0,2750.0, + . 3000.0,3250.0,3500.0,3750.0,4000.0,4250.0,4500.0,4750.0,5000.0, . 5250.0,5500.0,5750.0,6000.0,6250.0,6500.0,6750.0/) - real, parameter, dimension(2,ddm) :: + real, parameter, dimension(2,ddm) :: . depthslev_bnds=reshape((/ - . 0000.0,0002.5,0002.5,0007.5,0007.5,0012.5,0012.5,0017.5,0017.5, - . 0022.5,0022.5,0027.5,0027.5,0035.0,0035.0,0045.0,0045.0,0056.2, - . 0056.2,0068.8,0068.8,0081.2,0081.2,0093.8,0093.8,0106.2,0106.2, - . 0118.8,0118.8,0131.2,0131.2,0143.8,0143.8,0162.5,0162.5,0187.5, - . 0187.5,0212.5,0212.5,0237.5,0237.5,0262.5,0262.5,0287.5,0287.5, - . 0325.0,0325.0,0375.0,0375.0,0425.0,0425.0,0475.0,0475.0,0525.0, - . 0525.0,0575.0,0575.0,0625.0,0625.0,0675.0,0675.0,0725.0,0725.0, - . 0775.0,0775.0,0825.0,0825.0,0875.0,0875.0,0925.0,0925.0,0975.0, - . 0975.0,1025.0,1025.0,1075.0,1075.0,1125.0,1125.0,1175.0,1175.0, - . 1225.0,1225.0,1275.0,1275.0,1325.0,1325.0,1375.0,1375.0,1425.0, - . 1425.0,1475.0,1475.0,1562.5,1562.5,1687.5,1687.5,1812.5,1812.5, - . 1937.5,1937.5,2125.0,2125.0,2375.0,2375.0,2625.0,2625.0,2875.0, - . 2875.0,3125.0,3125.0,3375.0,3375.0,3625.0,3625.0,3875.0,3875.0, - . 4125.0,4125.0,4375.0,4375.0,4625.0,4625.0,4875.0,4875.0,5125.0, - . 5125.0,5375.0,5375.0,5625.0,5625.0,5875.0,5875.0,6125.0,6125.0, + . 0000.0,0002.5,0002.5,0007.5,0007.5,0012.5,0012.5,0017.5,0017.5, + . 0022.5,0022.5,0027.5,0027.5,0035.0,0035.0,0045.0,0045.0,0056.2, + . 0056.2,0068.8,0068.8,0081.2,0081.2,0093.8,0093.8,0106.2,0106.2, + . 0118.8,0118.8,0131.2,0131.2,0143.8,0143.8,0162.5,0162.5,0187.5, + . 0187.5,0212.5,0212.5,0237.5,0237.5,0262.5,0262.5,0287.5,0287.5, + . 0325.0,0325.0,0375.0,0375.0,0425.0,0425.0,0475.0,0475.0,0525.0, + . 0525.0,0575.0,0575.0,0625.0,0625.0,0675.0,0675.0,0725.0,0725.0, + . 0775.0,0775.0,0825.0,0825.0,0875.0,0875.0,0925.0,0925.0,0975.0, + . 0975.0,1025.0,1025.0,1075.0,1075.0,1125.0,1125.0,1175.0,1175.0, + . 1225.0,1225.0,1275.0,1275.0,1325.0,1325.0,1375.0,1375.0,1425.0, + . 1425.0,1475.0,1475.0,1562.5,1562.5,1687.5,1687.5,1812.5,1812.5, + . 1937.5,1937.5,2125.0,2125.0,2375.0,2375.0,2625.0,2625.0,2875.0, + . 2875.0,3125.0,3125.0,3375.0,3375.0,3625.0,3625.0,3875.0,3875.0, + . 4125.0,4125.0,4375.0,4375.0,4625.0,4625.0,4875.0,4875.0,5125.0, + . 5125.0,5375.0,5375.0,5625.0,5625.0,5875.0,5875.0,6125.0,6125.0, . 6375.0,6375.0,6625.0,6625.0,8000.0/),(/2,ddm/)) -#endif +#endif c -c --- Meridional overturning and flux diagnostics +c --- Meridional overturning and flux diagnostics integer, parameter :: . ldm=itdm+jtdm,sdm=ldm,odm=10,slenmax=50,rflgdm=20 character(len=slenmax), save, dimension(odm) :: mer_regnam='' @@ -146,15 +147,15 @@ module mod_dia integer, save, dimension(odm,rflgdm) :: mer_regflg=-1 integer, save, dimension(odm) :: mer_nflg real, save, dimension(odm) :: mer_minlat=-90.,mer_maxlat=90. - integer, save :: mer_nreg,lmax + integer, save :: mer_nreg,lmax real, save, dimension(ldm) :: mtlat - real, save, dimension(kdm) :: sigmar1 + real, save, dimension(kdm) :: sigmar1 real, save, allocatable, dimension(:,:,:) :: . mmflxl,mmftdl,mmflxd,mmftdd real, save, allocatable, dimension(:,:) :: . mhflx,mhftd,mhfld,msflx,msftd,msfld c -c --- Section transports +c --- Section transports character(len=256), save :: sec_sifile integer, save :: sec_num integer, parameter :: max_sec=400 @@ -172,7 +173,7 @@ module mod_dia c --- thickness estimation (Levitus, 1982) real, parameter :: dbcrit=.03 c -c --- Namelist +c --- Namelist integer, dimension(nphymax), save :: . H2D_ABSWND ,H2D_ALB ,H2D_BTMSTR ,H2D_BRNFLX ,H2D_BRNPD , . H2D_DFL ,H2D_EVA ,H2D_FICE ,H2D_FMLTFZ ,H2D_HICE , @@ -187,20 +188,21 @@ module mod_dia . H2D_SURRLX ,H2D_SWA ,H2D_T20D ,H2D_TAUX ,H2D_TAUY , . H2D_TBOT ,H2D_TICE ,H2D_TSRF ,H2D_UB ,H2D_UICE , . H2D_USTAR ,H2D_USTAR3 ,H2D_VB ,H2D_VICE ,H2D_ZTX , - . LYR_BFSQ ,LYR_DIFDIA ,LYR_DIFINT ,LYR_DIFISO ,LYR_DP , - . LYR_DPU ,LYR_DPV ,LYR_DZ ,LYR_SALN ,LYR_TEMP , - . LYR_TRC ,LYR_UFLX ,LYR_UTFLX ,LYR_USFLX ,LYR_UMFLTD , - . LYR_UTFLTD ,LYR_UTFLLD ,LYR_USFLTD ,LYR_USFLLD ,LYR_UVEL , - . LYR_VFLX ,LYR_VTFLX ,LYR_VSFLX ,LYR_VMFLTD ,LYR_VTFLTD , - . LYR_VTFLLD ,LYR_VSFLTD ,LYR_VSFLLD ,LYR_VVEL ,LYR_WFLX , - . LYR_WFLX2 ,LYR_PV ,LYR_TKE ,LYR_GLS_PSI,LYR_IDLAGE , - . LVL_BFSQ ,LVL_DIFDIA ,LVL_DIFINT ,LVL_DIFISO ,LVL_DZ , - . LVL_SALN ,LVL_TEMP ,LVL_TRC ,LVL_UFLX ,LVL_UTFLX , - . LVL_USFLX ,LVL_UMFLTD ,LVL_UTFLTD ,LVL_UTFLLD ,LVL_USFLTD , - . LVL_USFLLD ,LVL_UVEL ,LVL_VFLX ,LVL_VTFLX ,LVL_VSFLX , - . LVL_VMFLTD ,LVL_VTFLTD ,LVL_VTFLLD ,LVL_VSFLTD ,LVL_VSFLLD , - . LVL_VVEL ,LVL_WFLX ,LVL_WFLX2 ,LVL_PV ,LVL_TKE , - . LVL_GLS_PSI,LVL_IDLAGE , + . LYR_BFSQ ,LYR_DIFDIA ,LYR_DIFVMO ,LYR_DIFVHO ,LYR_DIFVSO , + . LYR_DIFINT ,LYR_DIFISO ,LYR_DP ,LYR_DPU ,LYR_DPV , + . LYR_DZ ,LYR_SALN ,LYR_TEMP ,LYR_TRC ,LYR_UFLX , + . LYR_UTFLX ,LYR_USFLX ,LYR_UMFLTD ,LYR_UTFLTD ,LYR_UTFLLD , + . LYR_USFLTD ,LYR_USFLLD ,LYR_UVEL ,LYR_VFLX ,LYR_VTFLX , + . LYR_VSFLX ,LYR_VMFLTD ,LYR_VTFLTD ,LYR_VTFLLD ,LYR_VSFLTD , + . LYR_VSFLLD ,LYR_VVEL ,LYR_WFLX ,LYR_WFLX2 ,LYR_PV , + . LYR_TKE ,LYR_GLS_PSI,LYR_IDLAGE , + . LVL_BFSQ ,LVL_DIFDIA ,LVL_DIFVMO ,LVL_DIFVHO ,LVL_DIFVSO , + . LVL_DIFINT ,LVL_DIFISO ,LVL_DZ ,LVL_SALN ,LVL_TEMP , + . LVL_TRC ,LVL_UFLX ,LVL_UTFLX ,LVL_USFLX ,LVL_UMFLTD , + . LVL_UTFLTD ,LVL_UTFLLD ,LVL_USFLTD ,LVL_USFLLD ,LVL_UVEL , + . LVL_VFLX ,LVL_VTFLX ,LVL_VSFLX ,LVL_VMFLTD ,LVL_VTFLTD , + . LVL_VTFLLD ,LVL_VSFLTD ,LVL_VSFLLD ,LVL_VVEL ,LVL_WFLX , + . LVL_WFLX2 ,LVL_PV ,LVL_TKE ,LVL_GLS_PSI,LVL_IDLAGE , . MSC_MMFLXL ,MSC_MMFLXD ,MSC_MMFTDL ,MSC_MMFTDD ,MSC_MHFLX , . MSC_MHFTD ,MSC_MHFLD ,MSC_MSFLX ,MSC_MSFTD ,MSC_MSFLD , . MSC_VOLTR ,MSC_MASSGS ,MSC_VOLGS ,MSC_SALNGA ,MSC_TEMPGA , @@ -222,24 +224,25 @@ module mod_dia . ACC_TICE ,ACC_TSRF ,ACC_UB ,ACC_UBFLXS ,ACC_UICE , . ACC_USTAR ,ACC_USTAR3 ,ACC_VB ,ACC_VBFLXS ,ACC_VICE , . ACC_ZTX ,ACC_IVOLU ,ACC_IVOLV ,ACC_UTILH2D, - . ACC_BFSQ ,ACC_DIFDIA ,ACC_DIFINT ,ACC_DIFISO ,ACC_DP , - . ACC_DPU ,ACC_DPV ,ACC_DZ ,ACC_SALN ,ACC_TEMP , - . ACC_UFLX ,ACC_UTFLX ,ACC_USFLX ,ACC_UMFLTD ,ACC_UTFLTD , - . ACC_UTFLLD ,ACC_USFLTD ,ACC_USFLLD ,ACC_UVEL ,ACC_VFLX , - . ACC_VTFLX ,ACC_VSFLX ,ACC_VMFLTD ,ACC_VTFLTD ,ACC_VTFLLD , - . ACC_VSFLTD ,ACC_VSFLLD ,ACC_VVEL ,ACC_WFLX ,ACC_WFLX2 , - . ACC_AVDSG ,ACC_DPVOR ,ACC_TKE ,ACC_GLS_PSI,ACC_UTILLYR, - . ACC_BFSQLVL ,ACC_DIFDIALVL ,ACC_DIFINTLVL,ACC_DIFISOLVL, - . ACC_DZLVL ,ACC_SALNLVL ,ACC_TEMPLVL ,ACC_UFLXLVL , - . ACC_UTFLXLVL ,ACC_USFLXLVL ,ACC_UMFLTDLVL,ACC_UTFLTDLVL, - . ACC_UTFLLDLVL,ACC_USFLTDLVL ,ACC_USFLLDLVL,ACC_UVELLVL , - . ACC_VFLXLVL ,ACC_VTFLXLVL ,ACC_VSFLXLVL ,ACC_VMFLTDLVL, - . ACC_VTFLTDLVL,ACC_VTFLLDLVL ,ACC_VSFLTDLVL,ACC_VSFLLDLVL, - . ACC_VVELLVL ,ACC_WFLXLVL ,ACC_WFLX2LVL ,ACC_PVLVL , - . ACC_TKELVL ,ACC_GLS_PSILVL,ACC_UFLXOLD ,ACC_VFLXOLD , - . ACC_UTILLVL , + . ACC_BFSQ ,ACC_DIFDIA ,ACC_DIFVMO ,ACC_DIFVHO ,ACC_DIFVSO , + . ACC_DIFINT ,ACC_DIFISO ,ACC_DP ,ACC_DPU ,ACC_DPV , + . ACC_DZ ,ACC_SALN ,ACC_TEMP ,ACC_UFLX ,ACC_UTFLX , + . ACC_USFLX ,ACC_UMFLTD ,ACC_UTFLTD ,ACC_UTFLLD ,ACC_USFLTD , + . ACC_USFLLD ,ACC_UVEL ,ACC_VFLX ,ACC_VTFLX ,ACC_VSFLX , + . ACC_VMFLTD ,ACC_VTFLTD ,ACC_VTFLLD ,ACC_VSFLTD ,ACC_VSFLLD , + . ACC_VVEL ,ACC_WFLX ,ACC_WFLX2 ,ACC_AVDSG ,ACC_DPVOR , + . ACC_TKE ,ACC_GLS_PSI,ACC_UTILLYR, + . ACC_BFSQLVL ,ACC_DIFDIALVL ,ACC_DIFVMOLVL,ACC_DIFVHOLVL, + . ACC_DIFVSOLVL ,ACC_DIFINTLVL,ACC_DIFISOLVL,ACC_DZLVL , + . ACC_SALNLVL ,ACC_TEMPLVL ,ACC_UFLXLVL ,ACC_UTFLXLVL , + . ACC_USFLXLVL ,ACC_UMFLTDLVL,ACC_UTFLTDLVL,ACC_UTFLLDLVL, + . ACC_USFLTDLVL ,ACC_USFLLDLVL,ACC_UVELLVL ,ACC_VFLXLVL , + . ACC_VTFLXLVL ,ACC_VSFLXLVL ,ACC_VMFLTDLVL,ACC_VTFLTDLVL, + . ACC_VTFLLDLVL ,ACC_VSFLTDLVL,ACC_VSFLLDLVL,ACC_VVELLVL , + . ACC_WFLXLVL ,ACC_WFLX2LVL ,ACC_PVLVL ,ACC_TKELVL , + . ACC_GLS_PSILVL,ACC_UFLXOLD ,ACC_VFLXOLD ,ACC_UTILLVL , . ACC_MMFLXL,ACC_MMFLXD,ACC_MMFTDL,ACC_MMFTDD,ACC_MHFLX,ACC_MHFTD, - . ACC_MHFLD ,ACC_MSFLX ,ACC_MSFTD ,ACC_MSFLD ,ACC_VOLTR + . ACC_MHFLD ,ACC_MSFLX ,ACC_MSFTD ,ACC_MSFLD ,ACC_VOLTR namelist /MERDIA/ . MER_ORFILE,MER_MIFILE,MER_REGNAM,MER_REGFLG,MER_MINLAT,MER_MAXLAT namelist /SECDIA/ @@ -258,30 +261,31 @@ module mod_dia . H2D_SURRLX ,H2D_SWA ,H2d_T20D ,H2D_TAUX ,H2D_TAUY , . H2D_TBOT ,H2D_TICE ,H2D_TSRF ,H2D_UB ,H2D_UICE , . H2D_USTAR ,H2D_USTAR3 ,H2D_VB ,H2D_VICE ,H2D_ZTX , - . LYR_BFSQ ,LYR_DIFDIA ,LYR_DIFINT ,LYR_DIFISO ,LYR_DP , - . LYR_DPU ,LYR_DPV ,LYR_DZ ,LYR_SALN ,LYR_TEMP , - . LYR_TRC ,LYR_UFLX ,LYR_UTFLX ,LYR_USFLX ,LYR_UMFLTD , - . LYR_UTFLTD ,LYR_UTFLLD ,LYR_USFLTD ,LYR_USFLLD ,LYR_UVEL , - . LYR_VFLX ,LYR_VTFLX ,LYR_VSFLX ,LYR_VMFLTD ,LYR_VTFLTD , - . LYR_VTFLLD ,LYR_VSFLTD ,LYR_VSFLLD ,LYR_VVEL ,LYR_WFLX , - . LYR_WFLX2 ,LYR_PV ,LYR_TKE ,LYR_GLS_PSI,LYR_IDLAGE , - . LVL_BFSQ ,LVL_DIFDIA ,LVL_DIFINT ,LVL_DIFISO ,LVL_DZ , - . LVL_SALN ,LVL_TEMP ,LVL_TRC ,LVL_UFLX ,LVL_UTFLX , - . LVL_USFLX ,LVL_UMFLTD ,LVL_UTFLTD ,LVL_UTFLLD ,LVL_USFLTD , - . LVL_USFLLD ,LVL_UVEL ,LVL_VFLX ,LVL_VTFLX ,LVL_VSFLX , - . LVL_VMFLTD ,LVL_VTFLTD ,LVL_VTFLLD ,LVL_VSFLTD ,LVL_VSFLLD , - . LVL_VVEL ,LVL_WFLX ,LVL_WFLX2 ,LVL_PV ,LVL_TKE , - . LVL_GLS_PSI,LVL_IDLAGE , + . LYR_BFSQ ,LYR_DIFDIA ,LYR_DIFVMO ,LYR_DIFVHO ,LYR_DIFVSO , + . LYR_DIFINT ,LYR_DIFISO ,LYR_DP ,LYR_DPU ,LYR_DPV , + . LYR_DZ ,LYR_SALN ,LYR_TEMP ,LYR_TRC ,LYR_UFLX , + . LYR_UTFLX ,LYR_USFLX ,LYR_UMFLTD ,LYR_UTFLTD ,LYR_UTFLLD , + . LYR_USFLTD ,LYR_USFLLD ,LYR_UVEL ,LYR_VFLX ,LYR_VTFLX , + . LYR_VSFLX ,LYR_VMFLTD ,LYR_VTFLTD ,LYR_VTFLLD ,LYR_VSFLTD , + . LYR_VSFLLD ,LYR_VVEL ,LYR_WFLX ,LYR_WFLX2 ,LYR_PV , + . LYR_TKE ,LYR_GLS_PSI,LYR_IDLAGE , + . LVL_BFSQ ,LVL_DIFDIA ,LVL_DIFVMO ,LVL_DIFVHO ,LVL_DIFVSO , + . LVL_DIFINT ,LVL_DIFISO ,LVL_DZ ,LVL_SALN ,LVL_TEMP , + . LVL_TRC ,LVL_UFLX ,LVL_UTFLX ,LVL_USFLX ,LVL_UMFLTD , + . LVL_UTFLTD ,LVL_UTFLLD ,LVL_USFLTD ,LVL_USFLLD ,LVL_UVEL , + . LVL_VFLX ,LVL_VTFLX ,LVL_VSFLX ,LVL_VMFLTD ,LVL_VTFLTD , + . LVL_VTFLLD ,LVL_VSFLTD ,LVL_VSFLLD ,LVL_VVEL ,LVL_WFLX , + . LVL_WFLX2 ,LVL_PV ,LVL_TKE ,LVL_GLS_PSI,LVL_IDLAGE , . MSC_MMFLXL ,MSC_MMFLXD ,MSC_MMFTDL ,MSC_MMFTDD ,MSC_MHFLX , . MSC_MHFTD ,MSC_MHFLD ,MSC_MSFLX ,MSC_MSFTD ,MSC_MSFLD , . MSC_VOLTR ,MSC_MASSGS ,MSC_VOLGS ,MSC_SALNGA ,MSC_TEMPGA , . MSC_SSSGA ,MSC_SSTGA , - . GLB_AVEPERIO,GLB_FILEFREQ,GLB_COMPFLAG,GLB_NCFORMAT, + . GLB_AVEPERIO,GLB_FILEFREQ,GLB_COMPFLAG,GLB_NCFORMAT, . GLB_FNAMETAG - contains + contains @@ -289,13 +293,13 @@ subroutine diafnm(ctag,diagfq,diagmon,diagann,fname) c c --- ------------------------------------------------------------------ c --- Description: creates file name for the diagnostic output -c --- -c --- Arguments: -c --- char ctag (in) : string used in middle of file name -c --- real diagfq (in) : diagnostic frequency -c --- logi diagmon (in) : switch to show whether diagfq=month -c --- logi diagann (in) : switch to show whether diagfq=year -c --- char fname (out) : file name +c --- +c --- Arguments: +c --- char ctag (in) : string used in middle of file name +c --- real diagfq (in) : diagnostic frequency +c --- logi diagmon (in) : switch to show whether diagfq=month +c --- logi diagann (in) : switch to show whether diagfq=year +c --- char fname (out) : file name c --- ------------------------------------------ c implicit none @@ -381,7 +385,7 @@ subroutine diaini logical fexist c c --- Check existence of data files for meridional and section transport -c --- diagnostics +c --- diagnostics if (mnproc.eq.1) then if (sum(MSC_MMFLXL(1:nphy)+MSC_MMFLXD(1:nphy)+MSC_MMFTDL(1:nphy) . +MSC_MMFTDD(1:nphy)+MSC_MHFLX(1:nphy)+MSC_MHFTD(1:nphy) @@ -421,7 +425,7 @@ subroutine diaini do n=1,nphy nacc_phy(n)=0 c -c --- - Solve dependencies for diagnostic variables (0=skipped) +c --- - Solve dependencies for diagnostic variables (0=skipped) ACC_ABSWND(n) = H2D_ABSWND(n) ACC_ALB(n) = H2D_ALB(n) ACC_BRNFLX(n) = H2D_BRNFLX(n) @@ -429,8 +433,8 @@ subroutine diaini ACC_DFL(n) = H2D_DFL(n) ACC_EVA(n) = H2D_EVA(n) ACC_FMLTFZ(n) = H2D_FMLTFZ(n) - ACC_FICE(n) = H2D_FICE(n) + H2D_HICE(n) + H2D_UICE(n) + - . H2D_VICE(n) + H2D_HSNW(n) + ACC_FICE(n) = H2D_FICE(n) + H2D_HICE(n) + H2D_UICE(n) + . + H2D_VICE(n) + H2D_HSNW(n) ACC_HICE(n) = H2D_HICE(n) + H2D_UICE(n) + H2D_VICE(n) ACC_HMLTFZ(n) = H2D_HMLTFZ(n) ACC_HSNW(n) = H2D_HSNW(n) @@ -495,18 +499,25 @@ subroutine diaini ACC_BFSQLVL(n) = LVL_BFSQ(n) ACC_DIFDIA(n) = LYR_DIFDIA(n) ACC_DIFDIALVL(n)= LVL_DIFDIA(n) + ACC_DIFVMO(n) = LYR_DIFVMO(n) + ACC_DIFVMOLVL(n)= LVL_DIFVMO(n) + ACC_DIFVHO(n) = LYR_DIFVHO(n) + ACC_DIFVHOLVL(n)= LVL_DIFVHO(n) + ACC_DIFVSO(n) = LYR_DIFVSO(n) + ACC_DIFVSOLVL(n)= LVL_DIFVSO(n) ACC_DIFINT(n) = LYR_DIFINT(n) ACC_DIFINTLVL(n)= LVL_DIFINT(n) ACC_DIFISO(n) = LYR_DIFISO(n) ACC_DIFISOLVL(n)= LVL_DIFISO(n) - ACC_DP(n) = LYR_DP(n) + LYR_BFSQ(n) + - . LYR_SALN(n) + LYR_TEMP(n) + - . LYR_DIFDIA(n) + LYR_DIFINT(n) + LYR_DIFISO(n)+ - . LYR_TKE(n) + LYR_GLS_PSI(n)+ - . LVL_BFSQ(n) + LVL_SALN(n) + LVL_TEMP(n) + - . LVL_DIFDIA(n) + LVL_DIFINT(n) + LVL_DIFISO(n)+ - . LVL_TKE(n) + LVL_GLS_PSI(n)+ - . MSC_MASSGS(n) + MSC_SALNGA(n) + MSC_TEMPGA(n) + ACC_DP(n) = LYR_DP(n) + LYR_BFSQ(n) + LYR_SALN(n) + . + LYR_TEMP(n) + LYR_DIFDIA(n) + LYR_DIFVMO(n) + . + LYR_DIFVHO(n) + LYR_DIFVSO(n) + LYR_DIFINT(n) + . + LYR_DIFISO(n) + LYR_TKE(n) + LYR_GLS_PSI(n) + . + LVL_BFSQ(n) + LVL_SALN(n) + LVL_TEMP(n) + . + LVL_DIFDIA(n) + LVL_DIFVMO(n) + LVL_DIFVHO(n) + . + LVL_DIFVSO(n) + LVL_DIFINT(n) + LVL_DIFISO(n) + . + LVL_TKE(n) + LVL_GLS_PSI(n) + . + MSC_MASSGS(n) + MSC_SALNGA(n) + MSC_TEMPGA(n) ACC_DPU(n) = LYR_DPU(n) + LYR_UVEL(n) ACC_DPV(n) = LYR_DPV(n) + LYR_VVEL(n) ACC_DZ(n) = LYR_DZ(n) + MSC_VOLGS(n) @@ -515,10 +526,10 @@ subroutine diaini ACC_SALNLVL(n) = LVL_SALN(n) ACC_TEMP(n) = LYR_TEMP(n) + MSC_TEMPGA(n) ACC_TEMPLVL(n) = LVL_TEMP(n) - ACC_UFLX(n) = LYR_UFLX(n) + MSC_MMFLXL(n) + LYR_WFLX(n) + - . LYR_WFLX2(n) - ACC_UFLXLVL(n) = LVL_UFLX(n) + MSC_MMFLXD(n) + MSC_VOLTR(n) + - . LVL_WFLX(n) + LVL_WFLX2(n) + ACC_UFLX(n) = LYR_UFLX(n) + MSC_MMFLXL(n) + LYR_WFLX(n) + . + LYR_WFLX2(n) + ACC_UFLXLVL(n) = LVL_UFLX(n) + MSC_MMFLXD(n) + MSC_VOLTR(n) + . + LVL_WFLX(n) + LVL_WFLX2(n) ACC_UFLXOLD(n) = LVL_WFLX(n) + LVL_WFLX2(n) ACC_UTFLX(n) = LYR_UTFLX(n) + MSC_MHFLX(n) ACC_UTFLXLVL(n) = LVL_UTFLX(n) @@ -536,10 +547,10 @@ subroutine diaini ACC_USFLLDLVL(n)= LVL_USFLLD(n) ACC_UVEL(n) = LYR_UVEL(n) ACC_UVELLVL(n) = LVL_UVEL(n) - ACC_VFLX(n) = LYR_VFLX(n) + MSC_MMFLXL(n) + LYR_WFLX(n) + - . LYR_WFLX2(n) - ACC_VFLXLVL(n) = LVL_VFLX(n) + MSC_MMFLXD(n) + MSC_VOLTR(n) + - . LVL_WFLX(n) + LVL_WFLX2(n) + ACC_VFLX(n) = LYR_VFLX(n) + MSC_MMFLXL(n) + LYR_WFLX(n) + . + LYR_WFLX2(n) + ACC_VFLXLVL(n) = LVL_VFLX(n) + MSC_MMFLXD(n) + MSC_VOLTR(n) + . + LVL_WFLX(n) + LVL_WFLX2(n) ACC_VFLXOLD(n) = LVL_WFLX(n) + LVL_WFLX2(n) ACC_VTFLX(n) = LYR_VTFLX(n) + MSC_MHFLX(n) ACC_VTFLXLVL(n) = LVL_VTFLX(n) @@ -557,14 +568,14 @@ subroutine diaini ACC_VSFLLDLVL(n)= LVL_VSFLLD(n) ACC_VVEL(n) = LYR_VVEL(n) ACC_VVELLVL(n) = LVL_VVEL(n) - ACC_WFLX(n) = LYR_WFLX(n) + LYR_WFLX2(n) + LVL_WFLX(n) + - . LVL_WFLX2(n) - ACC_WFLXLVL(n) = LVL_WFLX(n) + LVL_WFLX2(n) + LYR_WFLX(n) + - . LYR_WFLX2(n) - ACC_WFLX2(n) = LYR_WFLX2(n) + LYR_WFLX(n) + LVL_WFLX(n) + - . LVL_WFLX2(n) - ACC_WFLX2LVL(n) = LVL_WFLX2(n) + LVL_WFLX(n) + LYR_WFLX(n) + - . LYR_WFLX2(n) + ACC_WFLX(n) = LYR_WFLX(n) + LYR_WFLX2(n) + LVL_WFLX(n) + . + LVL_WFLX2(n) + ACC_WFLXLVL(n) = LVL_WFLX(n) + LVL_WFLX2(n) + LYR_WFLX(n) + . + LYR_WFLX2(n) + ACC_WFLX2(n) = LYR_WFLX2(n) + LYR_WFLX(n) + LVL_WFLX(n) + . + LVL_WFLX2(n) + ACC_WFLX2LVL(n) = LVL_WFLX2(n) + LVL_WFLX(n) + LYR_WFLX(n) + . + LYR_WFLX2(n) ACC_AVDSG(n) = LYR_PV(n) ACC_DPVOR(n) = LYR_PV(n) ACC_PVLVL(n) = LVL_PV(n) @@ -572,10 +583,10 @@ subroutine diaini ACC_TKELVL(n) = LVL_TKE(n) ACC_GLS_PSI(n) = LYR_GLS_PSI(n) ACC_GLS_PSILVL(n) = LVL_GLS_PSI(n) - ACC_MMFLXL(n) = MSC_MMFLXL(n) + ACC_MMFLXL(n) = MSC_MMFLXL(n) ACC_MMFLXD(n) = MSC_MMFLXD(n) - ACC_MMFTDL(n) = MSC_MMFTDL(n) - ACC_MMFTDD(n) = MSC_MMFTDD(n) + ACC_MMFTDL(n) = MSC_MMFTDL(n) + ACC_MMFTDD(n) = MSC_MMFTDD(n) ACC_MHFLX(n) = MSC_MHFLX(n) ACC_MHFTD(n) = MSC_MHFTD(n) ACC_MHFLD(n) = MSC_MHFLD(n) @@ -584,45 +595,45 @@ subroutine diaini ACC_MSFLD(n) = MSC_MSFLD(n) ACC_VOLTR(n) = MSC_VOLTR(n) c -c --- - Determine position in buffer - if (ACC_ABSWND(n).ne.0) nphyh2d=nphyh2d+1 +c --- - Determine position in buffer + if (ACC_ABSWND(n).ne.0) nphyh2d=nphyh2d+1 ACC_ABSWND(n)=nphyh2d*min(1,ACC_ABSWND(n)) if (ACC_ALB(n).ne.0) nphyh2d=nphyh2d+1 - ACC_ALB(n)=nphyh2d*min(1,ACC_ALB(n)) - if (ACC_BRNFLX(n).ne.0) nphyh2d=nphyh2d+1 + ACC_ALB(n)=nphyh2d*min(1,ACC_ALB(n)) + if (ACC_BRNFLX(n).ne.0) nphyh2d=nphyh2d+1 ACC_BRNFLX(n)=nphyh2d*min(1,ACC_BRNFLX(n)) if (ACC_BRNPD(n).ne.0) nphyh2d=nphyh2d+1 ACC_BRNPD(n)=nphyh2d*min(1,ACC_BRNPD(n)) if (ACC_DFL(n).ne.0) nphyh2d=nphyh2d+1 - ACC_DFL(n)=nphyh2d*min(1,ACC_DFL(n)) + ACC_DFL(n)=nphyh2d*min(1,ACC_DFL(n)) if (ACC_EVA(n).ne.0) nphyh2d=nphyh2d+1 - ACC_EVA(n)=nphyh2d*min(1,ACC_EVA(n)) - if (ACC_FMLTFZ(n).ne.0) nphyh2d=nphyh2d+1 + ACC_EVA(n)=nphyh2d*min(1,ACC_EVA(n)) + if (ACC_FMLTFZ(n).ne.0) nphyh2d=nphyh2d+1 ACC_FMLTFZ(n)=nphyh2d*min(1,ACC_FMLTFZ(n)) if (ACC_FICE(n).ne.0) nphyh2d=nphyh2d+1 - ACC_FICE(n)=nphyh2d*min(1,ACC_FICE(n)) + ACC_FICE(n)=nphyh2d*min(1,ACC_FICE(n)) if (ACC_HICE(n).ne.0) nphyh2d=nphyh2d+1 - ACC_HICE(n)=nphyh2d*min(1,ACC_HICE(n)) - if (ACC_HMLTFZ(n).ne.0) nphyh2d=nphyh2d+1 + ACC_HICE(n)=nphyh2d*min(1,ACC_HICE(n)) + if (ACC_HMLTFZ(n).ne.0) nphyh2d=nphyh2d+1 ACC_HMLTFZ(n)=nphyh2d*min(1,ACC_HMLTFZ(n)) if (ACC_HSNW(n).ne.0) nphyh2d=nphyh2d+1 - ACC_HSNW(n)=nphyh2d*min(1,ACC_HSNW(n)) + ACC_HSNW(n)=nphyh2d*min(1,ACC_HSNW(n)) if (ACC_IAGE(n).ne.0) nphyh2d=nphyh2d+1 - ACC_IAGE(n)=nphyh2d*min(1,ACC_IAGE(n)) - if (ACC_IDKEDT(n).ne.0) nphyh2d=nphyh2d+1 + ACC_IAGE(n)=nphyh2d*min(1,ACC_IAGE(n)) + if (ACC_IDKEDT(n).ne.0) nphyh2d=nphyh2d+1 ACC_IDKEDT(n)=nphyh2d*min(1,ACC_IDKEDT(n)) - if (ACC_IVOLU(n).ne.0) nphyh2d=nphyh2d+1 + if (ACC_IVOLU(n).ne.0) nphyh2d=nphyh2d+1 ACC_IVOLU(n)=nphyh2d*min(1,ACC_IVOLU(n)) - if (ACC_IVOLV(n).ne.0) nphyh2d=nphyh2d+1 + if (ACC_IVOLV(n).ne.0) nphyh2d=nphyh2d+1 ACC_IVOLV(n)=nphyh2d*min(1,ACC_IVOLV(n)) if (ACC_LIP(n).ne.0) nphyh2d=nphyh2d+1 - ACC_LIP(n)=nphyh2d*min(1,ACC_LIP(n)) - if (ACC_MAXMLD(n).ne.0) nphyh2d=nphyh2d+1 + ACC_LIP(n)=nphyh2d*min(1,ACC_LIP(n)) + if (ACC_MAXMLD(n).ne.0) nphyh2d=nphyh2d+1 ACC_MAXMLD(n)=nphyh2d*min(1,ACC_MAXMLD(n)) if (ACC_MLD(n).ne.0) nphyh2d=nphyh2d+1 - ACC_MLD(n)=nphyh2d*min(1,ACC_MLD(n)) + ACC_MLD(n)=nphyh2d*min(1,ACC_MLD(n)) if (ACC_MLDU(n).ne.0) nphyh2d=nphyh2d+1 - ACC_MLDU(n)=nphyh2d*min(1,ACC_MLDU(n)) + ACC_MLDU(n)=nphyh2d*min(1,ACC_MLDU(n)) if (ACC_MLDV(n).ne.0) nphyh2d=nphyh2d+1 ACC_MLDV(n)=nphyh2d*min(1,ACC_MLDV(n)) if (ACC_MLTS(n).ne.0) nphyh2d=nphyh2d+1 @@ -634,89 +645,89 @@ subroutine diaini if (ACC_MLTSSQ(n).ne.0) nphyh2d=nphyh2d+1 ACC_MLTSSQ(n)=nphyh2d*min(1,ACC_MLTSSQ(n)) if (ACC_MTKEUS(n).ne.0) nphyh2d=nphyh2d+1 - ACC_MTKEUS(n)=nphyh2d*min(1,ACC_MTKEUS(n)) + ACC_MTKEUS(n)=nphyh2d*min(1,ACC_MTKEUS(n)) if (ACC_MTKENI(n).ne.0) nphyh2d=nphyh2d+1 - ACC_MTKENI(n)=nphyh2d*min(1,ACC_MTKENI(n)) + ACC_MTKENI(n)=nphyh2d*min(1,ACC_MTKENI(n)) if (ACC_MTKEBF(n).ne.0) nphyh2d=nphyh2d+1 - ACC_MTKEBF(n)=nphyh2d*min(1,ACC_MTKEBF(n)) + ACC_MTKEBF(n)=nphyh2d*min(1,ACC_MTKEBF(n)) if (ACC_MTKERS(n).ne.0) nphyh2d=nphyh2d+1 - ACC_MTKERS(n)=nphyh2d*min(1,ACC_MTKERS(n)) + ACC_MTKERS(n)=nphyh2d*min(1,ACC_MTKERS(n)) if (ACC_MTKEPE(n).ne.0) nphyh2d=nphyh2d+1 - ACC_MTKEPE(n)=nphyh2d*min(1,ACC_MTKEPE(n)) + ACC_MTKEPE(n)=nphyh2d*min(1,ACC_MTKEPE(n)) if (ACC_MTKEKE(n).ne.0) nphyh2d=nphyh2d+1 - ACC_MTKEKE(n)=nphyh2d*min(1,ACC_MTKEKE(n)) + ACC_MTKEKE(n)=nphyh2d*min(1,ACC_MTKEKE(n)) if (ACC_MTY(n).ne.0) nphyh2d=nphyh2d+1 - ACC_MTY(n)=nphyh2d*min(1,ACC_MTY(n)) + ACC_MTY(n)=nphyh2d*min(1,ACC_MTY(n)) if (ACC_MXLU(n).ne.0) nphyh2d=nphyh2d+1 - ACC_MXLU(n)=nphyh2d*min(1,ACC_MXLU(n)) + ACC_MXLU(n)=nphyh2d*min(1,ACC_MXLU(n)) if (ACC_MXLV(n).ne.0) nphyh2d=nphyh2d+1 ACC_MXLV(n)=nphyh2d*min(1,ACC_MXLV(n)) if (ACC_NSF(n).ne.0) nphyh2d=nphyh2d+1 - ACC_NSF(n)=nphyh2d*min(1,ACC_NSF(n)) + ACC_NSF(n)=nphyh2d*min(1,ACC_NSF(n)) if (ACC_PBOT(n).ne.0) nphyh2d=nphyh2d+1 - ACC_PBOT(n)=nphyh2d*min(1,ACC_PBOT(n)) + ACC_PBOT(n)=nphyh2d*min(1,ACC_PBOT(n)) if (ACC_PSRF(n).ne.0) nphyh2d=nphyh2d+1 - ACC_PSRF(n)=nphyh2d*min(1,ACC_PSRF(n)) - if (ACC_RFIFLX(n).ne.0) nphyh2d=nphyh2d+1 + ACC_PSRF(n)=nphyh2d*min(1,ACC_PSRF(n)) + if (ACC_RFIFLX(n).ne.0) nphyh2d=nphyh2d+1 ACC_RFIFLX(n)=nphyh2d*min(1,ACC_RFIFLX(n)) - if (ACC_RNFFLX(n).ne.0) nphyh2d=nphyh2d+1 + if (ACC_RNFFLX(n).ne.0) nphyh2d=nphyh2d+1 ACC_RNFFLX(n)=nphyh2d*min(1,ACC_RNFFLX(n)) - if (ACC_SURFLX(n).ne.0) nphyh2d=nphyh2d+1 + if (ACC_SURFLX(n).ne.0) nphyh2d=nphyh2d+1 ACC_SURFLX(n)=nphyh2d*min(1,ACC_SURFLX(n)) - if (ACC_SURRLX(n).ne.0) nphyh2d=nphyh2d+1 + if (ACC_SURRLX(n).ne.0) nphyh2d=nphyh2d+1 ACC_SURRLX(n)=nphyh2d*min(1,ACC_SURRLX(n)) - if (ACC_SALFLX(n).ne.0) nphyh2d=nphyh2d+1 + if (ACC_SALFLX(n).ne.0) nphyh2d=nphyh2d+1 ACC_SALFLX(n)=nphyh2d*min(1,ACC_SALFLX(n)) - if (ACC_SALRLX(n).ne.0) nphyh2d=nphyh2d+1 + if (ACC_SALRLX(n).ne.0) nphyh2d=nphyh2d+1 ACC_SALRLX(n)=nphyh2d*min(1,ACC_SALRLX(n)) - if (ACC_SBOT(n).ne.0) nphyh2d=nphyh2d+1 + if (ACC_SBOT(n).ne.0) nphyh2d=nphyh2d+1 ACC_SBOT(n)=nphyh2d*min(1,ACC_SBOT(n)) - if (ACC_SEALV(n).ne.0) nphyh2d=nphyh2d+1 + if (ACC_SEALV(n).ne.0) nphyh2d=nphyh2d+1 ACC_SEALV(n)=nphyh2d*min(1,ACC_SEALV(n)) - if (ACC_SLVSQ(n).ne.0) nphyh2d=nphyh2d+1 + if (ACC_SLVSQ(n).ne.0) nphyh2d=nphyh2d+1 ACC_SLVSQ(n)=nphyh2d*min(1,ACC_SLVSQ(n)) if (ACC_SFL(n).ne.0) nphyh2d=nphyh2d+1 - ACC_SFL(n)=nphyh2d*min(1,ACC_SFL(n)) - if (ACC_SIGMX(n).ne.0) nphyh2d=nphyh2d+1 + ACC_SFL(n)=nphyh2d*min(1,ACC_SFL(n)) + if (ACC_SIGMX(n).ne.0) nphyh2d=nphyh2d+1 ACC_SIGMX(n)=nphyh2d*min(1,ACC_SIGMX(n)) if (ACC_SOP(n).ne.0) nphyh2d=nphyh2d+1 - ACC_SOP(n)=nphyh2d*min(1,ACC_SOP(n)) + ACC_SOP(n)=nphyh2d*min(1,ACC_SOP(n)) if (ACC_SSS(n).ne.0) nphyh2d=nphyh2d+1 - ACC_SSS(n)=nphyh2d*min(1,ACC_SSS(n)) + ACC_SSS(n)=nphyh2d*min(1,ACC_SSS(n)) if (ACC_SSSSQ(n).ne.0) nphyh2d=nphyh2d+1 - ACC_SSSSQ(n)=nphyh2d*min(1,ACC_SSSSQ(n)) + ACC_SSSSQ(n)=nphyh2d*min(1,ACC_SSSSQ(n)) if (ACC_SST(n).ne.0) nphyh2d=nphyh2d+1 - ACC_SST(n)=nphyh2d*min(1,ACC_SST(n)) + ACC_SST(n)=nphyh2d*min(1,ACC_SST(n)) if (ACC_SSTSQ(n).ne.0) nphyh2d=nphyh2d+1 - ACC_SSTSQ(n)=nphyh2d*min(1,ACC_SSTSQ(n)) + ACC_SSTSQ(n)=nphyh2d*min(1,ACC_SSTSQ(n)) if (ACC_SWA(n).ne.0) nphyh2d=nphyh2d+1 - ACC_SWA(n)=nphyh2d*min(1,ACC_SWA(n)) + ACC_SWA(n)=nphyh2d*min(1,ACC_SWA(n)) if (ACC_T20D(n).ne.0) nphyh2d=nphyh2d+1 - ACC_T20D(n)=nphyh2d*min(1,ACC_T20D(n)) + ACC_T20D(n)=nphyh2d*min(1,ACC_T20D(n)) if (ACC_TAUX(n).ne.0) nphyh2d=nphyh2d+1 - ACC_TAUX(n)=nphyh2d*min(1,ACC_TAUX(n)) + ACC_TAUX(n)=nphyh2d*min(1,ACC_TAUX(n)) if (ACC_TAUY(n).ne.0) nphyh2d=nphyh2d+1 - ACC_TAUY(n)=nphyh2d*min(1,ACC_TAUY(n)) - if (ACC_TBOT(n).ne.0) nphyh2d=nphyh2d+1 + ACC_TAUY(n)=nphyh2d*min(1,ACC_TAUY(n)) + if (ACC_TBOT(n).ne.0) nphyh2d=nphyh2d+1 ACC_TBOT(n)=nphyh2d*min(1,ACC_TBOT(n)) if (ACC_TICE(n).ne.0) nphyh2d=nphyh2d+1 - ACC_TICE(n)=nphyh2d*min(1,ACC_TICE(n)) + ACC_TICE(n)=nphyh2d*min(1,ACC_TICE(n)) if (ACC_TSRF(n).ne.0) nphyh2d=nphyh2d+1 ACC_TSRF(n)=nphyh2d*min(1,ACC_TSRF(n)) if (ACC_UB(n).ne.0) nphyh2d=nphyh2d+1 - ACC_UB(n)=nphyh2d*min(1,ACC_UB(n)) + ACC_UB(n)=nphyh2d*min(1,ACC_UB(n)) if (ACC_UBFLXS(n).ne.0) nphyh2d=nphyh2d+1 - ACC_UBFLXS(n)=nphyh2d*min(1,ACC_UBFLXS(n)) + ACC_UBFLXS(n)=nphyh2d*min(1,ACC_UBFLXS(n)) if (ACC_UICE(n).ne.0) nphyh2d=nphyh2d+1 - ACC_UICE(n)=nphyh2d*min(1,ACC_UICE(n)) - if (ACC_USTAR(n).ne.0) nphyh2d=nphyh2d+1 + ACC_UICE(n)=nphyh2d*min(1,ACC_UICE(n)) + if (ACC_USTAR(n).ne.0) nphyh2d=nphyh2d+1 ACC_USTAR(n)=nphyh2d*min(1,ACC_USTAR(n)) - if (ACC_USTAR3(n).ne.0) nphyh2d=nphyh2d+1 + if (ACC_USTAR3(n).ne.0) nphyh2d=nphyh2d+1 ACC_USTAR3(n)=nphyh2d*min(1,ACC_USTAR3(n)) if (ACC_VB(n).ne.0) nphyh2d=nphyh2d+1 - ACC_VB(n)=nphyh2d*min(1,ACC_VB(n)) + ACC_VB(n)=nphyh2d*min(1,ACC_VB(n)) if (ACC_VBFLXS(n).ne.0) nphyh2d=nphyh2d+1 - ACC_VBFLXS(n)=nphyh2d*min(1,ACC_VBFLXS(n)) + ACC_VBFLXS(n)=nphyh2d*min(1,ACC_VBFLXS(n)) if (ACC_VICE(n).ne.0) nphyh2d=nphyh2d+1 ACC_VICE(n)=nphyh2d*min(1,ACC_VICE(n)) if (ACC_ZTX(n).ne.0) nphyh2d=nphyh2d+1 @@ -726,6 +737,12 @@ subroutine diaini ACC_BFSQ(n)=nphylyr*min(1,ACC_BFSQ(n)) if (ACC_DIFDIA(n).ne.0) nphylyr=nphylyr+1 ACC_DIFDIA(n)=nphylyr*min(1,ACC_DIFDIA(n)) + if (ACC_DIFVMO(n).ne.0) nphylyr=nphylyr+1 + ACC_DIFVMO(n)=nphylyr*min(1,ACC_DIFVMO(n)) + if (ACC_DIFVHO(n).ne.0) nphylyr=nphylyr+1 + ACC_DIFVHO(n)=nphylyr*min(1,ACC_DIFVHO(n)) + if (ACC_DIFVSO(n).ne.0) nphylyr=nphylyr+1 + ACC_DIFVSO(n)=nphylyr*min(1,ACC_DIFVSO(n)) if (ACC_DIFINT(n).ne.0) nphylyr=nphylyr+1 ACC_DIFINT(n)=nphylyr*min(1,ACC_DIFINT(n)) if (ACC_DIFISO(n).ne.0) nphylyr=nphylyr+1 @@ -795,6 +812,12 @@ subroutine diaini ACC_BFSQLVL(n)=nphylvl*min(1,ACC_BFSQLVL(n)) if (ACC_DIFDIALVL(n).ne.0) nphylvl=nphylvl+1 ACC_DIFDIALVL(n)=nphylvl*min(1,ACC_DIFDIALVL(n)) + if (ACC_DIFVMOLVL(n).ne.0) nphylvl=nphylvl+1 + ACC_DIFVMOLVL(n)=nphylvl*min(1,ACC_DIFVMOLVL(n)) + if (ACC_DIFVHOLVL(n).ne.0) nphylvl=nphylvl+1 + ACC_DIFVHOLVL(n)=nphylvl*min(1,ACC_DIFVHOLVL(n)) + if (ACC_DIFVSOLVL(n).ne.0) nphylvl=nphylvl+1 + ACC_DIFVSOLVL(n)=nphylvl*min(1,ACC_DIFVSOLVL(n)) if (ACC_DIFINTLVL(n).ne.0) nphylvl=nphylvl+1 ACC_DIFINTLVL(n)=nphylvl*min(1,ACC_DIFINTLVL(n)) if (ACC_DIFISOLVL(n).ne.0) nphylvl=nphylvl+1 @@ -858,20 +881,20 @@ subroutine diaini c c --- End loop over io groups enddo -c +c c --- Assign buffer positions for utility fields - ACC_UTILH2D=0 + ACC_UTILH2D=0 nphyh2d=nphyh2d+1 - ACC_UTILH2D(1)=nphyh2d + ACC_UTILH2D(1)=nphyh2d c - ACC_UTILLYR=0 + ACC_UTILLYR=0 nphylyr=nphylyr+1 - ACC_UTILLYR(1)=nphylyr + ACC_UTILLYR(1)=nphylyr c - ACC_UTILLVL=0 + ACC_UTILLVL=0 nphylvl=nphylvl+1 - ACC_UTILLVL(1)=nphylvl -c + ACC_UTILLVL(1)=nphylvl +c c --- Allocate buffers istatsum=0 istat=0 @@ -895,10 +918,10 @@ subroutine diaini call inifld(n) enddo c -c --- Load bathymetry into module mod_dia (used for vertical +c --- Load bathymetry into module mod_dia (used for vertical c --- interpolation in BLOM and HAMOCC) nstepinday=nstep_in_day -c$OMP PARALLEL DO PRIVATE(l,i) +c$OMP PARALLEL DO PRIVATE(l,i) do j=1,jj+1 do l=1,isp(j) do i=max(1,ifp(j,l)),min(ii,ilp(j,l)) @@ -948,7 +971,7 @@ subroutine diasg1 do i=1,itdm if (tmp2d(i,j).gt.0.) then i1=i - j1=j + j1=j lsigmar1=.true. exit endif @@ -963,7 +986,7 @@ subroutine diasg1 sigmar1(k)=sigmar1(k)*1.e3 ! Convert units from g cm-3 to kg m-3 enddo if (mnproc.eq.1) then - write(lp,*) 'sigma layers=',sigmar1 + write(lp,*) 'sigma layers=',sigmar1 endif c end subroutine diasg1 @@ -985,22 +1008,22 @@ subroutine diaacc(m,n,mm,nn,k1m,k1n) integer i,j,k,l,km,kup,iogrp integer, dimension(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy) :: ind1,ind2, . ipsw,ipse,ipnw,ipne -c +c real, dimension(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy,ddm) :: wghts, . wghtsflx real, dimension(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy,kdm+1) :: z real, dimension(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy,kdm) :: uvel,vvel, . dz,avdsg_p,dpvor_p,pv_p,dummy - real, dimension(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy) :: + real, dimension(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy) :: . dpml,sbot,tbot,dps,mlts,t20d real dsig,q,zup,zlo,plo,dbup,dblo,tup,tlo c -c --- Increase counter +c --- Increase counter do iogrp=1,nphy nacc_phy(iogrp)=nacc_phy(iogrp)+1 enddo c -c --- Define auxillary variables +c --- Define auxillary variables c if (sum(ACC_UICE(1:nphy)+ACC_VICE(1:nphy)).ne.0) then call xctilr(hicem, 1,1, 1,1, halo_ps) @@ -1243,7 +1266,7 @@ subroutine diaacc(m,n,mm,nn,k1m,k1n) do i=max(1,ifp(j,l)),min(ii,ilp(j,l)) k=1 km=k+mm - do + do if (dp(i,j,km).gt.onecm) then if (temp(i,j,km).gt.20.) then kup=k @@ -1338,11 +1361,11 @@ subroutine diaacc(m,n,mm,nn,k1m,k1n) c c --- fractional ice cover call acch2d(ACC_FICE,ficem,dummy,0,'p') -c -c --- ice volume in u-points[m] +c +c --- ice volume in u-points[m] call acch2d(ACC_IVOLU,util1,dummy,0,'u') -c -c --- ice volume in v-points[m] +c +c --- ice volume in v-points[m] call acch2d(ACC_IVOLV,util3,dummy,0,'v') c c --- surface temperature [K] @@ -1572,9 +1595,18 @@ subroutine diaacc(m,n,mm,nn,k1m,k1n) c --- isopycnal diffusivity [cm^2/s] call acclyr(ACC_DIFISO,difiso,dp(1-nbdy,1-nbdy,k1m),1,'p') c -c --- diapycnal diffusivity [cm^2/s] +c --- vertical diffusivity (vcoord_type_tag == isopyc_bulkml) [cm^2/s] call acclyr(ACC_DIFDIA,difdia,dp(1-nbdy,1-nbdy,k1m),1,'p') c +c --- vertical momentum diffusivity (vcoord_type_tag == cntiso_hybrid) [cm^2/s] + call accily(ACC_DIFVMO,Kvisc_m,dp(1-nbdy,1-nbdy,k1m),1,'p') +c +c --- vertical heat diffusivity (vcoord_type_tag == cntiso_hybrid) [cm^2/s] + call accily(ACC_DIFVHO,Kdiff_t,dp(1-nbdy,1-nbdy,k1m),1,'p') +c +c --- vertical salt diffusivity (vcoord_type_tag == cntiso_hybrid) [cm^2/s] + call accily(ACC_DIFVSO,Kdiff_s,dp(1-nbdy,1-nbdy,k1m),1,'p') +c c --- absolute vorticity multiplied with potential density difference c --- over layer [g/cm^3/s] call acclyr(ACC_AVDSG,avdsg_p,dummy,0,'p') @@ -1593,28 +1625,28 @@ subroutine diaacc(m,n,mm,nn,k1m,k1n) c #endif c --- ------------------------------------------------------------------ -c --- accumulate 3d diagnostic variables on Levitus levels +c --- accumulate 3d diagnostic variables on Levitus levels c --- ------------------------------------------------------------------ c - do iogrp=1,nphy + do iogrp=1,nphy if (ACC_WFLXLVL(iogrp)+ACC_WFLX2LVL(iogrp).ne.0) then c$OMP PARALLEL DO PRIVATE(k,l,i) do j=1,jj+1 do k=1,ddm do l=1,isu(j) - do i=max(1,ifu(j,l)),min(ii+1,ilu(j,l)) + do i=max(1,ifu(j,l)),min(ii+1,ilu(j,l)) phylvl(i,j,k,ACC_UFLXOLD(iogrp))= . phylvl(i,j,k,ACC_UFLXLVL(iogrp)) enddo enddo do l=1,isv(j) - do i=max(1,ifv(j,l)),min(ii,ilv(j,l)) + do i=max(1,ifv(j,l)),min(ii,ilv(j,l)) phylvl(i,j,k,ACC_VFLXOLD(iogrp))= . phylvl(i,j,k,ACC_VFLXLVL(iogrp)) enddo enddo - enddo - enddo + enddo + enddo c$OMP END PARALLEL DO endif enddo @@ -1709,11 +1741,13 @@ subroutine diaacc(m,n,mm,nn,k1m,k1n) enddo endif c - if (sum(ACC_SALNLVL(1:nphy)+ACC_TEMPLVL(1:nphy)+ - . ACC_BFSQLVL(1:nphy)+ACC_DIFDIALVL(1:nphy)+ - . ACC_DIFINTLVL(1:nphy)+ACC_DIFISOLVL(1:nphy)+ - . ACC_TKELVL(1:nphy)+ACC_GLS_PSILVL(1:nphy)+ - . ACC_PVLVL(1:nphy)+ACC_DZLVL(1:nphy)).ne.0) then + if (sum(ACC_SALNLVL(1:nphy) +ACC_TEMPLVL(1:nphy) + . +ACC_BFSQLVL(1:nphy) +ACC_DIFDIALVL(1:nphy) + . +ACC_DIFVMOLVL(1:nphy) +ACC_DIFVHOLVL(1:nphy) + . +ACC_DIFVSOLVL(1:nphy) +ACC_DIFINTLVL(1:nphy) + . +ACC_DIFISOLVL(1:nphy) +ACC_TKELVL(1:nphy) + . +ACC_GLS_PSILVL(1:nphy)+ACC_PVLVL(1:nphy) + . +ACC_DZLVL(1:nphy) ).ne.0) then do k=1,kk call diazlv('p',k,mm,nn,ind1,ind2,wghts,wghtsflx) c @@ -1734,9 +1768,19 @@ subroutine diaacc(m,n,mm,nn,k1m,k1n) c --- --- isopycnal diffusivity [cm^2/s] call acclvl(ACC_DIFISOLVL,difiso,'p',k,ind1,ind2,wghts) c -c --- --- diapycnal diffusivity [cm^2/s] +c --- --- vertical diffusivity (vcoord_type_tag == isopyc_bulkml) [cm^2/s] call acclvl(ACC_DIFDIALVL,difdia,'p',k,ind1,ind2,wghts) c +c --- --- vertical momentum diffusivity (vcoord_type_tag == cntiso_hybrid) +c --- --- [cm^2/s] + call accilv(ACC_DIFVMOLVL,Kvisc_m,'p',k,ind1,ind2,wghts) +c +c --- --- vertical heat diffusivity (vcoord_type_tag == cntiso_hybrid) [cm^2/s] + call accilv(ACC_DIFVHOLVL,Kdiff_t,'p',k,ind1,ind2,wghts) +c +c --- --- vertical salt diffusivity (vcoord_type_tag == cntiso_hybrid) [cm^2/s] + call accilv(ACC_DIFVSOLVL,Kdiff_s,'p',k,ind1,ind2,wghts) +c c --- --- potential vorticity [s m-2] call acclvl(ACC_PVLVL,pv_p,'p',k,ind1,ind2,wghts) c @@ -1809,7 +1853,7 @@ subroutine diaout(iogrp,m,n,mm,nn,k1m,k1n) c rnacc=1./real(nacc_phy(iogrp)) cmpflg=GLB_COMPFLAG(iogrp) -c +c c --- compute meridional transports and transports through sections if (ACC_MMFLXL(iogrp)+ACC_MMFLXD(iogrp)+ACC_MMFTDL(iogrp) . +ACC_MMFTDD(iogrp)+ACC_MHFLX(iogrp)+ACC_MHFTD(iogrp) @@ -2046,6 +2090,9 @@ subroutine diaout(iogrp,m,n,mm,nn,k1m,k1n) call finlyr(ACC_TEMP(iogrp),ACC_DP(iogrp),'p') call finlyr(ACC_BFSQ(iogrp),ACC_DP(iogrp),'p') call finlyr(ACC_DIFDIA(iogrp),ACC_DP(iogrp),'p') + call finlyr(ACC_DIFVMO(iogrp),ACC_DP(iogrp),'p') + call finlyr(ACC_DIFVHO(iogrp),ACC_DP(iogrp),'p') + call finlyr(ACC_DIFVSO(iogrp),ACC_DP(iogrp),'p') call finlyr(ACC_DIFINT(iogrp),ACC_DP(iogrp),'p') call finlyr(ACC_DIFISO(iogrp),ACC_DP(iogrp),'p') call finlyr(ACC_AVDSG(iogrp),ACC_DPVOR(iogrp),'p') @@ -2053,10 +2100,16 @@ subroutine diaout(iogrp,m,n,mm,nn,k1m,k1n) call finlyr(ACC_TKE(iogrp),ACC_DP(iogrp),'p') call finlyr(ACC_GLS_PSI(iogrp),ACC_DP(iogrp),'p') #endif -c +c c --- compute log10 of diffusivities if (LYR_DIFDIA(iogrp).eq.2) . call loglyr(ACC_DIFDIA(iogrp),'p',1e-4,0.) + if (LYR_DIFVMO(iogrp).eq.2) + . call loglyr(ACC_DIFVMO(iogrp),'p',1e-4,0.) + if (LYR_DIFVHO(iogrp).eq.2) + . call loglyr(ACC_DIFVHO(iogrp),'p',1e-4,0.) + if (LYR_DIFVSO(iogrp).eq.2) + . call loglyr(ACC_DIFVSO(iogrp),'p',1e-4,0.) if (LYR_DIFINT(iogrp).eq.2) . call loglyr(ACC_DIFINT(iogrp),'p',1e-4,0.) if (LYR_DIFISO(iogrp).eq.2) @@ -2064,6 +2117,12 @@ subroutine diaout(iogrp,m,n,mm,nn,k1m,k1n) c if (LVL_DIFDIA(iogrp).eq.2) . call loglvl(ACC_DIFDIALVL(iogrp),'p',1e-4*rnacc,0.) + if (LVL_DIFVMO(iogrp).eq.2) + . call loglvl(ACC_DIFVMOLVL(iogrp),'p',1e-4*rnacc,0.) + if (LVL_DIFVHO(iogrp).eq.2) + . call loglvl(ACC_DIFVHOLVL(iogrp),'p',1e-4*rnacc,0.) + if (LVL_DIFVSO(iogrp).eq.2) + . call loglvl(ACC_DIFVSOLVL(iogrp),'p',1e-4*rnacc,0.) if (LVL_DIFINT(iogrp).eq.2) . call loglvl(ACC_DIFINTLVL(iogrp),'p',1e-4*rnacc,0.) if (LVL_DIFISO(iogrp).eq.2) @@ -2072,6 +2131,9 @@ subroutine diaout(iogrp,m,n,mm,nn,k1m,k1n) c --- mask sea floor of level fields call msklvl(ACC_BFSQLVL(iogrp),'p') call msklvl(ACC_DIFDIALVL(iogrp),'p') + call msklvl(ACC_DIFVMOLVL(iogrp),'p') + call msklvl(ACC_DIFVHOLVL(iogrp),'p') + call msklvl(ACC_DIFVSOLVL(iogrp),'p') call msklvl(ACC_DIFINTLVL(iogrp),'p') call msklvl(ACC_DIFISOLVL(iogrp),'p') call msklvl(ACC_DZLVL(iogrp),'p') @@ -2102,8 +2164,8 @@ subroutine diaout(iogrp,m,n,mm,nn,k1m,k1n) call msklvl(ACC_TKELVL(iogrp),'p') call msklvl(ACC_GLS_PSILVL(iogrp),'p') #endif -c -c --- get instantaneous values for ice age +c +c --- get instantaneous values for ice age if (ACC_IAGE(iogrp).ne.0) then c$OMP PARALLEL DO PRIVATE(l,i) do j=1,jj @@ -2125,7 +2187,7 @@ subroutine diaout(iogrp,m,n,mm,nn,k1m,k1n) . date0%year,'-',date0%month,'-',date0%day,' 00:00' datenum=time-time0-0.5*diagfq_phy(iogrp)/nstep_in_day c -c --- create file name +c --- create file name if (.not.append2file(iogrp)) then call diafnm(GLB_FNAMETAG(IOGRP), . filefq_phy(iogrp)/real(nstep_in_day), @@ -2155,7 +2217,7 @@ subroutine diaout(iogrp,m,n,mm,nn,k1m,k1n) call ncfopn(fname(iogrp),'w','c',irec(iogrp),iotype) endif c -c --- compute extended ocean masks +c --- compute extended ocean masks if (iniflg) then iniflg=.false. c$OMP PARALLEL DO PRIVATE(i) @@ -2176,7 +2238,7 @@ subroutine diaout(iogrp,m,n,mm,nn,k1m,k1n) c$OMP END PARALLEL DO endif c -c --- define output dimensions +c --- define output dimensions if (cmpflg.ne.0) then call ncdimc('pcomp',ip,0) call ncdimc('ucomp',iuu,0) @@ -2187,7 +2249,7 @@ subroutine diaout(iogrp,m,n,mm,nn,k1m,k1n) endif call ncdims('sigma',kdm) call ncdims('depth',ddm) - call ncdims('bounds',2) + call ncdims('bounds',2) call ncdims('time',0) c if (ACC_MMFLXL(iogrp)+ACC_MMFLXD(iogrp)+ACC_MMFTDL(iogrp) @@ -2228,7 +2290,7 @@ subroutine diaout(iogrp,m,n,mm,nn,k1m,k1n) call nctime(datenum,calendar,timeunits,startdate) c -c --- write auxillary dimension information +c --- write auxillary dimension information if (irec(iogrp).eq.1) then c --- sigma levels call ncwrt1('sigma','sigma',sigmar1) @@ -2246,18 +2308,18 @@ subroutine diaout(iogrp,m,n,mm,nn,k1m,k1n) if (MSC_MMFLXL(iogrp)+MSC_MMFLXD(iogrp)+MSC_MMFTDL(iogrp) . +MSC_MMFTDD(iogrp)+MSC_MHFLX(iogrp)+MSC_MHFTD(iogrp) . +MSC_MHFLD(iogrp)+MSC_MSFLX(iogrp)+MSC_MSFTD(iogrp) - . +MSC_MSFLD(iogrp).ne.0) then - call ncwrt1('lat','lat',mtlat) + . +MSC_MSFLD(iogrp).ne.0) then + call ncwrt1('lat','lat',mtlat) call ncattr('long_name','Latitude') call ncattr('standard_name','latitude') call ncattr('units','degree_north') - call ncwrtc('region','slenmax region',mer_regnam) - call ncattr('long_name','Region name') + call ncwrtc('region','slenmax region',mer_regnam) + call ncattr('long_name','Region name') endif - if (MSC_VOLTR(iogrp).ne.0) then + if (MSC_VOLTR(iogrp).ne.0) then call ncwrtc('section','slenmax section',sec_name) - call ncattr('long_name','Section name') - endif + call ncattr('long_name','Section name') + endif endif c c --- write 2d fields @@ -2377,7 +2439,7 @@ subroutine diaout(iogrp,m,n,mm,nn,k1m,k1n) . 'Momentum flux received by ocean x-component',' ','N m-2') c call wrth2d(ACC_TAUY(iogrp),H2D_TAUY(iogrp),rnacc*.1, - . 0.,cmpflg,ivv,'v','tauy', + . 0.,cmpflg,ivv,'v','tauy', . 'Momentum flux received by ocean y-component',' ','N m-2') c call wrth2d(ACC_IDKEDT(iogrp),H2D_IDKEDT(iogrp), @@ -2636,11 +2698,41 @@ subroutine diaout(iogrp,m,n,mm,nn,k1m,k1n) c if (LYR_DIFDIA(iogrp).eq.2) then call wrtlyr(ACC_DIFDIA(iogrp),LYR_DIFDIA(iogrp),1., - . 0.,cmpflg,ip,'p','difdia','Diapycnal diffusivity',' ', + . 0.,cmpflg,ip,'p','difdia','Vertical diffusivity',' ', . 'log10(m2 s-1)') else call wrtlyr(ACC_DIFDIA(iogrp),LYR_DIFDIA(iogrp),1e-4, - . 0.,cmpflg,ip,'p','difdia','Diapycnal diffusivity',' ', + . 0.,cmpflg,ip,'p','difdia','Vertical diffusivity',' ', + . 'm2 s-1') + endif +c + if (LYR_DIFVMO(iogrp).eq.2) then + call wrtlyr(ACC_DIFVMO(iogrp),LYR_DIFVMO(iogrp),1., + . 0.,cmpflg,ip,'p','difvmo','Vertical momentum diffusivity',' ', + . 'log10(m2 s-1)') + else + call wrtlyr(ACC_DIFVMO(iogrp),LYR_DIFVMO(iogrp),1e-4, + . 0.,cmpflg,ip,'p','difvmo','Vertical momentum diffusivity',' ', + . 'm2 s-1') + endif +c + if (LYR_DIFVHO(iogrp).eq.2) then + call wrtlyr(ACC_DIFVHO(iogrp),LYR_DIFVHO(iogrp),1., + . 0.,cmpflg,ip,'p','difvho','Vertical heat diffusivity',' ', + . 'log10(m2 s-1)') + else + call wrtlyr(ACC_DIFVHO(iogrp),LYR_DIFVHO(iogrp),1e-4, + . 0.,cmpflg,ip,'p','difvho','Vertical heat diffusivity',' ', + . 'm2 s-1') + endif +c + if (LYR_DIFVSO(iogrp).eq.2) then + call wrtlyr(ACC_DIFVSO(iogrp),LYR_DIFVSO(iogrp),1., + . 0.,cmpflg,ip,'p','difvso','Vertical salt diffusivity',' ', + . 'log10(m2 s-1)') + else + call wrtlyr(ACC_DIFVSO(iogrp),LYR_DIFVSO(iogrp),1e-4, + . 0.,cmpflg,ip,'p','difvso','Vertical salt diffusivity',' ', . 'm2 s-1') endif c @@ -2673,7 +2765,7 @@ subroutine diaout(iogrp,m,n,mm,nn,k1m,k1n) call wrtlvl(ACC_VVELLVL(iogrp),LVL_VVEL(iogrp), . rnacc*1e-2,0.,cmpflg,ivv,'v','vvellvl', . 'Velocity y-component',' ','m s-1') -c +c call wrtlvl(ACC_UFLXLVL(iogrp),LVL_UFLX(iogrp), . rnacc*0.5e-3/(g*baclin),0.,cmpflg,iuu,'u','uflxlvl', . 'Mass flux in x-direction',' ','kg s-1') @@ -2786,13 +2878,43 @@ subroutine diaout(iogrp,m,n,mm,nn,k1m,k1n) c if (LVL_DIFDIA(iogrp).eq.2) then call wrtlvl(ACC_DIFDIALVL(iogrp),LVL_DIFDIA(iogrp),1., - . 0.,cmpflg,ip,'p','difdialvl','Diapycnal diffusivity',' ', + . 0.,cmpflg,ip,'p','difdialvl','Vertical diffusivity',' ', . 'log10(m2 s-1)') else call wrtlvl(ACC_DIFDIALVL(iogrp),LVL_DIFDIA(iogrp),1e-4*rnacc, - . 0.,cmpflg,ip,'p','difdialvl','Diapycnal diffusivity',' ', + . 0.,cmpflg,ip,'p','difdialvl','Vertical diffusivity',' ', . 'm2 s-1') endif +c + if (LVL_DIFVMO(iogrp).eq.2) then + call wrtlvl(ACC_DIFVMOLVL(iogrp),LVL_DIFVMO(iogrp),1., + . 0.,cmpflg,ip,'p','difvmolvl','Vertical momentum diffusivity', + . ' ','log10(m2 s-1)') + else + call wrtlvl(ACC_DIFVMOLVL(iogrp),LVL_DIFVMO(iogrp),1e-4*rnacc, + . 0.,cmpflg,ip,'p','difvmolvl','Vertical momentum diffusivity', + . ' ','m2 s-1') + endif +c + if (LVL_DIFVHO(iogrp).eq.2) then + call wrtlvl(ACC_DIFVHOLVL(iogrp),LVL_DIFVHO(iogrp),1., + . 0.,cmpflg,ip,'p','difvholvl','Vertical heat diffusivity', + . ' ','log10(m2 s-1)') + else + call wrtlvl(ACC_DIFVHOLVL(iogrp),LVL_DIFVHO(iogrp),1e-4*rnacc, + . 0.,cmpflg,ip,'p','difvholvl','Vertical heat diffusivity', + . ' ','m2 s-1') + endif +c + if (LVL_DIFVSO(iogrp).eq.2) then + call wrtlvl(ACC_DIFVSOLVL(iogrp),LVL_DIFVSO(iogrp),1., + . 0.,cmpflg,ip,'p','difvsolvl','Vertical salt diffusivity', + . ' ','log10(m2 s-1)') + else + call wrtlvl(ACC_DIFVSOLVL(iogrp),LVL_DIFVSO(iogrp),1e-4*rnacc, + . 0.,cmpflg,ip,'p','difvsolvl','Vertical salt diffusivity', + . ' ','m2 s-1') + endif c #if defined(TRC) && defined(TKE) call wrtlvl(ACC_TKELVL(iogrp),LVL_TKE(iogrp),rnacc*1.e-4, @@ -2805,70 +2927,70 @@ subroutine diaout(iogrp,m,n,mm,nn,k1m,k1n) c #endif c -c --- store meridional transports - if (MSC_MMFLXL(iogrp).ne.0) then +c --- store meridional transports + if (MSC_MMFLXL(iogrp).ne.0) then call ncwrt1('mmflxl','lat sigma region time',mmflxl) call ncattr('long_name', - . 'Overturning stream-function on isopycnic layers') - call ncattr('units','kg s-1') + . 'Overturning stream-function on isopycnic layers') + call ncattr('units','kg s-1') endif - if (MSC_MMFLXD(iogrp).ne.0) then + if (MSC_MMFLXD(iogrp).ne.0) then call ncwrt1('mmflxd','lat depth region time',mmflxd) call ncattr('long_name', - . 'Overturning stream-function on z-levels') - call ncattr('units','kg s-1') + . 'Overturning stream-function on z-levels') + call ncattr('units','kg s-1') endif - if (MSC_MMFTDL(iogrp).ne.0) then + if (MSC_MMFTDL(iogrp).ne.0) then call ncwrt1('mmftdl','lat sigma region time',mmftdl) call ncattr('long_name', . 'Overturning stream-function due to thickness diffusion '// - . 'on isopycnic layers') - call ncattr('units','kg s-1') + . 'on isopycnic layers') + call ncattr('units','kg s-1') endif - if (MSC_MMFTDD(iogrp).ne.0) then + if (MSC_MMFTDD(iogrp).ne.0) then call ncwrt1('mmftdd','lat depth region time',mmftdd) call ncattr('long_name', . 'Overturning stream-function due to thickness diffusion '// - . 'on z-levels') - call ncattr('units','kg s-1') + . 'on z-levels') + call ncattr('units','kg s-1') endif - if (MSC_MHFLX(iogrp).ne.0) then + if (MSC_MHFLX(iogrp).ne.0) then call ncwrt1('mhflx','lat region time',mhflx) - call ncattr('long_name','Meridional heat flux') - call ncattr('units','W') + call ncattr('long_name','Meridional heat flux') + call ncattr('units','W') endif - if (MSC_MHFTD(iogrp).ne.0) then + if (MSC_MHFTD(iogrp).ne.0) then call ncwrt1('mhftd','lat region time',mhftd) call ncattr('long_name', - . 'Meridional heat flux due to thickness diffusion') - call ncattr('units','W') + . 'Meridional heat flux due to thickness diffusion') + call ncattr('units','W') endif - if (MSC_MHFLD(iogrp).ne.0) then + if (MSC_MHFLD(iogrp).ne.0) then call ncwrt1('mhfld','lat region time',mhfld) call ncattr('long_name', - . 'Meridional heat flux due to lateral diffusion') - call ncattr('units','W') + . 'Meridional heat flux due to lateral diffusion') + call ncattr('units','W') endif - if (MSC_MSFLX(iogrp).ne.0) then + if (MSC_MSFLX(iogrp).ne.0) then call ncwrt1('msflx','lat region time',msflx) - call ncattr('long_name','Meridional salt flux') - call ncattr('units','kg s-1') + call ncattr('long_name','Meridional salt flux') + call ncattr('units','kg s-1') endif - if (MSC_MSFTD(iogrp).ne.0) then + if (MSC_MSFTD(iogrp).ne.0) then call ncwrt1('msftd','lat region time',msftd) call ncattr('long_name', - . 'Meridional salt flux due to thickness diffusion') - call ncattr('units','kg s-1') + . 'Meridional salt flux due to thickness diffusion') + call ncattr('units','kg s-1') endif - if (MSC_MSFLD(iogrp).ne.0) then + if (MSC_MSFLD(iogrp).ne.0) then call ncwrt1('msfld','lat region time',msfld) call ncattr('long_name', - . 'Meridional salt flux due to lateral diffusion') - call ncattr('units','kg s-1') + . 'Meridional salt flux due to lateral diffusion') + call ncattr('units','kg s-1') endif c -c --- store section transports - if (MSC_VOLTR(iogrp).ne.0) then +c --- store section transports + if (MSC_VOLTR(iogrp).ne.0) then call ncwrt1('voltr','section time',voltr) call ncattr('long_name','Section transports') call ncattr('units','kg s-1') @@ -2917,7 +3039,7 @@ subroutine diaout(iogrp,m,n,mm,nn,k1m,k1n) endif # ifdef IDLAGE c -c --- ideal age tracer +c --- ideal age tracer if (LYR_IDLAGE(iogrp).ne.0) then call inilyr(ACC_UTILLYR(1),'p',0.) call acclyr(ACC_UTILLYR,trc(1-nbdy,1-nbdy,k1m,itriag),tmp3d,0, @@ -3047,7 +3169,7 @@ subroutine diaout(iogrp,m,n,mm,nn,k1m,k1n) c --- initialisation of fields call inifld(iogrp) c -c --- reset accumulation counter +c --- reset accumulation counter nacc_phy(iogrp)=0 c end subroutine diaout @@ -3106,8 +3228,8 @@ subroutine diasec(iogrp) call xcbcst(sec_num) iniflg=.false. endif -c -c --- Prepare 2d field +c +c --- Prepare 2d field c$OMP PARALLEL DO PRIVATE(i) do j=1,jj do i=1,ii @@ -3150,7 +3272,7 @@ subroutine diasec(iogrp) vflx_cum350(i,j)=vflx_cum(i,j) enddo enddo - elseif (k.eq.k350) then + elseif (k.eq.k350) then do l=1,isu(j) do i=max(1,ifu(j,l)),min(ii,ilu(j,l)) uflx_cum350(i,j)=uflx_cum350(i,j)+ @@ -3207,7 +3329,7 @@ subroutine diamer(iogrp) implicit none c integer :: iogrp -c +c integer :: ncid,dimid,varid,i,j,k,l,m,n,o,s,ocn_nreg,iostatus, . istat,iind1,jind1,uflg1,vflg1,nind1, . nfld,ACC_UIND,ACC_VIND,nind(ldm),iind(sdm,ldm),jind(sdm,ldm), @@ -3331,7 +3453,7 @@ subroutine diamer(iogrp) c endif c -c --- Compute vertical integrated heat and salt transports +c --- Compute vertical integrated heat and salt transports c c$OMP PARALLEL DO PRIVATE(i) do j=1,jj @@ -3414,8 +3536,8 @@ subroutine diamer(iogrp) do o=1,ocn_nreg mflx_or(l,o)=0. mcnt_or(l,o)=0 - enddo - do s=1,nind(l) + enddo + do s=1,nind(l) i=iind(s,l) j=jind(s,l) o=oflg(i,j) @@ -3605,10 +3727,10 @@ subroutine diamer(iogrp) if (mnproc.eq.1) then do l=1,lmax c ---- ------ Accumulate meridional fluxes in seperate ocean regions - do o=1,ocn_nreg + do o=1,ocn_nreg mflx_or(l,o)=0. - enddo - do s=1,nind(l) + enddo + do s=1,nind(l) i=iind(s,l) j=jind(s,l) o=oflg(i,j) @@ -3669,7 +3791,7 @@ subroutine diamer(iogrp) enddo c c --- Compute overturning stream function at levitus level interfaces -c --- Prepare depth mask +c --- Prepare depth mask c if (iniflg) call xcaget(depthst,depths,1) if (iniflg.and.mnproc.eq.1) then @@ -3677,7 +3799,7 @@ subroutine diamer(iogrp) do m=1,mer_nreg kmax(l,m)=0 enddo - enddo + enddo do k=1,ddm do l=1,lmax do s=1,nind(l) @@ -3694,7 +3816,7 @@ subroutine diamer(iogrp) endif enddo endif - enddo + enddo enddo enddo endif @@ -3751,10 +3873,10 @@ subroutine diamer(iogrp) if (mnproc.eq.1) then do l=1,lmax c ---- ------ Accumulate meridional fluxes in seperate ocean regions - do o=1,ocn_nreg + do o=1,ocn_nreg mflx_or(l,o)=0. - enddo - do s=1,nind(l) + enddo + do s=1,nind(l) i=iind(s,l) j=jind(s,l) o=oflg(i,j) @@ -3816,7 +3938,7 @@ end subroutine diamer subroutine diavfl(iogrp,m,n,mm,nn,k1m,k1n) c c --- ------------------------------------------------------------------ -c --- computation of vertical mass flux at isopycnic layer interfaces +c --- computation of vertical mass flux at isopycnic layer interfaces c --- ------------------------------------------------------------------ c implicit none @@ -3828,7 +3950,7 @@ subroutine diavfl(iogrp,m,n,mm,nn,k1m,k1n) real :: q c c --- -c --- Compute vertical mass flux at isopycnic layer interfaces +c --- Compute vertical mass flux at isopycnic layer interfaces c --- if (ACC_WFLX(iogrp)+ACC_WFLX2(IOGRP).ne.0) then c @@ -3837,15 +3959,15 @@ subroutine diavfl(iogrp,m,n,mm,nn,k1m,k1n) do i=1,ii wflx(i,j)=0. enddo - enddo + enddo c$OMP END PARALLEL DO do k=kk,1,-1 km=k+mm kn=k+nn c$OMP PARALLEL DO PRIVATE(l,i) - do j=1,jj + do j=1,jj do l=1,isp(j) - do i=max(1,ifp(j,l)),min(ii,ilp(j,l)) + do i=max(1,ifp(j,l)),min(ii,ilp(j,l)) wflx(i,j)=wflx(i,j) . -(uflx(i+1,j,kn)-uflx(i,j,kn) . +vflx(i,j+1,kn)-vflx(i,j,kn)) @@ -3860,8 +3982,8 @@ subroutine diavfl(iogrp,m,n,mm,nn,k1m,k1n) c$OMP END PARALLEL DO enddo endif -c -c --- Computation of vertical mass flux at levitus layer interfaces +c +c --- Computation of vertical mass flux at levitus layer interfaces if (ACC_WFLXLVL(iogrp)+ACC_WFLX2LVL(iogrp).ne.0) then c call xctilr(phylvl(1-nbdy,1-nbdy,1,ACC_UFLXLVL(iogrp)), @@ -3874,35 +3996,35 @@ subroutine diavfl(iogrp,m,n,mm,nn,k1m,k1n) ucum(i,j)=0. vcum(i,j)=0. enddo - enddo + enddo c$OMP END PARALLEL DO do k=ddm,1,-1 c$OMP PARALLEL DO PRIVATE(l,i) do j=1,jj do l=1,isu(j) - do i=max(1,ifu(j,l)),min(ii+1,ilu(j,l)) + do i=max(1,ifu(j,l)),min(ii+1,ilu(j,l)) ucum(i,j)=ucum(i,j) . +phylvl(i,j,k,ACC_UFLXLVL(iogrp)) . -phylvl(i,j,k,ACC_UFLXOLD(iogrp)) enddo enddo - enddo + enddo c$OMP END PARALLEL DO c$OMP PARALLEL DO PRIVATE(l,i) - do j=1,jj+1 + do j=1,jj+1 do l=1,isv(j) - do i=max(1,ifv(j,l)),min(ii,ilv(j,l)) + do i=max(1,ifv(j,l)),min(ii,ilv(j,l)) vcum(i,j)=vcum(i,j) . +phylvl(i,j,k,ACC_VFLXLVL(iogrp)) . -phylvl(i,j,k,ACC_VFLXOLD(iogrp)) enddo enddo - enddo + enddo c$OMP END PARALLEL DO c$OMP PARALLEL DO PRIVATE(l,i,q) - do j=1,jj + do j=1,jj do l=1,isp(j) - do i=max(1,ifp(j,l)),min(ii,ilp(j,l)) + do i=max(1,ifp(j,l)),min(ii,ilp(j,l)) q=-(ucum(i+1,j)-ucum(i,j) . +vcum(i,j+1)-vcum(i,j)) phylvl(i,j,k,ACC_WFLXLVL(iogrp))= @@ -3927,7 +4049,7 @@ subroutine diazlv(gridid,k,mm,nn,ind1,ind2,weights,weightsflx) c integer :: d,i,j,k,mm,nn,l,kl,km,kn,kml,k1m integer, dimension(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy) :: ind1,ind2 -c +c real :: r,dzeps,dpeps,flxeps real, dimension(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy,kk) :: ztop,zbot real, dimension(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy,ddm) :: weights, @@ -3939,12 +4061,12 @@ subroutine diazlv(gridid,k,mm,nn,ind1,ind2,weights,weightsflx) c save ztop,zbot,dlevp,dlevu,dlevv,iniflg c -c --- Define thresholds +c --- Define thresholds dzeps=1e1*epsil dpeps=1e5*epsil flxeps=1e5*epsil c -c --- Sort out stuff related to time stepping +c --- Sort out stuff related to time stepping km=k+mm kn=k+nn k1m=1+mm @@ -3979,7 +4101,7 @@ subroutine diazlv(gridid,k,mm,nn,ind1,ind2,weights,weightsflx) endif c c -c --- Compute top and bottom depths of density layers +c --- Compute top and bottom depths of density layers if (k.eq.1) then if (gridid.eq.'p') then c$OMP PARALLEL DO PRIVATE(l,i,kl,kml) @@ -4088,7 +4210,7 @@ subroutine diazlv(gridid,k,mm,nn,ind1,ind2,weights,weightsflx) endif endif c -c --- Compute interpolation weights +c --- Compute interpolation weights if (gridid.eq.'p') then c$OMP PARALLEL DO PRIVATE(l,i,d) do j=1,jj @@ -4115,7 +4237,7 @@ subroutine diazlv(gridid,k,mm,nn,ind1,ind2,weights,weightsflx) c$OMP END PARALLEL DO c elseif (gridid.eq.'u') then -c$OMP PARALLEL DO PRIVATE(l,i,d,r) +c$OMP PARALLEL DO PRIVATE(l,i,d,r) do j=1,jj do l=1,isu(j) do i=max(1,ifu(j,l)),min(ii+1,ilu(j,l)) @@ -4185,19 +4307,19 @@ subroutine inih2d(pos,gridid,inival) c c --- ------------------------------------------------------------------ c --- Description: initialise 2d diagnostic field -c --- +c --- c --- Arguments: -c --- int pos (in) : position in common buffer +c --- int pos (in) : position in common buffer c --- char gridid (in) : grid identifier ('p','u' or 'v') c --- real inival (in) : value used for initalisation c --- ------------------------------------------------------------------ c implicit none -c +c integer :: pos real :: inival character :: gridid -c +c integer :: i,j c c --- Check whether field should be initialised @@ -4245,19 +4367,19 @@ subroutine inilyr(pos,gridid,inival) c c --- ------------------------------------------------------------------ c --- Description: initialise layer diagnostic field -c --- +c --- c --- Arguments: -c --- int pos (in) : position in common buffer +c --- int pos (in) : position in common buffer c --- char gridid (in) : grid identifier ('p','u' or 'v') c --- real inival (in) : value used for initalisation c --- ------------------------------------------------------------------ c implicit none -c +c integer :: pos real :: inival character :: gridid -c +c integer :: i,j,k c c --- Check whether field should be initialised @@ -4266,7 +4388,7 @@ subroutine inilyr(pos,gridid,inival) if (gridid(1:1).eq.'u') then c$OMP PARALLEL DO PRIVATE(k,i) do j=1-nbdy,jj+nbdy - do k=1,kk + do k=1,kk do i=1-nbdy,ii+nbdy phylyr(i,j,k,pos)=inival*iu(i,j) enddo @@ -4276,7 +4398,7 @@ subroutine inilyr(pos,gridid,inival) elseif (gridid(1:1).eq.'v') then c$OMP PARALLEL DO PRIVATE(k,i) do j=1-nbdy,jj+nbdy - do k=1,kk + do k=1,kk do i=1-nbdy,ii+nbdy phylyr(i,j,k,pos)=inival*iv(i,j) enddo @@ -4286,7 +4408,7 @@ subroutine inilyr(pos,gridid,inival) elseif (gridid(1:1).eq.'p') then c$OMP PARALLEL DO PRIVATE(k,i) do j=1-nbdy,jj+nbdy - do k=1,kk + do k=1,kk do i=1-nbdy,ii+nbdy phylyr(i,j,k,pos)=inival*ip(i,j) enddo @@ -4296,7 +4418,7 @@ subroutine inilyr(pos,gridid,inival) else c$OMP PARALLEL DO PRIVATE(k,i) do j=1-nbdy,jj+nbdy - do k=1,kk + do k=1,kk do i=1-nbdy,ii+nbdy phylyr(i,j,k,pos)=inival enddo @@ -4313,19 +4435,19 @@ subroutine inilvl(pos,gridid,inival) c c --- ------------------------------------------------------------------ c --- Description: initialise level diagnostic field -c --- +c --- c --- Arguments: -c --- int pos (in) : position in common buffer +c --- int pos (in) : position in common buffer c --- char gridid (in) : grid identifier ('p','u' or 'v') c --- real inival (in) : value used for initalisation c --- ------------------------------------------------------------------ c implicit none -c +c integer :: pos real :: inival character :: gridid -c +c integer :: i,j,k c c --- Check whether field should be initialised @@ -4380,22 +4502,22 @@ end subroutine inilvl subroutine acch2d(pos,fld,wghts,wghtsflg,gridid) c c --- ------------------------------------------------------------------ -c --- Description: accumulate 2d fields -c --- -c --- Arguments: -c --- int pos (in) : position in 2d buffer +c --- Description: accumulate 2d fields +c --- +c --- Arguments: +c --- int pos (in) : position in 2d buffer c --- real fld (in) : input data used for accumulation c --- real wghts (in) : weights used for accumulation -c --- int wghtsflg (in) : weights flag (0=no weighting) +c --- int wghtsflg (in) : weights flag (0=no weighting) c --- char gridid (in) : grid identifier ('p','u' or 'v') c --- ------------------------------------------------------------------ c implicit none -c +c integer :: pos(nphymax),wghtsflg real, dimension(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy) :: fld,wghts character :: gridid -c +c integer :: i,j,l,o c c --- Check whether field should be accumulated @@ -4403,7 +4525,7 @@ subroutine acch2d(pos,fld,wghts,wghtsflg,gridid) if (pos(o).eq.0) cycle c if (gridid.eq.'u') then - if (wghtsflg.eq.0) then + if (wghtsflg.eq.0) then c$OMP PARALLEL DO PRIVATE(l,i) do j=1,jj do l=1,isu(j) @@ -4424,9 +4546,9 @@ subroutine acch2d(pos,fld,wghts,wghtsflg,gridid) enddo enddo c$OMP END PARALLEL DO - endif + endif elseif (gridid.eq.'v') then - if (wghtsflg.eq.0) then + if (wghtsflg.eq.0) then c$OMP PARALLEL DO PRIVATE(l,i) do j=1,jj do l=1,isv(j) @@ -4447,9 +4569,9 @@ subroutine acch2d(pos,fld,wghts,wghtsflg,gridid) enddo enddo c$OMP END PARALLEL DO - endif + endif elseif (gridid.eq.'p') then - if (wghtsflg.eq.0) then + if (wghtsflg.eq.0) then c$OMP PARALLEL DO PRIVATE(l,i) do j=1,jj do l=1,isp(j) @@ -4470,7 +4592,7 @@ subroutine acch2d(pos,fld,wghts,wghtsflg,gridid) enddo enddo c$OMP END PARALLEL DO - endif + endif else write (lp,*) 'cannot identify grid '//gridid//'!' call xchalt('(acch2d)') @@ -4478,7 +4600,7 @@ subroutine acch2d(pos,fld,wghts,wghtsflg,gridid) endif c enddo -c +c end subroutine acch2d @@ -4486,20 +4608,20 @@ end subroutine acch2d subroutine maxh2d(pos,fld,gridid) c c --- ------------------------------------------------------------------ -c --- Description: store maximum of 2d fields -c --- -c --- Arguments: -c --- int pos (in) : position in 2d buffer +c --- Description: store maximum of 2d fields +c --- +c --- Arguments: +c --- int pos (in) : position in 2d buffer c --- real fld (in) : input data used for finding maximum c --- char gridid (in) : grid identifier ('p','u' or 'v') c --- ------------------------------------------------------------------ c implicit none -c +c integer :: pos(nphymax) real, dimension(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy) :: fld character :: gridid -c +c integer :: i,j,l,o c c --- Check whether maximum of field should be stored @@ -4543,7 +4665,7 @@ subroutine maxh2d(pos,fld,gridid) endif c enddo -c +c end subroutine maxh2d @@ -4551,20 +4673,20 @@ end subroutine maxh2d subroutine minh2d(pos,fld,gridid) c c --- ------------------------------------------------------------------ -c --- Description: store minimum of 2d fields -c --- -c --- Arguments: -c --- int pos (in) : position in 2d buffer +c --- Description: store minimum of 2d fields +c --- +c --- Arguments: +c --- int pos (in) : position in 2d buffer c --- real fld (in) : input data used for finding minimum c --- char gridid (in) : grid identifier ('p','u' or 'v') c --- ------------------------------------------------------------------ c implicit none -c +c integer :: pos(nphymax) real, dimension(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy) :: fld character :: gridid -c +c integer :: i,j,l,o c c --- Check whether minimum of field should be stored @@ -4608,7 +4730,7 @@ subroutine minh2d(pos,fld,gridid) endif c enddo -c +c end subroutine minh2d @@ -4616,20 +4738,20 @@ end subroutine minh2d subroutine sqh2d(pos,fld,gridid) c c --- ------------------------------------------------------------------ -c --- Description: accumulate square of 2d fields -c --- -c --- Arguments: -c --- int pos (in) : position in 2d buffer +c --- Description: accumulate square of 2d fields +c --- +c --- Arguments: +c --- int pos (in) : position in 2d buffer c --- real fld (in) : input data used for accumulation c --- char gridid (in) : grid identifier ('p','u' or 'v') c --- ------------------------------------------------------------------ c implicit none -c +c integer :: pos(nphymax) real, dimension(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy) :: fld character :: gridid -c +c integer :: i,j,l,o c c --- Check whether field should be accumulated @@ -4673,7 +4795,7 @@ subroutine sqh2d(pos,fld,gridid) endif c enddo -c +c end subroutine sqh2d @@ -4681,22 +4803,22 @@ end subroutine sqh2d subroutine acclyr(pos,fld,wghts,wghtsflg,gridid) c c --- ------------------------------------------------------------------ -c --- Description: accumulate layer fields -c --- -c --- Arguments: -c --- int pos (in) : position in 3d layer buffer +c --- Description: accumulate layer fields +c --- +c --- Arguments: +c --- int pos (in) : position in 3d layer buffer c --- real fld (in) : input data used for accumulation c --- real wghts (in) : weights used for accumulation -c --- int wghtsflg (in) : weights flag (0=no weighting) +c --- int wghtsflg (in) : weights flag (0=no weighting) c --- char gridid (in) : grid identifier ('p','u' or 'v') c --- ------------------------------------------------------------------ c implicit none -c +c integer :: pos(nphymax),wghtsflg real, dimension(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy,kdm) :: fld,wghts character :: gridid -c +c integer :: i,j,k,l,o c c --- Check whether field should be accumulated @@ -4704,7 +4826,7 @@ subroutine acclyr(pos,fld,wghts,wghtsflg,gridid) if (pos(o).eq.0) cycle c if (gridid.eq.'u') then - if (wghtsflg.eq.0) then + if (wghtsflg.eq.0) then c$OMP PARALLEL DO PRIVATE(k,l,i) do j=1,jj do k=1,kk @@ -4722,16 +4844,16 @@ subroutine acclyr(pos,fld,wghts,wghtsflg,gridid) do k=1,kk do l=1,isu(j) do i=max(1,ifu(j,l)),min(ii,ilu(j,l)) - phylyr(i,j,k,pos(o))=phylyr(i,j,k,pos(o))+fld(i,j,k) - . *wghts(i,j,k) + phylyr(i,j,k,pos(o))=phylyr(i,j,k,pos(o)) + . +fld(i,j,k)*wghts(i,j,k) enddo enddo enddo enddo c$OMP END PARALLEL DO - endif + endif elseif (gridid.eq.'v') then - if (wghtsflg.eq.0) then + if (wghtsflg.eq.0) then c$OMP PARALLEL DO PRIVATE(k,l,i) do j=1,jj do k=1,kk @@ -4749,16 +4871,16 @@ subroutine acclyr(pos,fld,wghts,wghtsflg,gridid) do k=1,kk do l=1,isv(j) do i=max(1,ifv(j,l)),min(ii,ilv(j,l)) - phylyr(i,j,k,pos(o))=phylyr(i,j,k,pos(o))+fld(i,j,k) - . *wghts(i,j,k) + phylyr(i,j,k,pos(o))=phylyr(i,j,k,pos(o)) + . +fld(i,j,k)*wghts(i,j,k) enddo enddo enddo enddo c$OMP END PARALLEL DO - endif + endif elseif (gridid.eq.'p') then - if (wghtsflg.eq.0) then + if (wghtsflg.eq.0) then c$OMP PARALLEL DO PRIVATE(k,l,i) do j=1,jj do k=1,kk @@ -4776,14 +4898,14 @@ subroutine acclyr(pos,fld,wghts,wghtsflg,gridid) do k=1,kk do l=1,isp(j) do i=max(1,ifp(j,l)),min(ii,ilp(j,l)) - phylyr(i,j,k,pos(o))=phylyr(i,j,k,pos(o))+fld(i,j,k) - . *wghts(i,j,k) + phylyr(i,j,k,pos(o))=phylyr(i,j,k,pos(o)) + . +fld(i,j,k)*wghts(i,j,k) enddo enddo enddo enddo c$OMP END PARALLEL DO - endif + endif else write (lp,*) 'cannot identify grid '//gridid//'!' call xchalt('(acclyr)') @@ -4791,38 +4913,164 @@ subroutine acclyr(pos,fld,wghts,wghtsflg,gridid) endif c enddo -c +c end subroutine acclyr + subroutine accily(pos,fld,wghts,wghtsflg,gridid) +c +c --- ------------------------------------------------------------------ +c --- Description: accumulate interface fields after interpolation to +c --- layers +c --- +c --- Arguments: +c --- int pos (in) : position in 3d layer buffer +c --- real fld (in) : input data used for accumulation +c --- real wghts (in) : weights used for accumulation +c --- int wghtsflg (in) : weights flag (0=no weighting) +c --- char gridid (in) : grid identifier ('p','u' or 'v') +c --- ------------------------------------------------------------------ +c + implicit none +c + integer :: pos(nphymax),wghtsflg + real, dimension(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy,kdm+1) :: fld + real, dimension(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy,kdm) :: wghts + character :: gridid +c + integer :: i,j,k,l,o +c +c --- Check whether field should be accumulated + do o=1,nphy + if (pos(o).eq.0) cycle +c + if (gridid.eq.'u') then + if (wghtsflg.eq.0) then +c$OMP PARALLEL DO PRIVATE(k,l,i) + do j=1,jj + do k=1,kk + do l=1,isu(j) + do i=max(1,ifu(j,l)),min(ii,ilu(j,l)) + phylyr(i,j,k,pos(o))=phylyr(i,j,k,pos(o)) + . +.5*(fld(i,j,k)+fld(i,j,k)) + enddo + enddo + enddo + enddo +c$OMP END PARALLEL DO + else +c$OMP PARALLEL DO PRIVATE(k,l,i) + do j=1,jj + do k=1,kk + do l=1,isu(j) + do i=max(1,ifu(j,l)),min(ii,ilu(j,l)) + phylyr(i,j,k,pos(o))=phylyr(i,j,k,pos(o)) + . +.5*(fld(i,j,k)+fld(i,j,k)) + . *wghts(i,j,k) + enddo + enddo + enddo + enddo +c$OMP END PARALLEL DO + endif + elseif (gridid.eq.'v') then + if (wghtsflg.eq.0) then +c$OMP PARALLEL DO PRIVATE(k,l,i) + do j=1,jj + do k=1,kk + do l=1,isv(j) + do i=max(1,ifv(j,l)),min(ii,ilv(j,l)) + phylyr(i,j,k,pos(o))=phylyr(i,j,k,pos(o)) + . +.5*(fld(i,j,k)+fld(i,j,k)) + enddo + enddo + enddo + enddo +c$OMP END PARALLEL DO + else +c$OMP PARALLEL DO PRIVATE(k,l,i) + do j=1,jj + do k=1,kk + do l=1,isv(j) + do i=max(1,ifv(j,l)),min(ii,ilv(j,l)) + phylyr(i,j,k,pos(o))=phylyr(i,j,k,pos(o)) + . +.5*(fld(i,j,k)+fld(i,j,k)) + . *wghts(i,j,k) + enddo + enddo + enddo + enddo +c$OMP END PARALLEL DO + endif + elseif (gridid.eq.'p') then + if (wghtsflg.eq.0) then +c$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)) + phylyr(i,j,k,pos(o))=phylyr(i,j,k,pos(o)) + . +.5*(fld(i,j,k)+fld(i,j,k)) + enddo + enddo + enddo + enddo +c$OMP END PARALLEL DO + else +c$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)) + phylyr(i,j,k,pos(o))=phylyr(i,j,k,pos(o)) + . +.5*(fld(i,j,k)+fld(i,j,k)) + . *wghts(i,j,k) + enddo + enddo + enddo + enddo +c$OMP END PARALLEL DO + endif + else + write (lp,*) 'cannot identify grid '//gridid//'!' + call xchalt('(accily)') + stop '(accily)' + endif +c + enddo +c + end subroutine accily + + + subroutine acclvl(pos,fld,gridid,k,ind1,ind2,wghts) c c --- ------------------------------------------------------------------ -c --- Description: accumulate 3d level fields -c --- -c --- Arguments: -c --- int pos (in) : position in buffer +c --- Description: accumulate layer fields mapped to levels +c --- +c --- Arguments: +c --- int pos (in) : position in buffer c --- real fld (in) : input data used for accumulation c --- char gridid (in) : grid identifier ('p','u' or 'v') -c --- int k (in) : layer index of fld -c --- int ind1 (in) : index field for first accumulated level -c --- int ind2 (in) : index field for last accumulated level +c --- int k (in) : layer index of fld +c --- int ind1 (in) : index field for first accumulated level +c --- int ind2 (in) : index field for last accumulated level c --- real wghts (in) : weights used for accumulation c --- ------------------------------------------------------------------ c implicit none -c +c integer :: pos(nphymax),k integer, dimension(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy) :: ind1,ind2 real, dimension(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy,ddm) :: wghts real, dimension(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy,kdm) :: fld character :: gridid -c +c integer :: d,i,j,l,o c c --- Check whether field should be accumulated - do o=1,nphy + do o=1,nphy if (pos(o).eq.0) cycle c if (gridid.eq.'u') then @@ -4831,8 +5079,8 @@ subroutine acclvl(pos,fld,gridid,k,ind1,ind2,wghts) do l=1,isu(j) do i=max(1,ifu(j,l)),min(ii+1,ilu(j,l)) do d=ind1(i,j),ind2(i,j) - phylvl(i,j,d,pos(o))=phylvl(i,j,d,pos(o))+ - . fld(i,j,k)*wghts(i,j,d) + phylvl(i,j,d,pos(o))=phylvl(i,j,d,pos(o)) + . +fld(i,j,k)*wghts(i,j,d) enddo enddo enddo @@ -4844,8 +5092,8 @@ subroutine acclvl(pos,fld,gridid,k,ind1,ind2,wghts) do l=1,isv(j) do i=max(1,ifv(j,l)),min(ii,ilv(j,l)) do d=ind1(i,j),ind2(i,j) - phylvl(i,j,d,pos(o))=phylvl(i,j,d,pos(o))+ - . fld(i,j,k)*wghts(i,j,d) + phylvl(i,j,d,pos(o))=phylvl(i,j,d,pos(o)) + . +fld(i,j,k)*wghts(i,j,d) enddo enddo enddo @@ -4857,8 +5105,8 @@ subroutine acclvl(pos,fld,gridid,k,ind1,ind2,wghts) do l=1,isp(j) do i=max(1,ifp(j,l)),min(ii,ilp(j,l)) do d=ind1(i,j),ind2(i,j) - phylvl(i,j,d,pos(o))=phylvl(i,j,d,pos(o))+ - . fld(i,j,k)*wghts(i,j,d) + phylvl(i,j,d,pos(o))=phylvl(i,j,d,pos(o)) + . +fld(i,j,k)*wghts(i,j,d) enddo enddo enddo @@ -4870,11 +5118,93 @@ subroutine acclvl(pos,fld,gridid,k,ind1,ind2,wghts) stop '(acclvl)' endif enddo -c +c end subroutine acclvl + subroutine accilv(pos,fld,gridid,k,ind1,ind2,wghts) +c +c --- ------------------------------------------------------------------ +c --- Description: accumulate interface fields mapped to levels +c --- +c --- Arguments: +c --- int pos (in) : position in buffer +c --- real fld (in) : input data used for accumulation +c --- char gridid (in) : grid identifier ('p','u' or 'v') +c --- int k (in) : layer index of fld +c --- int ind1 (in) : index field for first accumulated level +c --- int ind2 (in) : index field for last accumulated level +c --- real wghts (in) : weights used for accumulation +c --- ------------------------------------------------------------------ +c + implicit none +c + integer :: pos(nphymax),k + integer, dimension(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy) :: ind1,ind2 + real, dimension(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy,ddm) :: wghts + real, dimension(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy,kdm+1) :: fld + character :: gridid +c + integer :: d,i,j,l,o +c +c --- Check whether field should be accumulated + do o=1,nphy + if (pos(o).eq.0) cycle +c + if (gridid.eq.'u') then +c$OMP PARALLEL DO PRIVATE(l,i,d) + do j=1,jj + do l=1,isu(j) + do i=max(1,ifu(j,l)),min(ii+1,ilu(j,l)) + do d=ind1(i,j),ind2(i,j) + phylvl(i,j,d,pos(o))=phylvl(i,j,d,pos(o)) + . +.5*(fld(i,j,k)+fld(i,j,k+1)) + . *wghts(i,j,d) + enddo + enddo + enddo + enddo +c$OMP END PARALLEL DO + elseif (gridid.eq.'v') then +c$OMP PARALLEL DO PRIVATE(l,i,d) + do j=1,jj+1 + do l=1,isv(j) + do i=max(1,ifv(j,l)),min(ii,ilv(j,l)) + do d=ind1(i,j),ind2(i,j) + phylvl(i,j,d,pos(o))=phylvl(i,j,d,pos(o)) + . +.5*(fld(i,j,k)+fld(i,j,k+1)) + . *wghts(i,j,d) + enddo + enddo + enddo + enddo +c$OMP END PARALLEL DO + elseif (gridid(1:1).eq.'p') then +c$OMP PARALLEL DO PRIVATE(l,i,d) + do j=1,jj + do l=1,isp(j) + do i=max(1,ifp(j,l)),min(ii,ilp(j,l)) + do d=ind1(i,j),ind2(i,j) + phylvl(i,j,d,pos(o))=phylvl(i,j,d,pos(o)) + . +.5*(fld(i,j,k)+fld(i,j,k+1)) + . *wghts(i,j,d) + enddo + enddo + enddo + enddo +c$OMP END PARALLEL DO + else + write (lp,*) 'cannot identify grid '//gridid//'!' + call xchalt('(accilv)') + stop '(accilv)' + endif + enddo +c + end subroutine accilv + + + subroutine inifld(iogrp) c implicit none @@ -4951,7 +5281,7 @@ subroutine inifld(iogrp) call inih2d(ACC_FICE(iogrp),'p',0.) call inih2d(ACC_TSRF(iogrp),'p',0.) call inih2d(ACC_TICE(iogrp),'p',0.) -c +c c --- initialisation of 3d layer fields call inilyr(ACC_UVEL(iogrp),'u',0.) call inilyr(ACC_DPU(iogrp),'u',0.) @@ -4981,6 +5311,9 @@ subroutine inifld(iogrp) call inilyr(ACC_DZ(iogrp),'p',0.) call inilyr(ACC_BFSQ(iogrp),'p',0.) call inilyr(ACC_DIFDIA(iogrp),'p',0.) + call inilyr(ACC_DIFVMO(iogrp),'p',0.) + call inilyr(ACC_DIFVHO(iogrp),'p',0.) + call inilyr(ACC_DIFVSO(iogrp),'p',0.) call inilyr(ACC_DIFINT(iogrp),'p',0.) call inilyr(ACC_DIFISO(iogrp),'p',0.) call inilyr(ACC_WFLX(iogrp),'p',0.) @@ -5015,6 +5348,9 @@ subroutine inifld(iogrp) c call inilvl(ACC_BFSQLVL(iogrp),'p',0.) call inilvl(ACC_DIFDIALVL(iogrp),'p',0.) + call inilvl(ACC_DIFVMOLVL(iogrp),'p',0.) + call inilvl(ACC_DIFVHOLVL(iogrp),'p',0.) + call inilvl(ACC_DIFVSOLVL(iogrp),'p',0.) call inilvl(ACC_DIFINTLVL(iogrp),'p',0.) call inilvl(ACC_DIFISOLVL(iogrp),'p',0.) call inilvl(ACC_DZLVL(iogrp),'p',0.) @@ -5029,25 +5365,25 @@ subroutine inifld(iogrp) #endif c end subroutine inifld - + subroutine finh2d(posacc,poswgt,gridid) c c --- ------------------------------------------------------------------ -c --- Description: finalise accumulation of weighted 2d fields -c --- +c --- Description: finalise accumulation of weighted 2d fields +c --- c --- Arguments: c --- real posacc (in) : position of accumulated field in buffer -c --- real poswgt (in) : position of accumulated weights +c --- real poswgt (in) : position of accumulated weights c --- char gridid (in) : grid identifier ('p','u' or 'v') c --- ------------------------------------------------------------------ c implicit none -c +c integer :: posacc,poswgt character :: gridid -c +c integer :: i,j,l real, parameter :: epsil=1e-11 c @@ -5092,27 +5428,27 @@ subroutine finh2d(posacc,poswgt,gridid) call xchalt('(finh2d)') stop '(finh2d)' endif -c +c end subroutine finh2d - + subroutine finlyr(posacc,poswgt,gridid) c c --- ------------------------------------------------------------------ -c --- Description: finalise accumulation of weighted 3d layer fields -c --- +c --- Description: finalise accumulation of weighted 3d layer fields +c --- c --- Arguments: c --- real posacc (in) : position of accumulated field in buffer -c --- real poswgt (in) : position of accumulated weights +c --- real poswgt (in) : position of accumulated weights c --- char gridid (in) : grid identifier ('p','u' or 'v') c --- ------------------------------------------------------------------ c implicit none -c +c integer :: posacc,poswgt character :: gridid -c +c integer :: i,j,k,l real, parameter :: epsil=1e-11 c @@ -5127,8 +5463,8 @@ subroutine finlyr(posacc,poswgt,gridid) do i=max(1,ifu(j,l)),min(ii,ilu(j,l)) if (phylyr(i,j,k,poswgt).gt.epsil) then phylyr(i,j,k,posacc)=phylyr(i,j,k,posacc)/ - . phylyr(i,j,k,poswgt) - else + . phylyr(i,j,k,poswgt) + else phylyr(i,j,k,posacc)=nf90_fill_double endif enddo @@ -5144,8 +5480,8 @@ subroutine finlyr(posacc,poswgt,gridid) do i=max(1,ifv(j,l)),min(ii,ilv(j,l)) if (phylyr(i,j,k,poswgt).gt.epsil) then phylyr(i,j,k,posacc)=phylyr(i,j,k,posacc)/ - . phylyr(i,j,k,poswgt) - else + . phylyr(i,j,k,poswgt) + else phylyr(i,j,k,posacc)=nf90_fill_double endif enddo @@ -5161,8 +5497,8 @@ subroutine finlyr(posacc,poswgt,gridid) do i=max(1,ifp(j,l)),min(ii,ilp(j,l)) if (phylyr(i,j,k,poswgt).gt.epsil) then phylyr(i,j,k,posacc)=phylyr(i,j,k,posacc)/ - . phylyr(i,j,k,poswgt) - else + . phylyr(i,j,k,poswgt) + else phylyr(i,j,k,posacc)=nf90_fill_double endif enddo @@ -5175,7 +5511,7 @@ subroutine finlyr(posacc,poswgt,gridid) call xchalt('(finlyr)') stop '(finlyr)' endif -c +c end subroutine finlyr @@ -5184,30 +5520,30 @@ subroutine wrth2d(pos,frmt,sfac,offs,cmpflg,msk,gridid, . vnm,vlngnm,vstdnm,vunits) c c --- ------------------------------------------------------------------ -c --- Description: writes diagnostic 2d field to file -c --- +c --- Description: writes diagnostic 2d field to file +c --- c --- Arguments: c --- int pos (in) : variable position in common buffer -c --- int frmt (in) : format/precision of output -c --- 0=field is not written -c --- 2=field is written as int2 with scale -c --- factor and offset +c --- int frmt (in) : format/precision of output +c --- 0=field is not written +c --- 2=field is written as int2 with scale +c --- factor and offset c --- 4=field is written as real4 c --- 8=field is written as real8 -c --- real sfac (in) : user defined scale factor to be applied -c --- real offs (in) : user defined offset to be added -c --- int cmpflg (in) : compression flag; only wet points are -c --- written if flag is set to 1 -c --- int msk (in) ocean mask +c --- real sfac (in) : user defined scale factor to be applied +c --- real offs (in) : user defined offset to be added +c --- int cmpflg (in) : compression flag; only wet points are +c --- written if flag is set to 1 +c --- int msk (in) ocean mask c --- char gridid (in) : grid identifier ('p','u' or 'v') -c --- char vnm (in) : variable name used in nc-file -c --- char vlngnm (in) : variable long name (skipped if ' ') -c --- char vstdnm (in) : variable standard name (skipped if ' ') -c --- char vunits (in) : variable units (skipped if ' ') +c --- char vnm (in) : variable name used in nc-file +c --- char vlngnm (in) : variable long name (skipped if ' ') +c --- char vstdnm (in) : variable standard name (skipped if ' ') +c --- char vunits (in) : variable units (skipped if ' ') c --- ------------------------------------------------------------------ c implicit none -c +c real :: sfac,offs integer :: frmt,cmpflg,pos character(len=*) :: gridid,vnm,vlngnm,vstdnm,vunits @@ -5218,7 +5554,7 @@ subroutine wrth2d(pos,frmt,sfac,offs,cmpflg,msk,gridid, c --- Check whether field should be written if (frmt.eq.0) return c -c --- Create dimension string +c --- Create dimension string if (cmpflg.eq.1) then dims=gridid(1:1)//'comp time' else @@ -5272,30 +5608,30 @@ subroutine wrtlyr(pos,frmt,sfac,offs,cmpflg,msk,gridid, . vnm,vlngnm,vstdnm,vunits) c c --- ------------------------------------------------------------------ -c --- Description: writes diagnostic layer field to file -c --- +c --- Description: writes diagnostic layer field to file +c --- c --- Arguments: c --- int pos (in) : variable position in common buffer -c --- int frmt (in) : format/precision of output -c --- 0=field is not written -c --- 2=field is written as int2 with scale -c --- factor and offset +c --- int frmt (in) : format/precision of output +c --- 0=field is not written +c --- 2=field is written as int2 with scale +c --- factor and offset c --- 4=field is written as real4 c --- 8=field is written as real8 -c --- real sfac (in) : user defined scale factor to be applied -c --- real offs (in) : user defined offset to be added -c --- int cmpflg (in) : compression flag; only wet points are -c --- written if flag is set to 1 -c --- int msk (in) ocean mask +c --- real sfac (in) : user defined scale factor to be applied +c --- real offs (in) : user defined offset to be added +c --- int cmpflg (in) : compression flag; only wet points are +c --- written if flag is set to 1 +c --- int msk (in) ocean mask c --- char gridid (in) : grid identifier ('p','u' or 'v') -c --- char vnm (in) : variable name used in nc-file -c --- char vlngnm (in) : variable long name (skipped if ' ') -c --- char vstdnm (in) : variable standard name (skipped if ' ') -c --- char vunits (in) : variable units (skipped if ' ') +c --- char vnm (in) : variable name used in nc-file +c --- char vlngnm (in) : variable long name (skipped if ' ') +c --- char vstdnm (in) : variable standard name (skipped if ' ') +c --- char vunits (in) : variable units (skipped if ' ') c --- ------------------------------------------------------------------ c implicit none -c +c real :: sfac,offs integer :: frmt,cmpflg,pos character(len=*) :: gridid,vnm,vlngnm,vstdnm,vunits @@ -5306,7 +5642,7 @@ subroutine wrtlyr(pos,frmt,sfac,offs,cmpflg,msk,gridid, c --- Check whether field should be written if (frmt.eq.0) return c -c --- Create dimension string +c --- Create dimension string if (cmpflg.eq.1) then dims=gridid(1:1)//'comp sigma time' else @@ -5360,30 +5696,30 @@ subroutine wrtlvl(pos,frmt,sfac,offs,cmpflg,msk,gridid, . vnm,vlngnm,vstdnm,vunits) c c --- ------------------------------------------------------------------ -c --- Description: writes diagnostic level field to file -c --- +c --- Description: writes diagnostic level field to file +c --- c --- Arguments: c --- int pos (in) : variable position in common buffer -c --- int frmt (in) : format/precision of output -c --- 0=field is not written -c --- 2=field is written as int2 with scale -c --- factor and offset +c --- int frmt (in) : format/precision of output +c --- 0=field is not written +c --- 2=field is written as int2 with scale +c --- factor and offset c --- 4=field is written as real4 c --- 8=field is written as real8 -c --- real sfac (in) : user defined scale factor to be applied -c --- real offs (in) : user defined offset to be added -c --- int cmpflg (in) : compression flag; only wet points are -c --- written if flag is set to 1 -c --- int msk (in) ocean mask +c --- real sfac (in) : user defined scale factor to be applied +c --- real offs (in) : user defined offset to be added +c --- int cmpflg (in) : compression flag; only wet points are +c --- written if flag is set to 1 +c --- int msk (in) ocean mask c --- char gridid (in) : grid identifier ('p','u' or 'v') -c --- char vnm (in) : variable name used in nc-file -c --- char vlngnm (in) : variable long name (skipped if ' ') -c --- char vstdnm (in) : variable standard name (skipped if ' ') -c --- char vunits (in) : variable units (skipped if ' ') +c --- char vnm (in) : variable name used in nc-file +c --- char vlngnm (in) : variable long name (skipped if ' ') +c --- char vstdnm (in) : variable standard name (skipped if ' ') +c --- char vunits (in) : variable units (skipped if ' ') c --- ------------------------------------------------------------------ c implicit none -c +c real :: sfac,offs integer :: frmt,cmpflg,pos character(len=*) :: gridid,vnm,vlngnm,vstdnm,vunits @@ -5394,7 +5730,7 @@ subroutine wrtlvl(pos,frmt,sfac,offs,cmpflg,msk,gridid, c --- Check whether field should be written if (frmt.eq.0) return c -c --- Create dimension string +c --- Create dimension string if (cmpflg.eq.1) then dims=gridid//'comp depth time' else @@ -5447,21 +5783,21 @@ end subroutine wrtlvl subroutine logh2d(pos,gridid,sfac,offs) c c --- ------------------------------------------------------------------ -c --- Description: replace 2d field with log10(field) -c --- +c --- Description: replace 2d field with log10(field) +c --- c --- Arguments: -c --- int pos (in) : field position in layer buffer +c --- int pos (in) : field position in layer buffer c --- char gridid (in) : grid identifier ('p','u' or 'v') -c --- real sfac (in) : scale factor to be applied before log10 -c --- real offs (in) : offset to be added before log10 +c --- real sfac (in) : scale factor to be applied before log10 +c --- real offs (in) : offset to be added before log10 c --- ------------------------------------------------------------------ c implicit none -c +c real :: sfac,offs integer :: pos character :: gridid -c +c integer :: i,j,l real :: epsil=1e-11 c @@ -5522,21 +5858,21 @@ end subroutine logh2d subroutine loglyr(pos,gridid,sfac,offs) c c --- ------------------------------------------------------------------ -c --- Description: replace 3d layer field with log10(field) -c --- +c --- Description: replace 3d layer field with log10(field) +c --- c --- Arguments: -c --- int pos (in) : field position in layer buffer +c --- int pos (in) : field position in layer buffer c --- char gridid (in) : grid identifier ('p','u' or 'v') -c --- real sfac (in) : scale factor to be applied before log10 -c --- real offs (in) : offset to be added before log10 +c --- real sfac (in) : scale factor to be applied before log10 +c --- real offs (in) : offset to be added before log10 c --- ------------------------------------------------------------------ c implicit none -c +c real :: sfac,offs integer :: pos character :: gridid -c +c integer :: i,j,k,l real :: epsil=1e-11 c @@ -5603,21 +5939,21 @@ end subroutine loglyr subroutine loglvl(pos,gridid,sfac,offs) c c --- ------------------------------------------------------------------ -c --- Description: replace 3d level field with log10(field) -c --- +c --- Description: replace 3d level field with log10(field) +c --- c --- Arguments: -c --- int pos (in) : field position in layer buffer +c --- int pos (in) : field position in layer buffer c --- char gridid (in) : grid identifier ('p','u' or 'v') -c --- real sfac (in) : scale factor to be applied before log10 -c --- real offs (in) : offset to be added before log10 +c --- real sfac (in) : scale factor to be applied before log10 +c --- real offs (in) : offset to be added before log10 c --- ------------------------------------------------------------------ c implicit none -c +c real :: sfac,offs integer :: pos character :: gridid -c +c integer :: i,j,k,l real :: epsil=1e-11 c @@ -5684,10 +6020,10 @@ end subroutine loglvl subroutine msklvl(pos,gridid) c c --- ------------------------------------------------------------------ -c --- Description: set sea floor points to NaN in level fields -c --- +c --- Description: set sea floor points to NaN in level fields +c --- c --- Arguments: -c --- int pos (in) : field position in level buffer +c --- int pos (in) : field position in level buffer c --- char gridid (in) : grid identifier ('p','u' or 'v') c --- ------------------------------------------------------------------ c @@ -5695,14 +6031,14 @@ subroutine msklvl(pos,gridid) c integer :: pos character :: gridid -c +c integer :: i,j,k logical :: iniflg=.true. integer, dimension(idm,jdm) :: kmaxu,kmaxv,kmaxp real, parameter :: mskval=nf90_fill_double c save iniflg,kmaxu,kmaxv,kmaxp -c +c c --- Check whether field should be processed if (pos.eq.0) return c @@ -6133,13 +6469,37 @@ subroutine definevar(irec,iogrp,cmpflg,timeunits,calendar) c if (LYR_DIFDIA(iogrp).eq.2) then call ncdefvar3d(LYR_DIFDIA(iogrp),cmpflg,'p','difdia', - . 'Diapycnal diffusivity',' ','log10(m2 s-1)',1) + . 'Vertical diffusivity',' ','log10(m2 s-1)',1) else call ncdefvar3d(LYR_DIFDIA(iogrp),cmpflg,'p','difdia', - . 'Diapycnal diffusivity',' ','m2 s-1',1) + . 'Vertical diffusivity',' ','m2 s-1',1) + endif +c + if (LYR_DIFVMO(iogrp).eq.2) then + call ncdefvar3d(LYR_DIFVMO(iogrp),cmpflg,'p','difvmo', + . 'Vertical momentum diffusivity',' ','log10(m2 s-1)',1) + else + call ncdefvar3d(LYR_DIFVMO(iogrp),cmpflg,'p','difvmo', + . 'Vertical momentum diffusivity',' ','m2 s-1',1) + endif +c + if (LYR_DIFVHO(iogrp).eq.2) then + call ncdefvar3d(LYR_DIFVHO(iogrp),cmpflg,'p','difvho', + . 'Vertical heat diffusivity',' ','log10(m2 s-1)',1) + else + call ncdefvar3d(LYR_DIFVHO(iogrp),cmpflg,'p','difvho', + . 'Vertical heat diffusivity',' ','m2 s-1',1) endif c -#if defined TKE + if (LYR_DIFVSO(iogrp).eq.2) then + call ncdefvar3d(LYR_DIFVSO(iogrp),cmpflg,'p','difvso', + . 'Vertical salt diffusivity',' ','log10(m2 s-1)',1) + else + call ncdefvar3d(LYR_DIFVSO(iogrp),cmpflg,'p','difvso', + . 'Vertical salt diffusivity',' ','m2 s-1',1) + endif +c +#if defined TKE call ncdefvar3d(LYR_TKE(iogrp),cmpflg,'p','tke', . 'TKE','Turbulent kinetic energy','m2 s-2',1) @@ -6163,7 +6523,7 @@ subroutine definevar(irec,iogrp,cmpflg,timeunits,calendar) c call ncdefvar3d(LVL_VVEL(iogrp),cmpflg,'v','vvellvl', . 'Velocity y-component',' ','m s-1',2) -c +c call ncdefvar3d(LVL_UFLX(iogrp),cmpflg,'u','uflxlvl', . 'Mass flux in x-direction',' ','kg s-1',2) c @@ -6252,10 +6612,34 @@ subroutine definevar(irec,iogrp,cmpflg,timeunits,calendar) c if (LVL_DIFDIA(iogrp).eq.2) then call ncdefvar3d(LVL_DIFDIA(iogrp),cmpflg,'p','difdialvl', - . 'Diapycnal diffusivity',' ','log10(m2 s-1)',2) + . 'Vertical diffusivity',' ','log10(m2 s-1)',2) else call ncdefvar3d(LVL_DIFDIA(iogrp),cmpflg,'p','difdialvl', - . 'Diapycnal diffusivity',' ','m2 s-1',2) + . 'Vertical diffusivity',' ','m2 s-1',2) + endif +c + if (LVL_DIFVMO(iogrp).eq.2) then + call ncdefvar3d(LVL_DIFVMO(iogrp),cmpflg,'p','difvmolvl', + . 'Vertical momentum diffusivity',' ','log10(m2 s-1)',2) + else + call ncdefvar3d(LVL_DIFVMO(iogrp),cmpflg,'p','difvmolvl', + . 'Vertical momentum diffusivity',' ','m2 s-1',2) + endif +c + if (LVL_DIFVHO(iogrp).eq.2) then + call ncdefvar3d(LVL_DIFVHO(iogrp),cmpflg,'p','difvholvl', + . 'Vertical heat diffusivity',' ','log10(m2 s-1)',2) + else + call ncdefvar3d(LVL_DIFVHO(iogrp),cmpflg,'p','difvholvl', + . 'Vertical heat diffusivity',' ','m2 s-1',2) + endif +c + if (LVL_DIFVSO(iogrp).eq.2) then + call ncdefvar3d(LVL_DIFVSO(iogrp),cmpflg,'p','difvsolvl', + . 'Vertical salt diffusivity',' ','log10(m2 s-1)',2) + else + call ncdefvar3d(LVL_DIFVSO(iogrp),cmpflg,'p','difvsolvl', + . 'Vertical salt diffusivity',' ','m2 s-1',2) endif c #if defined(TRC) && defined(TKE) @@ -6267,7 +6651,7 @@ subroutine definevar(irec,iogrp,cmpflg,timeunits,calendar) c #endif c -c --- define meridional transports +c --- define meridional transports if (MSC_MMFLXL(iogrp).ne.0) then call ncdefvar('mmflxl','lat sigma region time',ndouble,8) call ncattr('long_name', @@ -6329,7 +6713,7 @@ subroutine definevar(irec,iogrp,cmpflg,timeunits,calendar) call ncattr('units','kg s-1') endif c -c --- store section transports +c --- store section transports if (MSC_VOLTR(iogrp).ne.0) then call ncdefvar('voltr','section time',ndouble,8) call ncattr('long_name','Section transports') @@ -6374,7 +6758,7 @@ subroutine definevar(irec,iogrp,cmpflg,timeunits,calendar) call ncdefvar3d(max(LYR_IDLAGE(iogrp),LYR_TRC(iogrp)),cmpflg, . 'p','dp_trc','Layer pressure thickness',' ','Pa',1) endif -c --- ideal age tracer +c --- ideal age tracer #if IDLAGE call ncdefvar3d(LYR_IDLAGE(iogrp),cmpflg,'p','idlage', . 'Ideal age','sea_water_age_since_surface_contact','year',1) diff --git a/phy/rdlim.F b/phy/rdlim.F index cc7cc6c6..c7ca5c6c 100644 --- a/phy/rdlim.F +++ b/phy/rdlim.F @@ -54,7 +54,8 @@ subroutine rdlim use mod_tidaldissip, only: tdfile use mod_dia use mod_ben02, only: atm_path, atm_path_len - use mod_vcoord, only: readnml_vcoord + use mod_vcoord, only: vcoord_type_tag, isopyc_bulkml, + . cntiso_hybrid, readnml_vcoord use mod_cesm, only: runid_cesm, ocn_cpl_dt_cesm, nstep_in_cpl, . smtfrc use mod_pointtest, only: itest, jtest @@ -81,10 +82,10 @@ subroutine rdlim . itest,jtest, . rstfrq,rstfmt,rstcmp,iotype c -c --- read limits and diaphy namelists +c --- read limits namelist +c if (mnproc.eq.1) then c - GLB_AVEPERIO=-999 nlfnm='ocn_in'//trim(inst_suffix) inquire(file=nlfnm,exist=fexist) if (fexist) then @@ -102,7 +103,6 @@ subroutine rdlim endif endif read (unit=nfu,nml=LIMITS) - read (unit=nfu,nml=DIAPHY) close (unit=nfu) c c --- - print limits namelist to stdout @@ -184,18 +184,134 @@ subroutine rdlim write (lp,*) 'RSTFMT',RSTFMT write (lp,*) 'RSTCMP',RSTCMP write (lp,*) 'IOTYPE',IOTYPE + write (lp,*) +c + endif +c +c --- broadcast variables set by limits namelist +c + call xcbcst(nday1) + call xcbcst(nday2) + call xcbcst(idate) + call xcbcst(idate0) + call xcbcst(runid) + call xcbcst(expcnf) + call xcbcst(runtyp) + call xcbcst(grfile) + call xcbcst(icfile) + call xcbcst(pref) + call xcbcst(baclin) + call xcbcst(batrop) + call xcbcst(mdv2hi) + call xcbcst(mdv2lo) + call xcbcst(mdv4hi) + call xcbcst(mdv4lo) + call xcbcst(mdc2hi) + call xcbcst(mdc2lo) + call xcbcst(vsc2hi) + call xcbcst(vsc2lo) + call xcbcst(vsc4hi) + call xcbcst(vsc4lo) + call xcbcst(cbar) + call xcbcst(cb) + call xcbcst(cwbdts) + call xcbcst(cwbdls) + call xcbcst(mommth) + call xcbcst(eitmth) + call xcbcst(edritp) + call xcbcst(bmcmth) + call xcbcst(rmpmth) + call xcbcst(edwmth) + call xcbcst(mlrttp) + call xcbcst(edsprs) + call xcbcst(egc) + call xcbcst(eggam) + call xcbcst(eglsmn) + call xcbcst(egmndf) + call xcbcst(egmxdf) + call xcbcst(egidfq) + call xcbcst(ri0) + call xcbcst(rm0) + call xcbcst(rm5) + call xcbcst(ce) + call xcbcst(bdmtyp) + call xcbcst(bdmc1) + call xcbcst(bdmc2) + call xcbcst(tdfile) + call xcbcst(tkepf) + call xcbcst(niwgf) + call xcbcst(niwbf) + call xcbcst(niwlf) + call xcbcst(swamth) + call xcbcst(jwtype) + call xcbcst(chlopt) + call xcbcst(ccfile) + call xcbcst(trxday) + call xcbcst(srxday) + call xcbcst(trxdpt) + call xcbcst(srxdpt) + call xcbcst(trxlim) + call xcbcst(srxlim) + call xcbcst(aptflx) + call xcbcst(apsflx) + call xcbcst(ditflx) + call xcbcst(disflx) + call xcbcst(srxbal) + call xcbcst(scfile) + call xcbcst(smtfrc) + call xcbcst(sprfac) + call xcbcst(atm_path) + call xcbcst(itest) + call xcbcst(jtest) + call xcbcst(rstfrq) + call xcbcst(rstfmt) + call xcbcst(rstcmp) + call xcbcst(iotype) +c +c --- read vertical coordinate namelist variables + call readnml_vcoord +c +c --- read diaphy namelist +c + if (mnproc.eq.1) then +c + GLB_AVEPERIO(:)=-999 + open (unit=nfu,file=nlfnm,status='old',action='read',recl=80) + read (unit=nfu,nml=DIAPHY,iostat=ios) + close (unit=nfu) c -c --- - determine number of io groups and print diaphy namelist +c --- - determine number of io groups nphy=0 do n=1,nphymax if (GLB_AVEPERIO(n).ne.-999) nphy=nphy+1 enddo +c +c --- - modify diaphy namelist variables based on dependency with other +c --- - variables set in namelists + select case (vcoord_type_tag) + case (isopyc_bulkml) + LYR_DIFVMO(1:nphy)=0 + LYR_DIFVHO(1:nphy)=0 + LYR_DIFVSO(1:nphy)=0 + LVL_DIFVMO(1:nphy)=0 + LVL_DIFVHO(1:nphy)=0 + LVL_DIFVSO(1:nphy)=0 + case (cntiso_hybrid) + 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.eq.0.) then H2D_SURRLX(1:nphy)=0 endif if (srxday.eq.0.) then H2D_SALRLX(1:nphy)=0 endif +c +c --- - print diaphy namelist write (lp,*) write (lp,*) 'rdlim: BLOM DIAPHY NAMELIST GROUP:' write (lp,*) 'GLB_FNAMETAG',GLB_FNAMETAG(1:nphy) @@ -350,85 +466,7 @@ subroutine rdlim c endif c -c --- broadcast variables set by limits and diaphy namelists -c - call xcbcst(nday1) - call xcbcst(nday2) - call xcbcst(idate) - call xcbcst(idate0) - call xcbcst(runid) - call xcbcst(expcnf) - call xcbcst(runtyp) - call xcbcst(grfile) - call xcbcst(icfile) - call xcbcst(pref) - call xcbcst(baclin) - call xcbcst(batrop) - call xcbcst(mdv2hi) - call xcbcst(mdv2lo) - call xcbcst(mdv4hi) - call xcbcst(mdv4lo) - call xcbcst(mdc2hi) - call xcbcst(mdc2lo) - call xcbcst(vsc2hi) - call xcbcst(vsc2lo) - call xcbcst(vsc4hi) - call xcbcst(vsc4lo) - call xcbcst(cbar) - call xcbcst(cb) - call xcbcst(cwbdts) - call xcbcst(cwbdls) - call xcbcst(mommth) - call xcbcst(eitmth) - call xcbcst(edritp) - call xcbcst(bmcmth) - call xcbcst(rmpmth) - call xcbcst(edwmth) - call xcbcst(mlrttp) - call xcbcst(edsprs) - call xcbcst(egc) - call xcbcst(eggam) - call xcbcst(eglsmn) - call xcbcst(egmndf) - call xcbcst(egmxdf) - call xcbcst(egidfq) - call xcbcst(ri0) - call xcbcst(rm0) - call xcbcst(rm5) - call xcbcst(ce) - call xcbcst(bdmtyp) - call xcbcst(bdmc1) - call xcbcst(bdmc2) - call xcbcst(tdfile) - call xcbcst(tkepf) - call xcbcst(niwgf) - call xcbcst(niwbf) - call xcbcst(niwlf) - call xcbcst(swamth) - call xcbcst(jwtype) - call xcbcst(chlopt) - call xcbcst(ccfile) - call xcbcst(trxday) - call xcbcst(srxday) - call xcbcst(trxdpt) - call xcbcst(srxdpt) - call xcbcst(trxlim) - call xcbcst(srxlim) - call xcbcst(aptflx) - call xcbcst(apsflx) - call xcbcst(ditflx) - call xcbcst(disflx) - call xcbcst(srxbal) - call xcbcst(scfile) - call xcbcst(smtfrc) - call xcbcst(sprfac) - call xcbcst(atm_path) - call xcbcst(itest) - call xcbcst(jtest) - call xcbcst(rstfrq) - call xcbcst(rstfmt) - call xcbcst(rstcmp) - call xcbcst(iotype) +c --- broadcast variables set by diaphy namelist c call xcbcst(H2D_ABSWND) call xcbcst(H2D_ALB) @@ -688,9 +726,6 @@ subroutine rdlim atm_path_len=atm_path_len-1 endif c -c --- read vertical coordinate namelist variables - call readnml_vcoord -c c --- initialize time variables call init_timevars c From b1de0af65f5737dfb9cc7eff34370b1fe97e7503 Mon Sep 17 00:00:00 2001 From: Mehmet Ilicak Date: Wed, 29 Sep 2021 13:09:12 +0200 Subject: [PATCH 005/366] Bottom Brunt-Vaisala frequency computation added. CVMIX CPP is removed. New method to compute interface heights has been implemented. --- meson.build | 3 --- meson_options.txt | 4 +-- phy/mod_difest.F | 60 ++++++++++++++++++++++++------------------- phy/mod_diffusion.F90 | 10 +------- 4 files changed, 37 insertions(+), 40 deletions(-) diff --git a/meson.build b/meson.build index 6a87dba9..3958cf0c 100644 --- a/meson.build +++ b/meson.build @@ -92,9 +92,6 @@ if get_option('turbclo').length() > 0 if get_option('turbclo').contains('advection') add_project_arguments('-DTKEADV', language: 'fortran') endif - if get_option('turbclo').contains('cvmix') - add_project_arguments('-DCVMIX', language: 'fortran') - endif if get_option('turbclo').contains('isodif') add_project_arguments('-DTKEIDF', language: 'fortran') endif diff --git a/meson_options.txt b/meson_options.txt index 116c870a..ee2e89b2 100644 --- a/meson_options.txt +++ b/meson_options.txt @@ -11,9 +11,9 @@ option('driver', type: 'combo', choices: ['nocoupler', 'noforc'], value: 'nocoupler') # List of BLOM options option('turbclo', type: 'array', - choices: ['oneeq', 'twoeq', 'advection', 'isodif', 'cvmix'], + choices: ['oneeq', 'twoeq', 'advection', 'isodif'], description: 'Turbulent closure options', value: ['oneeq', - 'advection', 'cvmix']) + 'advection']) option('iage', type: 'boolean', description: 'Enable ideal age tracer', value: true) option('ecosys', type: 'boolean', diff --git a/phy/mod_difest.F b/phy/mod_difest.F index e52f33a8..0eb80346 100644 --- a/phy/mod_difest.F +++ b/phy/mod_difest.F @@ -42,7 +42,6 @@ module mod_difest use mod_seaice, only: ficem use mod_utility, only: util1 use mod_checksum, only: csdiag, chksummsk -#if defined(CVMIX) use mod_diffusion, only: Kvisc_m, Kdiff_t, Kdiff_s use CVMix_kpp, only : CVMix_coeffs_kpp use CVMix_kpp, only : CVMix_kpp_compute_turbulent_scales @@ -60,9 +59,8 @@ module mod_difest use CVMix_kpp, only : CVMix_kpp_params_type use CVMix_kpp, only : CVMix_put_kpp use CVMix_kpp, only : CVMix_init_kpp - use CVMix_put_get, only : CVMix_put + use CVMix_put_get, only : CVMix_put use mod_cmnfld, only: bfsqi -#endif #if defined(TRC) && defined(TKE) use mod_tracers, only: itrtke, itrgls, trc use mod_tke, only: gls_cmu0, Pr_t, tke_min, gls_psi_min, gls_p, @@ -77,13 +75,11 @@ module mod_difest c implicit none c -#ifdef CVMIX type(CVMix_tidal_params_type) :: CVMix_tidal_params type(CVMix_global_params_type) :: CVMix_glb_params !=min_thicknes + cellHeight(k) = iFaceHeight(k) - 0.5 * dh + iFaceHeight(k+1) = iFaceHeight(k) - dh + depth_int(k+1) = -iFaceHeight(k+1) ! compute rho_1d at the interfaces rho_1d(k)=rho(p(i,j,k),temp(i,j,kn),saln(i,j,kn)) @@ -479,6 +482,13 @@ subroutine difest_vertical_hyb(m,n,mm,nn,k1m,k1n) ! temporary variable bvfsq_i(k) = bfsqi(i,j,k) bvf_i(k) = sqrt( max( bvfsq_i(k), 0.) ) +c --- ------- Accumulate Brunt-Vaisala frequency in a region near the +c --- ------- bottom + q=max(0.,p(i,j,k+1)-max(p(i,j,kk+1)-dpnbav,p(i,j,k))) + if (q.gt.0.) then + bvfbot=bvfbot+bvf_i(k)*q + dps=dps+q + endif c --- ------- Local gradient Richardson number c DU = (u_p(i,j,k) - u_p(i,j,km1)) @@ -491,8 +501,7 @@ subroutine difest_vertical_hyb(m,n,mm,nn,k1m,k1n) c else enddo ! k - ! Mehmet bvfbot has to be defined again - bvfbot(i) = 1.0 + if(dps.gt.0.) bvfbot=bvfbot/dps ! convert cm2/s2 to m2/s2 deltaU2 = deltaU2*1e-4 @@ -518,7 +527,7 @@ subroutine difest_vertical_hyb(m,n,mm,nn,k1m,k1n) . efficiency=dmxeff, local_mixing_frac=tdmq) call CVMix_compute_Simmons_invariant(nlev=kk, - . energy_flux=twedon(i,j)*bvfbot(i)*1e-3, + . energy_flux=twedon(i,j)*bvfbot*1e-3, . rho=CVMix_glb_params%FreshWaterDensity, . SimmonsCoeff = Simmons_coeff, VertDep = vert_dep, . zw = iFaceHeight, zt = cellHeight, @@ -658,7 +667,6 @@ subroutine difest_vertical_hyb(m,n,mm,nn,k1m,k1n) . + Kd_tidal(:) + Kt_kpp(:) Kdiff_s(i,j,:) = Kd_col(:) + Kd_conv(:) + Kd_shr(:) . + Kd_tidal(:) + Ks_kpp(:) -# endif enddo enddo c end of single column diff --git a/phy/mod_diffusion.F90 b/phy/mod_diffusion.F90 index 7cbf7177..78aec162 100644 --- a/phy/mod_diffusion.F90 +++ b/phy/mod_diffusion.F90 @@ -74,12 +74,10 @@ module mod_diffusion difiso, & ! Isopycnal diffusivity [cm2 s-1]. difdia ! Diapycnal diffusivity [cm2 s-1]. -#if defined(CVMIX) real(r8), dimension(1 - nbdy:idm + nbdy,1 - nbdy:jdm + nbdy, kdm+1) :: & Kvisc_m, & ! momentum eddy viscosity [cm2 s-1]. Kdiff_t, & ! temperature eddy diffusivity [cm2 s-1]. Kdiff_s ! salinity eddy diffusivity [cm2 s-1]. -#endif real(r8), dimension(1 - nbdy:idm + nbdy,1 - nbdy:jdm + nbdy) :: & difmxp, & ! Maximum lateral diffusivity at p-points [cm2 s-1]. @@ -114,11 +112,7 @@ module mod_diffusion difint, difiso, difdia, difmxp, difmxq, difwgt, & umfltd, vmfltd, utfltd, vtfltd, utflld, vtflld, & usfltd, vsfltd, usflld, vsflld, & - inivar_diffusion - -#if defined(CVMIX) - public :: Kvisc_m, Kdiff_t, Kdiff_s -#endif + inivar_diffusion, Kvisc_m, Kdiff_t, Kdiff_s contains @@ -158,7 +152,6 @@ subroutine inivar_diffusion enddo enddo enddo -#if defined(CVMIX) do j = 1 - nbdy, jj + nbdy do k = 1, kk+1 do i = 1 - nbdy, ii + nbdy @@ -168,7 +161,6 @@ subroutine inivar_diffusion enddo enddo enddo -#endif !$omp end parallel do ! Initialize diffusive fluxes at points located upstream and downstream (in From 258ea7da708bdcf95c141a1cc866f0dfd8eecb27 Mon Sep 17 00:00:00 2001 From: Mats Bentsen Date: Thu, 30 Sep 2021 00:10:55 +0200 Subject: [PATCH 006/366] Modified GitHub workflow to checkout submodules. --- .github/workflows/ci.yml | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index 268493e0..63ac0786 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -39,6 +39,8 @@ jobs: - name: Checkout code uses: actions/checkout@v2 + with: + submodules: 'recursive' - name: Build env: @@ -132,6 +134,8 @@ jobs: - name: Checkout code uses: actions/checkout@v2 + with: + submodules: 'recursive' - name: Build with Intel compilers run: | From 43884d32350877b54a4f4c93f5648829366ec196 Mon Sep 17 00:00:00 2001 From: Mehmet Ilicak Date: Fri, 1 Oct 2021 11:57:06 +0200 Subject: [PATCH 007/366] hcorr is added to layer thickness --- phy/mod_difest.F | 1 + 1 file changed, 1 insertion(+) diff --git a/phy/mod_difest.F b/phy/mod_difest.F index 0eb80346..902db7b9 100644 --- a/phy/mod_difest.F +++ b/phy/mod_difest.F @@ -422,6 +422,7 @@ subroutine difest_vertical_hyb(m,n,mm,nn,k1m,k1n) ! New method to compute interface location, thicknesses dh = dp(i,j,kn)/onem dh = dh + hcorr ! Take away the accumulated error (could temporarily make dh<0) + hcorr = min(dh - 1e-10, 0.) ! If inflating then hcorr<0 dh = max(dh, 1e-10) ! Limit increment dh>=min_thicknes cellHeight(k) = iFaceHeight(k) - 0.5 * dh iFaceHeight(k+1) = iFaceHeight(k) - dh From 7ddfb795a38d15415fb0bc2c356a410433861afd Mon Sep 17 00:00:00 2001 From: Mats Bentsen Date: Sun, 3 Oct 2021 16:34:10 +0200 Subject: [PATCH 008/366] Fixed OpenMP parallel region. --- phy/mod_diffusion.F90 | 2 -- 1 file changed, 2 deletions(-) diff --git a/phy/mod_diffusion.F90 b/phy/mod_diffusion.F90 index 78aec162..a8941ad0 100644 --- a/phy/mod_diffusion.F90 +++ b/phy/mod_diffusion.F90 @@ -151,8 +151,6 @@ subroutine inivar_diffusion vsflld(i, j, k) = spval enddo enddo - enddo - do j = 1 - nbdy, jj + nbdy do k = 1, kk+1 do i = 1 - nbdy, ii + nbdy Kvisc_m(i, j, k) = epsil From ba6c4881667babef2f424df5093ba645a5c16277 Mon Sep 17 00:00:00 2001 From: Mats Bentsen Date: Sun, 3 Oct 2021 23:40:16 +0200 Subject: [PATCH 009/366] Removed redundant code in module for diffusivity estimation. --- phy/mod_difest.F | 416 ++++++++++------------------------------------- 1 file changed, 87 insertions(+), 329 deletions(-) diff --git a/phy/mod_difest.F b/phy/mod_difest.F index 902db7b9..9ec40846 100644 --- a/phy/mod_difest.F +++ b/phy/mod_difest.F @@ -215,32 +215,83 @@ end subroutine ini_difest subroutine difest(m,n,mm,nn,k1m,k1n) c c --- ------------------------------------------------------------------ -c --- estimate layer interface, isopycnal, and diapycnal diffusivities +c --- estimate diffusivities for eddy-induced transport, layer-wise +c --- diffusion and vertical diffusion c --- ------------------------------------------------------------------ -c c integer m,n,mm,nn,k1m,k1n c -c --- parameters: - + integer i,j,k,l,kn +c +c --- update halos of various fields + call xctilr(u, 1,2*kk, 2,2, halo_uv) + call xctilr(v, 1,2*kk, 2,2, halo_vv) + call xctilr(ubflxs_p, 1,2, 2,2, halo_uv) + call xctilr(vbflxs_p, 1,2, 2,2, halo_vv) + call xctilr(pbu, 1,2, 2,2, halo_us) + call xctilr(pbv, 1,2, 2,2, halo_vs) +c +c --- ------------------------------------------------------------------ +c --- Update layer interface pressure. +c --- ------------------------------------------------------------------ +c +c$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 +c$OMP END PARALLEL DO +c +c --- ------------------------------------------------------------------ +c --- Estimate friction velocity cubed. +c --- ------------------------------------------------------------------ +c +c$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)) + ustar3(i,j)=ustar(i,j)**3 + enddo + enddo + enddo +c$OMP END PARALLEL DO +c if (vcoord_type_tag == isopyc_bulkml) then - call difest_lateral_iso(m,n,mm,nn,k1m,k1n) + call difest_lateral_iso(m,n,mm,nn,k1m,k1n) elseif (vcoord_type_tag == cntiso_hybrid) then - call difest_lateral_hyb(m,n,mm,nn,k1m,k1n) + call difest_lateral_hyb(m,n,mm,nn,k1m,k1n) else - print*,'this vcoord_type_tag option has not been implemented' - stop + if (mnproc.eq.1) then + write (lp,*) 'difest: unsupported vertical coordinate!' + endif + call xcstop('(difest)') + stop '(difest)' endif - +c if (vcoord_type_tag == isopyc_bulkml) then - call difest_vertical_iso(m,n,mm,nn,k1m,k1n) + call difest_vertical_iso(m,n,mm,nn,k1m,k1n) elseif (vcoord_type_tag == cntiso_hybrid) then - call difest_vertical_hyb(m,n,mm,nn,k1m,k1n) + call difest_vertical_hyb(m,n,mm,nn,k1m,k1n) else - print*,'this vcoord_type_tag option has not been implemented' - stop + if (mnproc.eq.1) then + write (lp,*) 'difest: unsupported vertical coordinate!' + endif + call xcstop('(difest)') + stop '(difest)' + endif +c + if (csdiag) then + if (mnproc.eq.1) then + write (lp,*) 'difest:' + endif + call chksummsk(ustar3,ip,1,'ustar3') endif - c end subroutine difest c @@ -253,25 +304,9 @@ subroutine difest_vertical_hyb(m,n,mm,nn,k1m,k1n) c integer m,n,mm,nn,k1m,k1n c - real, dimension(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy,kdm) :: - . dv2 - real, dimension(1-nbdy:idm+nbdy,kdm) :: - . du2,drho,bvfsq,bvf,egr real, dimension(kdm+1) :: rig - real, dimension(1-nbdy:idm+nbdy) :: - . tup,pup,sup,cr,bcrrd,afeql,egrs,egrup,dfints,urmse, - . cpse,dfddsu,dfddsl - integer, dimension(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy,kdm) :: - . mskv - integer, dimension(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy) :: - . kfil,kmax - integer, dimension(1-nbdy:idm+nbdy,kdm) :: - . msku - integer, dimension(1-nbdy:idm+nbdy) :: - . kfpl,klpl integer i,j,k,l,kn - real q,plo,tlo,slo,rhisc,els,egrlo,umnsc,esfac,nus,nub, - . vsf,nusm,ust,mols,h,sg,zeta,phis,ws + real q c type(CVMix_tidal_params_type) :: CVMix_tidal_params real, dimension(kdm+1) :: depth_int @@ -309,33 +344,6 @@ subroutine difest_vertical_hyb(m,n,mm,nn,k1m,k1n) integer ki, kki, ksfc, ktmp, kOBL, kn1 real, dimension(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy) :: hOBL real, dimension(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy) :: OBLdepth -#if defined(TRC) && defined(TKE) - real gls_c3,tke_prod,tke_buoy,tke_epsilon,Ls_unlmt,Ls_lmt,tke_Q, - . Gm,Gh,Sm,Sh,cff,ql -# ifdef GLS - real gls_prod,gls_buoy,gls_diss,gls_Q -# endif -#endif -c -c$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 -c$OMP END PARALLEL DO -c - call xctilr(u, 1,2*kk, 2,2, halo_uv) - call xctilr(v, 1,2*kk, 2,2, halo_vv) - call xctilr(ubflxs_p, 1,2, 2,2, halo_uv) - call xctilr(vbflxs_p, 1,2, 2,2, halo_vv) - call xctilr(pbu, 1,2, 2,2, halo_us) - call xctilr(pbv, 1,2, 2,2, halo_vs) c surf_layer_ext = 0.1 bl1 = 8e-5 @@ -349,22 +357,6 @@ subroutine difest_vertical_hyb(m,n,mm,nn,k1m,k1n) c call niw_ke_tendency(m,n,mm,nn,k1m,k1n) c -c -c$OMP PARALLEL DO PRIVATE( -c$OMP+ l,i,kfpl,klpl,k,kn,du2,msku,q,tup,pup,sup,cr,plo,tlo,slo,bcrrd, -c$OMP+ afeql,bvfbot,dps,drho,bvfsq,bvf,rig,egrs,egr,egrup,egrlo,dfints, -c$OMP+ rhisc,els,urmse,cpse,umnsc,esfac,dfddsu,dfddsl,nub,nus,ust,vsf, -c$OMP+ nusm,mols,h,sg,zeta,phis,ws -#if defined(TRC) && defined(TKE) -c$OMP+ ,gls_c3,tke_epsilon,tke_prod,tke_buoy,tke_Q,Ls_unlmt,Ls_lmt,Gh, -c$OMP+ Gm,cff,Sm,Sh,ql -# ifdef GLS -c$OMP+ ,gls_prod,gls_buoy,gls_diss,gls_Q -# endif -#endif -c$OMP+ ) -c -c c single column diffusivity do j=1,jj do l=1,isp(j) @@ -673,8 +665,6 @@ subroutine difest_vertical_hyb(m,n,mm,nn,k1m,k1n) c end of single column c enddo ! j-index -c$OMP END PARALLEL DO -c c end subroutine difest_vertical_hyb c @@ -691,10 +681,9 @@ subroutine difest_lateral_hyb(m,n,mm,nn,k1m,k1n) real, dimension(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy,kdm) :: . dv2 real, dimension(1-nbdy:idm+nbdy,kdm) :: - . du2,drho,bvfsq,bvf,rig,egr + . du2,drho,rig,egr real, dimension(1-nbdy:idm+nbdy) :: - . tup,pup,sup,cr,bcrrd,afeql,bvfbot,dps,egrs,egrup,dfints,urmse, - . cpse,dfddsu,dfddsl + . tup,pup,sup,cr,bcrrd,afeql,dps,egrs,egrup,dfints,urmse,cpse integer, dimension(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy,kdm) :: . mskv integer, dimension(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy) :: @@ -704,47 +693,7 @@ subroutine difest_lateral_hyb(m,n,mm,nn,k1m,k1n) integer, dimension(1-nbdy:idm+nbdy) :: . kfpl,klpl integer i,j,k,l,kn - real q,plo,tlo,slo,rhisc,els,egrlo,umnsc,esfac,nus,nub,nut,nuls, - . vsf,nusm,ust,mols,h,sg,zeta,phis,ws -c -c$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 -c$OMP END PARALLEL DO -c - call xctilr(u, 1,2*kk, 2,2, halo_uv) - call xctilr(v, 1,2*kk, 2,2, halo_vv) - call xctilr(ubflxs_p, 1,2, 2,2, halo_uv) - call xctilr(vbflxs_p, 1,2, 2,2, halo_vv) - call xctilr(pbu, 1,2, 2,2, halo_us) - call xctilr(pbv, 1,2, 2,2, halo_vs) -c -c --- ------------------------------------------------------------------ -c --- Estimate energy input by near-inertial waves. -c --- ------------------------------------------------------------------ -c -c -c --- ------------------------------------------------------------------ -c --- Estimate friction velocity cubed. -c --- ------------------------------------------------------------------ -c -c$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)) - ustar3(i,j)=ustar(i,j)**3 - enddo - enddo - enddo -c$OMP END PARALLEL DO + real q,plo,tlo,slo,rhisc,els,egrlo,umnsc,esfac c c --- Locate the range of layers to be considered in the computation of c --- diffusivities. @@ -853,10 +802,8 @@ subroutine difest_lateral_hyb(m,n,mm,nn,k1m,k1n) c c$OMP PARALLEL DO PRIVATE( c$OMP+ l,i,kfpl,klpl,k,kn,du2,msku,q,tup,pup,sup,cr,plo,tlo,slo,bcrrd, -c$OMP+ afeql,bvfbot,dps,drho,bvfsq,bvf,rig,egrs,egr,egrup,egrlo,dfints, -c$OMP+ rhisc,els,urmse,cpse,umnsc,esfac,dfddsu,dfddsl,nub,nus,ust,vsf, -c$OMP+ nut,nuls,nusm,mols,h,sg,zeta,phis,ws -c$OMP+ ) +c$OMP+ afeql,dps,drho,rig,egrs,egr,egrup,egrlo,dfints, +c$OMP+ rhisc,els,urmse,cpse,umnsc,esfac) do j=1,jj c c ----- Compute squared vertical velocity gradients of u-component @@ -958,14 +905,7 @@ subroutine difest_lateral_hyb(m,n,mm,nn,k1m,k1n) enddo enddo c -c ----- Compute local gradient richardson number and Brunt-Vaisala -c ----- frequency. - do l=1,isp(j) - do i=max(1,ifp(j,l)),min(ii,ilp(j,l)) - bvfbot(i)=0. - dps(i)=0. - enddo - enddo +c ----- Compute local gradient richardson number. do k=4,kk kn=k+nn do l=1,isp(j) @@ -985,13 +925,6 @@ subroutine difest_lateral_hyb(m,n,mm,nn,k1m,k1n) else drho(i,k)=tup(i) endif -c -c --- ------- Brunt-Vaisala frequency squared - bvfsq(i,k)=g*g*max(drhomn,drho(i,k)) - . /max(epsil,dp(i,j,kn)) -c -c --- ------- Brunt-Vaisala frequency - bvf(i,k)=sqrt(bvfsq(i,k)) c q=(msku(i,k)*du2(i,k)+msku(i+1,k)*du2(i+1,k)) . /max(1,msku(i,k)+msku(i+1,k)) @@ -1002,24 +935,10 @@ subroutine difest_lateral_hyb(m,n,mm,nn,k1m,k1n) rig(i,k)=alpha0*alpha0*max(drhomn,drho(i,k))*dp(i,j,kn) . /max(1.e-9,q) c -c --- ------- Accumulate Brunt-Vaisala frequency in a region near the -c --- ------- bottom - q=max(0.,p(i,j,k+1)-max(p(i,j,kk+1)-dpnbav,p(i,j,k))) - if (q.gt.0.) then - bvfbot(i)=bvfbot(i)+bvf(i,k)*q - dps(i)=dps(i)+q - endif endif enddo enddo enddo - do l=1,isp(j) - do i=max(1,ifp(j,l)),min(ii,ilp(j,l)) - if (dps(i).gt.0.) then - bvfbot(i)=bvfbot(i)/dps(i) - endif - enddo - enddo c c --- - Compute diffusivity weigth to reduce eddy diffusivity when the c --- - Rossby radius is resolved by the grid. @@ -1367,13 +1286,11 @@ subroutine difest_lateral_hyb(m,n,mm,nn,k1m,k1n) endif enddo ! j=1,jj at line 360 c$OMP END PARALLEL DO -c c if (csdiag) then if (mnproc.eq.1) then - write (lp,*) 'difest:' + write (lp,*) 'difest_lateral_hyb:' endif - call chksummsk(ustar3,ip,1,'ustar3') call chksummsk(difint,ip,kk,'difint') call chksummsk(difiso,ip,kk,'difiso') endif @@ -1392,10 +1309,9 @@ subroutine difest_lateral_iso(m,n,mm,nn,k1m,k1n) real, dimension(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy,kdm) :: . dv2 real, dimension(1-nbdy:idm+nbdy,kdm) :: - . du2,drho,bvfsq,bvf,rig,egr + . du2,drho,rig,egr real, dimension(1-nbdy:idm+nbdy) :: - . tup,pup,sup,cr,bcrrd,afeql,bvfbot,dps,egrs,egrup,dfints,urmse, - . cpse,dfddsu,dfddsl + . tup,pup,sup,cr,bcrrd,afeql,dps,egrs,egrup,dfints,urmse,cpse integer, dimension(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy,kdm) :: . mskv integer, dimension(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy) :: @@ -1405,47 +1321,7 @@ subroutine difest_lateral_iso(m,n,mm,nn,k1m,k1n) integer, dimension(1-nbdy:idm+nbdy) :: . kfpl,klpl integer i,j,k,l,kn - real q,plo,tlo,slo,rhisc,els,egrlo,umnsc,esfac,nus,nub,nut,nuls, - . vsf,nusm,ust,mols,h,sg,zeta,phis,ws -c -c$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 -c$OMP END PARALLEL DO -c - call xctilr(u, 1,2*kk, 2,2, halo_uv) - call xctilr(v, 1,2*kk, 2,2, halo_vv) - call xctilr(ubflxs_p, 1,2, 2,2, halo_uv) - call xctilr(vbflxs_p, 1,2, 2,2, halo_vv) - call xctilr(pbu, 1,2, 2,2, halo_us) - call xctilr(pbv, 1,2, 2,2, halo_vs) -c -c --- ------------------------------------------------------------------ -c --- Estimate energy input by near-inertial waves. -c --- ------------------------------------------------------------------ -c -c -c --- ------------------------------------------------------------------ -c --- Estimate friction velocity cubed. -c --- ------------------------------------------------------------------ -c -c$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)) - ustar3(i,j)=ustar(i,j)**3 - enddo - enddo - enddo -c$OMP END PARALLEL DO + real q,plo,tlo,slo,rhisc,els,egrlo,umnsc,esfac c c --- Locate the range of layers to be considered in the computation of c --- diffusivities. @@ -1554,10 +1430,8 @@ subroutine difest_lateral_iso(m,n,mm,nn,k1m,k1n) c c$OMP PARALLEL DO PRIVATE( c$OMP+ l,i,kfpl,klpl,k,kn,du2,msku,q,tup,pup,sup,cr,plo,tlo,slo,bcrrd, -c$OMP+ afeql,bvfbot,dps,drho,bvfsq,bvf,rig,egrs,egr,egrup,egrlo,dfints, -c$OMP+ rhisc,els,urmse,cpse,umnsc,esfac,dfddsu,dfddsl,nub,nus,ust,vsf, -c$OMP+ nut,nuls,nusm,mols,h,sg,zeta,phis,ws -c$OMP+ ) +c$OMP+ afeql,dps,drho,rig,egrs,egr,egrup,egrlo,dfints, +c$OMP+ rhisc,els,urmse,cpse,umnsc,esfac) do j=1,jj c c ----- Compute squared vertical velocity gradients of u-component @@ -1659,14 +1533,7 @@ subroutine difest_lateral_iso(m,n,mm,nn,k1m,k1n) enddo enddo c -c ----- Compute local gradient richardson number and Brunt-Vaisala -c ----- frequency. - do l=1,isp(j) - do i=max(1,ifp(j,l)),min(ii,ilp(j,l)) - bvfbot(i)=0. - dps(i)=0. - enddo - enddo +c ----- Compute local gradient richardson number. do k=4,kk kn=k+nn do l=1,isp(j) @@ -1686,13 +1553,6 @@ subroutine difest_lateral_iso(m,n,mm,nn,k1m,k1n) else drho(i,k)=tup(i) endif -c -c --- ------- Brunt-Vaisala frequency squared - bvfsq(i,k)=g*g*max(drhomn,drho(i,k)) - . /max(epsil,dp(i,j,kn)) -c -c --- ------- Brunt-Vaisala frequency - bvf(i,k)=sqrt(bvfsq(i,k)) c q=(msku(i,k)*du2(i,k)+msku(i+1,k)*du2(i+1,k)) . /max(1,msku(i,k)+msku(i+1,k)) @@ -1703,24 +1563,10 @@ subroutine difest_lateral_iso(m,n,mm,nn,k1m,k1n) rig(i,k)=alpha0*alpha0*max(drhomn,drho(i,k))*dp(i,j,kn) . /max(1.e-9,q) c -c --- ------- Accumulate Brunt-Vaisala frequency in a region near the -c --- ------- bottom - q=max(0.,p(i,j,k+1)-max(p(i,j,kk+1)-dpnbav,p(i,j,k))) - if (q.gt.0.) then - bvfbot(i)=bvfbot(i)+bvf(i,k)*q - dps(i)=dps(i)+q - endif endif enddo enddo enddo - do l=1,isp(j) - do i=max(1,ifp(j,l)),min(ii,ilp(j,l)) - if (dps(i).gt.0.) then - bvfbot(i)=bvfbot(i)/dps(i) - endif - enddo - enddo c c --- - Compute diffusivity weigth to reduce eddy diffusivity when the c --- - Rossby radius is resolved by the grid. @@ -2072,13 +1918,11 @@ subroutine difest_lateral_iso(m,n,mm,nn,k1m,k1n) c if (csdiag) then if (mnproc.eq.1) then - write (lp,*) 'difest:' + write (lp,*) 'difest_lateral_iso:' endif - call chksummsk(ustar3,ip,1,'ustar3') call chksummsk(difint,ip,kk,'difint') call chksummsk(difiso,ip,kk,'difiso') endif -c c end subroutine difest_lateral_iso c @@ -2093,10 +1937,9 @@ subroutine difest_vertical_iso(m,n,mm,nn,k1m,k1n) real, dimension(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy,kdm) :: . dv2 real, dimension(1-nbdy:idm+nbdy,kdm) :: - . du2,drho,bvfsq,bvf,rig,egr + . du2,drho,bvfsq,bvf,rig real, dimension(1-nbdy:idm+nbdy) :: - . tup,pup,sup,cr,bcrrd,afeql,bvfbot,dps,egrs,egrup,dfints,urmse, - . cpse,dfddsu,dfddsl + . tup,bvfbot,dps,cpse,dfddsu,dfddsl integer, dimension(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy,kdm) :: . mskv integer, dimension(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy) :: @@ -2106,8 +1949,7 @@ subroutine difest_vertical_iso(m,n,mm,nn,k1m,k1n) integer, dimension(1-nbdy:idm+nbdy) :: . kfpl,klpl integer i,j,k,l,kn - real q,plo,tlo,slo,rhisc,els,egrlo,umnsc,esfac,nus,nub,nut,nuls, - . vsf,nusm,ust,mols,h,sg,zeta,phis,ws + real q,tlo,nus,nub,nut,nuls,vsf,nusm,ust,mols,h,sg,zeta,phis,ws c #if defined(TRC) && defined(TKE) real gls_c3,tke_prod,tke_buoy,tke_epsilon,Ls_unlmt,Ls_lmt,tke_Q, @@ -2117,46 +1959,12 @@ subroutine difest_vertical_iso(m,n,mm,nn,k1m,k1n) # endif #endif c -c$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 -c$OMP END PARALLEL DO -c - call xctilr(u, 1,2*kk, 2,2, halo_uv) - call xctilr(v, 1,2*kk, 2,2, halo_vv) - call xctilr(ubflxs_p, 1,2, 2,2, halo_uv) - call xctilr(vbflxs_p, 1,2, 2,2, halo_vv) - call xctilr(pbu, 1,2, 2,2, halo_us) - call xctilr(pbv, 1,2, 2,2, halo_vs) -c c --- ------------------------------------------------------------------ c --- Estimate energy input by near-inertial waves. c --- ------------------------------------------------------------------ c call niw_ke_tendency(m,n,mm,nn,k1m,k1n) c -c --- ------------------------------------------------------------------ -c --- Estimate friction velocity cubed. -c --- ------------------------------------------------------------------ -c -c$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)) - ustar3(i,j)=ustar(i,j)**3 - enddo - enddo - enddo -c$OMP END PARALLEL DO -c c --- Locate the range of layers to be considered in the computation of c --- diffusivities. do j=0,jj+1 @@ -2263,9 +2071,9 @@ subroutine difest_vertical_iso(m,n,mm,nn,k1m,k1n) c$OMP END PARALLEL DO c c$OMP PARALLEL DO PRIVATE( -c$OMP+ l,i,kfpl,klpl,k,kn,du2,msku,q,tup,pup,sup,cr,plo,tlo,slo,bcrrd, -c$OMP+ afeql,bvfbot,dps,drho,bvfsq,bvf,rig,egrs,egr,egrup,egrlo,dfints, -c$OMP+ rhisc,els,urmse,cpse,umnsc,esfac,dfddsu,dfddsl,nub,nus,ust,vsf, +c$OMP+ l,i,kfpl,klpl,k,kn,du2,msku,q,tup,tlo, +c$OMP+ bvfbot,dps,drho,bvfsq,bvf,rig, +c$OMP+ dfddsu,dfddsl,nub,nus,ust,vsf, c$OMP+ nut,nuls,nusm,mols,h,sg,zeta,phis,ws #if defined(TRC) && defined(TKE) c$OMP+ ,gls_c3,tke_epsilon,tke_prod,tke_buoy,tke_Q,Ls_unlmt,Ls_lmt,Gh, @@ -2330,52 +2138,6 @@ subroutine difest_vertical_iso(m,n,mm,nn,k1m,k1n) enddo enddo c -c ----- Compute the first baroclinic rossby radius of deformation using -c ----- the WKB approximation by Chelton at al. (1998). -c ----- !!! Could include top layer in computation !!! - do l=1,isp(j) - do i=max(1,ifp(j,l)),min(ii,ilp(j,l)) - pup(i)=.5*(3.*p(i,j,3)-p(i,j,min(kk,kfpla(i,j,n))+1)) - kn=2+nn - tup(i)=temp(i,j,kn) - sup(i)=saln(i,j,kn) - cr(i)=0. - enddo - enddo - do k=3,kk - kn=k+nn - do l=1,isp(j) - do i=max(1,ifp(j,l)),min(ii,ilp(j,l)) - if (k.ge.kfpla(i,j,n)) then - if (p(i,j,kk+1)-p(i,j,k+1).lt.epsil) then - plo=p(i,j,kk+1) - else - plo=.5*(p(i,j,k)+p(i,j,k+1)) - endif - tlo=temp(i,j,kn) - slo=saln(i,j,kn) - cr(i)=cr(i) - . +sqrt(max(0.,(rho(p(i,j,k),tlo,slo) - . -rho(p(i,j,k),tup(i),sup(i))) - . *(plo-pup(i)))) - pup(i)=plo - tup(i)=tlo - sup(i)=slo - endif - enddo - enddo - enddo - do l=1,isp(j) - do i=max(1,ifp(j,l)),min(ii,ilp(j,l)) - cr(i)=alpha0*cr(i)/pi - bcrrd(i)= - . sqrt(cr(i)*cr(i) - . /max(coriop(i,j)*coriop(i,j)+2.*betafp(i,j)*cr(i), - . 1.e-24)) - afeql(i)=max(abs(coriop(i,j)),sqrt(2.*betafp(i,j)*cr(i))) - enddo - enddo -c c ----- Compute local gradient richardson number and Brunt-Vaisala c ----- frequency. do l=1,isp(j) @@ -2821,10 +2583,9 @@ subroutine difest_vertical_iso(m,n,mm,nn,k1m,k1n) c if (csdiag) then if (mnproc.eq.1) then - write (lp,*) 'difest:' + write (lp,*) 'difest_vertical_iso:' endif call chksummsk(idkedt,ip,1,'idkedt') - call chksummsk(ustar3,ip,1,'ustar3') call chksummsk(difdia,ip,kk,'difdia') #if defined(TRC) && defined(TKE) call chksummsk(trc(1-nbdy,1-nbdy,1,itrtke),ip,2*kk,'tke') @@ -2833,10 +2594,7 @@ subroutine difest_vertical_iso(m,n,mm,nn,k1m,k1n) # endif #endif endif -c - c end subroutine difest_vertical_iso -c c end module mod_difest From 9f3a62dc3fecacaf21405b9735284ade09957f50 Mon Sep 17 00:00:00 2001 From: Mats Bentsen Date: Mon, 4 Oct 2021 00:41:40 +0200 Subject: [PATCH 010/366] Restructured the call of near-inertial waves energy input estimation. --- phy/mod_difest.F | 38 ++++++++++++++++---------------------- phy/rdlim.F | 7 +++++++ 2 files changed, 23 insertions(+), 22 deletions(-) diff --git a/phy/mod_difest.F b/phy/mod_difest.F index 9ec40846..7684520b 100644 --- a/phy/mod_difest.F +++ b/phy/mod_difest.F @@ -223,7 +223,10 @@ subroutine difest(m,n,mm,nn,k1m,k1n) c integer i,j,k,l,kn c +c --- ------------------------------------------------------------------ c --- update halos of various fields +c --- ------------------------------------------------------------------ +c call xctilr(u, 1,2*kk, 2,2, halo_uv) call xctilr(v, 1,2*kk, 2,2, halo_vv) call xctilr(ubflxs_p, 1,2, 2,2, halo_uv) @@ -263,20 +266,23 @@ subroutine difest(m,n,mm,nn,k1m,k1n) c$OMP END PARALLEL DO c if (vcoord_type_tag == isopyc_bulkml) then +c +c --- - Estimate energy input by near-inertial waves. + call niw_ke_tendency(m,n,mm,nn,k1m,k1n) +c +c --- - Estimate diffusivities for eddy-induced transport and layer-wise +c --- - diffusion. call difest_lateral_iso(m,n,mm,nn,k1m,k1n) - elseif (vcoord_type_tag == cntiso_hybrid) then - call difest_lateral_hyb(m,n,mm,nn,k1m,k1n) - else - if (mnproc.eq.1) then - write (lp,*) 'difest: unsupported vertical coordinate!' - endif - call xcstop('(difest)') - stop '(difest)' - endif c - if (vcoord_type_tag == isopyc_bulkml) then +c --- - Estimate vertical diffusivity. call difest_vertical_iso(m,n,mm,nn,k1m,k1n) elseif (vcoord_type_tag == cntiso_hybrid) then +c +c --- - Estimate diffusivities for eddy-induced transport and layer-wise +c --- - diffusion. + call difest_lateral_hyb(m,n,mm,nn,k1m,k1n) +c +c --- - Estimate vertical diffusivities.. call difest_vertical_hyb(m,n,mm,nn,k1m,k1n) else if (mnproc.eq.1) then @@ -351,12 +357,6 @@ subroutine difest_vertical_hyb(m,n,mm,nn,k1m,k1n) bl3 = 4.5e-3 bl4 = 2500.0 c -c --- ------------------------------------------------------------------ -c --- Estimate energy input by near-inertial waves. -c --- ------------------------------------------------------------------ -c - call niw_ke_tendency(m,n,mm,nn,k1m,k1n) -c c single column diffusivity do j=1,jj do l=1,isp(j) @@ -1959,12 +1959,6 @@ subroutine difest_vertical_iso(m,n,mm,nn,k1m,k1n) # endif #endif c -c --- ------------------------------------------------------------------ -c --- Estimate energy input by near-inertial waves. -c --- ------------------------------------------------------------------ -c - call niw_ke_tendency(m,n,mm,nn,k1m,k1n) -c c --- Locate the range of layers to be considered in the computation of c --- diffusivities. do j=0,jj+1 diff --git a/phy/rdlim.F b/phy/rdlim.F index c7ca5c6c..f4b43e6e 100644 --- a/phy/rdlim.F +++ b/phy/rdlim.F @@ -297,6 +297,13 @@ subroutine rdlim LVL_DIFVHO(1:nphy)=0 LVL_DIFVSO(1:nphy)=0 case (cntiso_hybrid) + H2D_IDKEDT(1:nphy)=0 + H2D_MTKEUS(1:nphy)=0 + H2D_MTKENI(1:nphy)=0 + H2D_MTKEBF(1:nphy)=0 + H2D_MTKERS(1:nphy)=0 + H2D_MTKEPE(1:nphy)=0 + H2D_MTKEKE(1:nphy)=0 LYR_DIFDIA(1:nphy)=0 LVL_DIFDIA(1:nphy)=0 case default From 65b88687f4c6251705724bfa69d6ec5748fe1d57 Mon Sep 17 00:00:00 2001 From: Mats Bentsen Date: Mon, 4 Oct 2021 23:46:13 +0200 Subject: [PATCH 011/366] Combined the computation of common fields for diffusivity estimation with isopycnic vertical coordinate. --- phy/mod_difest.F | 747 +++++++++++++++++++---------------------------- 1 file changed, 300 insertions(+), 447 deletions(-) diff --git a/phy/mod_difest.F b/phy/mod_difest.F index 7684520b..de40bd5f 100644 --- a/phy/mod_difest.F +++ b/phy/mod_difest.F @@ -74,6 +74,13 @@ module mod_difest #endif c implicit none +c + real, dimension(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy,kdm) :: + . du2l,drhol,rigl + integer, dimension(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy,kdm) :: + . mskv,msku + integer, dimension(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy) :: + . kmax,kfil c type(CVMix_tidal_params_type) :: CVMix_tidal_params type(CVMix_global_params_type) :: CVMix_glb_params ! Date: Tue, 5 Oct 2021 13:59:00 +0200 Subject: [PATCH 012/366] Removed diagnostics of mixed layer depth at velocity points. --- phy/mod_dia.F | 92 ++++++++++++++++-------------------------------- phy/rdlim.F | 4 --- phy/restart_rd.F | 4 --- phy/restart_wt.F | 8 ----- 4 files changed, 31 insertions(+), 77 deletions(-) diff --git a/phy/mod_dia.F b/phy/mod_dia.F index f77cac2d..f3af583d 100644 --- a/phy/mod_dia.F +++ b/phy/mod_dia.F @@ -178,16 +178,16 @@ module mod_dia . H2D_ABSWND ,H2D_ALB ,H2D_BTMSTR ,H2D_BRNFLX ,H2D_BRNPD , . H2D_DFL ,H2D_EVA ,H2D_FICE ,H2D_FMLTFZ ,H2D_HICE , . H2D_HMLTFZ ,H2D_HSNW ,H2D_IAGE ,H2D_IDKEDT ,H2D_LIP , - . H2D_MAXMLD ,H2D_MLD ,H2D_MLDU ,H2D_MLDV ,H2D_MLTS , - . H2D_MLTSMN ,H2D_MLTSMX ,H2D_MLTSSQ ,H2D_MTKEUS ,H2D_MTKENI , - . H2D_MTKEBF ,H2D_MTKERS ,H2D_MTKEPE ,H2D_MTKEKE ,H2D_MTY , - . H2D_MXLU ,H2D_MXLV ,H2D_NSF ,H2D_PBOT ,H2d_PSRF , - . H2D_RFIFLX ,H2D_RNFFLX ,H2D_SALFLX ,H2D_SALRLX ,H2D_SBOT , - . H2D_SEALV ,H2D_SLVSQ ,H2D_SFL ,H2D_SOP ,H2D_SIGMX , - . H2D_SSS ,H2D_SSSSQ ,H2D_SST ,H2D_SSTSQ ,H2D_SURFLX , - . H2D_SURRLX ,H2D_SWA ,H2D_T20D ,H2D_TAUX ,H2D_TAUY , - . H2D_TBOT ,H2D_TICE ,H2D_TSRF ,H2D_UB ,H2D_UICE , - . H2D_USTAR ,H2D_USTAR3 ,H2D_VB ,H2D_VICE ,H2D_ZTX , + . H2D_MAXMLD ,H2D_MLD ,H2D_MLTS ,H2D_MLTSMN ,H2D_MLTSMX , + . H2D_MLTSSQ ,H2D_MTKEUS ,H2D_MTKENI ,H2D_MTKEBF ,H2D_MTKERS , + . H2D_MTKEPE ,H2D_MTKEKE ,H2D_MTY ,H2D_MXLU ,H2D_MXLV , + . H2D_NSF ,H2D_PBOT ,H2D_PSRF ,H2D_RFIFLX ,H2D_RNFFLX , + . H2D_SALFLX ,H2D_SALRLX ,H2D_SBOT ,H2D_SEALV ,H2D_SLVSQ , + . H2D_SFL ,H2D_SOP ,H2D_SIGMX ,H2D_SSS ,H2D_SSSSQ , + . H2D_SST ,H2D_SSTSQ ,H2D_SURFLX ,H2D_SURRLX ,H2D_SWA , + . H2D_T20D ,H2D_TAUX ,H2D_TAUY ,H2D_TBOT ,H2D_TICE , + . H2D_TSRF ,H2D_UB ,H2D_UICE ,H2D_USTAR ,H2D_USTAR3 , + . H2D_VB ,H2D_VICE ,H2D_ZTX , . LYR_BFSQ ,LYR_DIFDIA ,LYR_DIFVMO ,LYR_DIFVHO ,LYR_DIFVSO , . LYR_DIFINT ,LYR_DIFISO ,LYR_DP ,LYR_DPU ,LYR_DPV , . LYR_DZ ,LYR_SALN ,LYR_TEMP ,LYR_TRC ,LYR_UFLX , @@ -213,17 +213,17 @@ module mod_dia . ACC_ABSWND ,ACC_ALB ,ACC_BRNFLX ,ACC_BRNPD ,ACC_DFL , . ACC_EVA ,ACC_FICE ,ACC_FMLTFZ ,ACC_HICE ,ACC_HMLTFZ , . ACC_HSNW ,ACC_IAGE ,ACC_IDKEDT ,ACC_LIP ,ACC_MAXMLD , - . ACC_MLD ,ACC_MLDU ,ACC_MLDV ,ACC_MLTS ,ACC_MLTSMN , - . ACC_MLTSMX ,ACC_MLTSSQ ,ACC_MTKEUS ,ACC_MTKENI ,ACC_MTKEBF , - . ACC_MTKERS ,ACC_MTKEPE ,ACC_MTKEKE ,ACC_MTY ,ACC_MXLU , - . ACC_MXLV ,ACC_NSF ,ACC_PBOT ,ACC_PSRF ,ACC_RFIFLX , - . ACC_RNFFLX ,ACC_SALFLX ,ACC_SALRLX ,ACC_SBOT ,ACC_SEALV , - . ACC_SLVSQ ,ACC_SFL ,ACC_SOP ,ACC_SIGMX ,ACC_SSS , - . ACC_SSSSQ ,ACC_SST ,ACC_SSTSQ ,ACC_SURFLX ,ACC_SURRLX , - . ACC_SWA ,ACC_T20D ,ACC_TAUX ,ACC_TAUY ,ACC_TBOT , - . ACC_TICE ,ACC_TSRF ,ACC_UB ,ACC_UBFLXS ,ACC_UICE , - . ACC_USTAR ,ACC_USTAR3 ,ACC_VB ,ACC_VBFLXS ,ACC_VICE , - . ACC_ZTX ,ACC_IVOLU ,ACC_IVOLV ,ACC_UTILH2D, + . ACC_MLD ,ACC_MLTS ,ACC_MLTSMN ,ACC_MLTSMX ,ACC_MLTSSQ , + . ACC_MTKEUS ,ACC_MTKENI ,ACC_MTKEBF ,ACC_MTKERS ,ACC_MTKEPE , + . ACC_MTKEKE ,ACC_MTY ,ACC_MXLU ,ACC_MXLV ,ACC_NSF , + . ACC_PBOT ,ACC_PSRF ,ACC_RFIFLX ,ACC_RNFFLX ,ACC_SALFLX , + . ACC_SALRLX ,ACC_SBOT ,ACC_SEALV ,ACC_SLVSQ ,ACC_SFL , + . ACC_SOP ,ACC_SIGMX ,ACC_SSS ,ACC_SSSSQ ,ACC_SST , + . ACC_SSTSQ ,ACC_SURFLX ,ACC_SURRLX ,ACC_SWA ,ACC_T20D , + . ACC_TAUX ,ACC_TAUY ,ACC_TBOT ,ACC_TICE ,ACC_TSRF , + . ACC_UB ,ACC_UBFLXS ,ACC_UICE ,ACC_USTAR ,ACC_USTAR3 , + . ACC_VB ,ACC_VBFLXS ,ACC_VICE ,ACC_ZTX ,ACC_IVOLU , + . ACC_IVOLV ,ACC_UTILH2D, . ACC_BFSQ ,ACC_DIFDIA ,ACC_DIFVMO ,ACC_DIFVHO ,ACC_DIFVSO , . ACC_DIFINT ,ACC_DIFISO ,ACC_DP ,ACC_DPU ,ACC_DPV , . ACC_DZ ,ACC_SALN ,ACC_TEMP ,ACC_UFLX ,ACC_UTFLX , @@ -251,16 +251,16 @@ module mod_dia . H2D_ABSWND ,H2D_ALB ,H2D_BTMSTR ,H2D_BRNFLX ,H2D_BRNPD , . H2D_DFL ,H2D_EVA ,H2D_FICE ,H2D_FMLTFZ ,H2D_HICE , . H2D_HMLTFZ ,H2D_HSNW ,H2D_IAGE ,H2D_IDKEDT ,H2D_LIP , - . H2D_MAXMLD ,H2D_MLD ,H2D_MLDU ,H2D_MLDV ,H2D_MLTS , - . H2D_MLTSMN ,H2D_MLTSMX ,H2D_MLTSSQ ,H2D_MTKEUS ,H2D_MTKENI , - . H2D_MTKEBF ,H2D_MTKERS ,H2D_MTKEPE ,H2D_MTKEKE ,H2D_MTY , - . H2D_MXLU ,H2D_MXLV ,H2D_NSF ,H2D_PBOT ,H2D_PSRF , - . H2D_RFIFLX ,H2D_RNFFLX ,H2D_SALFLX ,H2D_SALRLX ,H2D_SBOT , - . H2D_SEALV ,H2D_SLVSQ ,H2D_SFL ,H2D_SOP ,H2D_SIGMX , - . H2D_SSS ,H2D_SSSSQ ,H2D_SST ,H2D_SSTSQ ,H2D_SURFLX , - . H2D_SURRLX ,H2D_SWA ,H2d_T20D ,H2D_TAUX ,H2D_TAUY , - . H2D_TBOT ,H2D_TICE ,H2D_TSRF ,H2D_UB ,H2D_UICE , - . H2D_USTAR ,H2D_USTAR3 ,H2D_VB ,H2D_VICE ,H2D_ZTX , + . H2D_MAXMLD ,H2D_MLD ,H2D_MLTS ,H2D_MLTSMN ,H2D_MLTSMX , + . H2D_MLTSSQ ,H2D_MTKEUS ,H2D_MTKENI ,H2D_MTKEBF ,H2D_MTKERS , + . H2D_MTKEPE ,H2D_MTKEKE ,H2D_MTY ,H2D_MXLU ,H2D_MXLV , + . H2D_NSF ,H2D_PBOT ,H2D_PSRF ,H2D_RFIFLX ,H2D_RNFFLX , + . H2D_SALFLX ,H2D_SALRLX ,H2D_SBOT ,H2D_SEALV ,H2D_SLVSQ , + . H2D_SFL ,H2D_SOP ,H2D_SIGMX ,H2D_SSS ,H2D_SSSSQ , + . H2D_SST ,H2D_SSTSQ ,H2D_SURFLX ,H2D_SURRLX ,H2D_SWA , + . H2D_T20D ,H2D_TAUX ,H2D_TAUY ,H2D_TBOT ,H2D_TICE , + . H2D_TSRF ,H2D_UB ,H2D_UICE ,H2D_USTAR ,H2D_USTAR3 , + . H2D_VB ,H2D_VICE ,H2D_ZTX , . LYR_BFSQ ,LYR_DIFDIA ,LYR_DIFVMO ,LYR_DIFVHO ,LYR_DIFVSO , . LYR_DIFINT ,LYR_DIFISO ,LYR_DP ,LYR_DPU ,LYR_DPV , . LYR_DZ ,LYR_SALN ,LYR_TEMP ,LYR_TRC ,LYR_UFLX , @@ -445,8 +445,6 @@ subroutine diaini ACC_LIP(n) = H2D_LIP(n) ACC_MAXMLD(n) = H2D_MAXMLD(n) ACC_MLD(n) = H2D_MLD(n) - ACC_MLDU(n) = H2D_MLDU(n) + H2D_MXLU(n) - ACC_MLDV(n) = H2D_MLDV(n) + H2D_MXLV(n) ACC_MLTS(n) = H2D_MLTS(n) ACC_MLTSMN(n) = H2D_MLTSMN(n) ACC_MLTSMX(n) = H2D_MLTSMX(n) @@ -632,10 +630,6 @@ subroutine diaini ACC_MAXMLD(n)=nphyh2d*min(1,ACC_MAXMLD(n)) if (ACC_MLD(n).ne.0) nphyh2d=nphyh2d+1 ACC_MLD(n)=nphyh2d*min(1,ACC_MLD(n)) - if (ACC_MLDU(n).ne.0) nphyh2d=nphyh2d+1 - ACC_MLDU(n)=nphyh2d*min(1,ACC_MLDU(n)) - if (ACC_MLDV(n).ne.0) nphyh2d=nphyh2d+1 - ACC_MLDV(n)=nphyh2d*min(1,ACC_MLDV(n)) if (ACC_MLTS(n).ne.0) nphyh2d=nphyh2d+1 ACC_MLTS(n)=nphyh2d*min(1,ACC_MLTS(n)) if (ACC_MLTSMN(n).ne.0) nphyh2d=nphyh2d+1 @@ -1317,9 +1311,6 @@ subroutine diaacc(m,n,mm,nn,k1m,k1n) c --- weighted u-component of total velocity [g/s^3] call acch2d(ACC_MXLU,util2,dummy,0,'u') c -c --- mixed layer pressure thickness at u-point [g/cm/s^2] - call acch2d(ACC_MLDU,dpu(1-nbdy,1-nbdy,k1m),dummy,0,'u') -c c --- v-component of barotropic velocity [cm/s] call acch2d(ACC_VB,vb(1-nbdy,1-nbdy,m),dummy,0,'v') c @@ -1338,9 +1329,6 @@ subroutine diaacc(m,n,mm,nn,k1m,k1n) c --- weighted v-component of total velocity [g/s^3] call acch2d(ACC_MXLV,util4,dummy,0,'v') c -c --- mixed layer pressure thickness at v-point [g/cm/s^2] - call acch2d(ACC_MLDV,dpv(1-nbdy,1-nbdy,k1m),dummy,0,'v') -c c --- surface pressure [g/cm/s^2] call acch2d(ACC_PSRF,p(1-nbdy,1-nbdy,1),dummy,0,'p') c @@ -2078,8 +2066,6 @@ subroutine diaout(iogrp,m,n,mm,nn,k1m,k1n) c --- finalize accumulation of 2d fields call finh2d(ACC_HICE(iogrp),ACC_FICE(iogrp),'p') call finh2d(ACC_HSNW(iogrp),ACC_FICE(iogrp),'p') - call finh2d(ACC_MXLU(iogrp),ACC_MLDU(iogrp),'u') - call finh2d(ACC_MXLV(iogrp),ACC_MLDV(iogrp),'v') call finh2d(ACC_UICE(iogrp),ACC_IVOLU(iogrp),'u') call finh2d(ACC_VICE(iogrp),ACC_IVOLV(iogrp),'v') c @@ -2503,14 +2489,6 @@ subroutine diaout(iogrp,m,n,mm,nn,k1m,k1n) c call wrth2d(ACC_MLD(iogrp),H2D_MLD(iogrp),rnacc/onem, . 0.,cmpflg,ip,'p','mld','Mixed layer depth',' ','m') -c - call wrth2d(ACC_MLDU(iogrp),H2D_MLDU(iogrp), - . rnacc/onem,0.,cmpflg,iuu,'u','mldu', - . 'Mixed layer depth at u-point',' ','m') -c - call wrth2d(ACC_MLDV(iogrp),H2D_MLDV(iogrp), - . rnacc/onem,0.,cmpflg,ivv,'v','mldv', - . 'Mixed layer depth at v-point',' ','m') c call wrth2d(ACC_MAXMLD(iogrp),H2D_MAXMLD(iogrp), . 1./onem,0.,cmpflg,ip,'p','maxmld','Maximum mixed layer depth', @@ -5217,7 +5195,6 @@ subroutine inifld(iogrp) call inih2d(ACC_ZTX(iogrp),'u',0.) call inih2d(ACC_TAUX(iogrp),'u',0.) call inih2d(ACC_MXLU(iogrp),'u',0.) - call inih2d(ACC_MLDU(iogrp),'u',0.) call inih2d(ACC_UICE(iogrp),'u',0.) call inih2d(ACC_IVOLU(iogrp),'u',0.) c @@ -5226,7 +5203,6 @@ subroutine inifld(iogrp) call inih2d(ACC_MTY(iogrp),'v',0.) call inih2d(ACC_TAUY(iogrp),'v',0.) call inih2d(ACC_MXLV(iogrp),'v',0.) - call inih2d(ACC_MLDV(iogrp),'v',0.) call inih2d(ACC_VICE(iogrp),'v',0.) call inih2d(ACC_IVOLV(iogrp),'v',0.) c @@ -6309,12 +6285,6 @@ subroutine definevar(irec,iogrp,cmpflg,timeunits,calendar) c call ncdefvar3d(H2D_MLD(iogrp),cmpflg,'p','mld', . 'Mixed layer depth',' ','m',0) -c - call ncdefvar3d(H2D_MLDU(iogrp),cmpflg,'u','mldu', - . 'Mixed layer depth at u-point',' ','m',0) -c - call ncdefvar3d(H2D_MLDV(iogrp),cmpflg,'v','mldv', - . 'Mixed layer depth at v-point',' ','m',0) c call ncdefvar3d(H2D_MAXMLD(iogrp),cmpflg,'p','maxmld', . 'Maximum mixed layer depth',' ','m',0) diff --git a/phy/rdlim.F b/phy/rdlim.F index f4b43e6e..e0eb5470 100644 --- a/phy/rdlim.F +++ b/phy/rdlim.F @@ -343,8 +343,6 @@ subroutine rdlim write (lp,*) 'H2D_LIP ',H2D_LIP(1:nphy) write (lp,*) 'H2D_MAXMLD ',H2D_MAXMLD(1:nphy) write (lp,*) 'H2D_MLD ',H2D_MLD(1:nphy) - write (lp,*) 'H2D_MLDU ',H2D_MLDU(1:nphy) - write (lp,*) 'H2D_MLDV ',H2D_MLDV(1:nphy) write (lp,*) 'H2D_MLTS ',H2D_MLTS(1:nphy) write (lp,*) 'H2D_MLTSMN ',H2D_MLTSMN(1:nphy) write (lp,*) 'H2D_MLTSMX ',H2D_MLTSMX(1:nphy) @@ -492,8 +490,6 @@ subroutine rdlim call xcbcst(H2D_LIP) call xcbcst(H2D_MAXMLD) call xcbcst(H2D_MLD) - call xcbcst(H2D_MLDU) - call xcbcst(H2D_MLDV) call xcbcst(H2D_MLTS) call xcbcst(H2D_MLTSMN) call xcbcst(H2D_MLTSMX) diff --git a/phy/restart_rd.F b/phy/restart_rd.F index 7ff880ae..617beca6 100644 --- a/phy/restart_rd.F +++ b/phy/restart_rd.F @@ -656,10 +656,6 @@ subroutine restart_rd . phyh2d(1-nbdy,1-nbdy,ACC_MXLU(n)),iuu,1,0.) if (ACC_MXLV(n).ne.0) call ncread('mxlv_phy'//c2, . phyh2d(1-nbdy,1-nbdy,ACC_MXLV(n)),ivv,1,0.) - if (ACC_MLDU(n).ne.0) call ncread('mldu_phy'//c2, - . phyh2d(1-nbdy,1-nbdy,ACC_MLDU(n)),iuu,1,0.) - if (ACC_MLDV(n).ne.0) call ncread('mldv_phy'//c2, - . phyh2d(1-nbdy,1-nbdy,ACC_MLDV(n)),ivv,1,0.) if (ACC_UICE(n).ne.0) call ncread('uice_phy'//c2, . phyh2d(1-nbdy,1-nbdy,ACC_UICE(n)),iuu,1,0.) if (ACC_VICE(n).ne.0) call ncread('vice_phy'//c2, diff --git a/phy/restart_wt.F b/phy/restart_wt.F index 646329b6..489af60b 100644 --- a/phy/restart_wt.F +++ b/phy/restart_wt.F @@ -382,10 +382,6 @@ subroutine restart_wt . trim(c5u)//' time',phyh2d(1-nbdy,1-nbdy,ACC_MXLU(n)),iuu) if (ACC_MXLV(n) .ne.0) call wrtrst('mxlv_phy'//c2, . trim(c5v)//' time',phyh2d(1-nbdy,1-nbdy,ACC_MXLV(n)),ivv) - if (ACC_MLDU(n) .ne.0) call wrtrst('mldu_phy'//c2, - . trim(c5u)//' time',phyh2d(1-nbdy,1-nbdy,ACC_MLDU(n)),iuu) - if (ACC_MLDV(n) .ne.0) call wrtrst('mldv_phy'//c2, - . trim(c5v)//' time',phyh2d(1-nbdy,1-nbdy,ACC_MLDV(n)),ivv) if (ACC_UICE(n) .ne.0) call wrtrst('uice_phy'//c2, . trim(c5u)//' time',phyh2d(1-nbdy,1-nbdy,ACC_UICE(n)),iuu) if (ACC_VICE(n) .ne.0) call wrtrst('vice_phy'//c2, @@ -976,10 +972,6 @@ subroutine defvar_restart(c5p,c5u,c5v,c5q) if (ACC_MXLU(n) .ne.0) call defvarrst('mxlu_phy'//c2, . trim(c5u)//' time') if (ACC_MXLV(n) .ne.0) call defvarrst('mxlv_phy'//c2, - . trim(c5v)//' time') - if (ACC_MLDU(n) .ne.0) call defvarrst('mldu_phy'//c2, - . trim(c5u)//' time') - if (ACC_MLDV(n) .ne.0) call defvarrst('mldv_phy'//c2, . trim(c5v)//' time') if (ACC_UICE(n) .ne.0) call defvarrst('uice_phy'//c2, . trim(c5u)//' time') From df91971dc677ff7e972ebaafbafd16b1cb0aa077 Mon Sep 17 00:00:00 2001 From: Mats Bentsen Date: Tue, 5 Oct 2021 14:54:03 +0200 Subject: [PATCH 013/366] Made mixed layer depth diagnostic depend on choice of vertical coordinate. --- phy/mod_dia.F | 33 ++++++++++++++++++++++++++------- phy/mod_difest.F | 10 ++++++---- 2 files changed, 32 insertions(+), 11 deletions(-) diff --git a/phy/mod_dia.F b/phy/mod_dia.F index f3af583d..a3baa9bf 100644 --- a/phy/mod_dia.F +++ b/phy/mod_dia.F @@ -30,7 +30,8 @@ module mod_dia use mod_xc use mod_nctools use netcdf, only : nf90_fill_double - use mod_vcoord, only: sigmar + use mod_vcoord, only: vcoord_type_tag, isopyc_bulkml, + . cntiso_hybrid, 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, @@ -40,6 +41,7 @@ module mod_dia use mod_tmsmt, only: dpold use mod_mxlayr, only: mtkeus, mtkeni, mtkebf, mtkers, mtkepe, . mtkeke, pbrnda + use mod_difest, only: OBLdepth use mod_diffusion, only: difint, difiso, difdia, . Kvisc_m, Kdiff_t, Kdiff_s, . umfltd, vmfltd, utfltd, vtfltd, utflld, @@ -1058,15 +1060,32 @@ subroutine diaacc(m,n,mm,nn,k1m,k1n) endif c if (sum(ACC_MLD(1:nphy)).ne.0) then + select case (vcoord_type_tag) + case (isopyc_bulkml) c$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)) - dpml(i,j)=dp(i,j,1+mm)+dp(i,j,2+mm) + do j=1,jj + do l=1,isp(j) + do i=max(1,ifp(j,l)),min(ii,ilp(j,l)) + dpml(i,j)=dp(i,j,1+mm)+dp(i,j,2+mm) + enddo + enddo + enddo +c$OMP END PARALLEL DO + case (cntiso_hybrid) +c$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)) + dpml(i,j)=OBLdepth(i,j)*onem + enddo + enddo enddo - enddo - enddo c$OMP END PARALLEL DO + case default + write (lp,*) 'diaacc: unsupported vertical coordinate!' + call xcstop('(diaacc)') + stop '(diaacc)' + end select endif c if (sum(ACC_UVEL(1:nphy)+ACC_UVELLVL(1:nphy)).ne.0) then diff --git a/phy/mod_difest.F b/phy/mod_difest.F index de40bd5f..e1b41a99 100644 --- a/phy/mod_difest.F +++ b/phy/mod_difest.F @@ -74,9 +74,13 @@ module mod_difest #endif c implicit none +c + private c real, dimension(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy,kdm) :: . du2l,drhol,rigl + real, dimension(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy) :: + . OBLdepth integer, dimension(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy,kdm) :: . mskv,msku integer, dimension(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy) :: @@ -88,9 +92,6 @@ module mod_difest c type(CVMix_kpp_params_type), pointer :: CVmix_kpp_params_in c type(CVMix_kpp_params_type) :: CVmix_kpp_params_in c - public :: ini_difest, difest - private :: difest_lateral_iso, difest_vertical_iso, - . difest_lateral_hyb, difest_vertical_hyb c --- parameters: c --- iidtyp - type of interface and isopycnal diffusivities. If c --- iidtyp=1 the diffusivities are diffusive velocities @@ -167,6 +168,8 @@ module mod_difest . dpddav=10.*98060.,dpnbav=250.*98060.,ustmin=.1, . kappa=.4,bfeps=1.e-12,sleps=.1,zetas=-1.,as=-28.86, . cs=98.96,minOBLdepth=1.0) +c + public :: ini_difest, difest, OBLdepth c contains c @@ -596,7 +599,6 @@ subroutine difest_vertical_hyb(m,n,mm,nn,k1m,k1n) real :: bl1, bl2, bl3, bl4 integer ki, kki, ksfc, ktmp, kOBL, kn1 real, dimension(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy) :: hOBL - real, dimension(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy) :: OBLdepth c surf_layer_ext = 0.1 bl1 = 8e-5 From 54136cb7f4bb116c7a9220b6510bb20b55b59d4e Mon Sep 17 00:00:00 2001 From: Mats Bentsen Date: Thu, 7 Oct 2021 09:47:24 +0200 Subject: [PATCH 014/366] Replaced temporary hard-coded vertical momentum diffusivities. --- phy/mod_vdiff.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/phy/mod_vdiff.F90 b/phy/mod_vdiff.F90 index dcbf0eca..52ccce9a 100644 --- a/phy/mod_vdiff.F90 +++ b/phy/mod_vdiff.F90 @@ -181,7 +181,7 @@ subroutine cntiso_hybrid_vdiff(m, n, mm, nn, k1m, k1n) kn = k + nn dp_1d(k) = dpu(i, j, kn) u_1d(k) = u(i, j, kn) - nuv_1d(k) = 1._r8 + nuv_1d(k) = Kvisc_m(i, j, k) enddo ! Vertical diffusion equations are solved by backward integration @@ -233,7 +233,7 @@ subroutine cntiso_hybrid_vdiff(m, n, mm, nn, k1m, k1n) kn = k + nn dp_1d(k) = dpv(i, j, kn) v_1d(k) = v(i, j, kn) - nuv_1d(k) = 1._r8 + nuv_1d(k) = Kvisc_m(i, j, k) enddo ! Vertical diffusion equations are solved by backward integration From d7bf2dfd68ce7a4ca3e8410a7171dae647db10cf Mon Sep 17 00:00:00 2001 From: Mats Bentsen Date: Thu, 7 Oct 2021 15:13:18 +0200 Subject: [PATCH 015/366] Made the check sum test at end of simulation more robust. --- drivers/nocoupler/blom.F | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/drivers/nocoupler/blom.F b/drivers/nocoupler/blom.F index dac4d5eb..a3b02b50 100644 --- a/drivers/nocoupler/blom.F +++ b/drivers/nocoupler/blom.F @@ -40,7 +40,7 @@ program blom enddo blom_loop c c --- write check sum of layer thickness - call chksummsk(dp(1-nbdy,1-nbdy,1+mod(nstep2,2)*kk),ip,1,'dp') + call chksummsk(dp(1-nbdy,1-nbdy,1+mod(nstep2,2)*kk),ip,kk,'dp') c if (mnproc.eq.1) then open (unit=nfu,file='run.status',status='unknown') From d25f7d34c226ef8fc077454cffc461c6bde38abd Mon Sep 17 00:00:00 2001 From: Mats Bentsen Date: Thu, 7 Oct 2021 15:15:18 +0200 Subject: [PATCH 016/366] Removed diagnostics of mixed layer velocity. --- phy/mod_dia.F | 94 +++++++++++++----------------------------------- phy/rdlim.F | 4 --- phy/restart_rd.F | 4 --- phy/restart_wt.F | 8 ----- 4 files changed, 24 insertions(+), 86 deletions(-) diff --git a/phy/mod_dia.F b/phy/mod_dia.F index a3baa9bf..57276812 100644 --- a/phy/mod_dia.F +++ b/phy/mod_dia.F @@ -182,14 +182,14 @@ module mod_dia . H2D_HMLTFZ ,H2D_HSNW ,H2D_IAGE ,H2D_IDKEDT ,H2D_LIP , . H2D_MAXMLD ,H2D_MLD ,H2D_MLTS ,H2D_MLTSMN ,H2D_MLTSMX , . H2D_MLTSSQ ,H2D_MTKEUS ,H2D_MTKENI ,H2D_MTKEBF ,H2D_MTKERS , - . H2D_MTKEPE ,H2D_MTKEKE ,H2D_MTY ,H2D_MXLU ,H2D_MXLV , - . H2D_NSF ,H2D_PBOT ,H2D_PSRF ,H2D_RFIFLX ,H2D_RNFFLX , - . H2D_SALFLX ,H2D_SALRLX ,H2D_SBOT ,H2D_SEALV ,H2D_SLVSQ , - . H2D_SFL ,H2D_SOP ,H2D_SIGMX ,H2D_SSS ,H2D_SSSSQ , - . H2D_SST ,H2D_SSTSQ ,H2D_SURFLX ,H2D_SURRLX ,H2D_SWA , - . H2D_T20D ,H2D_TAUX ,H2D_TAUY ,H2D_TBOT ,H2D_TICE , - . H2D_TSRF ,H2D_UB ,H2D_UICE ,H2D_USTAR ,H2D_USTAR3 , - . H2D_VB ,H2D_VICE ,H2D_ZTX , + . H2D_MTKEPE ,H2D_MTKEKE ,H2D_MTY ,H2D_NSF ,H2D_PBOT , + . H2D_PSRF ,H2D_RFIFLX ,H2D_RNFFLX ,H2D_SALFLX ,H2D_SALRLX , + . H2D_SBOT ,H2D_SEALV ,H2D_SLVSQ ,H2D_SFL ,H2D_SOP , + . H2D_SIGMX ,H2D_SSS ,H2D_SSSSQ ,H2D_SST ,H2D_SSTSQ , + . H2D_SURFLX ,H2D_SURRLX ,H2D_SWA ,H2D_T20D ,H2D_TAUX , + . H2D_TAUY ,H2D_TBOT ,H2D_TICE ,H2D_TSRF ,H2D_UB , + . H2D_UICE ,H2D_USTAR ,H2D_USTAR3 ,H2D_VB ,H2D_VICE , + . H2D_ZTX , . LYR_BFSQ ,LYR_DIFDIA ,LYR_DIFVMO ,LYR_DIFVHO ,LYR_DIFVSO , . LYR_DIFINT ,LYR_DIFISO ,LYR_DP ,LYR_DPU ,LYR_DPV , . LYR_DZ ,LYR_SALN ,LYR_TEMP ,LYR_TRC ,LYR_UFLX , @@ -217,15 +217,14 @@ module mod_dia . ACC_HSNW ,ACC_IAGE ,ACC_IDKEDT ,ACC_LIP ,ACC_MAXMLD , . ACC_MLD ,ACC_MLTS ,ACC_MLTSMN ,ACC_MLTSMX ,ACC_MLTSSQ , . ACC_MTKEUS ,ACC_MTKENI ,ACC_MTKEBF ,ACC_MTKERS ,ACC_MTKEPE , - . ACC_MTKEKE ,ACC_MTY ,ACC_MXLU ,ACC_MXLV ,ACC_NSF , - . ACC_PBOT ,ACC_PSRF ,ACC_RFIFLX ,ACC_RNFFLX ,ACC_SALFLX , - . ACC_SALRLX ,ACC_SBOT ,ACC_SEALV ,ACC_SLVSQ ,ACC_SFL , - . ACC_SOP ,ACC_SIGMX ,ACC_SSS ,ACC_SSSSQ ,ACC_SST , - . ACC_SSTSQ ,ACC_SURFLX ,ACC_SURRLX ,ACC_SWA ,ACC_T20D , - . ACC_TAUX ,ACC_TAUY ,ACC_TBOT ,ACC_TICE ,ACC_TSRF , - . ACC_UB ,ACC_UBFLXS ,ACC_UICE ,ACC_USTAR ,ACC_USTAR3 , - . ACC_VB ,ACC_VBFLXS ,ACC_VICE ,ACC_ZTX ,ACC_IVOLU , - . ACC_IVOLV ,ACC_UTILH2D, + . ACC_MTKEKE ,ACC_MTY ,ACC_NSF ,ACC_PBOT ,ACC_PSRF , + . ACC_RFIFLX ,ACC_RNFFLX ,ACC_SALFLX ,ACC_SALRLX ,ACC_SBOT , + . ACC_SEALV ,ACC_SLVSQ ,ACC_SFL ,ACC_SOP ,ACC_SIGMX , + . ACC_SSS ,ACC_SSSSQ ,ACC_SST ,ACC_SSTSQ ,ACC_SURFLX , + . ACC_SURRLX ,ACC_SWA ,ACC_T20D ,ACC_TAUX ,ACC_TAUY , + . ACC_TBOT ,ACC_TICE ,ACC_TSRF ,ACC_UB ,ACC_UBFLXS , + . ACC_UICE ,ACC_USTAR ,ACC_USTAR3 ,ACC_VB ,ACC_VBFLXS , + . ACC_VICE ,ACC_ZTX ,ACC_IVOLU ,ACC_IVOLV ,ACC_UTILH2D, . ACC_BFSQ ,ACC_DIFDIA ,ACC_DIFVMO ,ACC_DIFVHO ,ACC_DIFVSO , . ACC_DIFINT ,ACC_DIFISO ,ACC_DP ,ACC_DPU ,ACC_DPV , . ACC_DZ ,ACC_SALN ,ACC_TEMP ,ACC_UFLX ,ACC_UTFLX , @@ -255,14 +254,14 @@ module mod_dia . H2D_HMLTFZ ,H2D_HSNW ,H2D_IAGE ,H2D_IDKEDT ,H2D_LIP , . H2D_MAXMLD ,H2D_MLD ,H2D_MLTS ,H2D_MLTSMN ,H2D_MLTSMX , . H2D_MLTSSQ ,H2D_MTKEUS ,H2D_MTKENI ,H2D_MTKEBF ,H2D_MTKERS , - . H2D_MTKEPE ,H2D_MTKEKE ,H2D_MTY ,H2D_MXLU ,H2D_MXLV , - . H2D_NSF ,H2D_PBOT ,H2D_PSRF ,H2D_RFIFLX ,H2D_RNFFLX , - . H2D_SALFLX ,H2D_SALRLX ,H2D_SBOT ,H2D_SEALV ,H2D_SLVSQ , - . H2D_SFL ,H2D_SOP ,H2D_SIGMX ,H2D_SSS ,H2D_SSSSQ , - . H2D_SST ,H2D_SSTSQ ,H2D_SURFLX ,H2D_SURRLX ,H2D_SWA , - . H2D_T20D ,H2D_TAUX ,H2D_TAUY ,H2D_TBOT ,H2D_TICE , - . H2D_TSRF ,H2D_UB ,H2D_UICE ,H2D_USTAR ,H2D_USTAR3 , - . H2D_VB ,H2D_VICE ,H2D_ZTX , + . H2D_MTKEPE ,H2D_MTKEKE ,H2D_MTY ,H2D_NSF ,H2D_PBOT , + . H2D_PSRF ,H2D_RFIFLX ,H2D_RNFFLX ,H2D_SALFLX ,H2D_SALRLX , + . H2D_SBOT ,H2D_SEALV ,H2D_SLVSQ ,H2D_SFL ,H2D_SOP , + . H2D_SIGMX ,H2D_SSS ,H2D_SSSSQ ,H2D_SST ,H2D_SSTSQ , + . H2D_SURFLX ,H2D_SURRLX ,H2D_SWA ,H2D_T20D ,H2D_TAUX , + . H2D_TAUY ,H2D_TBOT ,H2D_TICE ,H2D_TSRF ,H2D_UB , + . H2D_UICE ,H2D_USTAR ,H2D_USTAR3 ,H2D_VB ,H2D_VICE , + . H2D_ZTX , . LYR_BFSQ ,LYR_DIFDIA ,LYR_DIFVMO ,LYR_DIFVHO ,LYR_DIFVSO , . LYR_DIFINT ,LYR_DIFISO ,LYR_DP ,LYR_DPU ,LYR_DPV , . LYR_DZ ,LYR_SALN ,LYR_TEMP ,LYR_TRC ,LYR_UFLX , @@ -458,8 +457,6 @@ subroutine diaini ACC_MTKEPE(n) = H2D_MTKEPE(n) ACC_MTKEKE(n) = H2D_MTKEKE(n) ACC_MTY(n) = H2D_MTY(n) - ACC_MXLU(n) = H2D_MXLU(n) - ACC_MXLV(n) = H2D_MXLV(n) ACC_NSF(n) = H2D_NSF(n) ACC_PBOT(n) = H2D_PBOT(n) ACC_PSRF(n) = H2D_PSRF(n) @@ -654,10 +651,6 @@ subroutine diaini ACC_MTKEKE(n)=nphyh2d*min(1,ACC_MTKEKE(n)) if (ACC_MTY(n).ne.0) nphyh2d=nphyh2d+1 ACC_MTY(n)=nphyh2d*min(1,ACC_MTY(n)) - if (ACC_MXLU(n).ne.0) nphyh2d=nphyh2d+1 - ACC_MXLU(n)=nphyh2d*min(1,ACC_MXLU(n)) - if (ACC_MXLV(n).ne.0) nphyh2d=nphyh2d+1 - ACC_MXLV(n)=nphyh2d*min(1,ACC_MXLV(n)) if (ACC_NSF(n).ne.0) nphyh2d=nphyh2d+1 ACC_NSF(n)=nphyh2d*min(1,ACC_NSF(n)) if (ACC_PBOT(n).ne.0) nphyh2d=nphyh2d+1 @@ -1041,23 +1034,6 @@ subroutine diaacc(m,n,mm,nn,k1m,k1n) enddo c$OMP END PARALLEL DO endif -c - if (sum(ACC_MXLU(1:nphy)+ACC_MXLV(1:nphy)).ne.0) then -c$OMP PARALLEL DO PRIVATE(l,i) - do j=1,jj - do l=1,isu(j) - do i=max(1,ifu(j,l)),min(ii,ilu(j,l)) - util2(i,j)=(u(i,j,k1m)+ub(i,j,m))*dpu(i,j,k1m) - enddo - enddo - do l=1,isv(j) - do i=max(1,ifv(j,l)),min(ii,ilv(j,l)) - util4(i,j)=(v(i,j,k1m)+vb(i,j,m))*dpv(i,j,k1m) - enddo - enddo - enddo -c$OMP END PARALLEL DO - endif c if (sum(ACC_MLD(1:nphy)).ne.0) then select case (vcoord_type_tag) @@ -1327,9 +1303,6 @@ subroutine diaacc(m,n,mm,nn,k1m,k1n) c --- weighted u-component of ice velocity [m^2/s] call acch2d(ACC_UICE,uicem,util1,1,'u') c -c --- weighted u-component of total velocity [g/s^3] - call acch2d(ACC_MXLU,util2,dummy,0,'u') -c c --- v-component of barotropic velocity [cm/s] call acch2d(ACC_VB,vb(1-nbdy,1-nbdy,m),dummy,0,'v') c @@ -1345,9 +1318,6 @@ subroutine diaacc(m,n,mm,nn,k1m,k1n) c --- weighted v-component of ice velocity [m^2/s] call acch2d(ACC_VICE,vicem,util3,1,'v') c -c --- weighted v-component of total velocity [g/s^3] - call acch2d(ACC_MXLV,util4,dummy,0,'v') -c c --- surface pressure [g/cm/s^2] call acch2d(ACC_PSRF,p(1-nbdy,1-nbdy,1),dummy,0,'p') c @@ -2554,14 +2524,6 @@ subroutine diaout(iogrp,m,n,mm,nn,k1m,k1n) c call wrth2d(ACC_TBOT(iogrp),H2D_TBOT(iogrp),rnacc,0., . cmpflg,ip,'p','tbot','Bottom temperature',' ','degC') -c - call wrth2d(ACC_MXLU(iogrp),H2D_MXLU(iogrp),1e-2,0., - . cmpflg,iuu,'u','mxlu','Mixed layer velocity x-component',' ', - . 'm s-1') -c - call wrth2d(ACC_MXLV(iogrp),H2D_MXLV(iogrp),1e-2,0., - . cmpflg,ivv,'v','mxlv','Mixed layer velocity y-component',' ', - . 'm s-1') c c --- write 3d layer fields call wrtlyr(ACC_DP(iogrp),LYR_DP(iogrp),rnacc*.1,0., @@ -5213,7 +5175,6 @@ subroutine inifld(iogrp) call inih2d(ACC_UBFLXS(iogrp),'u',0.) call inih2d(ACC_ZTX(iogrp),'u',0.) call inih2d(ACC_TAUX(iogrp),'u',0.) - call inih2d(ACC_MXLU(iogrp),'u',0.) call inih2d(ACC_UICE(iogrp),'u',0.) call inih2d(ACC_IVOLU(iogrp),'u',0.) c @@ -5221,7 +5182,6 @@ subroutine inifld(iogrp) call inih2d(ACC_VBFLXS(iogrp),'v',0.) call inih2d(ACC_MTY(iogrp),'v',0.) call inih2d(ACC_TAUY(iogrp),'v',0.) - call inih2d(ACC_MXLV(iogrp),'v',0.) call inih2d(ACC_VICE(iogrp),'v',0.) call inih2d(ACC_IVOLV(iogrp),'v',0.) c @@ -6344,12 +6304,6 @@ subroutine definevar(irec,iogrp,cmpflg,timeunits,calendar) c call ncdefvar3d(H2D_TBOT(iogrp),cmpflg,'p','tbot', . 'Bottom temperature',' ','degC',0) -c - call ncdefvar3d(H2D_MXLU(iogrp),cmpflg,'u','mxlu', - . 'Mixed layer velocity x-component',' ','m s-1',0) -c - call ncdefvar3d(H2D_MXLV(iogrp),cmpflg,'v','mxlv', - . 'Mixed layer velocity y-component',' ','m s-1',0) c c --- define 3d layer fields call ncdefvar3d(LYR_DP(iogrp),cmpflg,'p','dp', diff --git a/phy/rdlim.F b/phy/rdlim.F index e0eb5470..6eedb3b1 100644 --- a/phy/rdlim.F +++ b/phy/rdlim.F @@ -354,8 +354,6 @@ subroutine rdlim write (lp,*) 'H2D_MTKEPE ',H2D_MTKEPE(1:nphy) write (lp,*) 'H2D_MTKEKE ',H2D_MTKEKE(1:nphy) write (lp,*) 'H2D_MTY ',H2D_MTY(1:nphy) - write (lp,*) 'H2D_MXLU ',H2D_MXLU(1:nphy) - write (lp,*) 'H2D_MXLV ',H2D_MXLV(1:nphy) write (lp,*) 'H2D_NSF ',H2D_NSF(1:nphy) write (lp,*) 'H2D_PBOT ',H2D_PBOT(1:nphy) write (lp,*) 'H2D_PSRF ',H2D_PSRF(1:nphy) @@ -501,8 +499,6 @@ subroutine rdlim call xcbcst(H2D_MTKEPE) call xcbcst(H2D_MTKEKE) call xcbcst(H2D_MTY) - call xcbcst(H2D_MXLU) - call xcbcst(H2D_MXLV) call xcbcst(H2D_NSF) call xcbcst(H2D_PBOT) call xcbcst(H2D_PSRF) diff --git a/phy/restart_rd.F b/phy/restart_rd.F index 617beca6..0e74fc1d 100644 --- a/phy/restart_rd.F +++ b/phy/restart_rd.F @@ -652,10 +652,6 @@ subroutine restart_rd . phyh2d(1-nbdy,1-nbdy,ACC_TAUX(n)),iuu,1,0.) if (ACC_TAUY(n).ne.0) call ncread('tauy_phy'//c2, . phyh2d(1-nbdy,1-nbdy,ACC_TAUY(n)),ivv,1,0.) - if (ACC_MXLU(n).ne.0) call ncread('mxlu_phy'//c2, - . phyh2d(1-nbdy,1-nbdy,ACC_MXLU(n)),iuu,1,0.) - if (ACC_MXLV(n).ne.0) call ncread('mxlv_phy'//c2, - . phyh2d(1-nbdy,1-nbdy,ACC_MXLV(n)),ivv,1,0.) if (ACC_UICE(n).ne.0) call ncread('uice_phy'//c2, . phyh2d(1-nbdy,1-nbdy,ACC_UICE(n)),iuu,1,0.) if (ACC_VICE(n).ne.0) call ncread('vice_phy'//c2, diff --git a/phy/restart_wt.F b/phy/restart_wt.F index 489af60b..6e367092 100644 --- a/phy/restart_wt.F +++ b/phy/restart_wt.F @@ -378,10 +378,6 @@ subroutine restart_wt . trim(c5u)//' time',phyh2d(1-nbdy,1-nbdy,ACC_TAUX(n)),iuu) if (ACC_TAUY(n) .ne.0) call wrtrst('tauy_phy'//c2, . trim(c5v)//' time',phyh2d(1-nbdy,1-nbdy,ACC_TAUY(n)),ivv) - if (ACC_MXLU(n) .ne.0) call wrtrst('mxlu_phy'//c2, - . trim(c5u)//' time',phyh2d(1-nbdy,1-nbdy,ACC_MXLU(n)),iuu) - if (ACC_MXLV(n) .ne.0) call wrtrst('mxlv_phy'//c2, - . trim(c5v)//' time',phyh2d(1-nbdy,1-nbdy,ACC_MXLV(n)),ivv) if (ACC_UICE(n) .ne.0) call wrtrst('uice_phy'//c2, . trim(c5u)//' time',phyh2d(1-nbdy,1-nbdy,ACC_UICE(n)),iuu) if (ACC_VICE(n) .ne.0) call wrtrst('vice_phy'//c2, @@ -968,10 +964,6 @@ subroutine defvar_restart(c5p,c5u,c5v,c5q) if (ACC_TAUX(n) .ne.0) call defvarrst('taux_phy'//c2, . trim(c5u)//' time') if (ACC_TAUY(n) .ne.0) call defvarrst('tauy_phy'//c2, - . trim(c5v)//' time') - if (ACC_MXLU(n) .ne.0) call defvarrst('mxlu_phy'//c2, - . trim(c5u)//' time') - if (ACC_MXLV(n) .ne.0) call defvarrst('mxlv_phy'//c2, . trim(c5v)//' time') if (ACC_UICE(n) .ne.0) call defvarrst('uice_phy'//c2, . trim(c5u)//' time') From e3ca0271bec6a235c44bb9abc3c9dbf94766f245 Mon Sep 17 00:00:00 2001 From: Mats Bentsen Date: Thu, 7 Oct 2021 15:49:02 +0200 Subject: [PATCH 017/366] Added functionality for lateral eddy diffusivity estimation with hybrid vertical coordinate. --- phy/mod_difest.F | 542 +++++++++++++++++++++-------------------------- 1 file changed, 239 insertions(+), 303 deletions(-) diff --git a/phy/mod_difest.F b/phy/mod_difest.F index e1b41a99..757dc8b4 100644 --- a/phy/mod_difest.F +++ b/phy/mod_difest.F @@ -77,8 +77,10 @@ module mod_difest c private c + real, dimension(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy,kdm+1) :: + . rig real, dimension(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy,kdm) :: - . du2l,drhol,rigl + . du2l,drhol,up,vp real, dimension(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy) :: . OBLdepth integer, dimension(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy,kdm) :: @@ -434,9 +436,9 @@ subroutine difest_common_iso(m,n,mm,nn,k1m,k1n) . /max(1,mskv(i,j,k)+mskv(i,j+1,k)) c c --- ------- Local gradient Richardson number. - rigl(i,j,k)=alpha0*alpha0 - . *max(drhomn,drhol(i,j,k))*dp(i,j,kn) - . /max(1.e-9,du2l(i,j,k)) + rig(i,j,k)=alpha0*alpha0 + . *max(drhomn,drhol(i,j,k))*dp(i,j,kn) + . /max(1.e-9,du2l(i,j,k)) c endif enddo @@ -451,10 +453,152 @@ subroutine difest_common_iso(m,n,mm,nn,k1m,k1n) endif call chksummsk(drhol,ip,kk,'drhol') call chksummsk(du2l,ip,kk,'du2l') - call chksummsk(rigl,ip,kk,'rigl') + call chksummsk(rig,ip,kk,'rig') endif c end subroutine difest_common_iso +c + subroutine difest_common_hyb(m,n,mm,nn,k1m,k1n) +c +c --- ------------------------------------------------------------------ +c --- Obtain common fields for the estimation of lateral and vertical +c --- diffusivities diapycnal diffusivities when vcoord_type_tag == +c --- isopyc_bulkml. +c --- ------------------------------------------------------------------ +c + integer m,n,mm,nn,k1m,k1n +c + real, dimension(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy,kdm) :: dv2 + real, dimension(1-nbdy:idm+nbdy,kdm) :: du2 + integer, dimension(1-nbdy:idm+nbdy) :: klpl + integer i,j,k,l,kn + real q,dz +c +c --- Compute squared vertical velocity difference of v-component +c$OMP PARALLEL DO PRIVATE(l,i,klpl,k,kn,q) + do j=1,jj+1 + do l=1,isv(j) + do i=max(1,ifv(j,l)),min(ii,ilv(j,l)) + klpl(i)=1 + enddo + enddo + do k=2,kk + kn=k+nn + do l=1,isv(j) + do i=max(1,ifv(j,l)),min(ii,ilv(j,l)) + if (dpv(i,j,kn).gt.dpbmin) klpl(i)=k + enddo + enddo + enddo + do k=2,kk + do i=1,ii + dv2(i,j,k)=0. + mskv(i,j,k)=0 + enddo + kn=k+nn + do l=1,isv(j) + do i=max(1,ifv(j,l)),min(ii,ilv(j,l)) + if (klpl(i).ge.2.and.k.le.klpl(i)) then + q=v(i,j,kn)-v(i,j,kn-1) + dv2(i,j,k)=q*q + mskv(i,j,k)=1 + endif + enddo + enddo + enddo + enddo +c$OMP END PARALLEL DO +c +c$OMP PARALLEL DO PRIVATE(l,i,klpl,k,kn,du2,q,dz) + do j=1,jj +c +c ----- Compute squared vertical velocity difference of u-component + do l=1,isu(j) + do i=max(1,ifu(j,l)),min(ii+1,ilu(j,l)) + klpl(i)=1 + enddo + enddo + do k=2,kk + kn=k+nn + do l=1,isu(j) + do i=max(1,ifu(j,l)),min(ii+1,ilu(j,l)) + if (dpu(i,j,kn).gt.dpbmin) klpl(i)=k + enddo + enddo + enddo + do k=2,kk + do i=1,ii + du2(i,k)=0. + msku(i,j,k)=0 + enddo + kn=k+nn + do l=1,isu(j) + do i=max(1,ifu(j,l)),min(ii+1,ilu(j,l)) + if (klpl(i).ge.2.and.k.le.klpl(i)) then + q=u(i,j,kn)-u(i,j,kn-1) + du2(i,k)=q*q + msku(i,j,k)=1 + endif + enddo + enddo + enddo +c +c --- - Compute local gradient Richardson number at interfaces. + do l=1,isp(j) + do i=max(1,ifp(j,l)),min(ii,ilp(j,l)) + rig(i,j,1)=0. + enddo + enddo + do k=2,kk + kn=k+nn + do l=1,isp(j) + do i=max(1,ifp(j,l)),min(ii,ilp(j,l)) + if (msku(i,j,k)+msku(i+1,j,k) + . +mskv(i,j,k)+mskv(i,j+1,k).gt.0) then + q=(msku(i,j,k)*du2(i,k) +msku(i+1,j,k)*du2(i+1,k)) + . /max(1,msku(i,j,k)+msku(i+1,j,k)) + . +(mskv(i,j,k)*dv2(i,j,k)+mskv(i,j+1,k)*dv2(i,j+1,k)) + . /max(1,mskv(i,j,k)+mskv(i,j+1,k)) + dz=.5*(dp(i,j,kn-1)+dp(i,j,kn))*alpha0/g + rig(i,j,k)=max(0.,bfsqi(i,j,k)*dz*dz)/max(1.e-9,q) + else + rig(i,j,k)=rig(i,j,k-1) + endif + enddo + enddo + enddo + do l=1,isp(j) + do i=max(1,ifp(j,l)),min(ii,ilp(j,l)) + rig(i,j,1)=rig(i,j,2) + rig(i,j,kk+1)=rig(i,j,kk) + enddo + enddo +c +c --- - Compute velocity components at p-points. + do k=1,kk + kn=k+nn + do l=1,isp(j) + do i=max(1,ifp(j,l)),min(ii,ilp(j,l)) + up(i,j,k)=(msku(i,j,k)*u(i,j,kn)+msku(i+1,j,k)*u(i+1,j,kn)) + . /max(1,msku(i,j,k)+msku(i+1,j,k)) + vp(i,j,k)=(mskv(i,j,k)*v(i,j,kn)+mskv(i,j+1,k)*v(i,j+1,kn)) + . /max(1,mskv(i,j,k)+mskv(i,j+1,k)) + enddo + enddo + enddo +c + enddo +c + if (csdiag) then + if (mnproc.eq.1) then + write (lp,*) 'difest_common_hyb:' + endif + call chksummsk(rig,ip,kk+1,'rig') + call chksummsk(up,ip,kk,'up') + call chksummsk(vp,ip,kk,'vp') + endif +c + end subroutine difest_common_hyb c subroutine difest(m,n,mm,nn,k1m,k1n) c @@ -518,21 +662,25 @@ subroutine difest(m,n,mm,nn,k1m,k1n) c --- - diffusivities diapycnal diffusivities. call difest_common_iso(m,n,mm,nn,k1m,k1n) c +c --- - Estimate vertical diffusivity. + call difest_vertical_iso(m,n,mm,nn,k1m,k1n) +c c --- - Estimate diffusivities for eddy-induced transport and layer-wise c --- - diffusion. call difest_lateral_iso(m,n,mm,nn,k1m,k1n) -c -c --- - Estimate vertical diffusivity. - call difest_vertical_iso(m,n,mm,nn,k1m,k1n) c elseif (vcoord_type_tag == cntiso_hybrid) then c -c --- - Estimate diffusivities for eddy-induced transport and layer-wise -c --- - diffusion. - call difest_lateral_hyb(m,n,mm,nn,k1m,k1n) +c --- - Obtain common fields for the estimation of lateral and vertical +c --- - diffusivities diapycnal diffusivities. + call difest_common_hyb(m,n,mm,nn,k1m,k1n) c c --- - Estimate vertical diffusivities.. call difest_vertical_hyb(m,n,mm,nn,k1m,k1n) +c +c --- - Estimate diffusivities for eddy-induced transport and layer-wise +c --- - diffusion. + call difest_lateral_hyb(m,n,mm,nn,k1m,k1n) c else if (mnproc.eq.1) then @@ -560,7 +708,7 @@ subroutine difest_vertical_hyb(m,n,mm,nn,k1m,k1n) c integer m,n,mm,nn,k1m,k1n c - real, dimension(kdm+1) :: rig + real, dimension(kdm+1) :: rig_i integer i,j,k,l,kn real q c @@ -584,7 +732,6 @@ subroutine difest_vertical_hyb(m,n,mm,nn,k1m,k1n) real, dimension(kdm) :: VT2 ! unresolved shear used for Bulk Ri real, dimension(kdm) :: deltaRho ! delta Rho [g/cm3] in numerator of Bulk Ri number real, dimension(kdm,2) :: nonLocalTrans ! Non-local transport for heat/salt at interfaces [nondim] - real :: DU, DV, DZ, S2 real :: surf_layer_ext, surfFricVel real :: surfBuoyFlux real :: delH, bvfbot, dps @@ -597,7 +744,7 @@ subroutine difest_vertical_hyb(m,n,mm,nn,k1m,k1n) real :: SLdepth_0d, hTot real :: Simmons_coeff, zBottomMinusOffset real :: bl1, bl2, bl3, bl4 - integer ki, kki, ksfc, ktmp, kOBL, kn1 + integer ki, ksfc, ktmp, kOBL, kn1 real, dimension(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy) :: hOBL c surf_layer_ext = 0.1 @@ -636,7 +783,7 @@ subroutine difest_vertical_hyb(m,n,mm,nn,k1m,k1n) rho_zeros(:)= 0. rho_1d = 0. nonLocalTrans(:,:) = 0.0 - rig = 1.e8 !Initialize w/ large Richardson value + rig_i = 1.e8 !Initialize w/ large Richardson value Kv_kpp = 0.0 Kt_kpp = 0.0 Ks_kpp = 0.0 @@ -698,10 +845,8 @@ subroutine difest_vertical_hyb(m,n,mm,nn,k1m,k1n) ! surface averaged fields surfHtemp = surfHtemp + temp(i,j,ktmp)*delH surfHsalt = surfHsalt + saln(i,j,ktmp)*delH - surfHu = surfHu - . +0.5*(u(i,j,ktmp)+u(i+1,j,ktmp))*delH - surfHv = surfHv - . +0.5*(v(i,j,ktmp)+v(i,j+1,ktmp))*delH + surfHu = surfHu+up(i,j,ki)*delH + surfHv = surfHv+vp(i,j,ki)*delH enddo surfTemp = surfHtemp / hTot surfSalt = surfHsalt / hTot @@ -716,8 +861,8 @@ subroutine difest_vertical_hyb(m,n,mm,nn,k1m,k1n) ! vertical shear between present layer and ! surface layer averaged surfU,surfV. ! C-grid average to get Uk and Vk on T-points. - Uk = 0.5*(u(i,j,kn)+u(i+1,j,kn)) - surfU - Vk = 0.5*(v(i,j,kn)+v(i,j+1,kn)) - surfV + Uk = up(i,j,k) - surfU + Vk = vp(i,j,k) - surfV deltaU2(k) = (Uk**2 + Vk**2) ! XXX: Temporary de-scaling of N2_int(i,:) into a @@ -733,22 +878,15 @@ subroutine difest_vertical_hyb(m,n,mm,nn,k1m,k1n) endif c --- ------- Local gradient Richardson number -c DU = (u_p(i,j,k) - u_p(i,j,km1)) -c DV = (v_p(i,j,k) - v_p(i,j,km1)) -c DZ = ((0.5*(dp(i,j,kn1) + dp(i,j,kn))+epsil)) -c S2 = (DU*DU+DV*DV)/(DZ*DZ) -c rig(k) = max(0.,bvfsq_i(k))/max(S2,1.e-10) -c if (p(i,j,kk+1)-p(i,j,k) < epsil) then -c rig(k) = rig(k-1) -c else - + rig_i(k)=rig(i,j,k) +c enddo ! k if(dps.gt.0.) bvfbot=bvfbot/dps ! convert cm2/s2 to m2/s2 deltaU2 = deltaU2*1e-4 ! bottom values for the Ri, N2, and N - rig(kk+1) = rig(kk) + rig_i(kk+1) = rig_i(kk) bvfsq_i(kk+1) = bfsqi(i,j,kk+1) bvf_i(kk+1) = sqrt( max( bvfsq_i(kk+1), 0.) ) @@ -863,7 +1001,7 @@ subroutine difest_vertical_hyb(m,n,mm,nn,k1m,k1n) ! Call to CVMix wrapper for computing interior mixing coefficients. call CVMix_coeffs_shear(Mdiff_out=Kv_shr(:), . Tdiff_out=Kd_shr(:), - . RICH=rig(:), + . RICH=rig_i(:), . nlev=kk, . max_nlev=kk) @@ -927,215 +1065,69 @@ subroutine difest_lateral_hyb(m,n,mm,nn,k1m,k1n) integer m,n,mm,nn,k1m,k1n c c - real, dimension(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy,kdm) :: - . dv2 - real, dimension(1-nbdy:idm+nbdy,kdm) :: - . du2,egr + real, dimension(1-nbdy:idm+nbdy,kdm) :: egr real, dimension(1-nbdy:idm+nbdy) :: - . tup,pup,sup,cr,bcrrd,afeql,dps,egrs,egrup,dfints,urmse,cpse - integer, dimension(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy) :: - . kfil,kmax - integer, dimension(1-nbdy:idm+nbdy) :: - . kfpl,klpl + . tup,pup,sup,cr,bcrrd,afeql,dps,egrs,egrup,dfints,udps,vdps, + . umlzon,urmse,cpse integer i,j,k,l,kn real q,plo,tlo,slo,rhisc,els,egrlo,umnsc,esfac c c --- Locate the range of layers to be considered in the computation of c --- diffusivities. - do j=0,jj+1 - do i=0,ii+1 + do j=1,jj + do i=1,ii kmax(i,j)=0 enddo do l=1,isp(j) - do i=max(0,ifp(j,l)),min(ii+1,ilp(j,l)) + do i=max(1,ifp(j,l)),min(ii,ilp(j,l)) kmax(i,j)=1 - do k=3,kk + do k=2,kk kn=k+nn if (dp(i,j,kn).gt.dpbmin) kmax(i,j)=k enddo - if (kfpla(i,j,n).ge.kmax(i,j)) then - kfil(i,j)=kfpla(i,j,n)+1 - else - if (sigma(i,j,kfpla(i,j,n)+nn).lt. - . .5*(sigmar(i,j,kfpla(i,j,n) ) - . +sigmar(i,j,kfpla(i,j,n)+1))) then - kfil(i,j)=kfpla(i,j,n)+1 - else - kfil(i,j)=kfpla(i,j,n)+2 - endif - endif - enddo - enddo - enddo -c -c$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)) - util1(i,j)=kfil(i,j) - enddo - enddo - enddo -c$OMP END PARALLEL DO - call xctilr(util1, 1,1, 1,1, halo_ps) -c$OMP PARALLEL DO PRIVATE(l,i) - do j=0,jj+1 - do l=1,isp(j) - do i=max(0,ifp(j,l)),min(ii+1,ilp(j,l)) - kfil(i,j)=nint(util1(i,j)) - enddo - enddo - enddo -c$OMP END PARALLEL DO -c -c --- Compute squared vertical velocity gradients of v-component -c$OMP PARALLEL DO PRIVATE(l,i,kfpl,klpl,k,kn,q,tup) - do j=1,jj+1 - do l=1,isv(j) - do i=max(1,ifv(j,l)),min(ii,ilv(j,l)) - kfpl(i)=kk+1 - klpl(i)=1 - enddo - enddo - do k=3,kk - kn=k+nn - do l=1,isv(j) - do i=max(1,ifv(j,l)),min(ii,ilv(j,l)) - if (dpv(i,j,kn).gt.dpbmin) klpl(i)=k - enddo + kfil(i,j)=kk+1 + do k=kk,2,-1 + if (p(i,j,k).gt.OBLdepth(i,j)*onem) kfil(i,j)=k enddo enddo - do k=kk,4,-1 - kn=k+nn - do l=1,isv(j) - do i=max(1,ifv(j,l)),min(ii,ilv(j,l)) - if (k.ge.max(kfil(i,j-1),kfil(i,j)).and. - . dpv(i,j,kn).gt.dptmin) kfpl(i)=k - enddo - enddo - enddo - do k=1,kk - kn=k+nn - do i=1,ii - dv2(i,j,k)=0. - mskv(i,j,k)=0 - enddo - do l=1,isv(j) - do i=max(1,ifv(j,l)),min(ii,ilv(j,l)) - if (k.ge.kfpl(i).and.k.le.klpl(i).and. - . klpl(i)-kfpl(i).ge.1) then - if (k.eq.kfpl(i)) then - q=v(i,j,kn+1)-v(i,j,kn) - q=q*q - dv2(i,j,k)=q - tup(i)=q - elseif (k.lt.klpl(i)) then - q=v(i,j,kn+1)-v(i,j,kn) - q=q*q - dv2(i,j,k)=.5*(tup(i)+q) - tup(i)=q - else - dv2(i,j,k)=tup(i) - endif - mskv(i,j,k)=1 - endif - enddo - enddo enddo enddo -c$OMP END PARALLEL DO c c$OMP PARALLEL DO PRIVATE( -c$OMP+ l,i,kfpl,klpl,k,kn,du2,q,tup,pup,sup,cr,plo,tlo,slo,bcrrd, +c$OMP+ l,i,k,kn,q,tup,pup,sup,cr,plo,tlo,slo,bcrrd, c$OMP+ afeql,dps,egrs,egr,egrup,egrlo,dfints, -c$OMP+ rhisc,els,urmse,cpse,umnsc,esfac) +c$OMP+ rhisc,els,udps,vdps,umlzon,urmse,cpse,umnsc,esfac) do j=1,jj c -c ----- Compute squared vertical velocity gradients of u-component - do l=1,isu(j) - do i=max(1,ifu(j,l)),min(ii+1,ilu(j,l)) - kfpl(i)=kk+1 - klpl(i)=1 - enddo - enddo - do k=3,kk - kn=k+nn - do l=1,isu(j) - do i=max(1,ifu(j,l)),min(ii+1,ilu(j,l)) - if (dpu(i,j,kn).gt.dpbmin) klpl(i)=k - enddo - enddo - enddo - do k=kk,4,-1 - kn=k+nn - do l=1,isu(j) - do i=max(1,ifu(j,l)),min(ii+1,ilu(j,l)) - if (k.ge.min(kfil(i-1,j),kfil(i,j)).and. - . dpu(i,j,kn).gt.dptmin) kfpl(i)=k - enddo - enddo - enddo - do k=1,kk - kn=k+nn - do i=1,ii+1 - du2(i,k)=0. - msku(i,j,k)=0 - enddo - do l=1,isu(j) - do i=max(1,ifu(j,l)),min(ii+1,ilu(j,l)) - if (k.ge.kfpl(i).and.k.le.klpl(i).and. - . klpl(i)-kfpl(i).ge.1) then - if (k.eq.kfpl(i)) then - q=u(i,j,kn+1)-u(i,j,kn) - q=q*q - du2(i,k)=q - tup(i)=q - elseif (k.lt.klpl(i)) then - q=u(i,j,kn+1)-u(i,j,kn) - q=q*q - du2(i,k)=.5*(tup(i)+q) - tup(i)=q - else - du2(i,k)=tup(i) - endif - msku(i,j,k)=1 - endif - enddo - enddo - enddo -c c ----- Compute the first baroclinic rossby radius of deformation using c ----- the WKB approximation by Chelton at al. (1998). -c ----- !!! Could include top layer in computation !!! do l=1,isp(j) do i=max(1,ifp(j,l)),min(ii,ilp(j,l)) - pup(i)=.5*(3.*p(i,j,3)-p(i,j,min(kk,kfpla(i,j,n))+1)) - kn=2+nn + pup(i)=p(i,j,1) + kn=1+nn tup(i)=temp(i,j,kn) sup(i)=saln(i,j,kn) cr(i)=0. enddo enddo - do k=3,kk + do k=2,kk kn=k+nn do l=1,isp(j) do i=max(1,ifp(j,l)),min(ii,ilp(j,l)) - if (k.ge.kfpla(i,j,n)) then - if (p(i,j,kk+1)-p(i,j,k+1).lt.epsil) then - plo=p(i,j,kk+1) - else - plo=.5*(p(i,j,k)+p(i,j,k+1)) - endif - tlo=temp(i,j,kn) - slo=saln(i,j,kn) - cr(i)=cr(i) - . +sqrt(max(0.,(rho(p(i,j,k),tlo,slo) - . -rho(p(i,j,k),tup(i),sup(i))) - . *(plo-pup(i)))) - pup(i)=plo - tup(i)=tlo - sup(i)=slo + if (p(i,j,kk+1)-p(i,j,k+1).lt.epsil) then + plo=p(i,j,kk+1) + else + plo=.5*(p(i,j,k)+p(i,j,k+1)) endif + tlo=temp(i,j,kn) + slo=saln(i,j,kn) + cr(i)=cr(i) + . +sqrt(max(0.,(rho(p(i,j,k),tlo,slo) + . -rho(p(i,j,k),tup(i),sup(i))) + . *(plo-pup(i)))) + pup(i)=plo + tup(i)=tlo + sup(i)=slo enddo enddo enddo @@ -1150,45 +1142,6 @@ subroutine difest_lateral_hyb(m,n,mm,nn,k1m,k1n) enddo enddo c -c ----- Compute local gradient richardson number. - do k=4,kk - kn=k+nn - do l=1,isp(j) - do i=max(1,ifp(j,l)),min(ii,ilp(j,l)) - if (k.ge.kfil(i,j).and.k.le.kmax(i,j).and. - . kmax(i,j)-kfil(i,j).ge.1) then - if (k.eq.kfil(i,j)) then - q=max(0.,rho(p(i,j,k+1),temp(i,j,kn+1),saln(i,j,kn+1)) - . -rho(p(i,j,k+1),temp(i,j,kn ),saln(i,j,kn ))) - drhol(i,j,k)=q - tup(i)=q - elseif (k.lt.kmax(i,j)) then - q=max(0.,rho(p(i,j,k+1),temp(i,j,kn+1),saln(i,j,kn+1)) - . -rho(p(i,j,k+1),temp(i,j,kn ),saln(i,j,kn ))) - drhol(i,j,k)=2.*tup(i)*q/max(1.e-14,tup(i)+q) - tup(i)=q - else - drhol(i,j,k)=tup(i) - endif -c -c --- ------- Vertical squared velocity difference. - du2l(i,j,k)=(msku(i ,j,k)*du2(i ,k) - . +msku(i+1,j,k)*du2(i+1,k)) - . /max(1,msku(i,j,k)+msku(i+1,j,k)) - . +(mskv(i,j ,k)*dv2(i,j ,k) - . +mskv(i,j+1,k)*dv2(i,j+1,k)) - . /max(1,mskv(i,j,k)+mskv(i,j+1,k)) -c -c --- ------- Local gradient Richardson number. - rigl(i,j,k)=alpha0*alpha0 - . *max(drhomn,drhol(i,j,k))*dp(i,j,kn) - . /max(1.e-9,du2l(i,j,k)) -c - endif - enddo - enddo - enddo -c c --- - Compute diffusivity weigth to reduce eddy diffusivity when the c --- - Rossby radius is resolved by the grid. if (edwmth.eq.'smooth') then @@ -1216,8 +1169,8 @@ subroutine difest_lateral_hyb(m,n,mm,nn,k1m,k1n) write (lp,'(3a)') ' edwmth=',trim(edwmth), . ' is unsupported!' endif - call xcstop('(difest)') - stop '(difest)' + call xcstop('(difest_lateral_hyb)') + stop '(difest_lateral_hyb)' endif c c --- ------------------------------------------------------------------ @@ -1264,7 +1217,8 @@ subroutine difest_lateral_hyb(m,n,mm,nn,k1m,k1n) do i=max(1,ifp(j,l)),min(ii,ilp(j,l)) if (k.ge.kfil(i,j).and.k.le.kmax(i,j).and. . kmax(i,j)-kfil(i,j).ge.1) then - egr(i,k)=afeql(i)/sqrt(rigl(i,j,k)+eggam) + egr(i,k)=afeql(i) + . /sqrt(.5*(rig(i,j,k)+rig(i,j,k+1))+eggam) if (edsprs) then q=max(0.,min(p(i,j,kfil(i,j))+dpgrav, . p(i,j,k+1))-p(i,j,k)) @@ -1399,6 +1353,33 @@ subroutine difest_lateral_hyb(m,n,mm,nn,k1m,k1n) c c --- --- Eddy diffusivity modification of surface non-isopycnic c --- --- layers. +c + if (edsprs) then +c +c --- ----- Zonal mixed layer velocity. + do l=1,isp(j) + do i=max(1,ifp(j,l)),min(ii,ilp(j,l)) + udps(i)=0. + vdps(i)=0. + enddo + enddo + do k=1,kk + do l=1,isp(j) + do i=max(1,ifp(j,l)),min(ii,ilp(j,l)) + q=max(0.,min(p(i,j,k+1),OBLdepth(i,j)*onem)-p(i,j,k)) + udps(i)=udps(i)+up(i,j,k)*q + vdps(i)=vdps(i)+vp(i,j,k)*q + enddo + enddo + enddo + do l=1,isp(j) + do i=max(1,ifp(j,l)),min(ii,ilp(j,l)) + umlzon(i)=(udps(i)*cosang(i,j)-vdps(i)*sinang(i,j)) + . /(OBLdepth(i,j)*onem) + enddo + enddo + endif +c do l=1,isp(j) do i=max(1,ifp(j,l)),min(ii,ilp(j,l)) c @@ -1425,44 +1406,7 @@ subroutine difest_lateral_hyb(m,n,mm,nn,k1m,k1n) c --- --------- that only the baroclinic component is used since the c --- --------- barotropic velocity is subtracted from the estimate of c --- --------- eddy phase speed. - if (ip(i-1,j)+ip(i+1,j).eq.2) then - q=.5*((u(i ,j,1+nn)*dpu(i ,j,1+nn) - . +u(i ,j,2+nn)*dpu(i ,j,2+nn)) - . /(dpu(i ,j,1+nn)+dpu(i ,j,2+nn)) - . +(u(i+1,j,1+nn)*dpu(i+1,j,1+nn) - . +u(i+1,j,2+nn)*dpu(i+1,j,2+nn)) - . /(dpu(i+1,j,1+nn)+dpu(i+1,j,2+nn))) - elseif (ip(i-1,j).eq.1) then - q=(u(i ,j,1+nn)*dpu(i ,j,1+nn) - . +u(i ,j,2+nn)*dpu(i ,j,2+nn)) - . /(dpu(i ,j,1+nn)+dpu(i ,j,2+nn)) - elseif (ip(i+1,j).eq.1) then - q=(u(i+1,j,1+nn)*dpu(i+1,j,1+nn) - . +u(i+1,j,2+nn)*dpu(i+1,j,2+nn)) - . /(dpu(i+1,j,1+nn)+dpu(i+1,j,2+nn)) - else - q=0. - endif - umnsc=q*cosang(i,j) - if (ip(i,j-1)+ip(i,j+1).eq.2) then - q=.5*((v(i,j ,1+nn)*dpv(i,j ,1+nn) - . +v(i,j ,2+nn)*dpv(i,j ,2+nn)) - . /(dpv(i,j ,1+nn)+dpv(i,j ,2+nn)) - . +(v(i,j+1,1+nn)*dpv(i,j+1,1+nn) - . +v(i,j+1,2+nn)*dpv(i,j+1,2+nn)) - . /(dpv(i,j+1,1+nn)+dpv(i,j+1,2+nn))) - elseif (ip(i,j-1).eq.1) then - q=(v(i,j ,1+nn)*dpv(i,j ,1+nn) - . +v(i,j ,2+nn)*dpv(i,j ,2+nn)) - . /(dpv(i,j ,1+nn)+dpv(i,j ,2+nn)) - elseif (ip(i,j+1).eq.1) then - q=(v(i,j+1,1+nn)*dpv(i,j+1,1+nn) - . +v(i,j+1,2+nn)*dpv(i,j+1,2+nn)) - . /(dpv(i,j+1,1+nn)+dpv(i,j+1,2+nn)) - else - q=0. - endif - umnsc=umnsc-q*sinang(i,j)-cpse(i) + umnsc=umlzon(i)-cpse(i) c c --- --------- Eddy mixing suppresion factor where lower bounds of c --- --------- zonal velocity minus eddy phase speed and absolute value @@ -1495,12 +1439,8 @@ subroutine difest_lateral_hyb(m,n,mm,nn,k1m,k1n) if (edsprs) then c c --- ----------- Zonal velocity minus eddy phase speed. - umnsc= - . (msku(i,j,k)*u(i,j,kn)+msku(i+1,j,k)*u(i+1,j,kn)) - . /max(1,msku(i,j,k)+msku(i+1,j,k))*cosang(i,j) - . -(mskv(i,j,k)*v(i,j,kn)+mskv(i,j+1,k)*v(i,j+1,kn)) - . /max(1,mskv(i,j,k)+mskv(i,j+1,k))*sinang(i,j) - . -cpse(i) + umnsc=up(i,j,k)*cosang(i,j)-vp(i,j,k)*sinang(i,j) + . -cpse(i) c c --- ----------- Eddy mixing suppresion factor. esfac=1./(1.+4.*(umnsc/max(5.,abs(urmse(i))))**2) @@ -1533,16 +1473,13 @@ subroutine difest_lateral_hyb(m,n,mm,nn,k1m,k1n) enddo c endif - enddo ! j=1,jj at line 360 + enddo c$OMP END PARALLEL DO c if (csdiag) then if (mnproc.eq.1) then write (lp,*) 'difest_lateral_hyb:' endif - call chksummsk(drhol,ip,kk,'drhol') - call chksummsk(du2l,ip,kk,'du2l') - call chksummsk(rigl,ip,kk,'rigl') call chksummsk(difint,ip,kk,'difint') call chksummsk(difiso,ip,kk,'difiso') endif @@ -1558,8 +1495,7 @@ subroutine difest_lateral_iso(m,n,mm,nn,k1m,k1n) c integer m,n,mm,nn,k1m,k1n c - real, dimension(1-nbdy:idm+nbdy,kdm) :: - . egr + real, dimension(1-nbdy:idm+nbdy,kdm) :: egr real, dimension(1-nbdy:idm+nbdy) :: . tup,pup,sup,cr,bcrrd,afeql,dps,egrs,egrup,dfints,urmse,cpse integer i,j,k,l,kn @@ -1692,7 +1628,7 @@ subroutine difest_lateral_iso(m,n,mm,nn,k1m,k1n) do i=max(1,ifp(j,l)),min(ii,ilp(j,l)) if (k.ge.kfil(i,j).and.k.le.kmax(i,j).and. . kmax(i,j)-kfil(i,j).ge.1) then - egr(i,k)=afeql(i)/sqrt(rigl(i,j,k)+eggam) + egr(i,k)=afeql(i)/sqrt(rig(i,j,k)+eggam) if (edsprs) then q=max(0.,min(p(i,j,kfil(i,j))+dpgrav, . p(i,j,k+1))-p(i,j,k)) @@ -1961,7 +1897,7 @@ subroutine difest_lateral_iso(m,n,mm,nn,k1m,k1n) enddo c endif - enddo ! j=1,jj at line 360 + enddo c$OMP END PARALLEL DO c c @@ -1983,7 +1919,7 @@ subroutine difest_vertical_iso(m,n,mm,nn,k1m,k1n) c integer m,n,mm,nn,k1m,k1n c - real, dimension(1-nbdy:idm+nbdy,kdm) :: bvfsq,bvf,rig + real, dimension(1-nbdy:idm+nbdy,kdm) :: bvfsq,bvf real, dimension(1-nbdy:idm+nbdy) :: bvfbot,dps,dfddsu,dfddsl integer i,j,k,l,kn real q,nus,nub,nut,nuls,vsf,nusm,ust,mols,h,sg,zeta,phis,ws @@ -2110,7 +2046,7 @@ subroutine difest_vertical_iso(m,n,mm,nn,k1m,k1n) c #if !defined(TRC) || !defined(TKE) c --- ------- Shear driven diapycnal mixing. - if (rigl(i,j,k).lt.ri0) then + if (rig(i,j,k).lt.ri0) then c c --- --------- Maximum diffusivity is increased near the bottom to c --- --------- provide additional mixing of gravity currents. @@ -2122,7 +2058,7 @@ subroutine difest_vertical_iso(m,n,mm,nn,k1m,k1n) c c --- --------- Parameterization of diffusivity as a function of local c --- --------- gradient richardson number. - q=rigl(i,j,k)/ri0 + q=rig(i,j,k)/ri0 q=max(0.,1.-q*q) nus=nus*q*q*q else From a6a3b875a1414d2c8a99e186c3970d78089b2153 Mon Sep 17 00:00:00 2001 From: Mats Bentsen Date: Sat, 9 Oct 2021 23:53:04 +0200 Subject: [PATCH 018/366] Reduced memory usage in checksum routines. --- phy/mod_checksum.F90 | 60 ++++++++++++++++++++++++-------------------- 1 file changed, 33 insertions(+), 27 deletions(-) diff --git a/phy/mod_checksum.F90 b/phy/mod_checksum.F90 index 73851df8..176929be 100644 --- a/phy/mod_checksum.F90 +++ b/phy/mod_checksum.F90 @@ -28,7 +28,7 @@ module mod_checksum ! Constants. logical :: & - csdiag = .false. ! Flag that indicates whether checksums are written. + csdiag = .true. ! Flag that indicates whether checksums are written. integer :: crcfast external :: crcfast @@ -47,16 +47,22 @@ subroutine chksum(a, kcsd, text) intent(in) :: a character(len = *), intent(in) :: text - real(r8), dimension(itdm, jtdm, kcsd) :: aa + real(r8), dimension(itdm, jtdm) :: aa + integer, dimension(kcsd) :: cslist integer :: kcs do kcs = 1, kcsd - call xcaget(aa(1, 1, kcs), a(1 - nbdy, 1 - nbdy, kcs), 1) + call xcaget(aa, a(1 - nbdy, 1 - nbdy, kcs), 1) + cslist(kcs) = crcfast(aa, itdm*jtdm*8) enddo if (mnproc == 1) then - write (lp,'(3a,z8.8)') ' chksum: ', text, ': 0x', & - crcfast(aa, itdm*jtdm*kcsd*8) + if (kcsd == 1) then + write (lp,'(3a,z8.8)') ' chksum: ', text, ': 0x', cslist(1) + else + write (lp,'(3a,z8.8)') ' chksum: ', text, ': 0x', & + crcfast(cslist, kcsd*4) + endif endif end subroutine chksum @@ -73,34 +79,34 @@ subroutine chksummsk(a, msk, kcsd, text) intent(in) :: msk character(len = *), intent(in) :: text - real(r8), dimension(itdm, jtdm, kcsd) :: aa - real(r8), dimension(itdm, jtdm) :: rrmsk - real(r8), dimension(1 - nbdy:idm + nbdy,1 - nbdy:jdm + nbdy) :: rmsk + real(r8), dimension(1 - nbdy:idm + nbdy,1 - nbdy:jdm + nbdy) :: amsk + real(r8), dimension(itdm, jtdm) :: aa + integer, dimension(kcsd) :: cslist integer :: ics, jcs, kcs - do jcs = 1, jj - do ics = 1, ii - rmsk(ics, jcs) = msk(ics, jcs) - enddo - enddo - do kcs = 1, kcsd - call xcaget(aa(1 , 1, kcs), a(1 - nbdy, 1 - nbdy, kcs), 1) + !$omp parallel do private(ics) + do jcs = 1, jj + do ics = 1, ii + if (msk(ics, jcs) == 0) then + amsk(ics, jcs) = 0._r8 + else + amsk(ics, jcs) = a(ics, jcs, kcs) + endif + enddo + enddo + !$omp end parallel do + call xcaget(aa, amsk, 1) + cslist(kcs) = crcfast(aa, itdm*jtdm*8) enddo - call xcaget(rrmsk, rmsk, 1) if (mnproc == 1) then - do kcs = 1, kcsd - do jcs = 1, jtdm - do ics = 1, itdm - if (rrmsk(ics, jcs) < .5_r8) then - aa(ics, jcs, kcs) = 0._r8 - endif - enddo - enddo - enddo - write (lp,'(3a,z8.8)') ' chksum: ', text, ': 0x', & - crcfast(aa, itdm*jtdm*kcsd*8) + if (kcsd == 1) then + write (lp,'(3a,z8.8)') ' chksum: ', text, ': 0x', cslist(1) + else + write (lp,'(3a,z8.8)') ' chksum: ', text, ': 0x', & + crcfast(cslist, kcsd*4) + endif endif end subroutine chksummsk From e019db2b7f52fc7cab828c3d5813cef9858897b4 Mon Sep 17 00:00:00 2001 From: Mats Bentsen Date: Sun, 10 Oct 2021 00:18:25 +0200 Subject: [PATCH 019/366] Corrected estimation of diffusion at tile boundaries. --- phy/inivar.F90 | 3 ++- phy/mod_difest.F | 58 +++++++++++++++++++++++++++++++++++++++++++----- 2 files changed, 54 insertions(+), 7 deletions(-) diff --git a/phy/inivar.F90 b/phy/inivar.F90 index aed869da..cc44445f 100644 --- a/phy/inivar.F90 +++ b/phy/inivar.F90 @@ -31,7 +31,7 @@ subroutine inivar use mod_barotp, only: inivar_barotp use mod_tmsmt, only: inivar_tmsmt use mod_diffusion, only: inivar_diffusion - use mod_difest, only: ini_difest + use mod_difest, only: inivar_difest, ini_difest use mod_utility, only: inivar_utility use mod_mxlayr, only: inivar_mxlayr use mod_seaice, only: inivar_seaice @@ -55,6 +55,7 @@ subroutine inivar call inivar_barotp call inivar_tmsmt call inivar_diffusion + call inivar_difest call ini_difest call inivar_utility call inivar_mxlayr diff --git a/phy/mod_difest.F b/phy/mod_difest.F index 757dc8b4..ebe8b2bd 100644 --- a/phy/mod_difest.F +++ b/phy/mod_difest.F @@ -20,7 +20,7 @@ module mod_difest c use mod_types, only: r8 - use mod_constants, only: g, alpha0, pi, epsil, onem, onecm + use mod_constants, only: g, alpha0, pi, epsil, spval, onem, onecm use mod_time, only: delt1 use mod_xc use mod_vcoord, only: sigmar @@ -171,9 +171,40 @@ module mod_difest . kappa=.4,bfeps=1.e-12,sleps=.1,zetas=-1.,as=-28.86, . cs=98.96,minOBLdepth=1.0) c - public :: ini_difest, difest, OBLdepth + public :: inivar_difest, ini_difest, difest, OBLdepth c contains +c + subroutine inivar_difest +c +c --- ------------------------------------------------------------------ +c --- Initialize arrays. +c --- ------------------------------------------------------------------ +c + integer :: i,j,k +c +c$OMP PARALLEL DO PRIVATE(i,k) + do j=1-nbdy,jj+nbdy + do k=1,kk+1 + do i=1-nbdy,ii+nbdy + rig(i,j,k)=spval + enddo + enddo + do k=1,kk + do i=1-nbdy,ii+nbdy + du2l(i,j,k)=spval + drhol(i,j,k)=spval + up(i,j,k)=spval + vp(i,j,k)=spval + enddo + enddo + do i=1-nbdy,ii+nbdy + OBLdepth(i,j)=spval + enddo + enddo +c$OMP END PARALLEL DO +c + end subroutine inivar_difest c subroutine ini_difest c @@ -527,7 +558,7 @@ subroutine difest_common_hyb(m,n,mm,nn,k1m,k1n) enddo enddo do k=2,kk - do i=1,ii + do i=1,ii+1 du2(i,k)=0. msku(i,j,k)=0 enddo @@ -1052,6 +1083,15 @@ subroutine difest_vertical_hyb(m,n,mm,nn,k1m,k1n) c end of single column c enddo ! j-index +c + if (csdiag) then + if (mnproc.eq.1) then + write (lp,*) 'difest_vertical_hyb:' + endif + call chksummsk(Kvisc_m,ip,kk,'Kvisc_m') + call chksummsk(Kdiff_t,ip,kk,'Kdiff_t') + call chksummsk(Kdiff_s,ip,kk,'Kdiff_s') + endif c end subroutine difest_vertical_hyb c @@ -1074,17 +1114,23 @@ subroutine difest_lateral_hyb(m,n,mm,nn,k1m,k1n) c c --- Locate the range of layers to be considered in the computation of c --- diffusivities. - do j=1,jj - do i=1,ii + do j=0,jj+1 + do i=0,ii+1 kmax(i,j)=0 enddo do l=1,isp(j) - do i=max(1,ifp(j,l)),min(ii,ilp(j,l)) + do i=max(0,ifp(j,l)),min(ii+1,ilp(j,l)) kmax(i,j)=1 do k=2,kk kn=k+nn if (dp(i,j,kn).gt.dpbmin) kmax(i,j)=k enddo + enddo + enddo + enddo + do j=1,jj + do l=1,isp(j) + do i=max(1,ifp(j,l)),min(ii,ilp(j,l)) kfil(i,j)=kk+1 do k=kk,2,-1 if (p(i,j,k).gt.OBLdepth(i,j)*onem) kfil(i,j)=k From c461b903bb450d37065f14692c135c1c52b7ae09 Mon Sep 17 00:00:00 2001 From: Mats Bentsen Date: Sun, 10 Oct 2021 00:20:15 +0200 Subject: [PATCH 020/366] Corrected dependencies in diagnostic variables. --- phy/mod_dia.F | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/phy/mod_dia.F b/phy/mod_dia.F index 57276812..71bae078 100644 --- a/phy/mod_dia.F +++ b/phy/mod_dia.F @@ -1094,7 +1094,10 @@ subroutine diaacc(m,n,mm,nn,k1m,k1n) c$OMP END PARALLEL DO endif c - if (sum(ACC_DZ(1:nphy)+ACC_DZLVL(1:nphy)).ne.0) then + if (sum(ACC_MLTS(1:nphy)+ACC_MLTSMN(1:nphy) + . +ACC_MLTSMX(1:nphy)+ACC_MLTSSQ(1:nphy) + . +ACC_T20D(1:nphy) + . +ACC_DZ(1:nphy)+ACC_DZLVL(1:nphy)).ne.0) then c$OMP PARALLEL DO PRIVATE(l,i) do j=1,jj do l=1,isp(j) From 9d6cc6893f2c3372231a1cfcd1b2bb3deb4c9965 Mon Sep 17 00:00:00 2001 From: Mats Bentsen Date: Sun, 10 Oct 2021 00:57:56 +0200 Subject: [PATCH 021/366] Added polymorphic interface to CRC32 checksum routine. --- phy/mod_checksum.F90 | 49 ++++++++++++++++++++++++++++++++++++-------- 1 file changed, 41 insertions(+), 8 deletions(-) diff --git a/phy/mod_checksum.F90 b/phy/mod_checksum.F90 index 176929be..6181a9c4 100644 --- a/phy/mod_checksum.F90 +++ b/phy/mod_checksum.F90 @@ -30,13 +30,48 @@ module mod_checksum logical :: & csdiag = .true. ! Flag that indicates whether checksums are written. - integer :: crcfast - external :: crcfast + interface crc32 + module procedure crc32_1d_integer, crc32_2d_r8 + end interface crc32 public :: csdiag, chksum, chksummsk contains + ! --------------------------------------------------------------------------- + ! Private procedures. + ! --------------------------------------------------------------------------- + + function crc32_1d_integer(a) + + integer, dimension(:), intent(in) :: a + + integer :: crc32_1d_integer + + integer :: crcfast + external :: crcfast + + crc32_1d_integer = crcfast(a, size(a)*4) + + end function crc32_1d_integer + + function crc32_2d_r8(a) + + real(r8), dimension(:,:), intent(in) :: a + + integer :: crc32_2d_r8 + + integer :: crcfast + external :: crcfast + + crc32_2d_r8 = crcfast(a, size(a)*8) + + end function crc32_2d_r8 + + ! --------------------------------------------------------------------------- + ! Public procedures. + ! --------------------------------------------------------------------------- + subroutine chksum(a, kcsd, text) ! --------------------------------------------------------------------------- ! Compute checksum of model field. @@ -53,15 +88,14 @@ subroutine chksum(a, kcsd, text) do kcs = 1, kcsd call xcaget(aa, a(1 - nbdy, 1 - nbdy, kcs), 1) - cslist(kcs) = crcfast(aa, itdm*jtdm*8) + cslist(kcs) = crc32(aa) enddo if (mnproc == 1) then if (kcsd == 1) then write (lp,'(3a,z8.8)') ' chksum: ', text, ': 0x', cslist(1) else - write (lp,'(3a,z8.8)') ' chksum: ', text, ': 0x', & - crcfast(cslist, kcsd*4) + write (lp,'(3a,z8.8)') ' chksum: ', text, ': 0x', crc32(cslist) endif endif @@ -97,15 +131,14 @@ subroutine chksummsk(a, msk, kcsd, text) enddo !$omp end parallel do call xcaget(aa, amsk, 1) - cslist(kcs) = crcfast(aa, itdm*jtdm*8) + cslist(kcs) = crc32(aa) enddo if (mnproc == 1) then if (kcsd == 1) then write (lp,'(3a,z8.8)') ' chksum: ', text, ': 0x', cslist(1) else - write (lp,'(3a,z8.8)') ' chksum: ', text, ': 0x', & - crcfast(cslist, kcsd*4) + write (lp,'(3a,z8.8)') ' chksum: ', text, ': 0x', crc32(cslist) endif endif From 15737305dc88dd3ef299628fe2c5d1b8944a8c61 Mon Sep 17 00:00:00 2001 From: Mats Bentsen Date: Sun, 10 Oct 2021 01:52:54 +0200 Subject: [PATCH 022/366] Moved call to initialization routine for diffusivity estimation. --- phy/iniphy.F | 6 ++++++ phy/inivar.F90 | 3 +-- phy/mod_difest.F | 6 +++--- 3 files changed, 10 insertions(+), 5 deletions(-) diff --git a/phy/iniphy.F b/phy/iniphy.F index 5f382481..7073fad2 100644 --- a/phy/iniphy.F +++ b/phy/iniphy.F @@ -25,7 +25,9 @@ subroutine iniphy c use mod_config, only: expcnf use mod_xc, only: lp, mnproc, xcstop + use mod_vcoord, only: vcoord_type_tag, cntiso_hybrid use mod_tidaldissip, only: read_tidaldissip + use mod_difest, only: init_difest c implicit none c @@ -44,6 +46,10 @@ subroutine iniphy call xcstop('(iniphy)') stop '(iniphy)' endif +c + if (vcoord_type_tag == cntiso_hybrid) then + call init_difest + endif c return end diff --git a/phy/inivar.F90 b/phy/inivar.F90 index cc44445f..780095bf 100644 --- a/phy/inivar.F90 +++ b/phy/inivar.F90 @@ -31,7 +31,7 @@ subroutine inivar use mod_barotp, only: inivar_barotp use mod_tmsmt, only: inivar_tmsmt use mod_diffusion, only: inivar_diffusion - use mod_difest, only: inivar_difest, ini_difest + use mod_difest, only: inivar_difest use mod_utility, only: inivar_utility use mod_mxlayr, only: inivar_mxlayr use mod_seaice, only: inivar_seaice @@ -56,7 +56,6 @@ subroutine inivar call inivar_tmsmt call inivar_diffusion call inivar_difest - call ini_difest call inivar_utility call inivar_mxlayr call inivar_seaice diff --git a/phy/mod_difest.F b/phy/mod_difest.F index ebe8b2bd..5200d004 100644 --- a/phy/mod_difest.F +++ b/phy/mod_difest.F @@ -171,7 +171,7 @@ module mod_difest . kappa=.4,bfeps=1.e-12,sleps=.1,zetas=-1.,as=-28.86, . cs=98.96,minOBLdepth=1.0) c - public :: inivar_difest, ini_difest, difest, OBLdepth + public :: inivar_difest, init_difest, difest, OBLdepth c contains c @@ -206,7 +206,7 @@ subroutine inivar_difest c end subroutine inivar_difest c - subroutine ini_difest + subroutine init_difest c c --- ------------------------------------------------------------------ c --- Initialize CVmix variables. @@ -253,7 +253,7 @@ subroutine ini_difest . CVMix_kpp_params_user=KPP_params ) c c - end subroutine ini_difest + end subroutine init_difest c subroutine difest_common_iso(m,n,mm,nn,k1m,k1n) c From 48e221421e4e12f11226a49435ad560b564fb529 Mon Sep 17 00:00:00 2001 From: Mats Bentsen Date: Sun, 10 Oct 2021 02:37:13 +0200 Subject: [PATCH 023/366] Turned off output of checksums by default. --- phy/mod_checksum.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/phy/mod_checksum.F90 b/phy/mod_checksum.F90 index 6181a9c4..6fb634e8 100644 --- a/phy/mod_checksum.F90 +++ b/phy/mod_checksum.F90 @@ -28,7 +28,7 @@ module mod_checksum ! Constants. logical :: & - csdiag = .true. ! Flag that indicates whether checksums are written. + csdiag = .false. ! Flag that indicates whether checksums are written. interface crc32 module procedure crc32_1d_integer, crc32_2d_r8 From 2c2676e81e2b055195334f6915bf2dcc2a3f2ba1 Mon Sep 17 00:00:00 2001 From: Mats Bentsen Date: Mon, 11 Oct 2021 00:38:06 +0200 Subject: [PATCH 024/366] Fixed parallelization bug in diagnostics and made checksum diagnostics more robust. --- phy/mod_checksum.F90 | 16 ++++++++++------ phy/mod_cmnfld.F90 | 8 ++++---- phy/mod_difest.F | 6 +++--- phy/rdlim.F | 19 +++++++++++++++++++ 4 files changed, 36 insertions(+), 13 deletions(-) diff --git a/phy/mod_checksum.F90 b/phy/mod_checksum.F90 index 6fb634e8..e2a4aeb0 100644 --- a/phy/mod_checksum.F90 +++ b/phy/mod_checksum.F90 @@ -42,29 +42,33 @@ module mod_checksum ! Private procedures. ! --------------------------------------------------------------------------- - function crc32_1d_integer(a) + function crc32_1d_integer(iarr) - integer, dimension(:), intent(in) :: a + integer, dimension(:), intent(in) :: iarr integer :: crc32_1d_integer integer :: crcfast external :: crcfast - crc32_1d_integer = crcfast(a, size(a)*4) + real(r8), dimension((size(iarr) + 1)/2) :: rarr + + rarr = transfer(iarr, rarr) + + crc32_1d_integer = crcfast(rarr, size(iarr)*4) end function crc32_1d_integer - function crc32_2d_r8(a) + function crc32_2d_r8(rarr) - real(r8), dimension(:,:), intent(in) :: a + real(r8), dimension(:,:), intent(in) :: rarr integer :: crc32_2d_r8 integer :: crcfast external :: crcfast - crc32_2d_r8 = crcfast(a, size(a)*8) + crc32_2d_r8 = crcfast(rarr, size(rarr)*8) end function crc32_2d_r8 diff --git a/phy/mod_cmnfld.F90 b/phy/mod_cmnfld.F90 index d946e7ac..eb4b566c 100644 --- a/phy/mod_cmnfld.F90 +++ b/phy/mod_cmnfld.F90 @@ -244,9 +244,9 @@ subroutine cmnfld_bfsqf_isopyc_bulkml(m, n, mm, nn, k1m, k1n) if (mnproc == 1) then write(lp,*) 'cmnfld_bfsqf_isopyc_bulkml:' endif - call chksummsk(bfsqi, ip, kk, 'bfsqi') + call chksummsk(bfsqi, ip, kk + 1, 'bfsqi') call chksummsk(bfsql, ip, kk, 'bfsql') - call chksummsk(bfsqf, ip, kk, 'bfsqf') + call chksummsk(bfsqf, ip, kk + 1, 'bfsqf') endif end subroutine cmnfld_bfsqf_isopyc_bulkml @@ -371,9 +371,9 @@ subroutine cmnfld_bfsqf_cntiso_hybrid(m, n, mm, nn, k1m, k1n) if (mnproc == 1) then write(lp,*) 'cmnfld_bfsqf_cntiso_hybrid:' endif - call chksummsk(bfsqi, ip, kk, 'bfsqi') + call chksummsk(bfsqi, ip, kk + 1, 'bfsqi') call chksummsk(bfsql, ip, kk, 'bfsql') - call chksummsk(bfsqf, ip, kk, 'bfsqf') + call chksummsk(bfsqf, ip, kk + 1, 'bfsqf') endif end subroutine cmnfld_bfsqf_cntiso_hybrid diff --git a/phy/mod_difest.F b/phy/mod_difest.F index 5200d004..984d01f2 100644 --- a/phy/mod_difest.F +++ b/phy/mod_difest.F @@ -1088,9 +1088,9 @@ subroutine difest_vertical_hyb(m,n,mm,nn,k1m,k1n) if (mnproc.eq.1) then write (lp,*) 'difest_vertical_hyb:' endif - call chksummsk(Kvisc_m,ip,kk,'Kvisc_m') - call chksummsk(Kdiff_t,ip,kk,'Kdiff_t') - call chksummsk(Kdiff_s,ip,kk,'Kdiff_s') + call chksummsk(Kvisc_m,ip,kk+1,'Kvisc_m') + call chksummsk(Kdiff_t,ip,kk+1,'Kdiff_t') + call chksummsk(Kdiff_s,ip,kk+1,'Kdiff_s') endif c end subroutine difest_vertical_hyb diff --git a/phy/rdlim.F b/phy/rdlim.F index 6eedb3b1..888c31b1 100644 --- a/phy/rdlim.F +++ b/phy/rdlim.F @@ -389,9 +389,14 @@ subroutine rdlim write (lp,*) 'H2D_ZTX ',H2D_ZTX(1:nphy) write (lp,*) 'LYR_BFSQ ',LYR_BFSQ(1:nphy) write (lp,*) 'LYR_DIFDIA ',LYR_DIFDIA(1:nphy) + write (lp,*) 'LYR_DIFVMO ',LYR_DIFVMO(1:nphy) + write (lp,*) 'LYR_DIFVHO ',LYR_DIFVHO(1:nphy) + write (lp,*) 'LYR_DIFVSO ',LYR_DIFVSO(1:nphy) write (lp,*) 'LYR_DIFINT ',LYR_DIFINT(1:nphy) write (lp,*) 'LYR_DIFISO ',LYR_DIFISO(1:nphy) write (lp,*) 'LYR_DP ',LYR_DP(1:nphy) + write (lp,*) 'LYR_DPU ',LYR_DPU(1:nphy) + write (lp,*) 'LYR_DPV ',LYR_DPV(1:nphy) write (lp,*) 'LYR_DZ ',LYR_DZ(1:nphy) write (lp,*) 'LYR_SALN ',LYR_SALN(1:nphy) write (lp,*) 'LYR_TEMP ',LYR_TEMP(1:nphy) @@ -421,6 +426,14 @@ subroutine rdlim write (lp,*) 'LYR_GLS_PSI ',LYR_GLS_PSI(1:nphy) write (lp,*) 'LYR_IDLAGE ',LYR_IDLAGE(1:nphy) write (lp,*) 'LVL_BFSQ ',LVL_BFSQ(1:nphy) + write (lp,*) 'LVL_DIFDIA ',LVL_DIFDIA(1:nphy) + write (lp,*) 'LVL_DIFVMO ',LVL_DIFVMO(1:nphy) + write (lp,*) 'LVL_DIFVHO ',LVL_DIFVHO(1:nphy) + write (lp,*) 'LVL_DIFVSO ',LVL_DIFVSO(1:nphy) + write (lp,*) 'LVL_DIFINT ',LVL_DIFINT(1:nphy) + write (lp,*) 'LVL_DIFISO ',LVL_DIFISO(1:nphy) + write (lp,*) 'LVL_DIFISO ',LVL_DIFISO(1:nphy) + write (lp,*) 'LVL_DZ ',LVL_DZ(1:nphy) write (lp,*) 'LVL_SALN ',LVL_SALN(1:nphy) write (lp,*) 'LVL_TEMP ',LVL_TEMP(1:nphy) write (lp,*) 'LVL_TRC ',LVL_TRC(1:nphy) @@ -534,6 +547,9 @@ subroutine rdlim call xcbcst(H2D_ZTX) call xcbcst(LYR_BFSQ) call xcbcst(LYR_DIFDIA) + call xcbcst(LYR_DIFVMO) + call xcbcst(LYR_DIFVHO) + call xcbcst(LYR_DIFVSO) call xcbcst(LYR_DIFINT) call xcbcst(LYR_DIFISO) call xcbcst(LYR_DP) @@ -569,6 +585,9 @@ subroutine rdlim call xcbcst(LYR_IDLAGE) call xcbcst(LVL_BFSQ) call xcbcst(LVL_DIFDIA) + call xcbcst(LVL_DIFVMO) + call xcbcst(LVL_DIFVHO) + call xcbcst(LVL_DIFVSO) call xcbcst(LVL_DIFINT) call xcbcst(LVL_DIFISO) call xcbcst(LVL_DZ) From 1da9055e2c2cfc7821dbd3262383cfb667dc8367 Mon Sep 17 00:00:00 2001 From: Mats Bentsen Date: Mon, 11 Oct 2021 00:39:33 +0200 Subject: [PATCH 025/366] Fixed bug in diagnostics of variables defined at layer interfaces. --- phy/mod_dia.F | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/phy/mod_dia.F b/phy/mod_dia.F index 71bae078..e51f349b 100644 --- a/phy/mod_dia.F +++ b/phy/mod_dia.F @@ -233,7 +233,7 @@ module mod_dia . ACC_VMFLTD ,ACC_VTFLTD ,ACC_VTFLLD ,ACC_VSFLTD ,ACC_VSFLLD , . ACC_VVEL ,ACC_WFLX ,ACC_WFLX2 ,ACC_AVDSG ,ACC_DPVOR , . ACC_TKE ,ACC_GLS_PSI,ACC_UTILLYR, - . ACC_BFSQLVL ,ACC_DIFDIALVL ,ACC_DIFVMOLVL,ACC_DIFVHOLVL, + . ACC_BFSQLVL ,ACC_DIFDIALVL,ACC_DIFVMOLVL,ACC_DIFVHOLVL, . ACC_DIFVSOLVL ,ACC_DIFINTLVL,ACC_DIFISOLVL,ACC_DZLVL , . ACC_SALNLVL ,ACC_TEMPLVL ,ACC_UFLXLVL ,ACC_UTFLXLVL , . ACC_USFLXLVL ,ACC_UMFLTDLVL,ACC_UTFLTDLVL,ACC_UTFLLDLVL, @@ -4915,7 +4915,7 @@ subroutine accily(pos,fld,wghts,wghtsflg,gridid) do l=1,isu(j) do i=max(1,ifu(j,l)),min(ii,ilu(j,l)) phylyr(i,j,k,pos(o))=phylyr(i,j,k,pos(o)) - . +.5*(fld(i,j,k)+fld(i,j,k)) + . +.5*(fld(i,j,k)+fld(i,j,k+1)) enddo enddo enddo @@ -4928,7 +4928,7 @@ subroutine accily(pos,fld,wghts,wghtsflg,gridid) do l=1,isu(j) do i=max(1,ifu(j,l)),min(ii,ilu(j,l)) phylyr(i,j,k,pos(o))=phylyr(i,j,k,pos(o)) - . +.5*(fld(i,j,k)+fld(i,j,k)) + . +.5*(fld(i,j,k)+fld(i,j,k+1)) . *wghts(i,j,k) enddo enddo @@ -4944,7 +4944,7 @@ subroutine accily(pos,fld,wghts,wghtsflg,gridid) do l=1,isv(j) do i=max(1,ifv(j,l)),min(ii,ilv(j,l)) phylyr(i,j,k,pos(o))=phylyr(i,j,k,pos(o)) - . +.5*(fld(i,j,k)+fld(i,j,k)) + . +.5*(fld(i,j,k)+fld(i,j,k+1)) enddo enddo enddo @@ -4957,7 +4957,7 @@ subroutine accily(pos,fld,wghts,wghtsflg,gridid) do l=1,isv(j) do i=max(1,ifv(j,l)),min(ii,ilv(j,l)) phylyr(i,j,k,pos(o))=phylyr(i,j,k,pos(o)) - . +.5*(fld(i,j,k)+fld(i,j,k)) + . +.5*(fld(i,j,k)+fld(i,j,k+1)) . *wghts(i,j,k) enddo enddo @@ -4973,7 +4973,7 @@ subroutine accily(pos,fld,wghts,wghtsflg,gridid) do l=1,isp(j) do i=max(1,ifp(j,l)),min(ii,ilp(j,l)) phylyr(i,j,k,pos(o))=phylyr(i,j,k,pos(o)) - . +.5*(fld(i,j,k)+fld(i,j,k)) + . +.5*(fld(i,j,k)+fld(i,j,k+1)) enddo enddo enddo @@ -4986,7 +4986,7 @@ subroutine accily(pos,fld,wghts,wghtsflg,gridid) do l=1,isp(j) do i=max(1,ifp(j,l)),min(ii,ilp(j,l)) phylyr(i,j,k,pos(o))=phylyr(i,j,k,pos(o)) - . +.5*(fld(i,j,k)+fld(i,j,k)) + . +.5*(fld(i,j,k)+fld(i,j,k+1)) . *wghts(i,j,k) enddo enddo From 089560304f1b6310bf5b6f56a1c55e88a48ef832 Mon Sep 17 00:00:00 2001 From: Mats Bentsen Date: Mon, 11 Oct 2021 01:13:38 +0200 Subject: [PATCH 026/366] Ensure correct restart with CVMix enabled. --- phy/restart_rd.F | 8 ++++++++ phy/restart_wt.F | 15 +++++++++++++++ 2 files changed, 23 insertions(+) diff --git a/phy/restart_rd.F b/phy/restart_rd.F index 0e74fc1d..7868ef61 100644 --- a/phy/restart_rd.F +++ b/phy/restart_rd.F @@ -28,6 +28,7 @@ subroutine restart_rd use mod_calendar, only: date_type, daynum_diff, operator(/=) use mod_time, only: date0, date, nday1, nstep0, nstep1 use mod_xc + use mod_vcoord, only: vcoord_type_tag, cntiso_hybrid use mod_inicon, only: icfile use mod_state, only: u, v, dp, temp, saln, sigma, . uflx, vflx, utflx, vtflx, usflx, vsflx, @@ -45,6 +46,7 @@ subroutine restart_rd . prfac, eiacc, pracc, . flxco2, flxdms, ustarb, buoyfl use mod_niw, only: uml, vml, umlres, vmlres + use mod_diffusion, only: Kvisc_m, Kdiff_t, Kdiff_s 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, ustarw_da, @@ -443,6 +445,12 @@ subroutine restart_rd write (lp,*) . 'will be initialized to zero.' endif +c + if (vcoord_type_tag.eq.cntiso_hybrid) then + call ncread('Kvisc_m',Kvisc_m,ip,1,0.) + call ncread('Kdiff_t',Kdiff_t,ip,1,0.) + call ncread('Kdiff_s',Kdiff_s,ip,1,0.) + endif c if (sprfac) then vexist=ncinqa('prfac') diff --git a/phy/restart_wt.F b/phy/restart_wt.F index 6e367092..0bb97401 100644 --- a/phy/restart_wt.F +++ b/phy/restart_wt.F @@ -28,6 +28,7 @@ subroutine restart_wt use mod_config, only: expcnf, runid, inst_suffix use mod_time, only: date0, date, nstep, nstep_in_day, nday_of_year use mod_xc + use mod_vcoord, only: vcoord_type_tag, cntiso_hybrid use mod_state, only: u, v, dp, temp, saln, sigma, . uflx, vflx, utflx, vtflx, usflx, vsflx, . phi, ubflxs, vbflxs, @@ -44,6 +45,7 @@ subroutine restart_wt . prfac, eiacc, pracc, . flxco2, flxdms, ustarb, buoyfl use mod_niw, only: uml, vml, umlres, vmlres + use mod_diffusion, only: Kvisc_m, Kdiff_t, Kdiff_s 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, ustarw_da, @@ -187,6 +189,7 @@ subroutine restart_wt call ncdims('k3',3) call ncdims('k4',4) call ncdims('kk',kk) + call ncdims('kkp1',kk+1) call ncdims('kk2',2*kk) call ncdims('plev',ddm) call ncputr('plev',depthslev) @@ -285,6 +288,12 @@ subroutine restart_wt call wrtrst('vml',trim(c5v)//' k4 time',vml,ivv) call wrtrst('umlres',trim(c5u)//' k2 time',umlres,iuu) call wrtrst('vmlres',trim(c5v)//' k2 time',vmlres,ivv) +c + if (vcoord_type_tag.eq.cntiso_hybrid) then + call wrtrst('Kvisc_m',trim(c5p)//' kkp1 time',Kvisc_m,ip) + call wrtrst('Kdiff_t',trim(c5p)//' kkp1 time',Kdiff_t,ip) + call wrtrst('Kdiff_s',trim(c5p)//' kkp1 time',Kdiff_s,ip) + endif c if (sprfac) then call wrtrst('eiacc',trim(c5p)//' time',eiacc,ip) @@ -875,6 +884,12 @@ subroutine defvar_restart(c5p,c5u,c5v,c5q) call defvarrst('vml',trim(c5v)//' k4 time') call defvarrst('umlres',trim(c5u)//' k2 time') call defvarrst('vmlres',trim(c5v)//' k2 time') +c + if (vcoord_type_tag.eq.cntiso_hybrid) then + call defvarrst('Kvisc_m',trim(c5p)//' kkp1 time') + call defvarrst('Kdiff_t',trim(c5p)//' kkp1 time') + call defvarrst('Kdiff_s',trim(c5p)//' kkp1 time') + endif c if (sprfac) then call defvarrst('eiacc',trim(c5p)//' time') From 7fb8aff6da667321e18a35248a8854e7499ca8c4 Mon Sep 17 00:00:00 2001 From: Mats Bentsen Date: Mon, 11 Oct 2021 01:17:22 +0200 Subject: [PATCH 027/366] Added "implicit none" and private/public statements in module for vertical diffusion solvers. --- phy/mod_vdiff.F90 | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) diff --git a/phy/mod_vdiff.F90 b/phy/mod_vdiff.F90 index 52ccce9a..61cd6117 100644 --- a/phy/mod_vdiff.F90 +++ b/phy/mod_vdiff.F90 @@ -34,9 +34,15 @@ module mod_vdiff use mod_tracers, only: ntr, trc #endif + implicit none + + private + real(r8), parameter :: & dpmin_vdiff = 0.1_r8*98060._r8 + public :: cntiso_hybrid_vdiff + contains subroutine cntiso_hybrid_vdiff(m, n, mm, nn, k1m, k1n) @@ -46,7 +52,7 @@ subroutine cntiso_hybrid_vdiff(m, n, mm, nn, k1m, k1n) real(r8), dimension(kdm) :: dp_1d, temp_1d, saln_1d, u_1d, v_1d, & nut_1d, nus_1d, nutrc_1d, nuv_1d real(r8), dimension(2:kdm) :: fpbase, fp, gam - real(r8) :: c + real(r8) :: c, bei integer :: i, j, k, l, kn, nt #ifdef TRC real(r8), dimension(kdm, ntr) :: trc_1d From 27de7f95e1ee41478d4ba01eb3a14a3dfab8a3b7 Mon Sep 17 00:00:00 2001 From: Mehmet Ilicak Date: Fri, 15 Oct 2021 09:30:49 +0200 Subject: [PATCH 028/366] CVMix subroutines call order changed. --- phy/mod_difest.F | 321 ++++++++++++++++++++++++----------------------- 1 file changed, 164 insertions(+), 157 deletions(-) diff --git a/phy/mod_difest.F b/phy/mod_difest.F index 984d01f2..f4469168 100644 --- a/phy/mod_difest.F +++ b/phy/mod_difest.F @@ -24,7 +24,7 @@ module mod_difest use mod_time, only: delt1 use mod_xc use mod_vcoord, only: sigmar - use mod_vcoord, only: vcoord_type_tag, isopyc_bulkml, + use mod_vcoord, only: vcoord_type_tag, isopyc_bulkml, . cntiso_hybrid use mod_grid, only: scpx, scpy, scp2, . plat, coriop, betafp, cosang, sinang @@ -43,12 +43,12 @@ module mod_difest use mod_utility, only: util1 use mod_checksum, only: csdiag, chksummsk use mod_diffusion, only: Kvisc_m, Kdiff_t, Kdiff_s - use CVMix_kpp, only : CVMix_coeffs_kpp - use CVMix_kpp, only : CVMix_kpp_compute_turbulent_scales - use CVMix_kpp, only : CVMix_kpp_compute_bulk_Richardson + use CVMix_kpp, only : CVMix_coeffs_kpp + use CVMix_kpp, only : CVMix_kpp_compute_turbulent_scales + use CVMix_kpp, only : CVMix_kpp_compute_bulk_Richardson use CVMix_kpp, only : CVMix_kpp_compute_OBL_depth use CVMix_kpp, only : CVmix_kpp_compute_unresolved_shear - use CVMix_kpp, only : CVMix_kpp_compute_kOBL_depth + use CVMix_kpp, only : CVMix_kpp_compute_kOBL_depth use CVMix_shear, only : CVMix_init_shear, CVMix_coeffs_shear use CVMix_background, only : CVMix_init_bkgnd, CVMix_coeffs_bkgnd use CVMix_convection, only : CVMix_init_conv, CVMix_coeffs_conv @@ -66,7 +66,7 @@ module mod_difest use mod_tke, only: gls_cmu0, Pr_t, tke_min, gls_psi_min, gls_p, . gls_m, gls_n, gls_c1, gls_c2, gls_c3plus, . gls_c3minus, gls_Gh0, gls_Ghmin, gls_Ghcri, - . Ls_unlmt_min, Prod, Buoy, Shear2, L_scale, + . Ls_unlmt_min, Prod, Buoy, Shear2, L_scale, . gls_s0, gls_s1, gls_s2, gls_s4, gls_s5, gls_s6, . gls_b0, gls_b1, gls_b2, gls_b3, gls_b4, gls_b5, . sqrt2, cmu_fac1, cmu_fac2, cmu_fac3, tke_exp1, @@ -211,7 +211,7 @@ subroutine init_difest c --- ------------------------------------------------------------------ c --- Initialize CVmix variables. c --- ------------------------------------------------------------------ -c +c c -- ------- Background diapycnal mixing. c The Bryan-Lewis parameterization is based on the following: c \begin{eqnarray*} @@ -221,32 +221,32 @@ subroutine init_difest c \nu_{BL} &=& \textrm{Pr}\cdot\kappa_{BL} c \end{eqnarray*} c --- ------ Diapycnal mixing when local stability is weak -c --- ------ convection routine based on N2 not rho -c --- ------ if lBruntVaisala is TRUE, otherwise based on rho -c --- ------ convert nuls0 to m2/s - call CVMix_init_conv(convect_diff=20.0*nuls0*1e-4, - . convect_visc=20.0*nuls0*1e-4, +c --- ------ convection routine based on N2 not rho +c --- ------ if lBruntVaisala is TRUE, otherwise based on rho +c --- ------ convert nuls0 to m2/s + call CVMix_init_conv(convect_diff=20.0*nuls0*1e-4, + . convect_visc=20.0*nuls0*1e-4, . lBruntVaisala=.true., - . BVsqr_convect=0.0) - call CVMix_put(CVMix_glb_params,'max_nlev',kk) - call CVMix_put(CVMix_glb_params,'Prandtl',1.0) - call CVMix_put(CVMix_glb_params,'FreshWaterDensity',1000.0) - call CVMix_put(CVMix_glb_params,'SaltWaterDensity',1025.0) - call cvmix_init_shear(mix_scheme='KPP', - . KPP_nu_zero=nus0*1e-4, + . BVsqr_convect=0.0) + call CVMix_put(CVMix_glb_params,'max_nlev',kk) + call CVMix_put(CVMix_glb_params,'Prandtl',1.0) + call CVMix_put(CVMix_glb_params,'FreshWaterDensity',1000.0) + call CVMix_put(CVMix_glb_params,'SaltWaterDensity',1025.0) + call cvmix_init_shear(mix_scheme='KPP', + . KPP_nu_zero=nus0*1e-4, . KPP_Ri_zero=ri0, - . KPP_exp=3.0) + . KPP_exp=3.0) ! CVmix_kpp_params_in => CVmix_kpp_params_user call CVMix_init_kpp(Ri_crit=0.3, - . minOBLdepth=minOBLdepth, - . minVtsqr=1e-10, - . vonKarman=0.4, - . surf_layer_ext=0.1, - . interp_type='quadratic', - . interp_type2='LMD94', - . lEkman=.false., - . lMonOb=.false., - . MatchTechnique='SimpleShapes', + . minOBLdepth=minOBLdepth, + . minVtsqr=1e-10, + . vonKarman=0.4, + . surf_layer_ext=0.1, + . interp_type='quadratic', + . interp_type2='LMD94', + . lEkman=.false., + . lMonOb=.false., + . MatchTechnique='SimpleShapes', . lenhanced_diff=.true., . lnonzero_surf_nonlocal=.false. , . lnoDGat1=.true. , @@ -738,27 +738,27 @@ subroutine difest_vertical_hyb(m,n,mm,nn,k1m,k1n) c --- ------------------------------------------------------------------ c integer m,n,mm,nn,k1m,k1n -c +c real, dimension(kdm+1) :: rig_i integer i,j,k,l,kn real q c type(CVMix_tidal_params_type) :: CVMix_tidal_params - real, dimension(kdm+1) :: depth_int + real, dimension(kdm+1) :: depth_int real, dimension(kdm+1) :: Kv_col, Kd_col ! background visc/diff real, dimension(kdm+1) :: Kv_shr, Kd_shr ! shear driven visc/diff real, dimension(kdm+1) :: Kv_conv, Kd_conv ! convection visc/diff - real, dimension(kdm+1) :: vert_dep ! vertical deposition + real, dimension(kdm+1) :: vert_dep ! vertical deposition real, dimension(kdm+1) :: Kv_tidal, Kd_tidal ! tidal viscosity,diffusivity real, dimension(kdm+1) :: Kv_kpp, Kt_kpp, Ks_kpp ! vertical viscosity,diffusivity temp/salt - real, dimension(kdm+1) :: iFaceHeight ! Height of interfaces [m] - real, dimension(kdm+1) :: bvfsq_i, bvf_i ! N2, N at interfaces - real, dimension(kdm) :: cellHeight ! Height of cell centers [m] - real, dimension(kdm) :: rho_zeros, rho_lwr ! dummy vars for convection + real, dimension(kdm+1) :: iFaceHeight ! Height of interfaces [m] + real, dimension(kdm+1) :: bvfsq_i, bvf_i ! N2, N at interfaces + real, dimension(kdm) :: cellHeight ! Height of cell centers [m] + real, dimension(kdm) :: rho_zeros, rho_lwr ! dummy vars for convection real, dimension(kdm) :: rho_1d ! 1D density at the layer center real, dimension(kdm) :: Ws_1d ! Profile of vertical velocity scale for scalars [m s-1] - real, dimension(kdm) :: surfBuoyFlux2 - real, dimension(kdm) :: BulkRi_1d ! Bulk Richardson number for each layer + real, dimension(kdm) :: surfBuoyFlux2 + real, dimension(kdm) :: BulkRi_1d ! Bulk Richardson number for each layer real, dimension(kdm) :: deltaU2 ! square of delta U (shear) in denominator of Bulk Ri [m2 s-2] real, dimension(kdm) :: VT2 ! unresolved shear used for Bulk Ri real, dimension(kdm) :: deltaRho ! delta Rho [g/cm3] in numerator of Bulk Ri number @@ -775,7 +775,7 @@ subroutine difest_vertical_hyb(m,n,mm,nn,k1m,k1n) real :: SLdepth_0d, hTot real :: Simmons_coeff, zBottomMinusOffset real :: bl1, bl2, bl3, bl4 - integer ki, ksfc, ktmp, kOBL, kn1 + integer ki, ksfc, ktmp, kOBL, kn1 real, dimension(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy) :: hOBL c surf_layer_ext = 0.1 @@ -796,30 +796,30 @@ subroutine difest_vertical_hyb(m,n,mm,nn,k1m,k1n) c Ws_1d = 0.0 bvfbot = 0. dps = 0. - depth_int = 0. + depth_int = 0. hcorr = 0. Kv_col = 0. Kd_col = 0. - vert_dep = 0. - Kv_tidal = 0. + vert_dep = 0. + Kv_tidal = 0. Kd_tidal = 0. Kv_conv = 0. Kd_conv = 0. Kv_shr = 0. Kd_shr = 0. - iFaceHeight = 0. + iFaceHeight = 0. cellHeight = 0. bvfsq_i = 0. rho_lwr(:)= drho0 rho_zeros(:)= 0. rho_1d = 0. - nonLocalTrans(:,:) = 0.0 - rig_i = 1.e8 !Initialize w/ large Richardson value + nonLocalTrans(:,:) = 0.0 + rig_i = 1.e8 !Initialize w/ large Richardson value Kv_kpp = 0.0 Kt_kpp = 0.0 Ks_kpp = 0.0 do k=1,kk+1 - Kv_kpp(k) = Kvisc_m(i,j,k)*1e-4 + Kv_kpp(k) = Kvisc_m(i,j,k)*1e-4 Kt_kpp(k) = Kdiff_t(i,j,k)*1e-4 Ks_kpp(k) = Kdiff_s(i,j,k)*1e-4 enddo @@ -830,19 +830,19 @@ subroutine difest_vertical_hyb(m,n,mm,nn,k1m,k1n) ! convert cm2/s3 to m2/s3 surfBuoyFlux = buoyfl(i,j) * 1e-4 surfBuoyFlux2(1) = buoyfl(i,j) * 1e-4 - do k=1,kk + do k=1,kk kn = k + nn kn1 = max(nn+1,kn-1) ! Old method to compute interface location, thicknesses -c depth_int(k+1) = p(i,j,k+1)/onem +c depth_int(k+1) = p(i,j,k+1)/onem c iFaceHeight(k+1) = -depth_int(k+1) c cellHeight(k) = 0.5*(iFaceHeight(k+1) + c . iFaceHeight(k)) ! New method to compute interface location, thicknesses dh = dp(i,j,kn)/onem dh = dh + hcorr ! Take away the accumulated error (could temporarily make dh<0) - hcorr = min(dh - 1e-10, 0.) ! If inflating then hcorr<0 - dh = max(dh, 1e-10) ! Limit increment dh>=min_thicknes + hcorr = min(dh - 1e-10, 0.) ! If inflating then hcorr<0 + dh = max(dh, 1e-10) ! Limit increment dh>=min_thicknes cellHeight(k) = iFaceHeight(k) - 0.5 * dh iFaceHeight(k+1) = iFaceHeight(k) - dh depth_int(k+1) = -iFaceHeight(k+1) @@ -850,16 +850,16 @@ subroutine difest_vertical_hyb(m,n,mm,nn,k1m,k1n) ! compute rho_1d at the interfaces rho_1d(k)=rho(p(i,j,k),temp(i,j,kn),saln(i,j,kn)) - ! find ksfc for cell where "surface layer" sits + ! find ksfc for cell where "surface layer" sits SLdepth_0d = surf_layer_ext* . max(max(-cellHeight(k),-iFaceHeight(2)), . minOBLdepth) ksfc = k do ki = 1,k - if (-1.0*iFaceHeight(ki+1) >= SLdepth_0d) then - ksfc = ki - exit - endif + if (-1.0*iFaceHeight(ki+1) >= SLdepth_0d) then + ksfc = ki + exit + endif enddo surfHu = 0.0 surfHv = 0.0 @@ -868,10 +868,10 @@ subroutine difest_vertical_hyb(m,n,mm,nn,k1m,k1n) hTot = 0.0 do ki = 1,ksfc ktmp = ki+nn - ! SLdepth_0d can be between cell interfaces + ! SLdepth_0d can be between cell interfaces delH = min( max(0.0, SLdepth_0d - hTot), - . dp(i,j,ktmp)/onem ) - ! surface layer thickness + . dp(i,j,ktmp)/onem ) + ! surface layer thickness hTot = hTot + delH ! surface averaged fields surfHtemp = surfHtemp + temp(i,j,ktmp)*delH @@ -883,23 +883,23 @@ subroutine difest_vertical_hyb(m,n,mm,nn,k1m,k1n) surfSalt = surfHsalt / hTot surfU = surfHu / hTot surfV = surfHv / hTot - surfRho = rho(0.0,surfTemp,surfSalt) + surfRho = rho(0.0,surfTemp,surfSalt) if (p(i,j,kk+1)-p(i,j,k) < epsil) then deltaRho(k) = deltaRho(k-1) else deltaRho(k) = rho_1d(k) - surfRho endif - ! vertical shear between present layer and - ! surface layer averaged surfU,surfV. + ! vertical shear between present layer and + ! surface layer averaged surfU,surfV. ! C-grid average to get Uk and Vk on T-points. Uk = up(i,j,k) - surfU Vk = vp(i,j,k) - surfV deltaU2(k) = (Uk**2 + Vk**2) ! XXX: Temporary de-scaling of N2_int(i,:) into a - ! temporary variable + ! temporary variable bvfsq_i(k) = bfsqi(i,j,k) - bvf_i(k) = sqrt( max( bvfsq_i(k), 0.) ) + bvf_i(k) = sqrt( max( bvfsq_i(k), 0.) ) c --- ------- Accumulate Brunt-Vaisala frequency in a region near the c --- ------- bottom q=max(0.,p(i,j,k+1)-max(p(i,j,kk+1)-dpnbav,p(i,j,k))) @@ -911,173 +911,180 @@ subroutine difest_vertical_hyb(m,n,mm,nn,k1m,k1n) c --- ------- Local gradient Richardson number rig_i(k)=rig(i,j,k) c - enddo ! k + enddo ! k if(dps.gt.0.) bvfbot=bvfbot/dps ! convert cm2/s2 to m2/s2 - deltaU2 = deltaU2*1e-4 + deltaU2 = deltaU2*1e-4 ! bottom values for the Ri, N2, and N rig_i(kk+1) = rig_i(kk) bvfsq_i(kk+1) = bfsqi(i,j,kk+1) - bvf_i(kk+1) = sqrt( max( bvfsq_i(kk+1), 0.) ) + bvf_i(kk+1) = sqrt( max( bvfsq_i(kk+1), 0.) ) c -- ------- Background diapycnal mixing. -c zw interface depths relative to the surface in m, must be positive. - call CVMix_init_bkgnd(max_nlev=kk, zw = depth_int(:), - . bl1 = bl1, bl2 = bl2, bl3 = bl3, bl4 = bl4, - . prandtl = CVMix_glb_params%Prandtl) - call CVMix_coeffs_bkgnd(Mdiff_out=Kv_col, - . Tdiff_out=Kd_col, nlev=kk, max_nlev=kk) - + if (bdmtyp.eq.1) then +c zw interface depths relative to the surface in m, must be positive. + call CVMix_init_bkgnd(max_nlev=kk, zw = depth_int(:), + . bl1 = bl1, bl2 = bl2, bl3 = bl3, bl4 = bl4, + . prandtl = CVMix_glb_params%Prandtl) + call CVMix_coeffs_bkgnd(Mdiff_out=Kv_col, + . Tdiff_out=Kd_col, nlev=kk, max_nlev=kk) + elseif (bdmtyp.eq.2) then +c --- --------- Type 2: Background diffusivity is a constant + ! convert cm2/s2 to m2/s2 + Kv_col(:) = bdmc2*1e-4 + Kd_col(:) = bdmc2*1e-4 + else + Kv_col(:) = 0. + Kd_col(:) = 0. + endif + if (iwdflg.eq.1) then + Kv_col=Kv_col*(1.+(iwdfac-1.)*ficem(i,j)) + Kd_col=Kd_col*(1.+(iwdfac-1.)*ficem(i,j)) + endif + c --- ------ Tidally driven diapycnal mixing c if (tdmflg.eq.1) then call CVMix_init_tidal( - . CVmix_tidal_params_user=CVMix_tidal_params, - . mix_scheme='Simmons', - . efficiency=dmxeff, local_mixing_frac=tdmq) + . CVmix_tidal_params_user=CVMix_tidal_params, + . mix_scheme='Simmons', + . efficiency=dmxeff, local_mixing_frac=tdmq) - call CVMix_compute_Simmons_invariant(nlev=kk, - . energy_flux=twedon(i,j)*bvfbot*1e-3, - . rho=CVMix_glb_params%FreshWaterDensity, + call CVMix_compute_Simmons_invariant(nlev=kk, + . energy_flux=twedon(i,j)*bvfbot*1e-3, + . rho=CVMix_glb_params%FreshWaterDensity, . SimmonsCoeff = Simmons_coeff, VertDep = vert_dep, - . zw = iFaceHeight, zt = cellHeight, - . CVmix_tidal_params_user=CVMix_tidal_params) - + . zw = iFaceHeight, zt = cellHeight, + . CVmix_tidal_params_user=CVMix_tidal_params) + - call CVMix_coeffs_tidal(Mdiff_out=Kv_tidal, - . Tdiff_out=Kd_tidal, Nsqr = bvfsq_i, + call CVMix_coeffs_tidal(Mdiff_out=Kv_tidal, + . Tdiff_out=Kd_tidal, Nsqr = bvfsq_i, . OceanDepth = -iFaceHeight(kk+1), - . SimmonsCoeff = Simmons_coeff, + . SimmonsCoeff = Simmons_coeff, . vert_dep = vert_dep, - . nlev=kk, max_nlev=kk, - . cvmix_params = CVMix_glb_params, - . CVmix_tidal_params_user=CVMix_tidal_params) + . nlev=kk, max_nlev=kk, + . cvmix_params = CVMix_glb_params, + . CVmix_tidal_params_user=CVMix_tidal_params) else Kd_tidal=0. endif +! Call to CVMix wrapper for computing interior mixing coefficients. + call CVMix_coeffs_shear(Mdiff_out=Kv_shr(:), + . Tdiff_out=Kd_shr(:), + . RICH=rig_i(:), + . nlev=kk, + . max_nlev=kk) + + c --- ------ turbulent velocity scales w_s and w_m computed at the cell -c --- ------ centers. - - call CVMix_kpp_compute_turbulent_scales( +c --- ------ centers. + call CVMix_kpp_compute_turbulent_scales( . surf_layer_ext, ! (in) Normalized surface layer Cdepth; sigma = CS%surf_layer_ext . -cellHeight, ! (in) Assume here that OBL depth [m] = -cellHeight(k) - . surfBuoyFlux2, ! (in) Buoyancy flux at surface [m2 s-3] + . surfBuoyFlux2, ! (in) Buoyancy flux at surface [m2 s-3] . surfFricVel, ! (in) Turbulent friction velocity at surface [m s-1] - . w_s=Ws_1d, ! (out) Turbulent velocity scale profile [m s-1] - . CVMix_kpp_params_user=KPP_params) + . w_s=Ws_1d, ! (out) Turbulent velocity scale profile [m s-1] + . CVMix_kpp_params_user=KPP_params) ! Compute unresolved shear for CVMix VT2(:) = CVmix_kpp_compute_unresolved_shear( . zt_cntr=cellHeight, ! Depth ofcell center [m] . ws_cntr=Ws_1d, ! Turbulent velocity scale profile, at centers [m s-1] . N_iface=bvf_i, ! Buoyancy frequency at the interface [s-1] - . CVMix_kpp_params_user=KPP_params) + . CVMix_kpp_params_user=KPP_params) - ! Calculate Bulk Richardson number from eq (21) of LMD94 + ! Calculate Bulk Richardson number from eq (21) of LMD94 BulkRi_1d = CVmix_kpp_compute_bulk_Richardson( . zt_cntr = cellHeight, ! Depth of cell center [m] - . delta_buoy_cntr=g*alpha0*deltaRho*1e-2, ! Bulk buoyancy difference, Br-B(z) [m s-2] + . delta_buoy_cntr=g*alpha0*deltaRho*1e-2, ! Bulk buoyancy difference, Br-B(z) [m s-2] . delta_Vsqr_cntr=deltaU2, ! Square of resolved velocity difference [m2 s-2] . Vt_sqr_cntr=VT2(:), ! Unresolved shear [m2 s-2] - . ws_cntr=Ws_1d, ! Turbulent velocity scale profile [m s-1] + . ws_cntr=Ws_1d, ! Turbulent velocity scale profile [m s-1] . N_iface=bvf_i) ! Buoyancy frequency at the interface [s-1] ! Compute OBL depth for KPP call CVMix_kpp_compute_OBL_depth( - . BulkRi_1d, ! (in) Bulk Richardson number + . BulkRi_1d, ! (in) Bulk Richardson number . iFaceHeight, ! (in) Height of interfaces [m] . OBLdepth(i,j), ! (out) OBL depth [m] - . hOBL(i,j), ! (out) level (+fraction) of OBL extent + . hOBL(i,j), ! (out) level (+fraction) of OBL extent . zt_cntr = cellHeight, ! Depth of cell center [m] . surf_fric=surfFricVel, ! (in) Turbulent friction velocity at surface [m s-1] . surf_buoy=surfBuoyFlux, ! (in) Buoyancy flux at surface [m2 s-3] - . Coriolis=coriop(i,j), ! (in) Coriolis parameter [s-1] - . CVMix_kpp_params_user=KPP_params ) ! KPP parameters + . Coriolis=coriop(i,j), ! (in) Coriolis parameter [s-1] + . CVMix_kpp_params_user=KPP_params ) ! KPP parameters ! Avoid KPP reaching bottom - zBottomMinusOffset = iFaceHeight(kk+1) + zBottomMinusOffset = iFaceHeight(kk+1) . + min(1.0,-0.1*iFaceHeight(kk+1)) OBLdepth(i,j) = min(OBLdepth(i,j), -zBottomMinusOffset) ! no shallower than top layer - OBLdepth(i,j) = max(OBLdepth(i,j), -iFaceHeight(2)) + OBLdepth(i,j) = max(OBLdepth(i,j), -iFaceHeight(2)) ! no deeper than bottom - OBLdepth(i,j) = min(OBLdepth(i,j), -iFaceHeight(kk+1)) - ! gets index of the level and interface above hbl + OBLdepth(i,j) = min(OBLdepth(i,j), -iFaceHeight(kk+1)) + ! gets index of the level and interface above hbl hOBL(i,j) = CVMix_kpp_compute_kOBL_depth(iFaceHeight, . cellHeight,OBLdepth(i,j)) + ! gets index of the level and interface above hbl + kOBL = CVMix_kpp_compute_kOBL_depth(iFaceHeight, + . cellHeight,OBLdepth(i,j)) +c --- ------ Diapycnal mixing when local stability is weak +c --- ------ convection routine based on N2 not rho +c --- ------ make sure it is in metrics if stability depends on rho + call CVMix_coeffs_conv(Mdiff_out=Kv_conv, + . Tdiff_out=Kd_conv, Nsqr = bvfsq_i, + . dens=rho_zeros,dens_lwr=rho_lwr, + . nlev=kk, max_nlev=kk, + . OBL_ind=kOBL) + ! Do not apply mixing due to convection within the boundary layer + do k = 1,kOBL + Kv_conv(k) = 0.0 + Kd_conv(k) = 0.0 + enddo + + ! total diffusivities without KPP + Kv_kpp(:) = Kv_col(:)+Kv_conv(:)+Kv_shr(:) + Kt_kpp(:) = Kd_col(:)+Kd_conv(:)+Kd_shr(:)+Kd_tidal(:) + Ks_kpp(:) = Kd_col(:)+Kd_conv(:)+Kd_shr(:)+Kd_tidal(:) + ! Compute KPP using CVMix call CVMix_coeffs_kpp(Kv_kpp(:), ! (inout) Total viscosity [m2 s-1] . Kt_kpp(:), ! (inout) Total temp diffusivity [m2 s-1] . Ks_kpp(:), ! (inout) Total salt diffusivity [m2 s-1] . iFaceHeight, ! (in) Height of interfaces [m] . cellHeight, ! (in) Height of level centers [m] - . Kv_kpp(:), ! (in) Original viscosity [m2 s-1] + . Kv_kpp(:), ! (in) Original viscosity [m2 s-1] . Kt_kpp(:), ! (in) Original temp diffusivity [m2 s-1] . Ks_kpp(:), ! (in) Original salt diffusivity [m2 s-1] - . OBLdepth(i,j), ! (in) OBL depth [m] + . OBLdepth(i,j), ! (in) OBL depth [m] . hOBL(i,j), ! (in) level (+fraction) of OBL extent . nonLocalTrans(:,1), ! (out) Non-local heat transport [nondim] . nonLocalTrans(:,2), ! (out) Non-local salt transport [nondim] . surfFricVel, ! (in) Turbulent friction velocity at surface [m s-1] . surfBuoyFlux, ! (in) Buoyancy flux at surface [m2 s-3] - . kk, ! (in) Number of levels to compute coeffs for + . kk, ! (in) Number of levels to compute coeffs for . kk, ! (in) Number of levels in array shape - . CVMix_kpp_params_user=KPP_params ) ! KPP parameters - + . CVMix_kpp_params_user=KPP_params ) ! KPP parameters - -! Call to CVMix wrapper for computing interior mixing coefficients. - call CVMix_coeffs_shear(Mdiff_out=Kv_shr(:), - . Tdiff_out=Kd_shr(:), - . RICH=rig_i(:), - . nlev=kk, - . max_nlev=kk) - - ! gets index of the level and interface above hbl + ! gets index of the level and interface above hbl kOBL = CVMix_kpp_compute_kOBL_depth(iFaceHeight, . cellHeight,OBLdepth(i,j)) -c --- ------ Diapycnal mixing when local stability is weak -c --- ------ convection routine based on N2 not rho -c --- ------ make sure it is in metrics if stability depends on rho - call CVMix_coeffs_conv(Mdiff_out=Kv_conv, - . Tdiff_out=Kd_conv, Nsqr = bvfsq_i, - . dens=rho_zeros,dens_lwr=rho_lwr, - . nlev=kk, max_nlev=kk, - . OBL_ind=kOBL) c ---- ccc ------- ! convert m2/s to cm2/s - Kv_col = Kv_col*1e4 - Kd_col = Kd_col*1e4 - Kv_shr = Kv_shr*1e4 - Kd_shr = Kd_shr*1e4 - Kv_tidal = Kv_tidal*1e4 - Kd_tidal = Kd_tidal*1e4 - Kv_conv = Kv_conv*1e4 - Kd_conv = Kd_conv*1e4 Kv_kpp = Kv_kpp*1e4 Kt_kpp = Kt_kpp*1e4 Ks_kpp = Ks_kpp*1e4 - if (iwdflg.eq.1) then - Kv_col=Kv_col*(1.+(iwdfac-1.)*ficem(i,j)) - Kd_col=Kd_col*(1.+(iwdfac-1.)*ficem(i,j)) - endif - Kv_col=max(nubmin,Kv_col) - Kd_col=max(nubmin,Kd_col) - ! Do not apply mixing due to convection within the boundary layer - do k = 1,kOBL - Kv_conv(k) = 0.0 - Kd_conv(k) = 0.0 - enddo - Kvisc_m(i,j,:) = Kv_col(:) + Kv_conv(:) - . + Kv_shr(:) + Kv_kpp(:) - Kdiff_t(i,j,:) = Kd_col(:) + Kd_conv(:) + Kd_shr(:) - . + Kd_tidal(:) + Kt_kpp(:) - Kdiff_s(i,j,:) = Kd_col(:) + Kd_conv(:) + Kd_shr(:) - . + Kd_tidal(:) + Ks_kpp(:) + Kv_kpp=max(nubmin,Kv_kpp) + Kt_kpp=max(nubmin,Kt_kpp) + Ks_kpp=max(nubmin,Ks_kpp) + Kvisc_m(i,j,:) = Kv_kpp(:) + Kdiff_t(i,j,:) = Kt_kpp(:) + Kdiff_s(i,j,:) = Ks_kpp(:) enddo enddo c end of single column @@ -1103,7 +1110,7 @@ subroutine difest_lateral_hyb(m,n,mm,nn,k1m,k1n) c --- ------------------------------------------------------------------ c integer m,n,mm,nn,k1m,k1n -c +c c real, dimension(1-nbdy:idm+nbdy,kdm) :: egr real, dimension(1-nbdy:idm+nbdy) :: @@ -1531,7 +1538,7 @@ subroutine difest_lateral_hyb(m,n,mm,nn,k1m,k1n) endif c end subroutine difest_lateral_hyb -c +c subroutine difest_lateral_iso(m,n,mm,nn,k1m,k1n) c c --- ------------------------------------------------------------------ @@ -2120,7 +2127,7 @@ subroutine difest_vertical_iso(m,n,mm,nn,k1m,k1n) trc(i,j,kn,itrgls)=max((gls_c1*Prod(i,j,k) . +gls_c3*Buoy(i,j,k))/gls_c2, . gls_psi_min) -# endif +# endif tke_epsilon=cmu_fac2*trc(i,j,kn,itrtke)**(1.5+gls_m/gls_n) . *trc(i,j,kn,itrgls)**(-1./gls_n) tke_prod=Prod(i,j,k) @@ -2214,7 +2221,7 @@ subroutine difest_vertical_iso(m,n,mm,nn,k1m,k1n) c Ls_lmt=min(Ls_unlmt, c . sqrt(.56*trc(i,j,kn,itrtke) c . /max(bvfsq(i,k),1.e-10))) - + Ls_lmt=min(Ls_unlmt,trc(i,j,kn,itrtke)**(-gls_m/gls_n) . *trc(i,j,kn,itrgls)**gls_n) c Ls_lmt=Ls_unlmt From a21fb44124a1f7810d6587e0e97029f4760aec39 Mon Sep 17 00:00:00 2001 From: Mats Bentsen Date: Mon, 25 Oct 2021 11:27:34 +0200 Subject: [PATCH 029/366] Removed unused variables. --- phy/mod_eddtra.F90 | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/phy/mod_eddtra.F90 b/phy/mod_eddtra.F90 index de46d8a8..0b12283c 100644 --- a/phy/mod_eddtra.F90 +++ b/phy/mod_eddtra.F90 @@ -970,7 +970,7 @@ subroutine eddtra_gm_cntiso_hybrid(m, n, mm, nn, k1m, k1n) real(r8), dimension(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy) :: ptu, ptv real(r8), dimension(kdm+1) :: mfl real(r8), dimension(kdm) :: dlm, dlp - real(r8) :: rho0, q, et2mf, kappa, fhi, flo + real(r8) :: rho0, q, et2mf, kappa integer :: i, j, k, l, km, kn, kmax, niter, kdir logical :: changed @@ -1006,7 +1006,7 @@ subroutine eddtra_gm_cntiso_hybrid(m, n, mm, nn, k1m, k1n) ! ------------------------------------------------------------------------- !$omp parallel do private(l, i, k, km, et2mf, kmax, kn, kappa, mfl, & - !$omp dlm, dlp, fhi, flo, changed, niter, kdir, q) + !$omp dlm, dlp, changed, niter, kdir, q) do j = - 1, jj + 2 do l = 1, isu(j) do i = max(0, ifu(j, l)), min(ii + 2, ilu(j, l)) @@ -1183,7 +1183,7 @@ subroutine eddtra_gm_cntiso_hybrid(m, n, mm, nn, k1m, k1n) ! ------------------------------------------------------------------------- !$omp parallel do private(l, i, k, km, et2mf, kmax, kn, kappa, mfl, & - !$omp dlm, dlp, fhi, flo, changed, niter, kdir, q) + !$omp dlm, dlp, changed, niter, kdir, q) do j = 0, jj + 2 do l = 1, isv(j) do i = max(- 1, ifv(j, l)), min(ii + 2, ilv(j, l)) From 5e3ed5529ce3c5d012ad406be4a80a6cb82ffc1b Mon Sep 17 00:00:00 2001 From: Mats Bentsen Date: Mon, 25 Oct 2021 11:31:24 +0200 Subject: [PATCH 030/366] Moved estimation of mixed layer depth defined by density criterion to module for common fields. --- phy/mod_cmnfld.F90 | 168 ++++++++++++++++++++++++++++++++++++++++----- phy/mod_dia.F | 85 ++--------------------- 2 files changed, 156 insertions(+), 97 deletions(-) diff --git a/phy/mod_cmnfld.F90 b/phy/mod_cmnfld.F90 index eb4b566c..eb12c6fc 100644 --- a/phy/mod_cmnfld.F90 +++ b/phy/mod_cmnfld.F90 @@ -24,13 +24,14 @@ module mod_cmnfld ! ------------------------------------------------------------------------------ use mod_types, only: r8 - use mod_constants, only: g, alpha0, epsil, spval, onem, onemm + use mod_constants, only: g, alpha0, epsil, spval, onem, onecm, onemm use mod_xc use mod_vcoord, only: vcoord_type_tag, isopyc_bulkml, cntiso_hybrid use mod_grid, only: scuxi, scvyi use mod_eos, only: rho, p_alpha use mod_state, only: dp, temp, saln, p, phi, kfpla -! use mod_dia, only : nphy, ACC_BFSQ +! use mod_dia, only : nphy, ACC_BFSQ, ACC_MLTS, ACC_MLTSMN, ACC_MLTSMX, & +! ACC_MLTSSQ, ACC_T20D, ACC_DZ, ACC_DZLVL use mod_diffusion, only: eitmth, edritp use mod_utility, only: util1 use mod_checksum, only: csdiag, chksummsk @@ -51,24 +52,32 @@ module mod_cmnfld ! layer depth to find the e-folding length ! scale of the smoothing length scale in the ! computation of filtered BFSQ []. - bfsqmn = 1.e-7_r8 ! Minimum value of BFSQ used in the + bfsqmn = 1.e-7_r8, & ! Minimum value of BFSQ used in the ! computation of neutral slope [s-2]. + dbcrit = .03_r8 ! Critical buoyancy difference used in the + ! mixed layer thickness estimation (Levitus, + ! 1982) [cm s-2]. real(r8), dimension(1 - nbdy:idm + nbdy, 1 - nbdy:jdm + nbdy, kdm + 1) :: & bfsqi, & ! Interface buoyancy frequency squared [s-2]. - bfsqf ! Filtered interface buoyancy frequency + bfsqf, & ! Filtered interface buoyancy frequency ! squared [s-2]. + z ! Interface depth [cm]. real(r8), dimension(1 - nbdy:idm + nbdy, 1 - nbdy:jdm + nbdy, kdm) :: & bfsql, & ! Layer buoyancy frequency squared [s-2]. nslpx, & ! x-component of local neutral slope []. nslpy, & ! y-component of local neutral slope []. nnslpx, & ! x-component of local neutral slope times ! buoyancy frequency [s-1]. - nnslpy ! y-component of local neutral slope times + nnslpy, & ! y-component of local neutral slope times ! buoyancy frequency [s-1]. + dz ! Layer thickness [cm]. + real(r8), dimension(1 - nbdy:idm + nbdy, 1 - nbdy:jdm + nbdy) :: & + mlts ! Mixed layer depth defined by density + ! criterion [cm]. - public :: bfsql, nslpx, nslpy, nnslpx, nnslpy, inivar_cmnfld, cmnfld - public :: bfsqi + public :: bfsqi, z, bfsql, nslpx, nslpy, nnslpx, nnslpy, dz, mlts, & + inivar_cmnfld, cmnfld contains @@ -261,7 +270,7 @@ subroutine cmnfld_bfsqf_cntiso_hybrid(m, n, mm, nn, k1m, k1n) integer, intent(in) :: m, n, mm, nn, k1m, k1n real(r8), dimension(kdm) :: delp, bfsq, sls2, atd, btd, ctd, rtd, gam - real(r8) :: q, pup, tup, sup, plo, tlo, slo, bei + real(r8) :: pup, tup, sup, plo, tlo, slo, bei integer :: i, j, k, l, km ! ------------------------------------------------------------------------ @@ -271,7 +280,7 @@ subroutine cmnfld_bfsqf_cntiso_hybrid(m, n, mm, nn, k1m, k1n) bfsqi = 0.0_r8 bfsql = 0.0_r8 - !$omp parallel do private(l, i, k, delp, bfsq, q, sls2, pup, tup, sup, km, & + !$omp parallel do private(l, i, k, delp, bfsq, sls2, pup, tup, sup, km, & !$omp plo, tlo, slo, ctd, btd, rtd, atd, bei, gam) do j = - 1, jj + 2 do l = 1, isp(j) @@ -772,6 +781,96 @@ subroutine cmnfld_nslope_cntiso_hybrid(m, n, mm, nn, k1m, k1n) end subroutine cmnfld_nslope_cntiso_hybrid + subroutine cmnfld_z(m, n, mm, nn, k1m, k1n) + ! --------------------------------------------------------------------------- + ! Estimate depth of layer interfaces and thickness of layers. + ! --------------------------------------------------------------------------- + + integer, intent(in) :: m, n, mm, nn, k1m, k1n + + integer :: i, j, k, l, km + + !$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)) + z(i, j, kk + 1) = - phi(i, j, kk + 1)/g + enddo + enddo + enddo + !$omp end parallel do + !$omp parallel do private(k, km, l, i) + do j = 1, jj + do k = kk, 1, - 1 + km = k + mm + do l = 1, isp(j) + do i = max(1, ifp(j, l)), min(ii, ilp(j, l)) + if (dp(i, j, km) < epsil) then + z(i, j, k) = z(i, j, k + 1) + else + z(i, j, k) = z(i, j, k + 1) & + + p_alpha(p(i, j, k + 1), p(i, j, k), & + temp(i, j, km), saln(i, j, km))/g + endif + dz(i, j, k) = z(i, j, k + 1) - z(i, j, k) + enddo + enddo + enddo + enddo + !$omp end parallel do + + end subroutine cmnfld_z + + subroutine cmnfld_mlts(m, n, mm, nn, k1m, k1n) + ! --------------------------------------------------------------------------- + ! Estimate mixed layer depth using density criterion. + ! --------------------------------------------------------------------------- + + integer, intent(in) :: m, n, mm, nn, k1m, k1n + + real(r8) :: zup, dbup, plo, zlo, dblo + integer :: i, j, k, l, km + + !$omp parallel do private(l, i, k, km, zup, dbup, plo, zlo, dblo) + do j = 1, jj + do l = 1, isp(j) + do i = max(1, ifp(j, l)), min(ii, ilp(j, l)) + k = 2 + km = k + mm + zup = z(i, j, 1) + .5_r8*dz(i, j, 1) + dbup = 0._r8 + do + if (dp(i, j, km) > onecm) then + plo = p(i, j, k) + .5_r8*dp(i, j, km) + zlo = z(i, j, k) + .5_r8*dz(i, j, k ) + dblo = & + g*(1._r8 - rho(plo, temp(i, j, k1m), saln(i, j, k1m)) & + /rho(plo, temp(i, j, km ), saln(i, j, km ))) + if (dblo <= dbcrit) then + zup = zlo + dbup = dblo + else + dbup = min(dbup, dbcrit - epsil) + mlts(i, j) = ( zup*(dblo - dbcrit) & + + zlo*(dbcrit - dbup))/(dblo - dbup) & + - z(i, j, 1) + exit + endif + endif + k = k + 1 + if (k > kk) then + mlts(i, j) = z(i, j, kk + 1) - z(i, j, 1) + exit + endif + km = k + mm + enddo + enddo + enddo + enddo + !$omp end parallel do + + end subroutine cmnfld_mlts + ! --------------------------------------------------------------------------- ! Public procedures. ! --------------------------------------------------------------------------- @@ -785,17 +884,26 @@ subroutine inivar_cmnfld !$omp parallel do private(k, i) do j = 1 - nbdy, jj + nbdy + do k = 1, kk + 1 + do i = 1 - nbdy, ii + nbdy + bfsqi(i, j, k) = spval + bfsqf(i, j, k) = spval + z (i, j, k) = spval + enddo + enddo do k = 1, kk do i = 1 - nbdy, ii + nbdy - bfsqi (i, j, k) = spval bfsql (i, j, k) = spval - bfsqf (i, j, k) = spval nslpx (i, j, k) = spval nslpy (i, j, k) = spval nnslpx(i, j, k) = spval nnslpy(i, j, k) = spval + dz (i, j, k) = spval enddo enddo + do i = 1 - nbdy, ii + nbdy + mlts(i, j) = spval + enddo enddo !$omp end parallel do @@ -839,12 +947,14 @@ subroutine cmnfld(m, n, mm, nn, k1m, k1n) !$omp end parallel do ! ------------------------------------------------------------------------ - ! Compute fields depending on selection of physics. + ! Compute fields depending on selection of physics and diagnostics. ! ------------------------------------------------------------------------ -! if (edritp == 'large scale' .or. eitmth == 'gm' .or. -! . sum(ACC_BFSQ(1:nphy)).ne.0) then - if (edritp == 'large scale' .or. eitmth == 'gm') then +! if (vcoord_type_tag == cntiso_hybrid .or. & +! edritp == 'large scale' .or. eitmth == 'gm' .or. & +! sum(ACC_BFSQ(1:nphy)) /= 0) then + if (vcoord_type_tag == cntiso_hybrid .or. & + edritp == 'large scale' .or. eitmth == 'gm') then ! --------------------------------------------------------------------- ! Compute filtered buoyancy frequency squared. @@ -872,6 +982,32 @@ subroutine cmnfld(m, n, mm, nn, k1m, k1n) endif - end subroutine cmnfld +! if (vcoord_type_tag == cntiso_hybrid .or. & +! sum( ACC_MLTS (1:nphy) + ACC_MLTSMN(1:nphy) & +! + ACC_MLTSMX(1:nphy) + ACC_MLTSSQ(1:nphy) & +! + ACC_T20D (1:nphy) + & +! + ACC_DZ (1:nphy) + ACC_DZLVL(1:nphy)) /= 0) then + + ! --------------------------------------------------------------------- + ! Estimate depth of layer interfaces and thickness of layers. + ! --------------------------------------------------------------------- + + call cmnfld_z(m, n, mm, nn, k1m, k1n) + +! endif + +! if (vcoord_type_tag == cntiso_hybrid .or. & +! sum( ACC_MLTS (1:nphy) + ACC_MLTSMN(1:nphy) & +! + ACC_MLTSMX(1:nphy) + ACC_MLTSSQ(1:nphy)) /= 0) then + + ! --------------------------------------------------------------------- + ! Estimate mixed layer depth using density criterion. + ! --------------------------------------------------------------------- + + call cmnfld_mlts(m, n, mm, nn, k1m, k1n) + +! endif + + end subroutine cmnfld end module mod_cmnfld diff --git a/phy/mod_dia.F b/phy/mod_dia.F index e51f349b..ef1f489c 100644 --- a/phy/mod_dia.F +++ b/phy/mod_dia.F @@ -46,7 +46,7 @@ module mod_dia . Kvisc_m, Kdiff_t, Kdiff_s, . umfltd, vmfltd, utfltd, vtfltd, utflld, . vtflld, usfltd, vsfltd, usflld, vsflld - use mod_cmnfld, only: bfsql + use mod_cmnfld, only: z, bfsql, dz, mlts use mod_seaice, only: ficem, hicem, hsnwm, uicem, vicem, iagem use mod_forcing, only: swa, nsf, hmltfz, lip, sop, eva, rnf, rfi, . fmltfz, sfl, ztx, mty, abswnd, surflx, @@ -171,10 +171,6 @@ module mod_dia c --- temperature diagnostics real, parameter :: dpbot=98060. c -c --- Critical buoyancy difference [cm s-2] used in the mixed layer -c --- thickness estimation (Levitus, 1982) - real, parameter :: dbcrit=.03 -c c --- Namelist integer, dimension(nphymax), save :: . H2D_ABSWND ,H2D_ALB ,H2D_BTMSTR ,H2D_BRNFLX ,H2D_BRNPD , @@ -1000,12 +996,11 @@ subroutine diaacc(m,n,mm,nn,k1m,k1n) c real, dimension(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy,ddm) :: wghts, . wghtsflx - real, dimension(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy,kdm+1) :: z real, dimension(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy,kdm) :: uvel,vvel, - . dz,avdsg_p,dpvor_p,pv_p,dummy + . avdsg_p,dpvor_p,pv_p,dummy real, dimension(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy) :: - . dpml,sbot,tbot,dps,mlts,t20d - real dsig,q,zup,zlo,plo,dbup,dblo,tup,tlo + . dpml,sbot,tbot,dps,t20d + real dsig,q,zup,zlo,plo,tup,tlo c c --- Increase counter do iogrp=1,nphy @@ -1093,39 +1088,6 @@ subroutine diaacc(m,n,mm,nn,k1m,k1n) enddo c$OMP END PARALLEL DO endif -c - if (sum(ACC_MLTS(1:nphy)+ACC_MLTSMN(1:nphy) - . +ACC_MLTSMX(1:nphy)+ACC_MLTSSQ(1:nphy) - . +ACC_T20D(1:nphy) - . +ACC_DZ(1:nphy)+ACC_DZLVL(1:nphy)).ne.0) then -c$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)) - z(i,j,kk+1)=-phi(i,j,kk+1)/g - enddo - enddo - enddo -c$OMP END PARALLEL DO -c$OMP PARALLEL DO PRIVATE(k,km,l,i) - do j=1,jj - do k=kk,1,-1 - km=k+mm - do l=1,isp(j) - do i=max(1,ifp(j,l)),min(ii,ilp(j,l)) - if (dp(i,j,km).lt.epsil) then - z(i,j,k)=z(i,j,k+1) - else - z(i,j,k)=z(i,j,k+1)+p_alpha(p(i,j,k+1),p(i,j,k), - . temp(i,j,km),saln(i,j,km))/g - endif - dz(i,j,k)=z(i,j,k+1)-z(i,j,k) - enddo - enddo - enddo - enddo -c$OMP END PARALLEL DO - endif c if (sum(ACC_AVDSG(1:nphy)+ACC_PVLVL(1:nphy)).ne.0) then c$OMP PARALLEL DO PRIVATE(l,i,k,km,dsig) @@ -1211,45 +1173,6 @@ subroutine diaacc(m,n,mm,nn,k1m,k1n) enddo c$OMP END PARALLEL DO endif -c - if (sum(ACC_MLTS(1:nphy)+ACC_MLTSMN(1:nphy) - . +ACC_MLTSMX(1:nphy)+ACC_MLTSSQ(1:nphy)).ne.0) then -c$OMP PARALLEL DO PRIVATE(l,i,k,km,zup,dbup,plo,zlo,dblo) - do j=1,jj - do l=1,isp(j) - do i=max(1,ifp(j,l)),min(ii,ilp(j,l)) - k=2 - km=k+mm - zup=z(i,j,1)+.5*dz(i,j,1) ! .5*(z(i,j,1)+z(i,j,2)) - dbup=0. - do - if (dp(i,j,km).gt.onecm) then - plo=p(i,j,k)+.5*dp(i,j,km) ! .5*(p(i,j,k)+p(i,j,k+1)) - zlo=z(i,j,k)+.5*dz(i,j,k ) ! .5*(z(i,j,k)+z(i,j,k+1)) - dblo=g*(1.-rho(plo,temp(i,j,k1m),saln(i,j,k1m)) - . /rho(plo,temp(i,j,km ),saln(i,j,km ))) - if (dblo.le.dbcrit) then - zup=zlo - dbup=dblo - else - dbup=min(dbup,dbcrit-epsil) - mlts(i,j)=(zup*(dblo-dbcrit) - . +zlo*(dbcrit-dbup))/(dblo-dbup)-z(i,j,1) - exit - endif - endif - k=k+1 - if (k.gt.kk) then - mlts(i,j)=z(i,j,kk+1)-z(i,j,1) - exit - endif - km=k+mm - enddo - enddo - enddo - enddo -c$OMP END PARALLEL DO - endif c if (sum(ACC_T20D(1:nphy)).ne.0) then c$OMP PARALLEL DO PRIVATE(l,i,k,km,kup,zup,zlo,tup,tlo) From 7cde1f8e5979583040d35ad7552f7ebe180c4bd2 Mon Sep 17 00:00:00 2001 From: Mats Bentsen Date: Mon, 25 Oct 2021 11:35:09 +0200 Subject: [PATCH 031/366] Changed the mixed layer depth estimation used to locate range of layers considered in eddy diffusivity estimation for hybrid vertical coordinate. --- phy/mod_difest.F | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/phy/mod_difest.F b/phy/mod_difest.F index f4469168..89a7b8d6 100644 --- a/phy/mod_difest.F +++ b/phy/mod_difest.F @@ -35,7 +35,7 @@ module mod_difest . egidfq, ri0, bdmc1, bdmc2, tkepf, bdmtyp, . edsprs, edritp, edwmth, . difint, difiso, difdia, difmxp, difwgt - use mod_cmnfld, only: nnslpx, nnslpy + use mod_cmnfld, only: nnslpx, nnslpy, mlts use mod_forcing, only: ustar, ustarb, ustar3, buoyfl use mod_tidaldissip, only: twedon use mod_niw, only: niwgf, niwbf, niwlf, idkedt, niw_ke_tendency @@ -1140,7 +1140,7 @@ subroutine difest_lateral_hyb(m,n,mm,nn,k1m,k1n) do i=max(1,ifp(j,l)),min(ii,ilp(j,l)) kfil(i,j)=kk+1 do k=kk,2,-1 - if (p(i,j,k).gt.OBLdepth(i,j)*onem) kfil(i,j)=k + if (p(i,j,k).gt.mlts(i,j)*onecm) kfil(i,j)=k enddo enddo enddo From d8dcf4e375d0a4decff53dd6a126298b7c01d7bc Mon Sep 17 00:00:00 2001 From: Mats Bentsen Date: Fri, 5 Nov 2021 11:23:33 +0100 Subject: [PATCH 032/366] Added functionality to run BLOM with hybrid vertical coordinate in NorESM. --- Externals_BLOM.cfg | 9 +++++++ cime_config/buildlib | 1 + cime_config/buildnml | 61 ++++++++++++++++++++++++++++++++++---------- 3 files changed, 58 insertions(+), 13 deletions(-) create mode 100644 Externals_BLOM.cfg diff --git a/Externals_BLOM.cfg b/Externals_BLOM.cfg new file mode 100644 index 00000000..4e31ea00 --- /dev/null +++ b/Externals_BLOM.cfg @@ -0,0 +1,9 @@ +[CVMix] +tag = master +protocol = git +repo_url = https://github.com/CVMix/CVMix-src +local_path = pkgs/CVMix-src +required = True + +[externals_description] +schema_version = 1.0.0 diff --git a/cime_config/buildlib b/cime_config/buildlib index f9de4546..17d5c7c7 100755 --- a/cime_config/buildlib +++ b/cime_config/buildlib @@ -42,6 +42,7 @@ $SRCROOT/components/blom/channel $SRCROOT/components/blom/single_column $SRCROOT/components/blom/drivers/cpl_share $SRCROOT/components/blom/drivers/cpl_mct +$SRCROOT/components/blom/pkgs/CVMix-src/src/shared $SRCROOT/components/blom/phy EOF1 diff --git a/cime_config/buildnml b/cime_config/buildnml index 0af0e41a..00e91f8f 100755 --- a/cime_config/buildnml +++ b/cime_config/buildnml @@ -167,6 +167,21 @@ else set IOTYPE = 0 endif +set VCOORD_TYPE = "'isopyc_bulkml'" +set RECONSTRUCTION_METHOD = "'ppm'" +set DENSITY_LIMITING = "'monotonic'" +set TRACER_LIMITING = "'monotonic'" +set VELOCITY_LIMITING = "'monotonic'" +set DENSITY_PC_UPPER_BNDR = .false. +set DENSITY_PC_LOWER_BNDR = .false. +set TRACER_PC_UPPER_BNDR = .true. +set TRACER_PC_LOWER_BNDR = .false. +set VELOCITY_PC_UPPER_BNDR = .true. +set VELOCITY_PC_LOWER_BNDR = .false. +set DPMIN_SURFACE = 2.5 +set DPMIN_INFLATION_FACTOR = 1.05 +set DPMIN_INTERIOR = .1 + # set BGCNML defaults set ATM_CO2 = $CCSM_CO2_PPMV if ($BLOM_RIVER_NUTRIENTS == TRUE) then @@ -234,8 +249,6 @@ set H2D_IDKEDT = '0, 4, 0' set H2D_LIP = '0, 4, 0' set H2D_MAXMLD = '4, 4, 0' set H2D_MLD = '0, 4, 0' -set H2D_MLDU = '0, 0, 0' -set H2D_MLDV = '0, 0, 0' set H2D_MLTS = '4, 4, 0' set H2D_MLTSMN = '0, 4, 0' set H2D_MLTSMX = '0, 4, 0' @@ -247,8 +260,6 @@ set H2D_MTKERS = '0, 4, 0' set H2D_MTKEPE = '0, 4, 0' set H2D_MTKEKE = '0, 4, 0' set H2D_MTY = '0, 4, 0' -set H2D_MXLU = '0, 4, 0' -set H2D_MXLV = '0, 4, 0' set H2D_NSF = '0, 4, 0' set H2D_PBOT = '0, 4, 0' set H2D_PSRF = '0, 4, 0' @@ -284,6 +295,9 @@ set H2D_VICE = '0, 0, 0' set H2D_ZTX = '0, 4, 0' set LYR_BFSQ = '0, 4, 0' set LYR_DIFDIA = '0, 4, 0' +set LYR_DIFVMO = '0, 4, 0' +set LYR_DIFVHO = '0, 4, 0' +set LYR_DIFVSO = '0, 4, 0' set LYR_DIFINT = '0, 4, 0' set LYR_DIFISO = '0, 4, 0' set LYR_DP = '0, 4, 0' @@ -317,6 +331,9 @@ set LYR_GLS_PSI = '0, 4, 0' set LYR_IDLAGE = '0, 4, 0' set LVL_BFSQ = '0, 4, 0' set LVL_DIFDIA = '0, 4, 0' +set LVL_DIFVMO = '0, 4, 0' +set LVL_DIFVHO = '0, 4, 0' +set LVL_DIFVSO = '0, 4, 0' set LVL_DIFINT = '0, 4, 0' set LVL_DIFISO = '0, 4, 0' set LVL_DZ = '0, 4, 0' @@ -947,6 +964,23 @@ cat >! $RUNDIR/ocn_in$inststr << EOF RSTCMP = $RSTCMP IOTYPE = $IOTYPE / + +&VCOORD + VCOORD_TYPE = $VCOORD_TYPE + RECONSTRUCTION_METHOD = $RECONSTRUCTION_METHOD + DENSITY_LIMITING = $DENSITY_LIMITING + TRACER_LIMITING = $TRACER_LIMITING + VELOCITY_LIMITING = $VELOCITY_LIMITING + DENSITY_PC_UPPER_BNDR = $DENSITY_PC_UPPER_BNDR + DENSITY_PC_LOWER_BNDR = $DENSITY_PC_LOWER_BNDR + TRACER_PC_UPPER_BNDR = $TRACER_PC_UPPER_BNDR + TRACER_PC_LOWER_BNDR = $TRACER_PC_LOWER_BNDR + VELOCITY_PC_UPPER_BNDR = $VELOCITY_PC_UPPER_BNDR + VELOCITY_PC_LOWER_BNDR = $VELOCITY_PC_LOWER_BNDR + DPMIN_SURFACE = $DPMIN_SURFACE + DPMIN_INFLATION_FACTOR = $DPMIN_INFLATION_FACTOR + DPMIN_INTERIOR = $DPMIN_INTERIOR +/ EOF if ($?CWMTAG) then @@ -1075,8 +1109,6 @@ cat >>! $RUNDIR/ocn_in$inststr << EOF ! LIP - liquid precipitation [kg m-2 s-1] ! MAXMLD - maximum mixed layer depth [m] ! MLD - mixed layer depth [m] -! MLDU - mixed layer depth at u-point [m] -! MLDV - mixed layer depth at v-point [m] ! MLTS - mixed layer thickness using "sigma-t" criterion [m] ! MLTSMN - minimum mixed layer thickness using "sigma-t" criterion [m] ! MLTSMX - maximum mixed layer thickness using "sigma-t" criterion [m] @@ -1088,8 +1120,6 @@ cat >>! $RUNDIR/ocn_in$inststr << EOF ! MTKEPE - mixed layer TKE tendency related to pot. energy change [kg s-3] ! MTKEKE - mixed layer TKE tendency related to kin. energy change [kg s-3] ! MTY - wind stress y-component [N m-2] -! MXLU - mixed layer velocity x-component [m s-1] -! MXLV - mixed layer velocity y-component [m s-1] ! NSF - non-solar heat flux [W m-2] ! PBOT - bottom pressure [Pa] ! PSRF - surface pressure [Pa] @@ -1124,7 +1154,10 @@ cat >>! $RUNDIR/ocn_in$inststr << EOF ! VICE - ice velocity y-component [m s-1] ! ZTX - wind stress x-component [N m-2] ! BFSQ - buoyancy frequency squared [s-1] -! DIFDIA - diapycnal diffusivity [log10(m2 s-1)] +! DIFDIA - vertical diffusivity [log10(m2 s-1)|m2 s-1] +! DIFVMO - vertical momentum diffusivity [log10(m2 s-1)|m2 s-1] +! DIFVHO - vertical heat diffusivity [log10(m2 s-1)|m2 s-1] +! DIFVSO - vertical salt diffusivity [log10(m2 s-1)|m2 s-1] ! DIFINT - layer interface diffusivity [log10(m2 s-1)] ! DIFISO - isopycnal diffusivity [log10(m2 s-1)] ! DP - layer pressure thickness [Pa] @@ -1197,8 +1230,6 @@ cat >>! $RUNDIR/ocn_in$inststr << EOF H2D_LIP = $H2D_LIP H2D_MAXMLD = $H2D_MAXMLD H2D_MLD = $H2D_MLD - H2D_MLDU = $H2D_MLDU - H2D_MLDV = $H2D_MLDV H2D_MLTS = $H2D_MLTS H2D_MLTSMN = $H2D_MLTSMN H2D_MLTSMX = $H2D_MLTSMX @@ -1210,8 +1241,6 @@ cat >>! $RUNDIR/ocn_in$inststr << EOF H2D_MTKEPE = $H2D_MTKEPE H2D_MTKEKE = $H2D_MTKEKE H2D_MTY = $H2D_MTY - H2D_MXLU = $H2D_MXLU - H2D_MXLV = $H2D_MXLV H2D_NSF = $H2D_NSF H2D_PBOT = $H2D_PBOT H2D_PSRF = $H2D_PSRF @@ -1247,6 +1276,9 @@ cat >>! $RUNDIR/ocn_in$inststr << EOF H2D_ZTX = $H2D_ZTX LYR_BFSQ = $LYR_BFSQ LYR_DIFDIA = $LYR_DIFDIA + LYR_DIFVMO = $LYR_DIFVMO + LYR_DIFVHO = $LYR_DIFVHO + LYR_DIFVSO = $LYR_DIFVSO LYR_DIFINT = $LYR_DIFINT LYR_DIFISO = $LYR_DIFISO LYR_DP = $LYR_DP @@ -1280,6 +1312,9 @@ cat >>! $RUNDIR/ocn_in$inststr << EOF LYR_IDLAGE = $LYR_IDLAGE LVL_BFSQ = $LVL_BFSQ LVL_DIFDIA = $LVL_DIFDIA + LVL_DIFVMO = $LVL_DIFVMO + LVL_DIFVHO = $LVL_DIFVHO + LVL_DIFVSO = $LVL_DIFVSO LVL_DIFINT = $LVL_DIFINT LVL_DIFISO = $LVL_DIFISO LVL_DZ = $LVL_DZ From bebeefb9d0f3359b0c26696e32f571b0da0edae3 Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Mon, 28 Feb 2022 14:18:40 +0100 Subject: [PATCH 033/366] Enabling time step-wise inventory calculation in 1D mode by default before and after BGC For test purposes, we check the inventory before and after entering the BGC routine. This can be thrown out again by the end of development --- hamocc/hamocc4bcm.F90 | 18 +++++++++++++++++- 1 file changed, 17 insertions(+), 1 deletion(-) diff --git a/hamocc/hamocc4bcm.F90 b/hamocc/hamocc4bcm.F90 index dd690af1..d82a9923 100644 --- a/hamocc/hamocc4bcm.F90 +++ b/hamocc/hamocc4bcm.F90 @@ -91,6 +91,7 @@ SUBROUTINE HAMOCC4BCM(kpie,kpje,kpke,kbnd,kplyear,kplmon,kplday,kldtday,& use mo_vgrid, only: set_vgrid use mo_riverinpt, only: riverinpt,nriv use mo_ndep, only: n_deposition + use mod_config, only: expcnf #if defined(BOXATM) use mo_boxatm #endif @@ -193,7 +194,14 @@ SUBROUTINE HAMOCC4BCM(kpie,kpje,kpke,kbnd,kplyear,kplmon,kplday,kldtday,& atm_cfc11_sh,atm_cfc12_sh,atm_sf6_sh) #endif - +! jm + IF(expcnf.eq.'single_column')THEN + IF (mnproc.eq.1) THEN + WRITE(io_stdo_bgc,*)' ' + WRITE(io_stdo_bgc,*)'before BGC: call INVENTORY' + ENDIF + CALL INVENTORY_BGC(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask,0) + ENDIF #ifdef PBGC_CK_TIMESTEP IF (mnproc.eq.1) THEN @@ -325,6 +333,14 @@ SUBROUTINE HAMOCC4BCM(kpie,kpje,kpke,kbnd,kplyear,kplmon,kplday,kldtday,& CALL INVENTORY_BGC(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask,0) #endif +! jm + IF(expcnf.eq.'single_column') THEN + IF (mnproc.eq.1) THEN + WRITE(io_stdo_bgc,*)' ' + WRITE(io_stdo_bgc,*)'after BGC: call INVENTORY' + ENDIF + CALL INVENTORY_BGC(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask,0) + ENDIF !-------------------------------------------------------------------- ! Pass co2 flux. Convert unit from kmol/m^2 to kg/m^2/s. From f5f0915c29d8fb2974e02475a0447b5b824460fc Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Mon, 28 Feb 2022 15:50:01 +0100 Subject: [PATCH 034/366] Start implementing the extended nitrogen cycle; introducing preprocessor flag extNcycle in meson build system The development of the new, extended nitrogen cycle in iHAMOCC is part of the EU ESM2025 project with the aim to enable NorESM runs with a processs-oriented representation of the oceanic nitrogen cycle --- meson.build | 3 +++ meson_options.txt | 2 ++ 2 files changed, 5 insertions(+) diff --git a/meson.build b/meson.build index 13945353..66454658 100644 --- a/meson.build +++ b/meson.build @@ -118,6 +118,9 @@ if get_option('ecosys') endif add_project_arguments('-Dcisonew', language: 'fortran') endif + if get_option('hamocc_extNcycle') + add_project_arguments('-DextNcycle', language: 'fortran') + endif subdir('hamocc') endif diff --git a/meson_options.txt b/meson_options.txt index 61f1a62d..bb81bc66 100644 --- a/meson_options.txt +++ b/meson_options.txt @@ -25,6 +25,8 @@ option('hamocc_sedbypass', type: 'boolean', description: 'Bypass sediment code in HAMOCC', value: true) option('hamocc_ciso', type: 'boolean', description: 'Enable carbon isotopes in HAMOCC', value: false) +option('hamocc_extNcycle', type: 'boolean', + description: 'Enable extended nitrogen cycle in HAMOCC', value: false) option('levitus2x', type: 'boolean', description: 'Enable level diagnostics at double resolution of standard Levitus depths', value: true) # Build configuration From 588caa93077b67585647181d7af7400c75ad184b Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Mon, 28 Feb 2022 16:37:31 +0100 Subject: [PATCH 035/366] Provide advected tracers iano2 and ianh4 for nitrite and ammonium for ocetra --- hamocc/mo_param1_bgc.F90 | 14 ++++++++++++-- 1 file changed, 12 insertions(+), 2 deletions(-) diff --git a/hamocc/mo_param1_bgc.F90 b/hamocc/mo_param1_bgc.F90 index 42a2cc95..efff91b6 100644 --- a/hamocc/mo_param1_bgc.F90 +++ b/hamocc/mo_param1_bgc.F90 @@ -135,10 +135,20 @@ MODULE mo_param1_bgc INTEGER, PARAMETER :: i_bromo=0, & & ibromo=-1 #endif - +#ifdef extNcycle + INTEGER, PARAMETER :: i_extn=2, & + & iano2 = i_base+i_iso+i_cfc+i_agg+i_nat_dic & + & +i_bromo+1, & + & ianh4 = i_base+i_iso+i_cfc+i_agg+i_nat_dic & + & +i_bromo+2 +#else + INTEGER, PARAMETER :: i_extn=0, & + & iano2 = -1, & + & ianh4 = -1 +#endif ! total number of advected tracers INTEGER, PARAMETER :: nocetra=i_base+i_iso+i_cfc+i_agg+i_nat_dic & - +i_bromo + +i_bromo+i_extn ! ATMOSPHERE From 0c031f274ba71c77dd9d818f9c8538c14cb888a9 Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Mon, 28 Feb 2022 18:11:07 +0100 Subject: [PATCH 036/366] included water column ammonium and nitrite into i/o of restart files --- hamocc/aufr_bgc.F90 | 28 +++++++++++++++++++++++++++- hamocc/aufw_bgc.F90 | 14 +++++++++++++- 2 files changed, 40 insertions(+), 2 deletions(-) diff --git a/hamocc/aufr_bgc.F90 b/hamocc/aufr_bgc.F90 index 3f3e4f9f..4345995d 100644 --- a/hamocc/aufr_bgc.F90 +++ b/hamocc/aufr_bgc.F90 @@ -127,7 +127,7 @@ SUBROUTINE AUFR_BGC(kpie,kpje,kpke,ntr,ntrbgc,itrbgc,trc, & INTEGER :: restday ! day of restart file INTEGER :: restdtoce ! time step number from bgc ocean file INTEGER :: idate(5),i,j,k - logical :: lread_cfc,lread_nat,lread_iso,lread_atm,lread_bro + logical :: lread_cfc,lread_nat,lread_iso,lread_atm,lread_bro,lread_extn #ifdef cisonew REAL :: rco213,rco214,alpha14,beta13,beta14,d13C_atm,d14cat #endif @@ -333,6 +333,26 @@ SUBROUTINE AUFR_BGC(kpie,kpje,kpke,ntr,ntrbgc,itrbgc,trc, & ENDIF #endif +! Find out whether to restart extended nitrogen cycle +#ifdef extNcycle + lread_extn=.true. + IF(IOTYPE==0) THEN + if(mnproc==1) ncstat=nf90_inq_varid(ncid,'anh4',ncvarid) + call xcbcst(ncstat) + if(ncstat.ne.nf90_noerr) lread_extn=.false. + ELSE IF(IOTYPE==1) THEN +#ifdef PNETCDF + ncstat=nfmpi_inq_varid(ncid,'anh4',ncvarid) + if(ncstat.ne.nf_noerr) lread_extn=.false. +#endif + ENDIF + IF(mnproc==1 .and. .not. lread_extn) THEN + WRITE(io_stdo_bgc,*) ' ' + WRITE(io_stdo_bgc,*) 'AUFR_BGC info: extended nitrogen cycle tracer not in restart file ' + WRITE(io_stdo_bgc,*) 'Initialising extended nitrogen cycle from scratch' + ENDIF +#endif + ! Find out whether to restart atmosphere #if defined(BOXATM) lread_atm=.true. @@ -424,6 +444,12 @@ SUBROUTINE AUFR_BGC(kpie,kpje,kpke,ntr,ntrbgc,itrbgc,trc, & CALL read_netcdf_var(ncid,'bromo',locetra(1,1,1,ibromo),2*kpke,0,iotype) ENDIF #endif +#ifdef extNcycle + IF(lread_extn) THEN + CALL read_netcdf_var(ncid,'anh4',locetra(1,1,1,ianh4),2*kpke,0,iotype) + CALL read_netcdf_var(ncid,'ano2',locetra(1,1,1,iano2),2*kpke,0,iotype) + ENDIF +#endif ! ! Read restart data : diagnostic ocean fields (needed for bit to bit reproducability) diff --git a/hamocc/aufw_bgc.F90 b/hamocc/aufw_bgc.F90 index 0bbec05a..8ab12e64 100644 --- a/hamocc/aufw_bgc.F90 +++ b/hamocc/aufw_bgc.F90 @@ -552,7 +552,15 @@ SUBROUTINE AUFW_BGC(kpie,kpje,kpke,ntr,ntrbgc,itrbgc,trc, & #endif #ifdef BROMO CALL NETCDF_DEF_VARDB(ncid,5,'bromo',3,ncdimst,ncvarid, & - & 6,'mol/kg',9,'Bromoform',rmissing,47,io_stdo_bgc) + & 6,'mol/kg',9,'Bromoform',rmissing,53,io_stdo_bgc) +#endif +#ifdef extNcycle + CALL NETCDF_DEF_VARDB(ncid,4,'anh4',3,ncdimst,ncvarid, & + & 6,'mol/kg',18,'Dissolved ammonium', & + rmissing,54,io_stdo_bgc) + CALL NETCDF_DEF_VARDB(ncid,4,'ano2',3,ncdimst,ncvarid, & + & 6,'mol/kg',17,'Dissolved nitrite', & + rmissing,55,io_stdo_bgc) #endif ! @@ -837,6 +845,10 @@ SUBROUTINE AUFW_BGC(kpie,kpje,kpke,ntr,ntrbgc,itrbgc,trc, & #ifdef BROMO CALL write_netcdf_var(ncid,'bromo',locetra(1,1,1,ibromo),2*kpke,0) #endif +#ifdef extNcycle + CALL write_netcdf_var(ncid,'anh4',locetra(1,1,1,ianh4),2*kpke,0) + CALL write_netcdf_var(ncid,'ano2',locetra(1,1,1,iano2),2*kpke,0) +#endif ! ! Write restart data : diagtnostic ocean fields From d4a6aaa7da7c6d1b16a5017e2edd7470c7373f92 Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Tue, 1 Mar 2022 11:41:48 +0100 Subject: [PATCH 037/366] Add inventory for advected water column tracers NO2 and NH4 to total nitrogen and oxygen --- hamocc/inventory_bgc.F90 | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/hamocc/inventory_bgc.F90 b/hamocc/inventory_bgc.F90 index e8260560..52b734b6 100644 --- a/hamocc/inventory_bgc.F90 +++ b/hamocc/inventory_bgc.F90 @@ -498,6 +498,9 @@ SUBROUTINE INVENTORY_BGC(kpie,kpje,kpke,dlxp,dlyp,ddpo,WETO & totalnitr= & & (zocetrato(idet)+zocetrato(idoc)+zocetrato(iphy) & & +zocetrato(izoo))*rnit+zocetrato(iano3)+zocetrato(igasnit)*2 & +#ifdef extNcycle + & +zocetrato(ianh4)+zocetrato(iano2) & +#endif & +zpowtrato(ipowno3)+zpowtrato(ipown2)*2 & & +zsedlayto(issso12)*rnit+zburial(issso12)*rnit & & +zocetrato(ian2o)*2 & @@ -525,6 +528,9 @@ SUBROUTINE INVENTORY_BGC(kpie,kpje,kpke,dlxp,dlyp,ddpo,WETO & & +zocetrato(izoo))*(-24.)+zocetrato(ioxygen) & & +zocetrato(iphosph)*2 +zocetrato(isco212)+zocetrato(icalc) & & +zocetrato(iano3)*1.5+zocetrato(ian2o)*0.5 & +#ifdef extNcycle + & +zocetrato(iano2) & +#endif & +zsedlayto(issso12)*(-24.) + zsedlayto(isssc12) & ! & +zburial(issso12)*(-24.) + zburial(isssc12) & & +zpowtrato(ipowno3)*1.5+zpowtrato(ipowaic) & From c811d95d617aabfee9676b14fb48437cdfd8e6bd Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Tue, 1 Mar 2022 17:47:16 +0100 Subject: [PATCH 038/366] Enabling to write out global fluxes in log file --- hamocc/inventory_bgc.F90 | 17 ++++++++--------- 1 file changed, 8 insertions(+), 9 deletions(-) diff --git a/hamocc/inventory_bgc.F90 b/hamocc/inventory_bgc.F90 index 52b734b6..8e8e431a 100644 --- a/hamocc/inventory_bgc.F90 +++ b/hamocc/inventory_bgc.F90 @@ -421,13 +421,12 @@ SUBROUTINE INVENTORY_BGC(kpie,kpje,kpke,dlxp,dlyp,ddpo,WETO & CALL xcsum(zatmn2,ztmp1,ips) #endif -! IF (mnproc.eq.1) THEN -! WRITE(io_stdo_bgc,*) ' ' -! WRITE(io_stdo_bgc,*) 'CO2Flux :',co2flux -! WRITE(io_stdo_bgc,*) 'O2 Flux :',so2flux -! WRITE(io_stdo_bgc,*) 'N2 Flux :',sn2flux -! WRITE(io_stdo_bgc,*) 'N2O Flux :',sn2oflux -! WRITE(io_stdo_bgc,*) ' ' + IF (mnproc.eq.1) THEN + WRITE(io_stdo_bgc,*) ' ' + WRITE(io_stdo_bgc,*) 'CO2Flux :',co2flux + WRITE(io_stdo_bgc,*) 'O2 Flux :',so2flux + WRITE(io_stdo_bgc,*) 'N2 Flux :',sn2flux + WRITE(io_stdo_bgc,*) 'N2O Flux :',sn2oflux #if defined(BOXATM) ! WRITE(io_stdo_bgc,*) 'global atm. CO2[ppm] / kmol: ', & ! & zatmco2/ztotarea,zatmco2*ppm2con @@ -435,9 +434,9 @@ SUBROUTINE INVENTORY_BGC(kpie,kpje,kpke,dlxp,dlyp,ddpo,WETO & ! & zatmo2/ztotarea,zatmo2*ppm2con ! WRITE(io_stdo_bgc,*) 'global atm. N2[ppm] / kmol : ', & ! & zatmn2/ztotarea,zatmn2*ppm2con -! ENDIF - #endif + WRITE(io_stdo_bgc,*) ' ' + ENDIF ! Complete sum of inventory in between bgc.f90 From df8bc195ebbc5efa3a3a99fb674f5a7f6ea878d4 Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Tue, 1 Mar 2022 20:03:52 +0100 Subject: [PATCH 039/366] Put single column inventory check after update of flux fields --- hamocc/accfields.F90 | 12 +++++++++++- hamocc/hamocc4bcm.F90 | 9 --------- 2 files changed, 11 insertions(+), 10 deletions(-) diff --git a/hamocc/accfields.F90 b/hamocc/accfields.F90 index b19a9cf9..e11b3a17 100644 --- a/hamocc/accfields.F90 +++ b/hamocc/accfields.F90 @@ -52,7 +52,7 @@ SUBROUTINE ACCFIELDS(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask) use mo_param1_bgc use mo_vgrid, only: dp_min use mod_xc - + use mod_config, only: expcnf implicit none INTEGER :: kpie,kpje,kpke REAL :: pdlxp(kpie,kpje) @@ -376,5 +376,15 @@ SUBROUTINE ACCFIELDS(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask) endif ENDDO +! jm + IF(expcnf.eq.'single_column') THEN + IF (mnproc.eq.1) THEN + WRITE(io_stdo_bgc,*)' ' + WRITE(io_stdo_bgc,*)'after BGC flux accumulation: call INVENTORY' + ENDIF + CALL INVENTORY_BGC(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask,0) + ENDIF + + RETURN END diff --git a/hamocc/hamocc4bcm.F90 b/hamocc/hamocc4bcm.F90 index d82a9923..d749c492 100644 --- a/hamocc/hamocc4bcm.F90 +++ b/hamocc/hamocc4bcm.F90 @@ -333,15 +333,6 @@ SUBROUTINE HAMOCC4BCM(kpie,kpje,kpke,kbnd,kplyear,kplmon,kplday,kldtday,& CALL INVENTORY_BGC(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask,0) #endif -! jm - IF(expcnf.eq.'single_column') THEN - IF (mnproc.eq.1) THEN - WRITE(io_stdo_bgc,*)' ' - WRITE(io_stdo_bgc,*)'after BGC: call INVENTORY' - ENDIF - CALL INVENTORY_BGC(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask,0) - ENDIF - !-------------------------------------------------------------------- ! Pass co2 flux. Convert unit from kmol/m^2 to kg/m^2/s. From 21dd54ea88848f459f94c5646b3566817f66b1ed Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Wed, 2 Mar 2022 17:18:04 +0100 Subject: [PATCH 040/366] Enabling inventory check in single column mode on a time step base --- hamocc/accfields.F90 | 2 +- hamocc/inventory_bgc.F90 | 22 +++++++++++++++++++++- 2 files changed, 22 insertions(+), 2 deletions(-) diff --git a/hamocc/accfields.F90 b/hamocc/accfields.F90 index e11b3a17..db8b7969 100644 --- a/hamocc/accfields.F90 +++ b/hamocc/accfields.F90 @@ -384,7 +384,7 @@ SUBROUTINE ACCFIELDS(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask) ENDIF CALL INVENTORY_BGC(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask,0) ENDIF - + atmflx(:,:,:)=0. ! nullifying atm flux here to have zero fluxes for stepwise inventory fluxes RETURN END diff --git a/hamocc/inventory_bgc.F90 b/hamocc/inventory_bgc.F90 index 8e8e431a..faefdc44 100644 --- a/hamocc/inventory_bgc.F90 +++ b/hamocc/inventory_bgc.F90 @@ -60,7 +60,9 @@ SUBROUTINE INVENTORY_BGC(kpie,kpje,kpke,dlxp,dlyp,ddpo,WETO & USE mo_param1_bgc use mo_vgrid, only: dp_min USE mod_xc - +!jm + USE mod_config, only: expcnf + implicit none INTEGER :: kpie,kpje,kpke,i,j,k,l,volchck @@ -364,7 +366,24 @@ SUBROUTINE INVENTORY_BGC(kpie,kpje,kpke,dlxp,dlyp,ddpo,WETO & ENDDO CALL xcsum(so2flux,ztmp1,ips) +!jm + IF(expcnf.eq.'single_column') THEN ! enable time step wise cal of fluxes in single col mode + ztmp1(:,:)=0.0 + DO j=1,kpje + DO i=1,kpie + ztmp1(i,j) = atmflx(i,j,iatmn2)*dlxp(i,j)*dlyp(i,j) + ENDDO + ENDDO + CALL xcsum(sn2flux,ztmp1,ips) + ztmp1(:,:)=0.0 + DO j=1,kpje + DO i=1,kpie + ztmp1(i,j) = atmflx(i,j,iatmn2o)*dlxp(i,j)*dlyp(i,j) + ENDDO + ENDDO + CALL xcsum(sn2oflux,ztmp1,ips) + ELSE ztmp1(:,:)=0.0 DO j=1,kpje DO i=1,kpie @@ -382,6 +401,7 @@ SUBROUTINE INVENTORY_BGC(kpie,kpje,kpke,dlxp,dlyp,ddpo,WETO & ENDDO CALL xcsum(sn2oflux,ztmp1,ips) + ENDIF ! single column ztmp1(:,:)=0.0 DO j=1,kpje From c8bbdb3cc7cdf2da358a6758d0b144805b00cf6a Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Wed, 2 Mar 2022 18:31:15 +0100 Subject: [PATCH 041/366] Add inventory tracking for N-deposition fluxes --- hamocc/accfields.F90 | 3 ++- hamocc/inventory_bgc.F90 | 33 +++++++++++++++++++++++++++++---- hamocc/mo_bgcmean.F90 | 3 ++- hamocc/mo_carbch.F90 | 11 +++++++++++ hamocc/mo_ndep.F90 | 10 ++++++---- 5 files changed, 50 insertions(+), 10 deletions(-) diff --git a/hamocc/accfields.F90 b/hamocc/accfields.F90 index db8b7969..4fa57272 100644 --- a/hamocc/accfields.F90 +++ b/hamocc/accfields.F90 @@ -103,6 +103,7 @@ SUBROUTINE ACCFIELDS(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask) bgct2d(i,j,jo2flux) = bgct2d(i,j,jo2flux) + atmflx(i,j,iatmo2)/2.0 bgct2d(i,j,jn2flux) = bgct2d(i,j,jn2flux) + atmflx(i,j,iatmn2)/2.0 bgct2d(i,j,jn2oflux) = bgct2d(i,j,jn2oflux) + atmflx(i,j,iatmn2o)/2.0 + bgct2d(i,j,jndep) = bgct2d(i,j,jndep) + ndepflx(i,j)/2.0 endif enddo @@ -385,6 +386,6 @@ SUBROUTINE ACCFIELDS(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask) CALL INVENTORY_BGC(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask,0) ENDIF atmflx(:,:,:)=0. ! nullifying atm flux here to have zero fluxes for stepwise inventory fluxes - + ndepflx=0. RETURN END diff --git a/hamocc/inventory_bgc.F90 b/hamocc/inventory_bgc.F90 index faefdc44..7bb361cf 100644 --- a/hamocc/inventory_bgc.F90 +++ b/hamocc/inventory_bgc.F90 @@ -81,6 +81,7 @@ SUBROUTINE INVENTORY_BGC(kpie,kpje,kpke,dlxp,dlyp,ddpo,WETO & REAL :: zhito,zco3to,sum,zprorca,zprcaca,zsilpro REAL :: zatmco2,zatmo2,zatmn2 REAL :: co2flux,so2flux,sn2flux,sn2oflux + REAL :: sndepflux REAL :: totalcarbon,totalphos,totalsil,totalnitr,totaloxy REAL :: ppm2con, co2atm @@ -329,6 +330,7 @@ SUBROUTINE INVENTORY_BGC(kpie,kpje,kpke,dlxp,dlyp,ddpo,WETO & so2flux =0. sn2flux =0. sn2oflux =0. + sndepflux=0. zatmco2 =0. zatmo2 =0. zatmn2 =0. @@ -340,6 +342,7 @@ SUBROUTINE INVENTORY_BGC(kpie,kpje,kpke,dlxp,dlyp,ddpo,WETO & so2flux =so2flux +bgct2d(i,j,jo2flux) *dlxp(i,j)*dlyp(i,j) sn2flux =sn2flux +bgct2d(i,j,jn2flux) *dlxp(i,j)*dlyp(i,j) sn2oflux=sn2oflux+bgct2d(i,j,jn2oflux)*dlxp(i,j)*dlyp(i,j) + sndepflux=sndepflux+bgct2d(i,j,jndep)*dlxp(i,j)*dlyp(i,j) ztotarea = ztotarea + dlxp(i,j)*dlyp(i,j) zatmco2 =zatmco2 + atm(i,j,iatmco2)*dlxp(i,j)*dlyp(i,j) #if defined(BOXATM) @@ -383,6 +386,15 @@ SUBROUTINE INVENTORY_BGC(kpie,kpje,kpke,dlxp,dlyp,ddpo,WETO & ENDDO ENDDO CALL xcsum(sn2oflux,ztmp1,ips) + + ztmp1(:,:)=0.0 + DO j=1,kpje + DO i=1,kpie + ztmp1(i,j) = ndepflx(i,j)*dlxp(i,j)*dlyp(i,j) + ENDDO + ENDDO + CALL xcsum(sndepflux,ztmp1,ips) + ELSE ztmp1(:,:)=0.0 DO j=1,kpje @@ -401,6 +413,16 @@ SUBROUTINE INVENTORY_BGC(kpie,kpje,kpke,dlxp,dlyp,ddpo,WETO & ENDDO CALL xcsum(sn2oflux,ztmp1,ips) + + ztmp1(:,:)=0.0 + DO j=1,kpje + DO i=1,kpie + ztmp1(i,j) = bgct2d(i,j,jndep)*dlxp(i,j)*dlyp(i,j) + ENDDO + ENDDO + CALL xcsum(sndepflux,ztmp1,ips) + + ENDIF ! single column ztmp1(:,:)=0.0 @@ -447,6 +469,7 @@ SUBROUTINE INVENTORY_BGC(kpie,kpje,kpke,dlxp,dlyp,ddpo,WETO & WRITE(io_stdo_bgc,*) 'O2 Flux :',so2flux WRITE(io_stdo_bgc,*) 'N2 Flux :',sn2flux WRITE(io_stdo_bgc,*) 'N2O Flux :',sn2oflux + WRITE(io_stdo_bgc,*) 'NdepFlux :',sndepflux #if defined(BOXATM) ! WRITE(io_stdo_bgc,*) 'global atm. CO2[ppm] / kmol: ', & ! & zatmco2/ztotarea,zatmco2*ppm2con @@ -525,10 +548,11 @@ SUBROUTINE INVENTORY_BGC(kpie,kpje,kpke,dlxp,dlyp,ddpo,WETO & & +zocetrato(ian2o)*2 & & +zprorca*rnit & #if defined(BOXATM) - & +zatmn2*ppm2con*2 + & +zatmn2*ppm2con*2 & #else - & +sn2flux*2+sn2oflux*2 + & +sn2flux*2+sn2oflux*2 & #endif + & - sndepflux totalphos= & & zocetrato(idet)+zocetrato(idoc)+zocetrato(iphy) & @@ -556,10 +580,11 @@ SUBROUTINE INVENTORY_BGC(kpie,kpje,kpke,dlxp,dlyp,ddpo,WETO & & +zpowtrato(ipowaox)+zpowtrato(ipowaph)*2 & & +zprorca*(-24.)+zprcaca & #if defined(BOXATM) - & +zatmo2*ppm2con+zatmco2*ppm2con + & +zatmo2*ppm2con+zatmco2*ppm2con & #else - & +so2flux+sn2oflux*0.5+co2flux + & +so2flux+sn2oflux*0.5+co2flux & #endif + & - sndepflux*1.5 IF (mnproc.eq.1) THEN ! WRITE(io_stdo_bgc,*) ' ' diff --git a/hamocc/mo_bgcmean.F90 b/hamocc/mo_bgcmean.F90 index 05de11d3..cfebb2a3 100644 --- a/hamocc/mo_bgcmean.F90 +++ b/hamocc/mo_bgcmean.F90 @@ -226,7 +226,8 @@ MODULE mo_bgcmean & jprcaca =7, & & jsilpro =8, & & jprodus =9, & - & nbgct2d =9 + & jndep =10, & + & nbgct2d =10 !---------------------------------------------------------------- INTEGER, SAVE :: i_bsc_m2d diff --git a/hamocc/mo_carbch.F90 b/hamocc/mo_carbch.F90 index 2e69a7b7..c6b415d7 100644 --- a/hamocc/mo_carbch.F90 +++ b/hamocc/mo_carbch.F90 @@ -58,6 +58,7 @@ MODULE mo_carbch REAL, DIMENSION (:,:,:,:), ALLOCATABLE :: ocetra REAL, DIMENSION (:,:,:), ALLOCATABLE :: atm REAL, DIMENSION (:,:,:), ALLOCATABLE :: atmflx + REAL, DIMENSION (:,:), ALLOCATABLE :: ndepflx REAL, DIMENSION (:,:,:), ALLOCATABLE :: co3 REAL, DIMENSION (:,:,:), ALLOCATABLE :: co2star REAL, DIMENSION (:,:,:), ALLOCATABLE :: hi @@ -312,6 +313,16 @@ SUBROUTINE ALLOC_MEM_CARBCH(kpie,kpje,kpke) if(errstat.ne.0) stop 'not enough memory atmflx' atmflx(:,:,:) = 0.0 + IF (mnproc.eq.1) THEN + WRITE(io_stdo_bgc,*)'Memory allocation for variable ndepflx ...' + WRITE(io_stdo_bgc,*)'First dimension : ',kpie + WRITE(io_stdo_bgc,*)'Second dimension : ',kpje + !WRITE(io_stdo_bgc,*)'Third dimension : ',natm + ENDIF + + ALLOCATE (ndepflx(kpie,kpje),stat=errstat) + if(errstat.ne.0) stop 'not enough memory ndepflx' + ndepflx(:,:) = 0.0 IF (mnproc.eq.1) THEN WRITE(io_stdo_bgc,*)'Memory allocation for variable pco2d ...' diff --git a/hamocc/mo_ndep.F90 b/hamocc/mo_ndep.F90 index 1ceea0a6..cb120d89 100644 --- a/hamocc/mo_ndep.F90 +++ b/hamocc/mo_ndep.F90 @@ -257,7 +257,7 @@ subroutine n_deposition(kpie,kpje,kpke,pddpo,omask,ndep) !****************************************************************************** use mod_xc, only: mnproc use mo_control_bgc, only: io_stdo_bgc,dtb,do_ndep - use mo_carbch, only: ocetra + use mo_carbch, only: ocetra,ndepflx use mo_param1_bgc, only: iano3,ialkali,inatalkali implicit none @@ -273,13 +273,15 @@ subroutine n_deposition(kpie,kpje,kpke,pddpo,omask,ndep) if (.not. do_ndep) return ! deposite N in topmost layer + ndepflx=0. do j=1,kpje do i=1,kpie if (omask(i,j).gt.0.5) then - ocetra(i,j,1,iano3)=ocetra(i,j,1,iano3)+ndep(i,j)*dtb/365./pddpo(i,j,1) - ocetra(i,j,1,ialkali)=ocetra(i,j,1,ialkali)-ndep(i,j)*dtb/365./pddpo(i,j,1) + ndepflx(i,j) = ndep(i,j)*dtb/365. + ocetra(i,j,1,iano3)=ocetra(i,j,1,iano3)+ndepflx(i,j)/pddpo(i,j,1) + ocetra(i,j,1,ialkali)=ocetra(i,j,1,ialkali)-ndepflx(i,j)/pddpo(i,j,1) #ifdef natDIC - ocetra(i,j,1,inatalkali)=ocetra(i,j,1,inatalkali)-ndep(i,j)*dtb/365./pddpo(i,j,1) + ocetra(i,j,1,inatalkali)=ocetra(i,j,1,inatalkali)-ndepflx(i,j)/pddpo(i,j,1) #endif endif enddo From 3148db683d350100ea27c43124fc417f134bc9af Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Thu, 3 Mar 2022 13:26:35 +0100 Subject: [PATCH 042/366] Add inventory tracking for riverine fluxes --- hamocc/accfields.F90 | 9 ++++++ hamocc/inventory_bgc.F90 | 61 ++++++++++++++++++++++++++++++++++------ hamocc/mo_bgcmean.F90 | 11 +++++++- hamocc/mo_riverinpt.F90 | 27 ++++++++++++++++-- 4 files changed, 97 insertions(+), 11 deletions(-) diff --git a/hamocc/accfields.F90 b/hamocc/accfields.F90 index 4fa57272..b0e11104 100644 --- a/hamocc/accfields.F90 +++ b/hamocc/accfields.F90 @@ -52,6 +52,7 @@ SUBROUTINE ACCFIELDS(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask) use mo_param1_bgc use mo_vgrid, only: dp_min use mod_xc + use mo_riverinpt, only: irdin,irdip,irsi,iralk,iriron,irdoc,irdet,rivinflx use mod_config, only: expcnf implicit none INTEGER :: kpie,kpje,kpke @@ -104,6 +105,13 @@ SUBROUTINE ACCFIELDS(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask) bgct2d(i,j,jn2flux) = bgct2d(i,j,jn2flux) + atmflx(i,j,iatmn2)/2.0 bgct2d(i,j,jn2oflux) = bgct2d(i,j,jn2oflux) + atmflx(i,j,iatmn2o)/2.0 bgct2d(i,j,jndep) = bgct2d(i,j,jndep) + ndepflx(i,j)/2.0 + bgct2d(i,j,jirdin) = bgct2d(i,j,jirdin) + rivinflx(i,j,irdin)/2.0 + bgct2d(i,j,jirdip) = bgct2d(i,j,jirdip) + rivinflx(i,j,irdip)/2.0 + bgct2d(i,j,jirsi) = bgct2d(i,j,jirsi) + rivinflx(i,j,irsi)/2.0 + bgct2d(i,j,jiralk) = bgct2d(i,j,jiralk) + rivinflx(i,j,iralk)/2.0 + bgct2d(i,j,jiriron) = bgct2d(i,j,jiriron) + rivinflx(i,j,iriron)/2.0 + bgct2d(i,j,jirdoc) = bgct2d(i,j,jirdoc) + rivinflx(i,j,irdoc)/2.0 + bgct2d(i,j,jirdet) = bgct2d(i,j,jirdet) + rivinflx(i,j,irdet)/2.0 endif enddo @@ -387,5 +395,6 @@ SUBROUTINE ACCFIELDS(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask) ENDIF atmflx(:,:,:)=0. ! nullifying atm flux here to have zero fluxes for stepwise inventory fluxes ndepflx=0. + rivinflx=0. RETURN END diff --git a/hamocc/inventory_bgc.F90 b/hamocc/inventory_bgc.F90 index 7bb361cf..1aee220a 100644 --- a/hamocc/inventory_bgc.F90 +++ b/hamocc/inventory_bgc.F90 @@ -62,6 +62,8 @@ SUBROUTINE INVENTORY_BGC(kpie,kpje,kpke,dlxp,dlyp,ddpo,WETO & USE mod_xc !jm USE mod_config, only: expcnf + USE mo_riverinpt, only: rivinflx,irdin,irdip,irsi,iralk,iriron,& + & irdoc,irdet,nriv implicit none @@ -81,7 +83,8 @@ SUBROUTINE INVENTORY_BGC(kpie,kpje,kpke,dlxp,dlyp,ddpo,WETO & REAL :: zhito,zco3to,sum,zprorca,zprcaca,zsilpro REAL :: zatmco2,zatmo2,zatmn2 REAL :: co2flux,so2flux,sn2flux,sn2oflux - REAL :: sndepflux + REAL :: srivflux(nriv) ! sum of riverfluxes + REAL :: sndepflux ! sum of N dep fluxes REAL :: totalcarbon,totalphos,totalsil,totalnitr,totaloxy REAL :: ppm2con, co2atm @@ -369,7 +372,7 @@ SUBROUTINE INVENTORY_BGC(kpie,kpje,kpke,dlxp,dlyp,ddpo,WETO & ENDDO CALL xcsum(so2flux,ztmp1,ips) -!jm + IF(expcnf.eq.'single_column') THEN ! enable time step wise cal of fluxes in single col mode ztmp1(:,:)=0.0 DO j=1,kpje @@ -394,8 +397,7 @@ SUBROUTINE INVENTORY_BGC(kpie,kpje,kpke,dlxp,dlyp,ddpo,WETO & ENDDO ENDDO CALL xcsum(sndepflux,ztmp1,ips) - - ELSE + ELSE ! accumulated fluxes ztmp1(:,:)=0.0 DO j=1,kpje DO i=1,kpie @@ -420,10 +422,9 @@ SUBROUTINE INVENTORY_BGC(kpie,kpje,kpke,dlxp,dlyp,ddpo,WETO & ztmp1(i,j) = bgct2d(i,j,jndep)*dlxp(i,j)*dlyp(i,j) ENDDO ENDDO - CALL xcsum(sndepflux,ztmp1,ips) - - ENDIF ! single column + CALL xcsum(sndepflux,ztmp1,ips) + ENDIF ! single column time step-wise check ztmp1(:,:)=0.0 DO j=1,kpje @@ -463,6 +464,30 @@ SUBROUTINE INVENTORY_BGC(kpie,kpje,kpke,dlxp,dlyp,ddpo,WETO & CALL xcsum(zatmn2,ztmp1,ips) #endif +!------------------------riverine fluxes + IF(expcnf.eq.'single_column') THEN + DO l=1,nriv + ztmp1(:,:)=0.0 + DO j=1,kpje + DO i=1,kpie + ztmp1(i,j) = rivinflx(i,j,l)*dlxp(i,j)*dlyp(i,j) + ENDDO + ENDDO + CALL xcsum(srivflux(l),ztmp1,ips) + ENDDO + ELSE + DO l=1,nriv + ztmp1(:,:)=0.0 + DO j=1,kpje + DO i=1,kpie + ztmp1(i,j) = bgct2d(i,j,jirdin+l-1)*dlxp(i,j)*dlyp(i,j) + ENDDO + ENDDO + CALL xcsum(srivflux(l),ztmp1,ips) + ENDDO + ENDIF ! single column + +!---------------------- fluxes summary IF (mnproc.eq.1) THEN WRITE(io_stdo_bgc,*) ' ' WRITE(io_stdo_bgc,*) 'CO2Flux :',co2flux @@ -470,6 +495,11 @@ SUBROUTINE INVENTORY_BGC(kpie,kpje,kpke,dlxp,dlyp,ddpo,WETO & WRITE(io_stdo_bgc,*) 'N2 Flux :',sn2flux WRITE(io_stdo_bgc,*) 'N2O Flux :',sn2oflux WRITE(io_stdo_bgc,*) 'NdepFlux :',sndepflux + WRITE(io_stdo_bgc,*) 'Riverine fluxes:' + DO l=1,nriv + WRITE(io_stdo_bgc,*) 'No. ',l,srivflux(l) + ENDDO + #if defined(BOXATM) ! WRITE(io_stdo_bgc,*) 'global atm. CO2[ppm] / kmol: ', & ! & zatmco2/ztotarea,zatmco2*ppm2con @@ -564,7 +594,7 @@ SUBROUTINE INVENTORY_BGC(kpie,kpje,kpke,dlxp,dlyp,ddpo,WETO & totalsil= & & zocetrato(isilica)+zocetrato(iopal) & & +zpowtrato(ipowasi)+zsedlayto(issssil)+zburial(issssil) & - & +zsilpro + & +zsilpro totaloxy= & & (zocetrato(idet)+zocetrato(idoc)+zocetrato(iphy) & @@ -586,6 +616,21 @@ SUBROUTINE INVENTORY_BGC(kpie,kpje,kpke,dlxp,dlyp,ddpo,WETO & #endif & - sndepflux*1.5 + IF (do_rivinpt) THEN + totalcarbon=totalcarbon-(srivflux(irdoc)+srivflux(irdet))*rcar& + & -(srivflux(iralk)+srivflux(irdin)+srivflux(irdip)) ! =sco212 + totalnitr=totalnitr-(srivflux(irdoc)+srivflux(irdet))*rnit & + & - srivflux(irdin) + totalphos = totalphos & + & -(srivflux(irdoc)+srivflux(irdet)+srivflux(irdip)) + totalsil = totalsil-srivflux(irsi) + totaloxy = totaloxy-(srivflux(irdoc)+srivflux(irdet))*(-24.) & + & - srivflux(irdin)*1.5 - srivflux(irdip)*2. + ENDIF + + + + IF (mnproc.eq.1) THEN ! WRITE(io_stdo_bgc,*) ' ' WRITE(io_stdo_bgc,*) 'Global total[kmol] of carbon : ', & diff --git a/hamocc/mo_bgcmean.F90 b/hamocc/mo_bgcmean.F90 index cfebb2a3..a9177a50 100644 --- a/hamocc/mo_bgcmean.F90 +++ b/hamocc/mo_bgcmean.F90 @@ -216,6 +216,8 @@ MODULE mo_bgcmean !---------------------------------------------------------------- ! declarations for inventory_bgc.F90 +! order and increments of river (jir...) indices require to be the same +! as in mo_riverinpt INTEGER, parameter :: & & jco2flux =1, & & jco214f =2, & @@ -227,7 +229,14 @@ MODULE mo_bgcmean & jsilpro =8, & & jprodus =9, & & jndep =10, & - & nbgct2d =10 + & jirdin =11, & + & jirdip =12, & + & jirsi =13, & + & jiralk =14, & + & jiriron =15, & + & jirdoc =16, & + & jirdet =17, & + & nbgct2d =17 !---------------------------------------------------------------- INTEGER, SAVE :: i_bsc_m2d diff --git a/hamocc/mo_riverinpt.F90 b/hamocc/mo_riverinpt.F90 index 65d49bad..c6a81b4c 100644 --- a/hamocc/mo_riverinpt.F90 +++ b/hamocc/mo_riverinpt.F90 @@ -66,7 +66,7 @@ module mo_riverinpt implicit none private -public :: ini_riverinpt,riverinpt,nriv,rivflx,rivinfile +public :: ini_riverinpt,riverinpt,nriv,rivflx,rivinfile,rivinflx public :: irdin,irdip,irsi,iralk,iriron,irdoc,irdet integer, parameter :: nriv = 7 ! size of river input field @@ -77,7 +77,8 @@ module mo_riverinpt iriron = 5, & ! dissolved bioavailable iron irdoc = 6, & ! dissolved organic carbon irdet = 7 ! particulate carbon -real,save,allocatable :: rivflx(:,:,:) +real,save,allocatable :: rivflx(:,:,:) ! holds raw input file +real,save,allocatable :: rivinflx(:,:,:) ! holds the fluxes per timestep for inventory calc ! File name (incl. full path) for input data, set through namelist ! in hamocc_init.F @@ -141,6 +142,20 @@ subroutine ini_riverinpt(kpie,kpje,omask) if(errstat.ne.0) stop 'not enough memory rivflx' rivflx(:,:,:) = 0.0 + ! Allocate field to hold riverine fluxes per timestep for inventory caluclations + IF (mnproc.eq.1) THEN + WRITE(io_stdo_bgc,*)'Memory allocation for variable rivinflx ...' + WRITE(io_stdo_bgc,*)'First dimension : ',kpie + WRITE(io_stdo_bgc,*)'Second dimension : ',kpje + WRITE(io_stdo_bgc,*)'Third dimension : ',nriv + ENDIF + + ALLOCATE (rivinflx(kpie,kpje,nriv),stat=errstat) + if(errstat.ne.0) stop 'not enough memory rivinflx' + rivinflx(:,:,:) = 0.0 + + + ! Return if riverine input is turned off if (.not. do_rivinpt) then if (mnproc.eq.1) then @@ -230,6 +245,7 @@ subroutine riverinpt(kpie,kpje,kpke,pddpo,omask,rivin) if (.not. do_rivinpt) return + rivinflx = 0. !$OMP PARALLEL DO PRIVATE(i,k,fdt,volij) DO j=1,kpje DO i=1,kpie @@ -266,6 +282,13 @@ subroutine riverinpt(kpie,kpje,kpke,pddpo,omask,rivin) ocetra(i,j,1:kmle,idoc) = ocetra(i,j,1:kmle,idoc) + rivin(i,j,irdoc)*fdt/volij ocetra(i,j,1:kmle,idet) = ocetra(i,j,1:kmle,idet) + rivin(i,j,irdet)*fdt/volij + rivinflx(i,j,irdin) = rivin(i,j,irdin)*fdt + rivinflx(i,j,irdip) = rivin(i,j,irdip)*fdt + rivinflx(i,j,irsi) = rivin(i,j,irsi)*fdt + rivinflx(i,j,iralk) = rivin(i,j,iralk)*fdt + rivinflx(i,j,iriron) = rivin(i,j,iriron)*fdt*0.01 + rivinflx(i,j,irdoc) = rivin(i,j,irdoc)*fdt + rivinflx(i,j,irdet) = rivin(i,j,irdet)*fdt ENDIF ENDDO ENDDO From 4837f9d6f1dd0dbce6cb531af9363fd11d14c8f7 Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Thu, 3 Mar 2022 15:12:09 +0100 Subject: [PATCH 043/366] Only calculate N and river flux sums in inventory, when switched on --- hamocc/inventory_bgc.F90 | 55 +++++++++++++++++++++------------------- 1 file changed, 29 insertions(+), 26 deletions(-) diff --git a/hamocc/inventory_bgc.F90 b/hamocc/inventory_bgc.F90 index 1aee220a..c5db482f 100644 --- a/hamocc/inventory_bgc.F90 +++ b/hamocc/inventory_bgc.F90 @@ -60,9 +60,8 @@ SUBROUTINE INVENTORY_BGC(kpie,kpje,kpke,dlxp,dlyp,ddpo,WETO & USE mo_param1_bgc use mo_vgrid, only: dp_min USE mod_xc -!jm USE mod_config, only: expcnf - USE mo_riverinpt, only: rivinflx,irdin,irdip,irsi,iralk,iriron,& + USE mo_riverinpt, only: rivinflx,irdin,irdip,irsi,iralk, & & irdoc,irdet,nriv implicit none @@ -334,6 +333,7 @@ SUBROUTINE INVENTORY_BGC(kpie,kpje,kpke,dlxp,dlyp,ddpo,WETO & sn2flux =0. sn2oflux =0. sndepflux=0. + srivflux =0. zatmco2 =0. zatmo2 =0. zatmn2 =0. @@ -345,7 +345,6 @@ SUBROUTINE INVENTORY_BGC(kpie,kpje,kpke,dlxp,dlyp,ddpo,WETO & so2flux =so2flux +bgct2d(i,j,jo2flux) *dlxp(i,j)*dlyp(i,j) sn2flux =sn2flux +bgct2d(i,j,jn2flux) *dlxp(i,j)*dlyp(i,j) sn2oflux=sn2oflux+bgct2d(i,j,jn2oflux)*dlxp(i,j)*dlyp(i,j) - sndepflux=sndepflux+bgct2d(i,j,jndep)*dlxp(i,j)*dlyp(i,j) ztotarea = ztotarea + dlxp(i,j)*dlyp(i,j) zatmco2 =zatmco2 + atm(i,j,iatmco2)*dlxp(i,j)*dlyp(i,j) #if defined(BOXATM) @@ -389,14 +388,15 @@ SUBROUTINE INVENTORY_BGC(kpie,kpje,kpke,dlxp,dlyp,ddpo,WETO & ENDDO ENDDO CALL xcsum(sn2oflux,ztmp1,ips) - - ztmp1(:,:)=0.0 - DO j=1,kpje - DO i=1,kpie - ztmp1(i,j) = ndepflx(i,j)*dlxp(i,j)*dlyp(i,j) + IF(do_ndep)THEN + ztmp1(:,:)=0.0 + DO j=1,kpje + DO i=1,kpie + ztmp1(i,j) = ndepflx(i,j)*dlxp(i,j)*dlyp(i,j) + ENDDO ENDDO - ENDDO - CALL xcsum(sndepflux,ztmp1,ips) + CALL xcsum(sndepflux,ztmp1,ips) + ENDIF ELSE ! accumulated fluxes ztmp1(:,:)=0.0 DO j=1,kpje @@ -415,15 +415,15 @@ SUBROUTINE INVENTORY_BGC(kpie,kpje,kpke,dlxp,dlyp,ddpo,WETO & ENDDO CALL xcsum(sn2oflux,ztmp1,ips) - - ztmp1(:,:)=0.0 - DO j=1,kpje - DO i=1,kpie - ztmp1(i,j) = bgct2d(i,j,jndep)*dlxp(i,j)*dlyp(i,j) - ENDDO - ENDDO - - CALL xcsum(sndepflux,ztmp1,ips) + IF(do_ndep)THEN + ztmp1(:,:)=0.0 + DO j=1,kpje + DO i=1,kpie + ztmp1(i,j) = bgct2d(i,j,jndep)*dlxp(i,j)*dlyp(i,j) + ENDDO + ENDDO + CALL xcsum(sndepflux,ztmp1,ips) + ENDIF ENDIF ! single column time step-wise check ztmp1(:,:)=0.0 @@ -464,7 +464,8 @@ SUBROUTINE INVENTORY_BGC(kpie,kpje,kpke,dlxp,dlyp,ddpo,WETO & CALL xcsum(zatmn2,ztmp1,ips) #endif -!------------------------riverine fluxes +!------------------------riverine fluxes + IF(do_rivinpt)THEN IF(expcnf.eq.'single_column') THEN DO l=1,nriv ztmp1(:,:)=0.0 @@ -486,7 +487,7 @@ SUBROUTINE INVENTORY_BGC(kpie,kpje,kpke,dlxp,dlyp,ddpo,WETO & CALL xcsum(srivflux(l),ztmp1,ips) ENDDO ENDIF ! single column - + ENDIF !---------------------- fluxes summary IF (mnproc.eq.1) THEN WRITE(io_stdo_bgc,*) ' ' @@ -494,11 +495,13 @@ SUBROUTINE INVENTORY_BGC(kpie,kpje,kpke,dlxp,dlyp,ddpo,WETO & WRITE(io_stdo_bgc,*) 'O2 Flux :',so2flux WRITE(io_stdo_bgc,*) 'N2 Flux :',sn2flux WRITE(io_stdo_bgc,*) 'N2O Flux :',sn2oflux - WRITE(io_stdo_bgc,*) 'NdepFlux :',sndepflux - WRITE(io_stdo_bgc,*) 'Riverine fluxes:' - DO l=1,nriv + IF(do_ndep) WRITE(io_stdo_bgc,*) 'NdepFlux :',sndepflux + IF(do_rivinpt)THEN + WRITE(io_stdo_bgc,*) 'Riverine fluxes:' + DO l=1,nriv WRITE(io_stdo_bgc,*) 'No. ',l,srivflux(l) - ENDDO + ENDDO + ENDIF #if defined(BOXATM) ! WRITE(io_stdo_bgc,*) 'global atm. CO2[ppm] / kmol: ', & @@ -594,7 +597,7 @@ SUBROUTINE INVENTORY_BGC(kpie,kpje,kpke,dlxp,dlyp,ddpo,WETO & totalsil= & & zocetrato(isilica)+zocetrato(iopal) & & +zpowtrato(ipowasi)+zsedlayto(issssil)+zburial(issssil) & - & +zsilpro + & +zsilpro totaloxy= & & (zocetrato(idet)+zocetrato(idoc)+zocetrato(iphy) & From b7fbfa1e505db945b3975706e0153afbe924cb32 Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Thu, 3 Mar 2022 19:01:42 +0100 Subject: [PATCH 044/366] Enabling setting of pre-processor flags for debugging of iHAMOCC via meson --- meson.build | 9 +++++++++ meson_options.txt | 8 ++++++++ 2 files changed, 17 insertions(+) diff --git a/meson.build b/meson.build index 66454658..4b79253e 100644 --- a/meson.build +++ b/meson.build @@ -121,6 +121,15 @@ if get_option('ecosys') if get_option('hamocc_extNcycle') add_project_arguments('-DextNcycle', language: 'fortran') endif + if get_option('hamocc_debug_timestep') + add_project_arguments('-DPBGC_OCNP_TIMESTEP','-DPBGC_CK_TIMESTEP', language: 'fortran') + endif + if get_option('hamocc_pbgc_ocnp_timestep') + add_project_arguments('-DPBGC_OCNP_TIMESTEP', language: 'fortran') + endif + if get_option('hamocc_pbgc_ck_timestep') + add_project_arguments('-DPBGC_CK_TIMESTEP', language: 'fortran') + endif subdir('hamocc') endif diff --git a/meson_options.txt b/meson_options.txt index bb81bc66..cd1162fe 100644 --- a/meson_options.txt +++ b/meson_options.txt @@ -27,6 +27,14 @@ option('hamocc_ciso', type: 'boolean', description: 'Enable carbon isotopes in HAMOCC', value: false) option('hamocc_extNcycle', type: 'boolean', description: 'Enable extended nitrogen cycle in HAMOCC', value: false) +#HAMOCC debugging options: +option('hamocc_debug_timestep', type: 'boolean', + description: 'Debug HAMOCC on timestep basis', value: false) +option('hamocc_pbgc_ocnp_timestep', type: 'boolean', + description: 'Debug HAMOCC only PBGC_OCNP_TIMESTEP', value: false) +option('hamocc_pbgc_ck_timestep', type: 'boolean', + description: 'Debug HAMOCC only PBGC_CK_TIMESTEP', value: false) +#---- option('levitus2x', type: 'boolean', description: 'Enable level diagnostics at double resolution of standard Levitus depths', value: true) # Build configuration From 1b4b06e58939674f9f953bf0f0e1caa4589d2e3b Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Thu, 3 Mar 2022 19:03:17 +0100 Subject: [PATCH 045/366] importing missing mnproc for debugging in ocprod --- hamocc/ocprod.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/hamocc/ocprod.F90 b/hamocc/ocprod.F90 index bda46fdb..cb10497a 100644 --- a/hamocc/ocprod.F90 +++ b/hamocc/ocprod.F90 @@ -88,7 +88,7 @@ subroutine ocprod(kpie,kpje,kpke,kbnd,pdlxp,pdlyp,pddpo,omask,dust,ptho) use mo_control_bgc use mo_vgrid use mo_clim_swa - + use mod_xc, only: mnproc implicit none integer, intent(in) :: kpie,kpje,kpke,kbnd From 71bd0cfce857b2a1a7f21100a4643c8478571c41 Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Fri, 4 Mar 2022 11:08:01 +0100 Subject: [PATCH 046/366] Fixing carbon inventory, enable time step-wise inventory tracking in single column mode also for carbon and oxygen --- hamocc/inventory_bgc.F90 | 95 +++++++++++++++++++++++----------------- 1 file changed, 56 insertions(+), 39 deletions(-) diff --git a/hamocc/inventory_bgc.F90 b/hamocc/inventory_bgc.F90 index c5db482f..f3a8da69 100644 --- a/hamocc/inventory_bgc.F90 +++ b/hamocc/inventory_bgc.F90 @@ -354,25 +354,24 @@ SUBROUTINE INVENTORY_BGC(kpie,kpje,kpke,dlxp,dlyp,ddpo,WETO & enddo enddo - ztmp1(:,:)=0.0 - DO j=1,kpje - DO i=1,kpie - ztmp1(i,j) = bgct2d(i,j,jco2flux)*dlxp(i,j)*dlyp(i,j) - ENDDO - ENDDO - CALL xcsum(co2flux,ztmp1,ips) - - ztmp1(:,:)=0.0 - DO j=1,kpje - DO i=1,kpie - ztmp1(i,j) = bgct2d(i,j,jo2flux)*dlxp(i,j)*dlyp(i,j) - ENDDO - ENDDO + IF(expcnf.eq.'single_column') THEN ! enable time step wise cal of fluxes in single col mode + ztmp1(:,:)=0.0 + DO j=1,kpje + DO i=1,kpie + ztmp1(i,j) = atmflx(i,j,iatmco2)*dlxp(i,j)*dlyp(i,j) + ENDDO + ENDDO + CALL xcsum(co2flux,ztmp1,ips) - CALL xcsum(so2flux,ztmp1,ips) + ztmp1(:,:)=0.0 + DO j=1,kpje + DO i=1,kpie + ztmp1(i,j) = atmflx(i,j,iatmo2)*dlxp(i,j)*dlyp(i,j) + ENDDO + ENDDO + CALL xcsum(so2flux,ztmp1,ips) - IF(expcnf.eq.'single_column') THEN ! enable time step wise cal of fluxes in single col mode ztmp1(:,:)=0.0 DO j=1,kpje DO i=1,kpie @@ -398,32 +397,50 @@ SUBROUTINE INVENTORY_BGC(kpie,kpje,kpke,dlxp,dlyp,ddpo,WETO & CALL xcsum(sndepflux,ztmp1,ips) ENDIF ELSE ! accumulated fluxes - ztmp1(:,:)=0.0 - DO j=1,kpje - DO i=1,kpie - ztmp1(i,j) = bgct2d(i,j,jn2flux)*dlxp(i,j)*dlyp(i,j) - ENDDO - ENDDO + ztmp1(:,:)=0.0 + DO j=1,kpje + DO i=1,kpie + ztmp1(i,j) = bgct2d(i,j,jco2flux)*dlxp(i,j)*dlyp(i,j) + ENDDO + ENDDO - CALL xcsum(sn2flux,ztmp1,ips) + CALL xcsum(co2flux,ztmp1,ips) - ztmp1(:,:)=0.0 - DO j=1,kpje - DO i=1,kpie - ztmp1(i,j) = bgct2d(i,j,jn2oflux)*dlxp(i,j)*dlyp(i,j) - ENDDO - ENDDO + ztmp1(:,:)=0.0 + DO j=1,kpje + DO i=1,kpie + ztmp1(i,j) = bgct2d(i,j,jo2flux)*dlxp(i,j)*dlyp(i,j) + ENDDO + ENDDO - CALL xcsum(sn2oflux,ztmp1,ips) - IF(do_ndep)THEN - ztmp1(:,:)=0.0 - DO j=1,kpje - DO i=1,kpie - ztmp1(i,j) = bgct2d(i,j,jndep)*dlxp(i,j)*dlyp(i,j) + CALL xcsum(so2flux,ztmp1,ips) + + ztmp1(:,:)=0.0 + DO j=1,kpje + DO i=1,kpie + ztmp1(i,j) = bgct2d(i,j,jn2flux)*dlxp(i,j)*dlyp(i,j) + ENDDO ENDDO - ENDDO - CALL xcsum(sndepflux,ztmp1,ips) - ENDIF + + CALL xcsum(sn2flux,ztmp1,ips) + + ztmp1(:,:)=0.0 + DO j=1,kpje + DO i=1,kpie + ztmp1(i,j) = bgct2d(i,j,jn2oflux)*dlxp(i,j)*dlyp(i,j) + ENDDO + ENDDO + + CALL xcsum(sn2oflux,ztmp1,ips) + IF(do_ndep)THEN + ztmp1(:,:)=0.0 + DO j=1,kpje + DO i=1,kpie + ztmp1(i,j) = bgct2d(i,j,jndep)*dlxp(i,j)*dlyp(i,j) + ENDDO + ENDDO + CALL xcsum(sndepflux,ztmp1,ips) + ENDIF ENDIF ! single column time step-wise check ztmp1(:,:)=0.0 @@ -568,7 +585,7 @@ SUBROUTINE INVENTORY_BGC(kpie,kpje,kpke,dlxp,dlyp,ddpo,WETO & & +zocetrato(izoo))*rcar+zocetrato(isco212)+zocetrato(icalc) & & +zpowtrato(ipowaic)+zsedlayto(isssc12)+zsedlayto(issso12)*rcar & & +zburial(isssc12)+zburial(issso12)*rcar+zprorca*rcar+zprcaca & - & +zatmco2*ppm2con + & +zatmco2*ppm2con + co2flux totalnitr= & & (zocetrato(idet)+zocetrato(idoc)+zocetrato(iphy) & From d1d8791850054a9cb2a06ebaba76e5bbadf84e51 Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Fri, 4 Mar 2022 14:44:35 +0100 Subject: [PATCH 047/366] Fixed oxygen inventory; up to date with tagged single_column_inventory branch at tag checked_inventory --- hamocc/accfields.F90 | 3 +-- hamocc/hamocc4bcm.F90 | 16 ++++++++++++++++ hamocc/inventory_bgc.F90 | 3 ++- 3 files changed, 19 insertions(+), 3 deletions(-) diff --git a/hamocc/accfields.F90 b/hamocc/accfields.F90 index b0e11104..47103e1d 100644 --- a/hamocc/accfields.F90 +++ b/hamocc/accfields.F90 @@ -385,7 +385,6 @@ SUBROUTINE ACCFIELDS(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask) endif ENDDO -! jm IF(expcnf.eq.'single_column') THEN IF (mnproc.eq.1) THEN WRITE(io_stdo_bgc,*)' ' @@ -393,7 +392,7 @@ SUBROUTINE ACCFIELDS(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask) ENDIF CALL INVENTORY_BGC(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask,0) ENDIF - atmflx(:,:,:)=0. ! nullifying atm flux here to have zero fluxes for stepwise inventory fluxes + atmflx=0. ! nullifying atm flux here to have zero fluxes for stepwise inventory fluxes ndepflx=0. rivinflx=0. RETURN diff --git a/hamocc/hamocc4bcm.F90 b/hamocc/hamocc4bcm.F90 index d749c492..36c755b7 100644 --- a/hamocc/hamocc4bcm.F90 +++ b/hamocc/hamocc4bcm.F90 @@ -275,9 +275,25 @@ SUBROUTINE HAMOCC4BCM(kpie,kpje,kpke,kbnd,kplyear,kplmon,kplday,kldtday,& ! Apply n-deposition CALL n_deposition(kpie,kpje,kpke,pddpo,omask,ndep) +#ifdef PBGC_CK_TIMESTEP + IF (mnproc.eq.1) THEN + WRITE(io_stdo_bgc,*)' ' + WRITE(io_stdo_bgc,*)'after N deposition: call INVENTORY' + ENDIF + CALL INVENTORY_BGC(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask,0) +#endif + ! Apply riverine input of carbon and nutrients call riverinpt(kpie,kpje,kpke,pddpo,omask,rivin) +#ifdef PBGC_CK_TIMESTEP + IF (mnproc.eq.1) THEN + WRITE(io_stdo_bgc,*)' ' + WRITE(io_stdo_bgc,*)'after river input: call INVENTORY' + ENDIF + CALL INVENTORY_BGC(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask,0) +#endif + ! Update atmospheric pCO2 [ppm] #if defined(BOXATM) CALL update_boxatm(kpie,kpje,pdlxp,pdlyp) diff --git a/hamocc/inventory_bgc.F90 b/hamocc/inventory_bgc.F90 index f3a8da69..9d4b8494 100644 --- a/hamocc/inventory_bgc.F90 +++ b/hamocc/inventory_bgc.F90 @@ -645,7 +645,8 @@ SUBROUTINE INVENTORY_BGC(kpie,kpje,kpke,dlxp,dlyp,ddpo,WETO & & -(srivflux(irdoc)+srivflux(irdet)+srivflux(irdip)) totalsil = totalsil-srivflux(irsi) totaloxy = totaloxy-(srivflux(irdoc)+srivflux(irdet))*(-24.) & - & - srivflux(irdin)*1.5 - srivflux(irdip)*2. + & - srivflux(irdin)*1.5 - srivflux(irdip)*2. & + & -(srivflux(iralk)+srivflux(irdin)+srivflux(irdip)) ! =sco212 ENDIF From 43158f8a8ea5c1df712c26e182aa52dbdee5df37 Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Mon, 28 Mar 2022 18:56:40 +0200 Subject: [PATCH 048/366] cyano: adopted bluefix approach for extended nitrogen cycle --- hamocc/cyano.F90 | 56 +++++++++++++++++++++++++++++++----------------- 1 file changed, 36 insertions(+), 20 deletions(-) diff --git a/hamocc/cyano.F90 b/hamocc/cyano.F90 index 71258126..2da3715a 100644 --- a/hamocc/cyano.F90 +++ b/hamocc/cyano.F90 @@ -67,7 +67,7 @@ SUBROUTINE CYANO(kpie,kpje,kpke,kbnd,pddpo,omask,ptho) use mo_vgrid, only: kmle implicit none - + INTEGER, intent(in) :: kpie,kpje,kpke,kbnd REAL, intent(in) :: pddpo(kpie,kpje,kpke) REAL, intent(in) :: omask(kpie,kpje) @@ -75,48 +75,64 @@ SUBROUTINE CYANO(kpie,kpje,kpke,kbnd,pddpo,omask,ptho) ! Local variables INTEGER :: i,j,k - REAL :: oldocetra,dano3 + REAL :: oldocetra,anavail,dansp,dox,dalk REAL :: ttemp,nfixtfac intnfix(:,:)=0.0 ! -! N-fixation by cyano bacteria (followed by remineralisation and nitrification), +! N-fixation by cyano bacteria (followed by remineralisation and nitrification, +! or, for the extended nitrogen cycle only by remin to NH4), ! it is assumed here that this process is limited to the mixed layer ! DO k=1,kmle -!$OMP PARALLEL DO PRIVATE(i,oldocetra,dano3,ttemp,nfixtfac) +!$OMP PARALLEL DO PRIVATE(i,oldocetra,dansp,anavail,dox,dalk,ttemp,nfixtfac) DO j=1,kpje DO i=1,kpie IF(omask(i,j).gt.0.5) THEN - IF(ocetra(i,j,k,iano3).LT.(rnit*ocetra(i,j,k,iphosph))) THEN +#ifdef extNcycle + ! assuming nitrate and ammonium required for cyanobacteria growth (as bulk PP) + anavail = ocetra(i,j,k,iano3)+ocetra(i,j,k,ianh4) +#else + anavail = ocetra(i,j,k,iano3) +#endif + IF(anavail.LT.(rnit*ocetra(i,j,k,iphosph))) THEN - oldocetra = ocetra(i,j,k,iano3) ttemp = min(40.,max(-3.,ptho(i,j,k))) -! Temperature dependence of nitrogen fixation, Kriest and Oschlies 2015. + ! Temperature dependence of nitrogen fixation, Kriest and Oschlies 2015. nfixtfac = MAX(0.0,tf2*ttemp*ttemp + tf1*ttemp + tf0)/tff - ocetra(i,j,k,iano3)=ocetra(i,j,k,iano3)*(1-bluefix*nfixtfac) & +#ifndef extNcycle + oldocetra = ocetra(i,j,k,iano3) + ocetra(i,j,k,iano3)=ocetra(i,j,k,iano3)*(1.-bluefix*nfixtfac) & & +bluefix*nfixtfac*rnit*ocetra(i,j,k,iphosph) + dansp=ocetra(i,j,k,iano3)-oldocetra + ! Note: to fix one mole N2 requires: N2+H2O+y*O2 = 2* HNO3 <-> y=2.5 mole O2. + ! I.e., to release one mole HNO3 = H+ + NO3- requires 1.25 mole O2 + dox = -dansp*1.25 + ! Nitrogen fixation followed by remineralisation and nitrification decreases + ! alkalinity by 1 mole per mole nitrogen fixed (Wolf-Gladrow et al. 2007) + dalk = -dansp +#else + oldocetra = ocetra(i,j,k,ianh4) + ocetra(i,j,k,ianh4)=ocetra(i,j,k,ianh4)*(1.-bluefix*nfixtfac) & + & +bluefix*nfixtfac*rnit*ocetra(i,j,k,iphosph) + dansp=ocetra(i,j,k,ianh4)-oldocetra + dox = dansp*0.75 + dalk = dansp - dano3=ocetra(i,j,k,iano3)-oldocetra - - ocetra(i,j,k,igasnit)=ocetra(i,j,k,igasnit)-dano3*(1./2.) +#endif + ocetra(i,j,k,igasnit)=ocetra(i,j,k,igasnit)-dansp*(1./2.) -! Note: to fix one mole N2 requires: N2+H2O+y*O2 = 2* HNO3 <-> y=2.5 mole O2. -! I.e., to release one mole HNO3 = H+ + NO3- requires 1.25 mole O2 - ocetra(i,j,k,ioxygen)=ocetra(i,j,k,ioxygen)-dano3*1.25 + ocetra(i,j,k,ioxygen)=ocetra(i,j,k,ioxygen)+dox -! Nitrogen fixation followed by remineralisation and nitrification decreases -! alkalinity by 1 mole per mole nitrogen fixed (Wolf-Gladrow et al. 2007) - ocetra(i,j,k,ialkali)=ocetra(i,j,k,ialkali)-dano3 + ocetra(i,j,k,ialkali)=ocetra(i,j,k,ialkali)+dalk #ifdef natDIC - ocetra(i,j,k,inatalkali)=ocetra(i,j,k,inatalkali)-dano3 + ocetra(i,j,k,inatalkali)=ocetra(i,j,k,inatalkali)+dalk #endif - intnfix(i,j) = intnfix(i,j) + & - & (ocetra(i,j,k,iano3)-oldocetra)*pddpo(i,j,k) + intnfix(i,j) = intnfix(i,j) + dansp*pddpo(i,j,k) ENDIF ENDIF From 1103bbe63f29230bfa5ae4165af67c2ad7f12e87 Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Fri, 8 Apr 2022 15:04:00 +0200 Subject: [PATCH 049/366] Fix variable name for global sum in extNcycle inventory --- hamocc/inventory_bgc.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/hamocc/inventory_bgc.F90 b/hamocc/inventory_bgc.F90 index 8eb90979..461fee04 100644 --- a/hamocc/inventory_bgc.F90 +++ b/hamocc/inventory_bgc.F90 @@ -363,7 +363,7 @@ SUBROUTINE INVENTORY_BGC(kpie,kpje,kpke,dlxp,dlyp,ddpo,omask,iogrp) & +zocetratot(ian2o)*2 & & - sndepflux & #ifdef extNcycle - & +zocetrato(ianh4)+zocetrato(iano2) & + & +zocetratot(ianh4)+zocetratot(iano2) & #endif #if defined(BOXATM) & +zatmn2*ppm2con*2 @@ -392,7 +392,7 @@ SUBROUTINE INVENTORY_BGC(kpie,kpje,kpke,dlxp,dlyp,ddpo,omask,iogrp) & +zpowtratot(ipowaox)+zpowtratot(ipowaph)*2 & & - sndepflux*1.5 & #ifdef extNcycle - & +zocetrato(iano2) & + & +zocetratot(iano2) & #endif #if defined(BOXATM) & +zatmo2*ppm2con+zatmco2*ppm2con From f0c8d6d24cea2a424f23234972e817f389a74a37 Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Fri, 8 Apr 2022 15:48:09 +0200 Subject: [PATCH 050/366] Insert missing expl. use statements for NH4 and NO2 for extNcycle --- hamocc/aufr_bgc.F90 | 3 +++ hamocc/aufw_bgc.F90 | 3 +++ hamocc/cyano.F90 | 3 +++ hamocc/inventory_bgc.F90 | 3 +++ 4 files changed, 12 insertions(+) diff --git a/hamocc/aufr_bgc.F90 b/hamocc/aufr_bgc.F90 index b1a6157d..6a342c01 100644 --- a/hamocc/aufr_bgc.F90 +++ b/hamocc/aufr_bgc.F90 @@ -137,6 +137,9 @@ SUBROUTINE AUFR_BGC(kpie,kpje,kpke,ntr,ntrbgc,itrbgc,trc, & #ifndef sedbypass use mo_param1_bgc, only: ipowaal,ipowaic,ipowaox,ipowaph,ipowasi,ipown2,ipowno3,isssc12,issso12,issssil,issster,ks #endif +#ifdef extNcycle + use mo_param1_bgc, only: ianh4,iano2 +#endif implicit none diff --git a/hamocc/aufw_bgc.F90 b/hamocc/aufw_bgc.F90 index 7c681418..f04b7bf0 100644 --- a/hamocc/aufw_bgc.F90 +++ b/hamocc/aufw_bgc.F90 @@ -128,6 +128,9 @@ SUBROUTINE AUFW_BGC(kpie,kpje,kpke,ntr,ntrbgc,itrbgc,trc, & #ifndef sedbypass use mo_param1_bgc, only: ipowaal,ipowaic,ipowaox,ipowaph,ipowasi,ipown2,ipowno3,isssc12,issso12,issssil,issster #endif +#ifdef extNcycle + use mo_param1_bgc, only: ianh4,iano2 +#endif implicit none diff --git a/hamocc/cyano.F90 b/hamocc/cyano.F90 index b1571b76..0c0da5cc 100644 --- a/hamocc/cyano.F90 +++ b/hamocc/cyano.F90 @@ -68,6 +68,9 @@ SUBROUTINE CYANO(kpie,kpje,kpke,kbnd,pddpo,omask,ptho) #ifdef natDIC use mo_param1_bgc, only: inatalkali #endif +#ifdef extNcycle + use mo_param1_bgc, only: ianh4 +#endif implicit none diff --git a/hamocc/inventory_bgc.F90 b/hamocc/inventory_bgc.F90 index 12d743f7..a05960c0 100644 --- a/hamocc/inventory_bgc.F90 +++ b/hamocc/inventory_bgc.F90 @@ -70,6 +70,9 @@ SUBROUTINE INVENTORY_BGC(kpie,kpje,kpke,dlxp,dlyp,ddpo,omask,iogrp) use mo_param1_bgc, only: ks use mo_sedmnt, only: porwat,seddw,sedlay,burial,sedhpl,powtra,porsol #endif +#ifdef extNcycle + use mo_param1_bgc, only: ianh4,iano2 +#endif implicit none From d9778fba8976ef8aa200247c0729c69c4e08b2cc Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Fri, 8 Apr 2022 17:45:35 +0200 Subject: [PATCH 051/366] Introduce atmosphere field and mixing ratios for NH3 (and more variable N2O field for later coupling use) Thus far, atmospheric N2O concentration was fixed and hard-coded in the air-sea fluxes, in the extNcycle, we will make use of the allocated atm and atmflx fields for iatmn2o (and iatmnh3) --- hamocc/beleg_parm.F90 | 20 ++++++++++++++++++++ hamocc/mo_carbch.F90 | 3 +++ hamocc/mo_param1_bgc.F90 | 10 +++++++++- 3 files changed, 32 insertions(+), 1 deletion(-) diff --git a/hamocc/beleg_parm.F90 b/hamocc/beleg_parm.F90 index ad27bc99..49189e58 100644 --- a/hamocc/beleg_parm.F90 +++ b/hamocc/beleg_parm.F90 @@ -68,6 +68,11 @@ SUBROUTINE BELEG_PARM(kpie,kpje) #ifdef natDIC use mo_carbch, only: atm_co2_nat #endif +#ifdef extNcycle + use mo_param1_bgc, only: iatmnh3,iatmn2o + use mo_carbch, only: atm_nh3,atm_n2o + use mo_chemcon, only: atn2o !fixed mixing ratio of N2O at 1980, 300ppb = 3e-7 +#endif implicit none @@ -98,6 +103,13 @@ SUBROUTINE BELEG_PARM(kpie,kpje) !BE UPDATED WITH Ziska et al. (2013) climatology database atm_bromo = 3.4 #endif +#ifdef extNcycle + ! Six & Mikolajewicz 2022: less than 1nmol m−3 + atm_nh3 = 0. + ! for now initializing the atmosphereic mixing ratio for N2O with fixed value + ! - later to be revereted to namelist parameter + atm_n2o = atn2o +#endif #ifdef cisonew ! set standard carbon isotope ratios @@ -137,6 +149,10 @@ SUBROUTINE BELEG_PARM(kpie,kpje) #endif #ifdef BROMO atm(i,j,iatmbromo)= atm_bromo +#endif +#ifdef extNcycle + atm(i,j,iatmnh3) = atm_nh3 + atm(i,j,iatmn2o) = atm_n2o #endif ENDDO ENDDO @@ -314,6 +330,10 @@ SUBROUTINE BELEG_PARM(kpie,kpje) &'* atm_o2 = ',atm_o2 WRITE(io_stdo_bgc,*) & &'* atm_n2 = ',atm_n2 +#ifdef extNcycle + WRITE(io_stdo_bgc,*) & + &'* atm_nh3 = ',atm_nh3 +#endif WRITE(io_stdo_bgc,*) & &'* phytomi = ',phytomi WRITE(io_stdo_bgc,*) & diff --git a/hamocc/mo_carbch.F90 b/hamocc/mo_carbch.F90 index c6b415d7..74cd2d49 100644 --- a/hamocc/mo_carbch.F90 +++ b/hamocc/mo_carbch.F90 @@ -105,6 +105,9 @@ MODULE mo_carbch #ifdef BROMO REAL :: atm_bromo, fbro1, fbro2 #endif +#ifdef extNcycle + REAL :: atm_nh3,atm_n2o +#endif CONTAINS diff --git a/hamocc/mo_param1_bgc.F90 b/hamocc/mo_param1_bgc.F90 index efff91b6..2ebcfa8a 100644 --- a/hamocc/mo_param1_bgc.F90 +++ b/hamocc/mo_param1_bgc.F90 @@ -196,9 +196,17 @@ MODULE mo_param1_bgc INTEGER, PARAMETER :: i_bromo_atm=0, & & iatmbromo=-1 #endif +#ifdef extNcycle + INTEGER, PARAMETER :: i_nh3_atm=1, & + & iatmnh3=i_base_atm+i_iso_atm+i_cfc_atm+ & + & i_ndic_atm+i_bromo_atm+1 +#else + INTEGER, PARAMETER :: i_nh3_atm=0, & + & iatmnh3=-1 +#endif ! total number of atmosphere tracers - INTEGER, PARAMETER :: natm=i_base_atm+i_iso_atm+i_cfc_atm+i_ndic_atm+i_bromo_atm + INTEGER, PARAMETER :: natm=i_base_atm+i_iso_atm+i_cfc_atm+i_ndic_atm+i_bromo_atm+i_nh3_atm ! sediment From 732bdcd7f9cbe0597a47785f0fde5064a5e2402c Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Fri, 8 Apr 2022 20:34:19 +0200 Subject: [PATCH 052/366] Introduced and checked air and water phase Schmidt numbers for air-sea gas exchange of NO3 OMP still missing --- hamocc/carchm.F90 | 42 +++++++++++++++++++++++++++++++++++++++++- hamocc/mo_chemcon.F90 | 23 +++++++++++++++++++++++ 2 files changed, 64 insertions(+), 1 deletion(-) diff --git a/hamocc/carchm.F90 b/hamocc/carchm.F90 index d86013b8..4b028136 100644 --- a/hamocc/carchm.F90 +++ b/hamocc/carchm.F90 @@ -117,6 +117,10 @@ SUBROUTINE CARCHM(kpie,kpje,kpke,kbnd, & use mo_carbch, only: atm_co2_nat,nathi,natco3,natpco2d,natomegaa,natomegac use mo_param1_bgc, only: iatmnco2,inatalkali,inatcalc,inatsco212 #endif +#ifdef extNcycle + use mo_param1_bgc, only: iatmnh3,ianh4 + use mo_chemcon, only: SV0_air,SV1_air,SV2_air,SV3_air,SV4_air,SD0_air,SD1_air,SD2_air,SD3_air,Vb_nh3,M_nh3 +#endif implicit none @@ -169,6 +173,9 @@ SUBROUTINE CARCHM(kpie,kpje,kpke,kbnd, & #ifdef BROMO REAL :: flx_bromo,sch_bromo,kw_bromo,a_bromo,atbrf,Kb1,lsub #endif +#ifdef extNcycle + REAL :: flx_nh3,sch_nh3_a,sch_nh3_w,kw_nh3,ka_nh3,atn2ov,atnh3,diff_nh3_a,diff_nh3_w,mu_air,mu_w,p_dbar,rho_air +#endif ! set variables for diagnostic output to zero atmflx (:,:,:)=0. @@ -214,6 +221,9 @@ SUBROUTINE CARCHM(kpie,kpje,kpke,kbnd, & #ifdef BROMO !$OMP ,flx_bromo,sch_bromo,kw_bromo,a_bromo,atbrf,Kb1,lsub & #endif +#ifdef extNcycle +!$OMP ,kw_nh3,ka_nh3 & +#endif !$OMP ,j,i) DO k=1,kpke DO j=1,kpje @@ -308,7 +318,37 @@ SUBROUTINE CARCHM(kpie,kpje,kpke,kbnd, & ! (2003; GBC) sch_bromo= 4662.8 - 319.45*t + 9.9012*t2 - 0.1159*t3 #endif - +#ifdef extNcycle + ! Tsilingiris 2008 Eq.(45) for moist air (kg/m s) + mu_air = SV0_air + SV1_air*t + SV2_air*t2 + SV3_air*t3 + SV4_air*t4 + + ! Tsinlingiris(44) moist air density (kg/m3) + rho_air = SD0_air + SD1_air*t + SD2_air*t2 + SD3_air*t3 + + ! molecular viscosity of sea water + ! (Matthaeus 1972, Richards 1998,assuming salinity s in per mille = ~PSU) + p_dbar = 1.01325 * 10. ! sea level pressure (bar) -> dbar + mu_w = 1.79e-2 - 6.1299e-4 * t + 1.4467e-5 * t2 - 1.6826e-7 * t3 & + & - 1.8266e-7 * p_dbar + 9.8972e-12 * p_dbar*p_dbar + 2.4727e-5 * s & + & + s * (4.8429e-7 * t - 4.7172e-8 * t2 + 7.5986e-10 * t3) & + & + s * (1.3817e-8 * t - 2.6363e-10 * t2) & + & - p_dbar*p_dbar * (6.3255e-13 * t - 1.2116e-14 * t2) + mu_w = mu_w * 0.1 ! conversion from g/(cm s) to kg/(m s) + + ! diffusion coeff in air (m2/s) Fuller 1966 / Johnson 2010 + ! division by pressure: assuming 1 atm, in Fuller, p is a factor for denominator + diff_nh3_a = 1e-7 * (t+273.15)**1.75 * M_nh3 + + ! Johnson 2010 - (34) cm2/s -> m2/s (1e-8*1e-4=1e-12) + ! closer to fit for Li & Gregory of: 9.874e-6*exp(2.644e-2*t) + ! mu_w*1000: kg/(m s) -> cPoise as in Eq.(34) of Johnson 2010 + diff_nh3_w = 1.25e-12*(t+273.15)**1.52 *(mu_w*1000.)**(9.58/Vb_nh3 -1.12)*(Vb_nh3**-0.19 - 0.292) + + ! Schmidt number air phase + sch_nh3_a = mu_air /(diff_nh3_a * rho_air) + ! Schmidt number water phase + sch_nh3_w = mu_w /(diff_nh3_w * rrho * 1000.) +#endif ! solubility of N2 (Weiss, R.F. 1970, Deep-Sea Res., 17, 721-735) for moist air ! at 1 atm; multiplication with oxyco converts to kmol/m^3/atm ani=an0+an1/tk100+an2*alog(tk100)+an3*tk100+s*(an4+an5*tk100+an6*tk100**2) diff --git a/hamocc/mo_chemcon.F90 b/hamocc/mo_chemcon.F90 index 7b666856..55a56b49 100644 --- a/hamocc/mo_chemcon.F90 +++ b/hamocc/mo_chemcon.F90 @@ -174,6 +174,29 @@ MODULE mo_chemcon ! real, parameter :: atn2o=3.e-7 +#ifdef extNcycle + ! Tsilingiris 2008 + ! moist air dynamic viscosity parameters + real, parameter :: SV0_air = 1.715747771e-5 + real, parameter :: SV1_air = 4.722402075e-8 + real, parameter :: SV2_air = -3.663027156e-10 + real, parameter :: SV3_air = 1.873236686e-12 + real, parameter :: SV4_air = -8.050218737e-14 + + ! moist air density parameters + real, parameter :: SD0_air = 1.293393662 + real, parameter :: SD1_air = -5.538444326e-3 + real, parameter :: SD2_air = 3.860201577e-5 + real, parameter :: SD3_air = -5.2536065e-7 + + ! diffusion of NH3 in water and air + real, parameter :: Va_air = 20.1 ! Johnson 2010 + real, parameter :: Ma_air = 28.97 ! Johnson 2010 + real, parameter :: Mb_nh3 = 17.03 ! Johnson 2010, Tang 2014 + real, parameter :: Vb_nh3 = 20.7 ! Johnson 2010 + real, parameter :: M_nh3 = (1./Ma_air + 1./Mb_nh3)**0.5 / (Va_air**(1./3.)+Vb_nh3**(1./3.))**2. +#endif + ! ----------------------------------------------------------------- From eed4b0bb43a8f82adf0ee161308f5c28a98a9de4 Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Mon, 11 Apr 2022 12:45:32 +0200 Subject: [PATCH 053/366] Added effective Henry law constant for NH3 --- hamocc/carchm.F90 | 12 ++++++++++-- 1 file changed, 10 insertions(+), 2 deletions(-) diff --git a/hamocc/carchm.F90 b/hamocc/carchm.F90 index 4b028136..946f6fd1 100644 --- a/hamocc/carchm.F90 +++ b/hamocc/carchm.F90 @@ -175,6 +175,7 @@ SUBROUTINE CARCHM(kpie,kpje,kpke,kbnd, & #endif #ifdef extNcycle REAL :: flx_nh3,sch_nh3_a,sch_nh3_w,kw_nh3,ka_nh3,atn2ov,atnh3,diff_nh3_a,diff_nh3_w,mu_air,mu_w,p_dbar,rho_air + REAL :: h_nh3,hstar_nh3,pKa_nh3 #endif ! set variables for diagnostic output to zero @@ -342,7 +343,7 @@ SUBROUTINE CARCHM(kpie,kpje,kpke,kbnd, & ! Johnson 2010 - (34) cm2/s -> m2/s (1e-8*1e-4=1e-12) ! closer to fit for Li & Gregory of: 9.874e-6*exp(2.644e-2*t) ! mu_w*1000: kg/(m s) -> cPoise as in Eq.(34) of Johnson 2010 - diff_nh3_w = 1.25e-12*(t+273.15)**1.52 *(mu_w*1000.)**(9.58/Vb_nh3 -1.12)*(Vb_nh3**-0.19 - 0.292) + diff_nh3_w = 1.25e-12*(t+273.15)**1.52 *(mu_w*1000.)**(9.58/Vb_nh3 -1.12)*(Vb_nh3**(-0.19) - 0.292) ! Schmidt number air phase sch_nh3_a = mu_air /(diff_nh3_a * rho_air) @@ -380,7 +381,14 @@ SUBROUTINE CARCHM(kpie,kpje,kpke,kbnd, & !Henry's law constant [dimensionless] for Bromoform from Quack and Wallace (2003; GBC) a_bromo = exp(13.16 - 4973*(1/tk)) #endif - +#ifdef extNcycle + !Henry number for NH3 (Paulot et al. 2015, ) + h_nh3 = (17.93*(t+273.15)/273.15 * exp(4092./(t+273.15) - 9.7))**(-1) + ! Dissociation constant (Paulot et al. 2015, Bell 2007) + pKa_nh3 = 10.04 - 3.16e-2*t + 3.1e-3*s + ! effective gas-over-liquid Henry constant (Paulot et al. 2015) + hstar_nh3 = h_nh3/(1. + 10.**(log10(hi(i,j,k))+pKa_nh3)) +#endif ! Transfer (piston) velocity kw according to Wanninkhof (2014), in units of ms-1 Xconvxa = 6.97e-07 ! Wanninkhof's a=0.251 converted from [cm hr-1]/[m s-1]^2 to [ms-1]/[m s-1]^2 kwco2 = (1.-psicomo(i,j)) * Xconvxa * pfu10(i,j)**2*(660./scco2)**0.5 From 677f280e162804be5f9d70467de11dcfff239262 Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Mon, 11 Apr 2022 14:01:00 +0200 Subject: [PATCH 054/366] Added total effective transfer velocity for NH3 (gas and liquid phase) --- hamocc/carchm.F90 | 25 +++++++++++++++++++++---- hamocc/mo_chemcon.F90 | 1 + 2 files changed, 22 insertions(+), 4 deletions(-) diff --git a/hamocc/carchm.F90 b/hamocc/carchm.F90 index 946f6fd1..7db1d48f 100644 --- a/hamocc/carchm.F90 +++ b/hamocc/carchm.F90 @@ -119,7 +119,7 @@ SUBROUTINE CARCHM(kpie,kpje,kpke,kbnd, & #endif #ifdef extNcycle use mo_param1_bgc, only: iatmnh3,ianh4 - use mo_chemcon, only: SV0_air,SV1_air,SV2_air,SV3_air,SV4_air,SD0_air,SD1_air,SD2_air,SD3_air,Vb_nh3,M_nh3 + use mo_chemcon, only: SV0_air,SV1_air,SV2_air,SV3_air,SV4_air,SD0_air,SD1_air,SD2_air,SD3_air,Vb_nh3,M_nh3,kappa #endif implicit none @@ -175,7 +175,8 @@ SUBROUTINE CARCHM(kpie,kpje,kpke,kbnd, & #endif #ifdef extNcycle REAL :: flx_nh3,sch_nh3_a,sch_nh3_w,kw_nh3,ka_nh3,atn2ov,atnh3,diff_nh3_a,diff_nh3_w,mu_air,mu_w,p_dbar,rho_air - REAL :: h_nh3,hstar_nh3,pKa_nh3 + REAL :: h_nh3,hstar_nh3,pKa_nh3,eps_safe,Kh_nh3,cD_wind,u_star + eps_safe = EPSILON(1.) #endif ! set variables for diagnostic output to zero @@ -337,8 +338,8 @@ SUBROUTINE CARCHM(kpie,kpje,kpke,kbnd, & mu_w = mu_w * 0.1 ! conversion from g/(cm s) to kg/(m s) ! diffusion coeff in air (m2/s) Fuller 1966 / Johnson 2010 - ! division by pressure: assuming 1 atm, in Fuller, p is a factor for denominator - diff_nh3_a = 1e-7 * (t+273.15)**1.75 * M_nh3 + ! division by pressure: ppao [Pa]; in Fuller, p is a factor for denominator [atm] + diff_nh3_a = 1e-7 * (t+273.15)**1.75 * M_nh3 / (ppao(i,j)/101325.0) ! Johnson 2010 - (34) cm2/s -> m2/s (1e-8*1e-4=1e-12) ! closer to fit for Li & Gregory of: 9.874e-6*exp(2.644e-2*t) @@ -407,6 +408,22 @@ SUBROUTINE CARCHM(kpie,kpje,kpke,kbnd, & kw_bromo=(1.-psicomo(i,j)) * 1.e-2/3600. * & & (0.222*pfu10(i,j)**2+0.33*pfu10(i,j))*(660./sch_bromo)**0.5 #endif +#ifdef extNcycle + ! Paulot et al. 2015 / Johnson 2010 + ! friction velocity of wind (m/s) + u_star = pfu10(i,j)*sqrt(6.1e-4 + 6.3e-5*pfu10(i,j)) + ! wind drag coeff (-) + cD_wind = (u_star / (pfu10(i,j) + eps_safe))**2. + ! gas transfer velocity on gas phase side (m/s) + ka_nh3 = 1e-3 + u_star/ (13.3*sch_nh3_a + (eps_safe + cD_wind)**(-0.5) - 5. + log(sch_nh3_a)/(2.*kappa)) + ! gas transfer velocity on liquid phase side (m/s) Nightingale 2000b - 3600*100: cm/h -> m/s + kw_nh3 = (0.24*pfu10(i,j)**2 + 0.061*pfu10(i,j))*sqrt(600./sch_nh3_w)/360000. + + ! total effective gas transfer velocity (m/s) + Kh_nh3 = (1./(ka_nh3 + eps_safe) + hstar_nh3/(kw_nh3 + eps_safe))**(-1.) + ! account for ice + Kh_nh3 = (1.-psicomo(i,j)) * Kh_nh3 +#endif atco2 = atm(i,j,iatmco2) ato2 = atm(i,j,iatmo2) diff --git a/hamocc/mo_chemcon.F90 b/hamocc/mo_chemcon.F90 index 55a56b49..bf722b54 100644 --- a/hamocc/mo_chemcon.F90 +++ b/hamocc/mo_chemcon.F90 @@ -195,6 +195,7 @@ MODULE mo_chemcon real, parameter :: Mb_nh3 = 17.03 ! Johnson 2010, Tang 2014 real, parameter :: Vb_nh3 = 20.7 ! Johnson 2010 real, parameter :: M_nh3 = (1./Ma_air + 1./Mb_nh3)**0.5 / (Va_air**(1./3.)+Vb_nh3**(1./3.))**2. + real, parameter :: kappa = 0.4 ! von Karman constant #endif From af4c1e008961fd5e85acf09c05d8d24eeb593cf0 Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Mon, 11 Apr 2022 17:08:39 +0200 Subject: [PATCH 055/366] Finalized flux formulation for NH3 Potentially requires re-adjustment of atmospheric concentration factor - currently atnh3 assumed in units of pptv --- hamocc/carchm.F90 | 14 ++++++++++++-- 1 file changed, 12 insertions(+), 2 deletions(-) diff --git a/hamocc/carchm.F90 b/hamocc/carchm.F90 index 7db1d48f..155725f0 100644 --- a/hamocc/carchm.F90 +++ b/hamocc/carchm.F90 @@ -329,7 +329,7 @@ SUBROUTINE CARCHM(kpie,kpje,kpke,kbnd, & ! molecular viscosity of sea water ! (Matthaeus 1972, Richards 1998,assuming salinity s in per mille = ~PSU) - p_dbar = 1.01325 * 10. ! sea level pressure (bar) -> dbar + p_dbar = ppao(i,j)*1e-4 ! sea level pressure (Pa *1e-5 -> bar *10-> dbar mu_w = 1.79e-2 - 6.1299e-4 * t + 1.4467e-5 * t2 - 1.6826e-7 * t3 & & - 1.8266e-7 * p_dbar + 9.8972e-12 * p_dbar*p_dbar + 2.4727e-5 * s & & + s * (4.8429e-7 * t - 4.7172e-8 * t2 + 7.5986e-10 * t3) & @@ -435,6 +435,9 @@ SUBROUTINE CARCHM(kpie,kpje,kpke,kbnd, & #ifdef BROMO atbrf = atm(i,j,iatmbromo) #endif +#ifdef extNcycle + atnh3 = atm(i,j,iatmnh3) +#endif ! Ratio P/P_0, where P is the local SLP and P_0 is standard pressure (1 atm). This is ! used in all surface flux calculations where atmospheric concentration is given as a @@ -548,7 +551,11 @@ SUBROUTINE CARCHM(kpie,kpje,kpke,kbnd, & & (atbrf/a_bromo*1e-12*ppao(i,j)*1e-5/(tk*0.083) - ocetra(i,j,1,ibromo)) ocetra(i,j,1,ibromo)=ocetra(i,j,1,ibromo)+flx_bromo/pddpo(i,j,1) #endif - +#ifdef extNcycle + ! surface flux NH3: STILL REQUIRES TO CHECK CONVERSION FACTOR FOR atNH3 (currently assumed atNH3 in pptv) + flx_nh3 = Kh_nh3*dtbgc*(atnh3*1e-12*ppao(i,j)*1e-5/(tk*0.08314510) - hstar_nh3*ocetra(i,j,1,ianh4)) + ocetra(i,j,1,ianh4) = ocetra(i,j,1,ianh4) + flx_nh3/pddpo(i,j,1) +#endif ! Save surface fluxes atmflx(i,j,iatmco2)=fluxu-fluxd @@ -571,6 +578,9 @@ SUBROUTINE CARCHM(kpie,kpje,kpke,kbnd, & #ifdef BROMO atmflx(i,j,iatmbromo)=-flx_bromo #endif +#ifdef extNcycle + atmflx(i,j,iatmnh3)=-flx_nh3 +#endif ! Save up- and downward components of carbon fluxes for output co2fxd(i,j) = fluxd From 6b8851761c6d4ec91056ab67c715b95b6e037a52 Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Mon, 11 Apr 2022 18:58:06 +0200 Subject: [PATCH 056/366] Consider air-sea NH3 fluxes in inventory and monitoring --- hamocc/accfields.F90 | 6 ++++- hamocc/inventory_bgc.F90 | 47 +++++++++++++++++++++++++++++++++++++--- hamocc/mo_bgcmean.F90 | 3 ++- 3 files changed, 51 insertions(+), 5 deletions(-) diff --git a/hamocc/accfields.F90 b/hamocc/accfields.F90 index d6992482..d1f2d85a 100644 --- a/hamocc/accfields.F90 +++ b/hamocc/accfields.F90 @@ -105,7 +105,10 @@ SUBROUTINE ACCFIELDS(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask) use mo_bgcmean, only: jbursssc12,jburssso12,jburssssil,jburssster,jpowaal,jpowaic,jpowaox,jpowaph,jpowaph,jpowasi,jpown2, & & jpowno3,jsssc12,jssso12,jssssil,jssster,accbur,accsdm #endif - +#ifdef extNcycle + use mo_param1_bgc, only: iatmnh3 + use mo_bgcmean, only: jnh3flux +#endif implicit none INTEGER :: kpie,kpje,kpke @@ -157,6 +160,7 @@ SUBROUTINE ACCFIELDS(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask) bgct2d(i,j,jo2flux) = bgct2d(i,j,jo2flux) + atmflx(i,j,iatmo2)/2.0 bgct2d(i,j,jn2flux) = bgct2d(i,j,jn2flux) + atmflx(i,j,iatmn2)/2.0 bgct2d(i,j,jn2oflux) = bgct2d(i,j,jn2oflux) + atmflx(i,j,iatmn2o)/2.0 + bgct2d(i,j,jnh3flux) = bgct2d(i,j,jnh3flux) + atmflx(i,j,iatmnh3)/2.0 bgct2d(i,j,jndep) = bgct2d(i,j,jndep) + ndepflx(i,j)/2.0 bgct2d(i,j,jirdin) = bgct2d(i,j,jirdin) + rivinflx(i,j,irdin)/2.0 bgct2d(i,j,jirdip) = bgct2d(i,j,jirdip) + rivinflx(i,j,irdip)/2.0 diff --git a/hamocc/inventory_bgc.F90 b/hamocc/inventory_bgc.F90 index a05960c0..cfede248 100644 --- a/hamocc/inventory_bgc.F90 +++ b/hamocc/inventory_bgc.F90 @@ -71,7 +71,8 @@ SUBROUTINE INVENTORY_BGC(kpie,kpje,kpke,dlxp,dlyp,ddpo,omask,iogrp) use mo_sedmnt, only: porwat,seddw,sedlay,burial,sedhpl,powtra,porsol #endif #ifdef extNcycle - use mo_param1_bgc, only: ianh4,iano2 + use mo_param1_bgc, only: ianh4,iano2,iatmnh3 + use mo_bgcmean, only: jnh3flux #endif @@ -120,7 +121,7 @@ SUBROUTINE INVENTORY_BGC(kpie,kpje,kpke,dlxp,dlyp,ddpo,omask,iogrp) !--- atmosphere flux and atmospheric CO2 real :: sndepflux ! sum of N dep fluxes real :: zatmco2,zatmo2,zatmn2 - real :: co2flux,so2flux,sn2flux,sn2oflux + real :: co2flux,so2flux,sn2flux,sn2oflux,snh3flux real :: zprorca,zprcaca,zsilpro !--- total tracer budgets real :: totalcarbon,totalphos,totalsil,totalnitr,totaloxy @@ -289,6 +290,7 @@ SUBROUTINE INVENTORY_BGC(kpie,kpje,kpke,dlxp,dlyp,ddpo,omask,iogrp) so2flux =0. sn2flux =0. sn2oflux =0. + snh3flux =0. sndepflux=0. srivflux =0. zatmco2 =0. @@ -309,6 +311,9 @@ SUBROUTINE INVENTORY_BGC(kpie,kpje,kpke,dlxp,dlyp,ddpo,omask,iogrp) so2flux = sum2d(atmflx(:,:,iatmo2)) sn2flux = sum2d(atmflx(:,:,iatmn2)) sn2oflux = sum2d(atmflx(:,:,iatmn2o)) +#ifdef extNcycle + snh3flux = sum2d(atmflx(:,:,iatmnh3)) +#endif ! nitrogen deposition if(do_ndep) then @@ -325,6 +330,9 @@ SUBROUTINE INVENTORY_BGC(kpie,kpje,kpke,dlxp,dlyp,ddpo,omask,iogrp) so2flux = sum2d(bgct2d(:,:,jo2flux)) sn2flux = sum2d(bgct2d(:,:,jn2flux)) sn2oflux = sum2d(bgct2d(:,:,jn2oflux)) +#ifdef extNcycle + snh3flux = sum2d(bgct2d(:,:,jnh3flux)) +#endif ! nitrogen deposition fluxes if(do_ndep) then @@ -375,7 +383,7 @@ SUBROUTINE INVENTORY_BGC(kpie,kpje,kpke,dlxp,dlyp,ddpo,omask,iogrp) & +zocetratot(ian2o)*2 & & - sndepflux & #ifdef extNcycle - & +zocetratot(ianh4)+zocetratot(iano2) & + & +zocetratot(ianh4)+zocetratot(iano2)+snh3flux & #endif #if defined(BOXATM) & +zatmn2*ppm2con*2 @@ -586,6 +594,9 @@ subroutine write_stdout ! WRITE(io_stdo_bgc,*) 'O2 Flux :',so2flux ! WRITE(io_stdo_bgc,*) 'N2 Flux :',sn2flux ! WRITE(io_stdo_bgc,*) 'N2O Flux :',sn2oflux +#ifdef extNcycle + ! WRITE(io_stdo_bgc,*) 'NH3 Flux :',snh3flux +#endif ! WRITE(io_stdo_bgc,*) ' ' #if defined(BOXATM) ! WRITE(io_stdo_bgc,*) 'global atm. CO2[ppm] / kmol: ', & @@ -681,6 +692,9 @@ subroutine write_netcdf(iogrp) #ifdef natDIC use mo_param1_bgc, only: inatalkali,inatcalc,inatsco212 #endif +#ifdef extNcycle + use mo_param1_bgc, only: ianh4 +#endif implicit none @@ -780,6 +794,9 @@ subroutine write_netcdf(iogrp) #endif #ifdef BROMO integer :: zt_bromo_varid, zc_bromo_varid ! Bromoform +#endif +#ifdef extNcycle + integer :: zt_nh4_varid, zc_nh4_varid ! Ammonium (NH4+) #endif !--- sum of inventory integer :: totcarb_varid, totphos_varid, totsili_varid, totnitr_varid @@ -1419,6 +1436,20 @@ subroutine write_netcdf(iogrp) & 'Mean bromoform concentration') ) call nccheck( NF90_PUT_ATT(ncid, zc_bromo_varid, 'units', 'kmol/m^3') ) #endif +#ifdef extNcycle + call nccheck( NF90_DEF_VAR(ncid, 'zt_nh4', NF90_DOUBLE, & + & time_dimid, zt_nh4_varid) ) + call nccheck( NF90_PUT_ATT(ncid, zt_nh4_varid, 'long_name', & + & 'Total ammonium tracer') ) + call nccheck( NF90_PUT_ATT(ncid, zt_nh4_varid, 'units', 'kmol') ) + + call nccheck( NF90_DEF_VAR(ncid, 'zc_nh4', NF90_DOUBLE, & + & time_dimid, zc_nh4_varid) ) + call nccheck( NF90_PUT_ATT(ncid, zc_nh4_varid, 'long_name', & + & 'Mean ammonium concentration') ) + call nccheck( NF90_PUT_ATT(ncid, zc_nh4_varid, 'units', 'kmol/m^3') ) +#endif + !--- Define variables : sum of inventory call nccheck( NF90_DEF_VAR(ncid, 'totcarb', NF90_DOUBLE, time_dimid, & @@ -1611,6 +1642,10 @@ subroutine write_netcdf(iogrp) #ifdef BROMO call nccheck( NF90_INQ_VARID(ncid, "zt_bromo", zt_bromo_varid) ) call nccheck( NF90_INQ_VARID(ncid, "zc_bromo", zc_bromo_varid) ) +#endif +#ifdef extNcycle + call nccheck( NF90_INQ_VARID(ncid, "zt_nh4", zt_nh4_varid) ) + call nccheck( NF90_INQ_VARID(ncid, "zc_nh4", zc_nh4_varid) ) #endif !--- Inquire varid : sum of inventory call nccheck( NF90_INQ_VARID(ncid, "totcarb", totcarb_varid) ) @@ -1840,6 +1875,12 @@ subroutine write_netcdf(iogrp) & zocetratot(ibromo), start = wrstart) ) call nccheck( NF90_PUT_VAR(ncid, zc_bromo_varid, & & zocetratoc(ibromo), start = wrstart) ) +#endif +#ifdef extNcycle + call nccheck( NF90_PUT_VAR(ncid, zt_nh4_varid, & + & zocetratot(ianh4), start = wrstart) ) + call nccheck( NF90_PUT_VAR(ncid, zc_nh4_varid, & + & zocetratoc(ianh4), start = wrstart) ) #endif !--- Write data : sum of inventory call nccheck( NF90_PUT_VAR(ncid, totcarb_varid, totalcarbon, & diff --git a/hamocc/mo_bgcmean.F90 b/hamocc/mo_bgcmean.F90 index cb651832..b106b7c1 100644 --- a/hamocc/mo_bgcmean.F90 +++ b/hamocc/mo_bgcmean.F90 @@ -238,7 +238,8 @@ MODULE mo_bgcmean & jiriron =15, & & jirdoc =16, & & jirdet =17, & - & nbgct2d =17 + & jnh3flux =18, & + & nbgct2d =18 !---------------------------------------------------------------- INTEGER, SAVE :: i_bsc_m2d From 4ba7230e0fce1a4af61503158ebba7914c302bba Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Mon, 11 Apr 2022 19:00:58 +0200 Subject: [PATCH 057/366] Initialize NO2 and NH4 with dummy values > 0. (initially for testing purposes) --- hamocc/beleg_vars.F90 | 9 ++++++++- 1 file changed, 8 insertions(+), 1 deletion(-) diff --git a/hamocc/beleg_vars.F90 b/hamocc/beleg_vars.F90 index 22cd8dc4..5a0a83e9 100644 --- a/hamocc/beleg_vars.F90 +++ b/hamocc/beleg_vars.F90 @@ -84,7 +84,9 @@ SUBROUTINE BELEG_VARS(kpaufr,kpie,kpje,kpke,kbnd,pddpo,prho,omask, & #ifdef FB_BGC_OCE use mo_biomod, only: abs_oce #endif - +#ifdef extNcycle + use mo_param1_bgc, only: iano2,ianh4 +#endif implicit none INTEGER, intent(in) :: kpaufr,kpie,kpje,kpke,kbnd @@ -213,6 +215,11 @@ SUBROUTINE BELEG_VARS(kpaufr,kpie,kpje,kpke,kbnd,pddpo,prho,omask, & ! Initialise to 0,01 pmol L-1 (Stemmler et al., 2015) => mol/kg ocetra(i,j,k,ibromo)= 1.e-14/prho(i,j,k) #endif +#ifdef extNcycle + ocetra(i,j,k,iano2) =1.9e-8/prho(i,j,k) + ocetra(i,j,k,ianh4) =2.9e-8/prho(i,j,k) +#endif + ENDIF ! omask > 0.5 ENDDO ENDDO From 229118744209d7b8bc8d1fe317f88f4f89ab630e Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Tue, 12 Apr 2022 14:41:16 +0200 Subject: [PATCH 058/366] Updated openMP private statement for extNcycle --- hamocc/carchm.F90 | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/hamocc/carchm.F90 b/hamocc/carchm.F90 index 155725f0..3e50236a 100644 --- a/hamocc/carchm.F90 +++ b/hamocc/carchm.F90 @@ -224,7 +224,9 @@ SUBROUTINE CARCHM(kpie,kpje,kpke,kbnd, & !$OMP ,flx_bromo,sch_bromo,kw_bromo,a_bromo,atbrf,Kb1,lsub & #endif #ifdef extNcycle -!$OMP ,kw_nh3,ka_nh3 & +!$OMP ,flx_nh3,sch_nh3_a,sch_nh3_w,kw_nh3,ka_nh3,atn2ov,atnh3 & +!$OMP ,diff_nh3_a,diff_nh3_w,mu_air,mu_w,p_dbar,rho_air,h_nh3 & +!$OMP ,hstar_nh3,pKa_nh3,eps_safe,Kh_nh3,cD_wind,u_star & #endif !$OMP ,j,i) DO k=1,kpke @@ -385,8 +387,8 @@ SUBROUTINE CARCHM(kpie,kpje,kpke,kbnd, & #ifdef extNcycle !Henry number for NH3 (Paulot et al. 2015, ) h_nh3 = (17.93*(t+273.15)/273.15 * exp(4092./(t+273.15) - 9.7))**(-1) - ! Dissociation constant (Paulot et al. 2015, Bell 2007) - pKa_nh3 = 10.04 - 3.16e-2*t + 3.1e-3*s + ! Dissociation constant (Paulot et al. 2015, Bell 2007/2008) + pKa_nh3 = 10.0423 - 3.15536e-2*t + 3.071e-3*s ! effective gas-over-liquid Henry constant (Paulot et al. 2015) hstar_nh3 = h_nh3/(1. + 10.**(log10(hi(i,j,k))+pKa_nh3)) #endif From 5ced1f813ac55311f24389b714fe31c58f8f46be Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Mon, 25 Apr 2022 11:41:40 +0200 Subject: [PATCH 059/366] Enabling to use potentially variable N2O atmosphere field when extNcycle is switched on thus far, the field holds the same constant value, but will become variable, once the coupling in NorESM is performed --- hamocc/carchm.F90 | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/hamocc/carchm.F90 b/hamocc/carchm.F90 index 3e50236a..cd64943f 100644 --- a/hamocc/carchm.F90 +++ b/hamocc/carchm.F90 @@ -439,6 +439,9 @@ SUBROUTINE CARCHM(kpie,kpje,kpke,kbnd, & #endif #ifdef extNcycle atnh3 = atm(i,j,iatmnh3) + atn2ov = atm(i,j,iatmn2o) +#else + atn2ov = atn2o #endif ! Ratio P/P_0, where P is the local SLP and P_0 is standard pressure (1 atm). This is @@ -498,7 +501,7 @@ SUBROUTINE CARCHM(kpie,kpje,kpke,kbnd, & niflux=kwn2*dtbgc*(ocetra(i,j,1,igasnit)-anisa*(atn2/802000)*rpp0) ocetra(i,j,1,igasnit)=ocetra(i,j,1,igasnit)-niflux/pddpo(i,j,1) ! Surface flux of laughing gas (same piston velocity as for O2 and N2) - n2oflux=kwn2o*dtbgc*(ocetra(i,j,1,ian2o)-satn2o(i,j)*atn2o*rpp0) + n2oflux=kwn2o*dtbgc*(ocetra(i,j,1,ian2o)-satn2o(i,j)*atn2ov*rpp0) ocetra(i,j,1,ian2o)=ocetra(i,j,1,ian2o)-n2oflux/pddpo(i,j,1) #ifdef CFC ! Surface fluxes for CFC: eqn. (1a) in ocmip2 howto doc(hyc) From 145445156f27daa513be40844e2c5776b445990a Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Tue, 26 Apr 2022 18:06:58 +0200 Subject: [PATCH 060/366] Initial setup of a new module file for extended nitrogen specific processes - to avoid further cluttering of OCPROD --- hamocc/mo_extNbioproc.F90 | 192 ++++++++++++++++++++++++++++++++++++++ 1 file changed, 192 insertions(+) create mode 100644 hamocc/mo_extNbioproc.F90 diff --git a/hamocc/mo_extNbioproc.F90 b/hamocc/mo_extNbioproc.F90 new file mode 100644 index 00000000..c7f46735 --- /dev/null +++ b/hamocc/mo_extNbioproc.F90 @@ -0,0 +1,192 @@ +! Copyright (C) 2022 j. maerz +! +! This file is part of BLOM/iHAMOCC. +! +! 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 https://www.gnu.org/licenses/. + + MODULE mo_extNbioproc + !**************************************************************** + ! + ! MODULE mo_extNbioproc - (microbial) biological processes of the + ! extended nitrogen cycle + ! + ! j.maerz 25.04.2022 + ! + ! Purpose: + ! -------- + ! - initialization of parameters related to the extended nitrogen cycle + ! - representing major biological parts of the extended nitrogen cycle + ! + ! Description: + ! ------------ + ! The module holds the sequentially operated processes of + ! - nitrification + ! - denitrification/dissimilatory nitrate reduction from NO3 to NO2 + ! - anammox + ! - denitrification processes from NO2 -> N2O -> N2 and DNRA + ! (dissimilatory nitrite reduction to ammonium) + ! + ! The process of ammonium and nitrate uptake by phytoplankton + ! is handled in ocprod. + ! + ! Ammonification (PON -> NH4) is also handled in ocprod. + ! + ! Explicit cyanobacteria? + ! + ! Sediment processes? + ! + !**************************************************************** + use mo_vgrid, only: dp_min + use mod_xc, only: mnproc + use mo_control_bgc, only: io_stdo_bgc + use mo_biomod, only: + + implicit none + + private + + public :: extNbioparam_init,nitrification,denit_NO3_to_NO2,& + & anammox,denit_dnra,extN_inv_check + + + CONTAINS + +!================================================================================================================================== + subroutine extNbioparam_init() + ! Initialization of model parameters for the extended nitrogen cycle + + end subroutine extNbioparam_init + +!================================================================================================================================== + subroutine nitrification(kpie,kpje,kpke,pddpo,omask) + ! Nitrification processes (NH4 -> NO2, NO2 -> NO3) + + integer, intent(in) :: kpie,kpje,kpke + real, intent(in) :: omask(kpie,kpje) + real, intent(in) :: pddpo(kpie,kpje,kpke) + + !local variables + integer :: i,j,k + + + !$OMP PARALLEL DO PRIVATE(i,j,k) + do j = 1,kpje + do i = 1,kpie + do k = 1,kpke + if(pddpo(i,j,k) > dp_min .and. omask(i,j) > 0.5) then + + endif + enddo + enddo + enddo + !$OMP END PARALLEL DO + + end subroutine nitrification + +!================================================================================================================================== + subroutine denit_NO3_to_NO2(kpie,kpje,kpke,pddpo,omask) + ! Denitrification / dissimilatory nitrate reduction (NO3 -> NO2) + + integer, intent(in) :: kpie,kpje,kpke + real, intent(in) :: omask(kpie,kpje) + real, intent(in) :: pddpo(kpie,kpje,kpke) + + !local variables + integer :: i,j,k + + + !$OMP PARALLEL DO PRIVATE(i,j,k) + do j = 1,kpje + do i = 1,kpie + do k = 1,kpke + if(pddpo(i,j,k) > dp_min .and. omask(i,j) > 0.5) then + + endif + enddo + enddo + enddo + !$OMP END PARALLEL DO + + end subroutine denit_NO3_to_NO2 + +!================================================================================================================================== + subroutine anammox(kpie,kpje,kpke,pddpo,omask) + ! Aanammox + + integer, intent(in) :: kpie,kpje,kpke + real, intent(in) :: omask(kpie,kpje) + real, intent(in) :: pddpo(kpie,kpje,kpke) + + !local variables + integer :: i,j,k + + + !$OMP PARALLEL DO PRIVATE(i,j,k) + do j = 1,kpje + do i = 1,kpie + do k = 1,kpke + if(pddpo(i,j,k) > dp_min .and. omask(i,j) > 0.5) then + + endif + enddo + enddo + enddo + !$OMP END PARALLEL DO + + end subroutine anammox + +!================================================================================================================================== + subroutine denit_dnra(kpie,kpje,kpke,pddpo,omask) + ! Denitrification processes (NO2 -> N2O -> N2) and dissmilatory nitrite reduction (NO2 -> NH4) + + integer, intent(in) :: kpie,kpje,kpke + real, intent(in) :: omask(kpie,kpje) + real, intent(in) :: pddpo(kpie,kpje,kpke) + + !local variables + integer :: i,j,k + + + !$OMP PARALLEL DO PRIVATE(i,j,k) + do j = 1,kpje + do i = 1,kpie + do k = 1,kpke + if(pddpo(i,j,k) > dp_min .and. omask(i,j) > 0.5) then + + endif + enddo + enddo + enddo + !$OMP END PARALLEL DO + end subroutine +!================================================================================================================================== + subroutine extN_inv_check(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask,inv_message) + integer, intent(in) :: kpie,kpje,kpke + real, intent(in) :: omask(kpie,kpje) + real, intent(in) :: pdlxp(kpie,kpje),pdlyp(kpie,kpje),pddpo(kpie,kpje,kpke) + + character (len=*),intent(in) :: inv_message + +#ifdef PBGC_OCNP_TIMESTEP + if (mnproc == 1) then + write(io_stdo_bgc,*)' ' + write(io_stdo_bgc,*)inv_message + endif + CALL INVENTORY_BGC(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask,0) +#endif + end subroutine extN_inv_check + + END MODULE + + From 8816ad35595426cc3c08e48afaf2399e4cbc6a0c Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Tue, 26 Apr 2022 18:08:23 +0200 Subject: [PATCH 061/366] add new module to meson build list --- hamocc/meson.build | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/hamocc/meson.build b/hamocc/meson.build index d511e449..6677ca1a 100644 --- a/hamocc/meson.build +++ b/hamocc/meson.build @@ -9,4 +9,4 @@ sources += files('accfields.F90', 'aufr_bgc.F90', 'aufw_bgc.F90', 'mo_riverinpt.F90', 'mo_sedmnt.F90', 'mo_vgrid.F90', 'ncout_hamocc.F', 'netcdf_def_vardb.F90', 'ocprod.F90', 'powach.F90', 'powadi.F90', 'preftrc.F90', 'profile_gd.F90', 'read_netcdf_var.F90', 'restart_hamoccwt.F', -'sedshi.F90', 'trc_limitc.F', 'write_netcdf_var.F90') +'sedshi.F90', 'trc_limitc.F', 'write_netcdf_var.F90','mo_extNbioproc.F90') From ee1b0c757e266d375255b6ed82a4a544310047e5 Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Tue, 26 Apr 2022 18:12:16 +0200 Subject: [PATCH 062/366] enable beleg_parm to initialize extended nitrogen cycle parameters --- hamocc/beleg_parm.F90 | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/hamocc/beleg_parm.F90 b/hamocc/beleg_parm.F90 index 49189e58..a9d07bd5 100644 --- a/hamocc/beleg_parm.F90 +++ b/hamocc/beleg_parm.F90 @@ -72,6 +72,7 @@ SUBROUTINE BELEG_PARM(kpie,kpje) use mo_param1_bgc, only: iatmnh3,iatmn2o use mo_carbch, only: atm_nh3,atm_n2o use mo_chemcon, only: atn2o !fixed mixing ratio of N2O at 1980, 300ppb = 3e-7 + use mo_extNbioproc, only: extNbioparam_init #endif implicit none @@ -252,6 +253,11 @@ SUBROUTINE BELEG_PARM(kpie,kpje) rdn2o1=2*ro2ut-2.5*rnit ! moles N2O used for remineralisation of 1 mole P rdn2o2=2*ro2ut-2*rnit ! moles N2 released for remineralisation of 1 mole P +#ifdef extNcycle + ! initialize the extended nitrogen cycle parameters + call extNbioparam_init() +#endif + #ifdef BROMO !Bromoform to phosphate ratio (Hense and Quack, 2009) !JT: too little production: 0.25Gmol/yr rbro=6.72e-7*rnit From 39125cad3766e3238a28c330eb20a7166a1e0bac Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Tue, 26 Apr 2022 18:14:48 +0200 Subject: [PATCH 063/366] setting up ocprod to call extended nitrogen cycle specific biological processes --- hamocc/ocprod.F90 | 28 +++++++++++++++++++++++++++- 1 file changed, 27 insertions(+), 1 deletion(-) diff --git a/hamocc/ocprod.F90 b/hamocc/ocprod.F90 index 85ea37a5..5b81a7e4 100644 --- a/hamocc/ocprod.F90 +++ b/hamocc/ocprod.F90 @@ -121,6 +121,9 @@ subroutine ocprod(kpie,kpje,kpke,kbnd,pdlxp,pdlyp,pddpo,omask,dust,ptho) #ifdef FB_BGC_OCE use mo_biomod, only: abs_oce,atten_f #endif +#ifdef extNcycle + use mo_extNbioproc, only: nitrification,denit_NO3_to_NO2,anammox,denit_dnra,extN_inv_check +#endif implicit none @@ -195,6 +198,9 @@ subroutine ocprod(kpie,kpje,kpke,kbnd,pdlxp,pdlyp,pddpo,omask,dust,ptho) real :: bro_beta,bro_uv real :: abs_uv(kpie,kpje,kpke) #endif +#ifdef extNcycle + character(len=:), allocatable :: inv_message +#endif @@ -741,6 +747,8 @@ subroutine ocprod(kpie,kpje,kpke,kbnd,pdlxp,pdlyp,pddpo,omask,dust,ptho) CALL INVENTORY_BGC(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask,0) #endif +#ifndef extNcycle +! =====>>>> Regular CMIP6 iHAMOCC version for denitrification wo extended nitrogen cycle =====>>>> !$OMP PARALLEL DO PRIVATE(remin,remin2o,dz & # ifdef AGG !$OMP ,avmass,avnos & @@ -810,7 +818,6 @@ subroutine ocprod(kpie,kpje,kpke,kbnd,pdlxp,pdlyp,pddpo,omask,dust,ptho) enddo loop3 !$OMP END PARALLEL DO - #ifdef PBGC_OCNP_TIMESTEP if (mnproc == 1) then write(io_stdo_bgc,*)' ' @@ -818,6 +825,25 @@ subroutine ocprod(kpie,kpje,kpke,kbnd,pdlxp,pdlyp,pddpo,omask,dust,ptho) endif CALL INVENTORY_BGC(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask,0) #endif +! <<<<===== end of CMIP6 version denitrification processes without extended nitrogen cycle <<<<===== +#else + !======>>>> extended nitrogen cycle processes (aerobic and anaerobic) that follow ammonification + inv_message = 'in OCPROD after extNcycle nitrification' + CALL nitrification(kpie,kpje,kpke,pddpo,omask) + CALL extN_inv_check(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask,inv_message) + + inv_message = 'in OCPROD after extNcycle denitrification NO3 -> NO2' + CALL denit_NO3_to_NO2(kpie,kpje,kpke,pddpo,omask,ptho) + CALL extN_inv_check(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask,inv_message) + + inv_message = 'in OCPROD after extNcycle anammox' + CALL anammox(kpie,kpje,kpke,pddpo,omask,ptho) + CALL extN_inv_check(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask,inv_message) + + inv_message = 'in OCPROD after extNcycle denitrification / DNRA' + CALL denit_dnra(kpie,kpje,kpke,pddpo,omask) + CALL extN_inv_check(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask,inv_message) +#endif !sulphate reduction ! introduced 11.5.2007 to improve poc-remineralisation in the From b0036f2f9627142de5ceef5b6c2947b174639335 Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Tue, 26 Apr 2022 18:16:55 +0200 Subject: [PATCH 064/366] Initial implementation of first denitrification step and anammox limitation of the denitrification by detritus missing (so far hard set) --- hamocc/mo_extNbioproc.F90 | 93 +++++++++++++++++++++++++++++++++------ 1 file changed, 80 insertions(+), 13 deletions(-) diff --git a/hamocc/mo_extNbioproc.F90 b/hamocc/mo_extNbioproc.F90 index c7f46735..941ecdea 100644 --- a/hamocc/mo_extNbioproc.F90 +++ b/hamocc/mo_extNbioproc.F90 @@ -49,8 +49,10 @@ MODULE mo_extNbioproc !**************************************************************** use mo_vgrid, only: dp_min use mod_xc, only: mnproc - use mo_control_bgc, only: io_stdo_bgc - use mo_biomod, only: + use mo_control_bgc, only: io_stdo_bgc,dtb + use mo_param1_bgc, only: ialkali,ianh4,iano2,ian2o,iano3,idet,igasnit,iiron,ioxygen,iphosph,isco212 + use mo_carbch, only: ocetra + use mo_biomod, only: riron implicit none @@ -59,13 +61,34 @@ MODULE mo_extNbioproc public :: extNbioparam_init,nitrification,denit_NO3_to_NO2,& & anammox,denit_dnra,extN_inv_check + real :: q10ano3denit,sc_ano3denit,Trefano3denit,rano3denit,bkano3denit, & + & rano2anmx,q10anmx,Trefanmx,alphaanmx,bkoxanmx,bkano2anmx,bkanh4anmx + CONTAINS !================================================================================================================================== subroutine extNbioparam_init() + !=========================================================================== ! Initialization of model parameters for the extended nitrogen cycle - + + ! === Denitrification step NO3 -> NO2: + rano3denit = 0.15*dtb ! Maximum growth rate (1/d) + q10ano3denit = 2. ! Q10 factor for denitrification on NO3 (-) + Trefano3denit = 10. ! Reference temperature for denitrification on NO3 (degr C) + sc_ano3denit = 0.05e6 ! Shape factor for NO3 denitrification oxygen inhibition function (m3/kmol) + bkano3denit = 5e-6 ! Half-saturation constant for NO3 denitrification (kmol/m3) + + ! === Anammox + rano2anmx = 0.05*dtb ! Maximum growth rate (1/d) + q10anmx = 1.6 ! Q10 factor for anammox (-) + Trefanmx = 10. ! Reference temperature for anammox (degr C) + alphaanmx = 0.45e6 ! Shape factor for anammox oxygen inhibition function (m3/kmol) + bkoxanmx = 11.3e-6 ! Half-saturation constant for oxygen inhibition function (kmol/m3) + bkano2anmx = 5. ! Half-saturation constant for NO2 limitation (kmol/m3) + bkanh4anmx = bkano2anmx * 880./1144. !Half constant function for NH4 limitation + + !=========================================================================== end subroutine extNbioparam_init !================================================================================================================================== @@ -78,14 +101,16 @@ subroutine nitrification(kpie,kpje,kpke,pddpo,omask) !local variables integer :: i,j,k - + real :: anh4Tdep,ano2Tdep !$OMP PARALLEL DO PRIVATE(i,j,k) do j = 1,kpje do i = 1,kpie do k = 1,kpke if(pddpo(i,j,k) > dp_min .and. omask(i,j) > 0.5) then - + + + endif enddo enddo @@ -95,23 +120,40 @@ subroutine nitrification(kpie,kpje,kpke,pddpo,omask) end subroutine nitrification !================================================================================================================================== - subroutine denit_NO3_to_NO2(kpie,kpje,kpke,pddpo,omask) + subroutine denit_NO3_to_NO2(kpie,kpje,kpke,pddpo,omask,ptho) ! Denitrification / dissimilatory nitrate reduction (NO3 -> NO2) integer, intent(in) :: kpie,kpje,kpke real, intent(in) :: omask(kpie,kpje) real, intent(in) :: pddpo(kpie,kpje,kpke) + real, intent(in) :: ptho(kpie,kpje,kpke) !local variables integer :: i,j,k + real :: Tdep,O2inhib,nutlim,ano3new,ano3denit - - !$OMP PARALLEL DO PRIVATE(i,j,k) + !$OMP PARALLEL DO PRIVATE(i,j,k,Tdep,O2inhib,nutlim,ano3new,ano3denit) do j = 1,kpje do i = 1,kpie do k = 1,kpke if(pddpo(i,j,k) > dp_min .and. omask(i,j) > 0.5) then + Tdep = q10ano3denit**((ptho(i,j,k)-Trefano3denit)/10.) + O2inhib = 1. - tanh(sc_ano3denit*ocetra(i,j,k,ioxygen)) + nutlim = ocetra(i,j,k,iano3)/(ocetra(i,j,k,iano3) + bkano3denit) + + ano3new = ocetra(i,j,k,iano3)/(1. + rano3denit*Tdep*O2inhib*nutlim) + + ano3denit = min(ocetra(i,j,k,iano3) - ano3new, ocetra(i,j,k,idet)*280.) + + ocetra(i,j,k,iano3) = ocetra(i,j,k,iano3) - ano3denit + ocetra(i,j,k,iano2) = ocetra(i,j,k,iano2) + ano3denit + ocetra(i,j,k,idet) = ocetra(i,j,k,idet) - ano3denit/280. + ocetra(i,j,k,ianh4) = ocetra(i,j,k,ianh4) + ano3denit*16./280. + ocetra(i,j,k,isco212) = ocetra(i,j,k,isco212) + ano3denit*122./280. + ocetra(i,j,k,iphosph) = ocetra(i,j,k,iphosph) + ano3denit/280. + ocetra(i,j,k,iiron) = ocetra(i,j,k,iiron) + ano3denit*riron/280. + ocetra(i,j,k,ialkali) = ocetra(i,j,k,ialkali) + ano3denit*15./280. endif enddo enddo @@ -121,23 +163,45 @@ subroutine denit_NO3_to_NO2(kpie,kpje,kpke,pddpo,omask) end subroutine denit_NO3_to_NO2 !================================================================================================================================== - subroutine anammox(kpie,kpje,kpke,pddpo,omask) + subroutine anammox(kpie,kpje,kpke,pddpo,omask,ptho) ! Aanammox integer, intent(in) :: kpie,kpje,kpke real, intent(in) :: omask(kpie,kpje) real, intent(in) :: pddpo(kpie,kpje,kpke) + real, intent(in) :: ptho(kpie,kpje,kpke) !local variables integer :: i,j,k + real :: Tdep,O2inhib,nut1lim,nut2lim,ano2new,ano2anmx - !$OMP PARALLEL DO PRIVATE(i,j,k) + !$OMP PARALLEL DO PRIVATE(i,j,k,Tdep,O2inhib,nut1lim,nut2lim,ano2new,ano2anmx) do j = 1,kpje do i = 1,kpie do k = 1,kpke if(pddpo(i,j,k) > dp_min .and. omask(i,j) > 0.5) then - + + Tdep = q10anmx**((ptho(i,j,k)-Trefanmx)/10.) + O2inhib = 1. - exp(alphaanmx*(ocetra(i,j,k,ioxygen)-bkoxanmx))/(1.+ exp(alphaanmx*(ocetra(i,j,k,ioxygen)-bkoxanmx))) + nut1lim = ocetra(i,j,k,iano2)/(ocetra(i,j,k,iano2)+bkano2anmx) + nut2lim = ocetra(i,j,k,ianh4)/(ocetra(i,j,k,ianh4)+bkanh4anmx) + + ano2new = ocetra(i,j,k,iano2)/(1. + rano2anmx*Tdep*O2inhib*nut1lim*nut2lim) + + ano2anmx = min(ocetra(i,j,k,iano2) - ano2new, ocetra(i,j,k,ianh4)*1144./880., ocetra(i,j,k,isco212)*1144./122., & + & ocetra(i,j,k,iphosph)*1144., ocetra(i,j,k,iiron)*1144./(riron*16.), ocetra(i,j,k,ialkali)*1144./15.) + + ocetra(i,j,k,iano2) = ocetra(i,j,k,iano2) - ano2anmx + ocetra(i,j,k,ianh4) = ocetra(i,j,k,ianh4) - ano2anmx*880./1144. + ocetra(i,j,k,igasnit) = ocetra(i,j,k,igasnit) + ano2anmx*864./1144. + ocetra(i,j,k,iano3) = ocetra(i,j,k,iano3) + ano2anmx*280./1144. + ocetra(i,j,k,idet) = ocetra(i,j,k,idet) + ano2anmx/1144. + ocetra(i,j,k,isco212) = ocetra(i,j,k,isco212) - ano2anmx*122/1144. + ocetra(i,j,k,iphosph) = ocetra(i,j,k,iphosph) - ano2anmx/1144. + ocetra(i,j,k,iiron) = ocetra(i,j,k,iiron) - ano2anmx*riron*16./1144. + ocetra(i,j,k,ialkali) = ocetra(i,j,k,ialkali) - ano2anmx*15./1144. + endif enddo enddo @@ -170,12 +234,14 @@ subroutine denit_dnra(kpie,kpje,kpke,pddpo,omask) enddo !$OMP END PARALLEL DO end subroutine + !================================================================================================================================== subroutine extN_inv_check(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask,inv_message) + ! provide inventory calculation for extended nitrogen cycle + integer, intent(in) :: kpie,kpje,kpke real, intent(in) :: omask(kpie,kpje) - real, intent(in) :: pdlxp(kpie,kpje),pdlyp(kpie,kpje),pddpo(kpie,kpje,kpke) - + real, intent(in) :: pdlxp(kpie,kpje),pdlyp(kpie,kpje),pddpo(kpie,kpje,kpke) character (len=*),intent(in) :: inv_message #ifdef PBGC_OCNP_TIMESTEP @@ -187,6 +253,7 @@ subroutine extN_inv_check(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask,inv_message) #endif end subroutine extN_inv_check +!================================================================================================================================== END MODULE From f66f312fa170bd7331a45d32e09ca906bf7f43e0 Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Wed, 27 Apr 2022 17:07:06 +0200 Subject: [PATCH 065/366] DNRA and competing denitrification steps included, fixed anammox, mass conserving according to inventory check detritus limitation still missing --- hamocc/mo_extNbioproc.F90 | 123 +++++++++++++++++++++++++++++++++----- hamocc/ocprod.F90 | 4 +- 2 files changed, 109 insertions(+), 18 deletions(-) diff --git a/hamocc/mo_extNbioproc.F90 b/hamocc/mo_extNbioproc.F90 index 941ecdea..28fec684 100644 --- a/hamocc/mo_extNbioproc.F90 +++ b/hamocc/mo_extNbioproc.F90 @@ -61,9 +61,13 @@ MODULE mo_extNbioproc public :: extNbioparam_init,nitrification,denit_NO3_to_NO2,& & anammox,denit_dnra,extN_inv_check - real :: q10ano3denit,sc_ano3denit,Trefano3denit,rano3denit,bkano3denit, & - & rano2anmx,q10anmx,Trefanmx,alphaanmx,bkoxanmx,bkano2anmx,bkanh4anmx - + real :: q10ano3denit,sc_ano3denit,Trefano3denit,rano3denit,bkano3denit, & + & rano2anmx,q10anmx,Trefanmx,alphaanmx,bkoxanmx,bkano2anmx,bkanh4anmx, & + & rano2denit,q10ano2denit,Trefano2denit,bkoxano2denit,bkano2denit, & + & ran2odenit,q10an2odenit,Trefan2odenit,bkoxan2odenit,bkan2odenit, & + & rdnra,q10dnra,Trefdnra,bkoxdnra,bkdnra + + real :: eps CONTAINS @@ -73,31 +77,54 @@ subroutine extNbioparam_init() ! Initialization of model parameters for the extended nitrogen cycle ! === Denitrification step NO3 -> NO2: - rano3denit = 0.15*dtb ! Maximum growth rate (1/d) + rano3denit = 0.15*dtb ! Maximum growth rate denitrification on NO3 at reference T (1/d -> 1/dt) q10ano3denit = 2. ! Q10 factor for denitrification on NO3 (-) Trefano3denit = 10. ! Reference temperature for denitrification on NO3 (degr C) sc_ano3denit = 0.05e6 ! Shape factor for NO3 denitrification oxygen inhibition function (m3/kmol) bkano3denit = 5e-6 ! Half-saturation constant for NO3 denitrification (kmol/m3) ! === Anammox - rano2anmx = 0.05*dtb ! Maximum growth rate (1/d) + rano2anmx = 0.05*dtb ! Maximum growth rate for anammox at reference T (1/d -> 1/dt) q10anmx = 1.6 ! Q10 factor for anammox (-) Trefanmx = 10. ! Reference temperature for anammox (degr C) alphaanmx = 0.45e6 ! Shape factor for anammox oxygen inhibition function (m3/kmol) bkoxanmx = 11.3e-6 ! Half-saturation constant for oxygen inhibition function (kmol/m3) bkano2anmx = 5. ! Half-saturation constant for NO2 limitation (kmol/m3) - bkanh4anmx = bkano2anmx * 880./1144. !Half constant function for NH4 limitation - + bkanh4anmx = bkano2anmx * 880./1144. !Half-saturation constant for NH4 limitation of anammox (kmol/m3) + + ! === Denitrification step NO2 -> N2O + rano2denit = 0.12*dtb ! Maximum growth rate denitrification on NO2 at reference T (1/d -> 1/dt) + q10ano2denit = 2.0 ! Q10 factor for denitrification on NO2 (-) + Trefano2denit = 10. ! Reference temperature for denitrification on NO2 (degr C) + bkoxano2denit = 2.e-6 ! Half-saturation constant for (quadratic) oxygen inhibition function of denitrification on NO2 (kmol/m3) + bkano2denit = 5.6e-6 ! Half-saturation constant for denitrification on NO2 (kmol/m3) + + ! === Denitrification step N2O -> N2 + ran2odenit = 0.16*dtb ! Maximum growth rate denitrification on N2O at reference T (1/d -> 1/dt) + q10an2odenit = 3. ! Q1- factor for denitrificationj on N2O (-) + Trefan2odenit = 10. ! Reference temperature for denitrification on N2O (degr C) + bkoxan2odenit = 5e-6 ! Half-saturation constant for (quadratic) oxygen inhibition function of denitrification on N2O (kmol/m3) + bkan2odenit = 1e-6 ! Half-saturation constant for denitrification on N2O (kmol/m3) + + ! === DNRA NO2 -> NH4 + rdnra = 0.1*dtb ! Maximum growth rate DNRA on NO2 at reference T (1/d -> 1/dt) + q10dnra = 2. ! Q10 factor for DNRA on NO2 (-) + Trefdnra = 10. ! Reference temperature for DNRA (degr C) + bkoxdnra = 2.5e-6 ! Half saturation constant for (quadratic) oxygen inhibition function of DNRA on NO2 (kmol/m3) + bkdnra = 0.05e-6 ! Half-saturation constant for DNRA on NO2 (kmol/m3) + + eps = epsilon(1.) !=========================================================================== end subroutine extNbioparam_init !================================================================================================================================== - subroutine nitrification(kpie,kpje,kpke,pddpo,omask) + subroutine nitrification(kpie,kpje,kpke,pddpo,omask,ptho) ! Nitrification processes (NH4 -> NO2, NO2 -> NO3) integer, intent(in) :: kpie,kpje,kpke real, intent(in) :: omask(kpie,kpje) real, intent(in) :: pddpo(kpie,kpje,kpke) + real, intent(in) :: ptho(kpie,kpje,kpke) !local variables integer :: i,j,k @@ -144,7 +171,7 @@ subroutine denit_NO3_to_NO2(kpie,kpje,kpke,pddpo,omask,ptho) ano3new = ocetra(i,j,k,iano3)/(1. + rano3denit*Tdep*O2inhib*nutlim) - ano3denit = min(ocetra(i,j,k,iano3) - ano3new, ocetra(i,j,k,idet)*280.) + ano3denit = max(0.,min(ocetra(i,j,k,iano3) - ano3new, ocetra(i,j,k,idet)*280.)) ocetra(i,j,k,iano3) = ocetra(i,j,k,iano3) - ano3denit ocetra(i,j,k,iano2) = ocetra(i,j,k,iano2) + ano3denit @@ -189,15 +216,15 @@ subroutine anammox(kpie,kpje,kpke,pddpo,omask,ptho) ano2new = ocetra(i,j,k,iano2)/(1. + rano2anmx*Tdep*O2inhib*nut1lim*nut2lim) - ano2anmx = min(ocetra(i,j,k,iano2) - ano2new, ocetra(i,j,k,ianh4)*1144./880., ocetra(i,j,k,isco212)*1144./122., & - & ocetra(i,j,k,iphosph)*1144., ocetra(i,j,k,iiron)*1144./(riron*16.), ocetra(i,j,k,ialkali)*1144./15.) + ano2anmx = max(0.,min(ocetra(i,j,k,iano2) - ano2new, ocetra(i,j,k,ianh4)*1144./880., ocetra(i,j,k,isco212)*1144./122., & + & ocetra(i,j,k,iphosph)*1144., ocetra(i,j,k,iiron)*1144./(riron*16.), ocetra(i,j,k,ialkali)*1144./15.)) ocetra(i,j,k,iano2) = ocetra(i,j,k,iano2) - ano2anmx ocetra(i,j,k,ianh4) = ocetra(i,j,k,ianh4) - ano2anmx*880./1144. ocetra(i,j,k,igasnit) = ocetra(i,j,k,igasnit) + ano2anmx*864./1144. ocetra(i,j,k,iano3) = ocetra(i,j,k,iano3) + ano2anmx*280./1144. ocetra(i,j,k,idet) = ocetra(i,j,k,idet) + ano2anmx/1144. - ocetra(i,j,k,isco212) = ocetra(i,j,k,isco212) - ano2anmx*122/1144. + ocetra(i,j,k,isco212) = ocetra(i,j,k,isco212) - ano2anmx*122./1144. ocetra(i,j,k,iphosph) = ocetra(i,j,k,iphosph) - ano2anmx/1144. ocetra(i,j,k,iiron) = ocetra(i,j,k,iiron) - ano2anmx*riron*16./1144. ocetra(i,j,k,ialkali) = ocetra(i,j,k,ialkali) - ano2anmx*15./1144. @@ -211,23 +238,87 @@ subroutine anammox(kpie,kpje,kpke,pddpo,omask,ptho) end subroutine anammox !================================================================================================================================== - subroutine denit_dnra(kpie,kpje,kpke,pddpo,omask) + subroutine denit_dnra(kpie,kpje,kpke,pddpo,omask,ptho) ! Denitrification processes (NO2 -> N2O -> N2) and dissmilatory nitrite reduction (NO2 -> NH4) integer, intent(in) :: kpie,kpje,kpke real, intent(in) :: omask(kpie,kpje) real, intent(in) :: pddpo(kpie,kpje,kpke) + real, intent(in) :: ptho(kpie,kpje,kpke) !local variables integer :: i,j,k + real :: Tdepano2,O2inhibano2,nutlimano2,detlimano2,rpotano2denit,ano2denit + real :: Tdepdnra,O2inhibdnra,nutlimdnra,detlimdnra,rpotano2dnra,ano2dnra + real :: fdenit,fdnra,potano2new,potdano2,potddet,fdetano2denit,fdetan2odenit,fdetdnra + real :: Tdepan2o,O2inhiban2o,nutliman2o,detliman2o,an2onew,an2odenit + + !$OMP PARALLEL DO PRIVATE(i,j,k,Tdepano2,O2inhibano2,nutlimano2,detlimano2,ano2denit, & + !$OMP Tdepan2o,O2inhiban2o,nutliman2o,detliman2o,an2onew,an2odenit, & + !$OMP rpotano2denit,rpotano2dnra, & + !$OMP fdenit,fdnra,potano2new,potdano2,potddet,fdetano2denit, & + !$OMP fdetan2odenit,fdetdnra, & + !$OMP Tdepdnra,O2inhibdnra,nutlimdnra,detlimdnra,ano2dnra) - - !$OMP PARALLEL DO PRIVATE(i,j,k) do j = 1,kpje do i = 1,kpie do k = 1,kpke if(pddpo(i,j,k) > dp_min .and. omask(i,j) > 0.5) then - + + ! denitrification on NO2 + Tdepano2 = q10ano2denit**((ptho(i,j,k)-Trefano2denit)/10.) + O2inhibano2 = 1. - ocetra(i,j,k,ioxygen)**2./(ocetra(i,j,k,ioxygen)**2. + bkoxano2denit**2.) + nutlimano2 = ocetra(i,j,k,iano2)/(ocetra(i,j,k,iano2) + bkano2denit) + rpotano2denit = rano2denit*Tdepano2*O2inhibano2*nutlimano2 ! potential rate of denit + + ! DNRA on NO2 + Tdepdnra = q10dnra**((ptho(i,j,k)-Trefdnra)/10.) + O2inhibdnra = 1. - ocetra(i,j,k,ioxygen)**2./(ocetra(i,j,k,ioxygen)**2. + bkoxdnra**2.) + nutlimdnra = ocetra(i,j,k,iano2)/(ocetra(i,j,k,iano2) + bkdnra) + rpotano2dnra = rdnra*Tdepdnra*O2inhibdnra*nutlimdnra ! pot. rate of dnra + + ! === limitation due to NO2: + ! fraction on potential change: + fdenit = rpotano2denit/(rpotano2denit + rpotano2dnra) + fdnra = 1. - fdenit + + ! potential new conc of NO2 + potano2new = ocetra(i,j,k,iano2)/(1. + rpotano2denit + rpotano2dnra) + potdano2 = ocetra(i,j,k,iano2) - potano2new + + ! potential fractional change + ano2denit = fdenit * potdano2 + ano2dnra = fdnra * potdano2 + + ! === denitrification on N2O + Tdepan2o = q10an2odenit**((ptho(i,j,k)-Trefan2odenit)/10.) + O2inhiban2o = 1. - ocetra(i,j,k,ioxygen)**2./(ocetra(i,j,k,ioxygen)**2. + bkoxan2odenit**2.) + nutliman2o = ocetra(i,j,k,ian2o)/(ocetra(i,j,k,ian2o) + bkan2odenit) + an2onew = ocetra(i,j,k,ian2o)/(1. + ran2odenit*Tdepan2o*O2inhiban2o*nutliman2o) + an2odenit = ocetra(i,j,k,ian2o) - an2onew + + ! limitation of processes due to detritus + potddet = 1./280.*(ano2denit + an2odenit) + 1./(93. + 1./3)*ano2dnra ! P units + fdetano2denit = 1./280.*ano2denit/potddet + fdetan2odenit = 1./280.*an2odenit/potddet + fdetdnra = 1. - fdetano2denit - fdetan2odenit + potddet = max(0.,min(potddet,ocetra(i,j,k,idet))) + + ano2denit = fdetano2denit*280.*potddet + an2odenit = fdetan2odenit*280.*potddet + ano2dnra = fdetdnra * (93. + 1./3)*potddet + + ! change in tracer concentrations due to denit (NO2->N2O->N2) and DNRA (NO2->NH4) + ocetra(i,j,k,iano2) = ocetra(i,j,k,iano2) - ano2denit - ano2dnra + ocetra(i,j,k,ian2o) = ocetra(i,j,k,ian2o) - an2odenit + 0.5*ano2denit + ocetra(i,j,k,igasnit) = ocetra(i,j,k,igasnit) + an2odenit + ocetra(i,j,k,ianh4) = ocetra(i,j,k,ianh4) + 16./280. * (ano2denit+an2odenit) + (109.+1./3.)/(93.+1./3.)*ano2dnra + ocetra(i,j,k,idet) = ocetra(i,j,k,idet) - (ano2denit + an2odenit)/280. - ano2dnra/(93.+1./3.) + ocetra(i,j,k,isco212) = ocetra(i,j,k,isco212) + 122./280.*(ano2denit + an2odenit) + 122./(93.+1./3.) * ano2dnra + ocetra(i,j,k,iphosph) = ocetra(i,j,k,iphosph) + (ano2denit + an2odenit)/280. + ano2dnra/(93.+1./3.) + ocetra(i,j,k,iiron) = ocetra(i,j,k,iiron) + riron/280.*(ano2denit + an2odenit) + riron/(93.+1./3.) * ano2dnra + ocetra(i,j,k,ialkali) = ocetra(i,j,k,ialkali) + (295.*ano2denit + 15.*an2odenit)/280. & + & + (201.+1./3.)/(93.+1./3.) * ano2dnra endif enddo enddo diff --git a/hamocc/ocprod.F90 b/hamocc/ocprod.F90 index 5b81a7e4..f33c074c 100644 --- a/hamocc/ocprod.F90 +++ b/hamocc/ocprod.F90 @@ -829,7 +829,7 @@ subroutine ocprod(kpie,kpje,kpke,kbnd,pdlxp,pdlyp,pddpo,omask,dust,ptho) #else !======>>>> extended nitrogen cycle processes (aerobic and anaerobic) that follow ammonification inv_message = 'in OCPROD after extNcycle nitrification' - CALL nitrification(kpie,kpje,kpke,pddpo,omask) + CALL nitrification(kpie,kpje,kpke,pddpo,omask,ptho) CALL extN_inv_check(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask,inv_message) inv_message = 'in OCPROD after extNcycle denitrification NO3 -> NO2' @@ -841,7 +841,7 @@ subroutine ocprod(kpie,kpje,kpke,kbnd,pdlxp,pdlyp,pddpo,omask,dust,ptho) CALL extN_inv_check(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask,inv_message) inv_message = 'in OCPROD after extNcycle denitrification / DNRA' - CALL denit_dnra(kpie,kpje,kpke,pddpo,omask) + CALL denit_dnra(kpie,kpje,kpke,pddpo,omask,ptho) CALL extN_inv_check(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask,inv_message) #endif From 3c07ac0159c64df67e59bfd20149c7e45c31ce21 Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Fri, 29 Apr 2022 17:04:52 +0200 Subject: [PATCH 066/366] implemented nitrification processes --- hamocc/mo_extNbioproc.F90 | 103 +++++++++++++++++++++++++++++++++++--- 1 file changed, 96 insertions(+), 7 deletions(-) diff --git a/hamocc/mo_extNbioproc.F90 b/hamocc/mo_extNbioproc.F90 index 28fec684..1ad3e614 100644 --- a/hamocc/mo_extNbioproc.F90 +++ b/hamocc/mo_extNbioproc.F90 @@ -65,8 +65,10 @@ MODULE mo_extNbioproc & rano2anmx,q10anmx,Trefanmx,alphaanmx,bkoxanmx,bkano2anmx,bkanh4anmx, & & rano2denit,q10ano2denit,Trefano2denit,bkoxano2denit,bkano2denit, & & ran2odenit,q10an2odenit,Trefan2odenit,bkoxan2odenit,bkan2odenit, & - & rdnra,q10dnra,Trefdnra,bkoxdnra,bkdnra - + & rdnra,q10dnra,Trefdnra,bkoxdnra,bkdnra,ranh4nitr,q10anh4nitr, & + & Trefanh4nitr,bkoxamox,bkanh4nitr,bkamoxn2o,bkamoxno2,bkyamox, & + & rano2nitr,q10ano2nitr,Trefano2nitr,bkoxnitr,bkano2nitr,n2omaxy,n2oybeta + real :: eps CONTAINS @@ -113,13 +115,33 @@ subroutine extNbioparam_init() bkoxdnra = 2.5e-6 ! Half saturation constant for (quadratic) oxygen inhibition function of DNRA on NO2 (kmol/m3) bkdnra = 0.05e-6 ! Half-saturation constant for DNRA on NO2 (kmol/m3) + ! === Nitrification on NH4 + ranh4nitr = 1.*dtb ! Maximum growth rate nitrification on NH4 at reference T (1/d -> 1/dt) + q10anh4nitr = 3.3 ! Q10 factor for nitrification on NH4 (-) + Trefanh4nitr = 20. ! Reference temperature for nitrification on NH4 (degr C) + bkoxamox = 0.333e-6 ! Half-saturation constant for oxygen limitation of nitrification on NH4 (kmol/m3) + bkanh4nitr = 0.133e-6 ! Half-saturation constant for nitrification on NH4 (kmol/m3) + bkamoxn2o = 0.453e-6 ! Half saturation constant for pathway splitting function N2O for nitrification on NH4 (kmol/m3) + bkamoxno2 = 0.479e-6 ! Half saturation constant for pathway splitting function N2O for nitrification on NH4 (kmol/m3) + n2omaxy = 0.006 ! Maximum yield of OM on NH4 nitrification (-) + n2oybeta = 18.e-6 ! Half saturation constant for inhibition function for yield during nitrification on NH4 (kmol/m3) + bkyamox = 0.333e-6 ! Half saturation constant for pathway splitting function OM-yield for nitrification on NH4 (kmol/m3) + + ! === Nitrification on NO2 + rano2nitr = 1.54*dtb ! Maximum growth rate nitrification on NO2 at reference T (1/d -> 1/dt) + q10ano2nitr = 2.7 ! Q10 factor for nitrification on NO2 (-) + Trefano2nitr = 20. ! Reference temperature for nitrification on NO2 (degr C) + bkoxnitr = 0.788e-6 ! Half-saturation constant for oxygen limitation of nitrification on NO2 (kmol/m3) + bkano2nitr = 0.287e-6 ! Half-saturation constant for NO2 for nitrification on NO2 (kmol/m3) + eps = epsilon(1.) !=========================================================================== end subroutine extNbioparam_init !================================================================================================================================== subroutine nitrification(kpie,kpje,kpke,pddpo,omask,ptho) - ! Nitrification processes (NH4 -> NO2, NO2 -> NO3) + ! Nitrification processes (NH4 -> NO2, NO2 -> NO3) accompanied + ! by dark carbon fixation and O2-dependent N2O production integer, intent(in) :: kpie,kpje,kpke real, intent(in) :: omask(kpie,kpje) @@ -128,16 +150,83 @@ subroutine nitrification(kpie,kpje,kpke,pddpo,omask,ptho) !local variables integer :: i,j,k - real :: anh4Tdep,ano2Tdep + real :: Tdepanh4,O2limanh4,nut1lim,anh4new,potdnh4amox,fdetamox,fno2,fn2o,ftotnh4 + real :: Tdepano2,O2limano2,nut2lim,ano2new,potdno2nitr,fdetnitr,fno3,ftotno2 + real :: amoxfrac,nitrfrac,totd,amox,nitr + + + !$OMP PARALLEL DO PRIVATE(i,j,k,Tdepanh4,O2limanh4,nut1lim,anh4new,potdnh4amox,fdetamox,fno2,fn2o,ftotnh4, & + !$OMP Tdepano2,O2limano2,nut2lim,ano2new,potdno2nitr,fdetnitr,fno3,ftotno2,amoxfrac, & + !$OMP nitrfrac,totd,amox,nitr) - !$OMP PARALLEL DO PRIVATE(i,j,k) do j = 1,kpje do i = 1,kpie do k = 1,kpke if(pddpo(i,j,k) > dp_min .and. omask(i,j) > 0.5) then - - + ! Ammonium oxidation step of nitrification + Tdepanh4 = q10anh4nitr**((ptho(i,j,k)-Trefanh4nitr)/10.) + O2limanh4 = ocetra(i,j,k,ioxygen)/(ocetra(i,j,k,ioxygen) + bkoxamox) + nut1lim = ocetra(i,j,k,ianh4)/(ocetra(i,j,k,ianh4) + bkanh4nitr) + anh4new = ocetra(i,j,k,ianh4)/(1. + ranh4nitr*Tdepanh4*O2limanh4*nut1lim) + potdnh4amox = ocetra(i,j,k,ianh4) - anh4new + + ! pathway splitting functions according to Goreau 1980 + fn2o = 1. - ocetra(i,j,k,ioxygen)/(ocetra(i,j,k,ioxygen) + bkamoxn2o) + fno2 = ocetra(i,j,k,ioxygen)/(ocetra(i,j,k,ioxygen) + bkamoxno2) + fdetamox = n2omaxy*2.*(1. + n2oybeta)*ocetra(i,j,k,ioxygen)*bkyamox & + & /(ocetra(i,j,k,ioxygen)**2. + 2.*ocetra(i,j,k,ioxygen)*bkyamox + bkyamox**2.) + + ! normalization of pathway splitting functions to sum=1 + ftotnh4 = fn2o + fno2 + fdetamox + eps + fn2o = fn2o/ftotnh4 + fno2 = fno2/ftotnh4 + fdetamox = 1. - (fn2o + fno2) + + ! NO2 oxidizing step of nitrification + Tdepano2 = q10ano2nitr**((ptho(i,j,k)-Trefano2nitr)/10.) + O2limano2 = ocetra(i,j,k,ioxygen)/(ocetra(i,j,k,ioxygen) + bkoxnitr) + nut2lim = ocetra(i,j,k,iano2)/(ocetra(i,j,k,iano2) + bkano2nitr) + ano2new = ocetra(i,j,k,iano2)/(1. + rano2nitr*Tdepano2*O2limano2*nut2lim) + potdno2nitr = ocetra(i,j,k,iano2) - ano2new + + ! pathway splitting functions for NO2 nitrification - assuming to be the same as for NH4 + fno3 = fno2 + fn2o! no N2O prod in this step - NO2 enters instead NO3 + fdetnitr = fdetamox + + ! normalization of pathway splitting functions for NO2 nitrification + ftotno2 = fno2 + fdetamox + eps + fno3 = fno3/ftotno2 + fdetnitr = 1. - fno3 + + ! limitation of the two processes through available nutrients, etc. + totd = potdnh4amox + potdno2nitr + amoxfrac = potdnh4amox/(totd + eps) + nitrfrac = 1. - amoxfrac + totd = max(0., & + & min(totd, & + & ocetra(i,j,k,ianh4)/(amoxfrac + fdetamox*nitrfrac + eps), & ! ammonium + & ocetra(i,j,k,isco212)/((122./16.)*(fdetamox*amoxfrac + fdetnitr*nitrfrac) + eps), & !CO2 + & ocetra(i,j,k,iphosph)/((fdetamox*amoxfrac + fdetnitr*nitrfrac)/16. + eps), & !PO4 + & ocetra(i,j,k,iiron)/((fdetamox*amoxfrac + fdetnitr*nitrfrac)/(16.*riron) + eps), & !Fe + & ocetra(i,j,k,ioxygen) & + & /((1.5*fno2 + fn2o + 140./16.*fdetamox)*amoxfrac + (0.5*fno3 + 140./16.*fdetnitr)*nitrfrac +eps), & ! O2 + & ocetra(i,j,k,ialkali) & + & /((2.*fno2 + fn2o + 15./16.*fdetamox)*amoxfrac + (15./16.*fdetnitr)*nitrfrac + eps))) + amox = amoxfrac*totd + nitr = nitrfrac*totd + + ocetra(i,j,k,ianh4) = ocetra(i,j,k,ianh4) - amox - fdetnitr*nitr + ocetra(i,j,k,ian2o) = ocetra(i,j,k,ian2o) + 0.5*fn2o*amox + ocetra(i,j,k,iano2) = ocetra(i,j,k,iano2) + fno2*amox - nitr + ocetra(i,j,k,iano3) = ocetra(i,j,k,iano3) + nitr + ocetra(i,j,k,idet) = ocetra(i,j,k,idet) + fdetamox/16.*amox + fdetnitr/16.*nitr + ocetra(i,j,k,isco212) = ocetra(i,j,k,isco212) - 122./16.*fdetamox*amox - 122./16.*fdetnitr*nitr + ocetra(i,j,k,iphosph) = ocetra(i,j,k,iphosph) - fdetamox/16.*amox - fdetnitr/16.*nitr + ocetra(i,j,k,iiron) = ocetra(i,j,k,iiron) - riron/16.*fdetamox*amox - riron/16.*fdetnitr*nitr + ocetra(i,j,k,ioxygen) = ocetra(i,j,k,ioxygen) - (1.5*fno2 + fn2o - 140./16.*fdetamox)*fdetamox & + & - (0.5*fno3 - 140./16.*fdetnitr)*nitr + ocetra(i,j,k,ialkali) = ocetra(i,j,k,ialkali) - (2.*fno2 + fn2o + 15./16.*fdetamox)*amox - 15./16.*fdetnitr*nitr endif enddo enddo From 1a87783423a2ab13a74aed46bfba3f9f30fdca21 Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Wed, 4 May 2022 17:59:10 +0200 Subject: [PATCH 067/366] fix oxygen consumption during nitrification --- hamocc/mo_extNbioproc.F90 | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/hamocc/mo_extNbioproc.F90 b/hamocc/mo_extNbioproc.F90 index 1ad3e614..bdef76af 100644 --- a/hamocc/mo_extNbioproc.F90 +++ b/hamocc/mo_extNbioproc.F90 @@ -206,13 +206,13 @@ subroutine nitrification(kpie,kpje,kpke,pddpo,omask,ptho) totd = max(0., & & min(totd, & & ocetra(i,j,k,ianh4)/(amoxfrac + fdetamox*nitrfrac + eps), & ! ammonium - & ocetra(i,j,k,isco212)/((122./16.)*(fdetamox*amoxfrac + fdetnitr*nitrfrac) + eps), & !CO2 - & ocetra(i,j,k,iphosph)/((fdetamox*amoxfrac + fdetnitr*nitrfrac)/16. + eps), & !PO4 - & ocetra(i,j,k,iiron)/((fdetamox*amoxfrac + fdetnitr*nitrfrac)/(16.*riron) + eps), & !Fe + & ocetra(i,j,k,isco212)/((122./16.)*(fdetamox*amoxfrac + fdetnitr*nitrfrac) + eps), & ! CO2 + & ocetra(i,j,k,iphosph)/((fdetamox*amoxfrac + fdetnitr*nitrfrac)/16. + eps), & ! PO4 + & ocetra(i,j,k,iiron)/((fdetamox*amoxfrac + fdetnitr*nitrfrac)/(16.*riron) + eps), & ! Fe & ocetra(i,j,k,ioxygen) & - & /((1.5*fno2 + fn2o + 140./16.*fdetamox)*amoxfrac + (0.5*fno3 + 140./16.*fdetnitr)*nitrfrac +eps), & ! O2 + & /((1.5*fno2 + fn2o - 140./16.*fdetamox)*amoxfrac + (0.5*fno3 + 140./16.*fdetnitr)*nitrfrac +eps), & ! O2 & ocetra(i,j,k,ialkali) & - & /((2.*fno2 + fn2o + 15./16.*fdetamox)*amoxfrac + (15./16.*fdetnitr)*nitrfrac + eps))) + & /((2.*fno2 + fn2o + 15./16.*fdetamox)*amoxfrac + (15./16.*fdetnitr)*nitrfrac + eps))) ! alkalinity amox = amoxfrac*totd nitr = nitrfrac*totd @@ -224,7 +224,7 @@ subroutine nitrification(kpie,kpje,kpke,pddpo,omask,ptho) ocetra(i,j,k,isco212) = ocetra(i,j,k,isco212) - 122./16.*fdetamox*amox - 122./16.*fdetnitr*nitr ocetra(i,j,k,iphosph) = ocetra(i,j,k,iphosph) - fdetamox/16.*amox - fdetnitr/16.*nitr ocetra(i,j,k,iiron) = ocetra(i,j,k,iiron) - riron/16.*fdetamox*amox - riron/16.*fdetnitr*nitr - ocetra(i,j,k,ioxygen) = ocetra(i,j,k,ioxygen) - (1.5*fno2 + fn2o - 140./16.*fdetamox)*fdetamox & + ocetra(i,j,k,ioxygen) = ocetra(i,j,k,ioxygen) - (1.5*fno2 + fn2o - 140./16.*fdetamox)*amox & & - (0.5*fno3 - 140./16.*fdetnitr)*nitr ocetra(i,j,k,ialkali) = ocetra(i,j,k,ialkali) - (2.*fno2 + fn2o + 15./16.*fdetamox)*amox - 15./16.*fdetnitr*nitr endif From a6fab62bc717e431dce133a17373f97225c31207 Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Wed, 4 May 2022 18:03:23 +0200 Subject: [PATCH 068/366] implementation of ammonification for extNcycle --- hamocc/ocprod.F90 | 22 +++++++++++++++++++--- 1 file changed, 19 insertions(+), 3 deletions(-) diff --git a/hamocc/ocprod.F90 b/hamocc/ocprod.F90 index f33c074c..33f437c8 100644 --- a/hamocc/ocprod.F90 +++ b/hamocc/ocprod.F90 @@ -123,6 +123,7 @@ subroutine ocprod(kpie,kpje,kpke,kbnd,pdlxp,pdlyp,pddpo,omask,dust,ptho) #endif #ifdef extNcycle use mo_extNbioproc, only: nitrification,denit_NO3_to_NO2,anammox,denit_dnra,extN_inv_check + use mo_param1_bgc, only: ianh4 #endif @@ -635,9 +636,15 @@ subroutine ocprod(kpie,kpje,kpke,kbnd,pdlxp,pdlyp,pddpo,omask,dust,ptho) #endif if(ocetra(i,j,k,ioxygen) > 5.e-8) then +#ifndef extNcycle pocrem = MIN(drempoc*ocetra(i,j,k,idet),0.33*ocetra(i,j,k,ioxygen)/ro2ut) docrem = MIN( remido*ocetra(i,j,k,idoc),0.33*ocetra(i,j,k,ioxygen)/ro2ut) phyrem = MIN(0.5*dyphy*phythresh, 0.33*ocetra(i,j,k,ioxygen)/ro2ut) +#else + pocrem = MIN(drempoc*ocetra(i,j,k,idet),0.33*ocetra(i,j,k,ioxygen)/140.) + docrem = MIN( remido*ocetra(i,j,k,idoc),0.33*ocetra(i,j,k,ioxygen)/140.) + phyrem = MIN(0.5*dyphy*phythresh, 0.33*ocetra(i,j,k,ioxygen)/140.) +#endif #ifdef cisonew pocrem13 = pocrem*rdet13 pocrem14 = pocrem*rdet14 @@ -667,10 +674,16 @@ subroutine ocprod(kpie,kpje,kpke,kbnd,pdlxp,pdlyp,pddpo,omask,dust,ptho) remin = pocrem + docrem + phyrem ocetra(i,j,k,iphosph) = ocetra(i,j,k,iphosph)+remin +#ifndef extNcycle ocetra(i,j,k,iano3) = ocetra(i,j,k,iano3)+remin*rnit - ocetra(i,j,k,isco212) = ocetra(i,j,k,isco212)+rcar*remin ocetra(i,j,k,ialkali) = ocetra(i,j,k,ialkali)-(rnit+1)*remin ocetra(i,j,k,ioxygen) = ocetra(i,j,k,ioxygen)-ro2ut*remin +#else + ocetra(i,j,k,ianh4) = ocetra(i,j,k,ianh4) + remin*rnit + ocetra(i,j,k,ialkali) = ocetra(i,j,k,ialkali) + (rnit-1.)*remin + ocetra(i,j,k,ioxygen) = ocetra(i,j,k,ioxygen) - 140.*remin +#endif + ocetra(i,j,k,isco212) = ocetra(i,j,k,isco212)+rcar*remin ocetra(i,j,k,iiron) = ocetra(i,j,k,iiron)+remin*riron & & -relaxfe*MAX(ocetra(i,j,k,iiron)-fesoly,0.) #ifdef natDIC @@ -698,17 +711,20 @@ subroutine ocprod(kpie,kpje,kpke,kbnd,pdlxp,pdlyp,pddpo,omask,dust,ptho) ocetra(i,j,k,iopal) = ocetra(i,j,k,iopal)-opalrem ocetra(i,j,k,isilica) = ocetra(i,j,k,isilica)+opalrem +#ifndef extNcycle !*********************************************************************** ! There is about 1.e4 O2 on 1 N2O molecule (Broeker&Peng) ! refra : Tim Rixton, private communication !*********************************************************************** aou = satoxy(i,j,k)-ocetra(i,j,k,ioxygen) refra = 1.+3.*(0.5+sign(0.5,aou-1.97e-4)) - dms_bac = dmsp3 * dtb * abs(temp+3.) * ocetra(i,j,k,idms) & - & * (ocetra(i,j,k,idms) / (dmsp6+ocetra(i,j,k,idms))) ocetra(i,j,k,ian2o) = ocetra(i,j,k,ian2o)+remin*1.e-4*ro2ut*refra ocetra(i,j,k,igasnit) = ocetra(i,j,k,igasnit)-remin*1.e-4*ro2ut*refra ocetra(i,j,k,ioxygen) = ocetra(i,j,k,ioxygen)-remin*1.e-4*ro2ut*refra*0.5 +#endif + + dms_bac = dmsp3 * dtb * abs(temp+3.) * ocetra(i,j,k,idms) & + & * (ocetra(i,j,k,idms) / (dmsp6+ocetra(i,j,k,idms))) ocetra(i,j,k,idms) = ocetra(i,j,k,idms)-dms_bac dz = pddpo(i,j,k) From 1b82b3be63def553af24faff2454497ac65ed84c Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Wed, 11 May 2022 18:21:12 +0200 Subject: [PATCH 069/366] implementation of PP growth on NH4 and NO3, excretion and DOC remin to NH4 in euphotic zone --- hamocc/mo_extNbioproc.F90 | 15 +++++++++++++-- hamocc/ocprod.F90 | 37 +++++++++++++++++++++++++++++++++++-- 2 files changed, 48 insertions(+), 4 deletions(-) diff --git a/hamocc/mo_extNbioproc.F90 b/hamocc/mo_extNbioproc.F90 index bdef76af..271a98c6 100644 --- a/hamocc/mo_extNbioproc.F90 +++ b/hamocc/mo_extNbioproc.F90 @@ -58,8 +58,12 @@ MODULE mo_extNbioproc private + ! public functions public :: extNbioparam_init,nitrification,denit_NO3_to_NO2,& & anammox,denit_dnra,extN_inv_check + ! public parameters + public :: bkphyanh4,bkphyano3,bkphosph,bkiron + real :: q10ano3denit,sc_ano3denit,Trefano3denit,rano3denit,bkano3denit, & & rano2anmx,q10anmx,Trefanmx,alphaanmx,bkoxanmx,bkano2anmx,bkanh4anmx, & @@ -67,8 +71,9 @@ MODULE mo_extNbioproc & ran2odenit,q10an2odenit,Trefan2odenit,bkoxan2odenit,bkan2odenit, & & rdnra,q10dnra,Trefdnra,bkoxdnra,bkdnra,ranh4nitr,q10anh4nitr, & & Trefanh4nitr,bkoxamox,bkanh4nitr,bkamoxn2o,bkamoxno2,bkyamox, & - & rano2nitr,q10ano2nitr,Trefano2nitr,bkoxnitr,bkano2nitr,n2omaxy,n2oybeta - + & rano2nitr,q10ano2nitr,Trefano2nitr,bkoxnitr,bkano2nitr,n2omaxy, & + & n2oybeta,bkphyanh4,bkphyano3,bkphosph,bkiron + real :: eps CONTAINS @@ -78,6 +83,12 @@ subroutine extNbioparam_init() !=========================================================================== ! Initialization of model parameters for the extended nitrogen cycle + ! Phytoplankton growth + bkphyanh4 = 0.1e-6 ! Half-saturation constant for NH4 uptake by bulk phytoplankton (kmol/m3) + bkphyano3 = 0.16e-6 ! Half-saturation constant for NO3 uptake by bulk phytoplankton (kmol/m3) + bkphosph = 0.01e-6 ! Half-saturation constant for PO4 uptake by bulk phytoplankton (kmol/m3) + bkiron = bkphosph*riron ! Half-saturation constant for Fe uptake by bulk phytoplankton (kmol/m3) + ! === Denitrification step NO3 -> NO2: rano3denit = 0.15*dtb ! Maximum growth rate denitrification on NO3 at reference T (1/d -> 1/dt) q10ano3denit = 2. ! Q10 factor for denitrification on NO3 (-) diff --git a/hamocc/ocprod.F90 b/hamocc/ocprod.F90 index 33f437c8..1d48a76f 100644 --- a/hamocc/ocprod.F90 +++ b/hamocc/ocprod.F90 @@ -123,6 +123,7 @@ subroutine ocprod(kpie,kpje,kpke,kbnd,pdlxp,pdlyp,pddpo,omask,dust,ptho) #endif #ifdef extNcycle use mo_extNbioproc, only: nitrification,denit_NO3_to_NO2,anammox,denit_dnra,extN_inv_check + use mo_extNbioproc, only: bkphyanh4,bkphyano3,bkphosph,bkiron use mo_param1_bgc, only: ianh4 #endif @@ -201,6 +202,7 @@ subroutine ocprod(kpie,kpje,kpke,kbnd,pdlxp,pdlyp,pddpo,omask,dust,ptho) #endif #ifdef extNcycle character(len=:), allocatable :: inv_message + real :: ano3up_inh,nutlim,anh4lim,nlim,grlim,nh4uptfrac #endif @@ -344,6 +346,9 @@ subroutine ocprod(kpie,kpje,kpke,kbnd,pdlxp,pdlyp,pddpo,omask,dust,ptho) # ifdef BROMO !$OMP ,bro_beta,bro_uv & # endif +#ifdef extNcycle +!$OMP , ano3up_inh,nutlim,anh4lim,nlim,grlim,nh4uptfrac & +#endif !$OMP ,i,k) loop1: do j = 1,kpje @@ -368,12 +373,29 @@ subroutine ocprod(kpie,kpje,kpke,kbnd,pdlxp,pdlyp,pddpo,omask,dust,ptho) avgra = MAX(grami,ocetra(i,j,k,izoo)) ! 'available' zooplankton avsil = MAX(0.,ocetra(i,j,k,isilica)) avdic = MAX(0.,ocetra(i,j,k,isco212)) +#ifdef extNcycle + ano3up_inh = bkphyanh4/(bkphyanh4 + ocetra(i,j,k,ianh4)) ! inhibition of NO3 uptake + nutlim = min(ocetra(i,j,k,iphosph)/(ocetra(i,j,k,iphosph)+bkphosph),ocetra(i,j,k,iiron)/(ocetra(i,j,k,iiron)+bkiron)) + anh4lim = ocetra(i,j,k,ianh4)/(ocetra(i,j,k,ianh4) + bkphyanh4) + nlim = ano3up_inh*ocetra(i,j,k,iano3)/(ocetra(i,j,k,iano3) + bkphyano3) + anh4lim + grlim = min(nutlim,nlim) ! growth limitation + + nh4uptfrac = 1. + if(nlim .gt. 1.e-18) nh4uptfrac = anh4lim/nlim + ! re-check avnut - can sum N avail exceed indiv. contrib? + avanut = max(0.,min(ocetra(i,j,k,iphosph), ocetra(i,j,k,iiron)/riron, & + & rnoi*((1.-nh4uptfrac)*ocetra(i,j,k,iano3) + nh4uptfrac*ocetra(i,j,k,ianh4)))) + + xn = avphy/(1. - pho*grlim) ! phytoplankton growth + phosy = max(0.,min(xn-avphy,avanut)) ! limit PP growth to available nutr. +#else avanut = MAX(0.,MIN(ocetra(i,j,k,iphosph), & & rnoi*ocetra(i,j,k,iano3))) avanfe = MAX(0.,MIN(avanut,ocetra(i,j,k,iiron)/riron)) xa = avanfe xn = xa/(1.+pho*avphy/(xa+bkphy)) phosy = MAX(0.,xa-xn) +#endif phosy = MERGE(avdic/rcar, phosy, avdic <= rcar*phosy) ! limit phosy by available DIC ya = avphy+phosy yn = (ya+grazra*avgra*phytomi/(avphy+bkzoo)) & @@ -470,12 +492,23 @@ subroutine ocprod(kpie,kpje,kpke,kbnd,pdlxp,pdlyp,pddpo,omask,dust,ptho) dtr = bacfra-phosy+graton+ecan*zoomor ocetra(i,j,k,iphosph) = ocetra(i,j,k,iphosph)+dtr +#ifndef extNcycle ocetra(i,j,k,iano3) = ocetra(i,j,k,iano3)+dtr*rnit + ocetra(i,j,k,ialkali) = ocetra(i,j,k,ialkali)-2.*delcar-(rnit+1)*dtr + ocetra(i,j,k,ioxygen) = ocetra(i,j,k,ioxygen)-dtr*ro2ut +#else + ocetra(i,j,k,iano3) = ocetra(i,j,k,iano3) - (1.-nh4uptfrac)*phosy*rnit + ocetra(i,j,k,ianh4) = ocetra(i,j,k,ianh4) - nh4uptfrac*phosy*rnit + (dtr+phosy)*rnit + ocetra(i,j,k,ialkali) = ocetra(i,j,k,ialkali) - nh4uptfrac*phosy*(rnit-1.) & ! NH4 + PO4 Uptake + & + (1.-nh4uptfrac)*phosy*(rnit+1.) & ! NO3 + PO4 Uptake + & + (dtr+phosy)*(rnit-1.) - 2.*delcar ! Remin to (NH4 + PO4) and CaCO3 formation + ocetra(i,j,k,ioxygen) = ocetra(i,j,k,ioxygen) + nh4uptfrac*phosy*140. & ! NH4 uptake + & + (1.-nh4uptfrac)*phosy*ro2ut & ! NO3 uptake + & - (dtr+phosy)*140. ! Remin to NH4 +#endif ocetra(i,j,k,idet) = ocetra(i,j,k,idet)+export ocetra(i,j,k,idms) = ocetra(i,j,k,idms)+dmsprod-dms_bac-dms_uv ocetra(i,j,k,isco212) = ocetra(i,j,k,isco212)-delcar+rcar*dtr - ocetra(i,j,k,ialkali) = ocetra(i,j,k,ialkali)-2.*delcar-(rnit+1)*dtr - ocetra(i,j,k,ioxygen) = ocetra(i,j,k,ioxygen)-dtr*ro2ut ocetra(i,j,k,iphy) = ocetra(i,j,k,iphy)+phosy-grazing-phymor-exud ocetra(i,j,k,izoo) = ocetra(i,j,k,izoo)+grawa-excdoc-zoomor ocetra(i,j,k,idoc) = ocetra(i,j,k,idoc)-bacfra+excdoc+exud From a9a65168f93f061d384a259e7417a19b67b9a5c2 Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Wed, 11 May 2022 18:22:12 +0200 Subject: [PATCH 070/366] add missing pre-proc flag for extNcycle --- hamocc/accfields.F90 | 2 ++ 1 file changed, 2 insertions(+) diff --git a/hamocc/accfields.F90 b/hamocc/accfields.F90 index d1f2d85a..91d789d1 100644 --- a/hamocc/accfields.F90 +++ b/hamocc/accfields.F90 @@ -160,7 +160,9 @@ SUBROUTINE ACCFIELDS(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask) bgct2d(i,j,jo2flux) = bgct2d(i,j,jo2flux) + atmflx(i,j,iatmo2)/2.0 bgct2d(i,j,jn2flux) = bgct2d(i,j,jn2flux) + atmflx(i,j,iatmn2)/2.0 bgct2d(i,j,jn2oflux) = bgct2d(i,j,jn2oflux) + atmflx(i,j,iatmn2o)/2.0 +#ifdef extNcycle bgct2d(i,j,jnh3flux) = bgct2d(i,j,jnh3flux) + atmflx(i,j,iatmnh3)/2.0 +#endif bgct2d(i,j,jndep) = bgct2d(i,j,jndep) + ndepflx(i,j)/2.0 bgct2d(i,j,jirdin) = bgct2d(i,j,jirdin) + rivinflx(i,j,irdin)/2.0 bgct2d(i,j,jirdip) = bgct2d(i,j,jirdip) + rivinflx(i,j,irdip)/2.0 From ca2a893518768675f357e46cb395d029dcb3e170 Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Wed, 11 May 2022 18:25:48 +0200 Subject: [PATCH 071/366] fix: atn2ov now also/always available in non-extNcycle setup --- hamocc/carchm.F90 | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/hamocc/carchm.F90 b/hamocc/carchm.F90 index cd64943f..38338c88 100644 --- a/hamocc/carchm.F90 +++ b/hamocc/carchm.F90 @@ -147,7 +147,7 @@ SUBROUTINE CARCHM(kpie,kpje,kpke,kbnd, & REAL :: scco2,sco2,scn2,scdms,scn2o REAL :: Xconvxa REAL :: oxflux,niflux,dmsflux,n2oflux - REAL :: ato2,atn2,atco2,pco2 + REAL :: ato2,atn2,atco2,pco2,atn2ov REAL :: oxy,ani,anisa REAL :: rrho,t,t2,t3,t4,tk,tk100,prb,s,rs REAL :: Kh,Khd,K1,K2,Kb,K1p,K2p,K3p,Ksi,Kw,Ks1,Kf,Kspc,Kspa @@ -174,7 +174,7 @@ SUBROUTINE CARCHM(kpie,kpje,kpke,kbnd, & REAL :: flx_bromo,sch_bromo,kw_bromo,a_bromo,atbrf,Kb1,lsub #endif #ifdef extNcycle - REAL :: flx_nh3,sch_nh3_a,sch_nh3_w,kw_nh3,ka_nh3,atn2ov,atnh3,diff_nh3_a,diff_nh3_w,mu_air,mu_w,p_dbar,rho_air + REAL :: flx_nh3,sch_nh3_a,sch_nh3_w,kw_nh3,ka_nh3,atnh3,diff_nh3_a,diff_nh3_w,mu_air,mu_w,p_dbar,rho_air REAL :: h_nh3,hstar_nh3,pKa_nh3,eps_safe,Kh_nh3,cD_wind,u_star eps_safe = EPSILON(1.) #endif @@ -206,8 +206,8 @@ SUBROUTINE CARCHM(kpie,kpje,kpke,kbnd, & !$OMP PARALLEL DO PRIVATE(t,t2,t3,t4,tk,tk100,s,rs,prb,Kh,Khd,K1,K2 & !$OMP ,Kb,K1p,K2p,K3p,Ksi,Kw,Ks1,Kf,Kspc,Kspa,tc,ta,sit,pt,ah1,ac & !$OMP ,cu,cb,cc,pco2,rpp0,scco2,scdms,sco2,oxy,ani,anisa,Xconvxa & -!$OMP ,kwco2,kwdms,kwo2,atco2,ato2,atn2,fluxd,fluxu,oxflux,tc_sat & -!$OMP ,niflux,n2oflux,dmsflux,omega,supsat,undsa,dissol & +!$OMP ,kwco2,kwdms,kwo2,atco2,ato2,atn2,atn2ov,fluxd,fluxu,oxflux & +!$OMP ,tc_sat,niflux,n2oflux,dmsflux,omega,supsat,undsa,dissol & #ifdef CFC !$OMP ,sch_11,sch_12,sch_sf,kw_11,kw_12,kw_sf,a_11,a_12,a_sf,flx11 & !$OMP ,flx12,flxsf,atm_cfc11,atm_cfc12,atm_sf6 & @@ -224,7 +224,7 @@ SUBROUTINE CARCHM(kpie,kpje,kpke,kbnd, & !$OMP ,flx_bromo,sch_bromo,kw_bromo,a_bromo,atbrf,Kb1,lsub & #endif #ifdef extNcycle -!$OMP ,flx_nh3,sch_nh3_a,sch_nh3_w,kw_nh3,ka_nh3,atn2ov,atnh3 & +!$OMP ,flx_nh3,sch_nh3_a,sch_nh3_w,kw_nh3,ka_nh3,atnh3 & !$OMP ,diff_nh3_a,diff_nh3_w,mu_air,mu_w,p_dbar,rho_air,h_nh3 & !$OMP ,hstar_nh3,pKa_nh3,eps_safe,Kh_nh3,cD_wind,u_star & #endif From 4cd471fc9566e3296a1cdd17dc184746574fe154 Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Thu, 12 May 2022 18:18:58 +0200 Subject: [PATCH 072/366] FIRST VERY BASIC OUTPUT for extNcycle implemented --- hamocc/accfields.F90 | 24 ++++++++++--- hamocc/mo_bgcmean.F90 | 37 +++++++++++++++++++ hamocc/ncout_hamocc.F | 82 ++++++++++++++++++++++++++++++++++++++++--- 3 files changed, 133 insertions(+), 10 deletions(-) diff --git a/hamocc/accfields.F90 b/hamocc/accfields.F90 index 91d789d1..f95ffd52 100644 --- a/hamocc/accfields.F90 +++ b/hamocc/accfields.F90 @@ -28,7 +28,7 @@ SUBROUTINE ACCFIELDS(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask) ! ! Purpose ! ------- -! Accumulate fields for time-avaraged output and write output +! Accumulate fields for time-averaged output and write output ! ! ! @@ -106,8 +106,8 @@ SUBROUTINE ACCFIELDS(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask) & jpowno3,jsssc12,jssso12,jssssil,jssster,accbur,accsdm #endif #ifdef extNcycle - use mo_param1_bgc, only: iatmnh3 - use mo_bgcmean, only: jnh3flux + use mo_param1_bgc, only: iatmnh3,ianh4,iano2 + use mo_bgcmean, only: jnh3flux,janh3fx,janh4,jano2,jsrfanh4,jsrfano2,jlvlanh4,jlvlano2 #endif implicit none @@ -203,6 +203,9 @@ SUBROUTINE ACCFIELDS(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask) call accsrf(jatmc13,atm(1,1,iatmc13),omask,0) call accsrf(jatmc14,atm(1,1,iatmc14),omask,0) #endif +#ifdef extNcycle + call accsrf(janh3fx,atmflx(1,1,iatmnh3),omask,0) +#endif ! Save up and downward fluxes for CO2 seperately call accsrf(jco2fxd,co2fxd,omask,0) @@ -245,6 +248,10 @@ SUBROUTINE ACCFIELDS(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask) call accsrf(jbromo_prod,int_chbr3_prod,omask,0) call accsrf(jbromo_uv,int_chbr3_uv,omask,0) #endif +#ifdef extNcycle + call accsrf(jsrfanh4,ocetra(1,1,1,ianh4),omask,0) + call accsrf(jsrfano2,ocetra(1,1,1,iano2),omask,0) +#endif ! Accumulate the diagnostic mass sinking field IF( domassfluxes ) THEN @@ -331,7 +338,10 @@ SUBROUTINE ACCFIELDS(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask) #ifdef BROMO call acclyr(jbromo,ocetra(1,1,1,ibromo),pddpo,1) #endif - +#ifdef extNcycle + call acclyr(janh4,ocetra(1,1,1,ianh4),pddpo,1) + call acclyr(jano2,ocetra(1,1,1,iano2),pddpo,1) +#endif ! Accumulate level diagnostics IF (SUM(jlvlphyto+jlvlgrazer+jlvlphosph+jlvloxygen+jlvliron+ & @@ -342,7 +352,7 @@ SUBROUTINE ACCFIELDS(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask) & jlvlnatomegaa+jlvlnatomegac+jlvldic13+jlvldic14+jlvld13c+ & & jlvld14c+jlvlbigd14c+jlvlpoc13+jlvldoc13+jlvlcalc13+jlvlphyto13+& & jlvlgrazer13+jlvlnos+jlvlwphy+jlvlwnos+jlvleps+jlvlasize+ & - & jlvlcfc11+jlvlcfc12+jlvlsf6+jlvlbromo).NE.0) THEN + & jlvlcfc11+jlvlcfc12+jlvlsf6+jlvlbromo+jlvlanh4+jlvlano2).NE.0) THEN DO k=1,kpke call bgczlv(pddpo,k,ind1,ind2,wghts) call acclvl(jlvlphyto,ocetra(1,1,1,iphy),k,ind1,ind2,wghts) @@ -405,6 +415,10 @@ SUBROUTINE ACCFIELDS(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask) #endif #ifdef BROMO call acclvl(jlvlbromo,ocetra(1,1,1,ibromo),k,ind1,ind2,wghts) +#endif +#ifdef extNcycle + call acclvl(jlvlanh4,ocetra(1,1,1,ianh4),k,ind1,ind2,wghts) + call acclvl(jlvlano2,ocetra(1,1,1,iano2),k,ind1,ind2,wghts) #endif ENDDO ENDIF diff --git a/hamocc/mo_bgcmean.F90 b/hamocc/mo_bgcmean.F90 index b106b7c1..f9f159a6 100644 --- a/hamocc/mo_bgcmean.F90 +++ b/hamocc/mo_bgcmean.F90 @@ -90,6 +90,7 @@ MODULE mo_bgcmean & SRF_NATDIC =0 ,SRF_NATALKALI =0 ,SRF_NATPCO2 =0 , & & SRF_NATCO2FX =0 , & & SRF_ATMBROMO =0 ,SRF_BROMO =0 ,SRF_BROMOFX =0 , & + & SRF_ANH4 =0 ,SRF_ANO2 =0 ,SRF_ANH3FX =0 , & & INT_BROMOPRO =0 ,INT_BROMOUV =0 , & & INT_PHOSY =0 ,INT_NFIX =0 ,INT_DNIT =0 , & & FLX_CAR0100 =0 ,FLX_CAR0500 =0 ,FLX_CAR1000 =0 , & @@ -117,6 +118,7 @@ MODULE mo_bgcmean & LYR_D13C =0 ,LYR_D14C =0 ,LYR_BIGD14C =0 , & & LYR_POC13 =0 ,LYR_DOC13 =0 ,LYR_CALC13 =0 , & & LYR_PHYTO13 =0 ,LYR_GRAZER13 =0 , & + & LYR_ANH4 =0 ,LYR_ANO2 =0 , & & LVL_PHYTO =0 ,LVL_GRAZER =0 ,LVL_DOC =0 , & & LVL_PHOSY =0 ,LVL_PHOSPH =0 ,LVL_OXYGEN =0 , & & LVL_IRON =0 ,LVL_ANO3 =0 ,LVL_ALKALI =0 , & @@ -136,6 +138,7 @@ MODULE mo_bgcmean & LVL_D13C =0 ,LVL_D14C =0 ,LVL_BIGD14C =0 , & & LVL_POC13 =0 ,LVL_DOC13 =0 ,LVL_CALC13 =0 , & & LVL_PHYTO13 =0 ,LVL_GRAZER13 =0 , & + & LVL_ANH4 =0 ,LVL_ANO2 =0 , & & SDM_POWAIC =0 ,SDM_POWAAL =0 ,SDM_POWAPH =0 , & & SDM_POWAOX =0 ,SDM_POWN2 =0 ,SDM_POWNO3 =0 , & & SDM_POWASI =0 ,SDM_SSSO12 =0 ,SDM_SSSSIL =0 , & @@ -161,6 +164,7 @@ MODULE mo_bgcmean & SRF_NATDIC ,SRF_NATALKALI ,SRF_NATPCO2 , & & SRF_NATCO2FX , & & SRF_ATMBROMO ,SRF_BROMO ,SRF_BROMOFX , & + & SRF_ANH4 ,SRF_ANO2 ,SRF_ANH3FX , & & INT_BROMOPRO ,INT_BROMOUV , & & INT_PHOSY ,INT_NFIX ,INT_DNIT , & & FLX_CAR0100 ,FLX_CAR0500 ,FLX_CAR1000 , & @@ -188,6 +192,7 @@ MODULE mo_bgcmean & LYR_D13C ,LYR_D14C ,LYR_BIGD14C , & & LYR_PHYTO13 ,LYR_GRAZER13 ,LYR_POC13 , & & LYR_DOC13 ,LYR_CALC13 , & + & LYR_ANH4 ,LYR_ANO2 , & & LVL_PHYTO ,LVL_GRAZER ,LVL_DOC , & & LVL_PHOSY ,LVL_PHOSPH ,LVL_OXYGEN , & & LVL_IRON ,LVL_ANO3 ,LVL_ALKALI , & @@ -207,6 +212,7 @@ MODULE mo_bgcmean & LVL_D13C ,LVL_D14C ,LVL_BIGD14C , & & LVL_PHYTO13 ,LVL_GRAZER13 ,LVL_POC13 , & & LVL_DOC13 ,LVL_CALC13 , & + & LVL_ANH4 ,LVL_ANO2 , & & SDM_POWAIC ,SDM_POWAAL ,SDM_POWAPH , & & SDM_POWAOX ,SDM_POWN2 ,SDM_POWNO3 , & & SDM_POWASI ,SDM_SSSO12 ,SDM_SSSSIL , & @@ -308,6 +314,11 @@ MODULE mo_bgcmean & jbromo_prod= 0 , & & jbromo_uv = 0 + INTEGER, DIMENSION(nbgcmax), SAVE :: & + & janh3fx = 0 , & + & jsrfanh4 = 0 , & + & jsrfano2 + INTEGER, SAVE :: i_atm_m2d INTEGER, DIMENSION(nbgcmax), SAVE :: & & jatmco2 = 0 , & @@ -436,6 +447,12 @@ MODULE mo_bgcmean & jbromo = 0 , & & jlvlbromo = 0 + INTEGER, DIMENSION(nbgcmax), SAVE :: & + & janh4 = 0 , & + & jano2 = 0 , & + & jlvlanh4 = 0 , & + & jlvlano2 = 0 + INTEGER, SAVE :: nbgcm3d,nbgcm3dlvl !---------------------------------------------------------------- @@ -664,6 +681,14 @@ SUBROUTINE ALLOC_MEM_BGCMEAN(kpie,kpje,kpke) jbromo_prod(n)=i_bsc_m2d*min(1,INT_BROMOPRO(n)) IF (INT_BROMOUV(n).GT.0) i_bsc_m2d=i_bsc_m2d+1 jbromo_uv(n)=i_bsc_m2d*min(1,INT_BROMOUV(n)) +#endif +#ifdef extNcycle + IF (SRF_ANH3FX(n).GT.0) i_bsc_m2d=i_bsc_m2d+1 + janh3fx(n)=i_bsc_m2d*min(1,SRF_ANH3FX(n)) + IF (SRF_ANH4(n).GT.0) i_bsc_m2d=i_bsc_m2d+1 + jsrfanh4(n)=i_bsc_m2d*min(1,SRF_ANH4(n)) + IF (SRF_ANO2(n).GT.0) i_bsc_m2d=i_bsc_m2d+1 + jsrfano2(n)=i_bsc_m2d*min(1,SRF_ANO2(n)) #endif ENDDO @@ -817,6 +842,12 @@ SUBROUTINE ALLOC_MEM_BGCMEAN(kpie,kpje,kpke) IF (LYR_BROMO(n).GT.0) i_bsc_m3d=i_bsc_m3d+1 jbromo(n)=i_bsc_m3d*min(1,LYR_BROMO(n)) #endif +#ifdef extNcycle + IF (LYR_ANH4(n).GT.0) i_bsc_m3d=i_bsc_m3d+1 + janh4(n)=i_bsc_m3d*min(1,LYR_ANH4(n)) + IF (LYR_ANO2(n).GT.0) i_bsc_m3d=i_bsc_m3d+1 + jano2(n)=i_bsc_m3d*min(1,LYR_ANO2(n)) +#endif IF (LVL_PHYTO(n).GT.0) ilvl_bsc_m3d=ilvl_bsc_m3d+1 jlvlphyto(n)=ilvl_bsc_m3d*min(1,LVL_PHYTO(n)) @@ -930,6 +961,12 @@ SUBROUTINE ALLOC_MEM_BGCMEAN(kpie,kpje,kpke) IF (LVL_BROMO(n).GT.0) ilvl_bsc_m3d=ilvl_bsc_m3d+1 jlvlbromo(n)=ilvl_bsc_m3d*min(1,LVL_BROMO(n)) #endif +#ifdef extNcycle + IF (LVL_ANH4(n).GT.0) ilvl_bsc_m3d=ilvl_bsc_m3d+1 + jlvlanh4(n)=ilvl_bsc_m3d*min(1,LVL_ANH4(n)) + IF (LVL_ANO2(n).GT.0) ilvl_bsc_m3d=ilvl_bsc_m3d+1 + jlvlano2(n)=ilvl_bsc_m3d*min(1,LVL_ANO2(n)) +#endif IF (i_bsc_m3d.NE.0) checkdp(n)=1 ENDDO diff --git a/hamocc/ncout_hamocc.F b/hamocc/ncout_hamocc.F index be6e098e..11245993 100644 --- a/hamocc/ncout_hamocc.F +++ b/hamocc/ncout_hamocc.F @@ -103,7 +103,7 @@ subroutine ncwrt_bgc(iogrp) . glb_fnametag,filefq_bgc,diagfq_bgc, . filemon_bgc,fileann_bgc,ip,wrtlyr,wrtlvl, . loglyr,inilvl,inilyr,inisrf,loglvl, - , msklvl,wrtsrf,msksrf,finlyr + . msklvl,wrtsrf,msksrf,finlyr #ifdef AGG use mo_bgcmean, only: lyr_nos,lyr_wphy, lyr_wnos,lyr_eps, . lyr_asize,lvl_nos,lvl_wphy,lvl_wnos,lvl_eps, @@ -156,6 +156,12 @@ subroutine ncwrt_bgc(iogrp) . bur_sssc12,bur_ssssil,bur_ssster,bur_ssso12, . inisdm,inibur,wrtsdm,accbur,accsdm,wrtbur #endif +#ifdef extNcycle + use mo_bgcmean, only: janh4,jano2,jlvlanh4,jlvlano2,jsrfanh4, + . jsrfano2,janh3fx,srf_anh4,srf_ano2, + . srf_anh3fx,lyr_anh4,lyr_ano2,lvl_anh4, + . lvl_ano2 +#endif c implicit none c @@ -297,6 +303,10 @@ subroutine ncwrt_bgc(iogrp) #ifdef BROMO call finlyr(jbromo(iogrp),jdp(iogrp)) #endif +#ifdef extNcycle + call finlyr(janh4(iogrp),jdp(iogrp)) + call finlyr(jano2(iogrp),jdp(iogrp)) +#endif c c --- Mask sea floor in mass fluxes @@ -378,6 +388,10 @@ subroutine ncwrt_bgc(iogrp) #ifdef BROMO call msklvl(jlvlbromo(iogrp),depths) #endif +#ifdef extNcycle + call msklvl(jlvlanh4(iogrp),depths) + call msklvl(jlvlano2(iogrp),depths) +#endif c c --- Compute log10 of pH @@ -574,6 +588,16 @@ subroutine ncwrt_bgc(iogrp) call wrtsrf(jatmc14(iogrp),SRF_ATMC14(iogrp),rnacc,0.,cmpflg, . 'atmc14','Atmospheric 14CO2',' ','ppm') #endif +#ifdef extNcycle + call wrtsrf(jsrfanh4(iogrp),SRF_ANH4(iogrp), + . rnacc*1e3,0.,cmpflg,'srfnh4', + . 'Surface ammonium',' ','mol N m-3') + call wrtsrf(jsrfano2(iogrp),SRF_ANO2(iogrp), + . rnacc*1e3,0.,cmpflg,'srfno2', + . 'Surface nitrite',' ','mol N m-3') + call wrtsrf(janh3fx(iogrp),SRF_ANH3FX(iogrp),rnacc*1e3/dtbgc,0., + . cmpflg,'nh3flux','NH3 flux',' ','mol NH3 m-2 s-1') +#endif c c --- Store 3d layer fields call wrtlyr(jdp(iogrp),LYR_DP(iogrp),rnacc,0.,cmpflg, @@ -691,7 +715,12 @@ subroutine ncwrt_bgc(iogrp) call wrtlyr(jbromo(iogrp),LYR_BROMO(iogrp),1e3,0.,cmpflg, . 'bromo','Bromoform',' ','mol CHBr3 m-3') #endif - +#ifdef extNcycle + call wrtlyr(janh4(iogrp),LYR_ANH4(iogrp),1e3,0.,cmpflg, + . 'nh4','Ammonium',' ','mol N m-3') + call wrtlyr(jano2(iogrp),LYR_ANO2(iogrp),1e3,0.,cmpflg, + . 'no2','Nitrite',' ','mol N m-3') +#endif c c --- Store 3d level fields call wrtlvl(jlvldic(iogrp),LVL_DIC(iogrp),rnacc*1e3,0.,cmpflg, @@ -818,6 +847,12 @@ subroutine ncwrt_bgc(iogrp) call wrtlvl(jlvlbromo(iogrp),LVL_BROMO(iogrp),rnacc*1e3,0., . cmpflg,'bromolvl','Bromoform',' ','mol CHBr3 m-3') #endif +#ifdef extNcycle + call wrtlvl(jlvlanh4(iogrp),LVL_ANH4(iogrp),rnacc*1e3,0.,cmpflg, + . 'nh4lvl','Ammonium',' ','mol N m-3') + call wrtlvl(jlvlano2(iogrp),LVL_ANO2(iogrp),rnacc*1e3,0.,cmpflg, + . 'no2lvl','Nitrite',' ','mol N m-3') +#endif c c --- Store sediment fields @@ -939,6 +974,11 @@ subroutine ncwrt_bgc(iogrp) call inisrf(jatmc13(iogrp),0.) call inisrf(jatmc14(iogrp),0.) #endif +#ifdef extNcycle + call inisrf(jsrfanh4(iogrp),0.) + call inisrf(jsrfano2(iogrp),0.) + call inisrf(janh3fx(iogrp),0.) +#endif c call inilyr(jdp(iogrp),0.) call inilyr(jdic(iogrp),0.) @@ -1002,7 +1042,10 @@ subroutine ncwrt_bgc(iogrp) #ifdef BROMO call inilyr(jbromo(iogrp),0.) #endif - +#ifdef extNcycle + call inilyr(janh4(iogrp),0.) + call inilyr(jano2(iogrp),0.) +#endif c call inilvl(jlvldic(iogrp),0.) call inilvl(jlvlalkali(iogrp),0.) @@ -1065,7 +1108,10 @@ subroutine ncwrt_bgc(iogrp) #ifdef BROMO call inilvl(jlvlbromo(iogrp),0.) #endif - +#ifdef extNcycle + call inilvl(jlvlanh4(iogrp),0.) + call inilvl(jlvlano2(iogrp),0.) +#endif c #ifndef sedbypass call inisdm(jpowaic(iogrp),0.) @@ -1150,6 +1196,13 @@ subroutine hamoccvardef(iogrp,timeunits,calendar,cmpflg) . sdm_sssc12,sdm_ssster,bur_ssso12,bur_sssc12,bur_ssssil, . bur_ssster #endif +#ifdef extNcycle + use mo_bgcmean, only: janh4,jano2,jlvlanh4,jlvlano2,jsrfanh4, + . jsrfano2,janh3fx,srf_anh4,srf_ano2, + . srf_anh3fx,lyr_anh4,lyr_ano2,lvl_anh4, + . lvl_ano2 +#endif + implicit none integer iogrp,cmpflg character timeunits*30,calendar*19 @@ -1313,6 +1366,14 @@ subroutine hamoccvardef(iogrp,timeunits,calendar,cmpflg) call ncdefvar3d(SRF_ATMC14(iogrp),cmpflg,'p', . 'atmc14','Atmospheric 14CO2',' ','ppm',0) #endif +#ifdef extNcycle + call ncdefvar3d(SRF_ANH4(iogrp),cmpflg,'p','srfnh4', + . 'Surface ammonium',' ','mol N m-3',0) + call ncdefvar3d(SRF_ANO2(iogrp),cmpflg,'p','srfno2', + . 'Surface nitrite',' ','mol N m-3',0) + call ncdefvar3d(SRF_ANH3FX(iogrp),cmpflg,'p','nh3flux', + . 'NH3 flux',' ','mol NH3 m-2 s-1',0) +#endif c c --- define 3d layer fields call ncdefvar3d(LYR_DP(iogrp),cmpflg,'p', @@ -1429,7 +1490,12 @@ subroutine hamoccvardef(iogrp,timeunits,calendar,cmpflg) call ncdefvar3d(LYR_BROMO(iogrp),cmpflg,'p', . 'bromo','Bromoform',' ','mol CHBr3 m-3',1) #endif - +#ifdef extNcycle + call ncdefvar3d(LYR_ANH4(iogrp),cmpflg,'p', + . 'nh4','Ammonium',' ','mol N m-3',1) + call ncdefvar3d(LYR_ANO2(iogrp),cmpflg,'p', + . 'no2','Nitrite',' ','mol N m-3',1) +#endif c c --- define 3d level fields call ncdefvar3d(LVL_DIC(iogrp),cmpflg,'p', @@ -1544,6 +1610,12 @@ subroutine hamoccvardef(iogrp,timeunits,calendar,cmpflg) call ncdefvar3d(LVL_BROMO(iogrp),cmpflg,'p', . 'bromolvl','Bromoform',' ','mol CHBr3 m-3',2) #endif +#ifdef extNcycle + call ncdefvar3d(LVL_ANH4(iogrp),cmpflg,'p', + . 'nh4lvl','Ammonium',' ','mol N m-3',2) + call ncdefvar3d(LVL_ANO2(iogrp),cmpflg,'p', + . 'no2lvl','Nitrite',' ','mol N m-3',2) +#endif c c --- define sediment fields #ifndef sedbypass From d2787c99e6665e6ebf362a0cff5e3d503b776591 Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Fri, 13 May 2022 16:02:01 +0200 Subject: [PATCH 073/366] rechecked and fixed model parameters --- hamocc/mo_extNbioproc.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/hamocc/mo_extNbioproc.F90 b/hamocc/mo_extNbioproc.F90 index 271a98c6..14630703 100644 --- a/hamocc/mo_extNbioproc.F90 +++ b/hamocc/mo_extNbioproc.F90 @@ -102,7 +102,7 @@ subroutine extNbioparam_init() Trefanmx = 10. ! Reference temperature for anammox (degr C) alphaanmx = 0.45e6 ! Shape factor for anammox oxygen inhibition function (m3/kmol) bkoxanmx = 11.3e-6 ! Half-saturation constant for oxygen inhibition function (kmol/m3) - bkano2anmx = 5. ! Half-saturation constant for NO2 limitation (kmol/m3) + bkano2anmx = 5.e-6 ! Half-saturation constant for NO2 limitation (kmol/m3) bkanh4anmx = bkano2anmx * 880./1144. !Half-saturation constant for NH4 limitation of anammox (kmol/m3) ! === Denitrification step NO2 -> N2O @@ -135,7 +135,7 @@ subroutine extNbioparam_init() bkamoxn2o = 0.453e-6 ! Half saturation constant for pathway splitting function N2O for nitrification on NH4 (kmol/m3) bkamoxno2 = 0.479e-6 ! Half saturation constant for pathway splitting function N2O for nitrification on NH4 (kmol/m3) n2omaxy = 0.006 ! Maximum yield of OM on NH4 nitrification (-) - n2oybeta = 18.e-6 ! Half saturation constant for inhibition function for yield during nitrification on NH4 (kmol/m3) + n2oybeta = 18. ! Decay factor for inhibition function for yield during nitrification on NH4 (kmol/m3) bkyamox = 0.333e-6 ! Half saturation constant for pathway splitting function OM-yield for nitrification on NH4 (kmol/m3) ! === Nitrification on NO2 From ee2a842d86c1841d1d51cc6ee60af52b16b51f57 Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Fri, 13 May 2022 17:22:15 +0200 Subject: [PATCH 074/366] put BASIC OUTPUT as NAMELIST option --- cime_config/buildnml | 14 ++++++++++++++ 1 file changed, 14 insertions(+) diff --git a/cime_config/buildnml b/cime_config/buildnml index 436291a3..a3c50f72 100755 --- a/cime_config/buildnml +++ b/cime_config/buildnml @@ -365,6 +365,8 @@ set SRF_PHOSPH = '0, 2, 2' set SRF_OXYGEN = '0, 2, 2' set SRF_IRON = '0, 2, 2' set SRF_ANO3 = '0, 2, 2' +set SRF_ANO2 = '0, 2, 2' +set SRF_ANH4 = '0, 2, 2' set SRF_ALKALI = '4, 2, 2' set SRF_SILICA = '0, 2, 2' set SRF_DIC = '4, 2, 2' @@ -379,6 +381,7 @@ set SRF_CO2FXU = '4, 2, 2' set SRF_OXFLUX = '0, 2, 2' set SRF_NIFLUX = '0, 2, 2' set SRF_N2OFX = '0, 0, 2' +set SRF_ANH3FX = '0, 0, 2' set SRF_DMSFLUX = '0, 2, 2' set SRF_DMS = '0, 2, 2' set SRF_DMSPROD = '0, 2, 2' @@ -431,6 +434,8 @@ set LYR_PHOSPH = '0, 0, 2' set LYR_OXYGEN = '0, 0, 4' set LYR_IRON = '0, 0, 2' set LYR_ANO3 = '0, 0, 2' +set LYR_ANO2 = '0, 0, 2' +set LYR_ANH4 = '0, 0, 2' set LYR_ALKALI = '0, 0, 2' set LYR_SILICA = '0, 0, 2' set LYR_DIC = '0, 0, 2' @@ -483,6 +488,8 @@ set LVL_PHOSPH = '0, 2, 2' set LVL_OXYGEN = '0, 4, 4' set LVL_IRON = '0, 2, 2' set LVL_ANO3 = '0, 2, 2' +set LVL_ANO2 = '0, 2, 2' +set LVL_ANH4 = '0, 2, 2' set LVL_ALKALI = '0, 2, 2' set LVL_SILICA = '0, 2, 2' set LVL_DIC = '0, 2, 2' @@ -1523,6 +1530,8 @@ cat >>! $RUNDIR/ocn_in$inststr << EOF SRF_OXYGEN = $SRF_OXYGEN SRF_IRON = $SRF_IRON SRF_ANO3 = $SRF_ANO3 + SRF_ANO2 = $SRF_ANO2 + SRF_ANH4 = $SRF_ANH4 SRF_ALKALI = $SRF_ALKALI SRF_SILICA = $SRF_SILICA SRF_DIC = $SRF_DIC @@ -1537,6 +1546,7 @@ cat >>! $RUNDIR/ocn_in$inststr << EOF SRF_OXFLUX = $SRF_OXFLUX SRF_NIFLUX = $SRF_NIFLUX SRF_N2OFX = $SRF_N2OFX + SRF_ANH3FX = $SRF_ANH3FX SRF_DMSFLUX = $SRF_DMSFLUX SRF_DMS = $SRF_DMS SRF_DMSPROD = $SRF_DMSPROD @@ -1589,6 +1599,8 @@ cat >>! $RUNDIR/ocn_in$inststr << EOF LYR_OXYGEN = $LYR_OXYGEN LYR_IRON = $LYR_IRON LYR_ANO3 = $LYR_ANO3 + LYR_ANO2 = $LYR_ANO2 + LYR_ANH4 = $LYR_ANH4 LYR_ALKALI = $LYR_ALKALI LYR_SILICA = $LYR_SILICA LYR_DIC = $LYR_DIC @@ -1641,6 +1653,8 @@ cat >>! $RUNDIR/ocn_in$inststr << EOF LVL_OXYGEN = $LVL_OXYGEN LVL_IRON = $LVL_IRON LVL_ANO3 = $LVL_ANO3 + LVL_ANO2 = $LVL_ANO2 + LVL_ANH4 = $LVL_ANH4 LVL_ALKALI = $LVL_ALKALI LVL_SILICA = $LVL_SILICA LVL_DIC = $LVL_DIC From f9f75c96b70b340f2632fcdb26d13ff2c8fcc150 Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Fri, 13 May 2022 18:12:02 +0200 Subject: [PATCH 075/366] enable PREPROCESSOR directive for extNcycle via cime --- cime_config/buildcpp | 3 +++ cime_config/config_component.xml | 9 +++++++++ 2 files changed, 12 insertions(+) diff --git a/cime_config/buildcpp b/cime_config/buildcpp index 116c2fe8..cc98bf97 100644 --- a/cime_config/buildcpp +++ b/cime_config/buildcpp @@ -81,6 +81,7 @@ def buildcpp(case): tracers = case.get_value("BLOM_TRACER_MODULES") co2type = case.get_value("OCN_CO2_TYPE") hamocc_cfc = case.get_value("HAMOCC_CFC") + hamocc_extNcycle = case.get_value("HAMOCC_EXTNCYCLE") hamocc_nattrc = case.get_value("HAMOCC_NATTRC") hamocc_sedbypass = case.get_value("HAMOCC_SEDBYPASS") hamocc_ciso = case.get_value("HAMOCC_CISO") @@ -124,6 +125,8 @@ def buildcpp(case): blom_cppdefs = blom_cppdefs + " -DHAMOCC -DWLIN" if hamocc_cfc: blom_cppdefs = blom_cppdefs + " -DCFC" + if hamocc_extNcycle: + blom_cppdefs = blom_cppdefs + " -DextNcycle" if hamocc_nattrc: blom_cppdefs = blom_cppdefs + " -DnatDIC" if hamocc_sedbypass: diff --git a/cime_config/config_component.xml b/cime_config/config_component.xml index 8d5fe34a..50b1a4aa 100644 --- a/cime_config/config_component.xml +++ b/cime_config/config_component.xml @@ -148,6 +148,15 @@ Set preprocessor option to activate the carbon isotope code. Requires module ecosys + + logical + TRUE,FALSE + FALSE + build_component_blom + env_build.xml + Set preprocessor option to activate the extended nitrogen cycle code. Requires module ecosys + + logical TRUE,FALSE From 345c5ea248f4c0017538954d172d47f33309c7f5 Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Fri, 13 May 2022 19:13:00 +0200 Subject: [PATCH 076/366] amended output information to BASIC OUTPUT --- cime_config/buildnml | 3 +++ 1 file changed, 3 insertions(+) diff --git a/cime_config/buildnml b/cime_config/buildnml index a3c50f72..ade80923 100755 --- a/cime_config/buildnml +++ b/cime_config/buildnml @@ -1409,6 +1409,8 @@ cat >>! $RUNDIR/ocn_in$inststr << EOF ! ALKALI - Alkalinity (talk) [eq m-3] ! OXYGEN - Oxygen (o2) [mol O2 m-3] ! ANO3 - Nitrate (no3) [mol N m-3] +! ANO2 - Nitrite (no2) [mol N m-3] - extended N cycle only +! ANH4 - Ammonium (nh4) [mol N m-3] - extended N cycle only ! PHOSPH - Phosphorus (po4) [mol P m-3] ! IRON - Dissolved iron (dfe) [mol Fe m-3] ! SILICA - Silicate (si) [mol Si m-3] @@ -1472,6 +1474,7 @@ cat >>! $RUNDIR/ocn_in$inststr << EOF ! NIFLUX - Nitrogen flux (fgn2) [mol N2 m-2 s-1] ! OXFLUX - Oxygen flux (fgo2) [mol O2 m-2 s-1] ! N2OFX - Nitrous oxide flux [mol N2O m-2 s-1] +! ANH3FX - Ammonia flux [mol NH3 m-2 s-1] ! DMSFLUX - DMS flux (dmsflux) [mol DMS m-2 s-1] ! DMS - surface DMS concentration (dms) [mol DMS m-3] ! DMSPROD - DMS production (dmsprod) [mol DMS m-2 s-1] From feafaa415b624dbd9f00a3cd09d7dc2fe17b04fa Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Mon, 16 May 2022 15:17:16 +0200 Subject: [PATCH 077/366] Enable debug mode via cime --- cime_config/buildcpp | 3 +++ cime_config/config_component.xml | 9 +++++++++ hamocc/beleg_vars.F90 | 4 ++-- 3 files changed, 14 insertions(+), 2 deletions(-) diff --git a/cime_config/buildcpp b/cime_config/buildcpp index cc98bf97..3ec77c32 100644 --- a/cime_config/buildcpp +++ b/cime_config/buildcpp @@ -82,6 +82,7 @@ def buildcpp(case): co2type = case.get_value("OCN_CO2_TYPE") hamocc_cfc = case.get_value("HAMOCC_CFC") hamocc_extNcycle = case.get_value("HAMOCC_EXTNCYCLE") + hamocc_debug = case.get_value("HAMOCC_DEBUG") hamocc_nattrc = case.get_value("HAMOCC_NATTRC") hamocc_sedbypass = case.get_value("HAMOCC_SEDBYPASS") hamocc_ciso = case.get_value("HAMOCC_CISO") @@ -127,6 +128,8 @@ def buildcpp(case): blom_cppdefs = blom_cppdefs + " -DCFC" if hamocc_extNcycle: blom_cppdefs = blom_cppdefs + " -DextNcycle" + if hamocc_debug: + blom_cppdefs = blom_cppdefs + " -DPBGC_OCNP_TIMESTEP -DPBGC_CK_TIMESTEP" if hamocc_nattrc: blom_cppdefs = blom_cppdefs + " -DnatDIC" if hamocc_sedbypass: diff --git a/cime_config/config_component.xml b/cime_config/config_component.xml index 50b1a4aa..a047c2df 100644 --- a/cime_config/config_component.xml +++ b/cime_config/config_component.xml @@ -156,6 +156,15 @@ env_build.xml Set preprocessor option to activate the extended nitrogen cycle code. Requires module ecosys + + + logical + TRUE,FALSE + FALSE + build_component_blom + env_build.xml + Set preprocessor option to activate the debugging mode for iHAMOCC. Requires module ecosys + logical diff --git a/hamocc/beleg_vars.F90 b/hamocc/beleg_vars.F90 index 5a0a83e9..9600a16a 100644 --- a/hamocc/beleg_vars.F90 +++ b/hamocc/beleg_vars.F90 @@ -216,8 +216,8 @@ SUBROUTINE BELEG_VARS(kpaufr,kpie,kpje,kpke,kbnd,pddpo,prho,omask, & ocetra(i,j,k,ibromo)= 1.e-14/prho(i,j,k) #endif #ifdef extNcycle - ocetra(i,j,k,iano2) =1.9e-8/prho(i,j,k) - ocetra(i,j,k,ianh4) =2.9e-8/prho(i,j,k) + ocetra(i,j,k,iano2) =1.e-10 + ocetra(i,j,k,ianh4) =0.5e-10 #endif ENDIF ! omask > 0.5 From 53aa237b6a4f0759ab5d6651a3cf20d2df3f6a56 Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Mon, 16 May 2022 20:09:20 +0200 Subject: [PATCH 078/366] fix potential division by zero in DNRA/Denit --- hamocc/mo_extNbioproc.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/hamocc/mo_extNbioproc.F90 b/hamocc/mo_extNbioproc.F90 index 14630703..12dd40b4 100644 --- a/hamocc/mo_extNbioproc.F90 +++ b/hamocc/mo_extNbioproc.F90 @@ -399,8 +399,8 @@ subroutine denit_dnra(kpie,kpje,kpke,pddpo,omask,ptho) ! limitation of processes due to detritus potddet = 1./280.*(ano2denit + an2odenit) + 1./(93. + 1./3)*ano2dnra ! P units - fdetano2denit = 1./280.*ano2denit/potddet - fdetan2odenit = 1./280.*an2odenit/potddet + fdetano2denit = 1./280.*ano2denit/(potddet + eps) + fdetan2odenit = 1./280.*an2odenit/(potddet + eps) fdetdnra = 1. - fdetano2denit - fdetan2odenit potddet = max(0.,min(potddet,ocetra(i,j,k,idet))) From 0dbe337343cada0d008fe5946d18f00776cd9a8a Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Wed, 18 May 2022 10:43:51 +0200 Subject: [PATCH 079/366] potential fix of issues in DNRA/denit --- hamocc/mo_extNbioproc.F90 | 17 +++++++++-------- 1 file changed, 9 insertions(+), 8 deletions(-) diff --git a/hamocc/mo_extNbioproc.F90 b/hamocc/mo_extNbioproc.F90 index 12dd40b4..3e631876 100644 --- a/hamocc/mo_extNbioproc.F90 +++ b/hamocc/mo_extNbioproc.F90 @@ -378,35 +378,36 @@ subroutine denit_dnra(kpie,kpje,kpke,pddpo,omask,ptho) rpotano2dnra = rdnra*Tdepdnra*O2inhibdnra*nutlimdnra ! pot. rate of dnra ! === limitation due to NO2: - ! fraction on potential change: - fdenit = rpotano2denit/(rpotano2denit + rpotano2dnra) + ! fraction on potential change of NO2: + fdenit = rpotano2denit/(rpotano2denit + rpotano2dnra + eps) fdnra = 1. - fdenit - ! potential new conc of NO2 + ! potential new conc of NO2 due to denitrification and DNRA potano2new = ocetra(i,j,k,iano2)/(1. + rpotano2denit + rpotano2dnra) - potdano2 = ocetra(i,j,k,iano2) - potano2new + potdano2 = max(0.,min(ocetra(i,j,k,iano2), ocetra(i,j,k,iano2) - potano2new)) ! potential fractional change ano2denit = fdenit * potdano2 ano2dnra = fdnra * potdano2 ! === denitrification on N2O - Tdepan2o = q10an2odenit**((ptho(i,j,k)-Trefan2odenit)/10.) + Tdepan2o = q10an2odenit**((ptho(i,j,k)-Trefan2odenit)/10.) O2inhiban2o = 1. - ocetra(i,j,k,ioxygen)**2./(ocetra(i,j,k,ioxygen)**2. + bkoxan2odenit**2.) nutliman2o = ocetra(i,j,k,ian2o)/(ocetra(i,j,k,ian2o) + bkan2odenit) an2onew = ocetra(i,j,k,ian2o)/(1. + ran2odenit*Tdepan2o*O2inhiban2o*nutliman2o) - an2odenit = ocetra(i,j,k,ian2o) - an2onew + an2odenit = max(0.,min(ocetra(i,j,k,ian2o),ocetra(i,j,k,ian2o) - an2onew)) ! limitation of processes due to detritus - potddet = 1./280.*(ano2denit + an2odenit) + 1./(93. + 1./3)*ano2dnra ! P units + potddet = 1./280.*(ano2denit + an2odenit) + 1./(93. + 1./3.)*ano2dnra ! P units fdetano2denit = 1./280.*ano2denit/(potddet + eps) fdetan2odenit = 1./280.*an2odenit/(potddet + eps) fdetdnra = 1. - fdetano2denit - fdetan2odenit potddet = max(0.,min(potddet,ocetra(i,j,k,idet))) + ! change of NO2 and N2O in N units ano2denit = fdetano2denit*280.*potddet an2odenit = fdetan2odenit*280.*potddet - ano2dnra = fdetdnra * (93. + 1./3)*potddet + ano2dnra = fdetdnra * (93. + 1./3.)*potddet ! change in tracer concentrations due to denit (NO2->N2O->N2) and DNRA (NO2->NH4) ocetra(i,j,k,iano2) = ocetra(i,j,k,iano2) - ano2denit - ano2dnra From 6b2d80abc1723e8d3bfd12b5b5c7f20527044af4 Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Wed, 18 May 2022 17:12:33 +0200 Subject: [PATCH 080/366] increase epsilon value to potentially avoid issues in DNRA/denitr. --- hamocc/mo_extNbioproc.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/hamocc/mo_extNbioproc.F90 b/hamocc/mo_extNbioproc.F90 index 3e631876..53f16111 100644 --- a/hamocc/mo_extNbioproc.F90 +++ b/hamocc/mo_extNbioproc.F90 @@ -145,7 +145,7 @@ subroutine extNbioparam_init() bkoxnitr = 0.788e-6 ! Half-saturation constant for oxygen limitation of nitrification on NO2 (kmol/m3) bkano2nitr = 0.287e-6 ! Half-saturation constant for NO2 for nitrification on NO2 (kmol/m3) - eps = epsilon(1.) + eps = 1e-12 !=========================================================================== end subroutine extNbioparam_init From 62a6a5e3b3a924718ee2b0d900905ce8b7b6a625 Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Thu, 19 May 2022 15:11:29 +0200 Subject: [PATCH 081/366] introduce lower limit of zero to potential denit. and DNRA rates --- hamocc/mo_extNbioproc.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/hamocc/mo_extNbioproc.F90 b/hamocc/mo_extNbioproc.F90 index 53f16111..764b12a6 100644 --- a/hamocc/mo_extNbioproc.F90 +++ b/hamocc/mo_extNbioproc.F90 @@ -369,13 +369,13 @@ subroutine denit_dnra(kpie,kpje,kpke,pddpo,omask,ptho) Tdepano2 = q10ano2denit**((ptho(i,j,k)-Trefano2denit)/10.) O2inhibano2 = 1. - ocetra(i,j,k,ioxygen)**2./(ocetra(i,j,k,ioxygen)**2. + bkoxano2denit**2.) nutlimano2 = ocetra(i,j,k,iano2)/(ocetra(i,j,k,iano2) + bkano2denit) - rpotano2denit = rano2denit*Tdepano2*O2inhibano2*nutlimano2 ! potential rate of denit + rpotano2denit = max(0.,rano2denit*Tdepano2*O2inhibano2*nutlimano2) ! potential rate of denit ! DNRA on NO2 Tdepdnra = q10dnra**((ptho(i,j,k)-Trefdnra)/10.) O2inhibdnra = 1. - ocetra(i,j,k,ioxygen)**2./(ocetra(i,j,k,ioxygen)**2. + bkoxdnra**2.) nutlimdnra = ocetra(i,j,k,iano2)/(ocetra(i,j,k,iano2) + bkdnra) - rpotano2dnra = rdnra*Tdepdnra*O2inhibdnra*nutlimdnra ! pot. rate of dnra + rpotano2dnra = max(0.,rdnra*Tdepdnra*O2inhibdnra*nutlimdnra) ! pot. rate of dnra ! === limitation due to NO2: ! fraction on potential change of NO2: From 9e8bcb063c97e870d1eb446bef2b9926d6806738 Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Thu, 19 May 2022 15:28:01 +0200 Subject: [PATCH 082/366] potential speed up --- hamocc/mo_extNbioproc.F90 | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/hamocc/mo_extNbioproc.F90 b/hamocc/mo_extNbioproc.F90 index 764b12a6..3eb33e33 100644 --- a/hamocc/mo_extNbioproc.F90 +++ b/hamocc/mo_extNbioproc.F90 @@ -186,7 +186,7 @@ subroutine nitrification(kpie,kpje,kpke,pddpo,omask,ptho) fn2o = 1. - ocetra(i,j,k,ioxygen)/(ocetra(i,j,k,ioxygen) + bkamoxn2o) fno2 = ocetra(i,j,k,ioxygen)/(ocetra(i,j,k,ioxygen) + bkamoxno2) fdetamox = n2omaxy*2.*(1. + n2oybeta)*ocetra(i,j,k,ioxygen)*bkyamox & - & /(ocetra(i,j,k,ioxygen)**2. + 2.*ocetra(i,j,k,ioxygen)*bkyamox + bkyamox**2.) + & /(ocetra(i,j,k,ioxygen)**2 + 2.*ocetra(i,j,k,ioxygen)*bkyamox + bkyamox**2) ! normalization of pathway splitting functions to sum=1 ftotnh4 = fn2o + fno2 + fdetamox + eps @@ -367,13 +367,13 @@ subroutine denit_dnra(kpie,kpje,kpke,pddpo,omask,ptho) ! denitrification on NO2 Tdepano2 = q10ano2denit**((ptho(i,j,k)-Trefano2denit)/10.) - O2inhibano2 = 1. - ocetra(i,j,k,ioxygen)**2./(ocetra(i,j,k,ioxygen)**2. + bkoxano2denit**2.) + O2inhibano2 = 1. - ocetra(i,j,k,ioxygen)**2/(ocetra(i,j,k,ioxygen)**2 + bkoxano2denit**2) nutlimano2 = ocetra(i,j,k,iano2)/(ocetra(i,j,k,iano2) + bkano2denit) rpotano2denit = max(0.,rano2denit*Tdepano2*O2inhibano2*nutlimano2) ! potential rate of denit ! DNRA on NO2 Tdepdnra = q10dnra**((ptho(i,j,k)-Trefdnra)/10.) - O2inhibdnra = 1. - ocetra(i,j,k,ioxygen)**2./(ocetra(i,j,k,ioxygen)**2. + bkoxdnra**2.) + O2inhibdnra = 1. - ocetra(i,j,k,ioxygen)**2/(ocetra(i,j,k,ioxygen)**2 + bkoxdnra**2) nutlimdnra = ocetra(i,j,k,iano2)/(ocetra(i,j,k,iano2) + bkdnra) rpotano2dnra = max(0.,rdnra*Tdepdnra*O2inhibdnra*nutlimdnra) ! pot. rate of dnra @@ -392,7 +392,7 @@ subroutine denit_dnra(kpie,kpje,kpke,pddpo,omask,ptho) ! === denitrification on N2O Tdepan2o = q10an2odenit**((ptho(i,j,k)-Trefan2odenit)/10.) - O2inhiban2o = 1. - ocetra(i,j,k,ioxygen)**2./(ocetra(i,j,k,ioxygen)**2. + bkoxan2odenit**2.) + O2inhiban2o = 1. - ocetra(i,j,k,ioxygen)**2/(ocetra(i,j,k,ioxygen)**2 + bkoxan2odenit**2) nutliman2o = ocetra(i,j,k,ian2o)/(ocetra(i,j,k,ian2o) + bkan2odenit) an2onew = ocetra(i,j,k,ian2o)/(1. + ran2odenit*Tdepan2o*O2inhiban2o*nutliman2o) an2odenit = max(0.,min(ocetra(i,j,k,ian2o),ocetra(i,j,k,ian2o) - an2onew)) From 896fbd91122242890ccdd721ae3b3747573fb46b Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Fri, 20 May 2022 14:37:56 +0200 Subject: [PATCH 083/366] add subroutine name at end of routine --- hamocc/mo_extNbioproc.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/hamocc/mo_extNbioproc.F90 b/hamocc/mo_extNbioproc.F90 index 3eb33e33..ddcbf39e 100644 --- a/hamocc/mo_extNbioproc.F90 +++ b/hamocc/mo_extNbioproc.F90 @@ -425,7 +425,7 @@ subroutine denit_dnra(kpie,kpje,kpke,pddpo,omask,ptho) enddo enddo !$OMP END PARALLEL DO - end subroutine + end subroutine denit_dnra !================================================================================================================================== subroutine extN_inv_check(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask,inv_message) From 592dde3efadc16e1d4658776abb860e1438323fa Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Fri, 20 May 2022 15:11:35 +0200 Subject: [PATCH 084/366] disentangled denit and DNRA for DEBUGGING purposes - can be reverted at some point --- hamocc/mo_extNbioproc.F90 | 159 ++++++++++++++++++++++++++++++++++++++ hamocc/ocprod.F90 | 17 +++- 2 files changed, 174 insertions(+), 2 deletions(-) diff --git a/hamocc/mo_extNbioproc.F90 b/hamocc/mo_extNbioproc.F90 index ddcbf39e..5075624d 100644 --- a/hamocc/mo_extNbioproc.F90 +++ b/hamocc/mo_extNbioproc.F90 @@ -61,6 +61,8 @@ MODULE mo_extNbioproc ! public functions public :: extNbioparam_init,nitrification,denit_NO3_to_NO2,& & anammox,denit_dnra,extN_inv_check + + public :: denit_NO2,denit_N2O, dnra ! public parameters public :: bkphyanh4,bkphyano3,bkphosph,bkiron @@ -427,6 +429,163 @@ subroutine denit_dnra(kpie,kpje,kpke,pddpo,omask,ptho) !$OMP END PARALLEL DO end subroutine denit_dnra +!##### FOR DEBUGGING PURPOSES ONLY ################# + subroutine dnra(kpie,kpje,kpke,pddpo,omask,ptho) + ! Denitrification processes (N2O -> N2) + + integer, intent(in) :: kpie,kpje,kpke + real, intent(in) :: omask(kpie,kpje) + real, intent(in) :: pddpo(kpie,kpje,kpke) + real, intent(in) :: ptho(kpie,kpje,kpke) + + !local variables + integer :: i,j,k + real :: Tdepdnra,O2inhibdnra,nutlimdnra,rpotano2dnra,potano2new,potdano2,ano2dnra,potddet + + + !$OMP PARALLEL DO PRIVATE(i,j,k,Tdepdnra,O2inhibdnra,nutlimdnra,rpotano2dnra,potano2new,potdano2,ano2dnra,potddet) + + do j = 1,kpje + do i = 1,kpie + do k = 1,kpke + if(pddpo(i,j,k) > dp_min .and. omask(i,j) > 0.5) then + ! DNRA on NO2 + Tdepdnra = q10dnra**((ptho(i,j,k)-Trefdnra)/10.) + O2inhibdnra = 1. - ocetra(i,j,k,ioxygen)**2/(ocetra(i,j,k,ioxygen)**2 + bkoxdnra**2) + nutlimdnra = ocetra(i,j,k,iano2)/(ocetra(i,j,k,iano2) + bkdnra) + rpotano2dnra = max(0.,rdnra*Tdepdnra*O2inhibdnra*nutlimdnra) ! pot. rate of dnra + + ! potential new conc of NO2 due to denitrification and DNRA + potano2new = ocetra(i,j,k,iano2)/(1. + rpotano2dnra) + potdano2 = max(0.,min(ocetra(i,j,k,iano2), ocetra(i,j,k,iano2) - potano2new)) + + ! potential fractional change + ano2dnra = potdano2 + ! limitation of processes due to detritus + potddet = 1./(93. + 1./3.)*ano2dnra ! P units + potddet = max(0.,min(potddet,ocetra(i,j,k,idet))) + + ! change of NO2 and N2O in N units + ano2dnra = (93. + 1./3.)*potddet + + ! change in tracer concentrations due to denit (NO2->N2O->N2) and DNRA (NO2->NH4) + ocetra(i,j,k,iano2) = ocetra(i,j,k,iano2) - ano2dnra + ocetra(i,j,k,ianh4) = ocetra(i,j,k,ianh4) + (109.+1./3.)/(93.+1./3.)*ano2dnra + ocetra(i,j,k,idet) = ocetra(i,j,k,idet) - ano2dnra/(93.+1./3.) + ocetra(i,j,k,isco212) = ocetra(i,j,k,isco212) + 122./(93.+1./3.) * ano2dnra + ocetra(i,j,k,iphosph) = ocetra(i,j,k,iphosph) + ano2dnra/(93.+1./3.) + ocetra(i,j,k,iiron) = ocetra(i,j,k,iiron) + riron/(93.+1./3.) * ano2dnra + ocetra(i,j,k,ialkali) = ocetra(i,j,k,ialkali) + (201.+1./3.)/(93.+1./3.) * ano2dnra + endif + enddo + enddo + enddo + !$OMP END PARALLEL DO + end subroutine dnra + + !---------------------------------------------------------------- + subroutine denit_N2O(kpie,kpje,kpke,pddpo,omask,ptho) + ! Denitrification processes (N2O -> N2) + + integer, intent(in) :: kpie,kpje,kpke + real, intent(in) :: omask(kpie,kpje) + real, intent(in) :: pddpo(kpie,kpje,kpke) + real, intent(in) :: ptho(kpie,kpje,kpke) + + !local variables + integer :: i,j,k + real :: Tdepan2o,O2inhiban2o,nutliman2o,an2onew,an2odenit,potddet + !$OMP PARALLEL DO PRIVATE(i,j,k,Tdepan2o,O2inhiban2o,nutliman2o,an2onew,an2odenit,potddet) + do j = 1,kpje + do i = 1,kpie + do k = 1,kpke + if(pddpo(i,j,k) > dp_min .and. omask(i,j) > 0.5) then + ! === denitrification on N2O + Tdepan2o = q10an2odenit**((ptho(i,j,k)-Trefan2odenit)/10.) + O2inhiban2o = 1. - ocetra(i,j,k,ioxygen)**2/(ocetra(i,j,k,ioxygen)**2 + bkoxan2odenit**2) + nutliman2o = ocetra(i,j,k,ian2o)/(ocetra(i,j,k,ian2o) + bkan2odenit) + an2onew = ocetra(i,j,k,ian2o)/(1. + ran2odenit*Tdepan2o*O2inhiban2o*nutliman2o) + an2odenit = max(0.,min(ocetra(i,j,k,ian2o),ocetra(i,j,k,ian2o) - an2onew)) + + ! limitation of processes due to detritus + potddet = 1./280.*an2odenit !P units + potddet = max(0.,min(potddet,ocetra(i,j,k,idet))) + + ! change of N2O in N units + an2odenit = 280.*potddet + + ! change in tracer concentrations due to denit (NO2->N2O->N2) and DNRA (NO2->NH4) + ocetra(i,j,k,ian2o) = ocetra(i,j,k,ian2o) - an2odenit + ocetra(i,j,k,igasnit) = ocetra(i,j,k,igasnit) + an2odenit + ocetra(i,j,k,ianh4) = ocetra(i,j,k,ianh4) + 16./280. *an2odenit + ocetra(i,j,k,idet) = ocetra(i,j,k,idet) - an2odenit/280. + ocetra(i,j,k,isco212) = ocetra(i,j,k,isco212) + 122./280.*an2odenit + ocetra(i,j,k,iphosph) = ocetra(i,j,k,iphosph) + an2odenit/280. + ocetra(i,j,k,iiron) = ocetra(i,j,k,iiron) + riron/280.*an2odenit + ocetra(i,j,k,ialkali) = ocetra(i,j,k,ialkali) + 15.*an2odenit/280. + endif + enddo + enddo + enddo + !$OMP END PARALLEL DO + end subroutine denit_N2O + + !---------------------------------------------------------------- + subroutine denit_NO2(kpie,kpje,kpke,pddpo,omask,ptho) + ! Denitrification processes (NO2 -> N2O) + + integer, intent(in) :: kpie,kpje,kpke + real, intent(in) :: omask(kpie,kpje) + real, intent(in) :: pddpo(kpie,kpje,kpke) + real, intent(in) :: ptho(kpie,kpje,kpke) + + !local variables + integer :: i,j,k + real :: Tdepano2,O2inhibano2,nutlimano2,detlimano2,rpotano2denit,ano2denit,potddet,potano2new,potdano2 + + !$OMP PARALLEL DO PRIVATE(i,j,k,Tdepano2,O2inhibano2,nutlimano2,detlimano2,rpotano2denit,ano2denit,potddet,potano2new, & + !$OMP potdano2) + + do j = 1,kpje + do i = 1,kpie + do k = 1,kpke + if(pddpo(i,j,k) > dp_min .and. omask(i,j) > 0.5) then + ! denitrification on NO2 + Tdepano2 = q10ano2denit**((ptho(i,j,k)-Trefano2denit)/10.) + O2inhibano2 = 1. - ocetra(i,j,k,ioxygen)**2/(ocetra(i,j,k,ioxygen)**2 + bkoxano2denit**2) + nutlimano2 = ocetra(i,j,k,iano2)/(ocetra(i,j,k,iano2) + bkano2denit) + rpotano2denit = max(0.,rano2denit*Tdepano2*O2inhibano2*nutlimano2) ! potential rate of denit + + ! potential new conc of NO2 due to denitrification and DNRA + potano2new = ocetra(i,j,k,iano2)/(1. + rpotano2denit) + potdano2 = max(0.,min(ocetra(i,j,k,iano2), ocetra(i,j,k,iano2) - potano2new)) + ano2denit = potdano2 + + ! limitation of processes due to detritus + potddet = 1./280.*ano2denit ! P units + potddet = max(0.,min(potddet,ocetra(i,j,k,idet))) + + ! change of NO2 in N units + ano2denit = 280.*potddet + + ! change in tracer concentrations due to denit (NO2->N2O->N2) and DNRA (NO2->NH4) + ocetra(i,j,k,iano2) = ocetra(i,j,k,iano2) - ano2denit + ocetra(i,j,k,ian2o) = ocetra(i,j,k,ian2o) + 0.5*ano2denit + ocetra(i,j,k,ianh4) = ocetra(i,j,k,ianh4) + 16./280. * ano2denit + ocetra(i,j,k,idet) = ocetra(i,j,k,idet) - ano2denit/280. + ocetra(i,j,k,isco212) = ocetra(i,j,k,isco212) + 122./280.*ano2denit + ocetra(i,j,k,iphosph) = ocetra(i,j,k,iphosph) + ano2denit/280. + ocetra(i,j,k,iiron) = ocetra(i,j,k,iiron) + riron/280.*ano2denit + ocetra(i,j,k,ialkali) = ocetra(i,j,k,ialkali) + 295.*ano2denit/280. + endif + enddo + enddo + enddo + !$OMP END PARALLEL DO + end subroutine denit_NO2 + +!################################################### + !================================================================================================================================== subroutine extN_inv_check(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask,inv_message) ! provide inventory calculation for extended nitrogen cycle diff --git a/hamocc/ocprod.F90 b/hamocc/ocprod.F90 index 1d48a76f..04f3bbf9 100644 --- a/hamocc/ocprod.F90 +++ b/hamocc/ocprod.F90 @@ -123,6 +123,7 @@ subroutine ocprod(kpie,kpje,kpke,kbnd,pdlxp,pdlyp,pddpo,omask,dust,ptho) #endif #ifdef extNcycle use mo_extNbioproc, only: nitrification,denit_NO3_to_NO2,anammox,denit_dnra,extN_inv_check + use mo_extNbioproc, only: denit_NO2,denit_N2O,dnra use mo_extNbioproc, only: bkphyanh4,bkphyano3,bkphosph,bkiron use mo_param1_bgc, only: ianh4 #endif @@ -889,8 +890,20 @@ subroutine ocprod(kpie,kpje,kpke,kbnd,pdlxp,pdlyp,pddpo,omask,dust,ptho) CALL anammox(kpie,kpje,kpke,pddpo,omask,ptho) CALL extN_inv_check(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask,inv_message) - inv_message = 'in OCPROD after extNcycle denitrification / DNRA' - CALL denit_dnra(kpie,kpje,kpke,pddpo,omask,ptho) +! inv_message = 'in OCPROD after extNcycle denitrification / DNRA' +! CALL denit_dnra(kpie,kpje,kpke,pddpo,omask,ptho) +! CALL extN_inv_check(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask,inv_message) + + inv_message = 'in OCPROD after extNcycle denitrification NO2 ' + CALL denit_NO2(kpie,kpje,kpke,pddpo,omask,ptho) + CALL extN_inv_check(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask,inv_message) + + inv_message = 'in OCPROD after extNcycle denitrification DNRA ' + CALL dnra(kpie,kpje,kpke,pddpo,omask,ptho) + CALL extN_inv_check(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask,inv_message) + + inv_message = 'in OCPROD after extNcycle denitrification N2O ' + CALL denit_N2O(kpie,kpje,kpke,pddpo,omask,ptho) CALL extN_inv_check(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask,inv_message) #endif From f019a193e2262013170477f63b96fb58cc3fb1c1 Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Fri, 20 May 2022 16:57:33 +0200 Subject: [PATCH 085/366] further pot. fixes, removing j in OMP --- hamocc/mo_extNbioproc.F90 | 26 +++++++++++++------------- 1 file changed, 13 insertions(+), 13 deletions(-) diff --git a/hamocc/mo_extNbioproc.F90 b/hamocc/mo_extNbioproc.F90 index 5075624d..d61e31a3 100644 --- a/hamocc/mo_extNbioproc.F90 +++ b/hamocc/mo_extNbioproc.F90 @@ -96,7 +96,7 @@ subroutine extNbioparam_init() q10ano3denit = 2. ! Q10 factor for denitrification on NO3 (-) Trefano3denit = 10. ! Reference temperature for denitrification on NO3 (degr C) sc_ano3denit = 0.05e6 ! Shape factor for NO3 denitrification oxygen inhibition function (m3/kmol) - bkano3denit = 5e-6 ! Half-saturation constant for NO3 denitrification (kmol/m3) + bkano3denit = 5.e-6 ! Half-saturation constant for NO3 denitrification (kmol/m3) ! === Anammox rano2anmx = 0.05*dtb ! Maximum growth rate for anammox at reference T (1/d -> 1/dt) @@ -118,8 +118,8 @@ subroutine extNbioparam_init() ran2odenit = 0.16*dtb ! Maximum growth rate denitrification on N2O at reference T (1/d -> 1/dt) q10an2odenit = 3. ! Q1- factor for denitrificationj on N2O (-) Trefan2odenit = 10. ! Reference temperature for denitrification on N2O (degr C) - bkoxan2odenit = 5e-6 ! Half-saturation constant for (quadratic) oxygen inhibition function of denitrification on N2O (kmol/m3) - bkan2odenit = 1e-6 ! Half-saturation constant for denitrification on N2O (kmol/m3) + bkoxan2odenit = 5.e-6 ! Half-saturation constant for (quadratic) oxygen inhibition function of denitrification on N2O (kmol/m3) + bkan2odenit = 1.e-6 ! Half-saturation constant for denitrification on N2O (kmol/m3) ! === DNRA NO2 -> NH4 rdnra = 0.1*dtb ! Maximum growth rate DNRA on NO2 at reference T (1/d -> 1/dt) @@ -147,7 +147,7 @@ subroutine extNbioparam_init() bkoxnitr = 0.788e-6 ! Half-saturation constant for oxygen limitation of nitrification on NO2 (kmol/m3) bkano2nitr = 0.287e-6 ! Half-saturation constant for NO2 for nitrification on NO2 (kmol/m3) - eps = 1e-12 + eps = 1.e-12 !=========================================================================== end subroutine extNbioparam_init @@ -168,7 +168,7 @@ subroutine nitrification(kpie,kpje,kpke,pddpo,omask,ptho) real :: amoxfrac,nitrfrac,totd,amox,nitr - !$OMP PARALLEL DO PRIVATE(i,j,k,Tdepanh4,O2limanh4,nut1lim,anh4new,potdnh4amox,fdetamox,fno2,fn2o,ftotnh4, & + !$OMP PARALLEL DO PRIVATE(i,k,Tdepanh4,O2limanh4,nut1lim,anh4new,potdnh4amox,fdetamox,fno2,fn2o,ftotnh4, & !$OMP Tdepano2,O2limano2,nut2lim,ano2new,potdno2nitr,fdetnitr,fno3,ftotno2,amoxfrac, & !$OMP nitrfrac,totd,amox,nitr) @@ -182,7 +182,7 @@ subroutine nitrification(kpie,kpje,kpke,pddpo,omask,ptho) O2limanh4 = ocetra(i,j,k,ioxygen)/(ocetra(i,j,k,ioxygen) + bkoxamox) nut1lim = ocetra(i,j,k,ianh4)/(ocetra(i,j,k,ianh4) + bkanh4nitr) anh4new = ocetra(i,j,k,ianh4)/(1. + ranh4nitr*Tdepanh4*O2limanh4*nut1lim) - potdnh4amox = ocetra(i,j,k,ianh4) - anh4new + potdnh4amox = max(0.,ocetra(i,j,k,ianh4) - anh4new) ! pathway splitting functions according to Goreau 1980 fn2o = 1. - ocetra(i,j,k,ioxygen)/(ocetra(i,j,k,ioxygen) + bkamoxn2o) @@ -201,7 +201,7 @@ subroutine nitrification(kpie,kpje,kpke,pddpo,omask,ptho) O2limano2 = ocetra(i,j,k,ioxygen)/(ocetra(i,j,k,ioxygen) + bkoxnitr) nut2lim = ocetra(i,j,k,iano2)/(ocetra(i,j,k,iano2) + bkano2nitr) ano2new = ocetra(i,j,k,iano2)/(1. + rano2nitr*Tdepano2*O2limano2*nut2lim) - potdno2nitr = ocetra(i,j,k,iano2) - ano2new + potdno2nitr = max(0.,ocetra(i,j,k,iano2) - ano2new) ! pathway splitting functions for NO2 nitrification - assuming to be the same as for NH4 fno3 = fno2 + fn2o! no N2O prod in this step - NO2 enters instead NO3 @@ -261,7 +261,7 @@ subroutine denit_NO3_to_NO2(kpie,kpje,kpke,pddpo,omask,ptho) integer :: i,j,k real :: Tdep,O2inhib,nutlim,ano3new,ano3denit - !$OMP PARALLEL DO PRIVATE(i,j,k,Tdep,O2inhib,nutlim,ano3new,ano3denit) + !$OMP PARALLEL DO PRIVATE(i,k,Tdep,O2inhib,nutlim,ano3new,ano3denit) do j = 1,kpje do i = 1,kpie do k = 1,kpke @@ -305,7 +305,7 @@ subroutine anammox(kpie,kpje,kpke,pddpo,omask,ptho) real :: Tdep,O2inhib,nut1lim,nut2lim,ano2new,ano2anmx - !$OMP PARALLEL DO PRIVATE(i,j,k,Tdep,O2inhib,nut1lim,nut2lim,ano2new,ano2anmx) + !$OMP PARALLEL DO PRIVATE(i,k,Tdep,O2inhib,nut1lim,nut2lim,ano2new,ano2anmx) do j = 1,kpje do i = 1,kpie do k = 1,kpke @@ -355,7 +355,7 @@ subroutine denit_dnra(kpie,kpje,kpke,pddpo,omask,ptho) real :: fdenit,fdnra,potano2new,potdano2,potddet,fdetano2denit,fdetan2odenit,fdetdnra real :: Tdepan2o,O2inhiban2o,nutliman2o,detliman2o,an2onew,an2odenit - !$OMP PARALLEL DO PRIVATE(i,j,k,Tdepano2,O2inhibano2,nutlimano2,detlimano2,ano2denit, & + !$OMP PARALLEL DO PRIVATE(i,k,Tdepano2,O2inhibano2,nutlimano2,detlimano2,ano2denit, & !$OMP Tdepan2o,O2inhiban2o,nutliman2o,detliman2o,an2onew,an2odenit, & !$OMP rpotano2denit,rpotano2dnra, & !$OMP fdenit,fdnra,potano2new,potdano2,potddet,fdetano2denit, & @@ -443,7 +443,7 @@ subroutine dnra(kpie,kpje,kpke,pddpo,omask,ptho) real :: Tdepdnra,O2inhibdnra,nutlimdnra,rpotano2dnra,potano2new,potdano2,ano2dnra,potddet - !$OMP PARALLEL DO PRIVATE(i,j,k,Tdepdnra,O2inhibdnra,nutlimdnra,rpotano2dnra,potano2new,potdano2,ano2dnra,potddet) + !$OMP PARALLEL DO PRIVATE(i,k,Tdepdnra,O2inhibdnra,nutlimdnra,rpotano2dnra,potano2new,potdano2,ano2dnra,potddet) do j = 1,kpje do i = 1,kpie @@ -495,7 +495,7 @@ subroutine denit_N2O(kpie,kpje,kpke,pddpo,omask,ptho) !local variables integer :: i,j,k real :: Tdepan2o,O2inhiban2o,nutliman2o,an2onew,an2odenit,potddet - !$OMP PARALLEL DO PRIVATE(i,j,k,Tdepan2o,O2inhiban2o,nutliman2o,an2onew,an2odenit,potddet) + !$OMP PARALLEL DO PRIVATE(i,k,Tdepan2o,O2inhiban2o,nutliman2o,an2onew,an2odenit,potddet) do j = 1,kpje do i = 1,kpie do k = 1,kpke @@ -543,7 +543,7 @@ subroutine denit_NO2(kpie,kpje,kpke,pddpo,omask,ptho) integer :: i,j,k real :: Tdepano2,O2inhibano2,nutlimano2,detlimano2,rpotano2denit,ano2denit,potddet,potano2new,potdano2 - !$OMP PARALLEL DO PRIVATE(i,j,k,Tdepano2,O2inhibano2,nutlimano2,detlimano2,rpotano2denit,ano2denit,potddet,potano2new, & + !$OMP PARALLEL DO PRIVATE(i,k,Tdepano2,O2inhibano2,nutlimano2,detlimano2,rpotano2denit,ano2denit,potddet,potano2new, & !$OMP potdano2) do j = 1,kpje From 6a0073571d64182d600ae133af55ee5c0951abf6 Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Fri, 20 May 2022 17:44:15 +0200 Subject: [PATCH 086/366] fix availability of jlvlano2 and jlvlanh4 in standard setup --- hamocc/accfields.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/hamocc/accfields.F90 b/hamocc/accfields.F90 index f95ffd52..6dfa7858 100644 --- a/hamocc/accfields.F90 +++ b/hamocc/accfields.F90 @@ -64,7 +64,7 @@ SUBROUTINE ACCFIELDS(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask) & jniflux,jnos,jo2flux,jo2sat,jomegaa,jomegac,jopal,joxflux,joxygen,jpco2,jph,jphosph,jphosy,jphyto, & & jpoc,jprefalk,jprefdic,jprefo2,jprefpo4,jsilica,jsrfalkali,jsrfano3,jsrfdic,jsrfiron,jsrfoxygen, & & jsrfphosph,jsrfphyto,jsrfsilica,jwnos,jwphy,nbgc,nacc_bgc,bgcwrt,glb_inventory,bgct2d,acclvl, & - & acclyr,accsrf,bgczlv + & acclyr,accsrf,bgczlv,jlvlanh4,jlvlano2 use mo_control_bgc, only: io_stdo_bgc use mo_param1_bgc, only: ialkali,ian2o,iano3,iatmco2,iatmdms,iatmn2,iatmn2o,iatmo2,icalc,idet,idms,idicsat,idoc,iiron,iopal,& & ioxygen,iphosph,iphy,iprefalk,iprefdic,iprefpo4,iprefo2,isco212,isilica,izoo @@ -107,7 +107,7 @@ SUBROUTINE ACCFIELDS(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask) #endif #ifdef extNcycle use mo_param1_bgc, only: iatmnh3,ianh4,iano2 - use mo_bgcmean, only: jnh3flux,janh3fx,janh4,jano2,jsrfanh4,jsrfano2,jlvlanh4,jlvlano2 + use mo_bgcmean, only: jnh3flux,janh3fx,janh4,jano2,jsrfanh4,jsrfano2 #endif implicit none From 68d0d6b343c5343aecd413a8f53c674956725d16 Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Fri, 20 May 2022 20:18:01 +0200 Subject: [PATCH 087/366] testing limiter for limitation functions --- hamocc/mo_extNbioproc.F90 | 26 +++++++++++++++++++------- 1 file changed, 19 insertions(+), 7 deletions(-) diff --git a/hamocc/mo_extNbioproc.F90 b/hamocc/mo_extNbioproc.F90 index d61e31a3..67cb50ef 100644 --- a/hamocc/mo_extNbioproc.F90 +++ b/hamocc/mo_extNbioproc.F90 @@ -76,7 +76,7 @@ MODULE mo_extNbioproc & rano2nitr,q10ano2nitr,Trefano2nitr,bkoxnitr,bkano2nitr,n2omaxy, & & n2oybeta,bkphyanh4,bkphyano3,bkphosph,bkiron - real :: eps + real :: eps,minlim CONTAINS @@ -147,7 +147,8 @@ subroutine extNbioparam_init() bkoxnitr = 0.788e-6 ! Half-saturation constant for oxygen limitation of nitrification on NO2 (kmol/m3) bkano2nitr = 0.287e-6 ! Half-saturation constant for NO2 for nitrification on NO2 (kmol/m3) - eps = 1.e-12 + eps = 1.e-12 + minlim = 1e-3 ! minimum for limitation functions !=========================================================================== end subroutine extNbioparam_init @@ -176,7 +177,9 @@ subroutine nitrification(kpie,kpje,kpke,pddpo,omask,ptho) do i = 1,kpie do k = 1,kpke if(pddpo(i,j,k) > dp_min .and. omask(i,j) > 0.5) then - + if(ocetra(i,j,k,ioxygen) > bkoxnitr*minlim .and. ocetra(i,j,k,ianh4)>bkanh4nitr*minlim & + & .and. ocetra(i,j,k,iano2)>bkano2nitr*minlim)then + ! Ammonium oxidation step of nitrification Tdepanh4 = q10anh4nitr**((ptho(i,j,k)-Trefanh4nitr)/10.) O2limanh4 = ocetra(i,j,k,ioxygen)/(ocetra(i,j,k,ioxygen) + bkoxamox) @@ -240,6 +243,7 @@ subroutine nitrification(kpie,kpje,kpke,pddpo,omask,ptho) ocetra(i,j,k,ioxygen) = ocetra(i,j,k,ioxygen) - (1.5*fno2 + fn2o - 140./16.*fdetamox)*amox & & - (0.5*fno3 - 140./16.*fdetnitr)*nitr ocetra(i,j,k,ialkali) = ocetra(i,j,k,ialkali) - (2.*fno2 + fn2o + 15./16.*fdetamox)*amox - 15./16.*fdetnitr*nitr + endif endif enddo enddo @@ -266,7 +270,7 @@ subroutine denit_NO3_to_NO2(kpie,kpje,kpke,pddpo,omask,ptho) do i = 1,kpie do k = 1,kpke if(pddpo(i,j,k) > dp_min .and. omask(i,j) > 0.5) then - + if(ocetra(i,j,k,ioxygen) < log(2./minlim-1.)/(2.*sc_ano3denit) .and. ocetra(i,j,k,iano3)>bkano3denit*minlim)then Tdep = q10ano3denit**((ptho(i,j,k)-Trefano3denit)/10.) O2inhib = 1. - tanh(sc_ano3denit*ocetra(i,j,k,ioxygen)) nutlim = ocetra(i,j,k,iano3)/(ocetra(i,j,k,iano3) + bkano3denit) @@ -283,6 +287,7 @@ subroutine denit_NO3_to_NO2(kpie,kpje,kpke,pddpo,omask,ptho) ocetra(i,j,k,iphosph) = ocetra(i,j,k,iphosph) + ano3denit/280. ocetra(i,j,k,iiron) = ocetra(i,j,k,iiron) + ano3denit*riron/280. ocetra(i,j,k,ialkali) = ocetra(i,j,k,ialkali) + ano3denit*15./280. + endif endif enddo enddo @@ -310,7 +315,8 @@ subroutine anammox(kpie,kpje,kpke,pddpo,omask,ptho) do i = 1,kpie do k = 1,kpke if(pddpo(i,j,k) > dp_min .and. omask(i,j) > 0.5) then - + if(ocetra(i,j,k,iano2) > bkano2anmx*minlim .and. ocetra(i,j,k,ianh4) > bkanh4anmx*minlim & + & .and. ocetra(i,j,k,ioxygen) dp_min .and. omask(i,j) > 0.5) then + if(ocetra(i,j,k,ioxygen) bkdnra*minlim)then ! DNRA on NO2 Tdepdnra = q10dnra**((ptho(i,j,k)-Trefdnra)/10.) O2inhibdnra = 1. - ocetra(i,j,k,ioxygen)**2/(ocetra(i,j,k,ioxygen)**2 + bkoxdnra**2) @@ -476,6 +483,7 @@ subroutine dnra(kpie,kpje,kpke,pddpo,omask,ptho) ocetra(i,j,k,iphosph) = ocetra(i,j,k,iphosph) + ano2dnra/(93.+1./3.) ocetra(i,j,k,iiron) = ocetra(i,j,k,iiron) + riron/(93.+1./3.) * ano2dnra ocetra(i,j,k,ialkali) = ocetra(i,j,k,ialkali) + (201.+1./3.)/(93.+1./3.) * ano2dnra + endif endif enddo enddo @@ -500,6 +508,7 @@ subroutine denit_N2O(kpie,kpje,kpke,pddpo,omask,ptho) do i = 1,kpie do k = 1,kpke if(pddpo(i,j,k) > dp_min .and. omask(i,j) > 0.5) then + if(ocetra(i,j,k,ioxygen) bkan2odenit*minlim)then ! === denitrification on N2O Tdepan2o = q10an2odenit**((ptho(i,j,k)-Trefan2odenit)/10.) O2inhiban2o = 1. - ocetra(i,j,k,ioxygen)**2/(ocetra(i,j,k,ioxygen)**2 + bkoxan2odenit**2) @@ -523,6 +532,7 @@ subroutine denit_N2O(kpie,kpje,kpke,pddpo,omask,ptho) ocetra(i,j,k,iphosph) = ocetra(i,j,k,iphosph) + an2odenit/280. ocetra(i,j,k,iiron) = ocetra(i,j,k,iiron) + riron/280.*an2odenit ocetra(i,j,k,ialkali) = ocetra(i,j,k,ialkali) + 15.*an2odenit/280. + endif endif enddo enddo @@ -550,6 +560,7 @@ subroutine denit_NO2(kpie,kpje,kpke,pddpo,omask,ptho) do i = 1,kpie do k = 1,kpke if(pddpo(i,j,k) > dp_min .and. omask(i,j) > 0.5) then + if(ocetra(i,j,k,ioxygen) bkano2denit*minlim)then ! denitrification on NO2 Tdepano2 = q10ano2denit**((ptho(i,j,k)-Trefano2denit)/10.) O2inhibano2 = 1. - ocetra(i,j,k,ioxygen)**2/(ocetra(i,j,k,ioxygen)**2 + bkoxano2denit**2) @@ -576,7 +587,8 @@ subroutine denit_NO2(kpie,kpje,kpke,pddpo,omask,ptho) ocetra(i,j,k,isco212) = ocetra(i,j,k,isco212) + 122./280.*ano2denit ocetra(i,j,k,iphosph) = ocetra(i,j,k,iphosph) + ano2denit/280. ocetra(i,j,k,iiron) = ocetra(i,j,k,iiron) + riron/280.*ano2denit - ocetra(i,j,k,ialkali) = ocetra(i,j,k,ialkali) + 295.*ano2denit/280. + ocetra(i,j,k,ialkali) = ocetra(i,j,k,ialkali) + 295.*ano2denit/280. + endif endif enddo enddo From 7d786b04eb9d7afb7f5f3a756b3b6e730fc3baa0 Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Sat, 21 May 2022 20:28:50 +0200 Subject: [PATCH 088/366] honed limiting conc for limitation functions previous attempt for limiting functions was successful, now reverted back to DNRA/NO2-denit competition; ready for another testrun on betzy --- hamocc/mo_extNbioproc.F90 | 79 ++++++++++++++++++++++++++++++++------- hamocc/ocprod.F90 | 24 ++++++------ 2 files changed, 77 insertions(+), 26 deletions(-) diff --git a/hamocc/mo_extNbioproc.F90 b/hamocc/mo_extNbioproc.F90 index 67cb50ef..1149e508 100644 --- a/hamocc/mo_extNbioproc.F90 +++ b/hamocc/mo_extNbioproc.F90 @@ -147,8 +147,8 @@ subroutine extNbioparam_init() bkoxnitr = 0.788e-6 ! Half-saturation constant for oxygen limitation of nitrification on NO2 (kmol/m3) bkano2nitr = 0.287e-6 ! Half-saturation constant for NO2 for nitrification on NO2 (kmol/m3) - eps = 1.e-12 - minlim = 1e-3 ! minimum for limitation functions + eps = 1.e-25 ! safe division etc. + minlim = 1e-3 ! minimum for limitation functions (e.g. nutlim or oxlim/inh can only decrease to 1/1000) !=========================================================================== end subroutine extNbioparam_init @@ -163,23 +163,28 @@ subroutine nitrification(kpie,kpje,kpke,pddpo,omask,ptho) real, intent(in) :: ptho(kpie,kpje,kpke) !local variables - integer :: i,j,k + integer :: i,j,k,proc_ctr real :: Tdepanh4,O2limanh4,nut1lim,anh4new,potdnh4amox,fdetamox,fno2,fn2o,ftotnh4 real :: Tdepano2,O2limano2,nut2lim,ano2new,potdno2nitr,fdetnitr,fno3,ftotno2 real :: amoxfrac,nitrfrac,totd,amox,nitr + + real :: minlim_oxnh4,minlim_nh4,minlim_oxno2,minlim_no2 ! minimum conc for limitation functions + minlim_oxnh4 = bkoxamox*minlim/(1. - minlim) + minlim_oxno2 = bkoxnitr*minlim/(1. - minlim) + minlim_nh4 = bkanh4nitr*minlim/(1. - minlim) + minlim_no2 = bkano2nitr*minlim/(1. - minlim) !$OMP PARALLEL DO PRIVATE(i,k,Tdepanh4,O2limanh4,nut1lim,anh4new,potdnh4amox,fdetamox,fno2,fn2o,ftotnh4, & !$OMP Tdepano2,O2limano2,nut2lim,ano2new,potdno2nitr,fdetnitr,fno3,ftotno2,amoxfrac, & - !$OMP nitrfrac,totd,amox,nitr) + !$OMP nitrfrac,totd,amox,nitr,proc_ctr) do j = 1,kpje do i = 1,kpie do k = 1,kpke if(pddpo(i,j,k) > dp_min .and. omask(i,j) > 0.5) then - if(ocetra(i,j,k,ioxygen) > bkoxnitr*minlim .and. ocetra(i,j,k,ianh4)>bkanh4nitr*minlim & - & .and. ocetra(i,j,k,iano2)>bkano2nitr*minlim)then - + proc_ctr = 0 + if(ocetra(i,j,k,ioxygen)>minlim_oxnh4 .and. ocetra(i,j,k,ianh4)>minlim_nh4)then ! Ammonium oxidation step of nitrification Tdepanh4 = q10anh4nitr**((ptho(i,j,k)-Trefanh4nitr)/10.) O2limanh4 = ocetra(i,j,k,ioxygen)/(ocetra(i,j,k,ioxygen) + bkoxamox) @@ -198,7 +203,15 @@ subroutine nitrification(kpie,kpje,kpke,pddpo,omask,ptho) fn2o = fn2o/ftotnh4 fno2 = fno2/ftotnh4 fdetamox = 1. - (fn2o + fno2) + proc_ctr = proc_ctr + 1 + else + potdnh4amox = 0. + fn2o = 0. + fno2 = 0. + fdetamox = 0. + endif + if(ocetra(i,j,k,ioxygen)>minlim_oxno2 .and. ocetra(i,j,k,iano2)>minlim_no2)then ! NO2 oxidizing step of nitrification Tdepano2 = q10ano2nitr**((ptho(i,j,k)-Trefano2nitr)/10.) O2limano2 = ocetra(i,j,k,ioxygen)/(ocetra(i,j,k,ioxygen) + bkoxnitr) @@ -215,9 +228,17 @@ subroutine nitrification(kpie,kpje,kpke,pddpo,omask,ptho) fno3 = fno3/ftotno2 fdetnitr = 1. - fno3 + proc_ctr = proc_ctr + 1 + else + potdno2nitr = 0. + fno3 = 0. + fdetnitr = 0. + endif + + if (proc_ctr>0)then ! limitation of the two processes through available nutrients, etc. totd = potdnh4amox + potdno2nitr - amoxfrac = potdnh4amox/(totd + eps) + amoxfrac = potdnh4amox/(totd + eps) nitrfrac = 1. - amoxfrac totd = max(0., & & min(totd, & @@ -265,12 +286,17 @@ subroutine denit_NO3_to_NO2(kpie,kpje,kpke,pddpo,omask,ptho) integer :: i,j,k real :: Tdep,O2inhib,nutlim,ano3new,ano3denit + real :: minlim_ox,minlim_no3 ! minimum conc for limitation functions + + minlim_ox = log(2./minlim-1.)/(2.*sc_ano3denit) + minlim_no3 = bkano3denit*minlim/(1.-minlim) + !$OMP PARALLEL DO PRIVATE(i,k,Tdep,O2inhib,nutlim,ano3new,ano3denit) do j = 1,kpje do i = 1,kpie do k = 1,kpke if(pddpo(i,j,k) > dp_min .and. omask(i,j) > 0.5) then - if(ocetra(i,j,k,ioxygen) < log(2./minlim-1.)/(2.*sc_ano3denit) .and. ocetra(i,j,k,iano3)>bkano3denit*minlim)then + if(ocetra(i,j,k,ioxygen) < minlim_ox .and. ocetra(i,j,k,iano3)>minlim_no3)then Tdep = q10ano3denit**((ptho(i,j,k)-Trefano3denit)/10.) O2inhib = 1. - tanh(sc_ano3denit*ocetra(i,j,k,ioxygen)) nutlim = ocetra(i,j,k,iano3)/(ocetra(i,j,k,iano3) + bkano3denit) @@ -309,14 +335,18 @@ subroutine anammox(kpie,kpje,kpke,pddpo,omask,ptho) integer :: i,j,k real :: Tdep,O2inhib,nut1lim,nut2lim,ano2new,ano2anmx + real :: minlim_ox,minlim_nh4,minlim_no2 ! minimum conc for limitation functions + + minlim_ox = log((1.-minlim)/minlim)/alphaanmx + bkoxanmx + minlim_nh4 = bkanh4anmx*minlim/(1.-minlim) + minlim_no2 = bkano2anmx*minlim/(1.-minlim) !$OMP PARALLEL DO PRIVATE(i,k,Tdep,O2inhib,nut1lim,nut2lim,ano2new,ano2anmx) do j = 1,kpje do i = 1,kpie do k = 1,kpke if(pddpo(i,j,k) > dp_min .and. omask(i,j) > 0.5) then - if(ocetra(i,j,k,iano2) > bkano2anmx*minlim .and. ocetra(i,j,k,ianh4) > bkanh4anmx*minlim & - & .and. ocetra(i,j,k,ioxygen)minlim_no2 .and. ocetra(i,j,k,ianh4)>minlim_nh4 .and. ocetra(i,j,k,ioxygen) dp_min .and. omask(i,j) > 0.5) then - + proc_ctr = 0 + if(ocetra(i,j,k,ioxygen)minlim_no2)then ! denitrification on NO2 Tdepano2 = q10ano2denit**((ptho(i,j,k)-Trefano2denit)/10.) O2inhibano2 = 1. - ocetra(i,j,k,ioxygen)**2/(ocetra(i,j,k,ioxygen)**2 + bkoxano2denit**2) @@ -397,14 +436,25 @@ subroutine denit_dnra(kpie,kpje,kpke,pddpo,omask,ptho) ! potential fractional change ano2denit = fdenit * potdano2 ano2dnra = fdnra * potdano2 + proc_ctr = proc_ctr + 1 + else + ano2denit = 0. + ano2dnra = 0. + endif + if(ocetra(i,j,k,ioxygen)minlim_n2o)then ! === denitrification on N2O Tdepan2o = q10an2odenit**((ptho(i,j,k)-Trefan2odenit)/10.) O2inhiban2o = 1. - ocetra(i,j,k,ioxygen)**2/(ocetra(i,j,k,ioxygen)**2 + bkoxan2odenit**2) nutliman2o = ocetra(i,j,k,ian2o)/(ocetra(i,j,k,ian2o) + bkan2odenit) an2onew = ocetra(i,j,k,ian2o)/(1. + ran2odenit*Tdepan2o*O2inhiban2o*nutliman2o) an2odenit = max(0.,min(ocetra(i,j,k,ian2o),ocetra(i,j,k,ian2o) - an2onew)) + proc_ctr = proc_ctr + 1 + else + an2odenit = 0. + endif + if(proc_ctr>0)then ! limitation of processes due to detritus potddet = 1./280.*(ano2denit + an2odenit) + 1./(93. + 1./3.)*ano2dnra ! P units fdetano2denit = 1./280.*ano2denit/(potddet + eps) @@ -428,6 +478,7 @@ subroutine denit_dnra(kpie,kpje,kpke,pddpo,omask,ptho) ocetra(i,j,k,iiron) = ocetra(i,j,k,iiron) + riron/280.*(ano2denit + an2odenit) + riron/(93.+1./3.) * ano2dnra ocetra(i,j,k,ialkali) = ocetra(i,j,k,ialkali) + (295.*ano2denit + 15.*an2odenit)/280. & & + (201.+1./3.)/(93.+1./3.) * ano2dnra + endif endif enddo enddo diff --git a/hamocc/ocprod.F90 b/hamocc/ocprod.F90 index 04f3bbf9..5f31120d 100644 --- a/hamocc/ocprod.F90 +++ b/hamocc/ocprod.F90 @@ -890,21 +890,21 @@ subroutine ocprod(kpie,kpje,kpke,kbnd,pdlxp,pdlyp,pddpo,omask,dust,ptho) CALL anammox(kpie,kpje,kpke,pddpo,omask,ptho) CALL extN_inv_check(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask,inv_message) -! inv_message = 'in OCPROD after extNcycle denitrification / DNRA' -! CALL denit_dnra(kpie,kpje,kpke,pddpo,omask,ptho) -! CALL extN_inv_check(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask,inv_message) - - inv_message = 'in OCPROD after extNcycle denitrification NO2 ' - CALL denit_NO2(kpie,kpje,kpke,pddpo,omask,ptho) + inv_message = 'in OCPROD after extNcycle denitrification / DNRA' + CALL denit_dnra(kpie,kpje,kpke,pddpo,omask,ptho) CALL extN_inv_check(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask,inv_message) - inv_message = 'in OCPROD after extNcycle denitrification DNRA ' - CALL dnra(kpie,kpje,kpke,pddpo,omask,ptho) - CALL extN_inv_check(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask,inv_message) +! inv_message = 'in OCPROD after extNcycle denitrification NO2 ' +! CALL denit_NO2(kpie,kpje,kpke,pddpo,omask,ptho) +! CALL extN_inv_check(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask,inv_message) - inv_message = 'in OCPROD after extNcycle denitrification N2O ' - CALL denit_N2O(kpie,kpje,kpke,pddpo,omask,ptho) - CALL extN_inv_check(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask,inv_message) +! inv_message = 'in OCPROD after extNcycle denitrification DNRA ' +! CALL dnra(kpie,kpje,kpke,pddpo,omask,ptho) +! CALL extN_inv_check(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask,inv_message) + +! inv_message = 'in OCPROD after extNcycle denitrification N2O ' +! CALL denit_N2O(kpie,kpje,kpke,pddpo,omask,ptho) +! CALL extN_inv_check(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask,inv_message) #endif From d4bbbea7c3b532270819cf69a3e4895ee33bbec4 Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Sat, 21 May 2022 21:55:27 +0200 Subject: [PATCH 089/366] re-structuring denit_dnra --- hamocc/mo_extNbioproc.F90 | 57 ++++++++++++++++++++++++--------------- 1 file changed, 35 insertions(+), 22 deletions(-) diff --git a/hamocc/mo_extNbioproc.F90 b/hamocc/mo_extNbioproc.F90 index 1149e508..5b22092d 100644 --- a/hamocc/mo_extNbioproc.F90 +++ b/hamocc/mo_extNbioproc.F90 @@ -385,7 +385,7 @@ subroutine denit_dnra(kpie,kpje,kpke,pddpo,omask,ptho) real, intent(in) :: ptho(kpie,kpje,kpke) !local variables - integer :: i,j,k,proc_ctr + integer :: i,j,k,proc_ctr,n2oden real :: Tdepano2,O2inhibano2,nutlimano2,detlimano2,rpotano2denit,ano2denit real :: Tdepdnra,O2inhibdnra,nutlimdnra,detlimdnra,rpotano2dnra,ano2dnra real :: fdenit,fdnra,potano2new,potdano2,potddet,fdetano2denit,fdetan2odenit,fdetdnra @@ -404,13 +404,30 @@ subroutine denit_dnra(kpie,kpje,kpke,pddpo,omask,ptho) !$OMP rpotano2denit,rpotano2dnra, & !$OMP fdenit,fdnra,potano2new,potdano2,potddet,fdetano2denit, & !$OMP fdetan2odenit,fdetdnra, & - !$OMP Tdepdnra,O2inhibdnra,nutlimdnra,detlimdnra,ano2dnra,proc_ctr) + !$OMP Tdepdnra,O2inhibdnra,nutlimdnra,detlimdnra,ano2dnra,proc_ctr,n2oden) do j = 1,kpje do i = 1,kpie do k = 1,kpke if(pddpo(i,j,k) > dp_min .and. omask(i,j) > 0.5) then - proc_ctr = 0 + proc_ctr = 0 + n2oden = 0 + + potddet = 0. + if(ocetra(i,j,k,ioxygen)minlim_n2o)then + ! === denitrification on N2O + Tdepan2o = q10an2odenit**((ptho(i,j,k)-Trefan2odenit)/10.) + O2inhiban2o = 1. - ocetra(i,j,k,ioxygen)**2/(ocetra(i,j,k,ioxygen)**2 + bkoxan2odenit**2) + nutliman2o = ocetra(i,j,k,ian2o)/(ocetra(i,j,k,ian2o) + bkan2odenit) + an2onew = ocetra(i,j,k,ian2o)/(1. + ran2odenit*Tdepan2o*O2inhiban2o*nutliman2o) + an2odenit = max(0.,min(ocetra(i,j,k,ian2o),ocetra(i,j,k,ian2o) - an2onew)) + potddet = 1./280.*an2odenit !P-units + proc_ctr = proc_ctr + 1 + n2oden = 1 + else + an2odenit = 0. + endif + if(ocetra(i,j,k,ioxygen)minlim_no2)then ! denitrification on NO2 Tdepano2 = q10ano2denit**((ptho(i,j,k)-Trefano2denit)/10.) @@ -436,35 +453,31 @@ subroutine denit_dnra(kpie,kpje,kpke,pddpo,omask,ptho) ! potential fractional change ano2denit = fdenit * potdano2 ano2dnra = fdnra * potdano2 + potddet = 1./280.*ano2denit + 1./(93. + 1./3.)*ano2dnra ! P units + + ! limitation of processes due to detritus + fdetano2denit = 1./280.*ano2denit/(potddet + eps) + fdetdnra = 1./(93. + 1./3.)*ano2dnra/(potddet + eps) + proc_ctr = proc_ctr + 1 else - ano2denit = 0. - ano2dnra = 0. - endif - - if(ocetra(i,j,k,ioxygen)minlim_n2o)then - ! === denitrification on N2O - Tdepan2o = q10an2odenit**((ptho(i,j,k)-Trefan2odenit)/10.) - O2inhiban2o = 1. - ocetra(i,j,k,ioxygen)**2/(ocetra(i,j,k,ioxygen)**2 + bkoxan2odenit**2) - nutliman2o = ocetra(i,j,k,ian2o)/(ocetra(i,j,k,ian2o) + bkan2odenit) - an2onew = ocetra(i,j,k,ian2o)/(1. + ran2odenit*Tdepan2o*O2inhiban2o*nutliman2o) - an2odenit = max(0.,min(ocetra(i,j,k,ian2o),ocetra(i,j,k,ian2o) - an2onew)) - proc_ctr = proc_ctr + 1 - else - an2odenit = 0. + ano2denit = 0. + ano2dnra = 0. + fdetano2denit = 0. + fdetdnra = 0. endif if(proc_ctr>0)then ! limitation of processes due to detritus - potddet = 1./280.*(ano2denit + an2odenit) + 1./(93. + 1./3.)*ano2dnra ! P units - fdetano2denit = 1./280.*ano2denit/(potddet + eps) - fdetan2odenit = 1./280.*an2odenit/(potddet + eps) - fdetdnra = 1. - fdetano2denit - fdetan2odenit potddet = max(0.,min(potddet,ocetra(i,j,k,idet))) + if (n2oden == 1) then + fdetan2odenit = 1. - fdetano2denit - fdetdnra + an2odenit = fdetan2odenit*280.*potddet + endif + ! change of NO2 and N2O in N units ano2denit = fdetano2denit*280.*potddet - an2odenit = fdetan2odenit*280.*potddet ano2dnra = fdetdnra * (93. + 1./3.)*potddet ! change in tracer concentrations due to denit (NO2->N2O->N2) and DNRA (NO2->NH4) From cd72de02620a2e33301e6a6d477ba87c8b6cd6ec Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Sat, 21 May 2022 22:34:46 +0200 Subject: [PATCH 090/366] fix potddet --- hamocc/mo_extNbioproc.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/hamocc/mo_extNbioproc.F90 b/hamocc/mo_extNbioproc.F90 index 5b22092d..184f5f5b 100644 --- a/hamocc/mo_extNbioproc.F90 +++ b/hamocc/mo_extNbioproc.F90 @@ -453,7 +453,7 @@ subroutine denit_dnra(kpie,kpje,kpke,pddpo,omask,ptho) ! potential fractional change ano2denit = fdenit * potdano2 ano2dnra = fdnra * potdano2 - potddet = 1./280.*ano2denit + 1./(93. + 1./3.)*ano2dnra ! P units + potddet = potddet + 1./280.*ano2denit + 1./(93. + 1./3.)*ano2dnra ! P units ! limitation of processes due to detritus fdetano2denit = 1./280.*ano2denit/(potddet + eps) From 1e1100032085319f08b9eb0eadd08c0cc38d3945 Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Sat, 21 May 2022 23:26:22 +0200 Subject: [PATCH 091/366] reformulate denit_dnra - trying to better avoid underflows --- hamocc/mo_extNbioproc.F90 | 80 ++++++++++++++++++++++++++------------- 1 file changed, 53 insertions(+), 27 deletions(-) diff --git a/hamocc/mo_extNbioproc.F90 b/hamocc/mo_extNbioproc.F90 index 184f5f5b..e4f09533 100644 --- a/hamocc/mo_extNbioproc.F90 +++ b/hamocc/mo_extNbioproc.F90 @@ -385,12 +385,15 @@ subroutine denit_dnra(kpie,kpje,kpke,pddpo,omask,ptho) real, intent(in) :: ptho(kpie,kpje,kpke) !local variables - integer :: i,j,k,proc_ctr,n2oden + integer :: i,j,k,n2oden,dnra real :: Tdepano2,O2inhibano2,nutlimano2,detlimano2,rpotano2denit,ano2denit real :: Tdepdnra,O2inhibdnra,nutlimdnra,detlimdnra,rpotano2dnra,ano2dnra real :: fdenit,fdnra,potano2new,potdano2,potddet,fdetano2denit,fdetan2odenit,fdetdnra real :: Tdepan2o,O2inhiban2o,nutliman2o,detliman2o,an2onew,an2odenit + real :: dano2,dan2o,dgasnit,danh4,ddet,dsco212,dphosph,diron,dalk + + real :: minlim_ox,minlim_oxn2o,minlim_no2,minlim_n2o minlim_ox = min(bkoxano2denit,bkoxdnra)/sqrt(minlim) @@ -404,16 +407,19 @@ subroutine denit_dnra(kpie,kpje,kpke,pddpo,omask,ptho) !$OMP rpotano2denit,rpotano2dnra, & !$OMP fdenit,fdnra,potano2new,potdano2,potddet,fdetano2denit, & !$OMP fdetan2odenit,fdetdnra, & - !$OMP Tdepdnra,O2inhibdnra,nutlimdnra,detlimdnra,ano2dnra,proc_ctr,n2oden) + !$OMP Tdepdnra,O2inhibdnra,nutlimdnra,detlimdnra,ano2dnra,dnra,n2oden,& + !$OMP dano2,dan2o,dgasnit,danh4,ddet,dsco212,dphosph,diron,dalk) do j = 1,kpje do i = 1,kpie do k = 1,kpke if(pddpo(i,j,k) > dp_min .and. omask(i,j) > 0.5) then - proc_ctr = 0 n2oden = 0 + dnra = 0 potddet = 0. + fdetano2denit = 0. + fdetdnra = 0. if(ocetra(i,j,k,ioxygen)minlim_n2o)then ! === denitrification on N2O Tdepan2o = q10an2odenit**((ptho(i,j,k)-Trefan2odenit)/10.) @@ -422,10 +428,7 @@ subroutine denit_dnra(kpie,kpje,kpke,pddpo,omask,ptho) an2onew = ocetra(i,j,k,ian2o)/(1. + ran2odenit*Tdepan2o*O2inhiban2o*nutliman2o) an2odenit = max(0.,min(ocetra(i,j,k,ian2o),ocetra(i,j,k,ian2o) - an2onew)) potddet = 1./280.*an2odenit !P-units - proc_ctr = proc_ctr + 1 n2oden = 1 - else - an2odenit = 0. endif if(ocetra(i,j,k,ioxygen)minlim_no2)then @@ -458,39 +461,62 @@ subroutine denit_dnra(kpie,kpje,kpke,pddpo,omask,ptho) ! limitation of processes due to detritus fdetano2denit = 1./280.*ano2denit/(potddet + eps) fdetdnra = 1./(93. + 1./3.)*ano2dnra/(potddet + eps) - - proc_ctr = proc_ctr + 1 - else - ano2denit = 0. - ano2dnra = 0. - fdetano2denit = 0. - fdetdnra = 0. + dnra = 1 endif - if(proc_ctr>0)then + if(n2oden+dnra>0)then + dano2 = 0. + dan2o = 0. + dgasnit = 0. + danh4 = 0. + ddet = 0. + dsco212 = 0. + dphosph = 0. + diron = 0. + dalk = 0. + ! limitation of processes due to detritus potddet = max(0.,min(potddet,ocetra(i,j,k,idet))) if (n2oden == 1) then fdetan2odenit = 1. - fdetano2denit - fdetdnra an2odenit = fdetan2odenit*280.*potddet + dan2o = -an2odenit + dgasnit = an2odenit + danh4 = 16./280.*an2odenit + ddet = -an2odenit/280. + dsco212 = 122./280.*an2odenit + dphosph = an2odenit/280. + diron = riron/280.*an2odenit + dalk = 15.*an2odenit/280. + endif + + if (dnra == 1)then + ! change of NO2 and N2O in N units + ano2denit = fdetano2denit*280.*potddet + ano2dnra = fdetdnra * (93. + 1./3.)*potddet + dano2 = -(ano2denit + ano2dnra) + dan2o = dan2o + 0.5*ano2denit + danh4 = danh4 + 16./280.*ano2denit + (109.+1./3.)/(93.+1./3.)*ano2dnra + ddet = ddet - ano2denit/280. - ano2dnra/(93.+1./3.) + dsco212 = dsco212 + 122./280.*ano2denit + 122./(93.+1./3.)*ano2dnra + dphosph = dphosph + ano2denit/280. + ano2dnra/(93.+1./3.) + diron = diron + riron/280.*ano2denit + riron/(93.+1./3.)*ano2dnra + dalk = dalk + 295.*ano2denit/280. + (201.+1./3.)/(93.+1./3.)*ano2dnra endif - ! change of NO2 and N2O in N units - ano2denit = fdetano2denit*280.*potddet - ano2dnra = fdetdnra * (93. + 1./3.)*potddet ! change in tracer concentrations due to denit (NO2->N2O->N2) and DNRA (NO2->NH4) - ocetra(i,j,k,iano2) = ocetra(i,j,k,iano2) - ano2denit - ano2dnra - ocetra(i,j,k,ian2o) = ocetra(i,j,k,ian2o) - an2odenit + 0.5*ano2denit - ocetra(i,j,k,igasnit) = ocetra(i,j,k,igasnit) + an2odenit - ocetra(i,j,k,ianh4) = ocetra(i,j,k,ianh4) + 16./280. * (ano2denit+an2odenit) + (109.+1./3.)/(93.+1./3.)*ano2dnra - ocetra(i,j,k,idet) = ocetra(i,j,k,idet) - (ano2denit + an2odenit)/280. - ano2dnra/(93.+1./3.) - ocetra(i,j,k,isco212) = ocetra(i,j,k,isco212) + 122./280.*(ano2denit + an2odenit) + 122./(93.+1./3.) * ano2dnra - ocetra(i,j,k,iphosph) = ocetra(i,j,k,iphosph) + (ano2denit + an2odenit)/280. + ano2dnra/(93.+1./3.) - ocetra(i,j,k,iiron) = ocetra(i,j,k,iiron) + riron/280.*(ano2denit + an2odenit) + riron/(93.+1./3.) * ano2dnra - ocetra(i,j,k,ialkali) = ocetra(i,j,k,ialkali) + (295.*ano2denit + 15.*an2odenit)/280. & - & + (201.+1./3.)/(93.+1./3.) * ano2dnra + ocetra(i,j,k,iano2) = ocetra(i,j,k,iano2) + dano2 !- ano2denit - ano2dnra + ocetra(i,j,k,ian2o) = ocetra(i,j,k,ian2o) + dan2o !- an2odenit + 0.5*ano2denit + ocetra(i,j,k,igasnit) = ocetra(i,j,k,igasnit) + dgasnit ! an2odenit + ocetra(i,j,k,ianh4) = ocetra(i,j,k,ianh4) + danh4 ! 16./280. * (ano2denit+an2odenit) + (109.+1./3.)/(93.+1./3.)*ano2dnra + ocetra(i,j,k,idet) = ocetra(i,j,k,idet) + ddet !- (ano2denit + an2odenit)/280. - ano2dnra/(93.+1./3.) + ocetra(i,j,k,isco212) = ocetra(i,j,k,isco212) + dsco212 !122./280.*(ano2denit + an2odenit) + 122./(93.+1./3.) * ano2dnra + ocetra(i,j,k,iphosph) = ocetra(i,j,k,iphosph) + dphosph !(ano2denit + an2odenit)/280. + ano2dnra/(93.+1./3.) + ocetra(i,j,k,iiron) = ocetra(i,j,k,iiron) + diron ! riron/280.*(ano2denit + an2odenit) + riron/(93.+1./3.) * ano2dnra + ocetra(i,j,k,ialkali) = ocetra(i,j,k,ialkali) + dalk ! (295.*ano2denit + 15.*an2odenit)/280. & + ! & + (201.+1./3.)/(93.+1./3.) * ano2dnra endif endif enddo From f6fb1e90574688d894b1213d3a819d8fb162751d Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Tue, 24 May 2022 13:41:20 +0200 Subject: [PATCH 092/366] try to avoid underflow through division --- hamocc/mo_extNbioproc.F90 | 31 ++++++++++++++++--------------- 1 file changed, 16 insertions(+), 15 deletions(-) diff --git a/hamocc/mo_extNbioproc.F90 b/hamocc/mo_extNbioproc.F90 index e4f09533..ce23b672 100644 --- a/hamocc/mo_extNbioproc.F90 +++ b/hamocc/mo_extNbioproc.F90 @@ -147,8 +147,8 @@ subroutine extNbioparam_init() bkoxnitr = 0.788e-6 ! Half-saturation constant for oxygen limitation of nitrification on NO2 (kmol/m3) bkano2nitr = 0.287e-6 ! Half-saturation constant for NO2 for nitrification on NO2 (kmol/m3) - eps = 1.e-25 ! safe division etc. - minlim = 1e-3 ! minimum for limitation functions (e.g. nutlim or oxlim/inh can only decrease to 1/1000) + eps = 1.e-16 ! safe division etc. + minlim = 1.e-3 ! minimum for limitation functions (e.g. nutlim or oxlim/inh can only decrease to 1/1000) !=========================================================================== end subroutine extNbioparam_init @@ -417,10 +417,10 @@ subroutine denit_dnra(kpie,kpje,kpke,pddpo,omask,ptho) n2oden = 0 dnra = 0 - potddet = 0. + potddet = 0. fdetano2denit = 0. fdetdnra = 0. - if(ocetra(i,j,k,ioxygen)minlim_n2o)then + if(0.<=ocetra(i,j,k,ioxygen) .and. ocetra(i,j,k,ioxygen)minlim_n2o)then ! === denitrification on N2O Tdepan2o = q10an2odenit**((ptho(i,j,k)-Trefan2odenit)/10.) O2inhiban2o = 1. - ocetra(i,j,k,ioxygen)**2/(ocetra(i,j,k,ioxygen)**2 + bkoxan2odenit**2) @@ -431,7 +431,7 @@ subroutine denit_dnra(kpie,kpje,kpke,pddpo,omask,ptho) n2oden = 1 endif - if(ocetra(i,j,k,ioxygen)minlim_no2)then + if(0.<=ocetra(i,j,k,ioxygen) .and. ocetra(i,j,k,ioxygen)minlim_no2)then ! denitrification on NO2 Tdepano2 = q10ano2denit**((ptho(i,j,k)-Trefano2denit)/10.) O2inhibano2 = 1. - ocetra(i,j,k,ioxygen)**2/(ocetra(i,j,k,ioxygen)**2 + bkoxano2denit**2) @@ -444,14 +444,16 @@ subroutine denit_dnra(kpie,kpje,kpke,pddpo,omask,ptho) nutlimdnra = ocetra(i,j,k,iano2)/(ocetra(i,j,k,iano2) + bkdnra) rpotano2dnra = max(0.,rdnra*Tdepdnra*O2inhibdnra*nutlimdnra) ! pot. rate of dnra + ! potential new conc of NO2 due to denitrification and DNRA + potano2new = ocetra(i,j,k,iano2)/(1. + rpotano2denit + rpotano2dnra) + potdano2 = max(0.,min(ocetra(i,j,k,iano2), ocetra(i,j,k,iano2) - potano2new)) + ! === limitation due to NO2: ! fraction on potential change of NO2: + rpotano2denit = rpotano2denit*1.e8 ! to avoid potential numerical issues + rpotano2dnra = rpotano2dnra *1.e8 fdenit = rpotano2denit/(rpotano2denit + rpotano2dnra + eps) fdnra = 1. - fdenit - - ! potential new conc of NO2 due to denitrification and DNRA - potano2new = ocetra(i,j,k,iano2)/(1. + rpotano2denit + rpotano2dnra) - potdano2 = max(0.,min(ocetra(i,j,k,iano2), ocetra(i,j,k,iano2) - potano2new)) ! potential fractional change ano2denit = fdenit * potdano2 @@ -464,7 +466,9 @@ subroutine denit_dnra(kpie,kpje,kpke,pddpo,omask,ptho) dnra = 1 endif - if(n2oden+dnra>0)then + ! limitation of processes due to detritus + potddet = max(0.,min(potddet,ocetra(i,j,k,idet))) + if(n2oden+dnra>0 .and. potddet>0.)then dano2 = 0. dan2o = 0. dgasnit = 0. @@ -474,11 +478,8 @@ subroutine denit_dnra(kpie,kpje,kpke,pddpo,omask,ptho) dphosph = 0. diron = 0. dalk = 0. - - ! limitation of processes due to detritus - potddet = max(0.,min(potddet,ocetra(i,j,k,idet))) - - if (n2oden == 1) then + + if (n2oden == 1) then ! change due to N2O denitrification fdetan2odenit = 1. - fdetano2denit - fdetdnra an2odenit = fdetan2odenit*280.*potddet dan2o = -an2odenit From 8a79faa87dcef18207c000b8e8a9027900f78ff7 Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Wed, 25 May 2022 13:43:50 +0200 Subject: [PATCH 093/366] further puzzling within denit_dnra --- hamocc/mo_extNbioproc.F90 | 36 +++++++++++++++++++----------------- 1 file changed, 19 insertions(+), 17 deletions(-) diff --git a/hamocc/mo_extNbioproc.F90 b/hamocc/mo_extNbioproc.F90 index ce23b672..b1eeeefd 100644 --- a/hamocc/mo_extNbioproc.F90 +++ b/hamocc/mo_extNbioproc.F90 @@ -385,13 +385,13 @@ subroutine denit_dnra(kpie,kpje,kpke,pddpo,omask,ptho) real, intent(in) :: ptho(kpie,kpje,kpke) !local variables - integer :: i,j,k,n2oden,dnra + integer :: i,j,k,n2oden,dnra_use real :: Tdepano2,O2inhibano2,nutlimano2,detlimano2,rpotano2denit,ano2denit real :: Tdepdnra,O2inhibdnra,nutlimdnra,detlimdnra,rpotano2dnra,ano2dnra real :: fdenit,fdnra,potano2new,potdano2,potddet,fdetano2denit,fdetan2odenit,fdetdnra real :: Tdepan2o,O2inhiban2o,nutliman2o,detliman2o,an2onew,an2odenit - real :: dano2,dan2o,dgasnit,danh4,ddet,dsco212,dphosph,diron,dalk + real :: dano2,dan2o,dgasnit,danh4,ddet,dsco212,dphosph,diron,dalk,sc real :: minlim_ox,minlim_oxn2o,minlim_no2,minlim_n2o @@ -401,13 +401,14 @@ subroutine denit_dnra(kpie,kpje,kpke,pddpo,omask,ptho) minlim_no2 = min(bkdnra,bkano2denit)*minlim/(1. - minlim) minlim_n2o = bkan2odenit*minlim/(1. - minlim) + sc = 1.e8 ! scaling factor !$OMP PARALLEL DO PRIVATE(i,k,Tdepano2,O2inhibano2,nutlimano2,detlimano2,ano2denit, & !$OMP Tdepan2o,O2inhiban2o,nutliman2o,detliman2o,an2onew,an2odenit, & !$OMP rpotano2denit,rpotano2dnra, & !$OMP fdenit,fdnra,potano2new,potdano2,potddet,fdetano2denit, & !$OMP fdetan2odenit,fdetdnra, & - !$OMP Tdepdnra,O2inhibdnra,nutlimdnra,detlimdnra,ano2dnra,dnra,n2oden,& + !$OMP Tdepdnra,O2inhibdnra,nutlimdnra,detlimdnra,ano2dnra,dnra_use,n2oden,& !$OMP dano2,dan2o,dgasnit,danh4,ddet,dsco212,dphosph,diron,dalk) do j = 1,kpje @@ -415,7 +416,7 @@ subroutine denit_dnra(kpie,kpje,kpke,pddpo,omask,ptho) do k = 1,kpke if(pddpo(i,j,k) > dp_min .and. omask(i,j) > 0.5) then n2oden = 0 - dnra = 0 + dnra_use = 0 potddet = 0. fdetano2denit = 0. @@ -423,7 +424,7 @@ subroutine denit_dnra(kpie,kpje,kpke,pddpo,omask,ptho) if(0.<=ocetra(i,j,k,ioxygen) .and. ocetra(i,j,k,ioxygen)minlim_n2o)then ! === denitrification on N2O Tdepan2o = q10an2odenit**((ptho(i,j,k)-Trefan2odenit)/10.) - O2inhiban2o = 1. - ocetra(i,j,k,ioxygen)**2/(ocetra(i,j,k,ioxygen)**2 + bkoxan2odenit**2) + O2inhiban2o = bkoxan2odenit**2/(ocetra(i,j,k,ioxygen)**2 + bkoxan2odenit**2) nutliman2o = ocetra(i,j,k,ian2o)/(ocetra(i,j,k,ian2o) + bkan2odenit) an2onew = ocetra(i,j,k,ian2o)/(1. + ran2odenit*Tdepan2o*O2inhiban2o*nutliman2o) an2odenit = max(0.,min(ocetra(i,j,k,ian2o),ocetra(i,j,k,ian2o) - an2onew)) @@ -434,13 +435,13 @@ subroutine denit_dnra(kpie,kpje,kpke,pddpo,omask,ptho) if(0.<=ocetra(i,j,k,ioxygen) .and. ocetra(i,j,k,ioxygen)minlim_no2)then ! denitrification on NO2 Tdepano2 = q10ano2denit**((ptho(i,j,k)-Trefano2denit)/10.) - O2inhibano2 = 1. - ocetra(i,j,k,ioxygen)**2/(ocetra(i,j,k,ioxygen)**2 + bkoxano2denit**2) + O2inhibano2 = bkoxano2denit**2/(ocetra(i,j,k,ioxygen)**2 + bkoxano2denit**2) nutlimano2 = ocetra(i,j,k,iano2)/(ocetra(i,j,k,iano2) + bkano2denit) rpotano2denit = max(0.,rano2denit*Tdepano2*O2inhibano2*nutlimano2) ! potential rate of denit ! DNRA on NO2 Tdepdnra = q10dnra**((ptho(i,j,k)-Trefdnra)/10.) - O2inhibdnra = 1. - ocetra(i,j,k,ioxygen)**2/(ocetra(i,j,k,ioxygen)**2 + bkoxdnra**2) + O2inhibdnra = bkoxdnra**2/(ocetra(i,j,k,ioxygen)**2 + bkoxdnra**2) nutlimdnra = ocetra(i,j,k,iano2)/(ocetra(i,j,k,iano2) + bkdnra) rpotano2dnra = max(0.,rdnra*Tdepdnra*O2inhibdnra*nutlimdnra) ! pot. rate of dnra @@ -450,25 +451,26 @@ subroutine denit_dnra(kpie,kpje,kpke,pddpo,omask,ptho) ! === limitation due to NO2: ! fraction on potential change of NO2: - rpotano2denit = rpotano2denit*1.e8 ! to avoid potential numerical issues - rpotano2dnra = rpotano2dnra *1.e8 + rpotano2denit = rpotano2denit*sc ! to avoid potential numerical issues + rpotano2dnra = rpotano2dnra *sc fdenit = rpotano2denit/(rpotano2denit + rpotano2dnra + eps) fdnra = 1. - fdenit ! potential fractional change - ano2denit = fdenit * potdano2 - ano2dnra = fdnra * potdano2 - potddet = potddet + 1./280.*ano2denit + 1./(93. + 1./3.)*ano2dnra ! P units + ano2denit = fdenit * potdano2 / 280. ! P units + ano2dnra = fdnra * potdano2 / (93. + 1./3.) ! P units + potddet = potddet + ano2denit + ano2dnra ! P units ! limitation of processes due to detritus - fdetano2denit = 1./280.*ano2denit/(potddet + eps) - fdetdnra = 1./(93. + 1./3.)*ano2dnra/(potddet + eps) - dnra = 1 + fdetano2denit = ano2denit /(potddet + eps) + fdetdnra = ano2dnra /(potddet + eps) + dnra_use = 1 + endif ! limitation of processes due to detritus potddet = max(0.,min(potddet,ocetra(i,j,k,idet))) - if(n2oden+dnra>0 .and. potddet>0.)then + if((n2oden+dnra_use)>0 .and. potddet>0.)then dano2 = 0. dan2o = 0. dgasnit = 0. @@ -492,7 +494,7 @@ subroutine denit_dnra(kpie,kpje,kpke,pddpo,omask,ptho) dalk = 15.*an2odenit/280. endif - if (dnra == 1)then + if (dnra_use == 1)then ! change of NO2 and N2O in N units ano2denit = fdetano2denit*280.*potddet ano2dnra = fdetdnra * (93. + 1./3.)*potddet From 92965eae876076c87b79871fe74ac4f88ba463b1 Mon Sep 17 00:00:00 2001 From: Mats Bentsen Date: Wed, 25 May 2022 15:55:56 +0200 Subject: [PATCH 094/366] - Modified boundary limiting for PPM. - Enforced monotonicity for edge values of neighbouring polynomial reconstructions. - Added additional regridding routine that finds direct intersections with the reconstructed polynomials. - Added array data structure and split the previous reconstruction data structure into specific structures for grid and source data. - Added routine to extract polynomial coefficients of a reconstruction. - Added limiting functionality for PQM. - Formatting change of array indices. - Declared "pure" routines where possible. --- phy/mod_hor3map.F90 | 4792 +++++++++++++++++++++++++++++++------------ 1 file changed, 3473 insertions(+), 1319 deletions(-) diff --git a/phy/mod_hor3map.F90 b/phy/mod_hor3map.F90 index 569065f3..e5ba4ed3 100644 --- a/phy/mod_hor3map.F90 +++ b/phy/mod_hor3map.F90 @@ -1,5 +1,5 @@ ! ------------------------------------------------------------------------------ -! Copyright (C) 2021 Mats Bentsen +! Copyright (C) 2021-2022 Mats Bentsen ! ! This file is part of BLOM. ! @@ -56,49 +56,56 @@ module mod_hor3map ! Error parameters. integer, parameter :: & - hor3map_noerr = 0, & - hor3map_invalid_method = 1, & - hor3map_nonmonotonic_src_edges = 2, & - hor3map_src_extent_too_small = 3, & - hor3map_failed_to_allocate_rcs = 4, & - hor3map_recon_not_prepared = 5, & - hor3map_inconsistent_grid_range = 6, & - hor3map_nonmonotonic_dst_edges = 7, & - hor3map_failed_to_allocate_rms = 8, & - hor3map_src_size_mismatch = 9, & - hor3map_invalid_plm_limiting = 10, & - hor3map_invalid_ppm_limiting = 11, & - hor3map_invalid_pqm_limiting = 12, & - hor3map_recon_not_available = 13, & - hor3map_grd_size_mismatch = 14, & - hor3map_remap_not_prepared = 15, & - hor3map_dst_size_mismatch = 16, & - hor3map_errmsg_num = 16 + hor3map_noerr = 0, & + hor3map_invalid_method = 1, & + hor3map_resizing_initialized_rcgs = 2, & + hor3map_nonmonotonic_src_edges = 3, & + hor3map_src_extent_too_small = 4, & + hor3map_failed_to_allocate_rcgs = 5, & + hor3map_recon_not_prepared = 6, & + hor3map_resizing_initialized_rms = 7, & + hor3map_inconsistent_grid_range = 8, & + hor3map_nonmonotonic_dst_edges = 9, & + hor3map_failed_to_allocate_rms = 10, & + hor3map_src_size_mismatch = 11, & + hor3map_failed_to_allocate_rcss = 12, & + hor3map_invalid_plm_limiting = 13, & + 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 character(len = 80), dimension(hor3map_errmsg_num), parameter :: errmsg = & ["Invalid reconstruction method! ", & + "Cannot resize initialized reconstruction grid data structure! ", & "Source grid edges do not monotonically increase or decrease! ", & "Source grid extent too small! ", & - "Failed to allocate reconstruction data structure! ", & + "Failed to allocate reconstruction grid data structure! ", & "Call 'prepare_reconstruction' first! ", & + "Cannot resize initialized remapping data structure! ", & "Inconsistent source and destination grid range! ", & "Destination grid edges do not monotonically increase or decrease!", & "Failed to allocate remapping data structure! ", & "Size mismatch between source grid edges and data array! ", & + "Failed to allocate reconstruction source data structure! ", & "Invalid limiting method for PLM! ", & "Invalid limiting method for PPM! ", & "Invalid limiting method for PQM! ", & "Call 'reconstruct' first! ", & "Size mismatch between grid edge values and locations! ", & "Call 'prepare_remapping' first! ", & - "Size mismatch between destination grid edges and data array! "] + "Size mismatch between destination grid edges and data array! ", & + "Array index of data structure is out of bounds! ", & + "Inconsistent data structure for reconstruction and remapping! "] ! Numeric data types. integer, parameter :: & r8 = real64 - ! Maximum order of accuracy in edge estimation. - integer, parameter :: maxord = 6 - ! Small non-dimensional value. real(r8), parameter :: eps = 1.e-14_r8 @@ -115,41 +122,126 @@ module mod_hor3map ! Numeric constants. real(r8), parameter :: & c0 = 0._r8, c1 = 1._r8, c2 = 2._r8, c3 = 3._r8, c4 = 4._r8, c5 = 5._r8, & - c6 = 6._r8, c12 = 12._r8, c15 = 15._r8, c18 = 18._r8, c28 = 28._r8, & - c30 = 30._r8, c32 = 32._r8, c60 = 60._r8, & + c6 = 6._r8, c10 = 10._r8, c12 = 12._r8, c15 = 15._r8, c18 = 18._r8, & + c20 = 20._r8, c28 = 28._r8, c30 = 30._r8, c32 = 32._r8, c60 = 60._r8, & c1_2 = 1._r8/2._r8, c1_3 = 1._r8/3._r8, c1_4 = 1._r8/4._r8, & - c1_5 = 1._r8/5._r8, c1_6 = 1._r8/6._r8, c1_12 = 1._r8/12._r8, & - c1_24 = 1._r8/24._r8, c1_80 = 1._r8/80._r8, c1_120 = 1._r8/120._r8, & - c3_4 = 3._r8/4._r8, c3_2 = 3._r8/2._r8, c5_2 = 5._r8/2._r8, & + c1_5 = 1._r8/5._r8, c1_6 = 1._r8/6._r8, c1_8 = 1._r8/8._r8, & + c1_12 = 1._r8/12._r8, c1_16 = 1._r8/16._r8, c1_24 = 1._r8/24._r8, & + c1_80 = 1._r8/80._r8, c1_120 = 1._r8/120._r8, & + c2_3 = 2._r8/3._r8, c3_4 = 3._r8/4._r8, c3_2 = 3._r8/2._r8, & + c5_2 = 5._r8/2._r8, c8_3 = 8._r8/3._r8, c10_3 = 10._r8/3._r8, & c9_2 = 9._r8/2._r8 - type reconstruction_struct - real(r8), allocatable, dimension(:, :) :: & - tdecoeff, tdscoeff, lblu, rblu, polycoeff + type :: recon_grd_struct + + integer :: & + i_lbound = 1, & + i_ubound = 1, & + j_lbound = 1, & + j_ubound = 1, & + i_index = 1, & + j_index = 1, & + i_index_curr = 0, & + j_index_curr = 0, & + method = hor3map_ppm + logical :: & + initialized = .false. + integer :: n_src, p_ord + + real(r8), allocatable, dimension(:,:,:) :: & + tdecoeff_data, tdscoeff_data, lblu_data, rblu_data + real(r8), allocatable, dimension(:,:) :: & + x_edge_src_data, h_src_data, hi_src_data, hci_src_data, & + src_dst_weight_data real(r8), allocatable, dimension(:) :: & - x_edge_src, h_src, hi_src, hci_src, src_dst_weight, & + x_eps_data + integer, allocatable, dimension(:,:) :: & + src_dst_index_data + integer, allocatable, dimension(:) :: & + n_src_actual_data, method_actual_data + logical, allocatable, dimension(:) :: & + prepared_data + + real(r8), dimension(:,:), pointer :: & + tdecoeff, tdscoeff, lblu, rblu + real(r8), dimension(:), pointer :: & + x_edge_src, h_src, hi_src, hci_src, & + src_dst_weight + real(r8), pointer :: & + x_eps + integer, dimension(:), pointer :: & + src_dst_index + integer, pointer :: & + n_src_actual, method_actual + logical, pointer :: & + prepared + + type(recon_src_struct), pointer :: rcss_dep_head + type(remap_struct), pointer :: rms_dep_head + + end type recon_grd_struct + + type :: recon_src_struct + + integer :: & + limiting = hor3map_monotonic, & + i_index_curr = 0, & + j_index_curr = 0 + logical :: & + pc_left_bndr = .true., & + pc_right_bndr = .true., & + initialized = .false. + real(r8) :: u_range, u_eps, uu_eps + + real(r8), allocatable, dimension(:,:,:) :: & + polycoeff_data + real(r8), allocatable, dimension(:,:) :: & + u_src_data, uel_data, uer_data, usl_data, usr_data + logical, allocatable, dimension(:) :: & + reconstructed_data + + real(r8), dimension(:,:), pointer :: & + polycoeff + real(r8), dimension(:), pointer :: & u_src, uel, uer, usl, usr - real(r8) :: x_eps - integer, allocatable, dimension(:) :: src_dst_index - integer :: n_src_all, n_src, method + logical, pointer :: & + reconstructed + + type(recon_grd_struct), pointer :: rcgs + type(recon_src_struct), pointer :: rcss_dep_next + + end type recon_src_struct + + type :: remap_struct + + integer :: & + i_index_curr = 0, & + j_index_curr = 0 logical :: & - alloced = .false., & - prepared = .false., & - reconstructed = .false. - end type reconstruction_struct - - type remap_struct - real(r8), allocatable, dimension(:) :: h_dst, hi_dst, seg_int_lim - integer, allocatable, dimension(:) :: n_src_seg, seg_dst_index + initialized = .false. integer :: n_dst - logical :: & - alloced = .false., & - prepared = .false. + + real(r8), allocatable, dimension(:,:) :: & + h_dst_data, hi_dst_data, seg_int_lim_data + integer, allocatable, dimension(:,:) :: & + n_src_seg_data, seg_dst_index_data + logical, allocatable, dimension(:) :: & + prepared_data + + real(r8), dimension(:), pointer :: h_dst, hi_dst, seg_int_lim + integer, dimension(:), pointer :: n_src_seg, seg_dst_index + logical, pointer :: prepared + + type(recon_grd_struct), pointer :: rcgs + type(remap_struct), pointer :: rms_dep_next + end type remap_struct - public :: reconstruction_struct, remap_struct, & + public :: recon_grd_struct, recon_src_struct, remap_struct, & + initialize_rcgs, initialize_rcss, initialize_rms, & prepare_reconstruction, prepare_remapping, & - reconstruct, regrid, remap, free_rcs, free_rms, & + reconstruct, extract_polycoeff, regrid, regrid2, remap, & + free_rcgs, free_rcss, free_rms, & hor3map_pcm, hor3map_plm, hor3map_ppm, hor3map_pqm, & hor3map_no_limiting, hor3map_monotonic, hor3map_non_oscillatory, & hor3map_non_oscillatory_posdef, & @@ -161,92 +253,170 @@ module mod_hor3map ! Private procedures. ! --------------------------------------------------------------------------- - function allocate_rcs(rcs) result(errstat) + function assign_ptr_rcgs(rcgs) result(errstat) ! --------------------------------------------------------------------------- - ! Allocate arrays in the reconstruction data structure. + ! Assign array pointers within reconstruction grid data structure. ! --------------------------------------------------------------------------- - type(reconstruction_struct), intent(inout) :: rcs + type(recon_grd_struct), target, intent(inout) :: rcgs integer :: errstat - integer :: allocstat - - allocate(rcs%x_edge_src(rcs%n_src_all + 1), rcs%h_src(rcs%n_src_all), & - rcs%hi_src(rcs%n_src_all), rcs%hci_src(2:rcs%n_src_all - 1), & - rcs%src_dst_weight(rcs%n_src_all), & - rcs%tdecoeff(maxord, rcs%n_src_all), & - rcs%tdscoeff(maxord, rcs%n_src_all), & - rcs%lblu(maxord, maxord), rcs%rblu(maxord, maxord), & - rcs%u_src(rcs%n_src_all), & - rcs%uel(rcs%n_src_all), rcs%uer(rcs%n_src_all), & - rcs%usl(rcs%n_src_all), rcs%usr(rcs%n_src_all), & - rcs%src_dst_index(rcs%n_src_all), & - rcs%polycoeff(maxord - 1, rcs%n_src_all), & - stat = allocstat) + integer :: ij_index - if (allocstat == 0) then - errstat = hor3map_noerr - else - errstat = hor3map_failed_to_allocate_rcs + errstat = hor3map_noerr + + ! Check if new pointer assignments are needed. + if (rcgs%i_index == rcgs%i_index_curr .and. & + rcgs%j_index == rcgs%j_index_curr) return + + ! Check index bounds. + if (rcgs%i_index < rcgs%i_lbound .or. rcgs%i_index > rcgs%i_ubound .or. & + rcgs%j_index < rcgs%j_lbound .or. rcgs%j_index > rcgs%j_ubound) then + errstat = hor3map_index_out_of_bounds return endif - rcs%alloced = .true. + ! Assign array pointers within the reconstruction grid data structure. + + ij_index = rcgs%i_index - rcgs%i_lbound + 1 & + + (rcgs%j_index - rcgs%j_lbound) & + *(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) + rcgs%h_src => rcgs%h_src_data(:,ij_index) + rcgs%hi_src => rcgs%hi_src_data(:,ij_index) + rcgs%src_dst_index => rcgs%src_dst_index_data(:,ij_index) + rcgs%n_src_actual => rcgs%n_src_actual_data(ij_index) + rcgs%method_actual => rcgs%method_actual_data(ij_index) + rcgs%prepared => rcgs%prepared_data(ij_index) + if (rcgs%method /= hor3map_pcm) then + rcgs%hci_src => rcgs%hci_src_data(:,ij_index) + endif + if (rcgs%method == hor3map_ppm .or. rcgs%method == hor3map_pqm) then + rcgs%src_dst_weight => rcgs%src_dst_weight_data(:,ij_index) + rcgs%tdecoeff => rcgs%tdecoeff_data(:,:,ij_index) + rcgs%tdscoeff => rcgs%tdscoeff_data(:,:,ij_index) + rcgs%lblu => rcgs%lblu_data(:,:,ij_index) + rcgs%rblu => rcgs%rblu_data(:,:,ij_index) + endif + + rcgs%i_index_curr = rcgs%i_index + rcgs%j_index_curr = rcgs%j_index - end function allocate_rcs + end function assign_ptr_rcgs - function allocate_rms(rcs, rms) result(errstat) + function assign_ptr_rcss(rcss) result(errstat) ! --------------------------------------------------------------------------- - ! Allocate arrays in the remapping data structure. + ! Assign array pointers within reconstruction grid and source data + ! structures. ! --------------------------------------------------------------------------- - type(reconstruction_struct), intent(in) :: rcs - type(remap_struct), intent(inout) :: rms + type(recon_src_struct), target, intent(inout) :: rcss integer :: errstat - integer :: allocstat + integer :: ij_index - allocate(rms%h_dst(rms%n_dst), rms%hi_dst(rms%n_dst), & - rms%seg_int_lim(rcs%n_src_all + rms%n_dst), & - rms%n_src_seg(rcs%n_src_all), & - rms%seg_dst_index(rcs%n_src_all + rms%n_dst), & - stat = allocstat) + errstat = hor3map_noerr - if (allocstat == 0) then - errstat = hor3map_noerr - else - errstat = hor3map_failed_to_allocate_rms + ! Check if new pointer assignments are needed. + if (rcss%rcgs%i_index == rcss%i_index_curr .and. & + rcss%rcgs%j_index == rcss%j_index_curr) return + + ! Check index bounds. + if (rcss%rcgs%i_index < rcss%rcgs%i_lbound .or. & + rcss%rcgs%i_index > rcss%rcgs%i_ubound .or. & + rcss%rcgs%j_index < rcss%rcgs%j_lbound .or. & + rcss%rcgs%j_index > rcss%rcgs%j_ubound) then + errstat = hor3map_index_out_of_bounds + return + endif + + ij_index = rcss%rcgs%i_index - rcss%rcgs%i_lbound + 1 & + + (rcss%rcgs%j_index - rcss%rcgs%j_lbound) & + *(rcss%rcgs%i_ubound - rcss%rcgs%i_lbound + 1) + + rcss%u_src => rcss%u_src_data(:,ij_index) + rcss%uel => rcss%uel_data(:,ij_index) + rcss%uer => rcss%uer_data(:,ij_index) + rcss%polycoeff => rcss%polycoeff_data(:,:,ij_index) + rcss%reconstructed => rcss%reconstructed_data(ij_index) + if (rcss%rcgs%method == hor3map_pqm) then + rcss%usl => rcss%usl_data(:,ij_index) + rcss%usr => rcss%usr_data(:,ij_index) + endif + + rcss%i_index_curr = rcss%rcgs%i_index + rcss%j_index_curr = rcss%rcgs%j_index + + end function assign_ptr_rcss + + function assign_ptr_rms(rms) result(errstat) + ! --------------------------------------------------------------------------- + ! Assign array pointers within the remapping data structure. + ! --------------------------------------------------------------------------- + + type(remap_struct), target, intent(inout) :: rms + + integer :: errstat + + integer :: ij_index + + errstat = hor3map_noerr + + ! Check if new pointer assignments are needed. + if (rms%rcgs%i_index == rms%i_index_curr .and. & + rms%rcgs%j_index == rms%j_index_curr) return + + ! Check index bounds. + if (rms%rcgs%i_index < rms%rcgs%i_lbound .or. & + rms%rcgs%i_index > rms%rcgs%i_ubound .or. & + rms%rcgs%j_index < rms%rcgs%j_lbound .or. & + rms%rcgs%j_index > rms%rcgs%j_ubound) then + errstat = hor3map_index_out_of_bounds return endif - rms%alloced = .true. + ij_index = rms%rcgs%i_index - rms%rcgs%i_lbound + 1 & + + (rms%rcgs%j_index - rms%rcgs%j_lbound) & + *(rms%rcgs%i_ubound - rms%rcgs%i_lbound + 1) + + rms%h_dst => rms%h_dst_data(:,ij_index) + rms%hi_dst => rms%hi_dst_data(:,ij_index) + rms%seg_int_lim => rms%seg_int_lim_data(:,ij_index) + rms%n_src_seg => rms%n_src_seg_data(:,ij_index) + rms%seg_dst_index => rms%seg_dst_index_data(:,ij_index) + rms%prepared => rms%prepared_data(ij_index) - end function allocate_rms + rms%i_index_curr = rms%rcgs%i_index + rms%j_index_curr = rms%rcgs%j_index - subroutine lu_decompose(n, a) + end function assign_ptr_rms + + pure subroutine lu_decompose(n, a) ! --------------------------------------------------------------------------- ! Replace the n x n input matrix A with its LU decomposition. ! --------------------------------------------------------------------------- integer, intent(in) :: n - real(r8), dimension(:, :), intent(inout) :: a + real(r8), dimension(:,:), intent(inout) :: a integer :: i, j, k - do k = 1, n - 1 - do i = k + 1, n - a(i, k) = a(i, k)/a(k, k) - do j = k + 1, n - a(i, j) = a(i, j) - a(i, k)*a(k, j) + do k = 1, n-1 + do i = k+1, n + a(i,k) = a(i,k)/a(k,k) + do j = k+1, n + a(i,j) = a(i,j) - a(i,k)*a(k,j) enddo enddo enddo end subroutine lu_decompose - subroutine lu_solve(n, lu, x) + pure subroutine lu_solve(n, lu, x) ! --------------------------------------------------------------------------- ! Solve the linear system of equations A*x = b using the LU decomposition of ! the n x n matrix A. The argument x has b as input and is replaced with the @@ -254,30 +424,30 @@ subroutine lu_solve(n, lu, x) ! --------------------------------------------------------------------------- integer, intent(in) :: n - real(r8), dimension(:, :), intent(in) :: lu + real(r8), dimension(:,:), intent(in) :: lu real(r8), dimension(:), intent(inout) :: x integer :: i, j ! Forward substitution. do i = 2, n - do j = 1, i - 1 - x(i) = x(i) - lu(i, j)*x(j) + do j = 1, i-1 + x(i) = x(i) - lu(i,j)*x(j) enddo enddo ! Back substitution. x(n) = x(n)/lu(n, n) - do i = n - 1, 1, -1 - do j = i + 1, n - x(i) = x(i) - lu(i, j)*x(j) + do i = n-1, 1, -1 + do j = i+1, n + x(i) = x(i) - lu(i,j)*x(j) enddo - x(i) = x(i)/lu(i, i) + x(i) = x(i)/lu(i,i) enddo end subroutine lu_solve - subroutine edge_ih4_coeff(h, tdecoeff) + pure subroutine edge_ih4_coeff(h, tdecoeff) ! --------------------------------------------------------------------------- ! Compute row coefficients for the tridiagonal system of equations to be ! solved for 4th order accurate edge estimates. @@ -296,37 +466,37 @@ subroutine edge_ih4_coeff(h, tdecoeff) end subroutine edge_ih4_coeff - subroutine edge_ih6_slope_ih5_coeff_common(a, tdecoeff, tdscoeff) + pure subroutine edge_ih6_slope_ih5_coeff_common(a, tdecoeff, tdscoeff) ! --------------------------------------------------------------------------- ! Common procedure for the various stencils for the computation of row ! coefficients for the tridiagonal system of equations to be solved for 6th ! and 5th order accurate edge and slope estimates, respectively. ! --------------------------------------------------------------------------- - real(r8), dimension(:, :), intent(inout) :: a + real(r8), dimension(:,:), intent(inout) :: a real(r8), dimension(:), intent(inout) :: tdecoeff, tdscoeff - real(r8), dimension(6, 6) :: b + real(r8), dimension(6,6) :: b ! Define matrix for linear system to be solved for slope coefficients. - b(1:5, 3:6) = a(2:6, 3:6) + b(1:5,3:6) = a(2:6,3:6) - b(1, 1) = c1 - b(2, 1) = c2*a(2, 1) - b(3, 1) = c3*a(3, 1) - b(4, 1) = c4*a(4, 1) - b(5, 1) = c5*a(5, 1) - b(6, 1) = c0 + b(1,1) = c1 + b(2,1) = c2*a(2,1) + b(3,1) = c3*a(3,1) + b(4,1) = c4*a(4,1) + b(5,1) = c5*a(5,1) + b(6,1) = c0 - b(1, 2) = c1 - b(2, 2) = c2*a(2, 2) - b(3, 2) = c3*a(3, 2) - b(4, 2) = c4*a(4, 2) - b(5, 2) = c5*a(5, 2) - b(6, 2) = c0 + b(1,2) = c1 + b(2,2) = c2*a(2,2) + b(3,2) = c3*a(3,2) + b(4,2) = c4*a(4,2) + b(5,2) = c5*a(5,2) + b(6,2) = c0 - b(6, 3:6) = c1 + b(6,3:6) = c1 ! Solve linear system for edge coefficients. tdecoeff(:) = [ - c1, c0, c0, c0, c0, c0] @@ -340,7 +510,7 @@ subroutine edge_ih6_slope_ih5_coeff_common(a, tdecoeff, tdscoeff) end subroutine edge_ih6_slope_ih5_coeff_common - subroutine edge_ih6_slope_ih5_coeff_asymleft(h, tdecoeff, tdscoeff) + pure subroutine edge_ih6_slope_ih5_coeff_asymleft(h, tdecoeff, tdscoeff) ! --------------------------------------------------------------------------- ! With an asymmetrical stencil, where edge values are shifted left compared ! to cell mean values, compute row coefficients for the tridiagonal system of @@ -351,62 +521,62 @@ subroutine edge_ih6_slope_ih5_coeff_asymleft(h, tdecoeff, tdscoeff) real(r8), dimension(:), intent(in) :: h real(r8), dimension(:), intent(inout) :: tdecoeff, tdscoeff - real(r8), dimension(6, 6) :: a + real(r8), dimension(6,6) :: a real(r8) :: a25sq, a26sq, h3sq, h4sq ! Define matrix for linear system to be solved for edge coefficients. - a(1, 1) = c1 - a(2, 1) = - h(1) - a(3, 1) = - a(2, 1)*h(1) - a(4, 1) = - a(3, 1)*h(1) - a(5, 1) = - a(4, 1)*h(1) - a(6, 1) = - a(5, 1)*h(1) - - a(1, 2) = c1 - a(2, 2) = h(2) - a(3, 2) = a(2, 2)*h(2) - a(4, 2) = a(3, 2)*h(2) - a(5, 2) = a(4, 2)*h(2) - a(6, 2) = a(5, 2)*h(2) - - a(1, 3) = - c1 - a(2, 3) = - c1_2*a(2, 1) - a(3, 3) = - c1_3*a(3, 1) - a(4, 3) = - c1_4*a(4, 1) - a(5, 3) = - c1_5*a(5, 1) - a(6, 3) = - c1_6*a(6, 1) - - a(1, 4) = - c1 - a(2, 4) = - c1_2*a(2, 2) - a(3, 4) = - c1_3*a(3, 2) - a(4, 4) = - c1_4*a(4, 2) - a(5, 4) = - c1_5*a(5, 2) - a(6, 4) = - c1_6*a(6, 2) - - a(1, 5) = - c1 - a(2, 5) = - h(2) - c1_2*h(3) - a25sq = a(2, 5)*a(2, 5) + a(1,1) = c1 + a(2,1) = - h(1) + a(3,1) = - a(2,1)*h(1) + a(4,1) = - a(3,1)*h(1) + a(5,1) = - a(4,1)*h(1) + a(6,1) = - a(5,1)*h(1) + + a(1,2) = c1 + a(2,2) = h(2) + a(3,2) = a(2,2)*h(2) + a(4,2) = a(3,2)*h(2) + a(5,2) = a(4,2)*h(2) + a(6,2) = a(5,2)*h(2) + + a(1,3) = - c1 + a(2,3) = - c1_2*a(2,1) + a(3,3) = - c1_3*a(3,1) + a(4,3) = - c1_4*a(4,1) + a(5,3) = - c1_5*a(5,1) + a(6,3) = - c1_6*a(6,1) + + a(1,4) = - c1 + a(2,4) = - c1_2*a(2,2) + a(3,4) = - c1_3*a(3,2) + a(4,4) = - c1_4*a(4,2) + a(5,4) = - c1_5*a(5,2) + a(6,4) = - c1_6*a(6,2) + + a(1,5) = - c1 + a(2,5) = - h(2) - c1_2*h(3) + a25sq = a(2,5)*a(2,5) h3sq = h(3)*h(3) - a(3, 5) = - a25sq - c1_12*h3sq - a(4, 5) = a(2, 5)*(a25sq + c1_4*h3sq) - a(5, 5) = - a25sq*(a25sq + c1_2*h3sq) - c1_80*h3sq*h3sq - a(6, 5) = a(2, 5)*(a25sq + c3_4*h3sq)*(a25sq + c1_12*h3sq) - - a(1, 6) = - c1 - a(2, 6) = - h(2) - h(3) - c1_2*h(4) - a26sq = a(2, 6)*a(2, 6) + a(3,5) = - a25sq - c1_12*h3sq + a(4,5) = a(2,5)*(a25sq + c1_4*h3sq) + a(5,5) = - a25sq*(a25sq + c1_2*h3sq) - c1_80*h3sq*h3sq + a(6,5) = a(2,5)*(a25sq + c3_4*h3sq)*(a25sq + c1_12*h3sq) + + a(1,6) = - c1 + a(2,6) = - h(2) - h(3) - c1_2*h(4) + a26sq = a(2,6)*a(2,6) h4sq = h(4)*h(4) - a(3, 6) = - a26sq - c1_12*h4sq - a(4, 6) = a(2, 6)*(a26sq + c1_4*h4sq) - a(5, 6) = - a26sq*(a26sq + c1_2*h4sq) - c1_80*h4sq*h4sq - a(6, 6) = a(2, 6)*(a26sq + c3_4*h4sq)*(a26sq + c1_12*h4sq) + a(3,6) = - a26sq - c1_12*h4sq + a(4,6) = a(2,6)*(a26sq + c1_4*h4sq) + a(5,6) = - a26sq*(a26sq + c1_2*h4sq) - c1_80*h4sq*h4sq + a(6,6) = a(2,6)*(a26sq + c3_4*h4sq)*(a26sq + c1_12*h4sq) call edge_ih6_slope_ih5_coeff_common(a, tdecoeff, tdscoeff) end subroutine edge_ih6_slope_ih5_coeff_asymleft - subroutine edge_ih6_slope_ih5_coeff_sym(h, tdecoeff, tdscoeff) + pure subroutine edge_ih6_slope_ih5_coeff_sym(h, tdecoeff, tdscoeff) ! --------------------------------------------------------------------------- ! With a symmetrical stencil, compute row coefficients for the tridiagonal ! system of equations to be solved for 6th and 5th order accurate edge and @@ -416,62 +586,62 @@ subroutine edge_ih6_slope_ih5_coeff_sym(h, tdecoeff, tdscoeff) real(r8), dimension(:), intent(in) :: h real(r8), dimension(:), intent(inout) :: tdecoeff, tdscoeff - real(r8), dimension(6, 6) :: a + real(r8), dimension(6,6) :: a real(r8) :: a23sq, a26sq, h1sq, h4sq ! Define matrix for linear system to be solved for edge coefficients. - a(1, 1) = c1 - a(2, 1) = - h(2) - a(3, 1) = - a(2, 1)*h(2) - a(4, 1) = - a(3, 1)*h(2) - a(5, 1) = - a(4, 1)*h(2) - a(6, 1) = - a(5, 1)*h(2) - - a(1, 2) = c1 - a(2, 2) = h(3) - a(3, 2) = a(2, 2)*h(3) - a(4, 2) = a(3, 2)*h(3) - a(5, 2) = a(4, 2)*h(3) - a(6, 2) = a(5, 2)*h(3) - - a(1, 3) = - c1 - a(2, 3) = c1_2*h(1) + h(2) - a23sq = a(2, 3)*a(2, 3) + a(1,1) = c1 + a(2,1) = - h(2) + a(3,1) = - a(2,1)*h(2) + a(4,1) = - a(3,1)*h(2) + a(5,1) = - a(4,1)*h(2) + a(6,1) = - a(5,1)*h(2) + + a(1,2) = c1 + a(2,2) = h(3) + a(3,2) = a(2,2)*h(3) + a(4,2) = a(3,2)*h(3) + a(5,2) = a(4,2)*h(3) + a(6,2) = a(5,2)*h(3) + + a(1,3) = - c1 + a(2,3) = c1_2*h(1) + h(2) + a23sq = a(2,3)*a(2,3) h1sq = h(1)*h(1) - a(3, 3) = - a23sq - c1_12*h1sq - a(4, 3) = a(2, 3)*(a23sq + c1_4*h1sq) - a(5, 3) = - a23sq*(a23sq + c1_2*h1sq) - c1_80*h1sq*h1sq - a(6, 3) = a(2, 3)*(a23sq + c3_4*h1sq)*(a23sq + c1_12*h1sq) - - a(1, 4) = - c1 - a(2, 4) = - c1_2*a(2, 1) - a(3, 4) = - c1_3*a(3, 1) - a(4, 4) = - c1_4*a(4, 1) - a(5, 4) = - c1_5*a(5, 1) - a(6, 4) = - c1_6*a(6, 1) - - a(1, 5) = - c1 - a(2, 5) = - c1_2*a(2, 2) - a(3, 5) = - c1_3*a(3, 2) - a(4, 5) = - c1_4*a(4, 2) - a(5, 5) = - c1_5*a(5, 2) - a(6, 5) = - c1_6*a(6, 2) - - a(1, 6) = - c1 - a(2, 6) = - h(3) - c1_2*h(4) - a26sq = a(2, 6)*a(2, 6) + a(3,3) = - a23sq - c1_12*h1sq + a(4,3) = a(2,3)*(a23sq + c1_4*h1sq) + a(5,3) = - a23sq*(a23sq + c1_2*h1sq) - c1_80*h1sq*h1sq + a(6,3) = a(2,3)*(a23sq + c3_4*h1sq)*(a23sq + c1_12*h1sq) + + a(1,4) = - c1 + a(2,4) = - c1_2*a(2,1) + a(3,4) = - c1_3*a(3,1) + a(4,4) = - c1_4*a(4,1) + a(5,4) = - c1_5*a(5,1) + a(6,4) = - c1_6*a(6,1) + + a(1,5) = - c1 + a(2,5) = - c1_2*a(2,2) + a(3,5) = - c1_3*a(3,2) + a(4,5) = - c1_4*a(4,2) + a(5,5) = - c1_5*a(5,2) + a(6,5) = - c1_6*a(6,2) + + a(1,6) = - c1 + a(2,6) = - h(3) - c1_2*h(4) + a26sq = a(2,6)*a(2,6) h4sq = h(4)*h(4) - a(3, 6) = - a26sq - c1_12*h4sq - a(4, 6) = a(2, 6)*(a26sq + c1_4*h4sq) - a(5, 6) = - a26sq*(a26sq + c1_2*h4sq) - c1_80*h4sq*h4sq - a(6, 6) = a(2, 6)*(a26sq + c3_4*h4sq)*(a26sq + c1_12*h4sq) + a(3,6) = - a26sq - c1_12*h4sq + a(4,6) = a(2,6)*(a26sq + c1_4*h4sq) + a(5,6) = - a26sq*(a26sq + c1_2*h4sq) - c1_80*h4sq*h4sq + a(6,6) = a(2,6)*(a26sq + c3_4*h4sq)*(a26sq + c1_12*h4sq) call edge_ih6_slope_ih5_coeff_common(a, tdecoeff, tdscoeff) end subroutine edge_ih6_slope_ih5_coeff_sym - subroutine edge_ih6_slope_ih5_coeff_asymright(h, tdecoeff, tdscoeff) + pure subroutine edge_ih6_slope_ih5_coeff_asymright(h, tdecoeff, tdscoeff) ! --------------------------------------------------------------------------- ! With an asymmetrical stencil, where edge values are shifted left compared ! to cell mean values, compute row coefficients for the tridiagonal system of @@ -482,302 +652,303 @@ subroutine edge_ih6_slope_ih5_coeff_asymright(h, tdecoeff, tdscoeff) real(r8), dimension(:), intent(in) :: h real(r8), dimension(:), intent(inout) :: tdecoeff, tdscoeff - real(r8), dimension(6, 6) :: a + real(r8), dimension(6,6) :: a real(r8) :: a23sq, a24sq, h1sq, h2sq ! Define matrix for linear system to be solved for edge coefficients. - a(1, 1) = c1 - a(2, 1) = - h(3) - a(3, 1) = - a(2, 1)*h(3) - a(4, 1) = - a(3, 1)*h(3) - a(5, 1) = - a(4, 1)*h(3) - a(6, 1) = - a(5, 1)*h(3) - - a(1, 2) = c1 - a(2, 2) = h(4) - a(3, 2) = a(2, 2)*h(4) - a(4, 2) = a(3, 2)*h(4) - a(5, 2) = a(4, 2)*h(4) - a(6, 2) = a(5, 2)*h(4) - - a(1, 3) = - c1 - a(2, 3) = c1_2*h(1) + h(2) + h(3) - a23sq = a(2, 3)*a(2, 3) + a(1,1) = c1 + a(2,1) = - h(3) + a(3,1) = - a(2,1)*h(3) + a(4,1) = - a(3,1)*h(3) + a(5,1) = - a(4,1)*h(3) + a(6,1) = - a(5,1)*h(3) + + a(1,2) = c1 + a(2,2) = h(4) + a(3,2) = a(2,2)*h(4) + a(4,2) = a(3,2)*h(4) + a(5,2) = a(4,2)*h(4) + a(6,2) = a(5,2)*h(4) + + a(1,3) = - c1 + a(2,3) = c1_2*h(1) + h(2) + h(3) + a23sq = a(2,3)*a(2,3) h1sq = h(1)*h(1) - a(3, 3) = - a23sq - c1_12*h1sq - a(4, 3) = a(2, 3)*(a23sq + c1_4*h1sq) - a(5, 3) = - a23sq*(a23sq + c1_2*h1sq) - c1_80*h1sq*h1sq - a(6, 3) = a(2, 3)*(a23sq + c3_4*h1sq)*(a23sq + c1_12*h1sq) - - a(1, 4) = - c1 - a(2, 4) = c1_2*h(2) + h(3) - a24sq = a(2, 4)*a(2, 4) + a(3,3) = - a23sq - c1_12*h1sq + a(4,3) = a(2,3)*(a23sq + c1_4*h1sq) + a(5,3) = - a23sq*(a23sq + c1_2*h1sq) - c1_80*h1sq*h1sq + a(6,3) = a(2,3)*(a23sq + c3_4*h1sq)*(a23sq + c1_12*h1sq) + + a(1,4) = - c1 + a(2,4) = c1_2*h(2) + h(3) + a24sq = a(2,4)*a(2,4) h2sq = h(2)*h(2) - a(3, 4) = - a24sq - c1_12*h2sq - a(4, 4) = a(2, 4)*(a24sq + c1_4*h2sq) - a(5, 4) = - a24sq*(a24sq + c1_2*h2sq) - c1_80*h2sq*h2sq - a(6, 4) = a(2, 4)*(a24sq + c3_4*h2sq)*(a24sq + c1_12*h2sq) - - a(1, 5) = - c1 - a(2, 5) = - c1_2*a(2, 1) - a(3, 5) = - c1_3*a(3, 1) - a(4, 5) = - c1_4*a(4, 1) - a(5, 5) = - c1_5*a(5, 1) - a(6, 5) = - c1_6*a(6, 1) - - a(1, 6) = - c1 - a(2, 6) = - c1_2*a(2, 2) - a(3, 6) = - c1_3*a(3, 2) - a(4, 6) = - c1_4*a(4, 2) - a(5, 6) = - c1_5*a(5, 2) - a(6, 6) = - c1_6*a(6, 2) + a(3,4) = - a24sq - c1_12*h2sq + a(4,4) = a(2,4)*(a24sq + c1_4*h2sq) + a(5,4) = - a24sq*(a24sq + c1_2*h2sq) - c1_80*h2sq*h2sq + a(6,4) = a(2,4)*(a24sq + c3_4*h2sq)*(a24sq + c1_12*h2sq) + + a(1,5) = - c1 + a(2,5) = - c1_2*a(2,1) + a(3,5) = - c1_3*a(3,1) + a(4,5) = - c1_4*a(4,1) + a(5,5) = - c1_5*a(5,1) + a(6,5) = - c1_6*a(6,1) + + a(1,6) = - c1 + a(2,6) = - c1_2*a(2,2) + a(3,6) = - c1_3*a(3,2) + a(4,6) = - c1_4*a(4,2) + a(5,6) = - c1_5*a(5,2) + a(6,6) = - c1_6*a(6,2) call edge_ih6_slope_ih5_coeff_common(a, tdecoeff, tdscoeff) end subroutine edge_ih6_slope_ih5_coeff_asymright - subroutine edge_eh4_lblu(h, a) + pure subroutine edge_eh4_lblu(h, a) ! --------------------------------------------------------------------------- ! Compute LU matrix for explicitly estimating 4th order accurate left ! boundary edge value. ! --------------------------------------------------------------------------- real(r8), dimension(:), intent(in) :: h - real(r8), dimension(:, :), intent(inout) :: a + real(r8), dimension(:,:), intent(inout) :: a real(r8) :: a22sq, a32sq, a42sq, h2sq, h3sq, h4sq ! Define matrix for linear system to be solved for edge value. - a(1:4, 1) = c1 + a(1:4,1) = c1 - a(1, 2) = c1_2*h(1) - a(2, 2) = a(1, 2) + c1_2*(h(1) + h(2)) - a(3, 2) = a(2, 2) + c1_2*(h(2) + h(3)) - a(4, 2) = a(3, 2) + c1_2*(h(3) + h(4)) + a(1,2) = c1_2*h(1) + a(2,2) = a(1,2) + c1_2*(h(1) + h(2)) + a(3,2) = a(2,2) + c1_2*(h(2) + h(3)) + a(4,2) = a(3,2) + c1_2*(h(3) + h(4)) - a22sq = a(2, 2)*a(2, 2) - a32sq = a(3, 2)*a(3, 2) - a42sq = a(4, 2)*a(4, 2) + a22sq = a(2,2)*a(2,2) + a32sq = a(3,2)*a(3,2) + a42sq = a(4,2)*a(4,2) h2sq = h(2)*h(2) h3sq = h(3)*h(3) h4sq = h(4)*h(4) - a(1, 3) = c1_3*a(1, 2)*h(1) - a(2, 3) = c1_2*(a22sq + c1_12*h2sq) - a(3, 3) = c1_2*(a32sq + c1_12*h3sq) - a(4, 3) = c1_2*(a42sq + c1_12*h4sq) + a(1,3) = c1_3*a(1,2)*h(1) + a(2,3) = c1_2*(a22sq + c1_12*h2sq) + a(3,3) = c1_2*(a32sq + c1_12*h3sq) + a(4,3) = c1_2*(a42sq + c1_12*h4sq) - a(1, 4) = c1_4*a(1, 3)*h(1) - a(2, 4) = c1_6*a(2, 2)*(a22sq + c1_4*h2sq) - a(3, 4) = c1_6*a(3, 2)*(a32sq + c1_4*h3sq) - a(4, 4) = c1_6*a(4, 2)*(a42sq + c1_4*h4sq) + a(1,4) = c1_4*a(1,3)*h(1) + a(2,4) = c1_6*a(2,2)*(a22sq + c1_4*h2sq) + a(3,4) = c1_6*a(3,2)*(a32sq + c1_4*h3sq) + a(4,4) = c1_6*a(4,2)*(a42sq + c1_4*h4sq) ! LU decomposition. call lu_decompose(4, a) end subroutine edge_eh4_lblu - subroutine edge_eh4_rblu(h, a) + pure subroutine edge_eh4_rblu(h, a) ! --------------------------------------------------------------------------- ! Compute LU matrix for explicitly estimating 4th order accurate right ! boundary edge value. ! --------------------------------------------------------------------------- real(r8), dimension(:), intent(in) :: h - real(r8), dimension(:, :), intent(inout) :: a + real(r8), dimension(:,:), intent(inout) :: a real(r8) :: a12sq, a22sq, a32sq, h1sq, h2sq, h3sq ! Define matrix for linear system to be solved for edge value. - a(1:4, 1) = c1 + a(1:4,1) = c1 - a(4, 2) = - c1_2*h(4) - a(3, 2) = a(4, 2) - c1_2*(h(4) + h(3)) - a(2, 2) = a(3, 2) - c1_2*(h(3) + h(2)) - a(1, 2) = a(2, 2) - c1_2*(h(2) + h(1)) + a(4,2) = - c1_2*h(4) + a(3,2) = a(4,2) - c1_2*(h(4) + h(3)) + a(2,2) = a(3,2) - c1_2*(h(3) + h(2)) + a(1,2) = a(2,2) - c1_2*(h(2) + h(1)) - a12sq = a(1, 2)*a(1, 2) - a22sq = a(2, 2)*a(2, 2) - a32sq = a(3, 2)*a(3, 2) + a12sq = a(1,2)*a(1,2) + a22sq = a(2,2)*a(2,2) + a32sq = a(3,2)*a(3,2) h1sq = h(1)*h(1) h2sq = h(2)*h(2) h3sq = h(3)*h(3) - a(1, 3) = c1_2*(a12sq + c1_12*h1sq) - a(2, 3) = c1_2*(a22sq + c1_12*h2sq) - a(3, 3) = c1_2*(a32sq + c1_12*h3sq) - a(4, 3) = - c1_3*a(4, 2)*h(4) + a(1,3) = c1_2*(a12sq + c1_12*h1sq) + a(2,3) = c1_2*(a22sq + c1_12*h2sq) + a(3,3) = c1_2*(a32sq + c1_12*h3sq) + a(4,3) = - c1_3*a(4,2)*h(4) - a(1, 4) = c1_6*a(1, 2)*(a12sq + c1_4*h1sq) - a(2, 4) = c1_6*a(2, 2)*(a22sq + c1_4*h2sq) - a(3, 4) = c1_6*a(3, 2)*(a32sq + c1_4*h3sq) - a(4, 4) = - c1_4*a(4, 3)*h(4) + a(1,4) = c1_6*a(1,2)*(a12sq + c1_4*h1sq) + a(2,4) = c1_6*a(2,2)*(a22sq + c1_4*h2sq) + a(3,4) = c1_6*a(3,2)*(a32sq + c1_4*h3sq) + a(4,4) = - c1_4*a(4,3)*h(4) ! LU decomposition. call lu_decompose(4, a) end subroutine edge_eh4_rblu - subroutine edge_eh6_slope_eh5_lblu(h, a) + pure subroutine edge_eh6_slope_eh5_lblu(h, a) ! --------------------------------------------------------------------------- ! Compute LU matrix for explicitly estimating 6th and 5th order accurate left ! edge and slope values, respectively. ! --------------------------------------------------------------------------- real(r8), dimension(:), intent(in) :: h - real(r8), dimension(:, :), intent(inout) :: a + real(r8), dimension(:,:), intent(inout) :: a real(r8) :: a22sq, a32sq, a42sq, a52sq, a62sq, & h2sq, h3sq, h4sq, h5sq, h6sq ! Define matrix for linear system to be solved for edge and slope values. - a(1:6, 1) = c1 + a(1:6,1) = c1 - a(1, 2) = c1_2*h(1) - a(2, 2) = a(1, 2) + c1_2*(h(1) + h(2)) - a(3, 2) = a(2, 2) + c1_2*(h(2) + h(3)) - a(4, 2) = a(3, 2) + c1_2*(h(3) + h(4)) - a(5, 2) = a(4, 2) + c1_2*(h(4) + h(5)) - a(6, 2) = a(5, 2) + c1_2*(h(5) + h(6)) + a(1,2) = c1_2*h(1) + a(2,2) = a(1,2) + c1_2*(h(1) + h(2)) + a(3,2) = a(2,2) + c1_2*(h(2) + h(3)) + a(4,2) = a(3,2) + c1_2*(h(3) + h(4)) + a(5,2) = a(4,2) + c1_2*(h(4) + h(5)) + a(6,2) = a(5,2) + c1_2*(h(5) + h(6)) - a22sq = a(2, 2)*a(2, 2) - a32sq = a(3, 2)*a(3, 2) - a42sq = a(4, 2)*a(4, 2) - a52sq = a(5, 2)*a(5, 2) - a62sq = a(6, 2)*a(6, 2) + a22sq = a(2,2)*a(2,2) + a32sq = a(3,2)*a(3,2) + a42sq = a(4,2)*a(4,2) + a52sq = a(5,2)*a(5,2) + a62sq = a(6,2)*a(6,2) h2sq = h(2)*h(2) h3sq = h(3)*h(3) h4sq = h(4)*h(4) h5sq = h(5)*h(5) h6sq = h(6)*h(6) - a(1, 3) = c1_3*a(1, 2)*h(1) - a(2, 3) = c1_2*(a22sq + c1_12*h2sq) - a(3, 3) = c1_2*(a32sq + c1_12*h3sq) - a(4, 3) = c1_2*(a42sq + c1_12*h4sq) - a(5, 3) = c1_2*(a52sq + c1_12*h5sq) - a(6, 3) = c1_2*(a62sq + c1_12*h6sq) - - a(1, 4) = c1_4*a(1, 3)*h(1) - a(2, 4) = c1_6*a(2, 2)*(a22sq + c1_4*h2sq) - a(3, 4) = c1_6*a(3, 2)*(a32sq + c1_4*h3sq) - a(4, 4) = c1_6*a(4, 2)*(a42sq + c1_4*h4sq) - a(5, 4) = c1_6*a(5, 2)*(a52sq + c1_4*h5sq) - a(6, 4) = c1_6*a(6, 2)*(a62sq + c1_4*h6sq) - - a(1, 5) = c1_5*a(1, 4)*h(1) - a(2, 5) = c1_24*(a22sq*(a22sq + c1_2*h2sq) + c1_80*h2sq*h2sq) - a(3, 5) = c1_24*(a32sq*(a32sq + c1_2*h3sq) + c1_80*h3sq*h3sq) - a(4, 5) = c1_24*(a42sq*(a42sq + c1_2*h4sq) + c1_80*h4sq*h4sq) - a(5, 5) = c1_24*(a52sq*(a52sq + c1_2*h5sq) + c1_80*h5sq*h5sq) - a(6, 5) = c1_24*(a62sq*(a62sq + c1_2*h6sq) + c1_80*h6sq*h6sq) - - a(1, 6) = c1_6*a(1, 5)*h(1) - a(2, 6) = c1_120*a(2, 2)*(a22sq + c3_4*h2sq)*(a22sq + c1_12*h2sq) - a(3, 6) = c1_120*a(3, 2)*(a32sq + c3_4*h3sq)*(a32sq + c1_12*h3sq) - a(4, 6) = c1_120*a(4, 2)*(a42sq + c3_4*h4sq)*(a42sq + c1_12*h4sq) - a(5, 6) = c1_120*a(5, 2)*(a52sq + c3_4*h5sq)*(a52sq + c1_12*h5sq) - a(6, 6) = c1_120*a(6, 2)*(a62sq + c3_4*h6sq)*(a62sq + c1_12*h6sq) + a(1,3) = c1_3*a(1,2)*h(1) + a(2,3) = c1_2*(a22sq + c1_12*h2sq) + a(3,3) = c1_2*(a32sq + c1_12*h3sq) + a(4,3) = c1_2*(a42sq + c1_12*h4sq) + a(5,3) = c1_2*(a52sq + c1_12*h5sq) + a(6,3) = c1_2*(a62sq + c1_12*h6sq) + + a(1,4) = c1_4*a(1,3)*h(1) + a(2,4) = c1_6*a(2,2)*(a22sq + c1_4*h2sq) + a(3,4) = c1_6*a(3,2)*(a32sq + c1_4*h3sq) + a(4,4) = c1_6*a(4,2)*(a42sq + c1_4*h4sq) + a(5,4) = c1_6*a(5,2)*(a52sq + c1_4*h5sq) + a(6,4) = c1_6*a(6,2)*(a62sq + c1_4*h6sq) + + a(1,5) = c1_5*a(1,4)*h(1) + a(2,5) = c1_24*(a22sq*(a22sq + c1_2*h2sq) + c1_80*h2sq*h2sq) + a(3,5) = c1_24*(a32sq*(a32sq + c1_2*h3sq) + c1_80*h3sq*h3sq) + a(4,5) = c1_24*(a42sq*(a42sq + c1_2*h4sq) + c1_80*h4sq*h4sq) + a(5,5) = c1_24*(a52sq*(a52sq + c1_2*h5sq) + c1_80*h5sq*h5sq) + a(6,5) = c1_24*(a62sq*(a62sq + c1_2*h6sq) + c1_80*h6sq*h6sq) + + a(1,6) = c1_6*a(1,5)*h(1) + a(2,6) = c1_120*a(2,2)*(a22sq + c3_4*h2sq)*(a22sq + c1_12*h2sq) + a(3,6) = c1_120*a(3,2)*(a32sq + c3_4*h3sq)*(a32sq + c1_12*h3sq) + a(4,6) = c1_120*a(4,2)*(a42sq + c3_4*h4sq)*(a42sq + c1_12*h4sq) + a(5,6) = c1_120*a(5,2)*(a52sq + c3_4*h5sq)*(a52sq + c1_12*h5sq) + a(6,6) = c1_120*a(6,2)*(a62sq + c3_4*h6sq)*(a62sq + c1_12*h6sq) ! LU decomposition. call lu_decompose(6, a) end subroutine edge_eh6_slope_eh5_lblu - subroutine edge_eh6_slope_eh5_rblu(h, a) + pure subroutine edge_eh6_slope_eh5_rblu(h, a) ! --------------------------------------------------------------------------- ! Compute LU matrix for explicitly estimating 6th and 5th order accurate ! right edge and slope values, respectively. ! --------------------------------------------------------------------------- real(r8), dimension(:), intent(in) :: h - real(r8), dimension(:, :), intent(inout) :: a + real(r8), dimension(:,:), intent(inout) :: a real(r8) :: a12sq, a22sq, a32sq, a42sq, a52sq, & h1sq, h2sq, h3sq, h4sq, h5sq ! Define matrix for linear system to be solved for edge and slope values. - a(1:6, 1) = c1 + a(1:6,1) = c1 - a(6, 2) = - c1_2*h(6) - a(5, 2) = a(6, 2) - c1_2*(h(6) + h(5)) - a(4, 2) = a(5, 2) - c1_2*(h(5) + h(4)) - a(3, 2) = a(4, 2) - c1_2*(h(4) + h(3)) - a(2, 2) = a(3, 2) - c1_2*(h(3) + h(2)) - a(1, 2) = a(2, 2) - c1_2*(h(2) + h(1)) + a(6,2) = - c1_2*h(6) + a(5,2) = a(6,2) - c1_2*(h(6) + h(5)) + a(4,2) = a(5,2) - c1_2*(h(5) + h(4)) + a(3,2) = a(4,2) - c1_2*(h(4) + h(3)) + a(2,2) = a(3,2) - c1_2*(h(3) + h(2)) + a(1,2) = a(2,2) - c1_2*(h(2) + h(1)) - a12sq = a(1, 2)*a(1, 2) - a22sq = a(2, 2)*a(2, 2) - a32sq = a(3, 2)*a(3, 2) - a42sq = a(4, 2)*a(4, 2) - a52sq = a(5, 2)*a(5, 2) + a12sq = a(1,2)*a(1,2) + a22sq = a(2,2)*a(2,2) + a32sq = a(3,2)*a(3,2) + a42sq = a(4,2)*a(4,2) + a52sq = a(5,2)*a(5,2) h1sq = h(1)*h(1) h2sq = h(2)*h(2) h3sq = h(3)*h(3) h4sq = h(4)*h(4) h5sq = h(5)*h(5) - a(1, 3) = c1_2*(a12sq + c1_12*h1sq) - a(2, 3) = c1_2*(a22sq + c1_12*h2sq) - a(3, 3) = c1_2*(a32sq + c1_12*h3sq) - a(4, 3) = c1_2*(a42sq + c1_12*h4sq) - a(5, 3) = c1_2*(a52sq + c1_12*h5sq) - a(6, 3) = - c1_3*a(6, 2)*h(6) - - a(1, 4) = c1_6*a(1, 2)*(a12sq + c1_4*h1sq) - a(2, 4) = c1_6*a(2, 2)*(a22sq + c1_4*h2sq) - a(3, 4) = c1_6*a(3, 2)*(a32sq + c1_4*h3sq) - a(4, 4) = c1_6*a(4, 2)*(a42sq + c1_4*h4sq) - a(5, 4) = c1_6*a(5, 2)*(a52sq + c1_4*h5sq) - a(6, 4) = - c1_4*a(6, 3)*h(6) - - a(1, 5) = c1_24*(a12sq*(a12sq + c1_2*h1sq) + c1_80*h1sq*h1sq) - a(2, 5) = c1_24*(a22sq*(a22sq + c1_2*h2sq) + c1_80*h2sq*h2sq) - a(3, 5) = c1_24*(a32sq*(a32sq + c1_2*h3sq) + c1_80*h3sq*h3sq) - a(4, 5) = c1_24*(a42sq*(a42sq + c1_2*h4sq) + c1_80*h4sq*h4sq) - a(5, 5) = c1_24*(a52sq*(a52sq + c1_2*h5sq) + c1_80*h5sq*h5sq) - a(6, 5) = - c1_5*a(6, 4)*h(6) - - a(1, 6) = c1_120*a(1, 2)*(a12sq + c3_4*h1sq)*(a12sq + c1_12*h1sq) - a(2, 6) = c1_120*a(2, 2)*(a22sq + c3_4*h2sq)*(a22sq + c1_12*h2sq) - a(3, 6) = c1_120*a(3, 2)*(a32sq + c3_4*h3sq)*(a32sq + c1_12*h3sq) - a(4, 6) = c1_120*a(4, 2)*(a42sq + c3_4*h4sq)*(a42sq + c1_12*h4sq) - a(5, 6) = c1_120*a(5, 2)*(a52sq + c3_4*h5sq)*(a52sq + c1_12*h5sq) - a(6, 6) = - c1_6*a(6, 5)*h(6) + a(1,3) = c1_2*(a12sq + c1_12*h1sq) + a(2,3) = c1_2*(a22sq + c1_12*h2sq) + a(3,3) = c1_2*(a32sq + c1_12*h3sq) + a(4,3) = c1_2*(a42sq + c1_12*h4sq) + a(5,3) = c1_2*(a52sq + c1_12*h5sq) + a(6,3) = - c1_3*a(6,2)*h(6) + + a(1,4) = c1_6*a(1,2)*(a12sq + c1_4*h1sq) + a(2,4) = c1_6*a(2,2)*(a22sq + c1_4*h2sq) + a(3,4) = c1_6*a(3,2)*(a32sq + c1_4*h3sq) + a(4,4) = c1_6*a(4,2)*(a42sq + c1_4*h4sq) + a(5,4) = c1_6*a(5,2)*(a52sq + c1_4*h5sq) + a(6,4) = - c1_4*a(6,3)*h(6) + + a(1,5) = c1_24*(a12sq*(a12sq + c1_2*h1sq) + c1_80*h1sq*h1sq) + a(2,5) = c1_24*(a22sq*(a22sq + c1_2*h2sq) + c1_80*h2sq*h2sq) + a(3,5) = c1_24*(a32sq*(a32sq + c1_2*h3sq) + c1_80*h3sq*h3sq) + a(4,5) = c1_24*(a42sq*(a42sq + c1_2*h4sq) + c1_80*h4sq*h4sq) + a(5,5) = c1_24*(a52sq*(a52sq + c1_2*h5sq) + c1_80*h5sq*h5sq) + a(6,5) = - c1_5*a(6,4)*h(6) + + a(1,6) = c1_120*a(1,2)*(a12sq + c3_4*h1sq)*(a12sq + c1_12*h1sq) + a(2,6) = c1_120*a(2,2)*(a22sq + c3_4*h2sq)*(a22sq + c1_12*h2sq) + a(3,6) = c1_120*a(3,2)*(a32sq + c3_4*h3sq)*(a32sq + c1_12*h3sq) + a(4,6) = c1_120*a(4,2)*(a42sq + c3_4*h4sq)*(a42sq + c1_12*h4sq) + a(5,6) = c1_120*a(5,2)*(a52sq + c3_4*h5sq)*(a52sq + c1_12*h5sq) + a(6,6) = - c1_6*a(6,5)*h(6) ! LU decomposition. call lu_decompose(6, a) end subroutine edge_eh6_slope_eh5_rblu - subroutine prepare_pqm(rcs, x_edge_src) + pure subroutine prepare_pqm(rcgs, x_edge_src) ! --------------------------------------------------------------------------- ! Prepare reconstruction with piecewise quartics using implicit 6th order ! accurate edge and 5th order accurate slope estimation. ! --------------------------------------------------------------------------- - type(reconstruction_struct), intent(inout) :: rcs + type(recon_grd_struct), intent(inout) :: rcgs real(r8), dimension(:), intent(in) :: x_edge_src - integer, dimension(rcs%n_src_all) :: prev_index, next_index - real(r8) :: hp, h_max, h_min - integer :: jp, j, last_index, jf, jl, n, j_min, jn, jd, js - integer :: first_index = 0 ! Initialized to avoid compiler warning. + integer, dimension(rcgs%n_src) :: prev_index, next_index + real(r8) :: hp, h_max, h_min, h + integer :: ns, jp, j, last_index, jf, jl, n, j_min, jn, jd, js + integer :: first_index +! integer :: first_index = 0 ! Initialized to avoid compiler warning. ! Exclude near-empty grid cells and establish a doubly linked list that ! connects the remaining grid cells. - rcs%n_src = 0 + ns = 0 jp = 0 - do j = 1, rcs%n_src_all - rcs%h_src(j) = abs(x_edge_src(j + 1) - x_edge_src(j)) - if (rcs%h_src(j) > c2*rcs%x_eps) then - rcs%n_src = rcs%n_src + 1 - rcs%src_dst_index(j) = 1 + do j = 1, rcgs%n_src + rcgs%h_src(j) = abs(x_edge_src(j+1) - x_edge_src(j)) + if (rcgs%h_src(j) > c2*rcgs%x_eps) then + ns = ns + 1 + rcgs%src_dst_index(j) = 1 prev_index(j) = jp if (jp == 0) then first_index = j @@ -786,12 +957,15 @@ subroutine prepare_pqm(rcs, x_edge_src) endif jp = j else - rcs%src_dst_index(j) = 0 + rcgs%src_dst_index(j) = 0 endif enddo last_index = jp next_index(jp) = 0 - if (rcs%n_src < 6) return + if (ns < 6) then + rcgs%n_src_actual = ns + return + endif ! Exclude grid cells that may lead to large condition numbers for the ! linear systems to be solved in edge_ih6_slope_ih5_coeff_asymleft, @@ -801,50 +975,53 @@ subroutine prepare_pqm(rcs, x_edge_src) jf = first_index outer: do j = jf - hp = rcs%h_src(j) - h_max = rcs%h_src(j) + hp = rcgs%h_src(j) + h_max = rcgs%h_src(j) do n = 1, 3 j = next_index(j) if (j == 0) exit outer - hp = hp*rcs%h_src(j) - h_max = max(h_max, rcs%h_src(j)) + hp = hp*rcgs%h_src(j) + h_max = max(h_max, rcgs%h_src(j)) enddo if (hp > hplim_ih6*h_max**4) then jf = next_index(jf) else - rcs%n_src = rcs%n_src - 1 - if (rcs%n_src < 6) return + ns = ns - 1 + if (ns < 6) then + rcgs%n_src_actual = ns + return + endif j = jf - h_min = rcs%h_src(j) + h_min = rcgs%h_src(j) j_min = j do n = 1, 3 j = next_index(j) - if (rcs%h_src(j) < h_min) then - h_min = rcs%h_src(j) + if (rcgs%h_src(j) < h_min) then + h_min = rcgs%h_src(j) j_min = j endif enddo jp = prev_index(j_min) jn = next_index(j_min) if (jp == 0) then - rcs%src_dst_index(j_min) = - jn - rcs%h_src(jn) = rcs%h_src(jn) + rcs%h_src(j_min) + rcgs%src_dst_index(j_min) = - jn + rcgs%h_src(jn) = rcgs%h_src(jn) + rcgs%h_src(j_min) first_index = jn prev_index(jn) = 0 jf = jn elseif (jn == 0) then - rcs%src_dst_index(j_min) = - jp - rcs%h_src(jp) = rcs%h_src(jp) + rcs%h_src(j_min) + rcgs%src_dst_index(j_min) = - jp + rcgs%h_src(jp) = rcgs%h_src(jp) + rcgs%h_src(j_min) next_index(jp) = 0 last_index = jp exit else - if (rcs%h_src(jn) < rcs%h_src(jp)) then - rcs%src_dst_index(j_min) = - jn - rcs%h_src(jn) = rcs%h_src(jn) + rcs%h_src(j_min) + if (rcgs%h_src(jn) < rcgs%h_src(jp)) then + rcgs%src_dst_index(j_min) = - jn + rcgs%h_src(jn) = rcgs%h_src(jn) + rcgs%h_src(j_min) else - rcs%src_dst_index(j_min) = - jp - rcs%h_src(jp) = rcs%h_src(jp) + rcs%h_src(j_min) + rcgs%src_dst_index(j_min) = - jp + rcgs%h_src(jp) = rcgs%h_src(jp) + rcgs%h_src(j_min) endif next_index(jp) = jn prev_index(jn) = jp @@ -864,43 +1041,46 @@ subroutine prepare_pqm(rcs, x_edge_src) jf = first_index do j = jf - hp = rcs%h_src(j) - h_max = rcs%h_src(j) + hp = rcgs%h_src(j) + h_max = rcgs%h_src(j) do n = 1, 5 j = next_index(j) - hp = hp*rcs%h_src(j) - h_max = max(h_max, rcs%h_src(j)) + hp = hp*rcgs%h_src(j) + h_max = max(h_max, rcgs%h_src(j)) enddo if (hp > hplim_eh6*h_max**6) then exit else - rcs%n_src = rcs%n_src - 1 - if (rcs%n_src < 6) return + ns = ns - 1 + if (ns < 6) then + rcgs%n_src_actual = ns + return + endif j = jf - h_min = rcs%h_src(j) + h_min = rcgs%h_src(j) j_min = j do n = 1, 5 j = next_index(j) - if (rcs%h_src(j) < h_min) then - h_min = rcs%h_src(j) + if (rcgs%h_src(j) < h_min) then + h_min = rcgs%h_src(j) j_min = j endif enddo jp = prev_index(j_min) jn = next_index(j_min) if (jp == 0) then - rcs%src_dst_index(j_min) = - jn - rcs%h_src(jn) = rcs%h_src(jn) + rcs%h_src(j_min) + rcgs%src_dst_index(j_min) = - jn + rcgs%h_src(jn) = rcgs%h_src(jn) + rcgs%h_src(j_min) first_index = jn prev_index(jn) = 0 jf = jn else - if (rcs%h_src(jn) < rcs%h_src(jp)) then - rcs%src_dst_index(j_min) = - jn - rcs%h_src(jn) = rcs%h_src(jn) + rcs%h_src(j_min) + if (rcgs%h_src(jn) < rcgs%h_src(jp)) then + rcgs%src_dst_index(j_min) = - jn + rcgs%h_src(jn) = rcgs%h_src(jn) + rcgs%h_src(j_min) else - rcs%src_dst_index(j_min) = - jp - rcs%h_src(jp) = rcs%h_src(jp) + rcs%h_src(j_min) + rcgs%src_dst_index(j_min) = - jp + rcgs%h_src(jp) = rcgs%h_src(jp) + rcgs%h_src(j_min) endif next_index(jp) = jn prev_index(jn) = jp @@ -915,42 +1095,45 @@ subroutine prepare_pqm(rcs, x_edge_src) jl = last_index do j = jl - hp = rcs%h_src(j) - h_max = rcs%h_src(j) + hp = rcgs%h_src(j) + h_max = rcgs%h_src(j) do n = 1, 5 j = prev_index(j) - hp = hp*rcs%h_src(j) - h_max = max(h_max, rcs%h_src(j)) + hp = hp*rcgs%h_src(j) + h_max = max(h_max, rcgs%h_src(j)) enddo if (hp > hplim_eh6*h_max**6) then exit else - rcs%n_src = rcs%n_src - 1 - if (rcs%n_src < 6) return + ns = ns - 1 + if (ns < 6) then + rcgs%n_src_actual = ns + return + endif j = jl - h_min = rcs%h_src(j) + h_min = rcgs%h_src(j) j_min = j do n = 1, 5 j = prev_index(j) - if (rcs%h_src(j) < h_min) then - h_min = rcs%h_src(j) + if (rcgs%h_src(j) < h_min) then + h_min = rcgs%h_src(j) j_min = j endif enddo jp = prev_index(j_min) jn = next_index(j_min) if (jn == 0) then - rcs%src_dst_index(j_min) = - jp - rcs%h_src(jp) = rcs%h_src(jp) + rcs%h_src(j_min) + rcgs%src_dst_index(j_min) = - jp + rcgs%h_src(jp) = rcgs%h_src(jp) + rcgs%h_src(j_min) next_index(jp) = 0 jl = jp else - if (rcs%h_src(jn) < rcs%h_src(jp)) then - rcs%src_dst_index(j_min) = - jn - rcs%h_src(jn) = rcs%h_src(jn) + rcs%h_src(j_min) + if (rcgs%h_src(jn) < rcgs%h_src(jp)) then + rcgs%src_dst_index(j_min) = - jn + rcgs%h_src(jn) = rcgs%h_src(jn) + rcgs%h_src(j_min) else - rcs%src_dst_index(j_min) = - jp - rcs%h_src(jp) = rcs%h_src(jp) + rcs%h_src(j_min) + rcgs%src_dst_index(j_min) = - jp + rcgs%h_src(jp) = rcgs%h_src(jp) + rcgs%h_src(j_min) endif next_index(jp) = jn prev_index(jn) = jp @@ -962,94 +1145,100 @@ subroutine prepare_pqm(rcs, x_edge_src) ! continuous array of grid cells to be used in the reconstruction. Also ! set the grid cell widths of the continuous array. jd = 0 - do js = 1, rcs%n_src_all - if (rcs%src_dst_index(js) > 0) then + do js = 1, rcgs%n_src + if (rcgs%src_dst_index(js) > 0) then jd = jd + 1 - rcs%src_dst_index(js) = jd - rcs%h_src(jd) = rcs%h_src(js) - rcs%hi_src(jd) = c1/rcs%h_src(jd) + rcgs%src_dst_index(js) = jd + rcgs%h_src(jd) = rcgs%h_src(js) + rcgs%hi_src(jd) = c1/rcgs%h_src(jd) endif enddo ! Find the destination index of excluded grid cells to be merged and ! compute the mapping weights. - do js = 1, rcs%n_src_all - jd = rcs%src_dst_index(js) + do js = 1, rcgs%n_src + jd = rcgs%src_dst_index(js) do while (jd < 0) - jd = rcs%src_dst_index(- jd) + jd = rcgs%src_dst_index(- jd) enddo - rcs%src_dst_index(js) = jd - if (jd > 0) & - rcs%src_dst_weight(js) = ( x_edge_src(js + 1) & - - x_edge_src(js ))*rcs%hi_src(jd) + rcgs%src_dst_index(js) = jd + if (jd > 0) then + h = abs(x_edge_src(js+1) - x_edge_src(js)) + if (abs(h - rcgs%h_src(jd)) < rcgs%x_eps) then + rcgs%src_dst_weight(js) = c1 + else + rcgs%src_dst_weight(js) = h*rcgs%hi_src(jd) + endif + endif enddo ! Set source edge values in the continuous reconstruction array. - rcs%x_edge_src(1) = x_edge_src(1) + rcgs%x_edge_src(1) = x_edge_src(1) js = 1 - do j = 1, rcs%n_src - 1 + do j = 1, ns-1 do - js = js + 1 - if (rcs%src_dst_index(js) /= j .and. rcs%src_dst_index(js) /= 0) exit + js = js + 1 + if (rcgs%src_dst_index(js) /= j .and. & + rcgs%src_dst_index(js) /= 0) exit enddo - rcs%x_edge_src(j + 1) = x_edge_src(js) + rcgs%x_edge_src(j+1) = x_edge_src(js) enddo - rcs%x_edge_src(rcs%n_src + 1) = x_edge_src(rcs%n_src_all + 1) + rcgs%x_edge_src(ns+1) = x_edge_src(rcgs%n_src+1) ! Compute the multiplicative inverse of cell width used for estimating ! centered linear slope. - do j = 2, rcs%n_src - 1 - rcs%hci_src(j) = c2/( rcs%h_src(j - 1) + c2*rcs%h_src(j) & - + rcs%h_src(j + 1)) + do j = 2, ns-1 + rcgs%hci_src(j) = c2/( rcgs%h_src(j-1) + c2*rcgs%h_src(j) & + + rcgs%h_src(j+1)) enddo - ! Compute coefficients for the tridiagonal system of equations for the ! estimation of interior edge and slope values. - call edge_ih6_slope_ih5_coeff_asymleft( & - rcs%h_src(1:4), & - rcs%tdecoeff(:, 2), rcs%tdscoeff(:, 2)) - do j = 3, rcs%n_src - 1 - call edge_ih6_slope_ih5_coeff_sym( & - rcs%h_src((j - 2):(j + 1)), & - rcs%tdecoeff(:, j), rcs%tdscoeff(:, j)) - enddo - call edge_ih6_slope_ih5_coeff_asymright( & - rcs%h_src((rcs%n_src - 3):rcs%n_src), & - rcs%tdecoeff(:, rcs%n_src), rcs%tdscoeff(:, rcs%n_src)) + call edge_ih6_slope_ih5_coeff_asymleft(rcgs%h_src(1:4), & + rcgs%tdecoeff(:,2), & + rcgs%tdscoeff(:,2)) + do j = 3, ns-1 + call edge_ih6_slope_ih5_coeff_sym(rcgs%h_src((j-2):(j+1)), & + rcgs%tdecoeff(:,j), & + rcgs%tdscoeff(:,j)) + enddo + call edge_ih6_slope_ih5_coeff_asymright(rcgs%h_src((ns-3):ns), & + rcgs%tdecoeff(:,ns), & + rcgs%tdscoeff(:,ns)) ! Compute LU matrices for the explicit estimation of boundary edge and ! slope values. - call edge_eh6_slope_eh5_lblu(rcs%h_src(1:6), & - rcs%lblu) - call edge_eh6_slope_eh5_rblu(rcs%h_src((rcs%n_src - 5):rcs%n_src), & - rcs%rblu) + call edge_eh6_slope_eh5_lblu(rcgs%h_src(1:6), rcgs%lblu) + call edge_eh6_slope_eh5_rblu(rcgs%h_src((ns-5):ns), rcgs%rblu) + + rcgs%n_src_actual = ns end subroutine prepare_pqm - subroutine prepare_ppm(rcs, x_edge_src) + pure subroutine prepare_ppm(rcgs, x_edge_src) ! --------------------------------------------------------------------------- ! Prepare reconstruction with piecewise parabolas using implicit 4th order ! accurate edge estimation. ! --------------------------------------------------------------------------- - type(reconstruction_struct), intent(inout) :: rcs + type(recon_grd_struct), intent(inout) :: rcgs real(r8), dimension(:), intent(in) :: x_edge_src - integer, dimension(rcs%n_src_all) :: prev_index, next_index - real(r8) :: hp, h_max, h_min - integer :: jp, j, last_index, jf, jl, n, j_min, jn, jd, js - integer :: first_index = 0 ! Initialized to avoid compiler warning. + integer, dimension(rcgs%n_src) :: prev_index, next_index + real(r8) :: hp, h_max, h_min, h + integer :: ns, jp, j, last_index, jf, jl, n, j_min, jn, jd, js + integer :: first_index +! integer :: first_index = 0 ! Initialized to avoid compiler warning. ! Exclude near-empty grid cells and establish a doubly linked list that ! connects the remaining grid cells. - rcs%n_src = 0 + ns = 0 jp = 0 - do j = 1, rcs%n_src_all - rcs%h_src(j) = abs(x_edge_src(j + 1) - x_edge_src(j)) - if (rcs%h_src(j) > c2*rcs%x_eps) then - rcs%n_src = rcs%n_src + 1 - rcs%src_dst_index(j) = 1 + do j = 1, rcgs%n_src + rcgs%h_src(j) = abs(x_edge_src(j+1) - x_edge_src(j)) + if (rcgs%h_src(j) > c2*rcgs%x_eps) then + ns = ns + 1 + rcgs%src_dst_index(j) = 1 prev_index(j) = jp if (jp == 0) then first_index = j @@ -1058,12 +1247,15 @@ subroutine prepare_ppm(rcs, x_edge_src) endif jp = j else - rcs%src_dst_index(j) = 0 + rcgs%src_dst_index(j) = 0 endif enddo last_index = jp next_index(jp) = 0 - if (rcs%n_src < 4) return + if (ns < 4) then + rcgs%n_src_actual = ns + return + endif ! Exclude grid cells that may lead to large condition numbers for the ! linear systems to be solved in edge_ih4_coeff. Excluded grid cells are @@ -1072,32 +1264,35 @@ subroutine prepare_ppm(rcs, x_edge_src) jf = first_index jl = next_index(jf) do - if (rcs%h_src(jf)*rcs%h_src(jl) > & - hplim_ih4*max(rcs%h_src(jf), rcs%h_src(jl))**2) then + if (rcgs%h_src(jf)*rcgs%h_src(jl) > & + hplim_ih4*max(rcgs%h_src(jf), rcgs%h_src(jl))**2) then jf = jl jl = next_index(jf) if (jl == 0) exit else - rcs%n_src = rcs%n_src - 1 - if (rcs%n_src < 4) return - if (rcs%h_src(jf) < rcs%h_src(jl)) then + ns = ns - 1 + if (ns < 4) then + rcgs%n_src_actual = ns + return + endif + if (rcgs%h_src(jf) < rcgs%h_src(jl)) then j = jf jf = prev_index(jf) prev_index(jl) = jf if (jf == 0) then - rcs%src_dst_index(j) = - jl - rcs%h_src(jl) = rcs%h_src(jl) + rcs%h_src(j) + rcgs%src_dst_index(j) = - jl + rcgs%h_src(jl) = rcgs%h_src(jl) + rcgs%h_src(j) first_index = jl jf = jl jl = next_index(jf) if (jl == 0) exit else - if (rcs%h_src(jf) < rcs%h_src(jl)) then - rcs%src_dst_index(j) = - jf - rcs%h_src(jf) = rcs%h_src(jf) + rcs%h_src(j) + if (rcgs%h_src(jf) < rcgs%h_src(jl)) then + rcgs%src_dst_index(j) = - jf + rcgs%h_src(jf) = rcgs%h_src(jf) + rcgs%h_src(j) else - rcs%src_dst_index(j) = - jl - rcs%h_src(jl) = rcs%h_src(jl) + rcs%h_src(j) + rcgs%src_dst_index(j) = - jl + rcgs%h_src(jl) = rcgs%h_src(jl) + rcgs%h_src(j) endif next_index(jf) = jl endif @@ -1106,17 +1301,17 @@ subroutine prepare_ppm(rcs, x_edge_src) jl = next_index(jl) next_index(jf) = jl if (jl == 0) then - rcs%src_dst_index(j) = - jf - rcs%h_src(jf) = rcs%h_src(jf) + rcs%h_src(j) + rcgs%src_dst_index(j) = - jf + rcgs%h_src(jf) = rcgs%h_src(jf) + rcgs%h_src(j) last_index = jf exit endif - if (rcs%h_src(jf) < rcs%h_src(jl)) then - rcs%src_dst_index(j) = - jf - rcs%h_src(jf) = rcs%h_src(jf) + rcs%h_src(j) + if (rcgs%h_src(jf) < rcgs%h_src(jl)) then + rcgs%src_dst_index(j) = - jf + rcgs%h_src(jf) = rcgs%h_src(jf) + rcgs%h_src(j) else - rcs%src_dst_index(j) = - jl - rcs%h_src(jl) = rcs%h_src(jl) + rcs%h_src(j) + rcgs%src_dst_index(j) = - jl + rcgs%h_src(jl) = rcgs%h_src(jl) + rcgs%h_src(j) endif prev_index(jl) = jf endif @@ -1130,43 +1325,46 @@ subroutine prepare_ppm(rcs, x_edge_src) jf = first_index do j = jf - hp = rcs%h_src(j) - h_max = rcs%h_src(j) + hp = rcgs%h_src(j) + h_max = rcgs%h_src(j) do n = 1, 3 j = next_index(j) - hp = hp*rcs%h_src(j) - h_max = max(h_max, rcs%h_src(j)) + hp = hp*rcgs%h_src(j) + h_max = max(h_max, rcgs%h_src(j)) enddo if (hp > hplim_eh4*h_max**4) then exit else - rcs%n_src = rcs%n_src - 1 - if (rcs%n_src < 4) return + ns = ns - 1 + if (ns < 4) then + rcgs%n_src_actual = ns + return + endif j = jf - h_min = rcs%h_src(j) + h_min = rcgs%h_src(j) j_min = j do n = 1, 3 j = next_index(j) - if (rcs%h_src(j) < h_min) then - h_min = rcs%h_src(j) + if (rcgs%h_src(j) < h_min) then + h_min = rcgs%h_src(j) j_min = j endif enddo jp = prev_index(j_min) jn = next_index(j_min) if (jp == 0) then - rcs%src_dst_index(j_min) = - jn - rcs%h_src(jn) = rcs%h_src(jn) + rcs%h_src(j_min) + rcgs%src_dst_index(j_min) = - jn + rcgs%h_src(jn) = rcgs%h_src(jn) + rcgs%h_src(j_min) first_index = jn prev_index(jn) = 0 jf = jn else - if (rcs%h_src(jn) < rcs%h_src(jp)) then - rcs%src_dst_index(j_min) = - jn - rcs%h_src(jn) = rcs%h_src(jn) + rcs%h_src(j_min) + if (rcgs%h_src(jn) < rcgs%h_src(jp)) then + rcgs%src_dst_index(j_min) = - jn + rcgs%h_src(jn) = rcgs%h_src(jn) + rcgs%h_src(j_min) else - rcs%src_dst_index(j_min) = - jp - rcs%h_src(jp) = rcs%h_src(jp) + rcs%h_src(j_min) + rcgs%src_dst_index(j_min) = - jp + rcgs%h_src(jp) = rcgs%h_src(jp) + rcgs%h_src(j_min) endif next_index(jp) = jn prev_index(jn) = jp @@ -1181,42 +1379,45 @@ subroutine prepare_ppm(rcs, x_edge_src) jl = last_index do j = jl - hp = rcs%h_src(j) - h_max = rcs%h_src(j) + hp = rcgs%h_src(j) + h_max = rcgs%h_src(j) do n = 1, 3 j = prev_index(j) - hp = hp*rcs%h_src(j) - h_max = max(h_max, rcs%h_src(j)) + hp = hp*rcgs%h_src(j) + h_max = max(h_max, rcgs%h_src(j)) enddo if (hp > hplim_eh4*h_max**4) then exit else - rcs%n_src = rcs%n_src - 1 - if (rcs%n_src < 4) return + ns = ns - 1 + if (ns < 4) then + rcgs%n_src_actual = ns + return + endif j = jl - h_min = rcs%h_src(j) + h_min = rcgs%h_src(j) j_min = j do n = 1, 3 j = prev_index(j) - if (rcs%h_src(j) < h_min) then - h_min = rcs%h_src(j) + if (rcgs%h_src(j) < h_min) then + h_min = rcgs%h_src(j) j_min = j endif enddo jp = prev_index(j_min) jn = next_index(j_min) if (jn == 0) then - rcs%src_dst_index(j_min) = - jp - rcs%h_src(jp) = rcs%h_src(jp) + rcs%h_src(j_min) + rcgs%src_dst_index(j_min) = - jp + rcgs%h_src(jp) = rcgs%h_src(jp) + rcgs%h_src(j_min) next_index(jp) = 0 jl = jp else - if (rcs%h_src(jn) < rcs%h_src(jp)) then - rcs%src_dst_index(j_min) = - jn - rcs%h_src(jn) = rcs%h_src(jn) + rcs%h_src(j_min) + if (rcgs%h_src(jn) < rcgs%h_src(jp)) then + rcgs%src_dst_index(j_min) = - jn + rcgs%h_src(jn) = rcgs%h_src(jn) + rcgs%h_src(j_min) else - rcs%src_dst_index(j_min) = - jp - rcs%h_src(jp) = rcs%h_src(jp) + rcs%h_src(j_min) + rcgs%src_dst_index(j_min) = - jp + rcgs%h_src(jp) = rcgs%h_src(jp) + rcgs%h_src(j_min) endif next_index(jp) = jn prev_index(jn) = jp @@ -1228,853 +1429,2496 @@ subroutine prepare_ppm(rcs, x_edge_src) ! continuous array of grid cells to be used in the reconstruction. Also ! set the grid cell widths of the continuous array. jd = 0 - do js = 1, rcs%n_src_all - if (rcs%src_dst_index(js) > 0) then + do js = 1, rcgs%n_src + if (rcgs%src_dst_index(js) > 0) then jd = jd + 1 - rcs%src_dst_index(js) = jd - rcs%h_src(jd) = rcs%h_src(js) - rcs%hi_src(jd) = c1/rcs%h_src(jd) + rcgs%src_dst_index(js) = jd + rcgs%h_src(jd) = rcgs%h_src(js) + rcgs%hi_src(jd) = c1/rcgs%h_src(jd) endif enddo ! Find the destination index of excluded grid cells to be merged and ! compute the mapping weights. - do js = 1, rcs%n_src_all - jd = rcs%src_dst_index(js) + do js = 1, rcgs%n_src + jd = rcgs%src_dst_index(js) do while (jd < 0) - jd = rcs%src_dst_index(- jd) + jd = rcgs%src_dst_index(- jd) enddo - rcs%src_dst_index(js) = jd - if (jd > 0) & - rcs%src_dst_weight(js) = ( x_edge_src(js + 1) & - - x_edge_src(js ))*rcs%hi_src(jd) + rcgs%src_dst_index(js) = jd + if (jd > 0) then + h = abs(x_edge_src(js+1) - x_edge_src(js)) + if (abs(h - rcgs%h_src(jd)) < rcgs%x_eps) then + rcgs%src_dst_weight(js) = c1 + else + rcgs%src_dst_weight(js) = h*rcgs%hi_src(jd) + endif + endif enddo ! Set source edge values in the continuous reconstruction array. - rcs%x_edge_src(1) = x_edge_src(1) + rcgs%x_edge_src(1) = x_edge_src(1) js = 1 - do j = 1, rcs%n_src - 1 + do j = 1, ns-1 do - js = js + 1 - if (rcs%src_dst_index(js) /= j .and. rcs%src_dst_index(js) /= 0) exit + js = js + 1 + if (rcgs%src_dst_index(js) /= j .and. & + rcgs%src_dst_index(js) /= 0) exit enddo - rcs%x_edge_src(j + 1) = x_edge_src(js) + rcgs%x_edge_src(j+1) = x_edge_src(js) enddo - rcs%x_edge_src(rcs%n_src + 1) = x_edge_src(rcs%n_src_all + 1) + rcgs%x_edge_src(ns+1) = x_edge_src(rcgs%n_src+1) ! Compute the multiplicative inverse of cell width used for estimating ! centered linear slope. - do j = 2, rcs%n_src - 1 - rcs%hci_src(j) = c2/( rcs%h_src(j - 1) + c2*rcs%h_src(j) & - + rcs%h_src(j + 1)) + do j = 2, ns-1 + rcgs%hci_src(j) = c2/( rcgs%h_src(j-1) + c2*rcgs%h_src(j) & + + rcgs%h_src(j+1)) enddo ! Compute coefficients for the tridiagonal system of equations for the ! estimation of interior edge values. - do j = 2, rcs%n_src - call edge_ih4_coeff(rcs%h_src((j - 1):j), rcs%tdecoeff(:, j)) + do j = 2, ns + call edge_ih4_coeff(rcgs%h_src((j-1):j), rcgs%tdecoeff(:,j)) enddo ! Compute LU matrices for the explicit estimation of boundary edge values. - call edge_eh4_lblu(rcs%h_src(1:4), rcs%lblu) - call edge_eh4_rblu(rcs%h_src((rcs%n_src - 3):rcs%n_src), rcs%rblu) + call edge_eh4_lblu(rcgs%h_src(1:4), rcgs%lblu) + call edge_eh4_rblu(rcgs%h_src((ns-3):ns), rcgs%rblu) + + rcgs%n_src_actual = ns end subroutine prepare_ppm - subroutine prepare_plm(rcs, x_edge_src) + pure subroutine prepare_plm(rcgs, x_edge_src) ! --------------------------------------------------------------------------- ! Prepare reconstruction with piecewise lines. ! --------------------------------------------------------------------------- - type(reconstruction_struct), intent(inout) :: rcs + type(recon_grd_struct), intent(inout) :: rcgs real(r8), dimension(:), intent(in) :: x_edge_src - integer :: j, js + integer :: ns, j, js ! Exclude near-empty grid cells and assign the destination index in the ! continuous array of grid cells to be used in the reconstruction. - rcs%n_src = 0 - do j = 1, rcs%n_src_all - if (abs(x_edge_src(j + 1) - x_edge_src(j)) > c2*rcs%x_eps) then - rcs%n_src = rcs%n_src + 1 - rcs%src_dst_index(j) = rcs%n_src + ns = 0 + do j = 1, rcgs%n_src + if (abs(x_edge_src(j+1) - x_edge_src(j)) > c2*rcgs%x_eps) then + ns = ns + 1 + rcgs%src_dst_index(j) = ns else - rcs%src_dst_index(j) = 0 + rcgs%src_dst_index(j) = 0 endif enddo - if (rcs%n_src < 2) return + if (ns < 2) then + rcgs%n_src_actual = ns + return + endif ! Set source edge values in the continuous reconstruction array. - rcs%x_edge_src(1) = x_edge_src(1) + rcgs%x_edge_src(1) = x_edge_src(1) js = 1 - do j = 1, rcs%n_src - 1 + do j = 1, ns-1 do js = js + 1 - if (rcs%src_dst_index(js) /= 0) exit + if (rcgs%src_dst_index(js) /= j .and. & + rcgs%src_dst_index(js) /= 0) exit enddo - rcs%x_edge_src(j + 1) = x_edge_src(js) + rcgs%x_edge_src(j+1) = x_edge_src(js) enddo - rcs%x_edge_src(rcs%n_src + 1) = x_edge_src(rcs%n_src_all + 1) + rcgs%x_edge_src(ns+1) = x_edge_src(rcgs%n_src+1) ! From edge locations, obtain source grid cell widths and their ! multiplicative inverse. - do j = 1, rcs%n_src - rcs%h_src(j) = abs(rcs%x_edge_src(j + 1) - rcs%x_edge_src(j)) - rcs%hi_src(j) = c1/rcs%h_src(j) + do j = 1, ns + rcgs%h_src(j) = abs(rcgs%x_edge_src(j+1) - rcgs%x_edge_src(j)) + rcgs%hi_src(j) = c1/rcgs%h_src(j) enddo ! Compute the multiplicative inverse of cell width used for estimating ! centered linear slope. - do j = 2, rcs%n_src - 1 - rcs%hci_src(j) = c2/( rcs%h_src(j - 1) + c2*rcs%h_src(j) & - + rcs%h_src(j + 1)) + do j = 2, ns-1 + rcgs%hci_src(j) = c2/( rcgs%h_src(j-1) + c2*rcgs%h_src(j) & + + rcgs%h_src(j+1)) enddo + rcgs%n_src_actual = ns + end subroutine prepare_plm - subroutine prepare_pcm(rcs, x_edge_src) + pure subroutine prepare_pcm(rcgs, x_edge_src) ! --------------------------------------------------------------------------- ! Prepare piecewise constant reconstruction. ! --------------------------------------------------------------------------- - type(reconstruction_struct), intent(inout) :: rcs + type(recon_grd_struct), intent(inout) :: rcgs real(r8), dimension(:), intent(in) :: x_edge_src - integer :: j, js + integer :: ns, j, js ! Exclude near-empty grid cells and assign the destination index in the ! continuous array of grid cells to be used in the reconstruction. - rcs%n_src = 0 - do j = 1, rcs%n_src_all - if (abs(x_edge_src(j + 1) - x_edge_src(j)) > c2*rcs%x_eps) then - rcs%n_src = rcs%n_src + 1 - rcs%src_dst_index(j) = rcs%n_src + ns = 0 + do j = 1, rcgs%n_src + if (abs(x_edge_src(j+1) - x_edge_src(j)) > c2*rcgs%x_eps) then + ns = ns + 1 + rcgs%src_dst_index(j) = ns else - rcs%src_dst_index(j) = 0 + rcgs%src_dst_index(j) = 0 endif enddo - if (rcs%n_src == 0) return + if (ns == 0) then + rcgs%n_src_actual = ns + return + endif ! Set source edge values in the continuous reconstruction array. - rcs%x_edge_src(1) = x_edge_src(1) + rcgs%x_edge_src(1) = x_edge_src(1) js = 1 - do j = 1, rcs%n_src - 1 + do j = 1, ns-1 do js = js + 1 - if (rcs%src_dst_index(js) /= 0) exit + if (rcgs%src_dst_index(js) /= j .and. & + rcgs%src_dst_index(js) /= 0) exit enddo - rcs%x_edge_src(j + 1) = x_edge_src(js) + rcgs%x_edge_src(j+1) = x_edge_src(js) enddo - rcs%x_edge_src(rcs%n_src + 1) = x_edge_src(rcs%n_src_all + 1) + rcgs%x_edge_src(ns+1) = x_edge_src(rcgs%n_src+1) ! From edge locations, obtain source grid cell widths and their ! multiplicative inverse. - do j = 1, rcs%n_src - rcs%h_src(j) = abs(rcs%x_edge_src(j + 1) - rcs%x_edge_src(j)) - rcs%hi_src(j) = c1/rcs%h_src(j) + do j = 1, ns + rcgs%h_src(j) = abs(rcgs%x_edge_src(j+1) - rcgs%x_edge_src(j)) + rcgs%hi_src(j) = c1/rcgs%h_src(j) enddo + rcgs%n_src_actual = ns + end subroutine prepare_pcm - subroutine reconstruct_plm_no_limiting(rcs) + pure subroutine reconstruct_plm_no_limiting(rcss) ! --------------------------------------------------------------------------- ! Carry out a reconstruction with piecewise lines. ! --------------------------------------------------------------------------- - type(reconstruction_struct), intent(inout) :: rcs + type(recon_src_struct), intent(inout) :: rcss real(r8) :: sc integer :: ns, j - ns = rcs%n_src - - sc = c2*(rcs%u_src(2) - rcs%u_src(1)) & - /(rcs%h_src(2) + rcs%h_src(1)) - rcs%polycoeff(2, 1) = sc*rcs%h_src(1) - rcs%polycoeff(1, 1) = rcs%u_src(1) - c1_2*rcs%polycoeff(2, 1) - rcs%uel(1) = rcs%polycoeff(1, 1) - rcs%uer(1) = rcs%polycoeff(1, 1) + rcs%polycoeff(2, 1) - do j = 2, ns - 1 - sc = (rcs%u_src(j + 1) - rcs%u_src(j - 1))*rcs%hci_src(j) - rcs%polycoeff(2, j) = sc*rcs%h_src(j) - rcs%polycoeff(1, j) = rcs%u_src(j) - c1_2*rcs%polycoeff(2, j) - rcs%uel(j) = rcs%polycoeff(1, j) - rcs%uer(j) = rcs%polycoeff(1, j) + rcs%polycoeff(2, j) - enddo - sc = c2*(rcs%u_src(ns) - rcs%u_src(ns - 1)) & - /(rcs%h_src(ns) + rcs%h_src(ns - 1)) - rcs%polycoeff(2, ns) = sc*rcs%h_src(ns) - rcs%polycoeff(1, ns) = rcs%u_src(ns) - c1_2*rcs%polycoeff(2, ns) - rcs%uel(ns) = rcs%polycoeff(1, ns) - rcs%uer(ns) = rcs%polycoeff(1, ns) + rcs%polycoeff(2, ns) - - rcs%polycoeff(3, :) = c0 + ns = rcss%rcgs%n_src_actual + + sc = c2*(rcss%u_src(2) - rcss%u_src(1)) & + /(rcss%rcgs%h_src(2) + rcss%rcgs%h_src(1)) + rcss%polycoeff(2,1) = sc*rcss%rcgs%h_src(1) + rcss%polycoeff(1,1) = rcss%u_src(1) - c1_2*rcss%polycoeff(2,1) + rcss%uel(1) = rcss%polycoeff(1,1) + rcss%uer(1) = rcss%polycoeff(1,1) + rcss%polycoeff(2,1) + do j = 2, ns-1 + sc = (rcss%u_src(j+1) - rcss%u_src(j-1))*rcss%rcgs%hci_src(j) + rcss%polycoeff(2,j) = sc*rcss%rcgs%h_src(j) + rcss%polycoeff(1,j) = rcss%u_src(j) - c1_2*rcss%polycoeff(2,j) + rcss%uel(j) = rcss%polycoeff(1,j) + rcss%uer(j) = rcss%polycoeff(1,j) + rcss%polycoeff(2,j) + enddo + sc = c2*(rcss%u_src(ns) - rcss%u_src(ns-1)) & + /(rcss%rcgs%h_src(ns) + rcss%rcgs%h_src(ns-1)) + rcss%polycoeff(2,ns) = sc*rcss%rcgs%h_src(ns) + rcss%polycoeff(1,ns) = rcss%u_src(ns) - c1_2*rcss%polycoeff(2,ns) + rcss%uel(ns) = rcss%polycoeff(1,ns) + rcss%uer(ns) = rcss%polycoeff(1,ns) + rcss%polycoeff(2,ns) + + rcss%polycoeff(3:rcss%rcgs%p_ord+1,:) = c0 end subroutine reconstruct_plm_no_limiting - subroutine reconstruct_plm_monotonic(rcs, pclb, pcrb) + pure subroutine reconstruct_plm_monotonic(rcss) ! --------------------------------------------------------------------------- ! Carry out a reconstruction with piecewise lines and apply limiting to ! ensure a monotonic reconstruction. ! --------------------------------------------------------------------------- - type(reconstruction_struct), intent(inout) :: rcs - logical, intent(in) :: pclb, pcrb + type(recon_src_struct), intent(inout) :: rcss real(r8) :: sl, sr, sc integer :: ns, j - ns = rcs%n_src + ns = rcss%rcgs%n_src_actual ! Use monotonized central-difference limiter for interior grid cells. - do j = 2, ns - 1 - sl = c2*(rcs%u_src(j) - rcs%u_src(j - 1))*rcs%hi_src(j) - sr = c2*(rcs%u_src(j + 1) - rcs%u_src(j))*rcs%hi_src(j) + do j = 2, ns-1 + sl = c2*(rcss%u_src(j) - rcss%u_src(j-1))*rcss%rcgs%hi_src(j) + sr = c2*(rcss%u_src(j+1) - rcss%u_src(j))*rcss%rcgs%hi_src(j) if (sl*sr > c0) then - sc = (rcs%u_src(j + 1) - rcs%u_src(j - 1))*rcs%hci_src(j) + sc = (rcss%u_src(j+1) - rcss%u_src(j-1))*rcss%rcgs%hci_src(j) sc = sign(min(abs(sl), abs(sr), abs(sc)), sc) else sc = c0 endif - rcs%polycoeff(2, j) = sc*rcs%h_src(j) - rcs%polycoeff(1, j) = rcs%u_src(j) - c1_2*rcs%polycoeff(2, j) - rcs%uel(j) = rcs%polycoeff(1, j) - rcs%uer(j) = rcs%polycoeff(1, j) + rcs%polycoeff(2, j) + rcss%polycoeff(2,j) = sc*rcss%rcgs%h_src(j) + rcss%polycoeff(1,j) = rcss%u_src(j) - c1_2*rcss%polycoeff(2,j) + rcss%uel(j) = rcss%polycoeff(1,j) + rcss%uer(j) = rcss%polycoeff(1,j) + rcss%polycoeff(2,j) enddo - if (pclb) then + if (rcss%pc_left_bndr) then ! Piecewise constant reconstruction of left boundary cell. - rcs%polycoeff(1, 1) = rcs%u_src(1) - rcs%polycoeff(2, 1) = c0 - rcs%uel(1) = rcs%u_src(1) - rcs%uer(1) = rcs%u_src(1) + rcss%polycoeff(1,1) = rcss%u_src(1) + rcss%polycoeff(2,1) = c0 + rcss%uel(1) = rcss%u_src(1) + rcss%uer(1) = rcss%u_src(1) else ! Piecewise linear reconstruction of left boundary cell. - sc = c2*(rcs%u_src(2) - rcs%u_src(1)) & - /(rcs%h_src(2) + rcs%h_src(1)) - rcs%polycoeff(2, 1) = sc*rcs%h_src(1) - rcs%polycoeff(1, 1) = rcs%u_src(1) - c1_2*rcs%polycoeff(2, 1) - rcs%uel(1) = rcs%polycoeff(1, 1) - rcs%uer(1) = rcs%polycoeff(1, 1) + rcs%polycoeff(2, 1) + sc = c2*(rcss%u_src(2) - rcss%u_src(1)) & + /(rcss%rcgs%h_src(2) + rcss%rcgs%h_src(1)) + rcss%polycoeff(2,1) = sc*rcss%rcgs%h_src(1) + rcss%polycoeff(1,1) = rcss%u_src(1) - c1_2*rcss%polycoeff(2,1) + rcss%uel(1) = rcss%polycoeff(1,1) + rcss%uer(1) = rcss%polycoeff(1,1) + rcss%polycoeff(2,1) endif - if (pcrb) then + if (rcss%pc_right_bndr) then ! Piecewise constant reconstruction of right boundary cell. - rcs%polycoeff(1, ns) = rcs%u_src(ns) - rcs%polycoeff(2, ns) = c0 - rcs%uel(ns) = rcs%u_src(ns) - rcs%uer(ns) = rcs%u_src(ns) + rcss%polycoeff(1,ns) = rcss%u_src(ns) + rcss%polycoeff(2,ns) = c0 + rcss%uel(ns) = rcss%u_src(ns) + rcss%uer(ns) = rcss%u_src(ns) else ! Piecewise linear reconstruction of right boundary cell. - sc = c2*(rcs%u_src(ns) - rcs%u_src(ns - 1)) & - /(rcs%h_src(ns) + rcs%h_src(ns - 1)) - rcs%polycoeff(2, ns) = sc*rcs%h_src(ns) - rcs%polycoeff(1, ns) = rcs%u_src(ns) & - - c1_2*rcs%polycoeff(2, ns) - rcs%uel(ns) = rcs%polycoeff(1, ns) - rcs%uer(ns) = rcs%polycoeff(1, ns) + rcs%polycoeff(2, ns) + sc = c2*(rcss%u_src(ns) - rcss%u_src(ns-1)) & + /(rcss%rcgs%h_src(ns) + rcss%rcgs%h_src(ns-1)) + rcss%polycoeff(2,ns) = sc*rcss%rcgs%h_src(ns) + rcss%polycoeff(1,ns) = rcss%u_src(ns) - c1_2*rcss%polycoeff(2,ns) + rcss%uel(ns) = rcss%polycoeff(1,ns) + rcss%uer(ns) = rcss%polycoeff(1,ns) + rcss%polycoeff(2,ns) endif - rcs%polycoeff(3, :) = c0 + rcss%polycoeff(3:rcss%rcgs%p_ord+1,:) = c0 end subroutine reconstruct_plm_monotonic - subroutine reconstruct_ppm_edge_values(rcs) + pure subroutine reconstruct_ppm_edge_values(rcss) ! --------------------------------------------------------------------------- ! Reconstruct edge values using an implicit 4th order scheme. ! --------------------------------------------------------------------------- - type(reconstruction_struct), intent(inout) :: rcs + type(recon_src_struct), intent(inout) :: rcss real(r8), dimension(4) :: x - real(r8), dimension(rcs%n_src + 1) :: uedge - real(r8), dimension(rcs%n_src) :: rhs, gam + real(r8), dimension(rcss%rcgs%n_src_actual+1) :: uedge + real(r8), dimension(rcss%rcgs%n_src_actual) :: rhs, gam real(r8) :: bei integer :: ns, j - ns = rcs%n_src + ns = rcss%rcgs%n_src_actual ! Obtain the left boundary edge value. - x(:) = rcs%u_src(1:4) - call lu_solve(4, rcs%lblu, x) + x(:) = rcss%u_src(1:4) + call lu_solve(4, rcss%rcgs%lblu, x) uedge(1) = x(1) ! Obtain the right boundary edge value. - x(:) = rcs%u_src((ns - 3):ns) - call lu_solve(4, rcs%rblu, x) - uedge(ns + 1) = x(1) + x(:) = rcss%u_src((ns-3):ns) + call lu_solve(4, rcss%rcgs%rblu, x) + uedge(ns+1) = x(1) ! Obtain right hand side of tridiagonal system of equations. do j = 2, ns - rhs(j) = rcs%tdecoeff(3, j)*rcs%u_src(j - 1) & - + rcs%tdecoeff(4, j)*rcs%u_src(j) + rhs(j) = rcss%rcgs%tdecoeff(3,j)*rcss%u_src(j-1) & + + rcss%rcgs%tdecoeff(4,j)*rcss%u_src(j ) enddo ! Solve tridiagonal system of equations to obtain interior edge values. gam(1) = c0 do j = 2, ns - bei = c1/(c1 - rcs%tdecoeff(1, j)*gam(j - 1)) - uedge(j) = (rhs(j) - rcs%tdecoeff(1, j)*uedge(j - 1))*bei - gam(j) = rcs%tdecoeff(2, j)*bei + bei = c1/(c1 - rcss%rcgs%tdecoeff(1,j)*gam(j-1)) + uedge(j) = (rhs(j) - rcss%rcgs%tdecoeff(1,j)*uedge(j-1))*bei + gam(j) = rcss%rcgs%tdecoeff(2,j)*bei enddo - do j = ns, 2, - 1 - uedge(j) = uedge(j) - gam(j)*uedge(j + 1) + do j = ns, 2, -1 + uedge(j) = uedge(j) - gam(j)*uedge(j+1) enddo ! Set left and right edge values for each grid cell. - rcs%uel(1:ns) = uedge(1:ns) - rcs%uer(1:ns) = uedge(2:(ns + 1)) + rcss%uel(1:ns) = uedge(1:ns) + rcss%uer(1:ns) = uedge(2:(ns+1)) end subroutine reconstruct_ppm_edge_values - subroutine reconstruct_pqm_edge_slope_values(rcs) + pure subroutine reconstruct_pqm_edge_slope_values(rcss) ! --------------------------------------------------------------------------- ! Reconstruct edge and slope values using implicit 6th and 5th order schemes, ! respectively. ! --------------------------------------------------------------------------- - type(reconstruction_struct), intent(inout) :: rcs + type(recon_src_struct), intent(inout) :: rcss real(r8), dimension(6) :: x - real(r8), dimension(rcs%n_src + 1) :: uedge, uslope - real(r8), dimension(rcs%n_src) :: rhs, gam + real(r8), dimension(rcss%rcgs%n_src_actual+1) :: uedge, uslope + real(r8), dimension(rcss%rcgs%n_src_actual) :: rhs, gam real(r8) :: bei integer :: ns, j - ns = rcs%n_src + ns = rcss%rcgs%n_src_actual ! Obtain the left boundary edge and slope values. - x(:) = rcs%u_src(1:6) - call lu_solve(6, rcs%lblu, x) + x(:) = rcss%u_src(1:6) + call lu_solve(6, rcss%rcgs%lblu, x) uedge(1) = x(1) uslope(1) = x(2) ! Obtain the right boundary edge and slope values. - x(:) = rcs%u_src((ns - 5):ns) - call lu_solve(6, rcs%rblu, x) - uedge(ns + 1) = x(1) - uslope(ns + 1) = x(2) + x(:) = rcss%u_src((ns - 5):ns) + call lu_solve(6, rcss%rcgs%rblu, x) + uedge(ns+1) = x(1) + uslope(ns+1) = x(2) ! Obtain right hand side of tridiagonal system of equations for edge ! values. - rhs(2) = rcs%tdecoeff(3, 2)*rcs%u_src(1) & - + rcs%tdecoeff(4, 2)*rcs%u_src(2) & - + rcs%tdecoeff(5, 2)*rcs%u_src(3) & - + rcs%tdecoeff(6, 2)*rcs%u_src(4) - do j = 3, ns - 1 - rhs(j) = rcs%tdecoeff(3, j)*rcs%u_src(j - 2) & - + rcs%tdecoeff(4, j)*rcs%u_src(j - 1) & - + rcs%tdecoeff(5, j)*rcs%u_src(j) & - + rcs%tdecoeff(6, j)*rcs%u_src(j + 1) - enddo - rhs(ns) = rcs%tdecoeff(3, ns)*rcs%u_src(ns - 3) & - + rcs%tdecoeff(4, ns)*rcs%u_src(ns - 2) & - + rcs%tdecoeff(5, ns)*rcs%u_src(ns - 1) & - + rcs%tdecoeff(6, ns)*rcs%u_src(ns) + rhs(2) = rcss%rcgs%tdecoeff(3,2)*rcss%u_src(1) & + + rcss%rcgs%tdecoeff(4,2)*rcss%u_src(2) & + + rcss%rcgs%tdecoeff(5,2)*rcss%u_src(3) & + + rcss%rcgs%tdecoeff(6,2)*rcss%u_src(4) + do j = 3, ns-1 + rhs(j) = rcss%rcgs%tdecoeff(3,j)*rcss%u_src(j-2) & + + rcss%rcgs%tdecoeff(4,j)*rcss%u_src(j-1) & + + rcss%rcgs%tdecoeff(5,j)*rcss%u_src(j ) & + + rcss%rcgs%tdecoeff(6,j)*rcss%u_src(j+1) + enddo + rhs(ns) = rcss%rcgs%tdecoeff(3,ns)*rcss%u_src(ns-3) & + + rcss%rcgs%tdecoeff(4,ns)*rcss%u_src(ns-2) & + + rcss%rcgs%tdecoeff(5,ns)*rcss%u_src(ns-1) & + + rcss%rcgs%tdecoeff(6,ns)*rcss%u_src(ns ) ! Solve tridiagonal system of equations to obtain interior edge values. gam(1) = c0 do j = 2, ns - bei = c1/(c1 - rcs%tdecoeff(1, j)*gam(j - 1)) - uedge(j) = (rhs(j) - rcs%tdecoeff(1, j)*uedge(j - 1))*bei - gam(j) = rcs%tdecoeff(2, j)*bei + bei = c1/(c1 - rcss%rcgs%tdecoeff(1,j)*gam(j-1)) + uedge(j) = (rhs(j) - rcss%rcgs%tdecoeff(1,j)*uedge(j-1))*bei + gam(j) = rcss%rcgs%tdecoeff(2,j)*bei enddo - do j = ns, 2, - 1 - uedge(j) = uedge(j) - gam(j)*uedge(j + 1) + do j = ns, 2, -1 + uedge(j) = uedge(j) - gam(j)*uedge(j+1) enddo ! Obtain right hand side of tridiagonal system of equations for slope ! values. - rhs(2) = rcs%tdscoeff(3, 2)*rcs%u_src(1) & - + rcs%tdscoeff(4, 2)*rcs%u_src(2) & - + rcs%tdscoeff(5, 2)*rcs%u_src(3) & - + rcs%tdscoeff(6, 2)*rcs%u_src(4) - do j = 3, ns - 1 - rhs(j) = rcs%tdscoeff(3, j)*rcs%u_src(j - 2) & - + rcs%tdscoeff(4, j)*rcs%u_src(j - 1) & - + rcs%tdscoeff(5, j)*rcs%u_src(j) & - + rcs%tdscoeff(6, j)*rcs%u_src(j + 1) - enddo - rhs(ns) = rcs%tdscoeff(3, ns)*rcs%u_src(ns - 3) & - + rcs%tdscoeff(4, ns)*rcs%u_src(ns - 2) & - + rcs%tdscoeff(5, ns)*rcs%u_src(ns - 1) & - + rcs%tdscoeff(6, ns)*rcs%u_src(ns) + rhs(2) = rcss%rcgs%tdscoeff(3,2)*rcss%u_src(1) & + + rcss%rcgs%tdscoeff(4,2)*rcss%u_src(2) & + + rcss%rcgs%tdscoeff(5,2)*rcss%u_src(3) & + + rcss%rcgs%tdscoeff(6,2)*rcss%u_src(4) + do j = 3, ns-1 + rhs(j) = rcss%rcgs%tdscoeff(3,j)*rcss%u_src(j-2) & + + rcss%rcgs%tdscoeff(4,j)*rcss%u_src(j-1) & + + rcss%rcgs%tdscoeff(5,j)*rcss%u_src(j ) & + + rcss%rcgs%tdscoeff(6,j)*rcss%u_src(j+1) + enddo + rhs(ns) = rcss%rcgs%tdscoeff(3,ns)*rcss%u_src(ns-3) & + + rcss%rcgs%tdscoeff(4,ns)*rcss%u_src(ns-2) & + + rcss%rcgs%tdscoeff(5,ns)*rcss%u_src(ns-1) & + + rcss%rcgs%tdscoeff(6,ns)*rcss%u_src(ns ) ! Solve tridiagonal system of equations to obtain interior slope values. gam(1) = c0 do j = 2, ns - bei = c1/(c1 - rcs%tdscoeff(1, j)*gam(j - 1)) - uslope(j) = (rhs(j) - rcs%tdscoeff(1, j)*uslope(j - 1))*bei - gam(j) = rcs%tdscoeff(2, j)*bei + bei = c1/(c1 - rcss%rcgs%tdscoeff(1,j)*gam(j-1)) + uslope(j) = (rhs(j) - rcss%rcgs%tdscoeff(1,j)*uslope(j-1))*bei + gam(j) = rcss%rcgs%tdscoeff(2,j)*bei enddo - do j = ns, 2, - 1 - uslope(j) = uslope(j) - gam(j)*uslope(j + 1) + do j = ns, 2, -1 + uslope(j) = uslope(j) - gam(j)*uslope(j+1) enddo ! Set left and right edge values for each grid cell. - rcs%uel(1:ns) = uedge(1:ns) - rcs%uer(1:ns) = uedge(2:(ns + 1)) + rcss%uel(1:ns) = uedge(1:ns) + rcss%uer(1:ns) = uedge(2:(ns+1)) ! Set left and right slope values for each grid cell and scale the slope ! values with the grid cell widths. - rcs%usl(1:ns) = uslope(1:ns)*rcs%h_src(1:ns) - rcs%usr(1:ns) = uslope(2:(ns + 1))*rcs%h_src(1:ns) + rcss%usl(1:ns) = uslope(1:ns)*rcss%rcgs%h_src(1:ns) + rcss%usr(1:ns) = uslope(2:(ns+1))*rcss%rcgs%h_src(1:ns) end subroutine reconstruct_pqm_edge_slope_values - subroutine limit_ppm_interior_monotonic(rcs) + pure subroutine limit_ppm_interior_monotonic(rcss) ! --------------------------------------------------------------------------- ! Apply limiting to ensure a monotonic reconstruction of piecewise parabolas ! for interior grid cells. ! --------------------------------------------------------------------------- - type(reconstruction_struct), intent(inout) :: rcs + type(recon_src_struct), intent(inout) :: rcss real(r8) :: sl, sr, sc, d, q, r - integer :: j - - do j = 2, rcs%n_src - 1 + integer :: ns, j - sl = c2*(rcs%u_src(j) - rcs%u_src(j - 1))*rcs%hi_src(j) - sr = c2*(rcs%u_src(j + 1) - rcs%u_src(j))*rcs%hi_src(j) + ns = rcss%rcgs%n_src_actual + do j = 2, ns-1 + sl = c2*(rcss%u_src(j) - rcss%u_src(j-1))*rcss%rcgs%hi_src(j) + sr = c2*(rcss%u_src(j+1) - rcss%u_src(j))*rcss%rcgs%hi_src(j) if (sl*sr > c0) then - - sc = (rcs%u_src(j + 1) - rcs%u_src(j - 1))*rcs%hci_src(j) + sc = (rcss%u_src(j+1) - rcss%u_src(j-1))*rcss%rcgs%hci_src(j) sc = sign(min(abs(sl), abs(sr), abs(sc)), sc) - if ( (rcs%u_src(j - 1) - rcs%uel(j)) & - *(rcs%u_src(j ) - rcs%uel(j)) > c0) & - rcs%uel(j) = rcs%u_src(j) & - - sign(min(c1_2*rcs%h_src(j)*abs(sc), & - abs(rcs%uel(j) - rcs%u_src(j))), sc) - if ( (rcs%u_src(j + 1) - rcs%uer(j)) & - *(rcs%u_src(j ) - rcs%uer(j)) > c0) & - rcs%uer(j) = rcs%u_src(j) & - + sign(min(c1_2*rcs%h_src(j)*abs(sc), & - abs(rcs%uer(j) - rcs%u_src(j))), sc) - - d = rcs%uer(j) - rcs%uel(j) - q = d*(c2*rcs%u_src(j) - rcs%uel(j) - rcs%uer(j)) - r = c1_3*d*d - if ( q > r) then - rcs%uel(j) = c3*rcs%u_src(j) - c2*rcs%uer(j) - elseif (- r > q) then - rcs%uer(j) = c3*rcs%u_src(j) - c2*rcs%uel(j) - endif - + if ( (rcss%u_src(j-1) - rcss%uel(j)) & + *(rcss%u_src(j ) - rcss%uel(j)) > c0) & + rcss%uel(j) = rcss%u_src(j) & + - sign(min(c1_2*rcss%rcgs%h_src(j)*abs(sc), & + abs(rcss%uel(j) - rcss%u_src(j))), sc) + if ( (rcss%u_src(j+1) - rcss%uer(j)) & + *(rcss%u_src(j ) - rcss%uer(j)) > c0) & + rcss%uer(j) = rcss%u_src(j) & + + sign(min(c1_2*rcss%rcgs%h_src(j)*abs(sc), & + abs(rcss%uer(j) - rcss%u_src(j))), sc) else - rcs%uel(j) = rcs%u_src(j) - rcs%uer(j) = rcs%u_src(j) + rcss%uel(j) = rcss%u_src(j) + rcss%uer(j) = rcss%u_src(j) endif + enddo + +! do j = 2, ns-1 + do j = 3, ns-1 + if ( (rcss%uel(j) - rcss%uer(j-1)) & + *(rcss%u_src(j) - rcss%u_src(j-1)) < c0) then + rcss%uel(j) = c1_2*(rcss%uer(j-1) + rcss%uel(j)) + rcss%uer(j-1) = rcss%uel(j) + endif + enddo + do j = 2, ns-1 + d = rcss%uer(j) - rcss%uel(j) + q = d*(c2*rcss%u_src(j) - rcss%uel(j) - rcss%uer(j)) + r = c1_3*d*d + if ( q > r) then + rcss%uel(j) = c3*rcss%u_src(j) - c2*rcss%uer(j) + elseif (- r > q) then + rcss%uer(j) = c3*rcss%u_src(j) - c2*rcss%uel(j) + endif enddo end subroutine limit_ppm_interior_monotonic - subroutine limit_ppm_interior_non_oscillatory(rcs) + pure subroutine limit_ppm_interior_non_oscillatory(rcss) ! --------------------------------------------------------------------------- ! Apply limiting to prevent a oscillatory reconstruction of piecewise ! parabolas for interior grid cells. ! --------------------------------------------------------------------------- - type(reconstruction_struct), intent(inout) :: rcs + type(recon_src_struct), intent(inout) :: rcss - real(r8), dimension(rcs%n_src) :: d2 + real(r8), dimension(rcss%rcgs%n_src_actual) :: d2 real(r8) :: sl, sr, sc, d, q, r - integer :: j + integer :: ns, j + + ns = rcss%rcgs%n_src_actual ! Obtain values proportional to the second derivative of the unlimited ! parabolas. - do j = 1, rcs%n_src - d2(j) = rcs%uel(j) - c2*rcs%u_src(j) + rcs%uer(j) + do j = 1, ns + d2(j) = rcss%uel(j) - c2*rcss%u_src(j) + rcss%uer(j) enddo - do j = 2, rcs%n_src - 1 - + do j = 2, ns-1 ! Only apply limiting if the sign of the second ! derivative differs from the sign of second derivatives ! of any of the neighbouring parabolas. - if (d2(j - 1)*d2(j) < c0 .or. d2(j)*d2(j + 1) < c0) then - - sl = c2*(rcs%u_src(j) - rcs%u_src(j - 1))*rcs%hi_src(j) - sr = c2*(rcs%u_src(j + 1) - rcs%u_src(j))*rcs%hi_src(j) - + if (d2(j-1)*d2(j) < c0 .or. d2(j)*d2(j+1) < c0) then + sl = c2*(rcss%u_src(j) - rcss%u_src(j-1))*rcss%rcgs%hi_src(j) + sr = c2*(rcss%u_src(j+1) - rcss%u_src(j))*rcss%rcgs%hi_src(j) if (sl*sr > c0) then - - sc = (rcs%u_src(j + 1) - rcs%u_src(j - 1))*rcs%hci_src(j) + sc = (rcss%u_src(j+1) - rcss%u_src(j-1))*rcss%rcgs%hci_src(j) sc = sign(min(abs(sl), abs(sr), abs(sc)), sc) - if ( (rcs%u_src(j - 1) - rcs%uel(j)) & - *(rcs%u_src(j ) - rcs%uel(j)) > c0) & - rcs%uel(j) = rcs%u_src(j) & - - sign(min(c1_2*rcs%h_src(j)*abs(sc), & - abs(rcs%uel(j) - rcs%u_src(j))), sc) - if ( (rcs%u_src(j + 1) - rcs%uer(j)) & - *(rcs%u_src(j ) - rcs%uer(j)) > c0) & - rcs%uer(j) = rcs%u_src(j) & - + sign(min(c1_2*rcs%h_src(j)*abs(sc), & - abs(rcs%uer(j) - rcs%u_src(j))), sc) - - d = rcs%uer(j) - rcs%uel(j) - q = d*(c2*rcs%u_src(j) - rcs%uel(j) - rcs%uer(j)) - r = c1_3*d*d - if ( q > r) then - rcs%uel(j) = c3*rcs%u_src(j) - c2*rcs%uer(j) - elseif (- r > q) then - rcs%uer(j) = c3*rcs%u_src(j) - c2*rcs%uel(j) - endif - + if ( (rcss%u_src(j-1) - rcss%uel(j)) & + *(rcss%u_src(j ) - rcss%uel(j)) > c0) & + rcss%uel(j) = rcss%u_src(j) & + - sign(min(c1_2*rcss%rcgs%h_src(j)*abs(sc), & + abs(rcss%uel(j) - rcss%u_src(j))), sc) + if ( (rcss%u_src(j+1) - rcss%uer(j)) & + *(rcss%u_src(j ) - rcss%uer(j)) > c0) & + rcss%uer(j) = rcss%u_src(j) & + + sign(min(c1_2*rcss%rcgs%h_src(j)*abs(sc), & + abs(rcss%uer(j) - rcss%u_src(j))), sc) else - rcs%uel(j) = rcs%u_src(j) - rcs%uer(j) = rcs%u_src(j) + rcss%uel(j) = rcss%u_src(j) + rcss%uer(j) = rcss%u_src(j) endif + endif + enddo +! do j = 2, ns-1 + do j = 3, ns-1 + if ( (rcss%uel(j) - rcss%uer(j-1)) & + *(rcss%u_src(j) - rcss%u_src(j-1)) < c0) then + rcss%uel(j) = c1_2*(rcss%uer(j-1) + rcss%uel(j)) + rcss%uer(j-1) = rcss%uel(j) endif + enddo + do j = 2, ns-1 + if (d2(j-1)*d2(j) < c0 .or. d2(j)*d2(j+1) < c0) then + d = rcss%uer(j) - rcss%uel(j) + q = d*(c2*rcss%u_src(j) - rcss%uel(j) - rcss%uer(j)) + r = c1_3*d*d + if ( q > r) then + rcss%uel(j) = c3*rcss%u_src(j) - c2*rcss%uer(j) + elseif (- r > q) then + rcss%uer(j) = c3*rcss%u_src(j) - c2*rcss%uel(j) + endif + endif enddo end subroutine limit_ppm_interior_non_oscillatory - subroutine limit_ppm_boundary(rcs, pclb, pcrb) + pure subroutine limit_ppm_boundary(rcss) ! --------------------------------------------------------------------------- ! Handle piecewise parabola limiting of boundary cells. ! --------------------------------------------------------------------------- - type(reconstruction_struct), intent(inout) :: rcs - logical, intent(in) :: pclb, pcrb + type(recon_src_struct), intent(inout) :: rcss - real(r8) :: dl, dr, d, q, r + real(r8) :: s integer :: ns - ns = rcs%n_src + ns = rcss%rcgs%n_src_actual - if (pclb) then + if (rcss%pc_left_bndr) then ! Piecewise constant reconstruction of the left boundary cell. - rcs%uel(1) = rcs%u_src(1) - rcs%uer(1) = rcs%u_src(1) + rcss%uel(1) = rcss%u_src(1) + rcss%uer(1) = rcss%u_src(1) else ! Do not treat the left boundary cell as a local extrema, but ensure ! that the piecewise parabola is monotonic within the cell. - if ((rcs%u_src(2) - rcs%uer(1))*(rcs%u_src(1) - rcs%uer(1)) > c0) then - rcs%uel(1) = rcs%u_src(1) - rcs%uer(1) = rcs%u_src(1) - elseif (( (rcs%u_src(3) - rcs%u_src(2)) & - *(rcs%h_src(1) + rcs%h_src(2)) & - - (rcs%u_src(2) - rcs%u_src(1)) & - *(rcs%h_src(2) + rcs%h_src(3))) & - *(rcs%uel(1) - c2*rcs%u_src(1) + rcs%uer(1)) < c0) then - rcs%uel(1) = c1_2*(c3*rcs%u_src(1) - rcs%uer(1)) + if ( (rcss%u_src(2) - rcss%uer(1)) & + *(rcss%u_src(1) - rcss%uer(1)) > c0) then + rcss%uel(1) = rcss%u_src(1) + rcss%uer(1) = rcss%u_src(1) else - dl = rcs%u_src(1) - rcs%uel(1) - dr = rcs%uer(1) - rcs%u_src(1) - if (dl*dr < c0) then - rcs%uel(1) = c1_2*(c3*rcs%u_src(1) - rcs%uer(1)) + s = c2*(rcss%u_src(3) - rcss%u_src(2)) & + /(rcss%rcgs%h_src(2) + rcss%rcgs%h_src(3)) + if (s > 0) then + rcss%uer(1) = & + max(rcss%u_src(1), & + min(rcss%uer(1), & + rcss%u_src(1) + c1_3*s*rcss%rcgs%h_src(1))) else - d = dl + dr - q = d*(dl - dr) - r = c1_3*d*d - if ( q > r) then - rcs%uel(1) = c3*rcs%u_src(1) - c2*rcs%uer(1) - elseif (- r > q) then - rcs%uer(1) = c3*rcs%u_src(1) - c2*rcs%uel(1) - endif + rcss%uer(1) = & + min(rcss%u_src(1), & + max(rcss%uer(1), & + rcss%u_src(1) + c1_3*s*rcss%rcgs%h_src(1))) endif + rcss%uel(1) = c1_2*(c3*rcss%u_src(1) - rcss%uer(1)) endif endif - if (pcrb) then + if (rcss%pc_right_bndr) then ! Piecewise constant reconstruction of the right boundary cell. - rcs%uel(ns) = rcs%u_src(ns) - rcs%uer(ns) = rcs%u_src(ns) + rcss%uel(ns) = rcss%u_src(ns) + rcss%uer(ns) = rcss%u_src(ns) else ! Do not treat the right boundary cell as a local extrema, but ensure ! that the piecewise parabola is monotonic within the cell. - if ( (rcs%u_src(ns ) - rcs%uel(ns)) & - *(rcs%u_src(ns - 1) - rcs%uel(ns)) > c0) then - rcs%uel(ns) = rcs%u_src(ns) - rcs%uer(ns) = rcs%u_src(ns) - elseif (( (rcs%u_src(ns ) - rcs%u_src(ns - 1)) & - *(rcs%h_src(ns - 2) + rcs%h_src(ns - 1)) & - - (rcs%u_src(ns - 1) - rcs%u_src(ns - 2)) & - *(rcs%h_src(ns - 1) + rcs%h_src(ns ))) & - *(rcs%uel(ns) - c2*rcs%u_src(ns) + rcs%uer(ns)) < c0) then - rcs%uer(ns) = c1_2*(c3*rcs%u_src(ns) - rcs%uel(ns)) + if ( (rcss%u_src(ns ) - rcss%uel(ns)) & + *(rcss%u_src(ns-1) - rcss%uel(ns)) > c0) then + rcss%uel(ns) = rcss%u_src(ns) + rcss%uer(ns) = rcss%u_src(ns) else - dl = rcs%u_src(ns) - rcs%uel(ns) - dr = rcs%uer(ns) - rcs%u_src(ns) - if (dl*dr < c0) then - rcs%uer(ns) = c1_2*(c3*rcs%u_src(ns) - rcs%uel(ns)) + s = c2*(rcss%u_src(ns-1) - rcss%u_src(ns-2)) & + /(rcss%rcgs%h_src(ns-2) + rcss%rcgs%h_src(ns-1)) + if (s > 0) then + rcss%uel(ns) = & + min(rcss%u_src(ns), & + max(rcss%uel(ns), & + rcss%u_src(ns) - c1_3*s*rcss%rcgs%h_src(ns))) else - d = dl + dr - q = d*(dl - dr) - r = c1_3*d*d - if ( q > r) then - rcs%uel(ns) = c3*rcs%u_src(ns) - c2*rcs%uer(ns) - elseif (- r > q) then - rcs%uer(ns) = c3*rcs%u_src(ns) - c2*rcs%uel(ns) - endif + rcss%uel(ns) = & + max(rcss%u_src(ns), & + min(rcss%uel(ns), & + rcss%u_src(ns) - c1_3*s*rcss%rcgs%h_src(ns))) endif + rcss%uer(ns) = c1_2*(c3*rcss%u_src(ns) - rcss%uel(ns)) endif endif end subroutine limit_ppm_boundary - subroutine limit_ppm_posdef(rcs) + pure subroutine limit_ppm_posdef(rcss) ! --------------------------------------------------------------------------- ! Modify piecewise parabolas so they are never negative within the grid cell. ! --------------------------------------------------------------------------- - type(reconstruction_struct), intent(inout) :: rcs + type(recon_src_struct), intent(inout) :: rcss real(r8) :: min_u_0, sl, a2, sr, q integer :: j - do j = 1, rcs%n_src - min_u_0 = min(rcs%u_src(j), c0) - rcs%uel(j) = max(rcs%uel(j), min_u_0) - rcs%uer(j) = max(rcs%uer(j), min_u_0) - sl = c2*(c3*rcs%u_src(j) - c2*rcs%uel(j) - rcs%uer(j)) - a2 = c3*(rcs%uel(j) - c2*rcs%u_src(j) + rcs%uer(j)) + do j = 1, rcss%rcgs%n_src_actual + min_u_0 = min(rcss%u_src(j), c0) + rcss%uel(j) = max(rcss%uel(j), min_u_0) + rcss%uer(j) = max(rcss%uer(j), min_u_0) + sl = c2*(c3*rcss%u_src(j) - c2*rcss%uel(j) - rcss%uer(j)) + a2 = c3*(rcss%uel(j) - c2*rcss%u_src(j) + rcss%uer(j)) sr = sl + c2*a2 if (sl < c0 .and. sr > c0) then - if (a2*rcs%uel(j) - c1_4*sl*sl < a2*min_u_0) then - q = c3*rcs%u_src(j)/(c3*sl*sr + c4*a2*a2) - rcs%uel(j) = sl*sl*q - rcs%uer(j) = sr*sr*q + if (a2*rcss%uel(j) - c1_4*sl*sl < a2*min_u_0) then + q = c3*rcss%u_src(j)/(c3*sl*sr + c4*a2*a2) + rcss%uel(j) = sl*sl*q + rcss%uer(j) = sr*sr*q endif endif enddo end subroutine limit_ppm_posdef - subroutine polycoeff_ppm(rcs) + pure subroutine polycoeff_ppm(rcss) ! --------------------------------------------------------------------------- ! Obtain coefficients for piecewise parabolas from grid cell means and left ! and right edge values. ! --------------------------------------------------------------------------- - type(reconstruction_struct), intent(inout) :: rcs + type(recon_src_struct), intent(inout) :: rcss integer :: j - do j = 1, rcs%n_src - rcs%polycoeff(1, j) = rcs%uel(j) - rcs%polycoeff(2, j) = c6*rcs%u_src(j) - c4*rcs%uel(j) - c2*rcs%uer(j) - rcs%polycoeff(3, j) = c3*(rcs%uel(j) - c2*rcs%u_src(j) + rcs%uer(j)) + do j = 1, rcss%rcgs%n_src_actual + rcss%polycoeff(1,j) = rcss%uel(j) + rcss%polycoeff(2,j) = c6*rcss%u_src(j) - c4*rcss%uel(j) & + - c2*rcss%uer(j) + rcss%polycoeff(3,j) = c3*(rcss%uel(j) - c2*rcss%u_src(j) + rcss%uer(j)) enddo end subroutine polycoeff_ppm - subroutine polycoeff_pqm(rcs) + pure subroutine limit_pqm_monotonic(rcss) ! --------------------------------------------------------------------------- - ! Obtain coefficients for piecewise quartics from grid cell means and left - ! and right edge and slope values. + ! Apply limiting to ensure a monotonic reconstruction of piecewise quartics + ! for interior grid cells. ! --------------------------------------------------------------------------- - type(reconstruction_struct), intent(inout) :: rcs - - integer :: j + type(recon_src_struct), intent(inout) :: rcss - do j = 1, rcs%n_src - rcs%polycoeff(1, j) = rcs%uel(j) - rcs%polycoeff(2, j) = rcs%usl(j) - rcs%polycoeff(3, j) = & - c30*rcs%u_src(j) - c18*rcs%uel(j) - c12*rcs%uer(j) & - - c9_2*rcs%usl(j) + c3_2*rcs%usr(j) - rcs%polycoeff(4, j) = & - - c60*rcs%u_src(j) + c32*rcs%uel(j) + c28*rcs%uer(j) & - + c6*rcs%usl(j) - c4*rcs%usr(j) - rcs%polycoeff(5, j) = & - c30*rcs%u_src(j) - c15*(rcs%uel(j) + rcs%uer(j)) & - - c5_2*(rcs%usl(j) - rcs%usr(j)) + real(r8), dimension(rcss%rcgs%n_src_actual) :: sl, sr, sc + real(r8) :: a0, a1, a2, a3, b0, b1, b2, q1, q2, q3, s, xi + integer :: ns, j + logical :: incon_inflex + + ns = rcss%rcgs%n_src_actual + + do j = 2, ns-1 + sl(j) = c2*(rcss%u_src(j) - rcss%u_src(j-1))*rcss%rcgs%hi_src(j) + sr(j) = c2*(rcss%u_src(j+1) - rcss%u_src(j))*rcss%rcgs%hi_src(j) + sc(j) = (rcss%u_src(j+1) - rcss%u_src(j-1))*rcss%rcgs%hci_src(j) + sc(j) = sign(min(abs(sl(j)), abs(sr(j)), abs(sc(j))), sc(j)) + if (sl(j)*sr(j) > c0) then + if ( (rcss%u_src(j-1) - rcss%uel(j)) & + *(rcss%u_src(j ) - rcss%uel(j)) > c0) & + rcss%uel(j) = rcss%u_src(j) & + - sign(min(c1_2*rcss%rcgs%h_src(j)*abs(sc(j)), & + abs(rcss%uel(j) - rcss%u_src(j))), sc(j)) + if ( (rcss%u_src(j+1) - rcss%uer(j)) & + *(rcss%u_src(j ) - rcss%uer(j)) > c0) & + rcss%uer(j) = rcss%u_src(j) & + + sign(min(c1_2*rcss%rcgs%h_src(j)*abs(sc(j)), & + abs(rcss%uer(j) - rcss%u_src(j))), sc(j)) +! if (rcss%usl(j)*sc(j) < c0) rcss%usl(j) = sc(j) +! if (rcss%usr(j)*sc(j) < c0) rcss%usr(j) = sc(j) + if (rcss%usl(j)*sc(j) < c0) rcss%usl(j) = c0 + if (rcss%usr(j)*sc(j) < c0) rcss%usr(j) = c0 + else + rcss%uel(j) = rcss%u_src(j) + rcss%uer(j) = rcss%u_src(j) + rcss%usl(j) = c0 + rcss%usr(j) = c0 + endif enddo - end subroutine polycoeff_pqm + do j = 3, ns-1 + if ( (rcss%uel(j) - rcss%uer(j-1)) & + *(rcss%u_src(j) - rcss%u_src(j-1)) < c0) then + rcss%uel(j) = c1_2*(rcss%uer(j-1) + rcss%uel(j)) + rcss%uer(j-1) = rcss%uel(j) + endif + enddo - pure function parabola_intersection(pc, u, u_eps, xil, xir) result(xi) + do j = 2, ns-1 + + ! Compute polynomial coefficients for 1. derivative of the + ! reconstruction. + a0 = rcss%usl(j) + a1 = c2*( c30*rcss%u_src(j) - c18*rcss%uel(j) - c12*rcss%uer(j) & + - c9_2*rcss%usl(j) + c3_2*rcss%usr(j)) + a2 = c3*(- c60*rcss%u_src(j) + c32*rcss%uel(j) + c28*rcss%uer(j) & + + c6*rcss%usl(j) - c4*rcss%usr(j)) + a3 = c4*( c30*rcss%u_src(j) - c15*(rcss%uel(j) + rcss%uer(j)) & + - c5_2*(rcss%usl(j) - rcss%usr(j))) + + ! Compute polynomial coefficients for 2. derivative of the + ! reconstruction. + b0 = a1 + b1 = c2*a2 + b2 = c3*a3 + + ! Check for inconsistent inflextion points. + incon_inflex = .false. + q1 = b0*b2 + q2 = b1*b1 - c4*q1 + if (q2 > c0) then + if (b0*(b0 + b1 + b2) < c0) then + ! One inflection point. + if (abs(b2) < rcss%u_eps) then + if (abs(b1) > rcss%u_eps) then + xi = - b0/b1 + if ((a0 + xi*(a1 + xi*(a2 + xi*a3)))*sc(j) < c0) & + incon_inflex = .true. + endif + else + q3 = c1_2/b2 + s = sqrt(q2) + xi = - (b1 + s)*q3 + if (xi > c0 .and. xi < c1) then + if ((a0 + xi*(a1 + xi*(a2 + xi*a3)))*sc(j) < c0) & + incon_inflex = .true. + else + xi = - (b1 - s)*q3 + if ((a0 + xi*(a1 + xi*(a2 + xi*a3)))*sc(j) < c0) & + incon_inflex = .true. + endif + endif + elseif (q1 > rcss%uu_eps) then ! Should imply b2 != 0 + ! Two inflection points. + q3 = c1_2/b2 + s = sqrt(q2) + xi = - (b1 + s)*q3 + if ((a0 + xi*(a1 + xi*(a2 + xi*a3)))*sc(j) < c0) then + incon_inflex = .true. + else + xi = - (b1 - s)*q3 + if ((a0 + xi*(a1 + xi*(a2 + xi*a3)))*sc(j) < c0) & + incon_inflex = .true. + endif + endif + endif - real(r8), dimension(:), intent(in) :: pc - real(r8), intent(in) :: u, u_eps, xil, xir + if (incon_inflex) then + if (abs(sl(j)) < abs(sr(j))) then + rcss%usl(j) = c10_3*rcss%u_src(j) - c8_3*rcss%uel(j) & + - c2_3*rcss%uer(j) + if (rcss%usl(j)*sc(j) < c0) then + rcss%usl(j) = c0 + rcss%uer(j) = c5*rcss%u_src(j) - c4*rcss%uel(j) + rcss%usr(j) = c20*(rcss%u_src(j) - rcss%uel(j)) + else + rcss%usr(j) = c4*rcss%uel(j) + c6*rcss%uer(j) & + - c10*rcss%u_src(j) + if (rcss%usr(j)*sc(j) < c0) then + rcss%usr(j) = c0 + rcss%uel(j) = c5_2*rcss%u_src(j) - c3_2*rcss%uer(j) + rcss%usl(j) = c10_3*(rcss%uer(j) - rcss%u_src(j)) + endif + endif + else + rcss%usr(j) = c8_3*rcss%uer(j) + c2_3*rcss%uel(j) & + - c10_3*rcss%u_src(j) + if (rcss%usr(j)*sc(j) < c0) then + rcss%usr(j) = c0 + rcss%uel(j) = c5*rcss%u_src(j) - c4*rcss%uer(j) + rcss%usl(j) = c20*(rcss%uer(j) - rcss%u_src(j)) + else + rcss%usl(j) = c10*rcss%u_src(j) - c4*rcss%uer(j) & + - c6*rcss%uel(j) + if (rcss%usl(j)*sc(j) < c0) then + rcss%usl(j) = c0 + rcss%uer(j) = c5_2*rcss%u_src(j) - c3_2*rcss%uel(j) + rcss%usr(j) = c10_3*(rcss%u_src(j) - rcss%uel(j)) + endif + endif + endif + endif - real(r8) :: xi + enddo - real(r8) :: q, s, xi1, xi2, xim - if (abs(pc(3)) < u_eps) then - if (abs(pc(2)) < u_eps) then - xi = xil + if (rcss%pc_left_bndr) then + ! Piecewise constant reconstruction of the left boundary cell. + rcss%uel(1) = rcss%u_src(1) + rcss%uer(1) = rcss%u_src(1) + rcss%usl(1) = c0 + rcss%usr(1) = c0 + else + ! Do not treat the left boundary cell as a local extrema, but ensure + ! that the piecewise parabola is monotonic within the cell. + if ( (rcss%u_src(2) - rcss%uer(1)) & + *(rcss%u_src(1) - rcss%uer(1)) > c0) then + rcss%uel(1) = rcss%u_src(1) + rcss%uer(1) = rcss%u_src(1) + rcss%usl(1) = c0 + rcss%usr(1) = c0 else - xi = (u - pc(1))/pc(2) + s = c2*(rcss%u_src(3) - rcss%u_src(2)) & + /(rcss%rcgs%h_src(2) + rcss%rcgs%h_src(3)) + if (s > 0) then + rcss%uer(1) = & + max(rcss%u_src(1), & + min(rcss%uel(2), & + rcss%u_src(1) + c1_3*s*rcss%rcgs%h_src(1))) + else + rcss%uer(1) = & + min(rcss%u_src(1), & + max(rcss%uel(2), & + rcss%u_src(1) + c1_3*s*rcss%rcgs%h_src(1))) + endif + rcss%uel(1) = c1_2*(c3*rcss%u_src(1) - rcss%uer(1)) + rcss%usl(1) = c6*rcss%u_src(1) - c4*rcss%uel(1) - c2*rcss%uer(1) + rcss%usr(1) = c2*rcss%uel(1) + c4*rcss%uer(1) - c6*rcss%u_src(1) endif + endif + + if (rcss%pc_right_bndr) then + ! Piecewise constant reconstruction of the right boundary cell. + rcss%uel(ns) = rcss%u_src(ns) + rcss%uer(ns) = rcss%u_src(ns) + rcss%usl(ns) = c0 + rcss%usr(ns) = c0 else - q = c1_2/pc(3) - s = sqrt(max(c0, pc(2)*pc(2) - c4*pc(3)*(pc(1) - u))) - xi1 = - (pc(2) + s)*q - xi2 = - (pc(2) - s)*q - xim = c1_2*(xil + xir) - if (abs(xi1 - xim) < abs(xi2 - xim)) then - xi = xi1 + ! Do not treat the right boundary cell as a local extrema, but ensure + ! that the piecewise parabola is monotonic within the cell. + if ( (rcss%u_src(ns ) - rcss%uel(ns)) & + *(rcss%u_src(ns-1) - rcss%uel(ns)) > c0) then + rcss%uel(ns) = rcss%u_src(ns) + rcss%uer(ns) = rcss%u_src(ns) + rcss%usl(ns) = c0 + rcss%usr(ns) = c0 else - xi = xi2 + s = c2*(rcss%u_src(ns-1) - rcss%u_src(ns-2)) & + /(rcss%rcgs%h_src(ns-2) + rcss%rcgs%h_src(ns-1)) + if (s > 0) then + rcss%uel(ns) = & + min(rcss%u_src(ns), & + max(rcss%uer(ns-1), & + rcss%u_src(ns) - c1_3*s*rcss%rcgs%h_src(ns))) + else + rcss%uel(ns) = & + max(rcss%u_src(ns), & + min(rcss%uer(ns-1), & + rcss%u_src(ns) - c1_3*s*rcss%rcgs%h_src(ns))) + endif + rcss%uer(ns) = c1_2*(c3*rcss%u_src(ns) - rcss%uel(ns)) + rcss%usl(ns) = c6*rcss%u_src(ns) - c4*rcss%uel(ns) - c2*rcss%uer(ns) + rcss%usr(ns) = c2*rcss%uel(ns) + c4*rcss%uer(ns) - c6*rcss%u_src(ns) endif endif - xi = max(xil, min(xir, xi)) - - end function parabola_intersection + end subroutine limit_pqm_monotonic + pure subroutine limit_pqm_non_oscillatory(rcss) ! --------------------------------------------------------------------------- - ! Public procedures. + ! Apply limiting to ensure a monotonic reconstruction of piecewise quartics + ! for interior grid cells. ! --------------------------------------------------------------------------- - function prepare_reconstruction(x_edge_src, method, rcs) result(errstat) - ! --------------------------------------------------------------------------- - ! Prepare reconstruction based on edge locations of source grid cells and - ! requested reconstruction method. Reconstruction data is stored in a - ! reconstruction data structure. - ! --------------------------------------------------------------------------- + type(recon_src_struct), intent(inout) :: rcss - real(r8), dimension(:), intent(in) :: x_edge_src - integer, intent(in) :: method - type(reconstruction_struct), intent(inout) :: rcs + real(r8), dimension(rcss%rcgs%n_src_actual) :: d2, sl, sr, sc + logical, dimension(rcss%rcgs%n_src_actual) :: smooth + real(r8) :: min_u_0, a0, a1, a2, a3, b0, b1, b2, q1, q2, q3, s, xi + integer :: ns, j + logical :: inflex, incon_inflex - integer :: errstat + ns = rcss%rcgs%n_src_actual - integer :: n_src_all, j + ! Obtain values proportional to the second derivative of the unlimited + ! parabolas. + do j = 1, ns + d2(j) = rcss%uel(j) - c2*rcss%u_src(j) + rcss%uer(j) + enddo - rcs%prepared = .false. - errstat = hor3map_noerr + do j = 2, ns-1 + ! Set flag if the reconstruction is considered smooth, that is + ! the sign of the second derivative equals the sign of the second + ! derivatives of both the neighbouring parabolas. + smooth(j) = d2(j-1)*d2(j) >= c0 .and. d2(j)*d2(j+1) >= c0 - ! Check reconstruction method. - if (method /= hor3map_pcm .and. method /= hor3map_plm .and. & - method /= hor3map_ppm .and. method /= hor3map_pqm) then - errstat = hor3map_invalid_method - return - endif + if (smooth(j)) then - ! Number of source grid cells. - n_src_all = size(x_edge_src) - 1 + ! Slopes of a parabolic reconstruction. + sl(j) = c6*rcss%u_src(j) - c4*rcss%uel(j) - c2*rcss%uer(j) + sr(j) = c2*rcss%uel(j) + c4*rcss%uer(j) - c6*rcss%u_src(j) - ! Check that source grid edges are monotonically increasing or decreasing. - if (x_edge_src(n_src_all + 1) - x_edge_src(1) > c0) then - do j = 1, n_src_all - if (x_edge_src(j + 1) < x_edge_src(j)) then - errstat = hor3map_nonmonotonic_src_edges - return - endif - enddo - else - do j = 1, n_src_all - if (x_edge_src(j + 1) > x_edge_src(j)) then - errstat = hor3map_nonmonotonic_src_edges - return - endif - enddo - endif + if (sl(j) < c0 .and. sr(j) > c0) then - ! Set small value with same dimensions as edge locations. - rcs%x_eps = max(abs( x_edge_src(n_src_all + 1) & - - x_edge_src(1)), eps)*eps + ! If the slopes of a parabolic reconstruction has different + ! signs, the parabolic reconstruction is chosen. + rcss%usl(j) = sl(j) + rcss%usr(j) = sr(j) - ! If needed, allocate arrays in reconstruction data structure. - if (.not. rcs%alloced) then - rcs%n_src_all = n_src_all - errstat = allocate_rcs(rcs) - if (errstat /= hor3map_noerr) return - elseif (rcs%n_src_all /= n_src_all) then - call free_rcs(rcs) - rcs%n_src_all = n_src_all - errstat = allocate_rcs(rcs) - if (errstat /= hor3map_noerr) return - endif -#ifdef DEBUG - rcs%x_edge_src(:) = ieee_value(1._r8, ieee_signaling_nan) - rcs%h_src(:) = ieee_value(1._r8, ieee_signaling_nan) - rcs%hi_src(:) = ieee_value(1._r8, ieee_signaling_nan) - rcs%hci_src(:) = ieee_value(1._r8, ieee_signaling_nan) - rcs%src_dst_weight(:) = ieee_value(1._r8, ieee_signaling_nan) - rcs%tdecoeff(:, :) = ieee_value(1._r8, ieee_signaling_nan) - rcs%tdscoeff(:, :) = ieee_value(1._r8, ieee_signaling_nan) - rcs%lblu(:, :) = ieee_value(1._r8, ieee_signaling_nan) - rcs%rblu(:, :) = ieee_value(1._r8, ieee_signaling_nan) - rcs%u_src(:) = ieee_value(1._r8, ieee_signaling_nan) - rcs%uel(:) = ieee_value(1._r8, ieee_signaling_nan) - rcs%uer(:) = ieee_value(1._r8, ieee_signaling_nan) - rcs%src_dst_index = -9999 - rcs%polycoeff(:, :) = ieee_value(1._r8, ieee_signaling_nan) -#endif + else - ! Based on the requested reconstruction method, prepare the data structure - ! for the various methods. Arrays with indices and weights are - ! constructed that will map the source data to a continuous array of - ! grid cells that are non-empty and with widths that will ensure - ! condition numbers below a specified threshold of matrices in linear - ! equation systems to be solved. If insufficient grid cells are available - ! for the requested method, lower order methods are tried. + ! If the quartic reconstruction has one or more inflextion + ! points, a parabolic reconstruction is chosen. + b0 = c2*( c30*rcss%u_src(j) - c18*rcss%uel(j) - c12*rcss%uer(j) & + - c9_2*rcss%usl(j) + c3_2*rcss%usr(j)) + b1 = c6*(- c60*rcss%u_src(j) + c32*rcss%uel(j) & + + c28*rcss%uer(j) + c6*rcss%usl(j) - c4*rcss%usr(j)) + b2 = c12*( c30*rcss%u_src(j) - c15*(rcss%uel(j) + rcss%uer(j)) & + - c5_2*(rcss%usl(j) - rcss%usr(j))) + q1 = b0*b2 + q2 = b1*b1 - c4*q1 + if (q2 > c0 .and. & + (b0*(b0 + b1 + b2) < c0 .or. q1 > rcss%uu_eps)) then + inflex = .true. + else + inflex = .false. + endif + if (inflex) then + rcss%usl(j) = sl(j) + rcss%usr(j) = sr(j) + endif - rcs%method = method + endif - if (rcs%method == hor3map_pqm) then - call prepare_pqm(rcs, x_edge_src) - if (rcs%n_src < 6) then - rcs%method = hor3map_ppm else - rcs%method = hor3map_pqm - endif - endif - if (rcs%method == hor3map_ppm) then - call prepare_ppm(rcs, x_edge_src) - if (rcs%n_src < 4) then - rcs%method = hor3map_plm - else - rcs%method = hor3map_ppm - endif - endif + ! Apply limiting for unsmooth reconstruction. + sl(j) = c2*(rcss%u_src(j) - rcss%u_src(j-1))*rcss%rcgs%hi_src(j) + sr(j) = c2*(rcss%u_src(j+1) - rcss%u_src(j))*rcss%rcgs%hi_src(j) + sc(j) = (rcss%u_src(j+1) - rcss%u_src(j-1))*rcss%rcgs%hci_src(j) + sc(j) = sign(min(abs(sl(j)), abs(sr(j)), abs(sc(j))), sc(j)) + if (sl(j)*sr(j) > c0) then + if ( (rcss%u_src(j-1) - rcss%uel(j)) & + *(rcss%u_src(j ) - rcss%uel(j)) > c0) & + rcss%uel(j) = rcss%u_src(j) & + - sign(min(c1_2*rcss%rcgs%h_src(j)*abs(sc(j)), & + abs(rcss%uel(j) - rcss%u_src(j))), & + sc(j)) + if ( (rcss%u_src(j+1) - rcss%uer(j)) & + *(rcss%u_src(j ) - rcss%uer(j)) > c0) & + rcss%uer(j) = rcss%u_src(j) & + + sign(min(c1_2*rcss%rcgs%h_src(j)*abs(sc(j)), & + abs(rcss%uer(j) - rcss%u_src(j))), & + sc(j)) +! if (rcss%usl(j)*sc(j) < c0) rcss%usl(j) = sc(j) +! if (rcss%usr(j)*sc(j) < c0) rcss%usr(j) = sc(j) + if (rcss%usl(j)*sc(j) < c0) rcss%usl(j) = c0 + if (rcss%usr(j)*sc(j) < c0) rcss%usr(j) = c0 + else + rcss%uel(j) = rcss%u_src(j) + rcss%uer(j) = rcss%u_src(j) + rcss%usl(j) = c0 + rcss%usr(j) = c0 + endif - if (rcs%method == hor3map_plm) then - call prepare_plm(rcs, x_edge_src) - if (rcs%n_src < 2) then - rcs%method = hor3map_pcm - else - rcs%method = hor3map_plm endif - endif + enddo - if (rcs%method == hor3map_pcm) then - call prepare_pcm(rcs, x_edge_src) - if (rcs%n_src == 0) then - errstat = hor3map_src_extent_too_small - return - else - rcs%method = hor3map_pcm + do j = 3, ns-1 + if ( (rcss%uel(j) - rcss%uer(j-1)) & + *(rcss%u_src(j) - rcss%u_src(j-1)) < c0) then + if (smooth(j-1)) then + rcss%uel(j) = rcss%uer(j-1) + elseif (smooth(j )) then + rcss%uer(j-1) = rcss%uel(j) + else + rcss%uel(j) = c1_2*(rcss%uer(j-1) + rcss%uel(j)) + rcss%uer(j-1) = rcss%uel(j) + endif endif - endif + enddo - rcs%prepared = .true. + do j = 2, ns-1 + + if (.not.smooth(j)) then + + ! Compute polynomial coefficients for 1. derivative of the + ! reconstruction. + a0 = rcss%usl(j) + a1 = c2*( c30*rcss%u_src(j) - c18*rcss%uel(j) - c12*rcss%uer(j) & + - c9_2*rcss%usl(j) + c3_2*rcss%usr(j)) + a2 = c3*(- c60*rcss%u_src(j) + c32*rcss%uel(j) + c28*rcss%uer(j) & + + c6*rcss%usl(j) - c4*rcss%usr(j)) + a3 = c4*( c30*rcss%u_src(j) - c15*(rcss%uel(j) + rcss%uer(j)) & + - c5_2*(rcss%usl(j) - rcss%usr(j))) + + ! Compute polynomial coefficients for 2. derivative of the + ! reconstruction. + b0 = a1 + b1 = c2*a2 + b2 = c3*a3 + + ! Check for inconsistent inflextion points. + incon_inflex = .false. + q1 = b0*b2 + q2 = b1*b1 - c4*q1 + if (q2 > c0) then + if (b0*(b0 + b1 + b2) < c0) then + ! One inflection point. + if (abs(b2) < rcss%u_eps) then + if (abs(b1) > rcss%u_eps) then + xi = - b0/b1 + if ((a0 + xi*(a1 + xi*(a2 + xi*a3)))*sc(j) < c0) & + incon_inflex = .true. + endif + else + q3 = c1_2/b2 + s = sqrt(q2) + xi = - (b1 + s)*q3 + if (xi > c0 .and. xi < c1) then + if ((a0 + xi*(a1 + xi*(a2 + xi*a3)))*sc(j) < c0) & + incon_inflex = .true. + else + xi = - (b1 - s)*q3 + if ((a0 + xi*(a1 + xi*(a2 + xi*a3)))*sc(j) < c0) & + incon_inflex = .true. + endif + endif + elseif (q1 > rcss%uu_eps) then ! Should imply b2 != 0 + ! Two inflection points. + q3 = c1_2/b2 + s = sqrt(q2) + xi = - (b1 + s)*q3 + if ((a0 + xi*(a1 + xi*(a2 + xi*a3)))*sc(j) < c0) then + incon_inflex = .true. + else + xi = - (b1 - s)*q3 + if ((a0 + xi*(a1 + xi*(a2 + xi*a3)))*sc(j) < c0) & + incon_inflex = .true. + endif + endif + endif - end function prepare_reconstruction + if (incon_inflex) then + if (abs(sl(j)) < abs(sr(j))) then + rcss%usl(j) = c10_3*rcss%u_src(j) - c8_3*rcss%uel(j) & + - c2_3*rcss%uer(j) + if (rcss%usl(j)*sc(j) < c0) then + rcss%usl(j) = c0 + rcss%uer(j) = c5*rcss%u_src(j) - c4*rcss%uel(j) + rcss%usr(j) = c20*(rcss%u_src(j) - rcss%uel(j)) + else + rcss%usr(j) = c4*rcss%uel(j) + c6*rcss%uer(j) & + - c10*rcss%u_src(j) + if (rcss%usr(j)*sc(j) < c0) then + rcss%usr(j) = c0 + rcss%uel(j) = c5_2*rcss%u_src(j) - c3_2*rcss%uer(j) + rcss%usl(j) = c10_3*(rcss%uer(j) - rcss%u_src(j)) + endif + endif + else + rcss%usr(j) = c8_3*rcss%uer(j) + c2_3*rcss%uel(j) & + - c10_3*rcss%u_src(j) + if (rcss%usr(j)*sc(j) < c0) then + rcss%usr(j) = c0 + rcss%uel(j) = c5*rcss%u_src(j) - c4*rcss%uer(j) + rcss%usl(j) = c20*(rcss%uer(j) - rcss%u_src(j)) + else + rcss%usl(j) = c10*rcss%u_src(j) - c4*rcss%uer(j) & + - c6*rcss%uel(j) + if (rcss%usl(j)*sc(j) < c0) then + rcss%usl(j) = c0 + rcss%uer(j) = c5_2*rcss%u_src(j) - c3_2*rcss%uel(j) + rcss%usr(j) = c10_3*(rcss%u_src(j) - rcss%uel(j)) + endif + endif + endif + endif - function prepare_remapping(rcs, x_edge_dst, rms) result(errstat) - ! --------------------------------------------------------------------------- + endif + + enddo + + + if (rcss%pc_left_bndr) then + ! Piecewise constant reconstruction of the left boundary cell. + rcss%uel(1) = rcss%u_src(1) + rcss%uer(1) = rcss%u_src(1) + rcss%usl(1) = c0 + rcss%usr(1) = c0 + else + ! Do not treat the left boundary cell as a local extrema, but ensure + ! that the piecewise parabola is monotonic within the cell. + if ( (rcss%u_src(2) - rcss%uer(1)) & + *(rcss%u_src(1) - rcss%uer(1)) > c0) then + rcss%uel(1) = rcss%u_src(1) + rcss%uer(1) = rcss%u_src(1) + rcss%usl(1) = c0 + rcss%usr(1) = c0 + else + s = c2*(rcss%u_src(3) - rcss%u_src(2)) & + /(rcss%rcgs%h_src(2) + rcss%rcgs%h_src(3)) + if (s > 0) then + rcss%uer(1) = & + max(rcss%u_src(1), & + min(rcss%uel(2), & + rcss%u_src(1) + c1_3*s*rcss%rcgs%h_src(1))) + else + rcss%uer(1) = & + min(rcss%u_src(1), & + max(rcss%uel(2), & + rcss%u_src(1) + c1_3*s*rcss%rcgs%h_src(1))) + endif + rcss%uel(1) = c1_2*(c3*rcss%u_src(1) - rcss%uer(1)) + rcss%usl(1) = c6*rcss%u_src(1) - c4*rcss%uel(1) - c2*rcss%uer(1) + rcss%usr(1) = c2*rcss%uel(1) + c4*rcss%uer(1) - c6*rcss%u_src(1) + endif + endif + + if (rcss%pc_right_bndr) then + ! Piecewise constant reconstruction of the right boundary cell. + rcss%uel(ns) = rcss%u_src(ns) + rcss%uer(ns) = rcss%u_src(ns) + rcss%usl(ns) = c0 + rcss%usr(ns) = c0 + else + ! Do not treat the right boundary cell as a local extrema, but ensure + ! that the piecewise parabola is monotonic within the cell. + if ( (rcss%u_src(ns ) - rcss%uel(ns)) & + *(rcss%u_src(ns-1) - rcss%uel(ns)) > c0) then + rcss%uel(ns) = rcss%u_src(ns) + rcss%uer(ns) = rcss%u_src(ns) + rcss%usl(ns) = c0 + rcss%usr(ns) = c0 + else + s = c2*(rcss%u_src(ns-1) - rcss%u_src(ns-2)) & + /(rcss%rcgs%h_src(ns-2) + rcss%rcgs%h_src(ns-1)) + if (s > 0) then + rcss%uel(ns) = & + min(rcss%u_src(ns), & + max(rcss%uer(ns-1), & + rcss%u_src(ns) - c1_3*s*rcss%rcgs%h_src(ns))) + else + rcss%uel(ns) = & + max(rcss%u_src(ns), & + min(rcss%uer(ns-1), & + rcss%u_src(ns) - c1_3*s*rcss%rcgs%h_src(ns))) + endif + rcss%uer(ns) = c1_2*(c3*rcss%u_src(ns) - rcss%uel(ns)) + rcss%usl(ns) = c6*rcss%u_src(ns) - c4*rcss%uel(ns) - c2*rcss%uer(ns) + rcss%usr(ns) = c2*rcss%uel(ns) + c4*rcss%uer(ns) - c6*rcss%u_src(ns) + endif + endif + + end subroutine limit_pqm_non_oscillatory + + pure subroutine limit_pqm_non_oscillatory_posdef(rcss) + ! --------------------------------------------------------------------------- + ! Apply limiting to ensure a monotonic reconstruction of piecewise quartics + ! for interior grid cells. + ! --------------------------------------------------------------------------- + + type(recon_src_struct), intent(inout) :: rcss + + real(r8), dimension(rcss%rcgs%n_src_actual) :: d2, sl, sr, sc + logical, dimension(rcss%rcgs%n_src_actual) :: smooth + real(r8) :: min_u_0, a0, a1, a2, a3, b0, b1, b2, q1, q2, q3, s, xi + integer :: ns, j + logical :: inflex, incon_inflex + + ns = rcss%rcgs%n_src_actual + + ! Obtain values proportional to the second derivative of the unlimited + ! parabolas. + do j = 1, ns + d2(j) = rcss%uel(j) - c2*rcss%u_src(j) + rcss%uer(j) + enddo + + do j = 2, ns-1 + ! Set flag if the reconstruction is considered smooth, that is + ! the sign of the second derivative equals the sign of the second + ! derivatives of both the neighbouring parabolas. + smooth(j) = d2(j-1)*d2(j) >= c0 .and. d2(j)*d2(j+1) >= c0 + + if (smooth(j)) then + + ! Ensure edge values of smooth reconstruction is positive definite. + min_u_0 = min(rcss%u_src(j), c0) + rcss%uel(j) = max(rcss%uel(j), min_u_0) + rcss%uer(j) = max(rcss%uer(j), min_u_0) + + ! Slopes of a parabolic reconstruction. + sl(j) = c6*rcss%u_src(j) - c4*rcss%uel(j) - c2*rcss%uer(j) + sr(j) = c2*rcss%uel(j) + c4*rcss%uer(j) - c6*rcss%u_src(j) + + if (sl(j) < c0 .and. sr(j) > c0) then + + ! If the slopes of a parabolic reconstruction has different + ! signs, the parabolic reconstruction is chosen. If needed, + ! modify the parabola it is positive definite. + a2 = c1_2*(sr(j) - sl(j)) + if (a2*rcss%uel(j) - c1_4*sl(j)*sl(j) < a2*min_u_0) then + q1 = c3*rcss%u_src(j)/(c3*sl(j)*sr(j) + c4*a2*a2) + rcss%uel(j) = sl(j)*sl(j)*q1 + rcss%uer(j) = sr(j)*sr(j)*q1 + rcss%usl(j) = c6*rcss%u_src(j) - c4*rcss%uel(j) & + - c2*rcss%uer(j) + rcss%usr(j) = c2*rcss%uel(j) + c4*rcss%uer(j) & + - c6*rcss%u_src(j) + else + rcss%usl(j) = sl(j) + rcss%usr(j) = sr(j) + endif + + else + + ! If the quartic reconstruction has one or more inflextion + ! points, a parabolic reconstruction is chosen. + b0 = c2*( c30*rcss%u_src(j) - c18*rcss%uel(j) - c12*rcss%uer(j) & + - c9_2*rcss%usl(j) + c3_2*rcss%usr(j)) + b1 = c6*(- c60*rcss%u_src(j) + c32*rcss%uel(j) & + + c28*rcss%uer(j) + c6*rcss%usl(j) - c4*rcss%usr(j)) + b2 = c12*( c30*rcss%u_src(j) - c15*(rcss%uel(j) + rcss%uer(j)) & + - c5_2*(rcss%usl(j) - rcss%usr(j))) + q1 = b0*b2 + q2 = b1*b1 - c4*q1 + if (q2 > c0 .and. & + (b0*(b0 + b1 + b2) < c0 .or. q1 > rcss%uu_eps)) then + inflex = .true. + else + inflex = .false. + endif + if (inflex) then + rcss%usl(j) = sl(j) + rcss%usr(j) = sr(j) + endif + + endif + + else + + ! Apply limiting for unsmooth reconstruction. + sl(j) = c2*(rcss%u_src(j) - rcss%u_src(j-1))*rcss%rcgs%hi_src(j) + sr(j) = c2*(rcss%u_src(j+1) - rcss%u_src(j))*rcss%rcgs%hi_src(j) + sc(j) = (rcss%u_src(j+1) - rcss%u_src(j-1))*rcss%rcgs%hci_src(j) + sc(j) = sign(min(abs(sl(j)), abs(sr(j)), abs(sc(j))), sc(j)) + if (sl(j)*sr(j) > c0) then + if ( (rcss%u_src(j-1) - rcss%uel(j)) & + *(rcss%u_src(j ) - rcss%uel(j)) > c0) & + rcss%uel(j) = rcss%u_src(j) & + - sign(min(c1_2*rcss%rcgs%h_src(j)*abs(sc(j)), & + abs(rcss%uel(j) - rcss%u_src(j))), & + sc(j)) + if ( (rcss%u_src(j+1) - rcss%uer(j)) & + *(rcss%u_src(j ) - rcss%uer(j)) > c0) & + rcss%uer(j) = rcss%u_src(j) & + + sign(min(c1_2*rcss%rcgs%h_src(j)*abs(sc(j)), & + abs(rcss%uer(j) - rcss%u_src(j))), & + sc(j)) +! if (rcss%usl(j)*sc(j) < c0) rcss%usl(j) = sc(j) +! if (rcss%usr(j)*sc(j) < c0) rcss%usr(j) = sc(j) + if (rcss%usl(j)*sc(j) < c0) rcss%usl(j) = c0 + if (rcss%usr(j)*sc(j) < c0) rcss%usr(j) = c0 + else + rcss%uel(j) = rcss%u_src(j) + rcss%uer(j) = rcss%u_src(j) + rcss%usl(j) = c0 + rcss%usr(j) = c0 + endif + + endif + enddo + + do j = 3, ns-1 + if ( (rcss%uel(j) - rcss%uer(j-1)) & + *(rcss%u_src(j) - rcss%u_src(j-1)) < c0) then + if (smooth(j-1)) then + rcss%uel(j) = rcss%uer(j-1) + elseif (smooth(j )) then + rcss%uer(j-1) = rcss%uel(j) + else + rcss%uel(j) = c1_2*(rcss%uer(j-1) + rcss%uel(j)) + rcss%uer(j-1) = rcss%uel(j) + endif + endif + enddo + + do j = 2, ns-1 + + if (.not.smooth(j)) then + + ! Compute polynomial coefficients for 1. derivative of the + ! reconstruction. + a0 = rcss%usl(j) + a1 = c2*( c30*rcss%u_src(j) - c18*rcss%uel(j) - c12*rcss%uer(j) & + - c9_2*rcss%usl(j) + c3_2*rcss%usr(j)) + a2 = c3*(- c60*rcss%u_src(j) + c32*rcss%uel(j) + c28*rcss%uer(j) & + + c6*rcss%usl(j) - c4*rcss%usr(j)) + a3 = c4*( c30*rcss%u_src(j) - c15*(rcss%uel(j) + rcss%uer(j)) & + - c5_2*(rcss%usl(j) - rcss%usr(j))) + + ! Compute polynomial coefficients for 2. derivative of the + ! reconstruction. + b0 = a1 + b1 = c2*a2 + b2 = c3*a3 + + ! Check for inconsistent inflextion points. + incon_inflex = .false. + q1 = b0*b2 + q2 = b1*b1 - c4*q1 + if (q2 > c0) then + if (b0*(b0 + b1 + b2) < c0) then + ! One inflection point. + if (abs(b2) < rcss%u_eps) then + if (abs(b1) > rcss%u_eps) then + xi = - b0/b1 + if ((a0 + xi*(a1 + xi*(a2 + xi*a3)))*sc(j) < c0) & + incon_inflex = .true. + endif + else + q3 = c1_2/b2 + s = sqrt(q2) + xi = - (b1 + s)*q3 + if (xi > c0 .and. xi < c1) then + if ((a0 + xi*(a1 + xi*(a2 + xi*a3)))*sc(j) < c0) & + incon_inflex = .true. + else + xi = - (b1 - s)*q3 + if ((a0 + xi*(a1 + xi*(a2 + xi*a3)))*sc(j) < c0) & + incon_inflex = .true. + endif + endif + elseif (q1 > rcss%uu_eps) then ! Should imply b2 != 0 + ! Two inflection points. + q3 = c1_2/b2 + s = sqrt(q2) + xi = - (b1 + s)*q3 + if ((a0 + xi*(a1 + xi*(a2 + xi*a3)))*sc(j) < c0) then + incon_inflex = .true. + else + xi = - (b1 - s)*q3 + if ((a0 + xi*(a1 + xi*(a2 + xi*a3)))*sc(j) < c0) & + incon_inflex = .true. + endif + endif + endif + + if (incon_inflex) then + if (abs(sl(j)) < abs(sr(j))) then + rcss%usl(j) = c10_3*rcss%u_src(j) - c8_3*rcss%uel(j) & + - c2_3*rcss%uer(j) + if (rcss%usl(j)*sc(j) < c0) then + rcss%usl(j) = c0 + rcss%uer(j) = c5*rcss%u_src(j) - c4*rcss%uel(j) + rcss%usr(j) = c20*(rcss%u_src(j) - rcss%uel(j)) + else + rcss%usr(j) = c4*rcss%uel(j) + c6*rcss%uer(j) & + - c10*rcss%u_src(j) + if (rcss%usr(j)*sc(j) < c0) then + rcss%usr(j) = c0 + rcss%uel(j) = c5_2*rcss%u_src(j) - c3_2*rcss%uer(j) + rcss%usl(j) = c10_3*(rcss%uer(j) - rcss%u_src(j)) + endif + endif + else + rcss%usr(j) = c8_3*rcss%uer(j) + c2_3*rcss%uel(j) & + - c10_3*rcss%u_src(j) + if (rcss%usr(j)*sc(j) < c0) then + rcss%usr(j) = c0 + rcss%uel(j) = c5*rcss%u_src(j) - c4*rcss%uer(j) + rcss%usl(j) = c20*(rcss%uer(j) - rcss%u_src(j)) + else + rcss%usl(j) = c10*rcss%u_src(j) - c4*rcss%uer(j) & + - c6*rcss%uel(j) + if (rcss%usl(j)*sc(j) < c0) then + rcss%usl(j) = c0 + rcss%uer(j) = c5_2*rcss%u_src(j) - c3_2*rcss%uel(j) + rcss%usr(j) = c10_3*(rcss%u_src(j) - rcss%uel(j)) + endif + endif + endif + endif + + endif + + enddo + + + if (rcss%pc_left_bndr) then + ! Piecewise constant reconstruction of the left boundary cell. + rcss%uel(1) = rcss%u_src(1) + rcss%uer(1) = rcss%u_src(1) + rcss%usl(1) = c0 + rcss%usr(1) = c0 + else + ! Do not treat the left boundary cell as a local extrema, but ensure + ! that the piecewise parabola is monotonic within the cell. + if ( (rcss%u_src(2) - rcss%uer(1)) & + *(rcss%u_src(1) - rcss%uer(1)) > c0) then + rcss%uel(1) = rcss%u_src(1) + rcss%uer(1) = rcss%u_src(1) + rcss%usl(1) = c0 + rcss%usr(1) = c0 + else + s = c2*(rcss%u_src(3) - rcss%u_src(2)) & + /(rcss%rcgs%h_src(2) + rcss%rcgs%h_src(3)) + if (s > 0) then + rcss%uer(1) = & + max(rcss%u_src(1), & + min(rcss%uel(2), & + rcss%u_src(1) + c1_3*s*rcss%rcgs%h_src(1))) + rcss%uel(1) = max(min(rcss%u_src(1), c0), & + c1_2*(c3*rcss%u_src(1) - rcss%uer(1))) + rcss%uer(1) = c3*rcss%u_src(1) - c2*rcss%uel(1) + else + rcss%uer(1) = & + min(rcss%u_src(1), & + max(rcss%uel(2), & + rcss%u_src(1) + c1_3*s*rcss%rcgs%h_src(1))) + rcss%uel(1) = c1_2*(c3*rcss%u_src(1) - rcss%uer(1)) + endif + rcss%usl(1) = c6*rcss%u_src(1) - c4*rcss%uel(1) - c2*rcss%uer(1) + rcss%usr(1) = c2*rcss%uel(1) + c4*rcss%uer(1) - c6*rcss%u_src(1) + endif + endif + + if (rcss%pc_right_bndr) then + ! Piecewise constant reconstruction of the right boundary cell. + rcss%uel(ns) = rcss%u_src(ns) + rcss%uer(ns) = rcss%u_src(ns) + rcss%usl(ns) = c0 + rcss%usr(ns) = c0 + else + ! Do not treat the right boundary cell as a local extrema, but ensure + ! that the piecewise parabola is monotonic within the cell. + if ( (rcss%u_src(ns ) - rcss%uel(ns)) & + *(rcss%u_src(ns-1) - rcss%uel(ns)) > c0) then + rcss%uel(ns) = rcss%u_src(ns) + rcss%uer(ns) = rcss%u_src(ns) + rcss%usl(ns) = c0 + rcss%usr(ns) = c0 + else + s = c2*(rcss%u_src(ns-1) - rcss%u_src(ns-2)) & + /(rcss%rcgs%h_src(ns-2) + rcss%rcgs%h_src(ns-1)) + if (s > 0) then + rcss%uel(ns) = & + min(rcss%u_src(ns), & + max(rcss%uer(ns-1), & + rcss%u_src(ns) - c1_3*s*rcss%rcgs%h_src(ns))) + rcss%uer(ns) = c1_2*(c3*rcss%u_src(ns) - rcss%uel(ns)) + else + rcss%uel(ns) = & + max(rcss%u_src(ns), & + min(rcss%uer(ns-1), & + rcss%u_src(ns) - c1_3*s*rcss%rcgs%h_src(ns))) + rcss%uer(ns) = max(min(rcss%u_src(ns), c0), & + c1_2*(c3*rcss%u_src(ns) - rcss%uel(ns))) + rcss%uel(ns) = c3*rcss%u_src(ns) - c2*rcss%uer(ns) + endif + rcss%usl(ns) = c6*rcss%u_src(ns) - c4*rcss%uel(ns) - c2*rcss%uer(ns) + rcss%usr(ns) = c2*rcss%uel(ns) + c4*rcss%uer(ns) - c6*rcss%u_src(ns) + endif + endif + + end subroutine limit_pqm_non_oscillatory_posdef + + pure subroutine polycoeff_pqm(rcss) + ! --------------------------------------------------------------------------- + ! Obtain coefficients for piecewise quartics from grid cell means and left + ! and right edge and slope values. + ! --------------------------------------------------------------------------- + + type(recon_src_struct), intent(inout) :: rcss + + integer :: j + + do j = 1, rcss%rcgs%n_src_actual + rcss%polycoeff(1,j) = rcss%uel(j) + rcss%polycoeff(2,j) = rcss%usl(j) + rcss%polycoeff(3,j) = & + c30*rcss%u_src(j) - c18*rcss%uel(j) - c12*rcss%uer(j) & + - c9_2*rcss%usl(j) + c3_2*rcss%usr(j) + rcss%polycoeff(4,j) = & + - c60*rcss%u_src(j) + c32*rcss%uel(j) + c28*rcss%uer(j) & + + c6*rcss%usl(j) - c4*rcss%usr(j) + rcss%polycoeff(5,j) = & + c30*rcss%u_src(j) - c15*(rcss%uel(j) + rcss%uer(j)) & + - c5_2*(rcss%usl(j) - rcss%usr(j)) + enddo + + end subroutine polycoeff_pqm + + pure function line_intersection(pc, u, u_eps, xil, xir) result(xi) + + real(r8), dimension(2), intent(in) :: pc + real(r8), intent(in) :: u, u_eps, xil, xir + + real(r8) :: xi + + real(r8) :: q, s, xi1, xi2, xim + + if (abs(pc(2)) < u_eps) then + xi = xil + else + xi = max(xil, min(xir, (u - pc(1))/pc(2))) + endif + + end function line_intersection + + pure function parabola_intersection(pc, u, u_eps, xil, xir) result(xi) + + real(r8), dimension(3), intent(in) :: pc + real(r8), intent(in) :: u, u_eps, xil, xir + + real(r8) :: xi + + real(r8) :: q, s, xi1, xi2, xim + + if (abs(pc(3)) < u_eps) then + xi = line_intersection(pc(1:2), u, u_eps, xil, xir) + else + q = c1_2/pc(3) + s = sqrt(max(c0, pc(2)*pc(2) - c4*pc(3)*(pc(1) - u))) + xi1 = - (pc(2) + s)*q + xi2 = - (pc(2) - s)*q + xim = c1_2*(xil + xir) + if (abs(xi1 - xim) < abs(xi2 - xim)) then + xi = xi1 + else + xi = xi2 + endif + xi = max(xil, min(xir, xi)) + endif + + end function parabola_intersection + + pure function quartic_intersection(pc, u, u_eps, xil, xir) result(xi) + + real(r8), dimension(5), intent(in) :: pc + real(r8), intent(in) :: u, u_eps, xil, xir + + real(r8) :: xi + + real(r8) :: r, drdx, xi_old + integer :: n + + if (abs(pc(4)) < u_eps .and. abs(pc(5)) < u_eps) then + xi = parabola_intersection(pc(1:3), u, u_eps, xil, xir) + else + xi = c1_2*(xil + xir) + do n = 1, 10 + r = pc(1) + (pc(2) + (pc(3) + (pc(4) + pc(5)*xi)*xi)*xi)*xi - u + drdx = pc(2) + (c2*pc(3) + (c3*pc(4) + c4*pc(5)*xi)*xi)*xi + xi_old = xi + xi = max(xil, min(xir, xi_old - r/sign(max(eps, abs(drdx)), drdx))) + if (abs(xi - xi_old) < 1.e-9_r8) return + enddo + endif + + end function quartic_intersection + + pure subroutine regrid_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), dimension(3) :: pcl, pcr + real(r8) :: umr, uml, xi, duml, dumr, uerl, uelr + 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) + + ! Find possible intersections in the first half of the first source grid + ! cell. + 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 + umr = rcss%polycoeff(1,js) & + + c1_2*rcss%polycoeff(2,js) + do + if ((u_edge_grd(jg) - umr)*u_sgn > c0) exit + xi = line_intersection(rcss%polycoeff(:,js), u_edge_grd(jg), & + rcss%u_eps, c0, c1_2) + 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 + + outer: do + + ! For the current grid edge index, find the index of the first source + ! grid cell with mid point reconstructed value larger than the grid + ! edge value. + do + uml = umr + umr = rcss%polycoeff(1,js) & + + c1_2*rcss%polycoeff(2,js) + if ((u_edge_grd(jg) - umr)*u_sgn <= c0) exit + js = js + 1 + if (js > ns) exit outer + enddo + + ! 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 + ! respective grid cells. + duml = rcss%polycoeff(2,js-1) + dumr = rcss%polycoeff(2,js ) + pcr(2) = (c4*(umr - uml) - duml - dumr)*rcss%rcgs%h_src(js) & + /(rcss%rcgs%h_src(js-1) + rcss%rcgs%h_src(js)) + pcr(1) = umr - c1_4*(dumr + pcr(2)) + if (pcr(2)*(rcss%u_src(js) - rcss%u_src(js-1)) < c0) then + ! 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 + ! is then not guaranteed. + pcr(2) = c0 + uerl = rcss%uer(js-1) + uelr = rcss%uel(js) + pcr(1) = min(max(pcr(1), min(uerl, uelr)), max(uerl, uelr)) + pcr(3) = c4*(umr - pcr(1)) + pcl(1) = c4*uml - c3*pcr(1) + pcl(2) = c2*(pcr(1) - pcl(1)) + pcl(3) = - c1_2*pcl(2) + else + pcr(3) = dumr - pcr(2) + pcl(1) = pcr(1) - duml + pcl(2) = c4*(uml - pcl(1)) - duml + pcl(3) = duml - pcl(2) + endif + + ! Find all intersections with piecewise parabola in the last half of + ! the source grid cell left of the edge. + do + if ((u_edge_grd(jg) - pcr(1))*u_sgn > c0) exit + xi = parabola_intersection(pcl, u_edge_grd(jg), & + rcss%u_eps, c1_2, c1) + x_edge_grd(jg) = rcss%rcgs%x_edge_src(js-1) & + + ( rcss%rcgs%x_edge_src(js ) & + - rcss%rcgs%x_edge_src(js-1))*xi + jg = jg + 1 + if (jg > ng) return + enddo + + ! Find all intersections with piecewise parabola in the first half of + ! the source grid cell right of the edge. + do + if ((u_edge_grd(jg) - umr)*u_sgn > c0) exit + xi = parabola_intersection(pcr, u_edge_grd(jg), & + rcss%u_eps, c0, c1_2) + 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 + + enddo outer + + ! Find possible intersections in the last half of the last source grid + ! cell. + js = ns + 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, c1_2, 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_intersections + + pure subroutine regrid_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), dimension(3) :: pcl, pcr + real(r8) :: umr, uml, xi, duml, dumr, uerl, uelr + 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) + + ! Find possible intersections in the first half of the first source grid + ! cell. + 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 + umr = rcss%polycoeff(1,js) & + + c1_2*rcss%polycoeff(2,js) & + + c1_4*rcss%polycoeff(3,js) + do + if ((u_edge_grd(jg) - umr)*u_sgn > c0) exit + xi = parabola_intersection(rcss%polycoeff(:,js), u_edge_grd(jg), & + rcss%u_eps, c0, c1_2) + 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 + + outer: do + + ! For the current grid edge index, find the index of the first source + ! grid cell with mid point reconstructed value larger than the grid + ! edge value. + do + uml = umr + umr = rcss%polycoeff(1,js) & + + c1_2*rcss%polycoeff(2,js) & + + c1_4*rcss%polycoeff(3,js) + if ((u_edge_grd(jg) - umr)*u_sgn <= c0) exit + js = js + 1 + if (js > ns) exit outer + enddo + + ! 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 + ! respective grid cells. + duml = rcss%polycoeff(2,js-1) + rcss%polycoeff(3,js-1) + dumr = rcss%polycoeff(2,js ) + rcss%polycoeff(3,js ) + pcr(2) = (c4*(umr - uml) - duml - dumr)*rcss%rcgs%h_src(js) & + /(rcss%rcgs%h_src(js-1) + rcss%rcgs%h_src(js)) + pcr(1) = umr - c1_4*(dumr + pcr(2)) + if (pcr(2)*(rcss%u_src(js) - rcss%u_src(js-1)) < c0) then + ! 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 + ! is then not guaranteed. + pcr(2) = c0 + uerl = rcss%uer(js-1) + uelr = rcss%uel(js) + pcr(1) = min(max(pcr(1), min(uerl, uelr)), max(uerl, uelr)) + pcr(3) = c4*(umr - pcr(1)) + pcl(1) = c4*uml - c3*pcr(1) + pcl(2) = c2*(pcr(1) - pcl(1)) + pcl(3) = - c1_2*pcl(2) + else + pcr(3) = dumr - pcr(2) + pcl(1) = pcr(1) - duml + pcl(2) = c4*(uml - pcl(1)) - duml + pcl(3) = duml - pcl(2) + endif + + ! Find all intersections with piecewise parabola in the last half of + ! the source grid cell left of the edge. + do + if ((u_edge_grd(jg) - pcr(1))*u_sgn > c0) exit + xi = parabola_intersection(pcl, u_edge_grd(jg), & + rcss%u_eps, c1_2, c1) + x_edge_grd(jg) = rcss%rcgs%x_edge_src(js-1) & + + ( rcss%rcgs%x_edge_src(js ) & + - rcss%rcgs%x_edge_src(js-1))*xi + jg = jg + 1 + if (jg > ng) return + enddo + + ! Find all intersections with piecewise parabola in the first half of + ! the source grid cell right of the edge. + do + if ((u_edge_grd(jg) - umr)*u_sgn > c0) exit + xi = parabola_intersection(pcr, u_edge_grd(jg), & + rcss%u_eps, c0, c1_2) + 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 + + enddo outer + + ! Find possible intersections in the last half of the last source grid + ! cell. + js = ns + 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, c1_2, 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_intersections + + pure subroutine regrid_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), dimension(3) :: pcl, pcr + real(r8) :: umr, uml, xi, duml, dumr, uerl, uelr + 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) + + ! Find possible intersections in the first half of the first source grid + ! cell. + 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 + umr = rcss%polycoeff(1,js) & + + c1_2 *rcss%polycoeff(2,js) & + + c1_4 *rcss%polycoeff(3,js) & + + c1_8 *rcss%polycoeff(4,js) & + + c1_16*rcss%polycoeff(5,js) + do + if ((u_edge_grd(jg) - umr)*u_sgn > c0) exit + xi = quartic_intersection(rcss%polycoeff(:,js), u_edge_grd(jg), & + rcss%u_eps, c0, c1_2) + 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 + + outer: do + + ! For the current grid edge index, find the index of the first source + ! grid cell with mid point reconstructed value larger than the grid + ! edge value. + do + uml = umr + umr = rcss%polycoeff(1,js) & + + c1_2 *rcss%polycoeff(2,js) & + + c1_4 *rcss%polycoeff(3,js) & + + c1_8 *rcss%polycoeff(4,js) & + + c1_16*rcss%polycoeff(5,js) + if ((u_edge_grd(jg) - umr)*u_sgn <= c0) exit + js = js + 1 + if (js > ns) exit outer + enddo + + ! 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 + ! 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) + dumr = rcss%polycoeff(2,js ) + rcss%polycoeff(3,js ) & + + c3_4*rcss%polycoeff(4,js ) + c1_2*rcss%polycoeff(5,js ) + pcr(2) = (c4*(umr - uml) - duml - dumr)*rcss%rcgs%h_src(js) & + /(rcss%rcgs%h_src(js-1) + rcss%rcgs%h_src(js)) + pcr(1) = umr - c1_4*(dumr + pcr(2)) + if (pcr(2)*(rcss%u_src(js) - rcss%u_src(js-1)) < c0) then + ! 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 + ! is then not guaranteed. + pcr(2) = c0 + uerl = rcss%uer(js-1) + uelr = rcss%uel(js) + pcr(1) = min(max(pcr(1), min(uerl, uelr)), max(uerl, uelr)) + pcr(3) = c4*(umr - pcr(1)) + pcl(1) = c4*uml - c3*pcr(1) + pcl(2) = c2*(pcr(1) - pcl(1)) + pcl(3) = - c1_2*pcl(2) + else + pcr(3) = dumr - pcr(2) + pcl(1) = pcr(1) - duml + pcl(2) = c4*(uml - pcl(1)) - duml + pcl(3) = duml - pcl(2) + endif + + ! Find all intersections with piecewise parabola in the last half of + ! the source grid cell left of the edge. + do + if ((u_edge_grd(jg) - pcr(1))*u_sgn > c0) exit + xi = parabola_intersection(pcl, u_edge_grd(jg), & + rcss%u_eps, c1_2, c1) + x_edge_grd(jg) = rcss%rcgs%x_edge_src(js-1) & + + ( rcss%rcgs%x_edge_src(js ) & + - rcss%rcgs%x_edge_src(js-1))*xi + jg = jg + 1 + if (jg > ng) return + enddo + + ! Find all intersections with piecewise parabola in the first half of + ! the source grid cell right of the edge. + do + if ((u_edge_grd(jg) - umr)*u_sgn > c0) exit + xi = parabola_intersection(pcr, u_edge_grd(jg), & + rcss%u_eps, c0, c1_2) + 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 + + enddo outer + + ! Find possible intersections in the last half of the last source grid + ! cell. + js = ns + 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, c1_2, 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_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 + + ! --------------------------------------------------------------------------- + ! Public procedures. + ! --------------------------------------------------------------------------- + + function initialize_rcgs(rcgs) result(errstat) + ! --------------------------------------------------------------------------- + ! Initialize reconstruction grid data structure. + ! --------------------------------------------------------------------------- + + type(recon_grd_struct), intent(inout) :: rcgs + + integer :: errstat + + integer :: ij_size, allocstat + + ! Check requested reconstruction method and set the required order of + ! polynomials for the piecewise reconstruction. + select case (rcgs%method) + case (hor3map_pcm) + rcgs%p_ord = 0 + case (hor3map_plm) + rcgs%p_ord = 1 + case (hor3map_ppm) + rcgs%p_ord = 2 + case (hor3map_pqm) + rcgs%p_ord = 4 + case default + errstat = hor3map_invalid_method + return + end select + + ! Allocate data arrays. + + ij_size = (rcgs%i_ubound - rcgs%i_lbound + 1) & + *(rcgs%j_ubound - rcgs%j_lbound + 1) + + allocate(rcgs%x_eps_data(ij_size), & + rcgs%x_edge_src_data(rcgs%n_src+1,ij_size), & + rcgs%h_src_data(rcgs%n_src,ij_size), & + rcgs%hi_src_data(rcgs%n_src,ij_size), & + rcgs%src_dst_index_data(rcgs%n_src,ij_size), & + rcgs%n_src_actual_data(ij_size), & + rcgs%method_actual_data(ij_size), & + rcgs%prepared_data(ij_size), & + stat = allocstat) + if (allocstat /= 0) then + errstat = hor3map_failed_to_allocate_rcgs + return + endif +#ifdef DEBUG + rcgs%x_eps_data(:) = ieee_value(1._r8, ieee_signaling_nan) + rcgs%x_edge_src_data(:,:) = ieee_value(1._r8, ieee_signaling_nan) + rcgs%h_src_data(:,:) = ieee_value(1._r8, ieee_signaling_nan) + rcgs%hi_src_data(:,:) = ieee_value(1._r8, ieee_signaling_nan) + rcgs%src_dst_index_data(:,:) = - 9999 + rcgs%n_src_actual_data(:) = - 9999 + rcgs%method_actual_data(:) = - 9999 +#endif + + if (rcgs%method /= hor3map_pcm) then + allocate(rcgs%hci_src_data(rcgs%n_src,ij_size), & + stat = allocstat) + if (allocstat /= 0) then + errstat = hor3map_failed_to_allocate_rcgs + return + endif +#ifdef DEBUG + rcgs%hci_src_data(:,:) = ieee_value(1._r8, ieee_signaling_nan) +#endif + endif + + if (rcgs%method == hor3map_ppm .or. rcgs%method == hor3map_pqm) then + allocate(rcgs%src_dst_weight_data(rcgs%n_src,ij_size), & + rcgs%tdecoeff_data(rcgs%p_ord+2,rcgs%n_src,ij_size), & + rcgs%tdscoeff_data(rcgs%p_ord+2,rcgs%n_src,ij_size), & + rcgs%lblu_data(rcgs%p_ord+2,rcgs%p_ord+2,ij_size), & + rcgs%rblu_data(rcgs%p_ord+2,rcgs%p_ord+2,ij_size), & + stat = allocstat) + if (allocstat /= 0) then + errstat = hor3map_failed_to_allocate_rcgs + return + endif +#ifdef DEBUG + rcgs%src_dst_weight_data(:,:) = ieee_value(1._r8, ieee_signaling_nan) + rcgs%tdecoeff_data(:,:,:) = ieee_value(1._r8, ieee_signaling_nan) + rcgs%tdscoeff_data(:,:,:) = ieee_value(1._r8, ieee_signaling_nan) + rcgs%lblu_data(:,:,:) = ieee_value(1._r8, ieee_signaling_nan) + rcgs%rblu_data(:,:,:) = ieee_value(1._r8, ieee_signaling_nan) +#endif + endif + + rcgs%prepared_data(:) = .false. + rcgs%initialized = .true. + + errstat = hor3map_noerr + + end function initialize_rcgs + + function initialize_rcss(rcgs, rcss) result(errstat) + ! --------------------------------------------------------------------------- + ! Initialize reconstruction source data structure. + ! --------------------------------------------------------------------------- + + type(recon_grd_struct), target, intent(inout) :: rcgs + type(recon_src_struct), target, intent(inout) :: rcss + + integer :: errstat + + integer :: ij_size, allocstat + + ij_size = (rcgs%i_ubound - rcgs%i_lbound + 1) & + *(rcgs%j_ubound - rcgs%j_lbound + 1) + + allocate(rcss%u_src_data(rcgs%n_src,ij_size), & + rcss%uel_data(rcgs%n_src,ij_size), & + rcss%uer_data(rcgs%n_src,ij_size), & + rcss%polycoeff_data(rcgs%p_ord+1,rcgs%n_src,ij_size), & + rcss%reconstructed_data(ij_size), & + stat = allocstat) + if (allocstat /= 0) then + errstat = hor3map_failed_to_allocate_rcss + return + endif +#ifdef DEBUG + rcss%u_src_data(:,:) = ieee_value(1._r8, ieee_signaling_nan) + rcss%uel_data(:,:) = ieee_value(1._r8, ieee_signaling_nan) + rcss%uer_data(:,:) = ieee_value(1._r8, ieee_signaling_nan) + rcss%polycoeff_data(:,:,:) = ieee_value(1._r8, ieee_signaling_nan) +#endif + if (rcgs%method == hor3map_pqm) then + allocate(rcss%usl_data(rcgs%n_src,ij_size), & + rcss%usr_data(rcgs%n_src,ij_size), & + stat = allocstat) + if (allocstat /= 0) then + errstat = hor3map_failed_to_allocate_rcss + return + endif +#ifdef DEBUG + rcss%usl_data(:,:) = ieee_value(1._r8, ieee_signaling_nan) + rcss%usr_data(:,:) = ieee_value(1._r8, ieee_signaling_nan) +#endif + endif + + rcss%rcgs => rcgs + rcss%rcss_dep_next => rcgs%rcss_dep_head + rcgs%rcss_dep_head => rcss + rcss%reconstructed_data(:) = .false. + rcss%initialized = .true. + + errstat = hor3map_noerr + + end function initialize_rcss + + function initialize_rms(rcgs, rms) result(errstat) + ! --------------------------------------------------------------------------- + ! Initialize remapping data structure. + ! --------------------------------------------------------------------------- + + type(recon_grd_struct), target, intent(inout) :: rcgs + type(remap_struct), target, intent(inout) :: rms + + integer :: errstat + + integer :: ij_size, allocstat + + ij_size = (rcgs%i_ubound - rcgs%i_lbound + 1) & + *(rcgs%j_ubound - rcgs%j_lbound + 1) + + allocate(rms%h_dst_data(rms%n_dst,ij_size), & + rms%hi_dst_data(rms%n_dst,ij_size), & + rms%seg_int_lim_data(rcgs%n_src+rms%n_dst,ij_size), & + rms%n_src_seg_data(rcgs%n_src,ij_size), & + rms%seg_dst_index_data(rcgs%n_src+rms%n_dst,ij_size), & + rms%prepared_data(ij_size), & + stat = allocstat) + if (allocstat /= 0) then + errstat = hor3map_failed_to_allocate_rms + return + endif +#ifdef DEBUG + rms%h_dst_data(:,:) = ieee_value(1._r8, ieee_signaling_nan) + rms%hi_dst_data(:,:) = ieee_value(1._r8, ieee_signaling_nan) + rms%seg_int_lim_data(:,:) = ieee_value(1._r8, ieee_signaling_nan) + rms%n_src_seg_data(:,:) = - 9999 + rms%seg_dst_index_data(:,:) = - 9999 +#endif + + rms%rcgs => rcgs + rms%rms_dep_next => rcgs%rms_dep_head + rcgs%rms_dep_head => rms + rms%prepared_data(:) = .false. + rms%initialized = .true. + + errstat = hor3map_noerr + + end function initialize_rms + + function prepare_reconstruction(rcgs, x_edge_src, i_index, j_index) & + result(errstat) + ! --------------------------------------------------------------------------- + ! Prepare reconstruction based on edge locations of source grid cells and + ! requested reconstruction method. Reconstruction data is stored in a + ! reconstruction grid data structure. + ! --------------------------------------------------------------------------- + + type(recon_grd_struct), intent(inout) :: rcgs + real(r8), dimension(:), intent(in) :: x_edge_src + integer, optional, intent(in) :: i_index, j_index + + integer :: errstat + + integer :: n_src, j + + errstat = hor3map_noerr + + ! Check optional arguments. + if (present(i_index)) rcgs%i_index = i_index + if (present(j_index)) rcgs%j_index = j_index + + ! Number of source grid cells. + n_src = size(x_edge_src) - 1 + + ! Check that source grid edges are monotonically increasing or decreasing. + if (x_edge_src(n_src+1) - x_edge_src(1) > c0) then + do j = 1, n_src + if (x_edge_src(j+1) < x_edge_src(j)) then + errstat = hor3map_nonmonotonic_src_edges + return + endif + enddo + else + do j = 1, n_src + if (x_edge_src(j+1) > x_edge_src(j)) then + errstat = hor3map_nonmonotonic_src_edges + return + endif + enddo + endif + + ! If needed, initialize reconstruction grid data structure. + if (.not. rcgs%initialized) then + rcgs%n_src = n_src + errstat = initialize_rcgs(rcgs) + if (errstat /= hor3map_noerr) return + elseif (rcgs%n_src /= n_src) then + if (rcgs%i_lbound == 1 .and. rcgs%i_ubound == 1 .and. & + rcgs%j_lbound == 1 .and. rcgs%j_ubound == 1) then + call free_rcgs(rcgs) + rcgs%n_src = n_src + errstat = initialize_rcgs(rcgs) + if (errstat /= hor3map_noerr) return + else + errstat = hor3map_resizing_initialized_rcgs + return + endif + endif + + ! Assign array pointers within reconstruction grid data structure. + errstat = assign_ptr_rcgs(rcgs) + if (errstat /= hor3map_noerr) return + + rcgs%prepared = .false. + + ! Set small value with same dimensions as edge locations. + rcgs%x_eps = max(abs(x_edge_src(n_src+1) - x_edge_src(1)), eps)*eps + + ! Based on the requested reconstruction method, prepare the data structure + ! for the various methods. Arrays with indices and weights are + ! constructed that will map the source data to a continuous array of + ! grid cells that are non-empty and with widths that will ensure + ! condition numbers below a specified threshold of matrices in linear + ! equation systems to be solved. If insufficient grid cells are available + ! for the requested method, lower order methods are tried. + + rcgs%method_actual = rcgs%method + + if (rcgs%method_actual == hor3map_pqm) then + call prepare_pqm(rcgs, x_edge_src) + if (rcgs%n_src_actual < 6) then + rcgs%method_actual = hor3map_ppm + else + rcgs%method_actual = hor3map_pqm + endif + endif + + if (rcgs%method_actual == hor3map_ppm) then + call prepare_ppm(rcgs, x_edge_src) + if (rcgs%n_src_actual < 4) then + rcgs%method_actual = hor3map_plm + else + rcgs%method_actual = hor3map_ppm + endif + endif + + if (rcgs%method_actual == hor3map_plm) then + call prepare_plm(rcgs, x_edge_src) + if (rcgs%n_src_actual < 2) then + rcgs%method_actual = hor3map_pcm + else + rcgs%method_actual = hor3map_plm + endif + endif + + if (rcgs%method_actual == hor3map_pcm) then + call prepare_pcm(rcgs, x_edge_src) + if (rcgs%n_src_actual == 0) then + errstat = hor3map_src_extent_too_small + return + else + rcgs%method_actual = hor3map_pcm + endif + endif + + ! Set flag to indicate the reconstruction has been prepared. + rcgs%prepared = .true. + + end function prepare_reconstruction + + function prepare_remapping(rcgs, rms, x_edge_dst, i_index, j_index) & + result(errstat) + ! --------------------------------------------------------------------------- ! Prepare remapping based on a reconstruction data structure and edge ! locations of destination grid cells. Remapping data is stored in a remap ! data structure. ! --------------------------------------------------------------------------- - type(reconstruction_struct), intent(in) :: rcs + type(recon_grd_struct), target, intent(inout) :: rcgs real(r8), dimension(:), intent(in) :: x_edge_dst - type(remap_struct), intent(out) :: rms + type(remap_struct), intent(inout) :: rms + integer, optional, intent(in) :: i_index, j_index integer :: errstat real(r8) :: xil integer :: n_dst, j, js, jd, iseg - rms%prepared = .false. - errstat = hor3map_noerr + ! Check optional arguments. + if (present(i_index)) rcgs%i_index = i_index + if (present(j_index)) rcgs%j_index = j_index - ! Check that the reconstruction has been prepared. - if (.not. rcs%prepared) then + ! Check that the reconstruction grid data structure has been initialized. + if (.not. rcgs%initialized) then errstat = hor3map_recon_not_prepared return endif @@ -2082,56 +3926,75 @@ function prepare_remapping(rcs, x_edge_dst, rms) result(errstat) ! Number of destination grid cells. n_dst = size(x_edge_dst) - 1 + ! If needed, initialize remapping data structure. + if (.not. rms%initialized) then + rms%n_dst = n_dst + errstat = initialize_rms(rcgs, rms) + if (errstat /= hor3map_noerr) return + elseif (.not. associated(rms%rcgs, rcgs)) then + call free_rms(rms) + rms%n_dst = n_dst + errstat = initialize_rms(rcgs, rms) + if (errstat /= hor3map_noerr) return + elseif (rms%n_dst /= n_dst) then + if (rcgs%i_lbound == 1 .and. rcgs%i_ubound == 1 .and. & + rcgs%j_lbound == 1 .and. rcgs%j_ubound == 1) then + call free_rms(rms) + rms%n_dst = n_dst + errstat = initialize_rms(rcgs, rms) + if (errstat /= hor3map_noerr) return + else + errstat = hor3map_resizing_initialized_rms + return + endif + endif + + ! Assign array pointers within reconstruction grid and source + ! data structures. + errstat = assign_ptr_rcgs(rms%rcgs) + if (errstat /= hor3map_noerr) return + errstat = assign_ptr_rms(rms) + if (errstat /= hor3map_noerr) return + + ! Check that the reconstruction has been prepared. + if (.not. rcgs%prepared) then + errstat = hor3map_recon_not_prepared + return + endif + + rms%prepared = .false. + ! Check for consistency between the source and destination grid range. - if (abs( rcs%x_edge_src(1) - x_edge_dst(1)) > rcs%x_eps .or. & - abs( rcs%x_edge_src(rcs%n_src + 1) & - - x_edge_dst(n_dst + 1)) > rcs%x_eps) then + if (abs(rcgs%x_edge_src(1) - x_edge_dst(1)) > rcgs%x_eps .or. & + abs(rcgs%x_edge_src(rcgs%n_src_actual+1) - x_edge_dst(n_dst+1)) & + > rcgs%x_eps) then errstat = hor3map_inconsistent_grid_range return endif ! Check that destination grid edges are monotonically increasing or ! decreasing. - if (x_edge_dst(n_dst + 1) - x_edge_dst(1) > c0) then + if (x_edge_dst(n_dst+1) - x_edge_dst(1) > c0) then do j = 1, n_dst - if (x_edge_dst(j + 1) < x_edge_dst(j)) then + if (x_edge_dst(j+1) < x_edge_dst(j)) then errstat = hor3map_nonmonotonic_dst_edges return endif enddo else do j = 1, n_dst - if (x_edge_dst(j + 1) > x_edge_dst(j)) then + if (x_edge_dst(j+1) > x_edge_dst(j)) then errstat = hor3map_nonmonotonic_dst_edges return endif enddo endif - ! If needed, allocate arrays in remap data structure. - if (.not. rms%alloced) then - rms%n_dst = n_dst - errstat = allocate_rms(rcs, rms) - if (errstat /= hor3map_noerr) return - elseif (rms%n_dst /= n_dst) then - call free_rms(rms) - rms%n_dst = n_dst - errstat = allocate_rms(rcs, rms) - if (errstat /= hor3map_noerr) return - endif -#ifdef DEBUG - rms%h_dst(:) = ieee_value(1._r8, ieee_signaling_nan) - rms%hi_dst(:) = ieee_value(1._r8, ieee_signaling_nan) - rms%seg_int_lim(:) = ieee_value(1._r8, ieee_signaling_nan) - rms%n_src_seg(:) = -9999 - rms%seg_dst_index(:) = -9999 -#endif - ! From edge locations, obtain destination grid cell widths and their ! multiplicative inverse. do j = 1, rms%n_dst - rms%h_dst(j) = abs(x_edge_dst(j + 1) - x_edge_dst(j)) - if (rms%h_dst(j) > rcs%x_eps) then + rms%h_dst(j) = abs(x_edge_dst(j+1) - x_edge_dst(j)) + if (rms%h_dst(j) > rcgs%x_eps) then rms%hi_dst(j) = c1/rms%h_dst(j) else rms%hi_dst(j) = c0 @@ -2151,25 +4014,25 @@ function prepare_remapping(rcs, x_edge_dst, rms) result(errstat) rms%n_src_seg(js) = 0 xil = c0 - if (x_edge_dst(n_dst + 1) - x_edge_dst(1) > c0) then + if (x_edge_dst(n_dst+1) - x_edge_dst(1) > c0) then do iseg = iseg + 1 rms%n_src_seg(js) = rms%n_src_seg(js) + 1 rms%seg_dst_index(iseg) = jd - if ( abs(rcs%x_edge_src(js + 1) - x_edge_dst(jd + 1)) & - <= rcs%x_eps) then + if ( abs(rcgs%x_edge_src(js+1) - x_edge_dst(jd+1)) & + <= rcgs%x_eps) then if (rms%hi_dst(jd) == c0) then rms%seg_int_lim(iseg) = xil else rms%seg_int_lim(iseg) = c1 endif - if (js == rcs%n_src) exit + if (js == rcgs%n_src_actual) exit xil = c0 js = js + 1 jd = jd + 1 rms%n_src_seg(js) = 0 - elseif (rcs%x_edge_src(js + 1) < x_edge_dst(jd + 1)) then + elseif (rcgs%x_edge_src(js+1) < x_edge_dst(jd+1)) then rms%seg_int_lim(iseg) = c1 xil = c0 js = js + 1 @@ -2179,7 +4042,7 @@ function prepare_remapping(rcs, x_edge_dst, rms) result(errstat) rms%seg_int_lim(iseg) = xil else rms%seg_int_lim(iseg) = & - (x_edge_dst(jd + 1) - rcs%x_edge_src(js))*rcs%hi_src(js) + (x_edge_dst(jd+1) - rcgs%x_edge_src(js))*rcgs%hi_src(js) xil = rms%seg_int_lim(iseg) endif jd = jd + 1 @@ -2192,19 +4055,19 @@ function prepare_remapping(rcs, x_edge_dst, rms) result(errstat) iseg = iseg + 1 rms%n_src_seg(js) = rms%n_src_seg(js) + 1 rms%seg_dst_index(iseg) = jd - if ( abs(rcs%x_edge_src(js + 1) - x_edge_dst(jd + 1)) & - <= rcs%x_eps) then + if ( abs(rcgs%x_edge_src(js+1) - x_edge_dst(jd+1)) & + <= rcgs%x_eps) then if (rms%hi_dst(jd) == c0) then rms%seg_int_lim(iseg) = xil else rms%seg_int_lim(iseg) = c1 endif - if (js == rcs%n_src) exit + if (js == rcgs%n_src_actual) exit xil = c0 js = js + 1 jd = jd + 1 rms%n_src_seg(js) = 0 - elseif (rcs%x_edge_src(js + 1) > x_edge_dst(jd + 1)) then + elseif (rcgs%x_edge_src(js+1) > x_edge_dst(jd+1)) then rms%seg_int_lim(iseg) = c1 xil = c0 js = js + 1 @@ -2214,7 +4077,7 @@ function prepare_remapping(rcs, x_edge_dst, rms) result(errstat) rms%seg_int_lim(iseg) = xil else rms%seg_int_lim(iseg) = & - (rcs%x_edge_src(js) - x_edge_dst(jd + 1))*rcs%hi_src(js) + (rcgs%x_edge_src(js) - x_edge_dst(jd+1))*rcgs%hi_src(js) xil = rms%seg_int_lim(iseg) endif jd = jd + 1 @@ -2227,141 +4090,369 @@ function prepare_remapping(rcs, x_edge_dst, rms) result(errstat) end function prepare_remapping - function reconstruct(rcs, u_src, limiting, pc_left_bndr, pc_right_bndr) & - result(errstat) + function reconstruct(rcgs, rcss, u_src, i_index, j_index) result(errstat) ! --------------------------------------------------------------------------- ! Carry out the piecewise polynomial reconstruction of the source data with ! desired limiting method and handling of boundaries. ! --------------------------------------------------------------------------- - type(reconstruction_struct), intent(inout) :: rcs + type(recon_grd_struct), target, intent(inout) :: rcgs real(r8), dimension(:), intent(in) :: u_src - integer, intent(in) :: limiting - logical, optional, intent(in) :: pc_left_bndr, pc_right_bndr + type(recon_src_struct), intent(inout) :: rcss + integer, optional, intent(in) :: i_index, j_index integer :: errstat integer :: js, jd - logical :: pclb, pcrb - - errstat = hor3map_noerr - ! Check optional arguments that controls whether left and right boundary - ! cells are reconstructed as piecewise constants or not. - if (present(pc_left_bndr) .and. present(pc_right_bndr)) then - pclb = pc_left_bndr - pcrb = pc_right_bndr - elseif (present(pc_left_bndr)) then - pclb = pc_left_bndr - pcrb = pclb - else - pclb = .true. - pcrb = .true. - endif + ! Check optional arguments. + if (present(i_index)) rcgs%i_index = i_index + if (present(j_index)) rcgs%j_index = j_index - ! Check that the reconstruction has been prepared. - if (.not. rcs%prepared) then + ! Check that the reconstruction grid data structure has been initialized. + if (.not. rcgs%initialized) then errstat = hor3map_recon_not_prepared return endif - if (size(u_src) /= rcs%n_src_all) then + ! Check consistency of number of source grid cells. + if (size(u_src) /= rcgs%n_src) then errstat = hor3map_src_size_mismatch return endif + ! If needed, initialize reconstruction source data structure. + if (.not. rcss%initialized) then + errstat = initialize_rcss(rcgs, rcss) + if (errstat /= hor3map_noerr) return + elseif (.not. associated(rcss%rcgs, rcgs)) then + call free_rcss(rcss) + errstat = initialize_rcss(rcgs, rcss) + if (errstat /= hor3map_noerr) return + endif + + ! Assign array pointers within reconstruction grid and source data + ! structures. + errstat = assign_ptr_rcgs(rcgs) + if (errstat /= hor3map_noerr) return + errstat = assign_ptr_rcss(rcss) + if (errstat /= hor3map_noerr) return + + ! Check that the reconstruction has been prepared. + if (.not. rcgs%prepared) then + errstat = hor3map_recon_not_prepared + return + endif + ! Copy source data array to continuous array of grid cells to be used in ! the reconstruction. - if (rcs%method == hor3map_pcm .or. rcs%method == hor3map_plm) then - do js = 1, rcs%n_src_all - jd = rcs%src_dst_index(js) - if (jd /= 0) rcs%u_src(jd) = u_src(js) + if (rcgs%method_actual == hor3map_pcm .or. & + rcgs%method_actual == hor3map_plm) then + do js = 1, rcgs%n_src + jd = rcgs%src_dst_index(js) + if (jd /= 0) rcss%u_src(jd) = u_src(js) enddo else - rcs%u_src(1:rcs%n_src) = c0 - do js = 1, rcs%n_src_all - jd = rcs%src_dst_index(js) - if (jd /= 0) rcs%u_src(jd) = rcs%u_src(jd) & - + rcs%src_dst_weight(js)*u_src(js) + rcss%u_src(1:rcgs%n_src_actual) = c0 + do js = 1, rcgs%n_src + jd = rcgs%src_dst_index(js) + if (jd /= 0) rcss%u_src(jd) = rcss%u_src(jd) & + + rcgs%src_dst_weight(js)*u_src(js) enddo endif - select case (rcs%method) + ! Set small value with same dimensions as source data. + rcss%u_range = abs( minval(rcss%u_src(1:rcgs%n_src_actual)) & + - maxval(rcss%u_src(1:rcgs%n_src_actual))) + rcss%u_eps = rcss%u_range*eps + rcss%uu_eps = rcss%u_range*rcss%u_eps + + + select case (rcgs%method_actual) case (hor3map_plm) - select case (limiting) + select case (rcss%limiting) case (hor3map_no_limiting) - call reconstruct_plm_no_limiting(rcs) - case (hor3map_monotonic) - call reconstruct_plm_monotonic(rcs, pclb, pcrb) + call reconstruct_plm_no_limiting(rcss) + case (hor3map_monotonic, hor3map_non_oscillatory, & + hor3map_non_oscillatory_posdef) + call reconstruct_plm_monotonic(rcss) case default errstat = hor3map_invalid_plm_limiting return end select case (hor3map_ppm) - call reconstruct_ppm_edge_values(rcs) - select case (limiting) + call reconstruct_ppm_edge_values(rcss) + select case (rcss%limiting) case (hor3map_no_limiting) case (hor3map_monotonic) - call limit_ppm_interior_monotonic(rcs) - call limit_ppm_boundary(rcs, pclb, pcrb) + call limit_ppm_interior_monotonic(rcss) + call limit_ppm_boundary(rcss) case (hor3map_non_oscillatory) - call limit_ppm_interior_non_oscillatory(rcs) - call limit_ppm_boundary(rcs, pclb, pcrb) + call limit_ppm_interior_non_oscillatory(rcss) + call limit_ppm_boundary(rcss) case (hor3map_non_oscillatory_posdef) - call limit_ppm_interior_non_oscillatory(rcs) - call limit_ppm_boundary(rcs, pclb, pcrb) - call limit_ppm_posdef(rcs) + call limit_ppm_interior_non_oscillatory(rcss) + call limit_ppm_boundary(rcss) + call limit_ppm_posdef(rcss) case default errstat = hor3map_invalid_ppm_limiting return end select - call polycoeff_ppm(rcs) + call polycoeff_ppm(rcss) case (hor3map_pqm) - call reconstruct_pqm_edge_slope_values(rcs) - select case (limiting) + call reconstruct_pqm_edge_slope_values(rcss) + select case (rcss%limiting) case (hor3map_no_limiting) + case (hor3map_monotonic) + call limit_pqm_monotonic(rcss) + case (hor3map_non_oscillatory) + call limit_pqm_non_oscillatory(rcss) + case (hor3map_non_oscillatory_posdef) + call limit_pqm_non_oscillatory_posdef(rcss) case default errstat = hor3map_invalid_pqm_limiting return end select - call polycoeff_pqm(rcs) + call polycoeff_pqm(rcss) end select - rcs%reconstructed = .true. + rcss%reconstructed = .true. end function reconstruct - function regrid(rcs, u_edge_grd, x_edge_grd, missing_value) result(errstat) + function extract_polycoeff(rcss, polycoeff, i_index, j_index) result(errstat) + ! --------------------------------------------------------------------------- + ! Extract polynomial coefficients of a reconstruction. For grid cells that + ! have been merged due to potential for ill-conditioned linear systems, + ! polynomial coefficients will be constructed that are consistent with the + ! reconstruction of the merged cells. Near-empty grid cells are set to a + ! constant reconstruction. + ! --------------------------------------------------------------------------- + + type(recon_src_struct), intent(inout) :: rcss + real(r8), dimension(:,:), intent(out) :: polycoeff + integer, optional, intent(in) :: i_index, j_index + + integer :: errstat + + real(r8) :: xi0, q + integer :: js0, js, jd + + ! Check that reconstruction source data structure has been initialized. + if (.not. rcss%initialized) then + errstat = hor3map_recon_not_available + return + 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 + 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 + + ! Extract polynomial coefficients. + + polycoeff(:,:) = c0 + + select case (rcss%rcgs%method_actual) + + case (hor3map_pcm) + + js0 = 1 + do + jd = rcss%rcgs%src_dst_index(js0) + if (jd == 0) then + polycoeff(1,js0) = rcss%u_src(1) + else + polycoeff(1,js0) = rcss%u_src(jd) + exit + endif + js0 = js0 + 1 + if (js0 > rcss%rcgs%n_src) exit + enddo + do js = js0+1, rcss%rcgs%n_src + jd = rcss%rcgs%src_dst_index(js) + if (jd == 0) then + polycoeff(1,js) = polycoeff(1,js-1) + else + polycoeff(1,js) = rcss%u_src(jd) + endif + enddo + + case (hor3map_plm) + + js0 = 1 + do + jd = rcss%rcgs%src_dst_index(js0) + if (jd == 0) then + polycoeff(1,js0) = rcss%polycoeff(1,1) + else + polycoeff(1:2,js0) = rcss%polycoeff(1:2,1) + exit + endif + js0 = js0 + 1 + if (js0 > rcss%rcgs%n_src) exit + enddo + do js = js0+1, rcss%rcgs%n_src + jd = rcss%rcgs%src_dst_index(js) + if (jd == 0) then + polycoeff(1,js) = polycoeff(1,js-1) + polycoeff(2,js-1) + else + polycoeff(1:2,js) = rcss%polycoeff(1:2,jd) + endif + enddo + + case (hor3map_ppm) + + js0 = 1 + do + jd = rcss%rcgs%src_dst_index(js0) + if (jd == 0) then + polycoeff(1,js0) = rcss%polycoeff(1,1) + else + exit + endif + js0 = js0 + 1 + if (js0 > rcss%rcgs%n_src) exit + enddo + xi0 = c0 + do js = js0, rcss%rcgs%n_src + jd = rcss%rcgs%src_dst_index(js) + if (jd == 0) then + polycoeff(1,js) = polycoeff(1,js-1) & + + polycoeff(2,js-1) & + + polycoeff(3,js-1) + else + if (rcss%rcgs%src_dst_weight(js) == c1) then + polycoeff(1:3,js) = rcss%polycoeff(1:3,jd) + xi0 = c0 + else + polycoeff(1,js) = rcss%polycoeff(1,jd) & + + ( rcss%polycoeff(2,jd) & + + rcss%polycoeff(3,jd)*xi0)*xi0 + polycoeff(2,js) = ( rcss%polycoeff(2,jd) & + + c2*rcss%polycoeff(3,jd)*xi0) & + *rcss%rcgs%src_dst_weight(js) + polycoeff(3,js) = rcss%polycoeff(3,jd) & + *rcss%rcgs%src_dst_weight(js) & + *rcss%rcgs%src_dst_weight(js) + xi0 = xi0 + rcss%rcgs%src_dst_weight(js) + endif + endif + enddo + + case (hor3map_pqm) + + js0 = 1 + do + jd = rcss%rcgs%src_dst_index(js0) + if (jd == 0) then + polycoeff(1,js0) = rcss%polycoeff(1,1) + else + exit + endif + js0 = js0 + 1 + if (js0 > rcss%rcgs%n_src) exit + enddo + xi0 = c0 + do js = js0, rcss%rcgs%n_src + jd = rcss%rcgs%src_dst_index(js) + if (jd == 0) then + polycoeff(1,js) = polycoeff(1,js-1) & + + polycoeff(2,js-1) & + + polycoeff(3,js-1) & + + polycoeff(4,js-1) & + + polycoeff(5,js-1) + else + if (rcss%rcgs%src_dst_weight(js) == c1) then + polycoeff(1:5,js) = rcss%polycoeff(1:5,jd) + xi0 = c0 + else + polycoeff(1,js) = rcss%polycoeff(1,jd) & + + ( rcss%polycoeff(2,jd) & + + ( rcss%polycoeff(3,jd) & + + ( rcss%polycoeff(4,jd) & + + rcss%polycoeff(5,jd) & + *xi0)*xi0)*xi0)*xi0 + q = rcss%rcgs%src_dst_weight(js) + polycoeff(2,js) = ( rcss%polycoeff(2,jd) & + + ( c2*rcss%polycoeff(3,jd) & + + ( c3*rcss%polycoeff(4,jd) & + + c4*rcss%polycoeff(5,jd) & + *xi0)*xi0)*xi0)*q + q = q*rcss%rcgs%src_dst_weight(js) + polycoeff(3,js) = ( rcss%polycoeff(3,jd) & + + ( c3*rcss%polycoeff(4,jd) & + + c6*rcss%polycoeff(5,jd) & + *xi0)*xi0)*q + q = q*rcss%rcgs%src_dst_weight(js) + polycoeff(4,js) = ( rcss%polycoeff(4,jd) & + + c4*rcss%polycoeff(5,jd)*xi0)*q + q = q*rcss%rcgs%src_dst_weight(js) + polycoeff(5,js) = rcss%polycoeff(5,jd)*q + xi0 = xi0 + rcss%rcgs%src_dst_weight(js) + endif + endif + enddo + + end select + + end function extract_polycoeff + + function regrid(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(reconstruction_struct), intent(in) :: rcs + 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), dimension(3) :: pcl, pcr - real(r8) :: u_min, u_max, u_eps, u_sgn, umr, uml, xi, & - duml, dumr, uerl, uelr - integer :: n_grd, jg, js + real(r8) :: u_sgn errstat = hor3map_noerr - ! Check that the reconstruction is available. - if (.not. rcs%reconstructed) then + ! Check that reconstruction source data structure has been initialized. + if (.not. rcss%initialized) then errstat = hor3map_recon_not_available return endif - ! Number of grid edges. - n_grd = size(u_edge_grd) + ! 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) /= n_grd) then + if (size(x_edge_grd) /= size(u_edge_grd)) then errstat = hor3map_grd_size_mismatch return endif @@ -2370,144 +4461,146 @@ function regrid(rcs, u_edge_grd, x_edge_grd, missing_value) result(errstat) x_edge_grd(:) = missing_value ! Return in case PCM method is used. - if (rcs%method == hor3map_pcm) return + if (rcss%rcgs%method_actual == hor3map_pcm) return - ! Set small value with same dimensions as source data. - u_min = minval(rcs%u_src(1:rcs%n_src)) - u_max = maxval(rcs%u_src(1:rcs%n_src)) - if (abs(u_max - u_min) < eps) then - return - endif - u_eps = abs(u_max - u_min)*eps + ! 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, rcs%u_src(rcs%n_src) - rcs%u_src(1)) + u_sgn = sign(c1, rcss%u_src(rcss%rcgs%n_src_actual) - rcss%u_src(1)) - ! Find possible intersections in the first half of the first source grid - ! cell. - jg = 1 - do - if ((u_edge_grd(jg) - rcs%uel(1))*u_sgn >= c0) exit - jg = jg + 1 - if (jg > n_grd) return - enddo - js = 1 - umr = rcs%polycoeff(1, js) & - + c1_2*rcs%polycoeff(2, js) & - + c1_4*rcs%polycoeff(3, js) - do - if ((u_edge_grd(jg) - umr)*u_sgn > c0) exit - xi = parabola_intersection(rcs%polycoeff(:, js), u_edge_grd(jg), & - u_eps, c0, c1_2) - x_edge_grd(jg) = rcs%x_edge_src(js) & - + (rcs%x_edge_src(js + 1) - rcs%x_edge_src(js))*xi - jg = jg + 1 - if (jg > n_grd) return - enddo + 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 - outer: do + end function regrid - ! For the current grid edge index, find the index of the first source - ! grid cell with mid point reconstructed value larger than the grid - ! edge value. - do - uml = umr - umr = rcs%polycoeff(1, js) & - + c1_2*rcs%polycoeff(2, js) & - + c1_4*rcs%polycoeff(3, js) - if ((u_edge_grd(jg) - umr)*u_sgn <= c0) exit - js = js + 1 - if (js > rcs%n_src) exit outer - enddo + 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. + ! --------------------------------------------------------------------------- - ! 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 - ! respective grid cells. - duml = rcs%polycoeff(2, js - 1) + rcs%polycoeff(3, js - 1) - dumr = rcs%polycoeff(2, js ) + rcs%polycoeff(3, js ) - pcr(2) = (c4*(umr - uml) - duml - dumr) & - *rcs%h_src(js)/(rcs%h_src(js - 1) + rcs%h_src(js)) - pcr(1) = umr - c1_4*(dumr + pcr(2)) - if (pcr(2)*(rcs%u_src(js) - rcs%u_src(js - 1)) < c0) then - ! 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 - ! is then not guaranteed. - pcr(2) = c0 - uerl = rcs%uer(js - 1) - uelr = rcs%uel(js) - pcr(1) = min(max(pcr(1), min(uerl, uelr)), max(uerl, uelr)) - pcr(3) = c4*(umr - pcr(1)) - pcl(1) = c4*uml - c3*pcr(1) - pcl(2) = c2*(pcr(1) - pcl(1)) - pcl(3) = - c1_2*pcl(2) - else - pcr(3) = dumr - pcr(2) - pcl(1) = pcr(1) - duml - pcl(2) = c4*(uml - pcl(1)) - duml - pcl(3) = duml - pcl(2) - endif + 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 - ! Find all intersections with piecewise parabola in the last half of - ! the source grid cell left of the edge. - do - if ((u_edge_grd(jg) - pcr(1))*u_sgn > c0) exit - xi = parabola_intersection(pcl, u_edge_grd(jg), u_eps, c1_2, c1) - x_edge_grd(jg) = rcs%x_edge_src(js - 1) & - + (rcs%x_edge_src(js) - rcs%x_edge_src(js - 1))*xi - jg = jg + 1 - if (jg > n_grd) return - enddo + integer :: errstat - ! Find all intersections with piecewise parabola in the first half of - ! the source grid cell right of the edge. - do - if ((u_edge_grd(jg) - umr)*u_sgn > c0) exit - xi = parabola_intersection(pcr, u_edge_grd(jg), u_eps, c0, c1_2) - x_edge_grd(jg) = rcs%x_edge_src(js) & - + (rcs%x_edge_src(js + 1) - rcs%x_edge_src(js))*xi - jg = jg + 1 - if (jg > n_grd) return - enddo + real(r8) :: u_sgn, ue_min, ue_max - enddo outer + errstat = hor3map_noerr - ! Find possible intersections in the last half of the last source grid - ! cell. - js = rcs%n_src - do - if ((u_edge_grd(jg) - rcs%uer(js))*u_sgn > c0) return - xi = parabola_intersection(rcs%polycoeff(:, js), u_edge_grd(jg), & - u_eps, c1_2, c1) - x_edge_grd(jg) = rcs%x_edge_src(js) & - + (rcs%x_edge_src(js + 1) - rcs%x_edge_src(js))*xi - jg = jg + 1 - if (jg > n_grd) return - enddo + ! Check that reconstruction source data structure has been initialized. + if (.not. rcss%initialized) then + errstat = hor3map_recon_not_available + return + endif - end function regrid + ! 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)) - function remap(rcs, rms, u_dst) result(errstat) + 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 + + end function regrid2 + + function remap(rcss, rms, u_dst, i_index, j_index) result(errstat) ! --------------------------------------------------------------------------- ! Carry out the remapping of a piecewise polynomial reconstruction of the ! source data to a destination grid. ! --------------------------------------------------------------------------- - type(reconstruction_struct), intent(in) :: rcs - type(remap_struct), intent(in) :: rms + type(recon_src_struct), intent(inout) :: rcss + type(remap_struct), intent(inout) :: rms real(r8), dimension(:), intent(out) :: u_dst + integer, optional, intent(in) :: i_index, j_index integer :: errstat real(r8) :: xil, xir, adl, adr - integer :: iseg, js, jd, i_src_seg + integer :: ns, iseg, js, jd, i_src_seg errstat = hor3map_noerr + ! Check that reconstruction source data structure has been initialized. + if (.not. rcss%initialized) then + errstat = hor3map_recon_not_available + return + endif + + ! Check optional arguments. + if (present(i_index)) rcss%rcgs%i_index = i_index + if (present(j_index)) rcss%rcgs%j_index = j_index + + ! Check that remapping data structure has been initialized. + if (.not. rms%initialized) then + errstat = hor3map_remap_not_prepared + return + endif + + ! Check that data structures have consistent associations. + if (.not. associated(rcss%rcgs, rms%rcgs)) then + errstat = hor3map_inconsistent_rcgs + return + endif + + ! 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 + errstat = assign_ptr_rms(rms) + if (errstat /= hor3map_noerr) return + ! Check that the remapping has been prepared if (.not. rms%prepared) then errstat = hor3map_remap_not_prepared @@ -2515,7 +4608,7 @@ function remap(rcs, rms, u_dst) result(errstat) endif ! Check that the reconstruction is available. - if (.not. rcs%reconstructed) then + if (.not. rcss%reconstructed) then errstat = hor3map_recon_not_available return endif @@ -2526,21 +4619,22 @@ function remap(rcs, rms, u_dst) result(errstat) endif u_dst(:) = 0._r8 + ns = rcss%rcgs%n_src_actual iseg = 0 - select case (rcs%method) + select case (rcss%rcgs%method_actual) case (hor3map_pcm) ! Integrate the required segments of each source grid cell in ! succession, adding the integrals to the appropriate destination ! grid cells. - do js = 1, rcs%n_src + do js = 1, ns if (rms%n_src_seg(js) == 1) then iseg = iseg + 1 jd = rms%seg_dst_index(iseg) u_dst(jd) = u_dst(jd) & - + rcs%u_src(js)*rcs%h_src(js)*rms%hi_dst(jd) + + rcss%u_src(js)*rcss%rcgs%h_src(js)*rms%hi_dst(jd) else xil = c0 do i_src_seg = 1, rms%n_src_seg(js) @@ -2548,11 +4642,11 @@ function remap(rcs, rms, u_dst) result(errstat) xir = rms%seg_int_lim(iseg) jd = rms%seg_dst_index(iseg) if (xil == xir) then - u_dst(jd) = rcs%u_src(js) + u_dst(jd) = rcss%u_src(js) else u_dst(jd) = u_dst(jd) & - + rcs%u_src(js)*(xir - xil)*rcs%h_src(js) & - *rms%hi_dst(jd) + + rcss%u_src(js)*(xir - xil) & + *rcss%rcgs%h_src(js)*rms%hi_dst(jd) xil = xir endif enddo @@ -2561,11 +4655,11 @@ function remap(rcs, rms, u_dst) result(errstat) ! Set values for any near-empty destination grid cells at the start ! and the end of the array. - do jd = 1, rms%seg_dst_index(1) - 1 - u_dst(jd) = rcs%u_src(1) + do jd = 1, rms%seg_dst_index(1)-1 + u_dst(jd) = rcss%u_src(1) enddo - do jd = rms%seg_dst_index(iseg) + 1, rms%n_dst - u_dst(jd) = rcs%u_src(rcs%n_src) + do jd = rms%seg_dst_index(iseg)+1, rms%n_dst + u_dst(jd) = rcss%u_src(ns) enddo case (hor3map_plm) @@ -2573,12 +4667,12 @@ function remap(rcs, rms, u_dst) result(errstat) ! Integrate the required segments of each source grid cell in ! succession, adding the integrals to the appropriate destination ! grid cells. - do js = 1, rcs%n_src + do js = 1, ns if (rms%n_src_seg(js) == 1) then iseg = iseg + 1 jd = rms%seg_dst_index(iseg) u_dst(jd) = u_dst(jd) & - + rcs%u_src(js)*rcs%h_src(js)*rms%hi_dst(jd) + + rcss%u_src(js)*rcss%rcgs%h_src(js)*rms%hi_dst(jd) else xil = c0 adl = c0 @@ -2587,13 +4681,14 @@ function remap(rcs, rms, u_dst) result(errstat) xir = rms%seg_int_lim(iseg) jd = rms%seg_dst_index(iseg) if (xil == xir) then - u_dst(jd) = rcs%polycoeff(1, js) & - + rcs%polycoeff(2, js)*xir + u_dst(jd) = rcss%polycoeff(1,js) & + + rcss%polycoeff(2,js)*xir else - adr = ( rcs%polycoeff(1, js) & - + c1_2*rcs%polycoeff(2, js)*xir)*xir + adr = ( rcss%polycoeff(1,js) & + + c1_2*rcss%polycoeff(2,js)*xir)*xir u_dst(jd) = u_dst(jd) & - + (adr - adl)*rcs%h_src(js)*rms%hi_dst(jd) + + (adr - adl)*rcss%rcgs%h_src(js) & + *rms%hi_dst(jd) xil = xir adl = adr endif @@ -2603,15 +4698,14 @@ function remap(rcs, rms, u_dst) result(errstat) ! Set values for any near-empty destination grid cells at the start ! and the end of the array. - do jd = 1, rms%seg_dst_index(1) - 1 - u_dst(jd) = rcs%polycoeff(1, 1) + do jd = 1, rms%seg_dst_index(1)-1 + u_dst(jd) = rcss%polycoeff(1,1) enddo if (rms%seg_dst_index(iseg) < rms%n_dst) then jd = rms%seg_dst_index(iseg) + 1 - u_dst(jd) = rcs%polycoeff(1, rcs%n_src) & - + rcs%polycoeff(2, rcs%n_src) - do jd = rms%seg_dst_index(iseg) + 2, rms%n_dst - u_dst(jd) = u_dst(rms%seg_dst_index(iseg) + 1) + u_dst(jd) = rcss%polycoeff(1,ns) + rcss%polycoeff(2,ns) + do jd = rms%seg_dst_index(iseg)+2, rms%n_dst + u_dst(jd) = u_dst(rms%seg_dst_index(iseg)+1) enddo endif @@ -2620,12 +4714,12 @@ function remap(rcs, rms, u_dst) result(errstat) ! Integrate the required segments of each source grid cell in ! succession, adding the integrals to the appropriate destination ! grid cells. - do js = 1, rcs%n_src + do js = 1, ns if (rms%n_src_seg(js) == 1) then iseg = iseg + 1 jd = rms%seg_dst_index(iseg) u_dst(jd) = u_dst(jd) & - + rcs%u_src(js)*rcs%h_src(js)*rms%hi_dst(jd) + + rcss%u_src(js)*rcss%rcgs%h_src(js)*rms%hi_dst(jd) else xil = c0 adl = c0 @@ -2634,15 +4728,16 @@ function remap(rcs, rms, u_dst) result(errstat) xir = rms%seg_int_lim(iseg) jd = rms%seg_dst_index(iseg) if (xil == xir) then - u_dst(jd) = rcs%polycoeff(1, js) & - + ( rcs%polycoeff(2, js) & - + rcs%polycoeff(3, js)*xir)*xir + u_dst(jd) = rcss%polycoeff(1,js) & + + ( rcss%polycoeff(2,js) & + + rcss%polycoeff(3,js)*xir)*xir else - adr = ( rcs%polycoeff(1, js) & - + ( c1_2*rcs%polycoeff(2, js) & - + c1_3*rcs%polycoeff(3, js)*xir)*xir)*xir + adr = ( rcss%polycoeff(1,js) & + + ( c1_2*rcss%polycoeff(2,js) & + + c1_3*rcss%polycoeff(3,js)*xir)*xir)*xir u_dst(jd) = u_dst(jd) & - + (adr - adl)*rcs%h_src(js)*rms%hi_dst(jd) + + (adr - adl)*rcss%rcgs%h_src(js) & + *rms%hi_dst(jd) xil = xir adl = adr endif @@ -2652,16 +4747,15 @@ function remap(rcs, rms, u_dst) result(errstat) ! Set values for any near-empty destination grid cells at the start ! and the end of the array. - do jd = 1, rms%seg_dst_index(1) - 1 - u_dst(jd) = rcs%polycoeff(1, 1) + do jd = 1, rms%seg_dst_index(1)-1 + u_dst(jd) = rcss%polycoeff(1,1) enddo if (rms%seg_dst_index(iseg) < rms%n_dst) then jd = rms%seg_dst_index(iseg) + 1 - u_dst(jd) = rcs%polycoeff(1, rcs%n_src) & - + rcs%polycoeff(2, rcs%n_src) & - + rcs%polycoeff(3, rcs%n_src) - do jd = rms%seg_dst_index(iseg) + 2, rms%n_dst - u_dst(jd) = u_dst(rms%seg_dst_index(iseg) + 1) + u_dst(jd) = rcss%polycoeff(1,ns) + rcss%polycoeff(2,ns) & + + rcss%polycoeff(3,ns) + do jd = rms%seg_dst_index(iseg)+2, rms%n_dst + u_dst(jd) = u_dst(rms%seg_dst_index(iseg)+1) enddo endif @@ -2670,12 +4764,12 @@ function remap(rcs, rms, u_dst) result(errstat) ! Integrate the required segments of each source grid cell in ! succession, adding the integrals to the appropriate destination ! grid cells. - do js = 1, rcs%n_src + do js = 1, ns if (rms%n_src_seg(js) == 1) then iseg = iseg + 1 jd = rms%seg_dst_index(iseg) u_dst(jd) = u_dst(jd) & - + rcs%u_src(js)*rcs%h_src(js)*rms%hi_dst(jd) + + rcss%u_src(js)*rcss%rcgs%h_src(js)*rms%hi_dst(jd) else xil = c0 adl = c0 @@ -2684,21 +4778,22 @@ function remap(rcs, rms, u_dst) result(errstat) xir = rms%seg_int_lim(iseg) jd = rms%seg_dst_index(iseg) if (xil == xir) then - u_dst(jd) = rcs%polycoeff(1, js) & - + ( rcs%polycoeff(2, js) & - + ( rcs%polycoeff(3, js) & - + ( rcs%polycoeff(4, js) & - + rcs%polycoeff(5, js) & + u_dst(jd) = rcss%polycoeff(1,js) & + + ( rcss%polycoeff(2,js) & + + ( rcss%polycoeff(3,js) & + + ( rcss%polycoeff(4,js) & + + rcss%polycoeff(5,js) & *xir)*xir)*xir)*xir else - adr = ( rcs%polycoeff(1, js) & - + ( c1_2*rcs%polycoeff(2, js) & - + ( c1_3*rcs%polycoeff(3, js) & - + ( c1_4*rcs%polycoeff(4, js) & - + c1_5*rcs%polycoeff(5, js) & + adr = ( rcss%polycoeff(1,js) & + + ( c1_2*rcss%polycoeff(2,js) & + + ( c1_3*rcss%polycoeff(3,js) & + + ( c1_4*rcss%polycoeff(4,js) & + + c1_5*rcss%polycoeff(5,js) & *xir)*xir)*xir)*xir)*xir u_dst(jd) = u_dst(jd) & - + (adr - adl)*rcs%h_src(js)*rms%hi_dst(jd) + + (adr - adl)*rcss%rcgs%h_src(js) & + *rms%hi_dst(jd) xil = xir adl = adr endif @@ -2708,18 +4803,16 @@ function remap(rcs, rms, u_dst) result(errstat) ! Set values for any near-empty destination grid cells at the start ! and the end of the array. - do jd = 1, rms%seg_dst_index(1) - 1 - u_dst(jd) = rcs%polycoeff(1, 1) + do jd = 1, rms%seg_dst_index(1)-1 + u_dst(jd) = rcss%polycoeff(1,1) enddo if (rms%seg_dst_index(iseg) < rms%n_dst) then jd = rms%seg_dst_index(iseg) + 1 - u_dst(jd) = rcs%polycoeff(1, rcs%n_src) & - + rcs%polycoeff(2, rcs%n_src) & - + rcs%polycoeff(3, rcs%n_src) & - + rcs%polycoeff(4, rcs%n_src) & - + rcs%polycoeff(5, rcs%n_src) - do jd = rms%seg_dst_index(iseg) + 2, rms%n_dst - u_dst(jd) = u_dst(rms%seg_dst_index(iseg) + 1) + u_dst(jd) = rcss%polycoeff(1,ns) + rcss%polycoeff(2,ns) & + + rcss%polycoeff(3,ns) + rcss%polycoeff(4,ns) & + + rcss%polycoeff(5,ns) + do jd = rms%seg_dst_index(iseg)+2, rms%n_dst + u_dst(jd) = u_dst(rms%seg_dst_index(iseg)+1) enddo endif @@ -2727,34 +4820,95 @@ function remap(rcs, rms, u_dst) result(errstat) end function remap - subroutine free_rcs(rcs) + subroutine free_rcgs(rcgs) ! --------------------------------------------------------------------------- - ! Deallocate arrays and reset flags. + ! Nullify pointers, deallocate arrays and reset flags. ! --------------------------------------------------------------------------- - type(reconstruction_struct), intent(inout) :: rcs + type(recon_grd_struct), intent(inout) :: rcgs - deallocate(rcs%x_edge_src, rcs%h_src, rcs%hi_src, rcs%hci_src, & - rcs%src_dst_weight, rcs%tdecoeff, rcs%tdscoeff, rcs%lblu, & - rcs%rblu, rcs%u_src, rcs%uel, rcs%uer, rcs%usl, rcs%usr, & - rcs%src_dst_index, rcs%polycoeff) + type(recon_src_struct), pointer :: rcss_dep, rcss_dep_next + type(remap_struct), pointer :: rms_dep, rms_dep_next + + ! Free data structures that depends on this + ! reconstruction grid data structure. + rcss_dep => rcgs%rcss_dep_head + do while (associated(rcss_dep)) + rcss_dep_next => rcss_dep%rcss_dep_next + call free_rcss(rcss_dep) + rcss_dep => rcss_dep_next + enddo + rms_dep => rcgs%rms_dep_head + do while (associated(rms_dep)) + rms_dep_next => rms_dep%rms_dep_next + call free_rms(rms_dep) + rms_dep => rms_dep_next + enddo + + nullify(rcgs%x_eps, rcgs%x_edge_src, rcgs%h_src, rcgs%hi_src, & + rcgs%src_dst_index, rcgs%n_src_actual, rcgs%method_actual, & + rcgs%prepared, rcgs%rcss_dep_head, rcgs%rms_dep_head) + deallocate(rcgs%x_eps_data, rcgs%x_edge_src_data, rcgs%h_src_data, & + rcgs%hi_src_data, rcgs%src_dst_index_data, & + rcgs%n_src_actual_data, rcgs%method_actual_data, & + rcgs%prepared_data) + + if (rcgs%method /= hor3map_pcm) then + nullify(rcgs%hci_src) + deallocate(rcgs%hci_src_data) + endif + + if (rcgs%method == hor3map_ppm .or. rcgs%method == hor3map_pqm) then + nullify(rcgs%src_dst_weight, rcgs%tdecoeff, rcgs%tdscoeff, rcgs%lblu, & + rcgs%rblu) + deallocate(rcgs%src_dst_weight_data, rcgs%tdecoeff_data, & + rcgs%tdscoeff_data, rcgs%lblu_data, rcgs%rblu_data) + endif + + rcgs%i_index_curr = 0 + rcgs%j_index_curr = 0 + rcgs%initialized = .false. + + end subroutine free_rcgs + + subroutine free_rcss(rcss) + ! --------------------------------------------------------------------------- + ! Nullify pointers, deallocate arrays and reset flags. + ! --------------------------------------------------------------------------- + + type(recon_src_struct), intent(inout) :: rcss + + nullify(rcss%u_src, rcss%uel, rcss%uer, rcss%polycoeff, & + rcss%reconstructed, rcss%rcss_dep_next) + deallocate(rcss%u_src_data, rcss%uel_data, rcss%uer_data, & + rcss%polycoeff_data, rcss%reconstructed_data) + + if (rcss%rcgs%method == hor3map_pqm) then + nullify(rcss%usl, rcss%usr) + deallocate(rcss%usl_data, rcss%usr_data) + endif - rcs%alloced = .false. - rcs%reconstructed = .false. + rcss%i_index_curr = 0 + rcss%j_index_curr = 0 + rcss%initialized = .false. - end subroutine free_rcs + end subroutine free_rcss subroutine free_rms(rms) ! --------------------------------------------------------------------------- - ! Deallocate arrays and reset flags. + ! Nullify pointers, deallocate arrays and reset flags. ! --------------------------------------------------------------------------- type(remap_struct), intent(inout) :: rms - deallocate(rms%h_dst, rms%hi_dst, rms%seg_int_lim, rms%n_src_seg, & - rms%seg_dst_index) + nullify(rms%h_dst, rms%hi_dst, rms%seg_int_lim, rms%n_src_seg, & + rms%seg_dst_index, rms%prepared, rms%rms_dep_next) + deallocate(rms%h_dst_data, rms%hi_dst_data, rms%seg_int_lim_data, & + rms%n_src_seg_data, rms%seg_dst_index_data, rms%prepared_data) - rms%alloced = .false. + rms%i_index_curr = 0 + rms%j_index_curr = 0 + rms%initialized = .false. end subroutine free_rms From d9beba45a7fbae962b2a218a545e7d08862bcc56 Mon Sep 17 00:00:00 2001 From: Mats Bentsen Date: Wed, 25 May 2022 16:19:16 +0200 Subject: [PATCH 095/366] - Added functions for in situ density derivatives with respect to potential temperature and salinity. - For lateral eddy-induced mixing, added the option of neutral diffusion. - Estimate neutral slope, used in eddy diffusivity and eddy-induced transport parameterizations, from the neutral diffusion algorithm. - Added technical support for PQM reconstruction for vertical regridding and remapping. - Added new method for regridding (by using the reconstructed high-order temperature and salinity profiles, nudge interfaces towards desired potential density). - Split the module related to common fields into a data module and a module with routines for field calculation. - Added a public routine for the computation of buoyancy frequency squared on layer interfaces for hybrid vertical coordinate. - Corrected sign of buoyancy flux passed to CVMix. - Modified buoyancy flux passed to CVMix for computing turbulent scales. - Modified buoyancy flux passed to CVMix for computing diffusivities. - Corrected pressure used for computing density contrast with surface, passed to CVMix. - Corrected passing of parameters to CVMix for computing bulk Richardson number. - Added CVMix settings for different matching techniques. - Non-local transport terms computed by CVMix are now used to distribute the surface forcing. - For hybrid vertical coordinate, instead of directly updating temperature due to shortwave flux absorption, store shortwave flux in a non-local transport array. - Incorporated non-local transport terms in the solving of the tracer vertical diffusion equations for hybrid coordinates. - Split the solving of vertical diffusion equations for hybrid coordinates into separate routines for tracers and momentum. - Corrected interpolation of vertical momentum diffusivity to velocity points. - For hybrid vertical coordinate, the computation of lateral and vertical diffusivities has been further split up. - For hybrid vertical coordinate, the order of operations during a model time step has been altered. --- phy/blom_init.F | 119 ++- phy/blom_step.F | 85 +- phy/cntiso_hybrid_forcing.F90 | 126 ++- phy/diffus.F | 35 +- phy/meson.build | 15 +- phy/mod_budget.F90 | 172 ++-- phy/mod_cmnfld.F90 | 909 +-------------------- phy/mod_cmnfld_routines.F90 | 1090 ++++++++++++++++++++++++++ phy/mod_difest.F | 228 ++++-- phy/mod_diffusion.F90 | 32 +- phy/mod_eos.F90 | 50 +- phy/mod_forcing.F90 | 40 +- phy/mod_inicon.F | 7 +- phy/mod_mxlayr.F | 4 +- phy/mod_ndiff.F90 | 1149 +++++++++++++++++++++++++++ phy/mod_pgforc.F | 19 +- phy/mod_remap.F | 14 +- phy/mod_state.F90 | 48 +- phy/mod_timing.F90 | 4 +- phy/mod_tmsmt.F | 147 ++-- phy/mod_vcoord.F90 | 1388 +++++++++++++++++++++++---------- phy/mod_vdiff.F90 | 118 ++- phy/restart_rd.F | 22 +- phy/restart_wt.F | 34 +- 24 files changed, 4130 insertions(+), 1725 deletions(-) create mode 100644 phy/mod_cmnfld_routines.F90 create mode 100644 phy/mod_ndiff.F90 diff --git a/phy/blom_init.F b/phy/blom_init.F index 24e8fda2..0c186891 100644 --- a/phy/blom_init.F +++ b/phy/blom_init.F @@ -1,5 +1,5 @@ ! ------------------------------------------------------------------------------ -! Copyright (C) 2008-2021 Mats Bentsen, Mehmet Ilicak +! Copyright (C) 2008-2022 Mats Bentsen, Mehmet Ilicak ! ! This file is part of BLOM. ! @@ -36,10 +36,11 @@ subroutine blom_init 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 use mod_inicon, only: inicon use mod_budget, only: budget_init - use mod_cmnfld, only: cmnfld + use mod_cmnfld_routines, only: cmnfld1 use netcdf #if defined(TRC) && defined(TKE) use mod_tke, only: initke @@ -47,7 +48,7 @@ subroutine blom_init c implicit none c - integer istat,ncid,varid,i,j,k,l,m,n,mm,km + integer istat,ncid,varid,i,j,k,l,m,n,mm,nn,k1m,k1n,mt,mmt,km real q logical icrest,fexist c @@ -200,60 +201,84 @@ subroutine blom_init endif c c --- ------------------------------------------------------------------ -c --- Set layer thickness at u,v points +c --- Initialize model time step and set time level indices consistent +c --- with starting state +c --- ------------------------------------------------------------------ +c + nstep=nstep1 + m=mod(nstep+1,2)+1 + n=mod(nstep ,2)+1 + mm=(m-1)*kk + nn=(n-1)*kk + k1m=1+mm + k1n=1+nn +c +c --- ------------------------------------------------------------------ +c --- Initialize layer thicknesses c --- ------------------------------------------------------------------ c call xctilr(dp, 1,2*kk, 3,3, halo_ps) c - n=mod(nstep1,2)+1 + if (vcoord_type_tag == isopyc_bulkml) then c - do m=n,3-n,3-2*n - mm=(m-1)*kk + do mt=n,3-n,3-2*n + mmt=(mt-1)*kk c c$OMP PARALLEL DO PRIVATE(k,l,i) - do j=-2,jj+2 - do k=1,kk - do l=1,isp(j) - do i=max(-2,ifp(j,l)),min(ii+2,ilp(j,l)) - p(i,j,k+1)=p(i,j,k)+dp(i,j,k+mm) - enddo + do j=-2,jj+2 + do k=1,kk + do l=1,isp(j) + do i=max(-2,ifp(j,l)),min(ii+2,ilp(j,l)) + p(i,j,k+1)=p(i,j,k)+dp(i,j,k+mmt) + enddo + enddo enddo enddo - enddo c$OMP END PARALLEL DO c c$OMP PARALLEL DO PRIVATE(k,km,l,i,q) - do j=-1,jj+2 - do k=1,kk - km=k+mm - 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,km)= - . .5*((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 + do j=-1,jj+2 + do k=1,kk + km=k+mmt + 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,km)= + . .5*((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,km)= + . .5*((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 - 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,km)= - . .5*((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 +c$OMP END PARALLEL DO +c + enddo +c + else +c + call xctilr(dpu, 1,2*kk, 3,3, halo_us) + call xctilr(dpv, 1,2*kk, 3,3, halo_vs) +c +c$OMP PARALLEL DO PRIVATE(k,l,i) + do j=-2,jj+2 + do k=1,kk + do l=1,isp(j) + do i=max(-2,ifp(j,l)),min(ii+2,ilp(j,l)) + p(i,j,k+1)=p(i,j,k)+dp(i,j,k+mm) enddo enddo enddo enddo c$OMP END PARALLEL DO c - enddo -c - nstep=nstep1 - if (mnproc.eq.1.and.expcnf.ne.'cesm') then - write (lp,'(/2(a,i6),2(a,i9),a/)') - . 'model starts at day',nday1,', goes to day',nday2,' (steps', - . nstep1,' --',nstep2,')' - call flush(lp) endif c c --- ------------------------------------------------------------------ @@ -280,6 +305,7 @@ subroutine blom_init call xctilr(vml, 1,4, 0,1, halo_vv) call xctilr(umlres, 1,2, 1,0, halo_uv) call xctilr(vmlres, 1,2, 0,1, halo_vv) + call xctilr(sigmar, 1,kk, 1,1, halo_ps) c c --- with arctic patch, switch xixp and xixm and xiyp and xiym in the c --- halo region adjacent to the arctic grid intersection @@ -314,8 +340,12 @@ subroutine blom_init enddo endif c - m=3-n - call cmnfld(m,n,(m-1)*kk,(n-1)*kk,1+(m-1)*kk,1+(n-1)*kk) +c --- ------------------------------------------------------------------ +c --- Initialize time smoothing variables and some common fields. +c --- ------------------------------------------------------------------ +c + call initms(m,n,mm,nn,k1m,k1n) + call cmnfld1(m,n,mm,nn,k1m,k1n) c c --- ------------------------------------------------------------------ c --- Extract reference potential density vector representative of the @@ -324,6 +354,15 @@ subroutine blom_init c call diasg1 c +c --- ------------------------------------------------------------------ +c + if (mnproc.eq.1.and.expcnf.ne.'cesm') then + write (lp,'(/2(a,i6),2(a,i9),a/)') + . 'model starts at day',nday1,', goes to day',nday2,' (steps', + . nstep1,' --',nstep2,')' + call flush(lp) + endif +c c --- print seconds elapsed since last call to system_clock (Time 0) if (mnproc.eq.1) then write (lp,'(f12.4,a,i8)') diff --git a/phy/blom_step.F b/phy/blom_step.F index 4d32dacd..6d366d0a 100644 --- a/phy/blom_step.F +++ b/phy/blom_step.F @@ -1,5 +1,5 @@ ! ------------------------------------------------------------------------------ -! Copyright (C) 2008-2021 Mats Bentsen, Mehmet Ilicak +! Copyright (C) 2008-2022 Mats Bentsen, Mehmet Ilicak ! ! This file is part of BLOM. ! @@ -40,7 +40,7 @@ subroutine blom_step use mod_vcoord, only: vcoord_type_tag, isopyc_bulkml, . cntiso_hybrid, cntiso_hybrid_regrid_remap, . remap_velocity - use mod_vdiff, only: cntiso_hybrid_vdiff + use mod_vdiff, only: cntiso_hybrid_vdifft, cntiso_hybrid_vdiffm use mod_swabs, only: updswa use mod_tmsmt, only: tmsmt1, tmsmt2 use mod_eddtra, only: eddtra @@ -50,20 +50,23 @@ subroutine blom_step use mod_momtum, only: momtum use mod_mxlayr, only: mxlayr use mod_barotp, only: barotp - use mod_cmnfld, only: cmnfld + use mod_cmnfld_routines, only: cmnfld_bfsqi_cntiso_hybrid, + . cmnfld1, cmnfld2 use mod_forcing, only: fwbbal use mod_budget, only: budget_sums, budget_output use mod_eddtra, only: eddtra use mod_momtum, only: momtum - use mod_difest, only: difest + use mod_difest, only: difest_isobml, difest_lateral_hybrid, + . difest_vertical_hybrid use mod_chkvar, only: chkvar use mod_dia c - use mod_state, only: temp, saln, dp + use mod_state, only: temp, saln, dp, init_fluxes implicit none c real q integer i,m,n,mm,nn,k1m,k1n + logical update_flux_halos c real total_step_time, . auxil_time , @@ -98,19 +101,13 @@ subroutine blom_step call step_time c c --- ------------------------------------------------------------------ -c --- Update some flux halos the first time step of a day to reproduce -c --- results after restart with arctic +c --- Reset fluxes to be accumulated over a model time step and update +c --- flux halos the first time step of a day to reproduce results after +c --- restart with tripolar grid. c --- ------------------------------------------------------------------ c - if (nreg.eq.2.and.mod(nstep,nstep_in_day).eq.1) then - if (mnproc.eq.1) write (lp,*) 'blom_step: update flux halos' - call xctilr(uflx(1-nbdy,1-nbdy,k1n), 1,kk, 1,1, halo_uv) - call xctilr(utflx(1-nbdy,1-nbdy,k1n), 1,kk, 1,1, halo_uv) - call xctilr(usflx(1-nbdy,1-nbdy,k1n), 1,kk, 1,1, halo_uv) - call xctilr(vflx(1-nbdy,1-nbdy,k1n), 1,kk, 1,1, halo_vv) - call xctilr(vtflx(1-nbdy,1-nbdy,k1n), 1,kk, 1,1, halo_vv) - call xctilr(vsflx(1-nbdy,1-nbdy,k1n), 1,kk, 1,1, halo_vv) - endif + update_flux_halos = nreg == 2 .and. mod(nstep,nstep_in_day) == 1 + call init_fluxes(m,n,mm,nn,k1m,k1n,update_flux_halos) c auxil_time=get_time() c @@ -127,20 +124,37 @@ subroutine blom_step call updswa c getfrc_time=get_time() +c + 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) + convec_time=get_time() + call budget_sums(2,n,nn) + endif +c + call cmnfld2(m,n,mm,nn,k1m,k1n) c cdiag write (lp,*) 'tmsmt1...' call tmsmt1(m,n,mm,nn,k1m,k1n) tmsmt1_time=get_time() c cdiag write (lp,*) 'advdif...' - call difest(m,n,mm,nn,k1m,k1n) + if (vcoord_type_tag == isopyc_bulkml) then + call difest_isobml(m,n,mm,nn,k1m,k1n) + else + call difest_lateral_hybrid(m,n,mm,nn,k1m,k1n) + endif call eddtra(m,n,mm,nn,k1m,k1n) call advect(m,n,mm,nn,k1m,k1n) call pbcor1(m,n,mm,nn,k1m,k1n) call diffus(m,n,mm,nn,k1m,k1n) advdif_time=get_time() c - call budget_sums(2,n,nn) + if (vcoord_type_tag == isopyc_bulkml) then + call budget_sums(2,n,nn) + else + call budget_sums(3,n,nn) + endif auxil_time=auxil_time+get_time() c cdiag write (lp,*) 'sfcstr...' @@ -170,18 +184,6 @@ subroutine blom_step c call budget_sums(4,n,nn) auxil_time=auxil_time+get_time() -c - else -c - convec_time=get_time() - call budget_sums(3,n,nn) - auxil_time=auxil_time+get_time() -c - call cntiso_hybrid_vdiff(m,n,mm,nn,k1m,k1n) - diapfl_time=get_time() -c - call budget_sums(4,n,nn) - auxil_time=auxil_time+get_time() c endif c @@ -194,21 +196,20 @@ subroutine blom_step 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 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 budget_sums(4,n,nn) + diapfl_time=get_time() endif c #ifdef TRC c --- update tracer due to non-passive processes call updtrc(m,n,mm,nn,k1m,k1n) #endif -c - if (vcoord_type_tag == cntiso_hybrid) then - call cntiso_hybrid_regrid_remap(m,n,mm,nn,k1m,k1n) - diapfl_time=get_time() - call remap_velocity(m,n,mm,nn,k1m,k1n) - mxlayr_time=get_time() - endif c call budget_sums(5,n,nn) auxil_time=auxil_time+get_time() @@ -227,10 +228,13 @@ subroutine blom_step cdiag write (lp,*) 'tmsmt2...' call tmsmt2(m,n,mm,nn,k1m,k1n) tmsmt2_time=get_time() -c - call cmnfld(m,n,mm,nn,k1m,k1n) c call budget_sums(7,m,mm) +c + call cmnfld1(m,n,mm,nn,k1m,k1n) +c + call diaacc(m,n,mm,nn,k1m,k1n) + diaacc_time=get_time() c call fwbbal(m,n,mm,nn,k1m,k1n) c @@ -245,9 +249,6 @@ subroutine blom_step c ---------------------------------------------------------------------- c call chkvar(m,n,mm,nn,k1m,k1n) -c - call diaacc(m,n,mm,nn,k1m,k1n) - diaacc_time=get_time() c if (mod(nstep,nstep_in_day).eq.0.and.nday_of_year.eq.1) then c diff --git a/phy/cntiso_hybrid_forcing.F90 b/phy/cntiso_hybrid_forcing.F90 index b8adafbe..254dacfc 100644 --- a/phy/cntiso_hybrid_forcing.F90 +++ b/phy/cntiso_hybrid_forcing.F90 @@ -1,5 +1,5 @@ ! ------------------------------------------------------------------------------ -! Copyright (C) 2021 Mats Bentsen +! Copyright (C) 2021-2022 Mats Bentsen ! ! This file is part of BLOM. ! @@ -24,88 +24,75 @@ subroutine cntiso_hybrid_forcing(m, n, mm, nn, k1m, k1n) use mod_types, only: r8 use mod_constants, only: g, spcifh, alpha0, onem, onemu - use mod_time, only: delt1 use mod_xc - use mod_eos, only: sig, dsigdt0, dsigds0 - use mod_state, only: dp, temp, saln, sigma + use mod_eos, only: dsigdt0, dsigds0 + use mod_state, only: dp, temp, saln use mod_swabs, only: swbgal, swbgfc, swamxd - use mod_forcing, only: surflx, surrlx, sswflx, salflx, salrlx, buoyfl + use mod_forcing, only: surflx, sswflx, salflx, buoyfl, t_sw_nonloc use mod_checksum, only: csdiag, chksummsk -#ifdef TRC - use mod_tracers, only: ntr, trc, trflx -#endif implicit none integer, intent(in) :: m, n, mm, nn, k1m, k1n - real(r8) :: pradd, lei, pres, pswbas, pswup, pswlo, q - integer :: i, j, k, l, kfmax, kn -#ifdef TRC - integer :: nt -#endif + real(r8) :: pres(kk+1) + real(r8) :: cpi, pswamx, gaa, dsgdt, dsgds, lei, pswamxi, pswbot + integer :: i, j, k, l, kswamx, kn - ! Maximum pressure of shortwave radiation penetration. - pradd = swamxd*onem + ! Set some constants: + cpi = 1._r8/spcifh ! Multiplicative inverse of specific heat capacity. + pswamx = swamxd*onem ! Maximum pressure of shortwave absorption. + gaa = g*alpha0*alpha0 -!$omp parallel do private(l, i, lei, pres, pswbas, pswup, kfmax, k, kn, pswlo, & -!$omp q & -#ifdef TRC -!$omp , nt & -#endif -!$omp ) +!$omp parallel do private(l, i, dsgdt, dsgds, lei, pres, kswamx, k, kn, & +!$omp pswamxi, pswbot) do j = 1, jj do l = 1, isp(j) - do i = max(1, ifp(j, l)), min(ii, ilp(j, l)) + do i = max(1, ifp(j,l)), min(ii, ilp(j,l)) - ! Compute total buoyancy flux [cm2 s-3] - buoyfl(i,j) = & - - ( dsigdt0(temp(i, j, k1n),saln(i, j, k1n))*surflx(i,j)/spcifh & - + dsigds0(temp(i, j, k1n),saln(i, j, k1n))*salflx(i,j)) & - *g*alpha0*alpha0 + ! Derivatives of potential density referenced at the surface. + dsgdt = dsigdt0(temp(i,j,k1n), saln(i,j,k1n)) + dsgds = dsigds0(temp(i,j,k1n), saln(i,j,k1n)) - ! Modify temperature below top layer due to penetrating short-wave - ! flux. - lei = 1._r8/(onem*swbgal(i, j)) - pres = dp(i, j, k1n) - pswbas = swbgfc(i, j)*exp( - lei*pres) - pswup = pswbas - kfmax = 1 - k = 2 - do while (k <= kk) + ! Compute surface buoyancy flux [cm2 s-3]. + buoyfl(i,j,1) = - (dsgdt*surflx(i,j)*cpi + dsgds*salflx(i,j))*gaa + + ! Compute shortwave penetration factors at layer interfaces. + lei = 1._r8/(onem*swbgal(i,j)) + pres(1) = 0._r8 + kswamx = 1 + t_sw_nonloc(i,j,1) = 1._r8 + do k = 1, kk kn = k + nn - pres = pres + dp(i, j, kn) - if (dp(i, j, kn) > onemu) then - pswlo = swbgfc(i,j)*exp( - lei*min(pradd, pres)) - temp(i, j, kn) = temp(i, j, kn) & - - (pswup - pswlo)*sswflx(i, j)*delt1*g & - /(spcifh*dp(i, j, kn)) - pswup = pswlo - kfmax = k + pres(k+1) = pres(k) + dp(i,j,kn) + if (dp(i,j,kn) > onemu) then + t_sw_nonloc(i,j,k+1) = & + swbgfc(i,j)*exp( - lei*min(pswamx, pres(k+1))) + kswamx = k + else + t_sw_nonloc(i,j,k+1) = t_sw_nonloc(i,j,k) endif - k = k + 1 - if (pres > pradd) exit + if (pres(k+1) > pswamx) exit enddo - ! Modify temperature and salinity in top layer due to surface heat and - ! salt fluxes. - q = delt1*g/dp(i, j, k1n) - temp(i, j, k1n) = temp(i, j, k1n) & - - ( surflx(i, j ) - (pswbas - pswup)*sswflx(i, j) & - + surrlx(i, j))*q/spcifh - saln(i, j, k1n) = saln(i, j, k1n) - (salflx(i,j) + salrlx(i,j))*q - -#ifdef TRC - ! Modify tracer content in top layer due to surface fluxes. - do nt = 1, ntr - trc(i, j, k1n, nt) = trc(i, j, k1n, nt) - trflx(nt, i, j)*q + ! Compute buoyancy flux at subsurface layer interfaces. Penetration + ! factors are modified so that shortwave radiation destined to + ! penetrate below the lowest model layer is evenly absorbed in the + ! water column. + pswamxi = 1._r8/min(pswamx, pres(kswamx+1)) + pswbot = t_sw_nonloc(i,j,kswamx+1) + do k = kswamx+1, kk+1 + t_sw_nonloc(i,j,k) = 0._r8 + buoyfl(i,j,k) = 0._r8 enddo -#endif - - ! Update potential density in modified layers. - do k = 1, kfmax + do k = kswamx, 2, -1 kn = k + nn - sigma(i, j, kn) = sig(temp(i, j, kn), saln(i, j, kn)) + if (dp(i,j,kn) > onemu) then + t_sw_nonloc(i,j,k) = t_sw_nonloc(i,j,k) - pswbot*pres(k)*pswamxi + else + t_sw_nonloc(i,j,k) = t_sw_nonloc(i,j,k+1) + endif + buoyfl(i,j,k) = - dsgdt*t_sw_nonloc(i,j,k)*sswflx(i,j)*cpi*gaa enddo enddo @@ -115,17 +102,10 @@ subroutine cntiso_hybrid_forcing(m, n, mm, nn, k1m, k1n) if (csdiag) then if (mnproc == 1) then - write (lp,*) 'mxlayr:' + write (lp,*) 'cntiso_hybrid_forcing:' endif - call chksummsk(dp, ip, 2*kk, 'dp') - call chksummsk(temp, ip, 2*kk, 'temp') - call chksummsk(saln, ip, 2*kk, 'saln') - call chksummsk(sigma, ip, 2*kk, 'sigma') -#ifdef TRC - do nt=1,ntr - call chksummsk(trc(1-nbdy,1-nbdy,1,nt),ip,2*kk,'trc') - enddo -#endif + call chksummsk(buoyfl, ip, kk+1, 'buoyfl') + call chksummsk(t_sw_nonloc, ip, kk+1, 't_sw_nonloc') endif end subroutine cntiso_hybrid_forcing diff --git a/phy/diffus.F b/phy/diffus.F index ab6c6118..7f810ab8 100644 --- a/phy/diffus.F +++ b/phy/diffus.F @@ -1,5 +1,5 @@ ! ------------------------------------------------------------------------------ -! Copyright (C) 2006-2020 Mats Bentsen +! Copyright (C) 2006-2022 Mats Bentsen ! ! This file is part of BLOM. ! @@ -29,7 +29,8 @@ subroutine diffus(m,n,mm,nn,k1m,k1n) use mod_eos, only: sig use mod_state, only: dp, temp, saln, sigma, . utflx, vtflx, usflx, vsflx - use mod_diffusion, only: difiso, utflld, vtflld, usflld, vsflld + use mod_diffusion, only: ntrdif,difiso, + . utflld, vtflld, usflld, vsflld use mod_checksum, only: csdiag, chksummsk #ifdef TRC use mod_tracers, only: ntr, itrtke, itrgls, trc, uflxtr, vflxtr @@ -48,18 +49,32 @@ subroutine diffus(m,n,mm,nn,k1m,k1n) real dpeps parameter (dpeps=1.e-4) c - 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(dp(1-nbdy,1-nbdy,k1n), 1,kk, 3,3, halo_ps) + if (ntrdif) then + 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) #ifdef TRC - do nt=1,ntr + do nt=1,ntr # if defined(TKE) && !defined(TKEIDF) - if (nt.eq.itrtke.or.nt.eq.itrgls) cycle + if (nt.eq.itrtke.or.nt.eq.itrgls) cycle # endif - call xctilr(trc(1-nbdy,1-nbdy,k1n,nt), 1,kk, 2,2, halo_ps) - enddo + call xctilr(trc(1-nbdy,1-nbdy,k1n,nt), 1,kk, 1,1, halo_ps) + enddo +#endif + return + else + 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) +#ifdef TRC + do nt=1,ntr +# if defined(TKE) && !defined(TKEIDF) + if (nt.eq.itrtke.or.nt.eq.itrgls) cycle +# endif + call xctilr(trc(1-nbdy,1-nbdy,k1n,nt), 1,kk, 2,2, halo_ps) + enddo #endif - call xctilr(difiso, 1,kk, 2,2, halo_ps) + call xctilr(difiso, 1,kk, 2,2, halo_ps) + endif c do k=1,kk kn=k+nn diff --git a/phy/meson.build b/phy/meson.build index d9bdcb5a..a573e1e1 100644 --- a/phy/meson.build +++ b/phy/meson.build @@ -3,13 +3,14 @@ sources += files('cntiso_hybrid_forcing.F90', 'bigrid.F', 'blom_init.F', 'fill_global.F', 'geoenv_file.F', 'geoenv_test.F', 'getfrc.F90', 'idarlx.F', 'inifrc.F90', 'inigeo.F', 'iniphy.F', 'inivar.F90', 'intp1d.F', 'mod_advect.F', 'mod_barotp.F', 'mod_budget.F90', 'mod_calendar.F90', 'mod_checksum.F90', -'mod_chkvar.F90', 'mod_cmnfld.F90', 'mod_config.F90', 'mod_constants.F90', -'mod_dia.F', 'mod_diffusion.F90', 'mod_eddtra.F90', 'mod_eos.F90', -'mod_forcing.F90', 'mod_grid.F90', 'mod_hor3map.F90', 'mod_inicon.F', -'mod_momtum.F', 'mod_mxlayr.F', 'mod_nctools.F', 'mod_niw.F90', 'mod_pbcor.F', -'mod_pgforc.F', 'mod_pointtest.F90', 'mod_remap.F', 'mod_seaice.F90', -'mod_state.F90', 'mod_swabs.F', 'mod_temmin.F', 'mod_tidaldissip.F90', -'mod_time.F90', 'mod_timing.F90', 'mod_tke.F90', 'mod_tmsmt.F', 'mod_types.F90', +'mod_chkvar.F90', 'mod_cmnfld.F90', 'mod_cmnfld_routines.F90', 'mod_config.F90', +'mod_constants.F90', 'mod_dia.F', 'mod_diffusion.F90', 'mod_eddtra.F90', +'mod_eos.F90', 'mod_forcing.F90', 'mod_grid.F90', 'mod_hor3map.F90', +'mod_inicon.F', 'mod_momtum.F', 'mod_mxlayr.F', 'mod_nctools.F', +'mod_ndiff.F90', 'mod_niw.F90', 'mod_pbcor.F', 'mod_pgforc.F', +'mod_pointtest.F90', 'mod_remap.F', 'mod_seaice.F90', 'mod_state.F90', +'mod_swabs.F', 'mod_temmin.F', 'mod_tidaldissip.F90', 'mod_time.F90', +'mod_timing.F90', 'mod_tke.F90', 'mod_tmsmt.F', 'mod_types.F90', 'mod_utility.F90', 'mod_vcoord.F90', 'mod_vdiff.F90', 'mod_xc.F', 'numerical_bounds.F90', 'rdcsss.F', 'rdlim.F', 'restart_rd.F', 'restart_wt.F', 'sfcstr.F90', 'thermf.F', 'wdiflx.F', 'wtime.F') diff --git a/phy/mod_budget.F90 b/phy/mod_budget.F90 index fd96f193..ed6bda87 100644 --- a/phy/mod_budget.F90 +++ b/phy/mod_budget.F90 @@ -1,5 +1,5 @@ ! ------------------------------------------------------------------------------ -! Copyright (C) 2007-2020 Mats Bentsen +! Copyright (C) 2007-2022 Mats Bentsen ! ! This file is part of BLOM. ! @@ -26,6 +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_grid, only: scp2 use mod_state, only: pb, dp, temp, saln use mod_forcing, only: surflx, surrlx, salflx, salrlx @@ -197,64 +198,131 @@ subroutine budget_output(m) if (.not.cnsvdi) return if (mnproc == 1 .and. nstep > nstep1 + 1) then - open (unit = nfu, file = 'salbud', position = 'append') - write (nfu, '(i8,6e12.4)') nstep - 1, & - (sdp(2, m) - sdp(1, m))/mass0, & - (sdp(3, m) - sdp(2, m))/mass0, & - (sdp(4, m) - sdp(3, m))/mass0, & - (sdp(5, m) - sdp(4, m) + sf*g)/mass0, & - (sdp(6, m) - sdp(5, m))/mass0, & - (sdp(7, m) - sdp(6, m))/mass0 - close (nfu) - open (unit = nfu, file = 'tembud', position = 'append') - write (nfu, '(i8,6e12.4)') nstep - 1, & - (tdp(2, m) - tdp(1, m))/mass0, & - (tdp(3, m) - tdp(2, m))/mass0, & - (tdp(4, m) - tdp(3, m))/mass0, & - (tdp(5, m) - tdp(4, m) + tf*g/spcifh)/mass0, & - (tdp(6, m) - tdp(5, m))/mass0, & - (tdp(7, m) - tdp(6, m))/mass0 - close (nfu) + + if (vcoord_type_tag == isopyc_bulkml) then + + open (unit = nfu, file = 'salbud', position = 'append') + write (nfu, '(i8,6e12.4)') nstep - 1, & + (sdp(2, m) - sdp(1, m))/mass0, & + (sdp(3, m) - sdp(2, m))/mass0, & + (sdp(4, m) - sdp(3, m))/mass0, & + (sdp(5, m) - sdp(4, m) + sf*g)/mass0, & + (sdp(6, m) - sdp(5, m))/mass0, & + (sdp(7, m) - sdp(6, m))/mass0 + close (nfu) + open (unit = nfu, file = 'tembud', position = 'append') + write (nfu, '(i8,6e12.4)') nstep - 1, & + (tdp(2, m) - tdp(1, m))/mass0, & + (tdp(3, m) - tdp(2, m))/mass0, & + (tdp(4, m) - tdp(3, m))/mass0, & + (tdp(5, m) - tdp(4, m) + tf*g/spcifh)/mass0, & + (tdp(6, m) - tdp(5, m))/mass0, & + (tdp(7, m) - tdp(6, m))/mass0 + close (nfu) #ifdef TRC # ifdef TKE - open (unit = nfu, file = 'tkebud', position = 'append') - write (nfu, '(i8,6e12.4)') nstep - 1, & - (tkedp(2, m) - tkedp(1, m))/mass0, & - (tkedp(3, m) - tkedp(2, m))/mass0, & - (tkedp(4, m) - tkedp(3, m))/mass0, & - (tkedp(5, m) - tkedp(4, m))/mass0, & - (tkedp(6, m) - tkedp(5, m))/mass0, & - (tkedp(7, m) - tkedp(6, m))/mass0 - close (nfu) + open (unit = nfu, file = 'tkebud', position = 'append') + write (nfu, '(i8,6e12.4)') nstep - 1, & + (tkedp(2, m) - tkedp(1, m))/mass0, & + (tkedp(3, m) - tkedp(2, m))/mass0, & + (tkedp(4, m) - tkedp(3, m))/mass0, & + (tkedp(5, m) - tkedp(4, m))/mass0, & + (tkedp(6, m) - tkedp(5, m))/mass0, & + (tkedp(7, m) - tkedp(6, m))/mass0 + close (nfu) # ifdef GLS - open (unit = nfu, file = 'glsbud', position = 'append') - write (nfu, '(i8,6e12.4)') nstep - 1, & - (glsdp(2, m) - glsdp(1, m))/mass0, & - (glsdp(3, m) - glsdp(2, m))/mass0, & - (glsdp(4, m) - glsdp(3, m))/mass0, & - (glsdp(5, m) - glsdp(4, m))/mass0, & - (glsdp(6, m) - glsdp(5, m))/mass0, & - (glsdp(7, m) - glsdp(6, m))/mass0 - close (nfu) + open (unit = nfu, file = 'glsbud', position = 'append') + write (nfu, '(i8,6e12.4)') nstep - 1, & + (glsdp(2, m) - glsdp(1, m))/mass0, & + (glsdp(3, m) - glsdp(2, m))/mass0, & + (glsdp(4, m) - glsdp(3, m))/mass0, & + (glsdp(5, m) - glsdp(4, m))/mass0, & + (glsdp(6, m) - glsdp(5, m))/mass0, & + (glsdp(7, m) - glsdp(6, m))/mass0 + close (nfu) # endif # endif - open (unit = nfu, file = 'trcbud', position = 'append') - write (nfu, '(i8,6e12.4)') nstep - 1, & - (trdp(2, m) - trdp(1, m))/mass0, & - (trdp(3, m) - trdp(2, m))/mass0, & - (trdp(4, m) - trdp(3, m))/mass0, & - (trdp(5, m) - trdp(4, m) + trf*g)/mass0, & - (trdp(6, m) - trdp(5, m))/mass0, & - (trdp(7, m) - trdp(6, m))/mass0 - close (nfu) - open (unit = nfu, file = 'trcbudtot', position = 'append') - write (nfu, '(i8,7e18.10)') nstep - 1, & - trdp(1, m)/mass0, trdp(2, m)/mass0, trdp(3, m)/mass0, & - trdp(4, m)/mass0, trdp(5, m)/mass0, trdp(6, m)/mass0, & - trdp(7, m)/mass0 - close (nfu) + open (unit = nfu, file = 'trcbud', position = 'append') + write (nfu, '(i8,6e12.4)') nstep - 1, & + (trdp(2, m) - trdp(1, m))/mass0, & + (trdp(3, m) - trdp(2, m))/mass0, & + (trdp(4, m) - trdp(3, m))/mass0, & + (trdp(5, m) - trdp(4, m) + trf*g)/mass0, & + (trdp(6, m) - trdp(5, m))/mass0, & + (trdp(7, m) - trdp(6, m))/mass0 + close (nfu) + open (unit = nfu, file = 'trcbudtot', position = 'append') + write (nfu, '(i8,7e18.10)') nstep - 1, & + trdp(1, m)/mass0, trdp(2, m)/mass0, trdp(3, m)/mass0, & + trdp(4, m)/mass0, trdp(5, m)/mass0, trdp(6, m)/mass0, & + trdp(7, m)/mass0 + close (nfu) #endif + + else + + open (unit = nfu, file = 'salbud', position = 'append') + write (nfu, '(i8,6e12.4)') nstep - 1, & + (sdp(2, m) - sdp(1, m))/mass0, & + (sdp(3, m) - sdp(2, m))/mass0, & + (sdp(4, m) - sdp(3, m) + sf*g)/mass0, & + (sdp(5, m) - sdp(4, m))/mass0, & + (sdp(6, m) - sdp(5, m))/mass0, & + (sdp(7, m) - sdp(6, m))/mass0 + close (nfu) + open (unit = nfu, file = 'tembud', position = 'append') + write (nfu, '(i8,6e12.4)') nstep - 1, & + (tdp(2, m) - tdp(1, m))/mass0, & + (tdp(3, m) - tdp(2, m))/mass0, & + (tdp(4, m) - tdp(3, m) + tf*g/spcifh)/mass0, & + (tdp(5, m) - tdp(4, m))/mass0, & + (tdp(6, m) - tdp(5, m))/mass0, & + (tdp(7, m) - tdp(6, m))/mass0 + close (nfu) +#ifdef TRC +# ifdef TKE + open (unit = nfu, file = 'tkebud', position = 'append') + write (nfu, '(i8,6e12.4)') nstep - 1, & + (tkedp(2, m) - tkedp(1, m))/mass0, & + (tkedp(3, m) - tkedp(2, m))/mass0, & + (tkedp(4, m) - tkedp(3, m))/mass0, & + (tkedp(5, m) - tkedp(4, m))/mass0, & + (tkedp(6, m) - tkedp(5, m))/mass0, & + (tkedp(7, m) - tkedp(6, m))/mass0 + close (nfu) +# ifdef GLS + open (unit = nfu, file = 'glsbud', position = 'append') + write (nfu, '(i8,6e12.4)') nstep - 1, & + (glsdp(2, m) - glsdp(1, m))/mass0, & + (glsdp(3, m) - glsdp(2, m))/mass0, & + (glsdp(4, m) - glsdp(3, m))/mass0, & + (glsdp(5, m) - glsdp(4, m))/mass0, & + (glsdp(6, m) - glsdp(5, m))/mass0, & + (glsdp(7, m) - glsdp(6, m))/mass0 + close (nfu) +# endif +# endif + open (unit = nfu, file = 'trcbud', position = 'append') + write (nfu, '(i8,6e12.4)') nstep - 1, & + (trdp(2, m) - trdp(1, m))/mass0, & + (trdp(3, m) - trdp(2, m))/mass0, & + (trdp(4, m) - trdp(3, m) + trf*g)/mass0, & + (trdp(5, m) - trdp(4, m))/mass0, & + (trdp(6, m) - trdp(5, m))/mass0, & + (trdp(7, m) - trdp(6, m))/mass0 + close (nfu) + open (unit = nfu, file = 'trcbudtot', position = 'append') + write (nfu, '(i8,7e18.10)') nstep - 1, & + trdp(1, m)/mass0, trdp(2, m)/mass0, trdp(3, m)/mass0, & + trdp(4, m)/mass0, trdp(5, m)/mass0, trdp(6, m)/mass0, & + trdp(7, m)/mass0 + close (nfu) +#endif + + endif + endif + !$omp parallel do private(l, i) do j = 1, jj do l = 1, isp(j) diff --git a/phy/mod_cmnfld.F90 b/phy/mod_cmnfld.F90 index eb12c6fc..6fe55510 100644 --- a/phy/mod_cmnfld.F90 +++ b/phy/mod_cmnfld.F90 @@ -1,5 +1,5 @@ ! ------------------------------------------------------------------------------ -! Copyright (C) 2015-2020 Mats Bentsen +! Copyright (C) 2015-2022 Mats Bentsen ! ! This file is part of BLOM. ! @@ -24,17 +24,8 @@ module mod_cmnfld ! ------------------------------------------------------------------------------ use mod_types, only: r8 - use mod_constants, only: g, alpha0, epsil, spval, onem, onecm, onemm + use mod_constants, only: spval use mod_xc - use mod_vcoord, only: vcoord_type_tag, isopyc_bulkml, cntiso_hybrid - use mod_grid, only: scuxi, scvyi - use mod_eos, only: rho, p_alpha - use mod_state, only: dp, temp, saln, p, phi, kfpla -! use mod_dia, only : nphy, ACC_BFSQ, ACC_MLTS, ACC_MLTSMN, ACC_MLTSMX, & -! ACC_MLTSSQ, ACC_T20D, ACC_DZ, ACC_DZLVL - use mod_diffusion, only: eitmth, edritp - use mod_utility, only: util1 - use mod_checksum, only: csdiag, chksummsk implicit none @@ -76,801 +67,12 @@ module mod_cmnfld mlts ! Mixed layer depth defined by density ! criterion [cm]. - public :: bfsqi, z, bfsql, nslpx, nslpy, nnslpx, nnslpy, dz, mlts, & - inivar_cmnfld, cmnfld + public :: sls0, slsmfq, slsels, bfsqmn, dbcrit, & + bfsqi, bfsqf, z, bfsql, nslpx, nslpy, nnslpx, nnslpy, dz, mlts, & + inivar_cmnfld contains - ! --------------------------------------------------------------------------- - ! Private procedures. - ! --------------------------------------------------------------------------- - - subroutine cmnfld_bfsqf_isopyc_bulkml(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 - ! interfaces. - ! --------------------------------------------------------------------------- - - integer, intent(in) :: m, n, mm, nn, k1m, k1n - - real(r8), dimension(kdm) :: delp, bfsq, sls2, atd, btd, ctd, rtd, gam - real(r8) :: pml, q, pup, tup, sup, plo, tlo, slo, bei - integer :: i, j, k, l, km, kfpl - - ! ------------------------------------------------------------------------ - ! The BFSQ is estimated locally at layer interfaces. The filtered BFSQ is - ! smoothed in the vertical direction by solving a diffusion equation. At - ! the mixed layer base the diffusion length scale is set to the maximum of - ! sls0 and mixed layer depth (MLD) times slsmfq. Below the mixed layer, - ! the diffusion length scale approaches sls0 with an e-folding length - ! scale of MLD times slsels. - ! ------------------------------------------------------------------------ - - !$omp parallel do private(l, i, kfpl, k, pml, delp, bfsq, q, sls2, & - !$omp pup, tup, sup, km, plo, tlo, slo, & - !$omp ctd, btd, rtd, atd, bei, gam) - do j = - 1, jj + 2 - do l = 1, isp(j) - do i = max(- 1, ifp(j, l)), min(ii + 2, ilp(j, l)) - - ! Compute BFSQ in the mixed layer. - bfsqi(i, j, 1) = & - .5_r8*g*g*( rho(p(i, j, 2), & - temp(i, j, 2 + mm), saln(i, j, 2 + mm)) & - - rho(p(i, j, 2), & - temp(i, j, 1 + mm), saln(i, j, 1 + mm))) & - /(dp(i, j, 1 + mm) + dp(i, j, 2 + mm)) - bfsqi(i, j, 2) = bfsqi(i, j, 1) - bfsql(i, j, 1) = bfsqi(i, j, 1) - bfsql(i, j, 2) = bfsqi(i, j, 1) - - kfpl = kfpla(i, j, m) - - if (kfpl > kk) then - - ! If the mixed layer extends to the bottom, propagate the - ! interface and layer BFSQ of the mixed layer downwards while the - ! filtered BFSQ is set to a minimum value. - do k = 3, kk - bfsqi(i, j, k) = bfsqi(i, j, 1) - bfsql(i, j, k) = bfsqi(i, j, 1) - enddo - bfsqi(i, j, kk + 1) = bfsqi(i, j, 1) - do k = 1, kk + 1 - bfsqf(i, j, k) = bfsqmn - enddo - - else - - ! At layer interfaces, compute BFSQ and length scale for the - ! subsequent smoothing. - pml = max(.5_r8*(p(i, j, 3) + p(i, j, 1)), & - .5_r8*(3._r8*p(i, j, 3) - p(i, j, kfpl + 1))) - delp(kfpl - 1) = pml - p(i, j, 1) - bfsqi(i, j, kfpl - 1) = bfsqi(i, j, 2) - bfsq(kfpl - 1) = bfsqmn - q = max(sls0, delp(kfpl - 1)*slsmfq) - sls2(kfpl - 1) = q*q - pup = pml - tup = temp(i, j, 2 + mm) - sup = saln(i, j, 2 + mm) - do k = kfpl, kk - km = k + mm - if (p(i, j, kk + 1) - p(i, j, k) < epsil) then - delp(k) = onemm - bfsqi(i, j, k) = bfsqi(i, j, k - 1) - bfsq(k) = bfsqmn - q = exp(- (p(i, j, kk + 1) - pml)/(slsels*delp(kfpl - 1))) - q = max(sls0, delp(kfpl - 1)*slsmfq*q + sls0*(1._r8 - q)) - sls2(k) = q*q - else - if (p(i, j, kk + 1) - p(i, j, k + 1) < epsil) then - plo = p(i, j, kk + 1) - else - plo = .5_r8*(p(i, j, k) + p(i, j, k + 1)) - endif - tlo = temp(i, j, km) - slo = saln(i, j, km) - delp(k) = max(onemm, plo - pup) - bfsqi(i, j, k) = g*g*( rho(p(i, j, k), tlo, slo) & - - rho(p(i, j, k), tup, sup))/delp(k) - bfsq(k) = max(bfsqmn, bfsqi(i, j, k)) - bfsqi(i, j, k) = bfsqi(i, j, k)*delp(k)/max(onem, delp(k)) - if (p(i, j, kk + 1) - p(i, j, k) < onem) then - bfsqi(i, j, k) = bfsqi(i, j, k - 1) - endif - q = exp(- (p(i, j, k) - pml)/(slsels*delp(kfpl - 1))) - q = max(sls0, delp(kfpl - 1)*slsmfq*q + sls0*(1._r8 - q)) - sls2(k) = q*q - pup = plo - tup = tlo - sup = slo - endif - enddo - - ! Compute the layer BFSQ as the arithmetic mean of the layer - ! interface BFSQ. - do k = kfpl, kk - 1 - bfsql(i, j, k) = .5_r8*(bfsqi(i, j, k) + bfsqi(i, j, k + 1)) - enddo - bfsql(i, j, kk) = bfsqi(i, j, kk) - do k = 3, kfpl - 1 - bfsqi(i, j, k) = bfsqi(i, j, kfpl) - bfsql(i, j, k) = bfsql(i, j, kfpl) - enddo - - ! For the filtered BFSQ, compute the coefficients for the - ! tridiagonal set of equations arising from the implicit backward - ! discretization. - k = kfpl - 1 - ctd(k) = - 2._r8*sls2(k ) & - /(delp(k)*(delp(k ) + delp(k + 1))) - btd(k) = 1._r8 - ctd(k) - rtd(k) = bfsq(k) - do k = kfpl, kk - 1 - atd(k) = - 2._r8*sls2(k - 1) & - /(delp(k)*(delp(k - 1) + delp(k ))) - ctd(k) = - 2._r8*sls2(k ) & - /(delp(k)*(delp(k ) + delp(k + 1))) - btd(k) = 1._r8 - atd(k) - ctd(k) - rtd(k) = bfsq(k) - enddo - k = kk - atd(k) = - 2._r8*sls2(k - 1) & - /(delp(k)*(delp(k - 1) + delp(k ))) - btd(k) = 1._r8 - atd(k) - rtd(k) = bfsq(k) - - ! Solve the tridiagonal set of equations. - bei = 1._r8/btd(kfpl - 1) - bfsqf(i, j, kfpl - 1) = rtd(kfpl - 1)*bei - do k = kfpl, kk - gam(k) = ctd(k - 1)*bei - bei = 1._r8/(btd(k) - atd(k)*gam(k)) - bfsqf(i, j, k) = (rtd(k) - atd(k)*bfsqf(i, j, k - 1))*bei - enddo - do k = kk - 1, kfpl - 1, - 1 - bfsqf(i, j, k) = bfsqf(i, j, k) & - - gam(k + 1)*bfsqf(i, j, k + 1) - enddo - do k = 1, kfpl - 2 - bfsqf(i, j, k) = bfsqf(i, j, kfpl - 1) - enddo - - ! Extrapolate to the bottom interface. - bfsqi(i, j, kk + 1) = bfsqi(i, j, kk) - bfsqf(i, j, kk + 1) = bfsqf(i, j, kk) - - endif - - enddo - enddo - enddo - !$omp end parallel do - - if (csdiag) then - if (mnproc == 1) then - write(lp,*) 'cmnfld_bfsqf_isopyc_bulkml:' - 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_isopyc_bulkml - - subroutine cmnfld_bfsqf_cntiso_hybrid(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 - ! interfaces. - ! --------------------------------------------------------------------------- - - integer, intent(in) :: m, n, mm, nn, k1m, k1n - - real(r8), dimension(kdm) :: delp, bfsq, sls2, atd, btd, ctd, rtd, gam - real(r8) :: pup, tup, sup, plo, tlo, slo, bei - integer :: i, j, k, l, km - - ! ------------------------------------------------------------------------ - ! The BFSQ is estimated locally at layer interfaces. The filtered BFSQ is - ! smoothed in the vertical direction by solving a diffusion equation. - ! ------------------------------------------------------------------------ - - bfsqi = 0.0_r8 - bfsql = 0.0_r8 - !$omp parallel do private(l, i, k, delp, bfsq, sls2, pup, tup, sup, km, & - !$omp plo, tlo, slo, ctd, btd, rtd, atd, bei, gam) - do j = - 1, jj + 2 - do l = 1, isp(j) - do i = max(- 1, ifp(j, l)), min(ii + 2, ilp(j, l)) - - ! At layer interfaces, compute BFSQ and length scale for the - ! subsequent smoothing. - bfsqi(i, j, 1) = bfsqmn - pup = .5_r8*(p(i, j, 1) + p(i, j, 2)) - tup = temp(i, j, 1 + mm) - sup = saln(i, j, 1 + mm) - do k = 2, kk - km = k + mm - if (p(i, j, kk + 1) - p(i, j, k) < epsil) then - delp(k) = onemm - bfsqi(i, j, k) = bfsqi(i, j, k - 1) - bfsq(k) = bfsqmn - sls2(k) = sls0*sls0 - else - if (p(i, j, kk + 1) - p(i, j, k + 1) < epsil) then - plo = p(i, j, kk + 1) - else - plo = .5_r8*(p(i, j, k) + p(i, j, k + 1)) - endif - tlo = temp(i, j, km) - slo = saln(i, j, km) - delp(k) = max(onemm, plo - pup) - bfsqi(i, j, k) = g*g*( rho(p(i, j, k), tlo, slo) & - - rho(p(i, j, k), tup, sup))/delp(k) - bfsq(k) = max(bfsqmn, bfsqi(i, j, k)) - bfsqi(i, j, k) = bfsqi(i, j, k)*delp(k)/max(onem, delp(k)) - if (p(i, j, kk + 1) - p(i, j, k) < onem) then - bfsqi(i, j, k) = bfsqi(i, j, k - 1) - endif - sls2(k) = sls0*sls0 - pup = plo - tup = tlo - sup = slo - endif - enddo - delp(1) = dp(i, j, 1 + mm) - bfsqi(i, j, 1) = bfsqi(i, j, 2) - bfsq(1) = max(bfsqmn, bfsqi(i, j, 1)) - sls2(1) = sls0*sls0 - - ! Compute the layer BFSQ as the arithmetic mean of the layer - ! interface BFSQ. - do k = 1, kk - 1 - bfsql(i, j, k) = .5_r8*(bfsqi(i, j, k) + bfsqi(i, j, k + 1)) - enddo - bfsql(i, j, kk) = bfsqi(i, j, kk) - - ! For the filtered BFSQ, compute the coefficients for the - ! tridiagonal set of equations arising from the implicit backward - ! discretization. - k = 1 - ctd(k) = - 2._r8*sls2(k ) & - /(delp(k)*(delp(k ) + delp(k + 1))) - btd(k) = 1._r8 - ctd(k) - rtd(k) = bfsq(k) - do k = 2, kk - 1 - atd(k) = - 2._r8*sls2(k - 1) & - /(delp(k)*(delp(k - 1) + delp(k ))) - ctd(k) = - 2._r8*sls2(k ) & - /(delp(k)*(delp(k ) + delp(k + 1))) - btd(k) = 1._r8 - atd(k) - ctd(k) - rtd(k) = bfsq(k) - enddo - k = kk - atd(k) = - 2._r8*sls2(k - 1) & - /(delp(k)*(delp(k - 1) + delp(k ))) - btd(k) = 1._r8 - atd(k) - rtd(k) = bfsq(k) - - ! Solve the tridiagonal set of equations. - bei = 1._r8/btd(1) - bfsqf(i, j, 1) = rtd(1)*bei - do k = 2, kk - gam(k) = ctd(k - 1)*bei - bei = 1._r8/(btd(k) - atd(k)*gam(k)) - bfsqf(i, j, k) = (rtd(k) - atd(k)*bfsqf(i, j, k - 1))*bei - enddo - do k = kk - 1, 1, - 1 - bfsqf(i, j, k) = bfsqf(i, j, k) - gam(k + 1)*bfsqf(i, j, k + 1) - enddo - - ! Extrapolate to the bottom interface. - bfsqi(i, j, kk + 1) = bfsqi(i, j, kk) - bfsqf(i, j, kk + 1) = bfsqf(i, j, kk) - - enddo - enddo - enddo - !$omp end parallel do - - if (csdiag) then - if (mnproc == 1) then - write(lp,*) 'cmnfld_bfsqf_cntiso_hybrid:' - 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 - - subroutine cmnfld_nslope_isopyc_bulkml(m, n, mm, nn, k1m, k1n) - ! --------------------------------------------------------------------------- - ! Estimate slope of local neutral surface. - ! --------------------------------------------------------------------------- - - integer, intent(in) :: m, n, mm, nn, k1m, k1n - - real(r8) :: rho0, pm, rho_x, phi_x, bfsqm, rho_y, phi_y - integer :: i, j, k, l, km, kintr, kmax, knnsl - - ! ------------------------------------------------------------------------ - ! Compute geopotential at layer interfaces. - ! ------------------------------------------------------------------------ - - !$omp parallel do private(k, km, l, i) - do j = - 1, jj + 2 - do k = kk, 1, - 1 - km = k + mm - do l = 1, isp(j) - do i = max(- 1, ifp(j, l)), min(ii + 2, ilp(j, l)) - if (dp(i, j, km) < epsil) then - phi(i, j, k) = phi(i, j, k + 1) - else - phi(i, j, k) = phi(i, j, k + 1) & - - p_alpha(p(i, j, k + 1), p(i, j, k), & - temp(i, j, km), saln(i, j, km)) - endif - enddo - enddo - enddo - enddo - !$omp end parallel do - - ! ------------------------------------------------------------------------ - ! Compute slope vector of local neutral surfaces and also slope vector - ! times Brunt-Vaisala frequency (optionally used in the computation of - ! eddy growth rate). The latter is not computed when the gradient of the - ! geopotential is expected to be influenced by the gradient of the - ! bathymetry and in this case values are extrapolated from above. - ! ------------------------------------------------------------------------ - - rho0 = 1._r8/alpha0 - - !$omp parallel do private(l, i, k, kmax, km, kintr, knnsl, pm, rho_x, & - !$omp phi_x, bfsqm) - do j = - 1, jj + 2 - do l = 1, isu(j) - do i = max(0, ifu(j, l)), min(ii + 2, ilu(j, l)) - - ! Set the x-component of the slope vector to zero initially. - do k = 1, kk - nslpx(i, j, k) = 0._r8 - nnslpx(i, j, k) = 0._r8 - enddo - - if (kfpla(i - 1, j, m) <= kk .or. kfpla(i, j, m) <= kk) then - - ! Index of last layer containing mass at either of the scalar - ! points adjacent to the velocity point. - kmax = 1 - do k = 3, kk - km = k + mm - if (dp(i - 1, j, km) > epsil .or. dp(i, j, km) > epsil) & - kmax = k - enddo - - ! The first interior interface where the x-component of the slope - ! vector is estimated is at index kintr + 1. - kintr = max(kfpla(i - 1, j, m), kfpla(i, j, m)) - - ! Index of last interface where slope vector times Brunt-Vaisala - ! frequency is computed. - knnsl = 2 - - ! Compute the x-component of the slope vector at the mixed layer - ! base. - pm = .5_r8*(p(i - 1, j, 3) + p(i, j, 3)) - rho_x = rho(pm, temp(i , j, 2 + mm), saln(i , j, 2 + mm)) & - - rho(pm, temp(i - 1, j, 2 + mm), saln(i - 1, j, 2 + mm)) - phi_x = phi(i, j, 3) - phi(i - 1, j, 3) - bfsqm = .5_r8*(bfsqf(i - 1, j, 3) + bfsqf(i, j, 3)) - nslpx(i, j, 3) = (g*rho_x/(rho0*bfsqm) + phi_x/g)*scuxi(i, j) - if (phi(i , j, 3) > phi(i - 1, j, kk + 1) .and. & - phi(i - 1, j, 3) > phi(i , j, kk + 1)) then - nnslpx(i, j, 3) = sqrt(bfsqm)*nslpx(i, j, 3) - knnsl = 3 - endif - - ! Compute the x-component of the slope vector at interior - ! interfaces. - do k = kintr + 1, kmax - km = k + mm - pm = .5_r8*(p(i - 1, j, k) + p(i, j, k)) - rho_x = .5_r8*( rho(pm, temp(i , j, km - 1), & - saln(i , j, km - 1)) & - - rho(pm, temp(i - 1, j, km - 1), & - saln(i - 1, j, km - 1)) & - + rho(pm, temp(i , j, km ), & - saln(i , j, km )) & - - rho(pm, temp(i - 1, j, km ), & - saln(i - 1, j, km ))) - phi_x = phi(i, j, k) - phi(i - 1, j, k) - bfsqm = .5_r8*(bfsqf(i - 1, j, k) + bfsqf(i, j, k)) - nslpx(i, j, k) = (g*rho_x/(rho0*bfsqm) + phi_x/g)*scuxi(i, j) - if (phi(i , j, k) > phi(i - 1, j, kk + 1) .and. & - phi(i - 1, j, k) > phi(i , j, kk + 1)) then - nnslpx(i, j, k) = sqrt(bfsqm)*nslpx(i, j, k) - knnsl = k - endif - enddo - do k = knnsl + 1, kmax - nnslpx(i, j, k) = nnslpx(i, j, knnsl) - enddo - if (kintr < kmax) then - do k = 4, kintr - nslpx(i, j, k) = nslpx(i, j, kintr + 1) - nnslpx(i, j, k) = nnslpx(i, j, kintr + 1) - enddo - else - do k = 4, kmax - nslpx(i, j, k) = nslpx(i, j, 3) - nnslpx(i, j, k) = nnslpx(i, j, 3) - enddo - endif - - endif - - enddo - enddo - enddo - !$omp end parallel do - - !$omp parallel do private(l, i, k, kmax, km, kintr, knnsl, pm, rho_y, & - !$omp phi_y, bfsqm) - do j = 0, jj + 2 - do l = 1, isv(j) - do i = max(- 1, ifv(j, l)), min(ii + 2, ilv(j, l)) - - ! Set the y-component of the slope vector to zero initially. - do k = 1, kk - nslpy(i, j, k) = 0._r8 - nnslpy(i, j, k) = 0._r8 - enddo - - if (kfpla(i, j - 1, m) <= kk .or. kfpla(i, j, m) <= kk) then - - ! Index of last layer containing mass at either of the scalar - ! points adjacent to the velocity point. - kmax = 1 - do k = 3, kk - km = k + mm - if (dp(i, j - 1, km) > epsil .or. dp(i, j, km) > epsil) & - kmax = k - enddo - - ! The first interior interface where the y-component of the slope - ! vector is estimated is at index kintr + 1. - kintr = max(kfpla(i, j - 1, m), kfpla(i, j, m)) - - ! Index of last interface where slope vector times Brunt-Vaisala - ! frequency is computed. - knnsl = 2 - - ! Compute the y-component of the slope vector at the mixed layer - ! base. - pm = .5_r8*(p(i, j - 1, 3) + p(i, j, 3)) - rho_y = rho(pm, temp(i, j , 2 + mm), saln(i, j , 2 + mm)) & - - rho(pm, temp(i, j - 1, 2 + mm), saln(i, j - 1, 2 + mm)) - phi_y = phi(i, j, 3) - phi(i, j - 1, 3) - bfsqm = .5_r8*(bfsqf(i, j - 1, 3) + bfsqf(i, j, 3)) - nslpy(i, j, 3) = (g*rho_y/(rho0*bfsqm) + phi_y/g)*scvyi(i, j) - if (phi(i, j , 3) > phi(i, j - 1, kk + 1) .and. & - phi(i, j - 1, 3) > phi(i, j , kk + 1)) then - nnslpy(i, j, 3) = sqrt(bfsqm)*nslpy(i, j, 3) - knnsl = 3 - endif - - ! Compute the y-component of the slope vector at interior - ! interfaces. - do k = kintr + 1, kmax - km = k + mm - pm = .5_r8*(p(i, j - 1, k) + p(i, j, k)) - rho_y = .5_r8*( rho(pm, temp(i, j , km - 1), & - saln(i, j , km - 1)) & - - rho(pm, temp(i, j - 1, km - 1), & - saln(i, j - 1, km - 1)) & - + rho(pm, temp(i, j , km ), & - saln(i, j , km )) & - - rho(pm, temp(i, j - 1, km ), & - saln(i, j - 1, km ))) - phi_y = phi(i, j, k) - phi(i, j - 1, k) - bfsqm = .5_r8*(bfsqf(i, j - 1, k) + bfsqf(i, j, k)) - nslpy(i, j, k) = (g*rho_y/(rho0*bfsqm) + phi_y/g)*scvyi(i, j) - if (phi(i, j , k) > phi(i, j - 1, kk + 1) .and. & - phi(i, j - 1, k) > phi(i, j , kk + 1)) then - nnslpy(i, j, k) = sqrt(bfsqm)*nslpy(i, j, k) - knnsl = k - endif - enddo - do k = knnsl + 1, kmax - nnslpy(i, j, k) = nnslpy(i, j, knnsl) - enddo - if (kintr < kmax) then - do k = 4, kintr - nslpy(i, j, k) = nslpy(i, j, kintr + 1) - nnslpy(i, j, k) = nnslpy(i, j, kintr + 1) - enddo - else - do k = 4, kmax - nslpy(i, j, k) = nslpy(i, j, 3) - nnslpy(i, j, k) = nnslpy(i, j, 3) - enddo - endif - - endif - - enddo - enddo - enddo - !$omp end parallel do - - if (csdiag) then - if (mnproc == 1) then - write (lp,*) 'cmnfld_nslope_isopyc_bulkml:' - endif - call chksummsk(nslpx, iu, kk, 'nslpx') - call chksummsk(nslpy, iv, kk, 'nslpy') - call chksummsk(nnslpx, iu, kk, 'nnslpx') - call chksummsk(nnslpy, iv, kk, 'nnslpy') - endif - - end subroutine cmnfld_nslope_isopyc_bulkml - - subroutine cmnfld_nslope_cntiso_hybrid(m, n, mm, nn, k1m, k1n) - ! --------------------------------------------------------------------------- - ! Estimate slope of local neutral surface. - ! --------------------------------------------------------------------------- - - integer, intent(in) :: m, n, mm, nn, k1m, k1n - - real(r8) :: rho0, pm, rho_x, phi_x, bfsqm, rho_y, phi_y - integer :: i, j, k, l, km, kmax, knnsl - - ! ------------------------------------------------------------------------ - ! Compute geopotential at layer interfaces. - ! ------------------------------------------------------------------------ - - !$omp parallel do private(k, km, l, i) - do j = - 1, jj + 2 - do k = kk, 1, - 1 - km = k + mm - do l = 1, isp(j) - do i = max(- 1, ifp(j, l)), min(ii + 2, ilp(j, l)) - if (dp(i, j, km) < epsil) then - phi(i, j, k) = phi(i, j, k + 1) - else - phi(i, j, k) = phi(i, j, k + 1) & - - p_alpha(p(i, j, k + 1), p(i, j, k), & - temp(i, j, km), saln(i, j, km)) - endif - enddo - enddo - enddo - enddo - !$omp end parallel do - - ! ------------------------------------------------------------------------ - ! Compute slope vector of local neutral surfaces and also slope vector - ! times Brunt-Vaisala frequency (optionally used in the computation of - ! eddy growth rate). The latter is not computed when the gradient of the - ! geopotential is expected to be influenced by the gradient of the - ! bathymetry and in this case values are extrapolated from above. - ! ------------------------------------------------------------------------ - - rho0 = 1._r8/alpha0 - - !$omp parallel do private(l, i, k, kmax, km, knnsl, pm, rho_x, phi_x, bfsqm) - do j = - 1, jj + 2 - do l = 1, isu(j) - do i = max(0, ifu(j, l)), min(ii + 2, ilu(j, l)) - - ! Set the x-component of the slope vector to zero initially. - do k = 1, kk - nslpx(i, j, k) = 0._r8 - nnslpx(i, j, k) = 0._r8 - enddo - - ! Index of last layer containing mass at either of the scalar - ! points adjacent to the velocity point. - kmax = 1 - do k = 2, kk - km = k + mm - if (dp(i - 1, j, km) > epsil .or. dp(i, j, km) > epsil) kmax = k - enddo - - ! Index of last interface where slope vector times Brunt-Vaisala - ! frequency is computed. - knnsl = 2 - - ! Compute the x-component of the slope vector at interfaces. - do k = 2, kmax - km = k + mm - pm = .5_r8*(p(i - 1, j, k) + p(i, j, k)) - rho_x = .5_r8*( rho(pm, temp(i , j, km - 1), & - saln(i , j, km - 1)) & - - rho(pm, temp(i - 1, j, km - 1), & - saln(i - 1, j, km - 1)) & - + rho(pm, temp(i , j, km ), & - saln(i , j, km )) & - - rho(pm, temp(i - 1, j, km ), & - saln(i - 1, j, km ))) - phi_x = phi(i, j, k) - phi(i - 1, j, k) - bfsqm = .5_r8*(bfsqf(i - 1, j, k) + bfsqf(i, j, k)) - nslpx(i, j, k) = (g*rho_x/(rho0*bfsqm) + phi_x/g)*scuxi(i, j) - if (phi(i , j, k) > phi(i - 1, j, kk + 1) .and. & - phi(i - 1, j, k) > phi(i , j, kk + 1)) then - nnslpx(i, j, k) = sqrt(bfsqm)*nslpx(i, j, k) - knnsl = k - endif - enddo - do k = knnsl + 1, kmax - nnslpx(i, j, k) = nnslpx(i, j, knnsl) - enddo - - enddo - enddo - enddo - !$omp end parallel do - - !$omp parallel do private(l, i, k, kmax, km, knnsl, pm, rho_y, phi_y, bfsqm) - do j = 0, jj + 2 - do l = 1, isv(j) - do i = max(- 1, ifv(j, l)), min(ii + 2, ilv(j, l)) - - ! Set the y-component of the slope vector to zero initially. - do k = 1, kk - nslpy(i, j, k) = 0._r8 - nnslpy(i, j, k) = 0._r8 - enddo - - ! Index of last layer containing mass at either of the scalar - ! points adjacent to the velocity point. - kmax = 1 - do k = 2, kk - km = k + mm - if (dp(i, j - 1, km) > epsil .or. dp(i, j, km) > epsil) kmax = k - enddo - - ! Index of last interface where slope vector times Brunt-Vaisala - ! frequency is computed. - knnsl = 2 - - ! Compute the y-component of the slope vector at interfaces. - do k = 2, kmax - km = k + mm - pm = .5_r8*(p(i, j - 1, k) + p(i, j, k)) - rho_y = .5_r8*( rho(pm, temp(i, j , km - 1), & - saln(i, j , km - 1)) & - - rho(pm, temp(i, j - 1, km - 1), & - saln(i, j - 1, km - 1)) & - + rho(pm, temp(i, j , km ), & - saln(i, j , km )) & - - rho(pm, temp(i, j - 1, km ), & - saln(i, j - 1, km ))) - phi_y = phi(i, j, k) - phi(i, j - 1, k) - bfsqm = .5_r8*(bfsqf(i, j - 1, k) + bfsqf(i, j, k)) - nslpy(i, j, k) = (g*rho_y/(rho0*bfsqm) + phi_y/g)*scvyi(i, j) - if (phi(i, j , k) > phi(i, j - 1, kk + 1) .and. & - phi(i, j - 1, k) > phi(i, j , kk + 1)) then - nnslpy(i, j, k) = sqrt(bfsqm)*nslpy(i, j, k) - knnsl = k - endif - enddo - do k = knnsl + 1, kmax - nnslpy(i, j, k) = nnslpy(i, j, knnsl) - enddo - - enddo - enddo - enddo - !$omp end parallel do - - if (csdiag) then - if (mnproc == 1) then - write (lp,*) 'cmnfld_nslope_cntiso_hybrid:' - endif - call chksummsk(nslpx, iu, kk, 'nslpx') - call chksummsk(nslpy, iv, kk, 'nslpy') - call chksummsk(nnslpx, iu, kk, 'nnslpx') - call chksummsk(nnslpy, iv, kk, 'nnslpy') - endif - - end subroutine cmnfld_nslope_cntiso_hybrid - - subroutine cmnfld_z(m, n, mm, nn, k1m, k1n) - ! --------------------------------------------------------------------------- - ! Estimate depth of layer interfaces and thickness of layers. - ! --------------------------------------------------------------------------- - - integer, intent(in) :: m, n, mm, nn, k1m, k1n - - integer :: i, j, k, l, km - - !$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)) - z(i, j, kk + 1) = - phi(i, j, kk + 1)/g - enddo - enddo - enddo - !$omp end parallel do - !$omp parallel do private(k, km, l, i) - do j = 1, jj - do k = kk, 1, - 1 - km = k + mm - do l = 1, isp(j) - do i = max(1, ifp(j, l)), min(ii, ilp(j, l)) - if (dp(i, j, km) < epsil) then - z(i, j, k) = z(i, j, k + 1) - else - z(i, j, k) = z(i, j, k + 1) & - + p_alpha(p(i, j, k + 1), p(i, j, k), & - temp(i, j, km), saln(i, j, km))/g - endif - dz(i, j, k) = z(i, j, k + 1) - z(i, j, k) - enddo - enddo - enddo - enddo - !$omp end parallel do - - end subroutine cmnfld_z - - subroutine cmnfld_mlts(m, n, mm, nn, k1m, k1n) - ! --------------------------------------------------------------------------- - ! Estimate mixed layer depth using density criterion. - ! --------------------------------------------------------------------------- - - integer, intent(in) :: m, n, mm, nn, k1m, k1n - - real(r8) :: zup, dbup, plo, zlo, dblo - integer :: i, j, k, l, km - - !$omp parallel do private(l, i, k, km, zup, dbup, plo, zlo, dblo) - do j = 1, jj - do l = 1, isp(j) - do i = max(1, ifp(j, l)), min(ii, ilp(j, l)) - k = 2 - km = k + mm - zup = z(i, j, 1) + .5_r8*dz(i, j, 1) - dbup = 0._r8 - do - if (dp(i, j, km) > onecm) then - plo = p(i, j, k) + .5_r8*dp(i, j, km) - zlo = z(i, j, k) + .5_r8*dz(i, j, k ) - dblo = & - g*(1._r8 - rho(plo, temp(i, j, k1m), saln(i, j, k1m)) & - /rho(plo, temp(i, j, km ), saln(i, j, km ))) - if (dblo <= dbcrit) then - zup = zlo - dbup = dblo - else - dbup = min(dbup, dbcrit - epsil) - mlts(i, j) = ( zup*(dblo - dbcrit) & - + zlo*(dbcrit - dbup))/(dblo - dbup) & - - z(i, j, 1) - exit - endif - endif - k = k + 1 - if (k > kk) then - mlts(i, j) = z(i, j, kk + 1) - z(i, j, 1) - exit - endif - km = k + mm - enddo - enddo - enddo - enddo - !$omp end parallel do - - end subroutine cmnfld_mlts - ! --------------------------------------------------------------------------- ! Public procedures. ! --------------------------------------------------------------------------- @@ -909,105 +111,4 @@ subroutine inivar_cmnfld end subroutine inivar_cmnfld - subroutine cmnfld(m, n, mm, nn, k1m, k1n) - ! --------------------------------------------------------------------------- - ! Compute fields that are used by several subsequent routines - ! --------------------------------------------------------------------------- - - integer, intent(in) :: m, n, mm, nn, k1m, k1n - - integer :: i, j, l - - ! ------------------------------------------------------------------------ - ! Update halos of various fields. - ! ------------------------------------------------------------------------ - - call xctilr(temp, 1, 2*kk, 3, 3, halo_ps) - call xctilr(saln, 1, 2*kk, 3, 3, halo_ps) -! 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) - !$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)) - util1(i, j) = kfpla(i, j, m) - enddo - enddo - enddo - !$omp end parallel do - call xctilr(util1, 1, 1, 2, 2, halo_ps) - !$omp parallel do private(l, i) - do j = - 1, jj + 2 - do l = 1, isp(j) - do i = max(- 1, ifp(j, l)), min(ii + 2, ilp(j, l)) - kfpla(i, j, m) = nint(util1(i, j)) - enddo - enddo - enddo - !$omp end parallel do - - ! ------------------------------------------------------------------------ - ! Compute fields depending on selection of physics and diagnostics. - ! ------------------------------------------------------------------------ - -! if (vcoord_type_tag == cntiso_hybrid .or. & -! edritp == 'large scale' .or. eitmth == 'gm' .or. & -! sum(ACC_BFSQ(1:nphy)) /= 0) then - if (vcoord_type_tag == cntiso_hybrid .or. & - edritp == 'large scale' .or. eitmth == 'gm') then - - ! --------------------------------------------------------------------- - ! Compute filtered buoyancy frequency squared. - ! --------------------------------------------------------------------- - - if (vcoord_type_tag == 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) - endif - - endif - - if (edritp == 'large scale' .or. eitmth == 'gm') then - - ! --------------------------------------------------------------------- - ! Estimate slope of local neutral surface. - ! --------------------------------------------------------------------- - - if (vcoord_type_tag == isopyc_bulkml) then - call cmnfld_nslope_isopyc_bulkml(m, n, mm, nn, k1m, k1n) - else - call cmnfld_nslope_cntiso_hybrid(m, n, mm, nn, k1m, k1n) - endif - - endif - -! if (vcoord_type_tag == cntiso_hybrid .or. & -! sum( ACC_MLTS (1:nphy) + ACC_MLTSMN(1:nphy) & -! + ACC_MLTSMX(1:nphy) + ACC_MLTSSQ(1:nphy) & -! + ACC_T20D (1:nphy) + & -! + ACC_DZ (1:nphy) + ACC_DZLVL(1:nphy)) /= 0) then - - ! --------------------------------------------------------------------- - ! Estimate depth of layer interfaces and thickness of layers. - ! --------------------------------------------------------------------- - - call cmnfld_z(m, n, mm, nn, k1m, k1n) - -! endif - -! if (vcoord_type_tag == cntiso_hybrid .or. & -! sum( ACC_MLTS (1:nphy) + ACC_MLTSMN(1:nphy) & -! + ACC_MLTSMX(1:nphy) + ACC_MLTSSQ(1:nphy)) /= 0) then - - ! --------------------------------------------------------------------- - ! Estimate mixed layer depth using density criterion. - ! --------------------------------------------------------------------- - - call cmnfld_mlts(m, n, mm, nn, k1m, k1n) - -! endif - - end subroutine cmnfld - end module mod_cmnfld diff --git a/phy/mod_cmnfld_routines.F90 b/phy/mod_cmnfld_routines.F90 new file mode 100644 index 00000000..b01913e4 --- /dev/null +++ b/phy/mod_cmnfld_routines.F90 @@ -0,0 +1,1090 @@ +! ------------------------------------------------------------------------------ +! Copyright (C) 2015-2022 Mats Bentsen +! +! 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_cmnfld_routines +! ------------------------------------------------------------------------------ +! This module contains variables and procedures related to common fields used by +! several subsequent routines. +! ------------------------------------------------------------------------------ + + use mod_types, only: r8 + use mod_constants, only: g, alpha0, epsil, onem, onecm, onemm + use mod_xc + use mod_vcoord, only: vcoord_type_tag, isopyc_bulkml, cntiso_hybrid + use mod_grid, only: scuxi, scvyi + use mod_eos, only: rho, p_alpha + use mod_state, only: dp, temp, saln, p, phi, kfpla +! use mod_dia, only : nphy, ACC_BFSQ, ACC_MLTS, ACC_MLTSMN, ACC_MLTSMX, & +! ACC_MLTSSQ, ACC_T20D, ACC_DZ, ACC_DZLVL + use mod_cmnfld, only: sls0, slsmfq, slsels, bfsqmn, dbcrit, & + bfsqi, bfsqf, z, bfsql, nslpx, nslpy, nnslpx, nnslpy, & + dz, mlts + use mod_diffusion, only: eitmth, edritp, ntrdif + use mod_utility, only: util1 + use mod_checksum, only: csdiag, chksummsk + + implicit none + + private + + public :: cmnfld_bfsqi_cntiso_hybrid, cmnfld1, cmnfld2 + + contains + + ! --------------------------------------------------------------------------- + ! Private procedures. + ! --------------------------------------------------------------------------- + + subroutine cmnfld_bfsqf_isopyc_bulkml(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 + ! interfaces. + ! --------------------------------------------------------------------------- + + integer, intent(in) :: m, n, mm, nn, k1m, k1n + + real(r8), dimension(kdm) :: delp, bfsq, sls2, atd, btd, ctd, rtd, gam + real(r8) :: pml, q, pup, tup, sup, plo, tlo, slo, bei + integer :: i, j, k, l, kn, kfpl + + ! ------------------------------------------------------------------------ + ! The BFSQ is estimated locally at layer interfaces. The filtered BFSQ is + ! smoothed in the vertical direction by solving a diffusion equation. At + ! the mixed layer base the diffusion length scale is set to the maximum of + ! sls0 and mixed layer depth (MLD) times slsmfq. Below the mixed layer, + ! the diffusion length scale approaches sls0 with an e-folding length + ! scale of MLD times slsels. + ! ------------------------------------------------------------------------ + + !$omp parallel do private(l, i, kfpl, k, pml, delp, bfsq, q, sls2, & + !$omp pup, tup, sup, kn, plo, tlo, slo, & + !$omp ctd, btd, rtd, atd, bei, gam) + do j = - 1, jj + 2 + do l = 1, isp(j) + do i = max(- 1, ifp(j, l)), min(ii + 2, ilp(j, l)) + + ! Compute BFSQ in the mixed layer. + bfsqi(i, j, 1) = & + .5_r8*g*g*( rho(p(i, j, 2), & + temp(i, j, 2 + nn), saln(i, j, 2 + nn)) & + - rho(p(i, j, 2), & + temp(i, j, 1 + nn), saln(i, j, 1 + nn))) & + /(dp(i, j, 1 + nn) + dp(i, j, 2 + nn)) + bfsqi(i, j, 2) = bfsqi(i, j, 1) + bfsql(i, j, 1) = bfsqi(i, j, 1) + bfsql(i, j, 2) = bfsqi(i, j, 1) + + kfpl = kfpla(i, j, n) + + if (kfpl > kk) then + + ! If the mixed layer extends to the bottom, propagate the + ! interface and layer BFSQ of the mixed layer downwards while the + ! filtered BFSQ is set to a minimum value. + do k = 3, kk + bfsqi(i, j, k) = bfsqi(i, j, 1) + bfsql(i, j, k) = bfsqi(i, j, 1) + enddo + bfsqi(i, j, kk + 1) = bfsqi(i, j, 1) + do k = 1, kk + 1 + bfsqf(i, j, k) = bfsqmn + enddo + + else + + ! At layer interfaces, compute BFSQ and length scale for the + ! subsequent smoothing. + pml = max(.5_r8*(p(i, j, 3) + p(i, j, 1)), & + .5_r8*(3._r8*p(i, j, 3) - p(i, j, kfpl + 1))) + delp(kfpl - 1) = pml - p(i, j, 1) + bfsqi(i, j, kfpl - 1) = bfsqi(i, j, 2) + bfsq(kfpl - 1) = bfsqmn + q = max(sls0, delp(kfpl - 1)*slsmfq) + sls2(kfpl - 1) = q*q + pup = pml + tup = temp(i, j, 2 + nn) + sup = saln(i, j, 2 + nn) + do k = kfpl, kk + kn = k + nn + if (p(i, j, kk + 1) - p(i, j, k) < epsil) then + delp(k) = onemm + bfsqi(i, j, k) = bfsqi(i, j, k - 1) + bfsq(k) = bfsqmn + q = exp(- (p(i, j, kk + 1) - pml)/(slsels*delp(kfpl - 1))) + q = max(sls0, delp(kfpl - 1)*slsmfq*q + sls0*(1._r8 - q)) + sls2(k) = q*q + else + if (p(i, j, kk + 1) - p(i, j, k + 1) < epsil) then + plo = p(i, j, kk + 1) + else + plo = .5_r8*(p(i, j, k) + p(i, j, k + 1)) + endif + tlo = temp(i, j, kn) + slo = saln(i, j, kn) + delp(k) = max(onemm, plo - pup) + bfsqi(i, j, k) = g*g*( rho(p(i, j, k), tlo, slo) & + - rho(p(i, j, k), tup, sup))/delp(k) + bfsq(k) = max(bfsqmn, bfsqi(i, j, k)) + bfsqi(i, j, k) = bfsqi(i, j, k)*delp(k)/max(onem, delp(k)) + if (p(i, j, kk + 1) - p(i, j, k) < onem) then + bfsqi(i, j, k) = bfsqi(i, j, k - 1) + endif + q = exp(- (p(i, j, k) - pml)/(slsels*delp(kfpl - 1))) + q = max(sls0, delp(kfpl - 1)*slsmfq*q + sls0*(1._r8 - q)) + sls2(k) = q*q + pup = plo + tup = tlo + sup = slo + endif + enddo + + ! Compute the layer BFSQ as the arithmetic mean of the layer + ! interface BFSQ. + do k = kfpl, kk - 1 + bfsql(i, j, k) = .5_r8*(bfsqi(i, j, k) + bfsqi(i, j, k + 1)) + enddo + bfsql(i, j, kk) = bfsqi(i, j, kk) + do k = 3, kfpl - 1 + bfsqi(i, j, k) = bfsqi(i, j, kfpl) + bfsql(i, j, k) = bfsql(i, j, kfpl) + enddo + + ! For the filtered BFSQ, compute the coefficients for the + ! tridiagonal set of equations arising from the implicit backward + ! discretization. + k = kfpl - 1 + ctd(k) = - 2._r8*sls2(k ) & + /(delp(k)*(delp(k ) + delp(k + 1))) + btd(k) = 1._r8 - ctd(k) + rtd(k) = bfsq(k) + do k = kfpl, kk - 1 + atd(k) = - 2._r8*sls2(k - 1) & + /(delp(k)*(delp(k - 1) + delp(k ))) + ctd(k) = - 2._r8*sls2(k ) & + /(delp(k)*(delp(k ) + delp(k + 1))) + btd(k) = 1._r8 - atd(k) - ctd(k) + rtd(k) = bfsq(k) + enddo + k = kk + atd(k) = - 2._r8*sls2(k - 1) & + /(delp(k)*(delp(k - 1) + delp(k ))) + btd(k) = 1._r8 - atd(k) + rtd(k) = bfsq(k) + + ! Solve the tridiagonal set of equations. + bei = 1._r8/btd(kfpl - 1) + bfsqf(i, j, kfpl - 1) = rtd(kfpl - 1)*bei + do k = kfpl, kk + gam(k) = ctd(k - 1)*bei + bei = 1._r8/(btd(k) - atd(k)*gam(k)) + bfsqf(i, j, k) = (rtd(k) - atd(k)*bfsqf(i, j, k - 1))*bei + enddo + do k = kk - 1, kfpl - 1, - 1 + bfsqf(i, j, k) = bfsqf(i, j, k) & + - gam(k + 1)*bfsqf(i, j, k + 1) + enddo + do k = 1, kfpl - 2 + bfsqf(i, j, k) = bfsqf(i, j, kfpl - 1) + enddo + + ! Extrapolate to the bottom interface. + bfsqi(i, j, kk + 1) = bfsqi(i, j, kk) + bfsqf(i, j, kk + 1) = bfsqf(i, j, kk) + + endif + + enddo + enddo + enddo + !$omp end parallel do + + if (csdiag) then + if (mnproc == 1) then + write(lp,*) 'cmnfld_bfsqf_isopyc_bulkml:' + 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_isopyc_bulkml + + subroutine cmnfld_bfsqf_cntiso_hybrid(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 + ! interfaces. + ! --------------------------------------------------------------------------- + + integer, intent(in) :: m, n, mm, nn, k1m, k1n + + real(r8), dimension(kdm) :: delp, bfsq, sls2, atd, btd, ctd, rtd, gam + real(r8) :: pup, tup, sup, plo, tlo, slo, bei + integer :: i, j, k, l, kn + + ! ------------------------------------------------------------------------ + ! The BFSQ is estimated locally at layer interfaces. The filtered BFSQ is + ! smoothed in the vertical direction by solving a diffusion equation. + ! ------------------------------------------------------------------------ + + bfsqi = 0.0_r8 + bfsql = 0.0_r8 + !$omp parallel do private(l, i, k, delp, bfsq, sls2, pup, tup, sup, kn, & + !$omp plo, tlo, slo, ctd, btd, rtd, atd, bei, gam) + do j = - 1, jj + 2 + do l = 1, isp(j) + do i = max(- 1, ifp(j, l)), min(ii + 2, ilp(j, l)) + + ! At layer interfaces, compute BFSQ and length scale for the + ! subsequent smoothing. + bfsqi(i, j, 1) = bfsqmn + pup = .5_r8*(p(i, j, 1) + p(i, j, 2)) + tup = temp(i, j, 1 + nn) + sup = saln(i, j, 1 + nn) + do k = 2, kk + kn = k + nn + if (p(i, j, kk + 1) - p(i, j, k) < epsil) then + delp(k) = onemm + bfsqi(i, j, k) = bfsqi(i, j, k - 1) + bfsq(k) = bfsqmn + sls2(k) = sls0*sls0 + else + if (p(i, j, kk + 1) - p(i, j, k + 1) < epsil) then + plo = p(i, j, kk + 1) + else + plo = .5_r8*(p(i, j, k) + p(i, j, k + 1)) + endif + tlo = temp(i, j, kn) + slo = saln(i, j, kn) + delp(k) = max(onemm, plo - pup) + bfsqi(i, j, k) = g*g*( rho(p(i, j, k), tlo, slo) & + - rho(p(i, j, k), tup, sup))/delp(k) + bfsq(k) = max(bfsqmn, bfsqi(i, j, k)) + bfsqi(i, j, k) = bfsqi(i, j, k)*delp(k)/max(onem, delp(k)) + if (p(i, j, kk + 1) - p(i, j, k) < onem) then + bfsqi(i, j, k) = bfsqi(i, j, k - 1) + endif + sls2(k) = sls0*sls0 + pup = plo + tup = tlo + sup = slo + endif + enddo + delp(1) = dp(i, j, 1 + nn) + bfsqi(i, j, 1) = bfsqi(i, j, 2) + bfsq(1) = max(bfsqmn, bfsqi(i, j, 1)) + sls2(1) = sls0*sls0 + + ! Compute the layer BFSQ as the arithmetic mean of the layer + ! interface BFSQ. + do k = 1, kk - 1 + bfsql(i, j, k) = .5_r8*(bfsqi(i, j, k) + bfsqi(i, j, k + 1)) + enddo + bfsql(i, j, kk) = bfsqi(i, j, kk) + + ! For the filtered BFSQ, compute the coefficients for the + ! tridiagonal set of equations arising from the implicit backward + ! discretization. + k = 1 + ctd(k) = - 2._r8*sls2(k ) & + /(delp(k)*(delp(k ) + delp(k + 1))) + btd(k) = 1._r8 - ctd(k) + rtd(k) = bfsq(k) + do k = 2, kk - 1 + atd(k) = - 2._r8*sls2(k - 1) & + /(delp(k)*(delp(k - 1) + delp(k ))) + ctd(k) = - 2._r8*sls2(k ) & + /(delp(k)*(delp(k ) + delp(k + 1))) + btd(k) = 1._r8 - atd(k) - ctd(k) + rtd(k) = bfsq(k) + enddo + k = kk + atd(k) = - 2._r8*sls2(k - 1) & + /(delp(k)*(delp(k - 1) + delp(k ))) + btd(k) = 1._r8 - atd(k) + rtd(k) = bfsq(k) + + ! Solve the tridiagonal set of equations. + bei = 1._r8/btd(1) + bfsqf(i, j, 1) = rtd(1)*bei + do k = 2, kk + gam(k) = ctd(k - 1)*bei + bei = 1._r8/(btd(k) - atd(k)*gam(k)) + bfsqf(i, j, k) = (rtd(k) - atd(k)*bfsqf(i, j, k - 1))*bei + enddo + do k = kk - 1, 1, - 1 + bfsqf(i, j, k) = bfsqf(i, j, k) - gam(k + 1)*bfsqf(i, j, k + 1) + enddo + + ! Extrapolate to the bottom interface. + bfsqi(i, j, kk + 1) = bfsqi(i, j, kk) + bfsqf(i, j, kk + 1) = bfsqf(i, j, kk) + + enddo + enddo + enddo + !$omp end parallel do + + if (csdiag) then + if (mnproc == 1) then + write(lp,*) 'cmnfld_bfsqf_cntiso_hybrid:' + 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 + + subroutine cmnfld_bfsqi_cntiso_hybrid(m, n, mm, nn, k1m, k1n) + ! --------------------------------------------------------------------------- + ! Compute buoyancy frequency squared (BFSQ) on layer interfaces. + ! --------------------------------------------------------------------------- + + integer, intent(in) :: m, n, mm, nn, k1m, k1n + + real(r8) :: pup, tup, sup, plo, tlo, slo + integer :: i, j, k, l, kn + + bfsqi = 0.0_r8 + !$omp parallel do private(l, i, k, pup, tup, sup, kn, plo, tlo, slo) + do j = 1, jj + do l = 1, isp(j) + do i = max(1, ifp(j, l)), min(ii, ilp(j, l)) + bfsqi(i, j, 1) = bfsqmn + pup = .5_r8*(p(i, j, 1) + p(i, j, 2)) + tup = temp(i, j, 1 + nn) + sup = saln(i, j, 1 + nn) + do k = 2, kk + kn = k + nn + if (p(i, j, kk + 1) - p(i, j, k) < epsil) then + bfsqi(i, j, k) = bfsqi(i, j, k - 1) + else + if (p(i, j, kk + 1) - p(i, j, k + 1) < epsil) then + plo = p(i, j, kk + 1) + else + plo = .5_r8*(p(i, j, k) + p(i, j, k + 1)) + endif + tlo = temp(i, j, kn) + slo = saln(i, j, kn) + bfsqi(i, j, k) = g*g*( rho(p(i, j, k), tlo, slo) & + - rho(p(i, j, k), tup, sup)) & + /max(onem, plo - pup) + if (p(i, j, kk + 1) - p(i, j, k) < onem) then + bfsqi(i, j, k) = bfsqi(i, j, k - 1) + endif + pup = plo + tup = tlo + sup = slo + endif + enddo + bfsqi(i, j, 1) = bfsqi(i, j, 2) + bfsqi(i, j, kk + 1) = bfsqi(i, j, kk) + enddo + enddo + enddo + !$omp end parallel do + + if (csdiag) then + if (mnproc == 1) then + write(lp,*) 'cmnfld_bfsqi_cntiso_hybrid:' + endif + call chksummsk(bfsqi, ip, kk + 1, 'bfsqi') + endif + + end subroutine cmnfld_bfsqi_cntiso_hybrid + + subroutine cmnfld_nslope_isopyc_bulkml(m, n, mm, nn, k1m, k1n) + ! --------------------------------------------------------------------------- + ! Estimate slope of local neutral surface. + ! --------------------------------------------------------------------------- + + integer, intent(in) :: m, n, mm, nn, k1m, k1n + + real(r8) :: rho0, pm, rho_x, phi_x, bfsqm, rho_y, phi_y + integer :: i, j, k, l, kn, kintr, kmax, knnsl + + ! ------------------------------------------------------------------------ + ! Compute geopotential at layer interfaces. + ! ------------------------------------------------------------------------ + + !$omp parallel do private(k, kn, l, i) + do j = - 1, jj + 2 + do k = kk, 1, - 1 + kn = k + nn + do l = 1, isp(j) + do i = max(- 1, ifp(j, l)), min(ii + 2, ilp(j, l)) + if (dp(i, j, kn) < epsil) then + phi(i, j, k) = phi(i, j, k + 1) + else + phi(i, j, k) = phi(i, j, k + 1) & + - p_alpha(p(i, j, k + 1), p(i, j, k), & + temp(i, j, kn), saln(i, j, kn)) + endif + enddo + enddo + enddo + enddo + !$omp end parallel do + + ! ------------------------------------------------------------------------ + ! Compute slope vector of local neutral surfaces and also slope vector + ! times Brunt-Vaisala frequency (optionally used in the computation of + ! eddy growth rate). The latter is not computed when the gradient of the + ! geopotential is expected to be influenced by the gradient of the + ! bathymetry and in this case values are extrapolated from above. + ! ------------------------------------------------------------------------ + + rho0 = 1._r8/alpha0 + + !$omp parallel do private(l, i, k, kmax, kn, kintr, knnsl, pm, rho_x, & + !$omp phi_x, bfsqm) + do j = - 1, jj + 2 + do l = 1, isu(j) + do i = max(0, ifu(j, l)), min(ii + 2, ilu(j, l)) + + ! Set the x-component of the slope vector to zero initially. + do k = 1, kk + nslpx(i, j, k) = 0._r8 + nnslpx(i, j, k) = 0._r8 + enddo + + if (kfpla(i - 1, j, n) <= kk .or. kfpla(i, j, n) <= kk) then + + ! Index of last layer containing mass at either of the scalar + ! points adjacent to the velocity point. + kmax = 1 + do k = 3, kk + kn = k + nn + if (dp(i - 1, j, kn) > epsil .or. dp(i, j, kn) > epsil) & + kmax = k + enddo + + ! The first interior interface where the x-component of the slope + ! vector is estimated is at index kintr + 1. + kintr = max(kfpla(i - 1, j, n), kfpla(i, j, n)) + + ! Index of last interface where slope vector times Brunt-Vaisala + ! frequency is computed. + knnsl = 2 + + ! Compute the x-component of the slope vector at the mixed layer + ! base. + pm = .5_r8*(p(i - 1, j, 3) + p(i, j, 3)) + rho_x = rho(pm, temp(i , j, 2 + nn), saln(i , j, 2 + nn)) & + - rho(pm, temp(i - 1, j, 2 + nn), saln(i - 1, j, 2 + nn)) + phi_x = phi(i, j, 3) - phi(i - 1, j, 3) + bfsqm = .5_r8*(bfsqf(i - 1, j, 3) + bfsqf(i, j, 3)) + nslpx(i, j, 3) = (g*rho_x/(rho0*bfsqm) + phi_x/g)*scuxi(i, j) + if (phi(i , j, 3) > phi(i - 1, j, kk + 1) .and. & + phi(i - 1, j, 3) > phi(i , j, kk + 1)) then + nnslpx(i, j, 3) = sqrt(bfsqm)*nslpx(i, j, 3) + knnsl = 3 + endif + + ! Compute the x-component of the slope vector at interior + ! interfaces. + do k = kintr + 1, kmax + kn = k + nn + pm = .5_r8*(p(i - 1, j, k) + p(i, j, k)) + rho_x = .5_r8*( rho(pm, temp(i , j, kn - 1), & + saln(i , j, kn - 1)) & + - rho(pm, temp(i - 1, j, kn - 1), & + saln(i - 1, j, kn - 1)) & + + rho(pm, temp(i , j, kn ), & + saln(i , j, kn )) & + - rho(pm, temp(i - 1, j, kn ), & + saln(i - 1, j, kn ))) + phi_x = phi(i, j, k) - phi(i - 1, j, k) + bfsqm = .5_r8*(bfsqf(i - 1, j, k) + bfsqf(i, j, k)) + nslpx(i, j, k) = (g*rho_x/(rho0*bfsqm) + phi_x/g)*scuxi(i, j) + if (phi(i , j, k) > phi(i - 1, j, kk + 1) .and. & + phi(i - 1, j, k) > phi(i , j, kk + 1)) then + nnslpx(i, j, k) = sqrt(bfsqm)*nslpx(i, j, k) + knnsl = k + endif + enddo + do k = knnsl + 1, kmax + nnslpx(i, j, k) = nnslpx(i, j, knnsl) + enddo + if (kintr < kmax) then + do k = 4, kintr + nslpx(i, j, k) = nslpx(i, j, kintr + 1) + nnslpx(i, j, k) = nnslpx(i, j, kintr + 1) + enddo + else + do k = 4, kmax + nslpx(i, j, k) = nslpx(i, j, 3) + nnslpx(i, j, k) = nnslpx(i, j, 3) + enddo + endif + + endif + + enddo + enddo + enddo + !$omp end parallel do + + !$omp parallel do private(l, i, k, kmax, kn, kintr, knnsl, pm, rho_y, & + !$omp phi_y, bfsqm) + do j = 0, jj + 2 + do l = 1, isv(j) + do i = max(- 1, ifv(j, l)), min(ii + 2, ilv(j, l)) + + ! Set the y-component of the slope vector to zero initially. + do k = 1, kk + nslpy(i, j, k) = 0._r8 + nnslpy(i, j, k) = 0._r8 + enddo + + if (kfpla(i, j - 1, n) <= kk .or. kfpla(i, j, n) <= kk) then + + ! Index of last layer containing mass at either of the scalar + ! points adjacent to the velocity point. + kmax = 1 + do k = 3, kk + kn = k + nn + if (dp(i, j - 1, kn) > epsil .or. dp(i, j, kn) > epsil) & + kmax = k + enddo + + ! The first interior interface where the y-component of the slope + ! vector is estimated is at index kintr + 1. + kintr = max(kfpla(i, j - 1, n), kfpla(i, j, n)) + + ! Index of last interface where slope vector times Brunt-Vaisala + ! frequency is computed. + knnsl = 2 + + ! Compute the y-component of the slope vector at the mixed layer + ! base. + pm = .5_r8*(p(i, j - 1, 3) + p(i, j, 3)) + rho_y = rho(pm, temp(i, j , 2 + nn), saln(i, j , 2 + nn)) & + - rho(pm, temp(i, j - 1, 2 + nn), saln(i, j - 1, 2 + nn)) + phi_y = phi(i, j, 3) - phi(i, j - 1, 3) + bfsqm = .5_r8*(bfsqf(i, j - 1, 3) + bfsqf(i, j, 3)) + nslpy(i, j, 3) = (g*rho_y/(rho0*bfsqm) + phi_y/g)*scvyi(i, j) + if (phi(i, j , 3) > phi(i, j - 1, kk + 1) .and. & + phi(i, j - 1, 3) > phi(i, j , kk + 1)) then + nnslpy(i, j, 3) = sqrt(bfsqm)*nslpy(i, j, 3) + knnsl = 3 + endif + + ! Compute the y-component of the slope vector at interior + ! interfaces. + do k = kintr + 1, kmax + kn = k + nn + pm = .5_r8*(p(i, j - 1, k) + p(i, j, k)) + rho_y = .5_r8*( rho(pm, temp(i, j , kn - 1), & + saln(i, j , kn - 1)) & + - rho(pm, temp(i, j - 1, kn - 1), & + saln(i, j - 1, kn - 1)) & + + rho(pm, temp(i, j , kn ), & + saln(i, j , kn )) & + - rho(pm, temp(i, j - 1, kn ), & + saln(i, j - 1, kn ))) + phi_y = phi(i, j, k) - phi(i, j - 1, k) + bfsqm = .5_r8*(bfsqf(i, j - 1, k) + bfsqf(i, j, k)) + nslpy(i, j, k) = (g*rho_y/(rho0*bfsqm) + phi_y/g)*scvyi(i, j) + if (phi(i, j , k) > phi(i, j - 1, kk + 1) .and. & + phi(i, j - 1, k) > phi(i, j , kk + 1)) then + nnslpy(i, j, k) = sqrt(bfsqm)*nslpy(i, j, k) + knnsl = k + endif + enddo + do k = knnsl + 1, kmax + nnslpy(i, j, k) = nnslpy(i, j, knnsl) + enddo + if (kintr < kmax) then + do k = 4, kintr + nslpy(i, j, k) = nslpy(i, j, kintr + 1) + nnslpy(i, j, k) = nnslpy(i, j, kintr + 1) + enddo + else + do k = 4, kmax + nslpy(i, j, k) = nslpy(i, j, 3) + nnslpy(i, j, k) = nnslpy(i, j, 3) + enddo + endif + + endif + + enddo + enddo + enddo + !$omp end parallel do + + if (csdiag) then + if (mnproc == 1) then + write (lp,*) 'cmnfld_nslope_isopyc_bulkml:' + endif + call chksummsk(nslpx, iu, kk, 'nslpx') + call chksummsk(nslpy, iv, kk, 'nslpy') + call chksummsk(nnslpx, iu, kk, 'nnslpx') + call chksummsk(nnslpy, iv, kk, 'nnslpy') + endif + + end subroutine cmnfld_nslope_isopyc_bulkml + + subroutine cmnfld_nslope_cntiso_hybrid(m, n, mm, nn, k1m, k1n) + ! --------------------------------------------------------------------------- + ! Estimate slope of local neutral surface. + ! --------------------------------------------------------------------------- + + integer, intent(in) :: m, n, mm, nn, k1m, k1n + + real(r8) :: rho0, pm, rho_x, phi_x, bfsqm, rho_y, phi_y + integer :: i, j, k, l, kn, kmax, knnsl + + ! ------------------------------------------------------------------------ + ! Compute geopotential at layer interfaces. + ! ------------------------------------------------------------------------ + + !$omp parallel do private(k, kn, l, i) + do j = - 1, jj + 2 + do k = kk, 1, - 1 + kn = k + nn + do l = 1, isp(j) + do i = max(- 1, ifp(j, l)), min(ii + 2, ilp(j, l)) + if (dp(i, j, kn) < epsil) then + phi(i, j, k) = phi(i, j, k + 1) + else + phi(i, j, k) = phi(i, j, k + 1) & + - p_alpha(p(i, j, k + 1), p(i, j, k), & + temp(i, j, kn), saln(i, j, kn)) + endif + enddo + enddo + enddo + enddo + !$omp end parallel do + + ! ------------------------------------------------------------------------ + ! Compute slope vector of local neutral surfaces and also slope vector + ! times Brunt-Vaisala frequency (optionally used in the computation of + ! eddy growth rate). The latter is not computed when the gradient of the + ! geopotential is expected to be influenced by the gradient of the + ! bathymetry and in this case values are extrapolated from above. + ! ------------------------------------------------------------------------ + + rho0 = 1._r8/alpha0 + + !$omp parallel do private(l, i, k, kmax, kn, knnsl, pm, rho_x, phi_x, bfsqm) + do j = - 1, jj + 2 + do l = 1, isu(j) + do i = max(0, ifu(j, l)), min(ii + 2, ilu(j, l)) + + ! Set the x-component of the slope vector to zero initially. + do k = 1, kk + nslpx(i, j, k) = 0._r8 + nnslpx(i, j, k) = 0._r8 + enddo + + ! Index of last layer containing mass at either of the scalar + ! points adjacent to the velocity point. + kmax = 1 + do k = 2, kk + kn = k + nn + if (dp(i - 1, j, kn) > epsil .or. dp(i, j, kn) > epsil) kmax = k + enddo + + ! Index of last interface where slope vector times Brunt-Vaisala + ! frequency is computed. + knnsl = 2 + + ! Compute the x-component of the slope vector at interfaces. + do k = 2, kmax + kn = k + nn + pm = .5_r8*(p(i - 1, j, k) + p(i, j, k)) + rho_x = .5_r8*( rho(pm, temp(i , j, kn - 1), & + saln(i , j, kn - 1)) & + - rho(pm, temp(i - 1, j, kn - 1), & + saln(i - 1, j, kn - 1)) & + + rho(pm, temp(i , j, kn ), & + saln(i , j, kn )) & + - rho(pm, temp(i - 1, j, kn ), & + saln(i - 1, j, kn ))) + phi_x = phi(i, j, k) - phi(i - 1, j, k) + bfsqm = .5_r8*(bfsqf(i - 1, j, k) + bfsqf(i, j, k)) + nslpx(i, j, k) = (g*rho_x/(rho0*bfsqm) + phi_x/g)*scuxi(i, j) + if (phi(i , j, k) > phi(i - 1, j, kk + 1) .and. & + phi(i - 1, j, k) > phi(i , j, kk + 1)) then + nnslpx(i, j, k) = sqrt(bfsqm)*nslpx(i, j, k) + knnsl = k + endif + enddo + do k = knnsl + 1, kmax + nnslpx(i, j, k) = nnslpx(i, j, knnsl) + enddo + + enddo + enddo + enddo + !$omp end parallel do + + !$omp parallel do private(l, i, k, kmax, kn, knnsl, pm, rho_y, phi_y, bfsqm) + do j = 0, jj + 2 + do l = 1, isv(j) + do i = max(- 1, ifv(j, l)), min(ii + 2, ilv(j, l)) + + ! Set the y-component of the slope vector to zero initially. + do k = 1, kk + nslpy(i, j, k) = 0._r8 + nnslpy(i, j, k) = 0._r8 + enddo + + ! Index of last layer containing mass at either of the scalar + ! points adjacent to the velocity point. + kmax = 1 + do k = 2, kk + kn = k + nn + if (dp(i, j - 1, kn) > epsil .or. dp(i, j, kn) > epsil) kmax = k + enddo + + ! Index of last interface where slope vector times Brunt-Vaisala + ! frequency is computed. + knnsl = 2 + + ! Compute the y-component of the slope vector at interfaces. + do k = 2, kmax + kn = k + nn + pm = .5_r8*(p(i, j - 1, k) + p(i, j, k)) + rho_y = .5_r8*( rho(pm, temp(i, j , kn - 1), & + saln(i, j , kn - 1)) & + - rho(pm, temp(i, j - 1, kn - 1), & + saln(i, j - 1, kn - 1)) & + + rho(pm, temp(i, j , kn ), & + saln(i, j , kn )) & + - rho(pm, temp(i, j - 1, kn ), & + saln(i, j - 1, kn ))) + phi_y = phi(i, j, k) - phi(i, j - 1, k) + bfsqm = .5_r8*(bfsqf(i, j - 1, k) + bfsqf(i, j, k)) + nslpy(i, j, k) = (g*rho_y/(rho0*bfsqm) + phi_y/g)*scvyi(i, j) + if (phi(i, j , k) > phi(i, j - 1, kk + 1) .and. & + phi(i, j - 1, k) > phi(i, j , kk + 1)) then + nnslpy(i, j, k) = sqrt(bfsqm)*nslpy(i, j, k) + knnsl = k + endif + enddo + do k = knnsl + 1, kmax + nnslpy(i, j, k) = nnslpy(i, j, knnsl) + enddo + + enddo + enddo + enddo + !$omp end parallel do + + if (csdiag) then + if (mnproc == 1) then + write (lp,*) 'cmnfld_nslope_cntiso_hybrid:' + endif + call chksummsk(nslpx, iu, kk, 'nslpx') + call chksummsk(nslpy, iv, kk, 'nslpy') + call chksummsk(nnslpx, iu, kk, 'nnslpx') + call chksummsk(nnslpy, iv, kk, 'nnslpy') + endif + + end subroutine cmnfld_nslope_cntiso_hybrid + + subroutine cmnfld_nnslope_cntiso_hybrid(m, n, mm, nn, k1m, k1n) + ! --------------------------------------------------------------------------- + ! Compute neutral slope times buoyancy frequency, where the neutral slope is + ! known. + ! --------------------------------------------------------------------------- + + integer, intent(in) :: m, n, mm, nn, k1m, k1n + + real(r8) :: bfsqm + integer :: i, j, k, l + + call xctilr(nslpx, 1, kk, 2, 2, halo_uv) + call xctilr(nslpy, 1, kk, 2, 2, halo_vv) + + !$omp parallel do private(k, l, i, bfsqm) + do j = - 1, jj + 2 + do k = 1, kk + do l = 1, isu(j) + do i = max(0, ifu(j, l)), min(ii + 2, ilu(j, l)) + bfsqm = .5_r8*(bfsqf(i - 1, j, k) + bfsqf(i, j, k)) + nnslpx(i, j, k) = sqrt(bfsqm)*nslpx(i, j, k) + enddo + enddo + enddo + enddo + !$omp end parallel do + + !$omp parallel do private(k, l, i, k, bfsqm) + do j = 0, jj + 2 + do k = 1, kk + do l = 1, isv(j) + do i = max(- 1, ifv(j, l)), min(ii + 2, ilv(j, l)) + bfsqm = .5_r8*(bfsqf(i, j - 1, k) + bfsqf(i, j, k)) + nnslpy(i, j, k) = sqrt(bfsqm)*nslpy(i, j, k) + enddo + enddo + enddo + enddo + !$omp end parallel do + + if (csdiag) then + if (mnproc == 1) then + write (lp,*) 'cmnfld_nnslope_cntiso_hybrid:' + endif + call chksummsk(nnslpx, iu, kk, 'nnslpx') + call chksummsk(nnslpy, iv, kk, 'nnslpy') + endif + + end subroutine cmnfld_nnslope_cntiso_hybrid + + subroutine cmnfld_z(m, n, mm, nn, k1m, k1n) + ! --------------------------------------------------------------------------- + ! Estimate depth of layer interfaces and thickness of layers. + ! --------------------------------------------------------------------------- + + integer, intent(in) :: m, n, mm, nn, k1m, k1n + + integer :: i, j, k, l, km + + !$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)) + z(i, j, kk + 1) = - phi(i, j, kk + 1)/g + enddo + enddo + enddo + !$omp end parallel do + !$omp parallel do private(k, km, l, i) + do j = 1, jj + do k = kk, 1, - 1 + km = k + mm + do l = 1, isp(j) + do i = max(1, ifp(j, l)), min(ii, ilp(j, l)) + if (dp(i, j, km) < epsil) then + z(i, j, k) = z(i, j, k + 1) + else + z(i, j, k) = z(i, j, k + 1) & + + p_alpha(p(i, j, k + 1), p(i, j, k), & + temp(i, j, km), saln(i, j, km))/g + endif + dz(i, j, k) = z(i, j, k + 1) - z(i, j, k) + enddo + enddo + enddo + enddo + !$omp end parallel do + + if (csdiag) then + if (mnproc == 1) then + write (lp,*) 'cmnfld_z:' + endif + call chksummsk(z, ip, kk+1, 'z') + call chksummsk(dz, ip, kk, 'dz') + endif + + end subroutine cmnfld_z + + subroutine cmnfld_mlts(m, n, mm, nn, k1m, k1n) + ! --------------------------------------------------------------------------- + ! Estimate mixed layer depth using density criterion. + ! --------------------------------------------------------------------------- + + integer, intent(in) :: m, n, mm, nn, k1m, k1n + + real(r8) :: zup, dbup, plo, zlo, dblo + integer :: i, j, k, l, km + + !$omp parallel do private(l, i, k, km, zup, dbup, plo, zlo, dblo) + do j = 1, jj + do l = 1, isp(j) + do i = max(1, ifp(j, l)), min(ii, ilp(j, l)) + k = 2 + km = k + mm + zup = z(i, j, 1) + .5_r8*dz(i, j, 1) + dbup = 0._r8 + do + if (dp(i, j, km) > onecm) then + plo = p(i, j, k) + .5_r8*dp(i, j, km) + zlo = z(i, j, k) + .5_r8*dz(i, j, k ) + dblo = & + g*(1._r8 - rho(plo, temp(i, j, k1m), saln(i, j, k1m)) & + /rho(plo, temp(i, j, km ), saln(i, j, km ))) + if (dblo <= dbcrit) then + zup = zlo + dbup = dblo + else + dbup = min(dbup, dbcrit - epsil) + mlts(i, j) = ( zup*(dblo - dbcrit) & + + zlo*(dbcrit - dbup))/(dblo - dbup) & + - z(i, j, 1) + exit + endif + endif + k = k + 1 + if (k > kk) then + mlts(i, j) = z(i, j, kk + 1) - z(i, j, 1) + exit + endif + km = k + mm + enddo + enddo + enddo + enddo + !$omp end parallel do + + if (csdiag) then + if (mnproc == 1) then + write (lp,*) 'cmnfld_mlts:' + endif + call chksummsk(mlts, ip, 1, 'mlts') + endif + + end subroutine cmnfld_mlts + + ! --------------------------------------------------------------------------- + ! Public procedures. + ! --------------------------------------------------------------------------- + + subroutine cmnfld1(m, n, mm, nn, k1m, k1n) + ! --------------------------------------------------------------------------- + ! Compute fields that are used by several subsequent routines + ! --------------------------------------------------------------------------- + + integer, intent(in) :: m, n, mm, nn, k1m, k1n + + integer :: i, j, l + + ! ------------------------------------------------------------------------ + ! Compute fields depending on selection of physics and diagnostics. + ! ------------------------------------------------------------------------ + +! if (vcoord_type_tag == cntiso_hybrid .or. & +! sum( ACC_MLTS (1:nphy) + ACC_MLTSMN(1:nphy) & +! + ACC_MLTSMX(1:nphy) + ACC_MLTSSQ(1:nphy) & +! + ACC_T20D (1:nphy) + & +! + ACC_DZ (1:nphy) + ACC_DZLVL(1:nphy)) /= 0) then + + ! --------------------------------------------------------------------- + ! Estimate depth of layer interfaces and thickness of layers. + ! --------------------------------------------------------------------- + + call cmnfld_z(m, n, mm, nn, k1m, k1n) + +! endif + +! if (vcoord_type_tag == cntiso_hybrid .or. & +! sum( ACC_MLTS (1:nphy) + ACC_MLTSMN(1:nphy) & +! + ACC_MLTSMX(1:nphy) + ACC_MLTSSQ(1:nphy)) /= 0) then + + ! --------------------------------------------------------------------- + ! Estimate mixed layer depth using density criterion. + ! --------------------------------------------------------------------- + + call cmnfld_mlts(m, n, mm, nn, k1m, k1n) + +! endif + + end subroutine cmnfld1 + + subroutine cmnfld2(m, n, mm, nn, k1m, k1n) + ! --------------------------------------------------------------------------- + ! Compute fields that are used by several subsequent routines + ! --------------------------------------------------------------------------- + + integer, intent(in) :: m, n, mm, nn, k1m, k1n + + integer :: i, j, l + + ! ------------------------------------------------------------------------ + ! Update halos of various fields. + ! ------------------------------------------------------------------------ + + call xctilr(temp, 1, 2*kk, 3, 3, halo_ps) + call xctilr(saln, 1, 2*kk, 3, 3, halo_ps) +! 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 + !$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)) + util1(i, j) = kfpla(i, j, n) + enddo + enddo + enddo + !$omp end parallel do + call xctilr(util1, 1, 1, 2, 2, halo_ps) + !$omp parallel do private(l, i) + do j = - 1, jj + 2 + do l = 1, isp(j) + do i = max(- 1, ifp(j, l)), min(ii + 2, ilp(j, l)) + kfpla(i, j, n) = nint(util1(i, j)) + enddo + enddo + enddo + !$omp end parallel do + endif + + ! ------------------------------------------------------------------------ + ! Compute fields depending on selection of physics and diagnostics. + ! ------------------------------------------------------------------------ + +! if (vcoord_type_tag == cntiso_hybrid .or. & +! edritp == 'large scale' .or. eitmth == 'gm' .or. & +! sum(ACC_BFSQ(1:nphy)) /= 0) then + if (vcoord_type_tag == cntiso_hybrid .or. & + edritp == 'large scale' .or. eitmth == 'gm') then + + ! --------------------------------------------------------------------- + ! Compute filtered buoyancy frequency squared. + ! --------------------------------------------------------------------- + + if (vcoord_type_tag == 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) + endif + + endif + + if (edritp == 'large scale' .or. eitmth == 'gm') then + + ! --------------------------------------------------------------------- + ! Estimate slope of local neutral surface. + ! --------------------------------------------------------------------- + + if (vcoord_type_tag == isopyc_bulkml) then + call cmnfld_nslope_isopyc_bulkml(m, n, mm, nn, k1m, k1n) + else + if (ntrdif) then + call cmnfld_nnslope_cntiso_hybrid(m, n, mm, nn, k1m, k1n) + else + call cmnfld_nslope_cntiso_hybrid(m, n, mm, nn, k1m, k1n) + endif + endif + + endif + + end subroutine cmnfld2 + +end module mod_cmnfld_routines diff --git a/phy/mod_difest.F b/phy/mod_difest.F index 89a7b8d6..e84bf2f6 100644 --- a/phy/mod_difest.F +++ b/phy/mod_difest.F @@ -1,5 +1,5 @@ ! ------------------------------------------------------------------------------ -! Copyright (C) 2009-2021 Mats Bentsen, Mehmet Ilicak +! Copyright (C) 2009-2022 Mats Bentsen, Mehmet Ilicak ! ! This file is part of BLOM. ! @@ -23,9 +23,8 @@ module mod_difest use mod_constants, only: g, alpha0, pi, epsil, spval, onem, onecm use mod_time, only: delt1 use mod_xc - use mod_vcoord, only: sigmar use mod_vcoord, only: vcoord_type_tag, isopyc_bulkml, - . cntiso_hybrid + . cntiso_hybrid, sigmar use mod_grid, only: scpx, scpy, scp2, . plat, coriop, betafp, cosang, sinang use mod_eos, only: rho @@ -34,15 +33,17 @@ module mod_difest use mod_diffusion, only: egc, eggam, eglsmn, egmndf, egmxdf, . egidfq, ri0, bdmc1, bdmc2, tkepf, bdmtyp, . edsprs, edritp, edwmth, - . difint, difiso, difdia, difmxp, difwgt - use mod_cmnfld, only: nnslpx, nnslpy, mlts - use mod_forcing, only: ustar, ustarb, ustar3, buoyfl + . difint, difiso, difdia, difmxp, difwgt, + . Kvisc_m, Kdiff_t, Kdiff_s, + . t_ns_nonloc, s_nonloc + use mod_cmnfld, only: bfsqi, nnslpx, nnslpy, mlts + use mod_forcing, only: ustar, ustarb, ustar3, buoyfl, t_sw_nonloc + . , surflx, sswflx, salflx use mod_tidaldissip, only: twedon use mod_niw, only: niwgf, niwbf, niwlf, idkedt, niw_ke_tendency use mod_seaice, only: ficem use mod_utility, only: util1 use mod_checksum, only: csdiag, chksummsk - use mod_diffusion, only: Kvisc_m, Kdiff_t, Kdiff_s use CVMix_kpp, only : CVMix_coeffs_kpp use CVMix_kpp, only : CVMix_kpp_compute_turbulent_scales use CVMix_kpp, only : CVMix_kpp_compute_bulk_Richardson @@ -60,7 +61,6 @@ module mod_difest use CVMix_kpp, only : CVMix_put_kpp use CVMix_kpp, only : CVMix_init_kpp use CVMix_put_get, only : CVMix_put - use mod_cmnfld, only: bfsqi #if defined(TRC) && defined(TKE) use mod_tracers, only: itrtke, itrgls, trc use mod_tke, only: gls_cmu0, Pr_t, tke_min, gls_psi_min, gls_p, @@ -171,7 +171,8 @@ module mod_difest . kappa=.4,bfeps=1.e-12,sleps=.1,zetas=-1.,as=-28.86, . cs=98.96,minOBLdepth=1.0) c - public :: inivar_difest, init_difest, difest, OBLdepth + public :: OBLdepth, inivar_difest, init_difest, difest_isobml, + . difest_lateral_hybrid, difest_vertical_hybrid c contains c @@ -251,6 +252,34 @@ subroutine init_difest . lnonzero_surf_nonlocal=.false. , . lnoDGat1=.true. , . CVMix_kpp_params_user=KPP_params ) +c call CVMix_init_kpp(Ri_crit=0.3, +c . minOBLdepth=minOBLdepth, +c . minVtsqr=1e-10, +c . vonKarman=0.4, +c . surf_layer_ext=0.1, +c . interp_type='quadratic', +c . interp_type2='LMD94', +c . lEkman=.false., +c . lMonOb=.false., +c . MatchTechnique='MatchGradient', +c . lenhanced_diff=.true., +c . lnonzero_surf_nonlocal=.false. , +c . lnoDGat1=.false. , +c . CVMix_kpp_params_user=KPP_params ) +c call CVMix_init_kpp(Ri_crit=0.3, +c . minOBLdepth=minOBLdepth, +c . minVtsqr=1e-10, +c . vonKarman=0.4, +c . surf_layer_ext=0.1, +c . interp_type='quadratic', +c . interp_type2='LMD94', +c . lEkman=.false., +c . lMonOb=.false., +c . MatchTechnique='ParabolicNonLocal', +c . lenhanced_diff=.true., +c . lnonzero_surf_nonlocal=.true. , +c . lnoDGat1=.true. , +c . CVMix_kpp_params_user=KPP_params ) c c end subroutine init_difest @@ -631,7 +660,7 @@ subroutine difest_common_hyb(m,n,mm,nn,k1m,k1n) c end subroutine difest_common_hyb c - subroutine difest(m,n,mm,nn,k1m,k1n) + subroutine difest_isobml(m,n,mm,nn,k1m,k1n) c c --- ------------------------------------------------------------------ c --- estimate diffusivities for eddy-induced transport, layer-wise @@ -684,51 +713,148 @@ subroutine difest(m,n,mm,nn,k1m,k1n) enddo c$OMP END PARALLEL DO c - if (vcoord_type_tag == isopyc_bulkml) then +c --- Estimate energy input by near-inertial waves. + call niw_ke_tendency(m,n,mm,nn,k1m,k1n) c -c --- - Estimate energy input by near-inertial waves. - call niw_ke_tendency(m,n,mm,nn,k1m,k1n) +c --- Obtain common fields for the estimation of lateral and vertical +c --- diffusivities diapycnal diffusivities. + call difest_common_iso(m,n,mm,nn,k1m,k1n) +c +c --- Estimate vertical diffusivity. + call difest_vertical_iso(m,n,mm,nn,k1m,k1n) c -c --- - Obtain common fields for the estimation of lateral and vertical -c --- - diffusivities diapycnal diffusivities. - call difest_common_iso(m,n,mm,nn,k1m,k1n) +c --- Estimate diffusivities for eddy-induced transport and layer-wise +c --- diffusion. + call difest_lateral_iso(m,n,mm,nn,k1m,k1n) +c + if (csdiag) then + if (mnproc.eq.1) then + write (lp,*) 'difest_isobml:' + endif + call chksummsk(ustar3,ip,1,'ustar3') + endif +c + end subroutine difest_isobml +c + subroutine difest_lateral_hybrid(m,n,mm,nn,k1m,k1n) +c +c --- ------------------------------------------------------------------ +c --- estimate diffusivities for eddy-induced transport, layer-wise +c --- diffusion and vertical diffusion +c --- ------------------------------------------------------------------ c -c --- - Estimate vertical diffusivity. - call difest_vertical_iso(m,n,mm,nn,k1m,k1n) + integer m,n,mm,nn,k1m,k1n c -c --- - Estimate diffusivities for eddy-induced transport and layer-wise -c --- - diffusion. - call difest_lateral_iso(m,n,mm,nn,k1m,k1n) + integer i,j,k,l,kn c - elseif (vcoord_type_tag == cntiso_hybrid) then +c --- ------------------------------------------------------------------ +c --- update halos of various fields +c --- ------------------------------------------------------------------ c -c --- - Obtain common fields for the estimation of lateral and vertical -c --- - diffusivities diapycnal diffusivities. - call difest_common_hyb(m,n,mm,nn,k1m,k1n) + call xctilr(u, 1,2*kk, 2,2, halo_uv) + call xctilr(v, 1,2*kk, 2,2, halo_vv) + call xctilr(ubflxs_p, 1,2, 2,2, halo_uv) + call xctilr(vbflxs_p, 1,2, 2,2, halo_vv) + call xctilr(pbu, 1,2, 2,2, halo_us) + call xctilr(pbv, 1,2, 2,2, halo_vs) +c +c --- ------------------------------------------------------------------ +c --- Update layer interface pressure. +c --- ------------------------------------------------------------------ +c +c$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 +c$OMP END PARALLEL DO +c +c --- ------------------------------------------------------------------ +c --- Estimate friction velocity cubed. +c --- ------------------------------------------------------------------ +c +c$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)) + ustar3(i,j)=ustar(i,j)**3 + enddo + enddo + enddo +c$OMP END PARALLEL DO c -c --- - Estimate vertical diffusivities.. - call difest_vertical_hyb(m,n,mm,nn,k1m,k1n) +c --- Obtain common fields for the estimation of lateral and vertical +c --- diffusivities diapycnal diffusivities. + call difest_common_hyb(m,n,mm,nn,k1m,k1n) c -c --- - Estimate diffusivities for eddy-induced transport and layer-wise -c --- - diffusion. - call difest_lateral_hyb(m,n,mm,nn,k1m,k1n) +c --- Estimate diffusivities for eddy-induced transport and layer-wise +c --- diffusion. + call difest_lateral_hyb(m,n,mm,nn,k1m,k1n) c - else + if (csdiag) then if (mnproc.eq.1) then - write (lp,*) 'difest: unsupported vertical coordinate!' + write (lp,*) 'difest_lateral_hybrid:' endif - call xcstop('(difest)') - stop '(difest)' + call chksummsk(ustar3,ip,1,'ustar3') endif +c + end subroutine difest_lateral_hybrid +c + subroutine difest_vertical_hybrid(m,n,mm,nn,k1m,k1n) +c +c --- ------------------------------------------------------------------ +c --- estimate diffusivities for eddy-induced transport, layer-wise +c --- diffusion and vertical diffusion +c --- ------------------------------------------------------------------ +c + integer m,n,mm,nn,k1m,k1n +c + integer i,j,k,l,kn +c +c --- ------------------------------------------------------------------ +c --- update halos of various fields +c --- ------------------------------------------------------------------ +c + call xctilr(u(1-nbdy,1-nbdy,k1n), 1,kk, 1,1, halo_uv) + call xctilr(v(1-nbdy,1-nbdy,k1n), 1,kk, 1,1, halo_vv) +c +c --- ------------------------------------------------------------------ +c --- Update layer interface pressure. +c --- ------------------------------------------------------------------ +c +c$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 +c$OMP END PARALLEL DO +c +c --- Obtain common fields for the estimation of lateral and vertical +c --- diffusivities diapycnal diffusivities. + call difest_common_hyb(m,n,mm,nn,k1m,k1n) +c +c --- Estimate vertical diffusivities.. + call difest_vertical_hyb(m,n,mm,nn,k1m,k1n) c if (csdiag) then if (mnproc.eq.1) then - write (lp,*) 'difest:' + write (lp,*) 'difest_vertical_hybrid:' endif - call chksummsk(ustar3,ip,1,'ustar3') endif c - end subroutine difest + end subroutine difest_vertical_hybrid c subroutine difest_vertical_hyb(m,n,mm,nn,k1m,k1n) c @@ -762,7 +888,7 @@ subroutine difest_vertical_hyb(m,n,mm,nn,k1m,k1n) real, dimension(kdm) :: deltaU2 ! square of delta U (shear) in denominator of Bulk Ri [m2 s-2] real, dimension(kdm) :: VT2 ! unresolved shear used for Bulk Ri real, dimension(kdm) :: deltaRho ! delta Rho [g/cm3] in numerator of Bulk Ri number - real, dimension(kdm,2) :: nonLocalTrans ! Non-local transport for heat/salt at interfaces [nondim] + real, dimension(kdm+1,2) :: nonLocalTrans ! Non-local transport for heat/salt at interfaces [nondim] real :: surf_layer_ext, surfFricVel real :: surfBuoyFlux real :: delH, bvfbot, dps @@ -828,8 +954,7 @@ subroutine difest_vertical_hyb(m,n,mm,nn,k1m,k1n) ! convert cm/s to m/s surfFricVel = ustar(i,j) * 1e-2 ! convert cm2/s3 to m2/s3 - surfBuoyFlux = buoyfl(i,j) * 1e-4 - surfBuoyFlux2(1) = buoyfl(i,j) * 1e-4 + surfBuoyFlux = - buoyfl(i,j,1) * 1e-4 do k=1,kk kn = k + nn kn1 = max(nn+1,kn-1) @@ -883,7 +1008,7 @@ subroutine difest_vertical_hyb(m,n,mm,nn,k1m,k1n) surfSalt = surfHsalt / hTot surfU = surfHu / hTot surfV = surfHv / hTot - surfRho = rho(0.0,surfTemp,surfSalt) + surfRho = rho(p(i,j,k),surfTemp,surfSalt) if (p(i,j,kk+1)-p(i,j,k) < epsil) then deltaRho(k) = deltaRho(k-1) else @@ -910,6 +1035,9 @@ subroutine difest_vertical_hyb(m,n,mm,nn,k1m,k1n) c --- ------- Local gradient Richardson number rig_i(k)=rig(i,j,k) + + surfBuoyFlux2(k) = ( buoyfl(i,j,k+1) + . - buoyfl(i,j,1 )) * 1e-4 c enddo ! k if(dps.gt.0.) bvfbot=bvfbot/dps @@ -1003,7 +1131,8 @@ subroutine difest_vertical_hyb(m,n,mm,nn,k1m,k1n) . delta_Vsqr_cntr=deltaU2, ! Square of resolved velocity difference [m2 s-2] . Vt_sqr_cntr=VT2(:), ! Unresolved shear [m2 s-2] . ws_cntr=Ws_1d, ! Turbulent velocity scale profile [m s-1] - . N_iface=bvf_i) ! Buoyancy frequency at the interface [s-1] + . N_iface=bvf_i, ! Buoyancy frequency at the interface [s-1] + . CVMix_kpp_params_user=KPP_params ) ! KPP parameters ! Compute OBL depth for KPP call CVMix_kpp_compute_OBL_depth( @@ -1051,6 +1180,10 @@ subroutine difest_vertical_hyb(m,n,mm,nn,k1m,k1n) Kt_kpp(:) = Kd_col(:)+Kd_conv(:)+Kd_shr(:)+Kd_tidal(:) Ks_kpp(:) = Kd_col(:)+Kd_conv(:)+Kd_shr(:)+Kd_tidal(:) + ! Buoyancy flux acting on the OBL + surfBuoyFlux = ( buoyfl(i,j,kOBL+1) + . - buoyfl(i,j,1 )) * 1e-4 + ! Compute KPP using CVMix call CVMix_coeffs_kpp(Kv_kpp(:), ! (inout) Total viscosity [m2 s-1] . Kt_kpp(:), ! (inout) Total temp diffusivity [m2 s-1] @@ -1085,6 +1218,13 @@ subroutine difest_vertical_hyb(m,n,mm,nn,k1m,k1n) Kvisc_m(i,j,:) = Kv_kpp(:) Kdiff_t(i,j,:) = Kt_kpp(:) Kdiff_s(i,j,:) = Ks_kpp(:) + t_ns_nonloc(i,j,:) = nonLocalTrans(:,1) + s_nonloc(i,j,:) = nonLocalTrans(:,2) + do k = 1, kk+1 + t_sw_nonloc(i,j,k) = max(t_sw_nonloc(i,j,k), + . nonLocalTrans(k,1)) + enddo + enddo enddo c end of single column @@ -2388,8 +2528,8 @@ subroutine difest_vertical_iso(m,n,mm,nn,k1m,k1n) ust=max(ustmin,ustar(i,j)) c c --- --- Monin-Obukhov length scale - mols=ust**3 - . /(kappa*sign(max(abs(buoyfl(i,j)),bfeps),-buoyfl(i,j))) + mols=ust**3/(kappa*sign(max(abs(buoyfl(i,j,1)),bfeps), + . -buoyfl(i,j,1))) c c --- --- Mixed layer thickness h=(p(i,j,3)-p(i,j,1))/onecm diff --git a/phy/mod_diffusion.F90 b/phy/mod_diffusion.F90 index a8941ad0..fe744461 100644 --- a/phy/mod_diffusion.F90 +++ b/phy/mod_diffusion.F90 @@ -1,5 +1,5 @@ ! ------------------------------------------------------------------------------ -! Copyright (C) 2020 Mats Bentsen +! Copyright (C) 2020-2022 Mats Bentsen ! ! This file is part of BLOM. ! @@ -68,6 +68,8 @@ module mod_diffusion edwmth ! Method to estimate eddy diffusivity weight as a function of ! the ration of Rossby radius of deformation to the horizontal ! grid spacing. Valid methods: 'smooth', 'step'. + logical :: & + ntrdif = .false. real(r8), dimension(1 - nbdy:idm + nbdy,1 - nbdy:jdm + nbdy, kdm) :: & difint, & ! Layer interface diffusivity [cm2 s-1]. @@ -75,9 +77,13 @@ module mod_diffusion difdia ! Diapycnal diffusivity [cm2 s-1]. real(r8), dimension(1 - nbdy:idm + nbdy,1 - nbdy:jdm + nbdy, kdm+1) :: & - Kvisc_m, & ! momentum eddy viscosity [cm2 s-1]. - Kdiff_t, & ! temperature eddy diffusivity [cm2 s-1]. - Kdiff_s ! salinity eddy diffusivity [cm2 s-1]. + Kvisc_m, & ! momentum eddy viscosity [cm2 s-1]. + Kdiff_t, & ! temperature eddy diffusivity [cm2 s-1]. + Kdiff_s, & ! salinity eddy diffusivity [cm2 s-1]. + t_ns_nonloc, & ! Non-local transport term that is the fraction of + ! non-shortwave flux passing a layer interface []. + s_nonloc ! Non-local transport term that is the fraction of + ! material tracer flux passing a layer interface []. real(r8), dimension(1 - nbdy:idm + nbdy,1 - nbdy:jdm + nbdy) :: & difmxp, & ! Maximum lateral diffusivity at p-points [cm2 s-1]. @@ -108,11 +114,12 @@ module mod_diffusion ! [g2 cm kg-1 s-2]. public :: egc, eggam, eglsmn, egmndf, egmxdf, egidfq, ri0, bdmc1, bdmc2, & - tkepf, bdmtyp, edsprs, eitmth, edritp, edwmth, & + tkepf, bdmtyp, edsprs, eitmth, edritp, edwmth, ntrdif, & difint, difiso, difdia, difmxp, difmxq, difwgt, & umfltd, vmfltd, utfltd, vtfltd, utflld, vtflld, & usfltd, vsfltd, usflld, vsflld, & - inivar_diffusion, Kvisc_m, Kdiff_t, Kdiff_s + Kvisc_m, Kdiff_t, Kdiff_s, t_ns_nonloc, s_nonloc, & + inivar_diffusion contains @@ -161,6 +168,19 @@ subroutine inivar_diffusion enddo !$omp end parallel do + ! Initialize isopycnal diffusivity . + 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)) + difiso(i, j, k) = 0._r8 + enddo + enddo + enddo + enddo + !$omp end parallel do + call xctilr(difiso, 1, kk, nbdy, nbdy, halo_ps) + ! Initialize diffusive fluxes at points located upstream and downstream (in ! i-direction) of p-points. !$omp parallel do private(k, l, i) diff --git a/phy/mod_eos.F90 b/phy/mod_eos.F90 index 875ebcb8..49bbef46 100644 --- a/phy/mod_eos.F90 +++ b/phy/mod_eos.F90 @@ -1,5 +1,5 @@ ! ------------------------------------------------------------------------------ -! Copyright (C) 2007-2021 Mats Bentsen, Mehmet Ilicak, Aleksi Nummelin +! Copyright (C) 2007-2022 Mats Bentsen, Mehmet Ilicak, Aleksi Nummelin ! ! This file is part of BLOM. ! @@ -72,7 +72,8 @@ module mod_eos ap11, ap12, ap13, ap14, ap15, ap16, & ap21, ap22, ap23, ap24, ap25, ap26, & atf, btf, ctf, & - inieos, rho, alp, sig, sig0, dsigdt, dsigdt0, dsigds, dsigds0, & + inieos, rho, alp, sig, sig0, & + drhodt, dsigdt, dsigdt0, drhods, dsigds, dsigds0, & tofsig, sofsig, p_alpha, p_p_alpha, delphi contains @@ -213,6 +214,29 @@ pure real(r8) function sig0(th, s) end function sig0 + pure real(r8) function drhodt(p, th, s) + ! --------------------------------------------------------------------------- + ! Derivative of in situ density with respect to potential temperature + ! [g cm-3 K-1]. + ! --------------------------------------------------------------------------- + + real(r8), intent(in) :: & + p, & ! Pressure [g cm-1 s-2]. + th, & ! Potental temperature [deg C]. + s ! Salinity [g kg-1]. + + real(r8) :: r1, r2i + + r1 = a11 + (a12 + a14*th + a15*s)*th + (a13 + a16*s)*s & + + (b11 + b12*th + b13*s)*p + r2i = 1._r8/( a21 + (a22 + a24*th + a25*s)*th + (a23 + a26*s)*s & + + (b21 + b22*th + b23*s)*p) + + drhodt = ( a12 + 2._r8*a14*th + a15*s + b12*p & + - (a22 + 2._r8*a24*th + a25*s + b22*p)*r1*r2i)*r2i + + end function drhodt + pure real(r8) function dsigdt(th, s) ! --------------------------------------------------------------------------- ! Derivative of potential density with respect to potential temperature @@ -254,6 +278,28 @@ pure real(r8) function dsigdt0(th, s) end function dsigdt0 + pure real(r8) function drhods(p, th, s) + ! --------------------------------------------------------------------------- + ! Derivative of in situ density with respect to salinity [kg cm-3]. + ! --------------------------------------------------------------------------- + + real(r8), intent(in) :: & + p, & ! Pressure [g cm-1 s-2]. + th, & ! Potental temperature [deg C]. + s ! Salinity [g kg-1]. + + real(r8) :: r1, r2i + + r1 = a11 + (a12 + a14*th + a15*s)*th + (a13 + a16*s)*s & + + (b11 + b12*th + b13*s)*p + r2i = 1._r8/( a21 + (a22 + a24*th + a25*s)*th + (a23 + a26*s)*s & + + (b21 + b22*th + b23*s)*p) + + drhods = ( a13 + a15*th + 2._r8*a16*s + b13*p & + - (a23 + a25*th + 2._r8*a26*s + b23*p)*r1*r2i)*r2i + + end function drhods + pure real(r8) function dsigds(th, s) ! --------------------------------------------------------------------------- ! Derivative of potential density with respect to salinity [kg cm-3]. diff --git a/phy/mod_forcing.F90 b/phy/mod_forcing.F90 index 3d2d5b60..b983167b 100644 --- a/phy/mod_forcing.F90 +++ b/phy/mod_forcing.F90 @@ -1,5 +1,5 @@ ! ------------------------------------------------------------------------------ -! Copyright (C) 2002-2020 Mats Bentsen, Jerry Tjiputra +! Copyright (C) 2002-2022 Mats Bentsen, Jerry Tjiputra ! ! This file is part of BLOM. ! @@ -121,8 +121,14 @@ module mod_forcing tauy, & ! v-component of surface stress [g cm-1 s-2]. ustar, & ! Surface friction velocity [cm s-1]. ustarb, & ! Bottom friction velocity [cm s-1]. - ustar3, & ! Friction velocity cubed [cm3 s-3]. - buoyfl ! Surface buoyancy flux [cm2 s-3]. + ustar3 ! Friction velocity cubed [cm3 s-3]. + + ! Flux fields at model interfaces. + + real(r8), dimension(1 - nbdy:idm + nbdy,1 - nbdy:jdm + nbdy, kk + 1) :: & + buoyfl, & ! Buoyancy flux [cm2 s-3]. + t_sw_nonloc ! Non-local transport term that is the fraction of + ! shortwave flux passing a layer interface []. public :: aptflx, apsflx, ditflx, disflx, srxbal, sprfac, & trxday, srxday, trxdpt, srxdpt, trxlim, srxlim, scfile, & @@ -131,7 +137,7 @@ module mod_forcing swa, nsf, hmltfz, lip, sop, eva, rnf, rfi, fmltfz, sfl, ztx, mty, & ustarw, slp, abswnd, atmco2, flxco2, flxdms, & surflx, surrlx, sswflx, salflx, brnflx, salrlx, taux, tauy, & - ustar, ustarb, ustar3, buoyfl, & + ustar, ustarb, ustar3, buoyfl, t_sw_nonloc, & inivar_forcing, fwbbal contains @@ -141,7 +147,7 @@ subroutine inivar_forcing ! Initialize variables related to forcing. ! --------------------------------------------------------------------------- - integer :: i, j, l + integer :: i, j, k, l !$omp parallel do private(i) do j = 1 - nbdy, jj + nbdy @@ -177,7 +183,16 @@ subroutine inivar_forcing ustar(i, j) = spval ustarb(i, j) = spval ustar3(i, j) = spval - buoyfl(i, j) = spval + enddo + enddo + !$omp end parallel do + + !$omp parallel do private(k, i) + do j = 1 - nbdy, jj + nbdy + do k = 1, kk + 1 + do i = 1 - nbdy, ii + nbdy + buoyfl(i, j, k) = spval + enddo enddo enddo !$omp end parallel do @@ -190,12 +205,23 @@ subroutine inivar_forcing flxdms(i, j) = 0._r8 ustar (i, j) = 0._r8 ustarb(i, j) = 0._r8 - buoyfl(i, j) = 0._r8 enddo enddo enddo !$omp end parallel do + !$omp parallel do private(k, l, i) + do j = 1, jj + do k = 1, kk + 1 + do l = 1, isp(j) + do i = max(1, ifp(j, l)), min(ii, ilp(j, l)) + buoyfl(i, j, k) = 0._r8 + enddo + enddo + enddo + enddo + !$omp end parallel do + if (sprfac) then prfac = 1._r8 !$omp parallel do private(l, i) diff --git a/phy/mod_inicon.F b/phy/mod_inicon.F index e72b2a00..401b4818 100644 --- a/phy/mod_inicon.F +++ b/phy/mod_inicon.F @@ -1,5 +1,5 @@ ! ------------------------------------------------------------------------------ -! Copyright (C) 2008-2021 Mats Bentsen +! Copyright (C) 2008-2022 Mats Bentsen ! ! This file is part of BLOM. ! @@ -32,7 +32,8 @@ module mod_inicon use mod_xc use mod_vcoord, only: vcoord_type_tag, isopyc_bulkml, . cntiso_hybrid, sigmar, - . cntiso_hybrid_regrid_remap, remap_velocity + . cntiso_hybrid_regrid_direct_remap, + . remap_velocity use mod_grid, only: scuy, scvx, scuyi, scvxi, depths, . corioq use mod_state, only: u, v, dp, dpu, dpv, temp, saln, sigma, p, pu, @@ -640,7 +641,7 @@ subroutine inicon c$OMP END PARALLEL DO c if (vcoord_type_tag.eq.cntiso_hybrid) then - call cntiso_hybrid_regrid_remap(2,1,kk,0,kk+1,1) + call cntiso_hybrid_regrid_direct_remap(2,1,kk,0,kk+1,1) call remap_velocity(2,1,kk,0,kk+1,1) endif call xctilr(temp, 1,kk, 1,1, halo_ps) diff --git a/phy/mod_mxlayr.F b/phy/mod_mxlayr.F index ae373117..c81abb6a 100644 --- a/phy/mod_mxlayr.F +++ b/phy/mod_mxlayr.F @@ -1,5 +1,5 @@ ! ------------------------------------------------------------------------------ -! Copyright (C) 2009-2021 Mats Bentsen, Mehmet Ilicak +! Copyright (C) 2009-2022 Mats Bentsen, Mehmet Ilicak ! ! This file is part of BLOM. ! @@ -333,7 +333,7 @@ subroutine mxlayr(m,n,mm,nn,k1m,k1n) beta=alpha0*dsigds0(tmxl,smxl) bfltot=g*alpha0*(alfa*surflx(i,j)/spcifh . -beta*(salflx(i,j)-brnflx(i,j))) - buoyfl(i,j)=bfltot + buoyfl(i,j,1)=bfltot bflpsw=g*alpha0*alfa*swbgfc(i,j)*sswflx(i,j)/spcifh c pmxl=pres(3) diff --git a/phy/mod_ndiff.F90 b/phy/mod_ndiff.F90 new file mode 100644 index 00000000..2a27bcab --- /dev/null +++ b/phy/mod_ndiff.F90 @@ -0,0 +1,1149 @@ +! ------------------------------------------------------------------------------ +! Copyright (C) 2022 Mats Bentsen +! +! 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_ndiff +! ------------------------------------------------------------------------------ +! This module contains procedures for solving vertical diffusion equations. +! ------------------------------------------------------------------------------ + + use mod_types, only: r8 + use mod_constants, only: g, alpha0, epsil, onemm + use mod_time, only: delt1 + use mod_xc + use mod_grid, only: scuy, scvx, scp2, scuxi, scvyi + use mod_eos, only: drhodt, drhods, rho + use mod_state, only: dp, temp, saln, utflx, vtflx, usflx, vsflx, pu, pv + use mod_diffusion, only: difiso, utflld, vtflld, usflld, vsflld + use mod_cmnfld, only: nslpx, nslpy + use mod_hor3map, only: recon_src_struct, extract_polycoeff, & + hor3map_noerr, hor3map_errstr +#ifdef TRC + use mod_tracers, only: ntr, trc +#endif + + implicit none + + private + + real(r8), parameter :: & + rhoeps = 1.e-8_r8, & + dpeps = 1.e-4_r8 + integer, parameter :: & + p_ord = 4, & + it = 1, & + is = 2, & +#ifdef TRC + ntr_loc = ntr + 2 ! Local number of tracers where temperature + ! and salinity is added to the ntr parameter. +#else + ntr_loc = 2 ! Local number of tracers consisting of + ! temperature and salinity. +#endif + + real(r8), dimension(p_ord+1,kdm,ntr_loc,1-nbdy:idm+nbdy,2), target :: & + tpc_src_rs + real(r8), dimension(2,kdm,1-nbdy:idm+nbdy,2), target :: & + p_srcdi_rs, drhodt_srcdi_rs, drhods_srcdi_rs + real(r8), dimension(2,kdm,ntr_loc,1-nbdy:idm+nbdy,2), target :: t_srcdi_rs + real(r8), dimension(kdm,ntr_loc,1-nbdy:idm+nbdy,2) :: flxconv_rs + integer, dimension(1-nbdy:idm+nbdy,2) :: ksmx_rs, kdmx_rs + + public :: ndiff_prep_jslice, ndiff_uflx_jslice, ndiff_vflx_jslice, & + ndiff_update_trc_jslice + +contains + + ! --------------------------------------------------------------------------- + ! Private procedures. + ! --------------------------------------------------------------------------- + + pure function peval(pc, x) result(f) + + real(r8), dimension(:), intent(in) :: pc + real(r8), intent(in) :: x + + real(r8) :: f + + f = pc(1) + (pc(2) + (pc(3) + (pc(4) + pc(5)*x)*x)*x)*x + + end function peval + + 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 ipeval(pc, x0, x1) result(f) + + real(r8), dimension(:), intent(in) :: pc + real(r8), intent(in) :: x0, x1 + + real(r8) :: f + + real(r8), parameter :: & + c1_2 = 1._r8/2._r8, & + c1_3 = 1._r8/3._r8, & + c1_4 = 1._r8/4._r8, & + c1_5 = 1._r8/5._r8 + + f = ( pc(1) & + + ( c1_2*pc(2) & + + ( c1_3*pc(3) & + + ( c1_4*pc(4) & + + c1_5*pc(5)*x1)*x1)*x1)*x1)*x1 & + - ( pc(1) & + + ( c1_2*pc(2) & + + ( c1_3*pc(3) & + + ( c1_4*pc(4) & + + c1_5*pc(5)*x0)*x0)*x0)*x0)*x0 + + end function ipeval + + pure function drho(t1, s1, t2, s2, drhodt, drhods) result(dr) + + real(r8), intent(in) :: t1, s1, t2, s2, drhodt, drhods + + real(r8) :: dr + + dr = drhodt*(t2 - t1) + drhods*(s2 - s1) + + end function drho + + pure function drhoroot(tpc, spc, tf, sf, & + drhodt_l, drhodt_u, drhods_l, drhods_u) result(x) + + real(r8), dimension(:), intent(in) :: tpc, spc + real(r8), intent(in) :: tf, sf, drhodt_l, drhodt_u, drhods_l, drhods_u + + real(r8) :: x + + real(r8), parameter :: & + c1_2 = 1._r8/2._r8, & + c0 = 0._r8, & + c1 = 1._r8, & + c2 = 2._r8, & + c3 = 3._r8, & + c4 = 4._r8, & + eps = 1.e-14_r8, & + x_tol = 1.e-4_r8 + + real(r8) :: ddrdtdx, ddrdsdx, dt, ds, drdt, drds, dtdx, dsdx, dr, ddrdx, & + x_old + integer :: n + + x = c1_2 + ddrdtdx = drhodt_l - drhodt_u + ddrdsdx = drhods_l - drhods_u + + do n = 1, 10 + + dt = tf - (tpc(1) + (tpc(2) + (tpc(3) + (tpc(4) + tpc(5)*x)*x)*x)*x) + ds = sf - (spc(1) + (spc(2) + (spc(3) + (spc(4) + spc(5)*x)*x)*x)*x) + drdt = drhodt_l*x + drhodt_u*(c1 - x) + drds = drhods_l*x + drhods_u*(c1 - x) + dtdx = - (tpc(2) + (c2*tpc(3) + (c3*tpc(4) + c4*tpc(5)*x)*x)*x) + dsdx = - (spc(2) + (c2*spc(3) + (c3*spc(4) + c4*spc(5)*x)*x)*x) + + dr = drdt*dt + drds*ds + ddrdx = ddrdtdx*dt + drdt*dtdx + ddrdsdx*ds + drds*dsdx + + x_old = x + x = max(c0, min(c1, x_old - dr/sign(max(eps, abs(ddrdx)), ddrdx))) + if (abs(x - x_old) < x_tol) return + + enddo + + end function drhoroot + + subroutine ndiff_flx(p_srcdi_m, t_srcdi_m, tpc_src_m, & + drhodt_srcdi_m, drhods_srcdi_m, & + p_dst_m, ksmx_m, kdmx_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, uvtflld, uvsflld, uvtflx, uvsflx, & + nslpxy, & + i_m, j_m, i_p, j_p, j_rs_m, j_rs_p, mm, nn) + + real(r8), dimension(:,:), intent(in) :: & + p_srcdi_m, drhodt_srcdi_m, drhods_srcdi_m, & + p_srcdi_p, drhodt_srcdi_p, drhods_srcdi_p + real(r8), dimension(:,:,:), intent(in) :: & + t_srcdi_m, tpc_src_m, t_srcdi_p, tpc_src_p + real(r8), dimension(:), intent(in) :: & + p_dst_m, p_dst_p + real(r8), dimension(1-nbdy:,1-nbdy:,:), intent(in) :: & + puv + real(r8), dimension(1-nbdy:,1-nbdy:,:), intent(inout) :: & + uvtflld, uvsflld, uvtflx, uvsflx + real(r8), dimension(1-nbdy:,1-nbdy:,:), intent(out) :: & + nslpxy + real(r8), intent(in) :: cdiff, cnslp + integer, intent(in) :: & + ksmx_m, ksmx_p, kdmx_m, kdmx_p, i_m, j_m, i_p, j_p, j_rs_m, j_rs_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 + real(r8), dimension(ntr_loc,2) :: t_ni_m, t_ni_p + real(r8), dimension(ntr_loc) :: t_nl_m, t_nl_p + real(r8), dimension(2) :: x_ni_m, x_ni_p, p_ni_m, p_ni_p + real(r8) :: drho_curr, p_ni_m_prev, p_ni_p_prev, & + drhodt_x0, drhodt_x1, drhods_x0, drhods_x1, & + x, drho_prev, r_m, q_m, r_p, q_p, & + dp_ni_m, dp_ni_p, q, dt, ds, & + tflx, sflx, p_ni_up, p_ni_lo, dp_ni_i, mlfrac, p_nslp_dst + integer :: nns, is_m, is_p, ks_m, ks_p, ks_m_prev, ks_p_prev, & + kd_m, kd_p, isn_m, isn_p, ksn_m, ksn_p, & + nip, nic, kuv, case_m, case_p, nt, kuvm, kd, ks + logical, dimension(kk) :: stab_src_m, stab_src_p + logical :: drho_neg, drho_pos, drho_zero, & + advance_src_m, advance_src_p, advance_dst_m, advance_dst_p, & + found_ni + + real(r8), parameter :: mval = 1.e30_r8 + + ! ------------------------------------------------------------------------ + ! Search the source columns, starting from the surface, to identify + ! neutral interfaces anchored at layer interfaces. Store information + ! about whether layers are stably stratified with current reconstruction + ! and neutral slopes. + ! ------------------------------------------------------------------------ + + p_ni_srcdi_m(:,:) = mval + p_ni_srcdi_p(:,:) = mval + stab_src_m(:) = .false. + stab_src_p(:) = .false. + + nns = 0 + + is_m = 1 + ks_m = 1 + ks_p = 1 + is_p = 1 + drho_curr = drho(t_srcdi_m(is_m,ks_m,it), & + t_srcdi_m(is_m,ks_m,is), & + t_srcdi_p(is_p,ks_p,it), & + t_srcdi_p(is_p,ks_p,is), & + .5_r8*( drhodt_srcdi_m(is_m,ks_m) & + + drhodt_srcdi_p(is_p,ks_p)), & + .5_r8*( drhods_srcdi_m(is_m,ks_m) & + + drhods_srcdi_p(is_p,ks_p))) + p_ni_m_prev = p_srcdi_m(1,1) + p_ni_p_prev = p_srcdi_p(1,1) + + search_loop1: do + + drho_neg = drho_curr <= - rhoeps + drho_pos = drho_curr >= rhoeps + drho_zero = .not. (drho_neg .or. drho_pos) + + if (is_m + ks_m > 2 .and. is_p + ks_p > 2) then + if (drho_neg) then + if (is_m == 2) then + drhodt_x0 = .5_r8*( drhodt_srcdi_m(1 ,ks_m) & + + drhodt_srcdi_p(is_p,ks_p)) + drhodt_x1 = .5_r8*( drhodt_srcdi_m(2 ,ks_m) & + + drhodt_srcdi_p(is_p,ks_p)) + drhods_x0 = .5_r8*( drhods_srcdi_m(1 ,ks_m) & + + drhods_srcdi_p(is_p,ks_p)) + drhods_x1 = .5_r8*( drhods_srcdi_m(2 ,ks_m) & + + drhods_srcdi_p(is_p,ks_p)) + x = drhoroot(tpc_src_m(:,ks_m,it), tpc_src_m(:,ks_m,is), & + t_srcdi_p(is_p,ks_p,it), & + t_srcdi_p(is_p,ks_p,is), & + drhodt_x1, drhodt_x0, & + drhods_x1, drhods_x0) + p_ni_srcdi_p(is_p,ks_p) = p_srcdi_m(2,ks_m)*x & + + p_srcdi_m(1,ks_m)*(1._r8 - x) + if (p_ni_srcdi_p(is_p,ks_p) > p_ni_m_prev) then + p_ni_m_prev = p_ni_srcdi_p(is_p,ks_p) + nns = nns + 1 + nslp_src(nns) = - cnslp*( p_srcdi_p(is_p,ks_p) & + - p_ni_srcdi_p(is_p,ks_p)) + p_nslp_src(nns) = .5_r8*( p_srcdi_p(is_p,ks_p) & + + p_ni_srcdi_p(is_p,ks_p)) + else + p_ni_srcdi_p(is_p,ks_p) = mval + endif + endif + elseif (drho_pos) then + if (is_p == 2) then + drhodt_x0 = .5_r8*( drhodt_srcdi_m(is_m,ks_m) & + + drhodt_srcdi_p(1 ,ks_p)) + drhodt_x1 = .5_r8*( drhodt_srcdi_m(is_m,ks_m) & + + drhodt_srcdi_p(2 ,ks_p)) + drhods_x0 = .5_r8*( drhods_srcdi_m(is_m,ks_m) & + + drhods_srcdi_p(1 ,ks_p)) + drhods_x1 = .5_r8*( drhods_srcdi_m(is_m,ks_m) & + + drhods_srcdi_p(2 ,ks_p)) + x = drhoroot(tpc_src_p(:,ks_p,it), tpc_src_p(:,ks_p,is), & + t_srcdi_m(is_m,ks_m,it), & + t_srcdi_m(is_m,ks_m,is), & + drhodt_x1, drhodt_x0, & + drhods_x1, drhods_x0) + p_ni_srcdi_m(is_m,ks_m) = p_srcdi_p(2,ks_p)*x & + + p_srcdi_p(1,ks_p)*(1._r8 - x) + if (p_ni_srcdi_m(is_m,ks_m) > p_ni_p_prev) then + p_ni_p_prev = p_ni_srcdi_m(is_m,ks_m) + nns = nns + 1 + nslp_src(nns) = - cnslp*( p_ni_srcdi_m(is_m,ks_m) & + - p_srcdi_m(is_m,ks_m)) + p_nslp_src(nns) = .5_r8*( p_ni_srcdi_m(is_m,ks_m) & + + p_srcdi_m(is_m,ks_m)) + else + p_ni_srcdi_m(is_m,ks_m) = mval + endif + endif + else + p_ni_srcdi_p(is_p,ks_p) = p_srcdi_m(is_m,ks_m) + p_ni_srcdi_m(is_m,ks_m) = p_srcdi_p(is_p,ks_p) + nns = nns + 1 + nslp_src(nns) = - cnslp*( p_srcdi_p(is_p,ks_p) & + - p_srcdi_m(is_m,ks_m)) + p_nslp_src(nns) = .5_r8*( p_srcdi_p(is_p,ks_p) & + + p_srcdi_m(is_m,ks_m)) + endif + endif + + if (drho_zero .or. drho_pos) then + do + drho_prev = drho_curr + if (is_m == 1) then + is_m = 2 + else + ks_m = ks_m + 1 + if (ks_m > ksmx_m) exit search_loop1 + is_m = 1 + endif + drho_curr = drho(t_srcdi_m(is_m,ks_m,it), & + t_srcdi_m(is_m,ks_m,is), & + t_srcdi_p(is_p,ks_p,it), & + t_srcdi_p(is_p,ks_p,is), & + .5_r8*( drhodt_srcdi_m(is_m,ks_m) & + + drhodt_srcdi_p(is_p,ks_p)), & + .5_r8*( drhods_srcdi_m(is_m,ks_m) & + + drhods_srcdi_p(is_p,ks_p))) + if (drho_prev - drho_curr > rhoeps) then + if (is_m == 2 .and. & + p_srcdi_m(2,ks_m) - p_srcdi_m(1,ks_m) > onemm) & + stab_src_m(ks_m) = .true. + exit + endif + if (is_m == 1) then + p_ni_srcdi_m(is_m,ks_m) = p_ni_srcdi_m(2,ks_m-1) + endif + enddo + endif + + if (drho_zero .or. drho_neg) then + do + drho_prev = drho_curr + if (is_p == 1) then + is_p = 2 + else + ks_p = ks_p + 1 + if (ks_p > ksmx_p) exit search_loop1 + is_p = 1 + endif + drho_curr = drho(t_srcdi_m(is_m,ks_m,it), & + t_srcdi_m(is_m,ks_m,is), & + t_srcdi_p(is_p,ks_p,it), & + t_srcdi_p(is_p,ks_p,is), & + .5_r8*( drhodt_srcdi_m(is_m,ks_m) & + + drhodt_srcdi_p(is_p,ks_p)), & + .5_r8*( drhods_srcdi_m(is_m,ks_m) & + + drhods_srcdi_p(is_p,ks_p))) + if (drho_curr - drho_prev > rhoeps) then + if (is_p == 2 .and. & + p_srcdi_p(2,ks_p) - p_srcdi_p(1,ks_p) > onemm) & + stab_src_p(ks_p) = .true. + exit + endif + if (is_p == 1) then + p_ni_srcdi_p(is_p,ks_p) = p_ni_srcdi_p(2,ks_p-1) + endif + enddo + endif + + enddo search_loop1 + + ! ------------------------------------------------------------------------ + ! Do another search from the surface, this time including target + ! interfaces, to identify neutral layers and compute fluxes that are added + ! to a flux convergence for the target layers. + ! ------------------------------------------------------------------------ + + is_m = 2 + ks_m = 0 + is_p = 2 + ks_p = 0 + kd_m = 1 + kd_p = 1 + advance_src_m = .true. + advance_src_p = .true. + advance_dst_m = .false. + advance_dst_p = .false. + ks_m_prev = 0 + ks_p_prev = 0 + nip = 1 + nic = 2 + p_ni_m(nip) = - mval + p_ni_p(nip) = - mval + kuv = 1 + + search_loop2: do + + ! Advance source and destination interface indices as requested. When + ! source interfaces indices are advanced, keep seperate indices for + ! next interface and next interface that is anchoring a neutral + ! interface. + + if (advance_src_m) then + do + if (is_m == 1) then + is_m = 2 + if (stab_src_m(ks_m)) exit + else + ks_m = ks_m + 1 + if (ks_m > ksmx_m) exit search_loop2 + is_m = 1 + if (stab_src_m(ks_m) .and. p_ni_srcdi_m(is_m,ks_m) /= mval) & + exit + endif + enddo + isn_m = is_m + ksn_m = ks_m + do while (p_ni_srcdi_m(isn_m,ksn_m) == mval) + if (isn_m == 1) then + isn_m = 2 + else + if (ksn_m == ksmx_m) exit + ksn_m = ksn_m + 1 + isn_m = 1 + endif + enddo + endif + + if (advance_src_p) then + do + if (is_p == 1) then + is_p = 2 + if (stab_src_p(ks_p)) exit + else + ks_p = ks_p + 1 + if (ks_p > ksmx_p) exit search_loop2 + is_p = 1 + if (stab_src_p(ks_p) .and. p_ni_srcdi_p(is_p,ks_p) /= mval) & + exit + endif + enddo + isn_p = is_p + ksn_p = ks_p + do while (p_ni_srcdi_p(isn_p,ksn_p) == mval) + if (isn_p == 1) then + isn_p = 2 + else + if (ksn_p == ksmx_p) exit + ksn_p = ksn_p + 1 + isn_p = 1 + endif + enddo + endif + + if (advance_dst_m) then + kd_m = kd_m + 1 + if (kd_m > kdmx_m) exit search_loop2 + endif + + if (advance_dst_p) then + kd_p = kd_p + 1 + if (kd_p > kdmx_p) exit search_loop2 + endif + + do while (p_dst_m(kd_m+1) & + <= max(p_srcdi_m(1,ks_m), p_ni_m(nip))) + kd_m = kd_m + 1 + if (kd_m > kdmx_m) exit search_loop2 + enddo + + do while (p_dst_p(kd_p+1) & + <= max(p_srcdi_p(1,ks_p), p_ni_p(nip))) + kd_p = kd_p + 1 + if (kd_p > kdmx_p) exit search_loop2 + enddo + + advance_src_m = .false. + advance_src_p = .false. + advance_dst_m = .false. + advance_dst_p = .false. + + ! By considering current destination interface, source interface and + ! neutral interface anchored by the neighbour column, find which of + ! those are the shallowes for each column. Whichever interfaces are + ! minimums defines cases that are considered to find the next neutral + ! interface between the columns. + + case_m = minloc([p_srcdi_m(is_m,ks_m), & + p_ni_srcdi_p(isn_p,ksn_p), & + p_dst_m(kd_m+1)], dim = 1) + case_p = minloc([p_srcdi_p(is_p,ks_p), & + p_ni_srcdi_m(isn_m,ksn_m), & + p_dst_p(kd_p+1)], dim = 1) + + found_ni = .false. + + if (case_m == 3 .and. case_p == 3) then + + if (is_p == 2 .and. is_m == 2) then + x_ni_m(nic) = (p_dst_m(kd_m+1) - p_srcdi_m(1,ks_m)) & + /(p_srcdi_m(2,ks_m) - p_srcdi_m(1,ks_m)) + p_ni_m(nic) = p_dst_m(kd_m+1) + t_ni_m(it,nic) = peval(tpc_src_m(:,ks_m,it), x_ni_m(nic)) + t_ni_m(is,nic) = peval(tpc_src_m(:,ks_m,is), x_ni_m(nic)) + x_ni_p(nic) = (p_dst_p(kd_p+1) - p_srcdi_p(1,ks_p)) & + /(p_srcdi_p(2,ks_p) - p_srcdi_p(1,ks_p)) + p_ni_p(nic) = p_dst_p(kd_p+1) + t_ni_p(it,nic) = peval(tpc_src_p(:,ks_p,it), x_ni_p(nic)) + t_ni_p(is,nic) = peval(tpc_src_p(:,ks_p,is), x_ni_p(nic)) + r_m = x_ni_m(nic) + q_m = 1._r8 - r_m + r_p = x_ni_p(nic) + q_p = 1._r8 - r_p + drho_curr = drho(t_ni_m(it,nic), t_ni_m(is,nic), & + t_ni_p(it,nic), t_ni_p(is,nic), & + .5_r8*( drhodt_srcdi_m(1,ks_m)*q_m & + + drhodt_srcdi_m(2,ks_m)*r_m & + + drhodt_srcdi_p(1,ks_p)*q_p & + + drhodt_srcdi_p(2,ks_p)*r_p), & + .5_r8*( drhods_srcdi_m(1,ks_m)*q_m & + + drhods_srcdi_m(2,ks_m)*r_m & + + drhods_srcdi_p(1,ks_p)*q_p & + + drhods_srcdi_p(2,ks_p)*r_p)) + if (drho_curr <= - rhoeps) then + drhodt_x0 = .5_r8*( drhodt_srcdi_m(1,ks_m) & + + drhodt_srcdi_p(1,ks_p)*q_p & + + drhodt_srcdi_p(2,ks_p)*r_p) + drhodt_x1 = .5_r8*( drhodt_srcdi_m(2,ks_m) & + + drhodt_srcdi_p(1,ks_p)*q_p & + + drhodt_srcdi_p(2,ks_p)*r_p) + drhods_x0 = .5_r8*( drhods_srcdi_m(1,ks_m) & + + drhods_srcdi_p(1,ks_p)*q_p & + + drhods_srcdi_p(2,ks_p)*r_p) + drhods_x1 = .5_r8*( drhods_srcdi_m(2,ks_m) & + + drhods_srcdi_p(1,ks_p)*q_p & + + drhods_srcdi_p(2,ks_p)*r_p) + x = drhoroot(tpc_src_m(:,ks_m,it), tpc_src_m(:,ks_m,is), & + t_ni_p(it,nic), t_ni_p(is,nic), & + drhodt_x1, drhodt_x0, drhods_x1, drhods_x0) + p_ni_m(nic) = p_srcdi_m(2,ks_m)*x & + + p_srcdi_m(1,ks_m)*(1._r8 - x) + if (p_ni_m(nic) > p_ni_m(nip) .and. & + p_ni_m(nic) < p_ni_srcdi_p(isn_p,ksn_p)) then + x_ni_m(nic) = x + do nt = 1, ntr_loc + t_ni_m(nt,nic) = peval(tpc_src_m(:,ks_m,nt), & + x_ni_m(nic)) + enddo + do nt = 3, ntr_loc + t_ni_p(nt,nic) = peval(tpc_src_p(:,ks_p,nt), & + x_ni_p(nic)) + enddo + found_ni = .true. + endif + advance_dst_p = .true. + elseif (drho_curr >= rhoeps) then + drhodt_x0 = .5_r8*( drhodt_srcdi_p(1,ks_p) & + + drhodt_srcdi_m(1,ks_m)*q_m & + + drhodt_srcdi_m(2,ks_m)*r_m) + drhodt_x1 = .5_r8*( drhodt_srcdi_p(2,ks_p) & + + drhodt_srcdi_m(1,ks_m)*q_m & + + drhodt_srcdi_m(2,ks_m)*r_m) + drhods_x0 = .5_r8*( drhods_srcdi_p(1,ks_p) & + + drhods_srcdi_m(1,ks_m)*q_m & + + drhods_srcdi_m(2,ks_m)*r_m) + drhods_x1 = .5_r8*( drhods_srcdi_p(2,ks_p) & + + drhods_srcdi_m(1,ks_m)*q_m & + + drhods_srcdi_m(2,ks_m)*r_m) + x = drhoroot(tpc_src_p(:,ks_p,it), tpc_src_p(:,ks_p,is), & + t_ni_m(it,nic), t_ni_m(is,nic), & + drhodt_x1, drhodt_x0, drhods_x1, drhods_x0) + p_ni_p(nic) = p_srcdi_p(2,ks_p)*x & + + p_srcdi_p(1,ks_p)*(1._r8 - x) + if (p_ni_p(nic) > p_ni_p(nip) .and. & + p_ni_p(nic) < p_ni_srcdi_m(isn_m,ksn_m)) then + x_ni_p(nic) = x + do nt = 1, ntr_loc + t_ni_p(nt,nic) = peval(tpc_src_p(:,ks_p,nt), & + x_ni_p(nic)) + enddo + do nt = 3, ntr_loc + t_ni_m(nt,nic) = peval(tpc_src_m(:,ks_m,nt), & + x_ni_m(nic)) + enddo + found_ni = .true. + endif + advance_dst_m = .true. + else + do nt = 3, ntr_loc + t_ni_m(nt,nic) = peval(tpc_src_m(:,ks_m,nt), x_ni_m(nic)) + t_ni_p(nt,nic) = peval(tpc_src_p(:,ks_p,nt), x_ni_p(nic)) + enddo + found_ni = .true. + advance_dst_m = .true. + advance_dst_p = .true. + endif + else + if (is_p /= 2) advance_dst_m = .true. + if (is_m /= 2) advance_dst_p = .true. + endif + + elseif (case_m == 3) then + + if (is_p == 2) then + x_ni_m(nic) = (p_dst_m(kd_m+1) - p_srcdi_m(1,ks_m)) & + /(p_srcdi_m(2,ks_m) - p_srcdi_m(1,ks_m)) + p_ni_m(nic) = p_dst_m(kd_m+1) + t_ni_m(it,nic) = peval(tpc_src_m(:,ks_m,it), x_ni_m(nic)) + t_ni_m(is,nic) = peval(tpc_src_m(:,ks_m,is), x_ni_m(nic)) + r_m = x_ni_m(nic) + q_m = 1._r8 - r_m + drhodt_x0 = .5_r8*( drhodt_srcdi_p(1,ks_p) & + + drhodt_srcdi_m(1,ks_m)*q_m & + + drhodt_srcdi_m(2,ks_m)*r_m) + drhodt_x1 = .5_r8*( drhodt_srcdi_p(2,ks_p) & + + drhodt_srcdi_m(1,ks_m)*q_m & + + drhodt_srcdi_m(2,ks_m)*r_m) + drhods_x0 = .5_r8*( drhods_srcdi_p(1,ks_p) & + + drhods_srcdi_m(1,ks_m)*q_m & + + drhods_srcdi_m(2,ks_m)*r_m) + drhods_x1 = .5_r8*( drhods_srcdi_p(2,ks_p) & + + drhods_srcdi_m(1,ks_m)*q_m & + + drhods_srcdi_m(2,ks_m)*r_m) + x = drhoroot(tpc_src_p(:,ks_p,it), tpc_src_p(:,ks_p,is), & + t_ni_m(it,nic), t_ni_m(is,nic), & + drhodt_x1, drhodt_x0, drhods_x1, drhods_x0) + p_ni_p(nic) = p_srcdi_p(2,ks_p)*x & + + p_srcdi_p(1,ks_p)*(1._r8 - x) + if (p_ni_p(nic) > p_ni_p(nip) .and. & + p_ni_p(nic) < p_ni_srcdi_m(isn_m,ksn_m)) then + x_ni_p(nic) = x + do nt = 1, ntr_loc + t_ni_p(nt,nic) = peval(tpc_src_p(:,ks_p,nt), x_ni_p(nic)) + enddo + do nt = 3, ntr_loc + t_ni_m(nt,nic) = peval(tpc_src_m(:,ks_m,nt), x_ni_m(nic)) + enddo + found_ni = .true. + advance_dst_m = .true. + else + if (case_p == 1 .and. p_ni_srcdi_p(is_p,ks_p) == mval) then + advance_src_p = .true. + else + advance_dst_m = .true. + endif + endif + else + advance_dst_m = .true. + endif + + elseif (case_p == 3) then + + if (is_m == 2) then + x_ni_p(nic) = (p_dst_p(kd_p+1) - p_srcdi_p(1,ks_p)) & + /(p_srcdi_p(2,ks_p) - p_srcdi_p(1,ks_p)) + p_ni_p(nic) = p_dst_p(kd_p+1) + t_ni_p(it,nic) = peval(tpc_src_p(:,ks_p,it), x_ni_p(nic)) + t_ni_p(is,nic) = peval(tpc_src_p(:,ks_p,is), x_ni_p(nic)) + r_p = x_ni_p(nic) + q_p = 1._r8 - r_p + drhodt_x0 = .5_r8*( drhodt_srcdi_m(1,ks_m) & + + drhodt_srcdi_p(1,ks_p)*q_p & + + drhodt_srcdi_p(2,ks_p)*r_p) + drhodt_x1 = .5_r8*( drhodt_srcdi_m(2,ks_m) & + + drhodt_srcdi_p(1,ks_p)*q_p & + + drhodt_srcdi_p(2,ks_p)*r_p) + drhods_x0 = .5_r8*( drhods_srcdi_m(1,ks_m) & + + drhods_srcdi_p(1,ks_p)*q_p & + + drhods_srcdi_p(2,ks_p)*r_p) + drhods_x1 = .5_r8*( drhods_srcdi_m(2,ks_m) & + + drhods_srcdi_p(1,ks_p)*q_p & + + drhods_srcdi_p(2,ks_p)*r_p) + x = drhoroot(tpc_src_m(:,ks_m,it), tpc_src_m(:,ks_m,is), & + t_ni_p(it,nic), t_ni_p(is,nic), & + drhodt_x1, drhodt_x0, drhods_x1, drhods_x0) + p_ni_m(nic) = p_srcdi_m(2,ks_m)*x & + + p_srcdi_m(1,ks_m)*(1._r8 - x) + if (p_ni_m(nic) > p_ni_m(nip) .and. & + p_ni_m(nic) < p_ni_srcdi_p(isn_p,ksn_p)) then + x_ni_m(nic) = x + do nt = 1, ntr_loc + t_ni_m(nt,nic) = peval(tpc_src_m(:,ks_m,nt), x_ni_m(nic)) + enddo + do nt = 3, ntr_loc + t_ni_p(nt,nic) = peval(tpc_src_p(:,ks_p,nt), x_ni_p(nic)) + enddo + found_ni = .true. + advance_dst_p = .true. + else + if (case_m == 1 .and. p_ni_srcdi_m(is_m,ks_m) == mval) then + advance_src_m = .true. + else + advance_dst_p = .true. + endif + endif + else + advance_dst_p = .true. + endif + + elseif (case_m == 1 .and. case_p == 1) then + + if (p_ni_srcdi_m(is_m,ks_m) /= mval .and. & + p_ni_srcdi_p(is_p,ks_p) /= mval) then + x_ni_m(nic) = real(is_m - 1, r8) + p_ni_m(nic) = p_srcdi_m(is_m,ks_m) + x_ni_p(nic) = real(is_p - 1, r8) + p_ni_p(nic) = p_srcdi_p(is_p,ks_p) + do nt = 1, ntr_loc + t_ni_m(nt,nic) = t_srcdi_m(is_m,ks_m,nt) + t_ni_p(nt,nic) = t_srcdi_p(is_p,ks_p,nt) + enddo + found_ni = .true. + advance_src_m = .true. + advance_src_p = .true. + else + if (p_ni_srcdi_m(is_m,ks_m) == mval) advance_src_m = .true. + if (p_ni_srcdi_p(is_p,ks_p) == mval) advance_src_p = .true. + endif + + elseif (case_m == 1) then + + if (p_ni_srcdi_m(is_m,ks_m) /= mval .and. & + p_ni_srcdi_m(is_m,ks_m) >= p_srcdi_p(1,ks_p)) then + x_ni_m(nic) = real(is_m - 1, r8) + p_ni_m(nic) = p_srcdi_m(is_m,ks_m) + p_ni_p(nic) = p_ni_srcdi_m(is_m,ks_m) + x_ni_p(nic) = (p_ni_p(nic) - p_srcdi_p(1,ks_p)) & + /(p_srcdi_p(2,ks_p) - p_srcdi_p(1,ks_p)) + do nt = 1, ntr_loc + t_ni_m(nt,nic) = t_srcdi_m(is_m,ks_m,nt) + t_ni_p(nt,nic) = peval(tpc_src_p(:,ks_p,nt), x_ni_p(nic)) + enddo + found_ni = .true. + endif + advance_src_m = .true. + + elseif (case_p == 1) then + + if (p_ni_srcdi_p(is_p,ks_p) /= mval .and. & + p_ni_srcdi_p(is_p,ks_p) >= p_srcdi_m(1,ks_m)) then + x_ni_p(nic) = real(is_p - 1, r8) + p_ni_p(nic) = p_srcdi_p(is_p,ks_p) + p_ni_m(nic) = p_ni_srcdi_p(is_p,ks_p) + x_ni_m(nic) = (p_ni_m(nic) - p_srcdi_m(1,ks_m)) & + /(p_srcdi_m(2,ks_m) - p_srcdi_m(1,ks_m)) + do nt = 1, ntr_loc + t_ni_p(nt,nic) = t_srcdi_p(is_p,ks_p,nt) + t_ni_m(nt,nic) = peval(tpc_src_m(:,ks_m,nt), x_ni_m(nic)) + enddo + found_ni = .true. + endif + advance_src_p = .true. + + else + write(lp,*) 'Unexpected case_m == 2 and case_p == 2!' + call xchalt('(ndiff_flx)') + stop '(ndiff_flx)' + endif + + if (found_ni) then + + ! if a neutral interface is found, check whether the current and + ! previous neutral interfaces are between same source and + ! destination layers. If so, a neutral layer, suitable for diffusive + ! flux computations, has been found. + if (ks_m == ks_m_prev .and. ks_p == ks_p_prev .and. & + p_ni_m(nip) >= p_dst_m(kd_m) .and. & + p_ni_m(nic) <= p_dst_m(kd_m+1) .and. & + p_ni_p(nip) >= p_dst_p(kd_p) .and. & + p_ni_p(nic) <= p_dst_p(kd_p+1)) then + + if (x_ni_m(nic) - x_ni_m(nip) < 1.e-12_r8) then + do nt = 1, ntr_loc + t_nl_m(nt) = t_ni_m(nt,nic) + enddo + else + q = 1._r8/(x_ni_m(nic) - x_ni_m(nip)) + do nt = 1, ntr_loc + t_nl_m(nt) = ipeval(tpc_src_m(:,ks_m,nt), & + x_ni_m(nip), x_ni_m(nic))*q + enddo + endif + if (x_ni_p(nic) - x_ni_p(nip) < 1.e-12_r8) then + do nt = 1, ntr_loc + t_nl_p(nt) = t_ni_p(nt,nic) + enddo + else + q = 1._r8/(x_ni_p(nic) - x_ni_p(nip)) + do nt = 1, ntr_loc + t_nl_p(nt) = ipeval(tpc_src_p(:,ks_p,nt), & + x_ni_p(nip), x_ni_p(nic))*q + enddo + endif + + dp_ni_m = p_ni_m(nic) - p_ni_m(nip) + dp_ni_p = p_ni_p(nic) - p_ni_p(nip) + + q = cdiff*(difiso(i_m,j_m,ks_m) + difiso(i_p,j_p,ks_p)) & + *dp_ni_m*dp_ni_p/max(dp_ni_m + dp_ni_p, 2._r8*dpeps) + + dt = t_nl_m(it) - t_nl_p(it) + ds = t_nl_m(is) - t_nl_p(is) + + if (dt*( temp(i_m,j_m,ks_m+nn) & + - temp(i_p,j_p,ks_p+nn)) >= 0._r8 .and. & + dt*( t_ni_m(it,nip) - t_ni_p(it,nip)) >= 0._r8 .and. & + dt*( t_ni_m(it,nic) - t_ni_p(it,nic)) >= 0._r8 .and. & + ds*( saln(i_m,j_m,ks_m+nn) & + - saln(i_p,j_p,ks_p+nn)) >= 0._r8 .and. & + 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 + 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 + 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(epsil, p_ni_lo - p_ni_up) + do while (kuv <= kk) + kuvm = kuv + mm + if (puv(i_p,j_p,kuv+1) < p_ni_lo) then + mlfrac = max(0._r8, puv(i_p,j_p,kuv+1) & + - max(p_ni_up, puv(i_p,j_p,kuv))) & + *dp_ni_i + uvtflld(i_p,j_p,kuvm) = uvtflld(i_p,j_p,kuvm) & + + tflx*mlfrac + uvsflld(i_p,j_p,kuvm) = uvsflld(i_p,j_p,kuvm) & + + sflx*mlfrac + uvtflx(i_p,j_p,kuvm) = uvtflx(i_p,j_p,kuvm) + tflx*mlfrac + uvsflx(i_p,j_p,kuvm) = uvsflx(i_p,j_p,kuvm) + sflx*mlfrac + kuv = kuv + 1 + else + mlfrac = (p_ni_lo - max(p_ni_up, puv(i_p,j_p,kuv))) & + *dp_ni_i + uvtflld(i_p,j_p,kuvm) = uvtflld(i_p,j_p,kuvm) & + + tflx*mlfrac + uvsflld(i_p,j_p,kuvm) = uvsflld(i_p,j_p,kuvm) & + + sflx*mlfrac + uvtflx(i_p,j_p,kuvm) = uvtflx(i_p,j_p,kuvm) + tflx*mlfrac + uvsflx(i_p,j_p,kuvm) = uvsflx(i_p,j_p,kuvm) + sflx*mlfrac + exit + endif + enddo + endif + + 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 + + endif + + ks_m_prev = ks_m + ks_p_prev = ks_p + nip = 3 - nip + nic = 3 - nic + + endif + + enddo search_loop2 + + ! Linearly interpolate the neutral slope estimates from the source data to + ! destination interfaces. + if (nns == 0) then + nslpxy(i_p,j_p,:) = 0._r8 + else + do kd = 1, kk + p_nslp_dst = .5_r8*(p_dst_m(kd) + p_dst_p(kd)) + if (p_nslp_dst > p_nslp_src(1)) exit + nslpxy(i_p,j_p,kd) = nslp_src(1) + enddo + ks = 1 + interp_loop: do + do while (p_nslp_dst > p_nslp_src(ks)) + if (ks == nns) exit interp_loop + ks = ks + 1 + enddo + q = (p_nslp_src(ks) - p_nslp_dst) & + /max(p_nslp_src(ks) - p_nslp_src(ks-1), epsil) + nslpxy(i_p,j_p,kd) = q*nslp_src(ks-1) + (1._r8 - q)*nslp_src(ks) + kd = kd + 1 + if (kd > kk) exit + p_nslp_dst = .5_r8*(p_dst_m(kd) + p_dst_p(kd)) + enddo interp_loop + do kd = kd, kk + nslpxy(i_p,j_p,kd) = nslp_src(nns) + enddo + endif + + end subroutine ndiff_flx + + ! --------------------------------------------------------------------------- + ! Public procedures. + ! --------------------------------------------------------------------------- + + subroutine ndiff_prep_jslice(p_src_rs, p_dst_rs, trc_rcss, & + i_lb, i_ub, j, j_rs, mm) + + real(r8), dimension(:,1-nbdy:,:), intent(in) :: p_src_rs, p_dst_rs + type(recon_src_struct) , dimension(:), intent(inout) :: trc_rcss + integer, intent(in) :: i_lb, i_ub, j, j_rs, 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)) + + ! Extract polynomial coefficients of the reconstructions. + do nt = 1, ntr_loc + errstat = extract_polycoeff(trc_rcss(nt), & + tpc_src_rs(:,:,nt,i,j_rs), i, j_rs) + if (errstat /= hor3map_noerr) then + write(lp,*) trim(hor3map_errstr(errstat)) + call xchalt('(ndiff_prep_jslice)') + stop '(ndiff_prep_jslice)' + endif + enddo + + ! Find index of deepest source layer with non-zero thickness. + ksmx_rs(i,j_rs) = kk + do k = kk, 1, -1 + if (p_src_rs(k,i,j_rs) == p_src_rs(kk+1,i,j_rs)) & + ksmx_rs(i,j_rs) = k - 1 + enddo + + ! Find index of deepest destination layer with non-zero thickness. + kdmx_rs(i,j_rs) = 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 + 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) + do nt = 1, ntr_loc + t_srcdi_rs(1,k,nt,i,j_rs) = peval0(tpc_src_rs(:,k,nt,i,j_rs)) + t_srcdi_rs(2,k,nt,i,j_rs) = peval1(tpc_src_rs(:,k,nt,i,j_rs)) + enddo + 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)) + enddo + + flxconv_rs(:,:,i,j_rs) = 0._r8 + + enddo + enddo + + 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)) + 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)) + vtflld(i,j,km) = 0._r8 + vsflld(i,j,km) = 0._r8 + enddo + enddo + enddo + + end subroutine ndiff_prep_jslice + + subroutine ndiff_uflx_jslice(p_dst_rs, i_lb, i_ub, j, j_rs, mm, nn) + + real(r8), dimension(:,1-nbdy:,:), target, intent(in) :: p_dst_rs + integer, intent(in) :: i_lb, i_ub, j, j_rs, mm, nn + + real(r8), dimension(:,:,:), pointer :: & + t_srcdi_m, tpc_src_m, t_srcdi_p, tpc_src_p + real(r8), dimension(:,:), pointer :: & + p_srcdi_m, drhodt_srcdi_m, drhods_srcdi_m, p_srcdi_p, drhodt_srcdi_p, drhods_srcdi_p + real(r8), dimension(:), pointer :: & + p_dst_m, p_dst_p + real(r8) :: cdiff, cnslp + 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) + cdiff = delt1*scuy(i,j)*scuxi(i,j) + cnslp = alpha0*scuxi(i,j)/g + + call ndiff_flx(p_srcdi_m, t_srcdi_m, tpc_src_m, & + drhodt_srcdi_m, drhods_srcdi_m, & + p_dst_m, ksmx_m, kdmx_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, pu, utflld, usflld, utflx, usflx, nslpx, & + i-1, j, i, j, j_rs, j_rs, mm, nn) + + enddo + enddo + + end subroutine ndiff_uflx_jslice + + subroutine ndiff_vflx_jslice(p_dst_rs, i_lb, i_ub, j, j_rs, mm, nn) + + real(r8), dimension(:,1-nbdy:,:), target, intent(in) :: p_dst_rs + integer, intent(in) :: i_lb, i_ub, j, j_rs, mm, nn + + real(r8), dimension(:,:,:), pointer :: & + t_srcdi_m, tpc_src_m, t_srcdi_p, tpc_src_p + real(r8), dimension(:,:), pointer :: & + p_srcdi_m, drhodt_srcdi_m, drhods_srcdi_m, p_srcdi_p, drhodt_srcdi_p, drhods_srcdi_p + real(r8), dimension(:), pointer :: & + p_dst_m, p_dst_p + real(r8) :: cdiff, cnslp + integer :: j_rs_m, l, i, ksmx_m, ksmx_p, kdmx_m, kdmx_p + + j_rs_m = 3 - j_rs + + 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 ) + t_srcdi_m => t_srcdi_rs(:,:,:,i,j_rs_m) + t_srcdi_p => t_srcdi_rs(:,:,:,i,j_rs ) + tpc_src_m => tpc_src_rs(:,:,:,i,j_rs_m) + tpc_src_p => tpc_src_rs(:,:,:,i,j_rs ) + drhodt_srcdi_m => drhodt_srcdi_rs(:,:,i,j_rs_m) + drhodt_srcdi_p => drhodt_srcdi_rs(:,:,i,j_rs ) + drhods_srcdi_m => drhods_srcdi_rs(:,:,i,j_rs_m) + drhods_srcdi_p => drhods_srcdi_rs(:,:,i,j_rs ) + p_dst_m => p_dst_rs(:,i,j_rs_m) + p_dst_p => p_dst_rs(:,i,j_rs ) + ksmx_m = ksmx_rs(i,j_rs_m) + ksmx_p = ksmx_rs(i,j_rs ) + kdmx_m = kdmx_rs(i,j_rs_m) + kdmx_p = kdmx_rs(i,j_rs ) + cdiff = delt1*scvx(i,j)*scvyi(i,j) + cnslp = alpha0*scvyi(i,j)/g + + call ndiff_flx(p_srcdi_m, t_srcdi_m, tpc_src_m, & + drhodt_srcdi_m, drhods_srcdi_m, & + p_dst_m, ksmx_m, kdmx_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, pv, vtflld, vsflld, vtflx, vsflx, nslpy, & + i, j-1, i, j, j_rs_m, j_rs, mm, nn) + + enddo + enddo + + end subroutine ndiff_vflx_jslice + + subroutine ndiff_update_trc_jslice(p_dst_rs, trc_rm, i_lb, i_ub, j, j_rs) + + real(r8), dimension(:,1-nbdy:,:), intent(in) :: p_dst_rs + real(r8), dimension(:,:,1-nbdy:), intent(inout) :: trc_rm + integer, intent(in) :: i_lb, i_ub, j, j_rs + + 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 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), dpeps)) + do nt = 1, ntr_loc + trc_rm(k,nt,i) = trc_rm(k,nt,i) - q*flxconv_rs(k,nt,i,j_rs) + enddo + enddo + enddo + enddo + + end subroutine ndiff_update_trc_jslice + +end module mod_ndiff diff --git a/phy/mod_pgforc.F b/phy/mod_pgforc.F index c97be6f3..22eed8c6 100644 --- a/phy/mod_pgforc.F +++ b/phy/mod_pgforc.F @@ -1,5 +1,5 @@ ! ------------------------------------------------------------------------------ -! Copyright (C) 2005-2020 Mats Bentsen, Mehmet Ilicak +! Copyright (C) 2005-2022 Mats Bentsen, Mehmet Ilicak ! ! This file is part of BLOM. ! @@ -157,11 +157,11 @@ subroutine pgforc(m,n,mm,nn,k1m,k1n) c --- compute new -dpu,dpv- field. c c$OMP PARALLEL DO PRIVATE(k,kn,l,i) - do j=0,jj+1 + do j=-2,jj+2 do k=1,kk kn=k+nn do l=1,isp(j) - do i=max(0,ifp(j,l)),min(ii+1,ilp(j,l)) + do i=max(-2,ifp(j,l)),min(ii+2,ilp(j,l)) p(i,j,k+1)=p(i,j,k)+dp(i,j,kn) enddo enddo @@ -170,11 +170,11 @@ subroutine pgforc(m,n,mm,nn,k1m,k1n) c$OMP END PARALLEL DO c c$OMP PARALLEL DO PRIVATE(k,kn,l,i,q) - do j=1,jj + 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+1,ilu(j,l)) + 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*((min(q,p(i-1,j,k+1))-min(q,p(i-1,j,k))) @@ -182,15 +182,8 @@ subroutine pgforc(m,n,mm,nn,k1m,k1n) pu(i,j,k+1)=pu(i,j,k)+dpu(i,j,kn) enddo enddo - enddo - enddo -c$OMP END PARALLEL DO -c$OMP PARALLEL DO PRIVATE(k,kn,l,i,q) - do j=1,jj+1 - do k=1,kk - kn=k+nn do l=1,isv(j) - do i=max(1,ifv(j,l)),min(ii,ilv(j,l)) + 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*((min(q,p(i,j-1,k+1))-min(q,p(i,j-1,k))) diff --git a/phy/mod_remap.F b/phy/mod_remap.F index 3350f32a..44180dd1 100644 --- a/phy/mod_remap.F +++ b/phy/mod_remap.F @@ -1,5 +1,5 @@ ! ------------------------------------------------------------------------------ -! Copyright (C) 2006-2020 Mats Bentsen, Mehmet Ilicak +! Copyright (C) 2006-2022 Mats Bentsen, Mehmet Ilicak ! ! This file is part of BLOM. ! @@ -1085,9 +1085,9 @@ subroutine remap_eitvel(scuy,scvx,scp2i,scp2,pbmin,pbu,pbv,plo, endif c c --- --- u-component of mass, heat and salt flux. - uflx(i,j)=fdu(i,j) - utflx(i,j)=ftu(i,j) - usflx(i,j)=fsu(i,j) + uflx(i,j)=uflx(i,j)+fdu(i,j) + utflx(i,j)=utflx(i,j)+ftu(i,j) + usflx(i,j)=usflx(i,j)+fsu(i,j) c enddo enddo @@ -2549,9 +2549,9 @@ subroutine remap_eitflx(scuy,scvx,scp2i,scp2,pbmin,pbu,pbv,plo, endif c c --- --- u-component of mass, heat and salt flux. - uflx(i,j)=fdu(i,j) - utflx(i,j)=ftu(i,j) - usflx(i,j)=fsu(i,j) + uflx(i,j)=uflx(i,j)+fdu(i,j) + utflx(i,j)=utflx(i,j)+ftu(i,j) + usflx(i,j)=usflx(i,j)+fsu(i,j) c enddo enddo diff --git a/phy/mod_state.F90 b/phy/mod_state.F90 index e78236fc..ceb22c4d 100644 --- a/phy/mod_state.F90 +++ b/phy/mod_state.F90 @@ -1,5 +1,5 @@ ! ------------------------------------------------------------------------------ -! Copyright (C) 2020 Mats Bentsen +! Copyright (C) 2020-2022 Mats Bentsen ! ! This file is part of BLOM. ! @@ -86,7 +86,7 @@ module mod_state p, pu, pv, phi, ubflxs, vbflxs, & ub, vb, pb, pbu, pbv, ubflxs_p, vbflxs_p, & pb_p, pbu_p, pbv_p, ubcors_p, vbcors_p, sealv, kfpla, & - inivar_state + inivar_state, init_fluxes contains @@ -351,4 +351,48 @@ subroutine inivar_state end subroutine inivar_state + subroutine init_fluxes(m, n, mm, nn, k1m, k1n, update_flux_halos) + ! --------------------------------------------------------------------------- + ! Reset fluxes to be accumulated over a model time step and update flux + ! halos if requested. + ! --------------------------------------------------------------------------- + + integer, intent(in) :: m, n, mm, nn, k1m, k1n + logical, intent(in) :: update_flux_halos + + integer :: i, j, k, km, l + + !$omp parallel do private(k, km, l, i) + do j = 0, jj+2 + do k = 1, kk + km = k + mm + do l=1, isu(j) + do i=max(0, ifu(j,l)), min(ii+2, ilu(j,l)) + uflx(i,j,km) = 0._r8 + utflx(i,j,km) = 0._r8 + usflx(i,j,km) = 0._r8 + enddo + enddo + do l=1, isv(j) + do i=max(0, ifv(j,l)), min(ii+2, ilv(j,l)) + vflx(i,j,km) = 0._r8 + vtflx(i,j,km) = 0._r8 + vsflx(i,j,km) = 0._r8 + enddo + enddo + enddo + enddo + !$omp end parallel do + + if (update_flux_halos) then + call xctilr(uflx (1-nbdy,1-nbdy,k1n), 1, kk, 1, 1, halo_uv) + call xctilr(utflx(1-nbdy,1-nbdy,k1n), 1, kk, 1, 1, halo_uv) + call xctilr(usflx(1-nbdy,1-nbdy,k1n), 1, kk, 1, 1, halo_uv) + call xctilr(vflx (1-nbdy,1-nbdy,k1n), 1, kk, 1, 1, halo_vv) + call xctilr(vtflx(1-nbdy,1-nbdy,k1n), 1, kk, 1, 1, halo_vv) + call xctilr(vsflx(1-nbdy,1-nbdy,k1n), 1, kk, 1, 1, halo_vv) + endif + + end subroutine init_fluxes + end module mod_state diff --git a/phy/mod_timing.F90 b/phy/mod_timing.F90 index f527d021..a3b1c824 100644 --- a/phy/mod_timing.F90 +++ b/phy/mod_timing.F90 @@ -1,5 +1,5 @@ ! ------------------------------------------------------------------------------ -! Copyright (C) 2006-2020 Mats Bentsen, Alok Kumar Gupta +! Copyright (C) 2006-2022 Mats Bentsen, Alok Kumar Gupta ! ! This file is part of BLOM. ! @@ -93,7 +93,7 @@ end subroutine init_timing real(r8) function get_time() ! --------------------------------------------------------------------------- - ! Return time in seconds since last call to either init_timer or get_time. + ! Return time in seconds since last call to either init_timing or get_time. ! --------------------------------------------------------------------------- if (mnproc == 1) then diff --git a/phy/mod_tmsmt.F b/phy/mod_tmsmt.F index 0449b551..5aec8d56 100644 --- a/phy/mod_tmsmt.F +++ b/phy/mod_tmsmt.F @@ -1,5 +1,5 @@ ! ------------------------------------------------------------------------------ -! Copyright (C) 2005-2021 Mats Bentsen +! Copyright (C) 2005-2022 Mats Bentsen ! ! This file is part of BLOM. ! @@ -29,6 +29,7 @@ module mod_tmsmt use mod_types, only: r8 use mod_constants, only: epsil, spval use mod_xc + use mod_vcoord, only: vcoord_type_tag, isopyc_bulkml use mod_state, only: dp, dpu, dpv, temp, saln, p, pb use mod_checksum, only: csdiag, chksummsk #ifdef TRC @@ -61,7 +62,7 @@ module mod_tmsmt . sold ! Salinity at old time level [g kg-1]. c public :: wuv1, wuv2, wts1, wts2, wbaro, dpold, dpuold, dpvold, - . inivar_tmsmt, tmsmt1, tmsmt2 + . inivar_tmsmt, initms, tmsmt1, tmsmt2 c contains c @@ -161,7 +162,7 @@ end subroutine inivar_tmsmt c c --- ------------------------------------------------------------------ c - subroutine tmsmt1(m,n,mm,nn,k1m,k1n) + subroutine initms(m,n,mm,nn,k1m,k1n) c c --- save old layer thickness, temperature and salinity for time c --- smoothing @@ -175,40 +176,70 @@ subroutine tmsmt1(m,n,mm,nn,k1m,k1n) integer nt #endif c - integer i,j,k,l,kn + integer i,j,k,l,km c -c$OMP PARALLEL DO PRIVATE(k,kn,l,i +c$OMP PARALLEL DO PRIVATE(k,km,l,i #ifdef TRC c$OMP+ ,nt #endif c$OMP+ ) do j=1,jj do k=1,kk - kn=k+nn + km=k+mm do l=1,isp(j) do i=max(1,ifp(j,l)),min(ii,ilp(j,l)) - dpold(i,j,kn)=dp(i,j,kn) - told(i,j,k)=temp(i,j,kn) - sold(i,j,k)=saln(i,j,kn) + dpold(i,j,km)=dp(i,j,km) + told(i,j,k)=temp(i,j,km) + sold(i,j,k)=saln(i,j,km) #ifdef TRC do nt=1,ntr - trcold(i,j,k,nt)=trc(i,j,kn,nt) + trcold(i,j,k,nt)=trc(i,j,km,nt) enddo #endif enddo enddo - do l=1,isu(j) - do i=max(1,ifu(j,l)),min(ii+1,ilu(j,l)) - dpuold(i,j,k)=dpu(i,j,kn) - enddo - enddo enddo enddo c$OMP END PARALLEL DO +c + if (csdiag) then + if (mnproc.eq.1) then + write (lp,*) 'initms:' + endif + call chksummsk(dpold,ip,2*kk,'dpold') + call chksummsk(told,ip,kk,'told') + call chksummsk(sold,ip,kk,'sold') +#ifdef TRC + do nt=1,ntr + call chksummsk(trcold(1-nbdy,1-nbdy,1,nt),ip,kk,'trcold') + enddo +#endif + endif +c + end subroutine initms +c + subroutine tmsmt1(m,n,mm,nn,k1m,k1n) +c +c --- save old layer thickness at velocity points for time smoothing in +c --- momentum equation. +c + use mod_xc +c + implicit none +c + integer m,n,mm,nn,k1m,k1n +c + integer i,j,k,l,kn +c c$OMP PARALLEL DO PRIVATE(k,kn,l,i) - do j=1,jj+1 + 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)) + dpuold(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)) dpvold(i,j,k)=dpv(i,j,kn) @@ -222,14 +253,8 @@ subroutine tmsmt1(m,n,mm,nn,k1m,k1n) if (mnproc.eq.1) then write (lp,*) 'tmsmt1:' endif - call chksummsk(dpold,ip,2*kk,'dpold') - call chksummsk(told,ip,kk,'told') - call chksummsk(sold,ip,kk,'sold') -#ifdef TRC - do nt=1,ntr - call chksummsk(trcold(1-nbdy,1-nbdy,1,nt),ip,kk,'trcold') - enddo -#endif + call chksummsk(dpuold,iu,kk,'dpuold') + call chksummsk(dpvold,iv,kk,'dpvold') endif c end subroutine tmsmt1 @@ -292,21 +317,25 @@ subroutine tmsmt2(m,n,mm,nn,k1m,k1n) pmid=max(0.,dp(i,j,km)) pnew=max(0.,dp(i,j,kn)*pbfacn(i)) dp(i,j,km)=wts1*pmid+wts2*(pold+pnew) + dpold(i,j,km)=dp(i,j,km) pold=pold+epsil pmid=pmid+epsil pnew=pnew+epsil temp(i,j,km)=(wts1*pmid*temp(i,j,km) . +wts2*(pold*told(i,j,k)+pnew*temp(i,j,kn))) . /(dp(i,j,km)+epsil) + told(i,j,k)=temp(i,j,km) saln(i,j,km)=(wts1*pmid*saln(i,j,km) . +wts2*(pold*sold(i,j,k)+pnew*saln(i,j,kn))) . /(dp(i,j,km)+epsil) + sold(i,j,k)=saln(i,j,km) #ifdef TRC do nt=1,ntr trc(i,j,km,nt)=(wts1*pmid*trc(i,j,km,nt) . +wts2*(pold*trcold(i,j,k,nt) . +pnew*trc(i,j,kn,nt))) . /(dp(i,j,km)+epsil) + trcold(i,j,k,nt)=trc(i,j,km,nt) enddo #endif enddo @@ -315,43 +344,61 @@ subroutine tmsmt2(m,n,mm,nn,k1m,k1n) enddo c$OMP END PARALLEL DO c - call xctilr(dp(1-nbdy,1-nbdy,k1m), 1,kk, 3,3, halo_ps) + if (vcoord_type_tag == isopyc_bulkml) then +c + call xctilr(dp(1-nbdy,1-nbdy,k1m), 1,kk, 3,3, halo_ps) c c$OMP PARALLEL DO PRIVATE(k,l,i) - do j=-2,jj+2 - do k=1,kk - do l=1,isp(j) - do i=max(-2,ifp(j,l)),min(ii+2,ilp(j,l)) - p(i,j,k+1)=p(i,j,k)+dp(i,j,k+mm) - enddo + do j=-2,jj+2 + do k=1,kk + do l=1,isp(j) + do i=max(-2,ifp(j,l)),min(ii+2,ilp(j,l)) + p(i,j,k+1)=p(i,j,k)+dp(i,j,k+mm) + enddo + enddo enddo enddo - enddo c$OMP END PARALLEL DO c c$OMP PARALLEL DO PRIVATE(k,km,l,i,q) - do j=-1,jj+2 - do k=1,kk - km=k+mm - 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,km)= - . .5*((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,km)= - . .5*((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)))) + do j=-1,jj+2 + do k=1,kk + km=k+mm + 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,km)= + . .5*((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,km)= + . .5*((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 +c$OMP END PARALLEL DO +c + else +c +c$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)) + p(i,j,k+1)=p(i,j,k)+dp(i,j,k+mm) + enddo + enddo enddo enddo - enddo c$OMP END PARALLEL DO +c + endif c if (csdiag) then if (mnproc.eq.1) then diff --git a/phy/mod_vcoord.F90 b/phy/mod_vcoord.F90 index d89dd3ec..cd6f87a6 100644 --- a/phy/mod_vcoord.F90 +++ b/phy/mod_vcoord.F90 @@ -1,5 +1,5 @@ ! ------------------------------------------------------------------------------ -! Copyright (C) 2021 Mats Bentsen +! Copyright (C) 2021-2022 Mats Bentsen ! ! This file is part of BLOM. ! @@ -27,15 +27,20 @@ module mod_vcoord use mod_config, only: inst_suffix use mod_constants, only: g, epsil, spval, onem use mod_xc - use mod_eos, only: sig + 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: reconstruction_struct, remap_struct, & - hor3map_plm, hor3map_ppm, hor3map_monotonic, & - hor3map_non_oscillatory, & + 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, & - prepare_reconstruction, reconstruct, regrid, & + initialize_rcgs, initialize_rcss, initialize_rms, & + prepare_reconstruction, reconstruct, & + extract_polycoeff, regrid2, & prepare_remapping, remap, & hor3map_noerr, hor3map_errstr + use mod_diffusion, only : ntrdif, difiso + use mod_ndiff, only: ndiff_prep_jslice, ndiff_uflx_jslice, & + ndiff_vflx_jslice, ndiff_update_trc_jslice use mod_checksum, only: csdiag, chksummsk #ifdef TRC use mod_tracers, only: ntr, trc @@ -76,9 +81,16 @@ module mod_vcoord integer, parameter :: & isopyc_bulkml = 1, & ! Vertical coordinate type: bulk surface mixed ! layer with isopycnic layers below. - cntiso_hybrid = 2 ! Vertical coordinate type: Hybrid coordinate + cntiso_hybrid = 2, & ! Vertical coordinate type: Hybrid coordinate ! with pressure coordinates towards the ! surface and continuous isopycnal below. +#ifdef TRC + ntr_loc = ntr + 2 ! Local number of tracers where temperature + ! and salinity is added to the ntr parameter. +#else + ntr_loc = 2 ! Local number of tracers consisting of + ! temperature and salinity. +#endif real(r8), parameter :: & bfsq_min = 1.e-7_r8, & ! Minimum buoyancy frequency squared in ! monotonized potential density to be used in @@ -86,15 +98,656 @@ module mod_vcoord regrid_mval = - 1.e33_r8 ! Missing value for regridding. - real(r8), dimension(1 - nbdy:idm + nbdy, 1 - nbdy:jdm + nbdy, kdm) :: & + type(recon_grd_struct) :: rcgs + type(recon_src_struct) :: d_rcss, v_rcss + type(recon_src_struct) , dimension(ntr_loc) :: trc_rcss + type(remap_struct) :: rms + + real(r8), dimension(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy,kdm) :: & sigmar ! Reference potential density [g cm-3]. public :: vcoord_type_tag, isopyc_bulkml, cntiso_hybrid, sigmar, & - readnml_vcoord, inivar_vcoord, cntiso_hybrid_regrid_remap, & - remap_velocity + readnml_vcoord, inivar_vcoord, cntiso_hybrid_regrid_direct_remap, & + cntiso_hybrid_regrid_remap, remap_velocity 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, i_lb, i_ub, j, j_rs, nn) + ! --------------------------------------------------------------------------- + ! Prepare vertical layer reconstruction along a j-slice of the model data. + ! --------------------------------------------------------------------------- + + real(r8), dimension(:,1-nbdy:), intent(out) :: p_src + 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)) + + 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 + + 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(i_lb, i_ub, j, j_rs, nn) + ! --------------------------------------------------------------------------- + ! Vertically reconstruct temperature, salinity and additional tracers along a + ! j-slice of the model data. + ! --------------------------------------------------------------------------- + + 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) +#ifdef TRC + do nt = 1, ntr + trc_1d(k,nt+2) = trc(i,j,kn,nt) + enddo +#endif + 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 + + 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) < epsil + 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) < epsil + 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) < epsil + 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, 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 + + integer, parameter :: & + p_ord = 4, & + it = 1, & + is = 2 + + real(r8), dimension(p_ord+1,kdm,2,1-nbdy:idm+nbdy) :: tpc_src + real(r8), dimension(2,kdm,2,1-nbdy:idm+nbdy) :: t_srcdi + real(r8), dimension(2,kdm) :: sig_srcdi + integer, dimension(1-nbdy:idm+nbdy) :: ksmx, kdmx + + real(r8), dimension(kdm+1) :: sigmar_1d, pmin, sig_pmin + real(r8) :: nudge_factor, sig_max, dpmin_sfc, dsig, dsigdx, q + integer :: l, i, nt, k, kr, kl, klastok, kt, errstat + logical :: ok + + real(r8) :: x,tt,st + + nudge_factor = 1._r8 + nudge_factor = 1._r8/10._r8 + + do l = 1, isp(j) + do i = max(i_lb, ifp(j, l)), min(i_ub, ilp(j, l)) + + ! Extract polynomial coefficients of the reconstructions. + do nt = 1, 2 + 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('(ndiff_prep_jslice)') + stop '(ndiff_prep_jslice)' + endif + 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 + + ! Store variables in dual interface arrays 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) + do nt = 1, 2 + 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 + 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) + + ! 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) + + do k = kdmx(i)+1, kk+1 + p_dst(k,i) = p_src(kk+1,i) + enddo + + 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) + + sig_pmin(1) = sig_srcdi(1,1) + kr = 2 + kl = 1 + do while (kr <= kdmx(i)) + do while (p_src(kl+1,i) < pmin(kr)) + kl = kl + 1 + enddo + sig_pmin(kr) = ( (p_src(kl+1,i) - pmin(kr))*sig_srcdi(1,kl) & + + (pmin(kr) - p_src(kl,i))*sig_srcdi(2,kl)) & + /(p_src(kl+1,i) - p_src(kl,i)) + if (sigmar_1d(kr) > sig_pmin(kr)) exit + p_dst(kr,i) = pmin(kr) + kr = kr + 1 + enddo + + klastok = kr - 1 + do k = kr, min(ksmx(i), kdmx(i)) + ok = .true. + if (sigmar_1d(k) < sig_srcdi(2,k-1) .and. & + sigmar_1d(k) < sig_srcdi(1,k )) then + dsig = (sigmar_1d(k) - sig_srcdi(2,k-1))*nudge_factor + 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)) + if (- dsig > .5_r8*dsigdx) then + dsigdx = sig_srcdi(2,k-1) - sig_srcdi(1,k-1) + if (- dsig > .5_r8*dsigdx) ok = .false. + endif + if (ok) p_dst(k,i) = p_src(k,i) & + + dsig*(p_src(k,i) - p_src(k-1,i))/dsigdx + elseif (sigmar_1d(k) > sig_srcdi(2,k-1) .and. & + sigmar_1d(k) > sig_srcdi(1,k )) then + dsig = (sigmar_1d(k) - sig_srcdi(1,k))*nudge_factor + 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)) + if (dsig > .5_r8*dsigdx) then + dsigdx = sig_srcdi(2,k) - sig_srcdi(1,k) + if (dsig > .5_r8*dsigdx) ok = .false. + endif + if (ok) p_dst(k,i) = p_src(k,i) & + + dsig*(p_src(k+1,i) - p_src(k,i))/dsigdx + else + p_dst(k,i) = p_src(k,i) + endif + if (ok) then + p_dst(k,i) = & + min(max(p_dst(k,i), pmin(k), & + p_dst(klastok,i) + (k - klastok)*dpmin_interior), & + p_src(kk+1,i)) + if (k - klastok > 1) then + q = (p_dst(k,i) - p_dst(klastok,i))/(k - klastok) + do kt = klastok+1, k-1 + p_dst(kt,i) = min(max(p_dst(kt-1,i) + q, pmin(kt)), & + p_src(kk+1,i)) + enddo + endif + klastok = k + endif + enddo + + do k = max(kr, min(ksmx(i), kdmx(i))) + 1, kdmx(i) + ok = .true. + if (sigmar_1d(k) < sig_srcdi(2,ksmx(i))) then + dsig = (sigmar_1d(k) - sig_srcdi(2,ksmx(i)))*nudge_factor + 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)) + if (- dsig > .5_r8*dsigdx) then + dsigdx = sig_srcdi(2,ksmx(i)) - sig_srcdi(1,ksmx(i)) + if (- dsig > .5_r8*dsigdx) ok = .false. + endif + if (ok) p_dst(k,i) = p_src(kk+1,i) & + + dsig*(p_src(kk+1,i) - p_src(ksmx(i),i)) & + /dsigdx + else + p_dst(k,i) = p_src(kk+1,i) + endif + if (ok) then + p_dst(k,i) = & + min(max(p_dst(k,i), pmin(k), & + p_dst(klastok,i) + (k - klastok)*dpmin_interior), & + p_src(kk+1,i)) + if (k - klastok > 1) then + q = (p_dst(k,i) - p_dst(klastok,i))/(k - klastok) + do kt = klastok+1, k-1 + p_dst(kt,i) = min(max(p_dst(kt-1,i) + q, pmin(kt)), & + p_src(kk+1,i)) + enddo + endif + klastok = k + endif + enddo + + if (kdmx(i) - klastok > 0) then + q = (p_dst(kdmx(i)+1,i) - p_dst(klastok,i))/(kdmx(i) + 1 - klastok) + do kt = klastok+1, kdmx(i) + p_dst(kt,i) = min(max(p_dst(kt-1,i) + q, pmin(kt)), & + p_src(kk+1,i)) + enddo + endif + + enddo + enddo + + end subroutine cntiso_regrid_nudge_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)) +#ifdef TRC + do nt = 1, ntr + trc(i,j,kn,nt) = trc_rm(k,nt+2,i) + enddo +#endif + enddo + + enddo + enddo + + end subroutine copy_jslice_to_3d + subroutine readnml_vcoord ! --------------------------------------------------------------------------- ! Read variables in the namelist group 'vcoord' and resolve options. @@ -196,6 +849,8 @@ subroutine readnml_vcoord 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)') & @@ -220,8 +875,6 @@ subroutine readnml_vcoord tracer_limiting_tag = hor3map_monotonic case ('non_oscillatory') tracer_limiting_tag = hor3map_non_oscillatory - case ('non_oscillatory_posdef') - tracer_limiting_tag = hor3map_non_oscillatory_posdef case default if (mnproc == 1) & write (lp,'(3a)') & @@ -243,7 +896,7 @@ subroutine readnml_vcoord 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 @@ -252,382 +905,295 @@ end subroutine readnml_vcoord subroutine inivar_vcoord ! --------------------------------------------------------------------------- - ! Initialize arrays. + ! Initialize arrays and data structures. ! --------------------------------------------------------------------------- - integer :: i, j, k + integer :: i, j, k, nt, errstat !$omp parallel do private(i, k) - do j = 1 - nbdy, jj + nbdy + do j = 1-nbdy, jj+nbdy do k = 1, kk - do i = 1 - nbdy, ii + nbdy - sigmar(i, j, k) = spval + do i = 1-nbdy, ii+nbdy + sigmar(i,j,k) = spval enddo enddo enddo !$omp end parallel do - end subroutine inivar_vcoord - - subroutine cntiso_hybrid_regrid_remap(m, n, mm, nn, k1m, k1n) + ! Configuration of the reconstruction data structure that only depends on + ! the source grid. + rcgs%n_src = kk + if (ntrdif) then + rcgs%i_lbound = 0 + rcgs%i_ubound = ii + 1 + else + rcgs%i_ubound = ii + endif + rcgs%j_ubound = 2 + rcgs%method = reconstruction_method_tag - integer, intent(in) :: m, n, mm, nn, k1m, k1n + ! Configuration of reconstruction data structures that is specific to + ! various source data. - type(reconstruction_struct) :: rcs - type(remap_struct) :: rms + d_rcss%limiting = density_limiting_tag + d_rcss%pc_left_bndr = density_pc_upper_bndr + d_rcss%pc_right_bndr = density_pc_lower_bndr - real(r8), dimension(kdm + 1) :: p_1d, prgrd_1d, sigmar_1d - real(r8), dimension(kdm) :: temp_1d, saln_1d, sigma_1d - real(r8) :: beta, sdpsum, smean, dpmin_max, dpmin, pku, pku_test, & - pmin, dpt, pt, ptu1, ptl1, ptu2, ptl2, w1, x - integer :: i, j, k, l, kn, nt, ks, ke, kl, ku, errstat - logical :: thin_layers, layer_added + 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 #ifdef TRC - real(r8), dimension(kdm, ntr) :: trc_1d + 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 #endif - - ! Minimum potential density difference with respect to pressure for - ! potential density to be used in regridding. - beta = bfsq_min/(g*g) - - do j = 1, jj - do l = 1, isp(j) - do i = max(1, ifp(j, l)), min(ii, ilp(j, l)) - - ! Copy variables into 1D arrays. - p_1d(1) = p(i, j, 1) - do k = 1, kk - kn = k + nn - temp_1d(k) = temp(i, j, kn) - saln_1d(k) = saln(i, j, kn) - p_1d(k + 1) = p_1d(k) + dp(i, j, kn) - sigma_1d(k) = sigma(i, j, kn) - sigmar_1d(k) = sigmar(i, j, k) + else #ifdef TRC - do nt = 1, ntr - trc_1d(k, nt) = trc(i, j, kn, nt) - enddo + 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 - enddo - sigmar_1d(kk + 1) = sigmar_1d(kk) + endif - ! 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_1d(kl + 1) - p_1d(ku) < epsil - if (thin_layers .or. & - sigma_1d(kl) - sigma_1d(ku) & - < .5_r8*beta*(p_1d(kl + 1) - p_1d(ku))) then - sdpsum = sigma_1d(ku)*(p_1d(ku + 1) - p_1d(ku)) & - + sigma_1d(kl)*(p_1d(kl + 1) - p_1d(kl)) - if (.not. thin_layers) & - smean = sdpsum/(p_1d(kl + 1) - p_1d(ku)) - do - layer_added = .false. - if (ku > 1) then - if (thin_layers) then - ku = ku - 1 - sdpsum = sdpsum & - + sigma_1d(ku)*(p_1d(ku + 1) - p_1d(ku)) - thin_layers = p_1d(kl + 1) - p_1d(ku) < epsil - if (.not. thin_layers) & - smean = sdpsum/(p_1d(kl + 1) - p_1d(ku)) - layer_added = .true. - else - if (smean - sigma_1d(ku - 1) & - < .5_r8*beta*(p_1d(kl + 1) - p_1d(ku - 1))) then - ku = ku - 1 - sdpsum = sdpsum & - + sigma_1d(ku)*(p_1d(ku + 1) - p_1d(ku)) - smean = sdpsum/(p_1d(kl + 1) - p_1d(ku)) - layer_added = .true. - endif - endif - endif - if (kl < kk) then - if (thin_layers) then - kl = kl + 1 - sdpsum = sdpsum & - + sigma_1d(kl)*(p_1d(kl + 1) - p_1d(kl)) - thin_layers = p_1d(kl + 1) - p_1d(ku) < epsil - if (.not. thin_layers) & - smean = sdpsum/(p_1d(kl + 1) - p_1d(ku)) - layer_added = .true. - else - if (sigma_1d(kl + 1) - smean & - < .5_r8*beta*(p_1d(kl + 2) - p_1d(ku))) then - kl = kl + 1 - sdpsum = sdpsum & - + sigma_1d(kl)*(p_1d(kl + 1) - p_1d(kl)) - smean = sdpsum/(p_1d(kl + 1) - p_1d(ku)) - layer_added = .true. - endif - endif - endif - if (.not. layer_added) exit - enddo - do k = ku, kl - sigma_1d(k) = smean & - + .5_r8*beta*( p_1d(k ) + p_1d(k + 1) & - - p_1d(ku) - p_1d(kl + 1)) - enddo - endif - kl = ku - ku = kl - 1 - enddo + v_rcss%limiting = velocity_limiting_tag + v_rcss%pc_left_bndr = velocity_pc_upper_bndr + v_rcss%pc_right_bndr = velocity_pc_lower_bndr - ! Prepare reconstruction with current interface pressures. - errstat = prepare_reconstruction(p_1d, reconstruction_method_tag, & - rcs) - if (errstat /= hor3map_noerr) then - write(lp,*) trim(hor3map_errstr(errstat)) - call xchalt('(cntiso_hybrid_regrid_remap)') - stop '(cntiso_hybrid_regrid_remap)' - endif + ! Configuration of remapping data structure. + rms%n_dst = kk - ! Monotonically reconstruct potential density. - errstat = reconstruct(rcs, sigma_1d, density_limiting_tag, & - density_pc_upper_bndr, density_pc_lower_bndr) - if (errstat /= hor3map_noerr) then - write(lp,*) trim(hor3map_errstr(errstat)) - call xchalt('(cntiso_hybrid_regrid_remap)') - stop '(cntiso_hybrid_regrid_remap)' - endif + ! Initialize reconstruction and remapping data structures. - ! On the basis of the reconstructed potential density, regrid - ! interface pressures so interface potential densities match target - ! values. - errstat = regrid(rcs, sigmar_1d, prgrd_1d, regrid_mval) - if (errstat /= hor3map_noerr) then - write(lp,*) trim(hor3map_errstr(errstat)) - call xchalt('(cntiso_hybrid_regrid_remap)') - stop '(cntiso_hybrid_regrid_remap)' - endif + errstat = initialize_rcgs(rcgs) + if (errstat /= hor3map_noerr) then + write(lp,*) trim(hor3map_errstr(errstat)) + call xchalt('(inivar_vcoord)') + stop '(inivar_vcoord)' + endif - ! Modify regridded interface pressures to ensure the water column is - ! properly bounded. - k = 1 - do - ks = k - if (prgrd_1d(k) /= regrid_mval) exit - prgrd_1d(k) = p_1d(1) - if (k > kk) exit - k = k + 1 - enddo - k = kk + 1 - do - ke = k - if (prgrd_1d(k) /= regrid_mval) exit - prgrd_1d(k) = p_1d(kk + 1) - if (k == 1) exit - k = k - 1 - enddo - prgrd_1d(1) = p_1d(1) - prgrd_1d(kk + 1) = p_1d(kk + 1) - - ! 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_1d(k + 1) - p_1d(k)) - enddo - smean = sdpsum/(p_1d(kk + 1) - p_1d(1)) - ks = 2 - do while (ks <= kk) - if (smean < sigmar_1d(ks)) exit - ks = ks + 1 - enddo - do k = ks, kk - prgrd_1d(k) = p_1d(kk + 1) - enddo - ke = ks - 1 - 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 - ! Modify interface pressures so that layer thicknesses are - ! above a specified threshold. - dpmin_max = (p_1d(kk + 1) - p_1d(1))/kk - dpmin_max = dpmin_surface - dpmin = min(dpmin_max, dpmin_surface, dpmin_interior) - ks = max(2, ks) - ke = min(kk, ke) - k = ks - do while (k <= ke) - if (prgrd_1d(k + 1) - prgrd_1d(k) < dpmin) then - if (k == ke) then - prgrd_1d(k) = prgrd_1d(ke + 1) - else - ku = k - kl = k + 1 - pku = .5_r8*(prgrd_1d(kl) + prgrd_1d(ku) - dpmin) - do - layer_added = .false. - kl = kl + 1 - pku_test = ((pku - dpmin)*(kl - ku) + prgrd_1d(kl)) & - /(kl - ku + 1) - if (pku_test + (kl - ku)*dpmin > prgrd_1d(kl)) then - if (kl == ke + 1) exit - pku = pku_test - layer_added = .true. - else - kl = kl - 1 - endif - ku = ku - 1 - pku_test = ((pku - dpmin)*(kl - ku) + prgrd_1d(ku)) & - /(kl - ku + 1) - if (pku_test < prgrd_1d(ku)) 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 - prgrd_1d(k) = min(prgrd_1d(ke + 1), & - prgrd_1d(k - 1) + dpmin) - enddo - do k = kl + 1, ke - prgrd_1d(k) = & - min(prgrd_1d(ke + 1), & - max(prgrd_1d(k), prgrd_1d(1) + dpmin*(k - 1))) - enddo - elseif (kl == ke + 1) then - do k = ku, kl - prgrd_1d(k) = prgrd_1d(ke + 1) - enddo - else - prgrd_1d(ku) = pku - do k = ku + 1, kl - prgrd_1d(k) = prgrd_1d(k - 1) + dpmin - enddo - endif - k = kl - endif - endif - k = k + 1 - enddo + 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 - ! 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 = min(dpmin_max, dpmin_surface) - pmin = p_1d(1) + dpmin - dpt = dpmin - do k = 2, ke - dpmin = dpmin*dpmin_inflation_factor - dpt = max(prgrd_1d(k + 1) - prgrd_1d(k), dpt, dpmin) - pt = max(prgrd_1d(k), pmin) - ptu1 = pmin - dpt - ptl1 = pmin + dpt - ptu2 = pmin - ptl2 = pmin + 2._r8*dpt - w1 = min(1._r8,(prgrd_1d(k) - p_1d(1))/(pmin - p_1d(1))) - if (prgrd_1d(k) > ptu1 .and. prgrd_1d(k) < ptl1) then - x = .5_r8*(prgrd_1d(k) - ptu1)/dpt - pt = pmin + dpt*x*x - endif - if (prgrd_1d(k + 1) > ptu2 .and. prgrd_1d(k + 1) < ptl2) then - x = .5_r8*(prgrd_1d(k + 1) - ptu2)/dpt - pt = w1*pt + (1._r8 - w1)*(pmin + dpt*x*x) - endif - prgrd_1d(k) = min(p_1d(ke + 1), pt) - pmin = pmin + dpmin - enddo - - ! Prepare remapping to layer structure with regridded interface - ! pressures. - errstat = prepare_remapping(rcs, prgrd_1d, rms) - if (errstat /= hor3map_noerr) then - write(lp,*) trim(hor3map_errstr(errstat)) - call xchalt('(cntiso_hybrid_regrid_remap)') - stop '(cntiso_hybrid_regrid_remap)' - endif + 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 - ! Reconstruct and remap potential temperature. - errstat = reconstruct(rcs, temp_1d, tracer_limiting_tag, & - tracer_pc_upper_bndr, tracer_pc_lower_bndr) - if (errstat /= hor3map_noerr) then - write(lp,*) trim(hor3map_errstr(errstat)) - call xchalt('(cntiso_hybrid_regrid_remap)') - stop '(cntiso_hybrid_regrid_remap)' - endif - errstat = remap(rcs, rms, temp_1d) - if (errstat /= hor3map_noerr) then - write(lp,*) trim(hor3map_errstr(errstat)) - call xchalt('(cntiso_hybrid_regrid_remap)') - stop '(cntiso_hybrid_regrid_remap)' - 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 - ! Reconstruct and remap salinity. - errstat = reconstruct(rcs, saln_1d, tracer_limiting_tag, & - tracer_pc_upper_bndr, tracer_pc_lower_bndr) - if (errstat /= hor3map_noerr) then - write(lp,*) trim(hor3map_errstr(errstat)) - call xchalt('(cntiso_hybrid_regrid_remap)') - stop '(cntiso_hybrid_regrid_remap)' - endif - errstat = remap(rcs, rms, saln_1d) - if (errstat /= hor3map_noerr) then - write(lp,*) trim(hor3map_errstr(errstat)) - call xchalt('(cntiso_hybrid_regrid_remap)') - stop '(cntiso_hybrid_regrid_remap)' - 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 + + real(r8), dimension(kdm+1,1-nbdy:idm+nbdy,2) :: p_src_rs, p_dst_rs + real(r8), dimension(kdm,ntr_loc,1-nbdy:idm+nbdy) :: trc_rm + integer :: j_rs, jm_rs, jp_rs, j, nt + + if (.not.ntrdif) then + + j_rs = 1 + + do j = 1, jj + call prep_recon_jslice(p_src_rs(:,:,j_rs), 1, ii, j, j_rs, nn) + call recon_trc_jslice(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) #ifdef TRC - ! Reconstruct and remap tracers. - do nt = 1, ntr - errstat = reconstruct(rcs, trc_1d(:, nt), tracer_limiting_tag, & - tracer_pc_upper_bndr, tracer_pc_lower_bndr) - if (errstat /= hor3map_noerr) then - write(lp,*) trim(hor3map_errstr(errstat)) - call xchalt('(cntiso_hybrid_regrid_remap)') - stop '(cntiso_hybrid_regrid_remap)' - endif - errstat = remap(rcs, rms, trc_1d(:, nt)) - if (errstat /= hor3map_noerr) then - write(lp,*) trim(hor3map_errstr(errstat)) - call xchalt('(cntiso_hybrid_regrid_remap)') - stop '(cntiso_hybrid_regrid_remap)' - endif - enddo + 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 #endif + 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), & + 0, ii+1, j+1, jp_rs, nn) + call recon_trc_jslice(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, p_dst_rs, trc_rcss, & + 0, ii+1, j+1, jp_rs, mm) + enddo - ! Update 3D arrays - do k = 1, kk - kn = k + nn - temp(i, j, kn) = temp_1d(k) - saln(i, j, kn) = saln_1d(k) - dp(i, j, kn) = prgrd_1d(k + 1) - prgrd_1d(k) - sigma(i, j, kn) = sig(temp_1d(k), saln_1d(k)) + j = 0 + call ndiff_vflx_jslice(p_dst_rs, 1, ii, j+1, 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), & + 0, ii+1, j+1, jp_rs, nn) + call recon_trc_jslice(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, p_dst_rs, trc_rcss, & + 0, ii+1, j+1, jp_rs, mm) + call ndiff_uflx_jslice(p_dst_rs, 1, ii+1, j, jm_rs, mm, nn) + call ndiff_vflx_jslice(p_dst_rs, 1, ii, j+1, 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, trc_rm, 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') #ifdef TRC - do nt = 1,ntr - trc(i, j, kn, nt) = trc_1d(k, nt) - enddo + do nt = 1, ntr + call chksummsk(trc(1-nbdy,1-nbdy,k1n,nt), ip, kk, 'trc') + enddo #endif - enddo + 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 + + real(r8), dimension(kdm+1,1-nbdy:idm+nbdy,2) :: p_src_rs, p_dst_rs + real(r8), dimension(kdm,ntr_loc,1-nbdy:idm+nbdy) :: trc_rm + integer :: j_rs, jm_rs, jp_rs, j, nt + + if (.not.ntrdif) then + + j_rs = 1 + + do j = 1, jj + call prep_recon_jslice(p_src_rs(:,:,j_rs), 1, ii, j, j_rs, nn) + call recon_trc_jslice(1, ii, j, j_rs, nn) + call cntiso_regrid_nudge_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) +#ifdef TRC + 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 +#endif + 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), & + 0, ii+1, j+1, jp_rs, nn) + call recon_trc_jslice(0, ii+1, j+1, jp_rs, nn) + call cntiso_regrid_nudge_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, p_dst_rs, trc_rcss, & + 0, ii+1, j+1, jp_rs, mm) enddo - enddo + + j = 0 + call ndiff_vflx_jslice(p_dst_rs, 1, ii, j+1, 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), & + 0, ii+1, j+1, jp_rs, nn) + call recon_trc_jslice(0, ii+1, j+1, jp_rs, nn) + call cntiso_regrid_nudge_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, p_dst_rs, trc_rcss, & + 0, ii+1, j+1, jp_rs, mm) + call ndiff_uflx_jslice(p_dst_rs, 1, ii+1, j, jm_rs, mm, nn) + call ndiff_vflx_jslice(p_dst_rs, 1, ii, j+1, 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, trc_rm, 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') - call chksummsk(sigmar, ip, kk, 'sigmar') + 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') #ifdef TRC do nt = 1, ntr - call chksummsk(trc(1-nbdy, 1-nbdy, k1n, nt), ip, kk, 'trc') + call chksummsk(trc(1-nbdy,1-nbdy,k1n,nt), ip, kk, 'trc') enddo #endif endif @@ -638,26 +1204,38 @@ subroutine remap_velocity(m, n, mm, nn, k1m, k1n) integer, intent(in) :: m, n, mm, nn, k1m, k1n - type(reconstruction_struct) :: rcs - type(remap_struct) :: rms - - real(r8), dimension(kdm + 1) :: p_1d, prgrd_1d + 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 -#ifdef TRC - real(r8), dimension(kdm, ntr) :: trc_1d -#endif - call xctilr(dp(1 - nbdy, 1 - nbdy, k1n), 1, kk, 3, 3, halo_ps) + !$omp parallel do private(k, km, 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 + 2 + do j = -2, jj+2 do k = 1, kk kn = k + nn do l = 1, isp(j) - do i = max(- 2, ifp(j, l)), min(ii + 2, ilp(j, l)) - p(i, j, k + 1) = p(i, j, k) + dp(i, j, kn) + do i = max(-2, ifp(j,l)), min(ii+2, ilp(j,l)) + p(i,j,k+1) = p(i,j,k) + dp(i,j,kn) enddo enddo enddo @@ -665,23 +1243,23 @@ subroutine remap_velocity(m, n, mm, nn, k1m, k1n) !$omp end parallel do !$omp parallel do private(k,kn,l,i,q) - do j = - 1, jj + 2 + 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)))) + 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)))) + 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 @@ -691,21 +1269,23 @@ subroutine remap_velocity(m, n, mm, nn, k1m, k1n) 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. - prgrd_1d(1) = pu(i, j, 1) + 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_1d(k) = pu(i, j, k) - prgrd_1d(k + 1) = prgrd_1d(k) + dpu(i, j, kn) + 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 - p_1d(kk + 1) = pu(i, j, kk + 1) ! Prepare reconstruction with current interface pressures. - errstat = prepare_reconstruction(p_1d, reconstruction_method_tag, & - rcs) + errstat = prepare_reconstruction(rcgs, p_1d, i, 1) if (errstat /= hor3map_noerr) then write(lp,*) trim(hor3map_errstr(errstat)) call xchalt('(remap_velocity)') @@ -714,7 +1294,7 @@ subroutine remap_velocity(m, n, mm, nn, k1m, k1n) ! Prepare remapping to layer structure with regridded interface ! pressures. - errstat = prepare_remapping(rcs, prgrd_1d, rms) + 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)') @@ -722,15 +1302,13 @@ subroutine remap_velocity(m, n, mm, nn, k1m, k1n) endif ! Reconstruct and remap u-component of velocity. - errstat = reconstruct(rcs, u_1d, velocity_limiting_tag, & - velocity_pc_upper_bndr, & - velocity_pc_lower_bndr) + 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(rcs, rms, u_1d) + errstat = remap(v_rcss, rms, u_1d, i, 1) if (errstat /= hor3map_noerr) then write(lp,*) trim(hor3map_errstr(errstat)) call xchalt('(remap_velocity)') @@ -740,28 +1318,30 @@ subroutine remap_velocity(m, n, mm, nn, k1m, k1n) ! Update 3D arrays do k = 1, kk kn = k + nn - u(i, j, kn) = u_1d(k) + 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. - prgrd_1d(1) = pv(i, j, 1) + 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_1d(k) = pv(i, j, k) - prgrd_1d(k + 1) = prgrd_1d(k) + dpv(i, j, kn) + 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 - p_1d(kk + 1) = pv(i, j, kk + 1) ! Prepare reconstruction with current interface pressures. - errstat = prepare_reconstruction(p_1d, reconstruction_method_tag, & - rcs) + errstat = prepare_reconstruction(rcgs, p_1d, i, 1) if (errstat /= hor3map_noerr) then write(lp,*) trim(hor3map_errstr(errstat)) call xchalt('(remap_velocity)') @@ -770,7 +1350,7 @@ subroutine remap_velocity(m, n, mm, nn, k1m, k1n) ! Prepare remapping to layer structure with regridded interface ! pressures. - errstat = prepare_remapping(rcs, prgrd_1d, rms) + 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)') @@ -778,15 +1358,13 @@ subroutine remap_velocity(m, n, mm, nn, k1m, k1n) endif ! Reconstruct and remap v-component of velocity. - errstat = reconstruct(rcs, v_1d, velocity_limiting_tag, & - velocity_pc_upper_bndr, & - velocity_pc_lower_bndr) + 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(rcs, rms, v_1d) + errstat = remap(v_rcss, rms, v_1d, i, 1) if (errstat /= hor3map_noerr) then write(lp,*) trim(hor3map_errstr(errstat)) call xchalt('(remap_velocity)') @@ -796,7 +1374,7 @@ subroutine remap_velocity(m, n, mm, nn, k1m, k1n) ! Update 3D arrays do k = 1, kk kn = k + nn - v(i, j, kn) = v_1d(k) + v(i,j,kn) = v_1d(k) enddo enddo @@ -808,10 +1386,10 @@ subroutine remap_velocity(m, n, mm, nn, k1m, k1n) if (mnproc == 1) then write (lp,*) 'remap_velocity:' endif - call chksummsk(dpu(1 - nbdy, 1 - nbdy, k1n), iu, kk, 'dpv') - 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') + 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 remap_velocity diff --git a/phy/mod_vdiff.F90 b/phy/mod_vdiff.F90 index 61cd6117..3d1798fd 100644 --- a/phy/mod_vdiff.F90 +++ b/phy/mod_vdiff.F90 @@ -1,5 +1,5 @@ ! ------------------------------------------------------------------------------ -! Copyright (C) 2021 Mats Bentsen +! Copyright (C) 2021-2022 Mats Bentsen ! ! This file is part of BLOM. ! @@ -23,15 +23,16 @@ module mod_vdiff ! ------------------------------------------------------------------------------ use mod_types, only: r8 - use mod_constants, only: g, alpha0 + use mod_constants, only: g, spcifh, alpha0 use mod_time, only: delt1 use mod_xc use mod_eos, only: sig use mod_state, only: u, v, dp, dpu, dpv, temp, saln, sigma use mod_checksum, only: csdiag, chksummsk - use mod_diffusion, only: Kvisc_m, Kdiff_t, Kdiff_s + use mod_diffusion, only: Kvisc_m, Kdiff_t, Kdiff_s, t_ns_nonloc, s_nonloc + use mod_forcing, only: surflx, sswflx, surrlx, salflx, salrlx, t_sw_nonloc #ifdef TRC - use mod_tracers, only: ntr, trc + use mod_tracers, only: ntr, trc, trflx #endif implicit none @@ -41,23 +42,25 @@ module mod_vdiff real(r8), parameter :: & dpmin_vdiff = 0.1_r8*98060._r8 - public :: cntiso_hybrid_vdiff + public :: cntiso_hybrid_vdifft, cntiso_hybrid_vdiffm contains - subroutine cntiso_hybrid_vdiff(m, n, mm, nn, k1m, k1n) + subroutine cntiso_hybrid_vdifft(m, n, mm, nn, k1m, k1n) integer, intent(in) :: m, n, mm, nn, k1m, k1n - real(r8), dimension(kdm) :: dp_1d, temp_1d, saln_1d, u_1d, v_1d, & - nut_1d, nus_1d, nutrc_1d, nuv_1d + real(r8), dimension(kdm) :: dp_1d, temp_1d, saln_1d, & + nut_1d, nus_1d, nutrc_1d real(r8), dimension(2:kdm) :: fpbase, fp, gam - real(r8) :: c, bei + real(r8) :: cpi, dtg, c, bei, rhs integer :: i, j, k, l, kn, nt #ifdef TRC real(r8), dimension(kdm, ntr) :: trc_1d #endif + cpi = 1._r8/spcifh ! Multiplicative inverse of specific heat capacity. + dtg = delt1*g c = g*g*delt1/(alpha0*alpha0) do j = 1, jj @@ -84,10 +87,11 @@ subroutine cntiso_hybrid_vdiff(m, n, mm, nn, k1m, k1n) ! forming a tridiagonal set of equations: ! ! - fp(k)*U(k-1) + (dp(k) + fp(k) + fp(k+1))*U(k) - fp(k+1)*U(k+1) - ! = dp(k)*u(k) + ! = dp(k)*(u(k) + Q_nonloc(k)) ! ! Here u and U is the variable to be diffused at old and new - ! time-level, respectively. + ! time-level, respectively, and Q_nonloc is the divergence of + ! non-local transport of surface flux. ! Diffusive interface fluxes, before multiplying with diffusivity. do k = 2, kk @@ -99,15 +103,29 @@ subroutine cntiso_hybrid_vdiff(m, n, mm, nn, k1m, k1n) fp(k) = nut_1d(k)*fpbase(k) enddo bei = 1._r8/(dp_1d(1) + fp(2)) - temp_1d(1) = dp_1d(1)*temp_1d(1)*bei + rhs = dp_1d(1)*temp_1d(1) & + - ( (1._r8 - t_ns_nonloc(i,j,2))*(surflx(i,j) - sswflx(i,j)) & + + (1._r8 - t_sw_nonloc(i,j,2))*sswflx(i,j) & + + surrlx(i,j))*dtg*cpi + temp_1d(1) = rhs*bei do k = 2, kk - 1 gam(k) = - fp(k)*bei bei = 1._r8/(dp_1d(k) + fp(k)*(1._r8 + gam(k)) + fp(k + 1)) - temp_1d(k) = (dp_1d(k)*temp_1d(k) + fp(k)*temp_1d(k - 1))*bei + rhs = dp_1d(k)*temp_1d(k) & + - ( (t_ns_nonloc(i,j,k) - t_ns_nonloc(i,j,k+1)) & + *(surflx(i,j) - sswflx(i,j)) & + + (t_sw_nonloc(i,j,k) - t_sw_nonloc(i,j,k+1)) & + *sswflx(i,j))*dtg*cpi + temp_1d(k) = (rhs + fp(k)*temp_1d(k - 1))*bei enddo gam(kk) = - fp(kk)*bei bei = 1._r8/(dp_1d(kk) + fp(kk)*(1._r8 + gam(kk))) - temp_1d(kk) = (dp_1d(kk)*temp_1d(kk) + fp(kk)*temp_1d(kk - 1))*bei + rhs = dp_1d(kk)*temp_1d(kk) & + - ( (t_ns_nonloc(i,j,kk) - t_ns_nonloc(i,j,kk+1)) & + *(surflx(i,j) - sswflx(i,j)) & + + (t_sw_nonloc(i,j,kk) - t_sw_nonloc(i,j,kk+1)) & + *sswflx(i,j))*dtg*cpi + temp_1d(kk) = (rhs + fp(kk)*temp_1d(kk - 1))*bei do k = kk - 1, 1, - 1 temp_1d(k) = temp_1d(k) - gam(k + 1)*temp_1d(k + 1) enddo @@ -117,15 +135,22 @@ subroutine cntiso_hybrid_vdiff(m, n, mm, nn, k1m, k1n) fp(k) = nus_1d(k)*fpbase(k) enddo bei = 1._r8/(dp_1d(1) + fp(2)) - saln_1d(1) = dp_1d(1)*saln_1d(1)*bei + rhs = dp_1d(1)*saln_1d(1) & + - ((1._r8 - s_nonloc(i,j,2))*salflx(i,j) & + + salrlx(i,j))*dtg + saln_1d(1) = rhs*bei do k = 2, kk - 1 gam(k) = - fp(k)*bei bei = 1._r8/(dp_1d(k) + fp(k)*(1._r8 + gam(k)) + fp(k + 1)) - saln_1d(k) = (dp_1d(k)*saln_1d(k) + fp(k)*saln_1d(k - 1))*bei + rhs = dp_1d(k)*saln_1d(k) & + - (s_nonloc(i,j,k) - s_nonloc(i,j,k+1))*salflx(i,j)*dtg + saln_1d(k) = (rhs + fp(k)*saln_1d(k - 1))*bei enddo gam(kk) = - fp(kk)*bei bei = 1._r8/(dp_1d(kk) + fp(kk)*(1._r8 + gam(kk))) - saln_1d(kk) = (dp_1d(kk)*saln_1d(kk) + fp(kk)*saln_1d(kk - 1))*bei + rhs = dp_1d(kk)*saln_1d(kk) & + - (s_nonloc(i,j,kk) - s_nonloc(i,j,kk+1))*salflx(i,j)*dtg + saln_1d(kk) = (rhs + fp(kk)*saln_1d(kk - 1))*bei do k = kk - 1, 1, - 1 saln_1d(k) = saln_1d(k) - gam(k + 1)*saln_1d(k + 1) enddo @@ -137,21 +162,25 @@ subroutine cntiso_hybrid_vdiff(m, n, mm, nn, k1m, k1n) enddo bei = 1._r8/(dp_1d(1) + fp(2)) do nt = 1, ntr - trc_1d(1, nt) = dp_1d(1)*trc_1d(1, nt)*bei + rhs = dp_1d(1)*trc_1d(1,nt) & + - (1._r8 - s_nonloc(i,j,2))*trflx(nt,i,j)*dtg + trc_1d(1, nt) = rhs*bei enddo do k = 2, kk - 1 gam(k) = - fp(k)*bei bei = 1._r8/(dp_1d(k) + fp(k)*(1._r8 + gam(k)) + fp(k + 1)) do nt = 1, ntr - trc_1d(k, nt) = ( dp_1d(k)*trc_1d(k, nt) & - + fp(k)*trc_1d(k - 1, nt))*bei + rhs = dp_1d(k)*trc_1d(k,nt) & + - (s_nonloc(i,j,k) - s_nonloc(i,j,k+1))*trflx(nt,i,j)*dtg + trc_1d(k, nt) = (rhs + fp(k)*trc_1d(k - 1, nt))*bei enddo enddo gam(kk) = - fp(kk)*bei bei = 1._r8/(dp_1d(kk) + fp(kk)*(1._r8 + gam(kk))) do nt = 1, ntr - trc_1d(kk, nt) = ( dp_1d(kk)*trc_1d(kk, nt) & - + fp(kk)*trc_1d(kk - 1, nt))*bei + rhs = dp_1d(kk)*trc_1d(kk,nt) & + - (s_nonloc(i,j,kk) - s_nonloc(i,j,kk+1))*trflx(nt,i,j)*dtg + trc_1d(kk, nt) = (rhs + fp(kk)*trc_1d(kk - 1, nt))*bei enddo do k = kk - 1, 1, - 1 do nt = 1, ntr @@ -177,6 +206,35 @@ subroutine cntiso_hybrid_vdiff(m, n, mm, nn, k1m, k1n) enddo enddo + if (csdiag) then + if (mnproc == 1) then + write (lp,*) 'cntiso_hybrid_vdifft:' + endif + call chksummsk(temp, ip, 2*kk, 'temp') + call chksummsk(saln, ip, 2*kk, 'saln') + call chksummsk(sigma, ip, 2*kk, 'sigma') +#ifdef TRC + do nt = 1, ntr + call chksummsk(trc(1-nbdy, 1-nbdy, 1, nt), ip, 2*kk, 'trc') + enddo +#endif + endif + + end subroutine cntiso_hybrid_vdifft + + subroutine cntiso_hybrid_vdiffm(m, n, mm, nn, k1m, k1n) + + integer, intent(in) :: m, n, mm, nn, k1m, k1n + + real(r8), dimension(kdm) :: dp_1d, u_1d, v_1d, nuv_1d + real(r8), dimension(2:kdm) :: fpbase, fp, gam + real(r8) :: c, bei + integer :: i, j, k, l, kn + + c = g*g*delt1/(alpha0*alpha0) + + call xctilr(Kvisc_m, 1, kk, 1, 1, halo_ps) + do j = 1, jj do l = 1, isu(j) @@ -187,7 +245,7 @@ subroutine cntiso_hybrid_vdiff(m, n, mm, nn, k1m, k1n) kn = k + nn dp_1d(k) = dpu(i, j, kn) u_1d(k) = u(i, j, kn) - nuv_1d(k) = Kvisc_m(i, j, k) + nuv_1d(k) = .5_r8*(Kvisc_m(i-1, j, k) + Kvisc_m(i, j, k)) enddo ! Vertical diffusion equations are solved by backward integration @@ -239,7 +297,7 @@ subroutine cntiso_hybrid_vdiff(m, n, mm, nn, k1m, k1n) kn = k + nn dp_1d(k) = dpv(i, j, kn) v_1d(k) = v(i, j, kn) - nuv_1d(k) = Kvisc_m(i, j, k) + nuv_1d(k) = .5_r8*(Kvisc_m(i, j-1, k) + Kvisc_m(i, j, k)) enddo ! Vertical diffusion equations are solved by backward integration @@ -287,20 +345,12 @@ subroutine cntiso_hybrid_vdiff(m, n, mm, nn, k1m, k1n) if (csdiag) then if (mnproc == 1) then - write (lp,*) 'cntiso_hybrid_vdiff:' + write (lp,*) 'cntiso_hybrid_vdiffm:' endif - call chksummsk(temp, ip, 2*kk, 'temp') - call chksummsk(saln, ip, 2*kk, 'saln') - call chksummsk(sigma, ip, 2*kk, 'sigma') -#ifdef TRC - do nt = 1, ntr - call chksummsk(trc(1-nbdy, 1-nbdy, 1, nt), ip, 2*kk, 'trc') - enddo -#endif call chksummsk(u, iu, 2*kk, 'u') call chksummsk(v, iv, 2*kk, 'v') endif - end subroutine cntiso_hybrid_vdiff + end subroutine cntiso_hybrid_vdiffm end module mod_vdiff diff --git a/phy/restart_rd.F b/phy/restart_rd.F index 7868ef61..d32306af 100644 --- a/phy/restart_rd.F +++ b/phy/restart_rd.F @@ -1,5 +1,5 @@ ! ------------------------------------------------------------------------------ -! Copyright (C) 2006-2021 Mats Bentsen, Mehmet Ilicak, Alok Kumar Gupta, +! Copyright (C) 2006-2022 Mats Bentsen, Mehmet Ilicak, Alok Kumar Gupta, ! Jerry Tjiputra, Ping-Gin Chiu, Aleksi Nummelin ! ! This file is part of BLOM. @@ -28,9 +28,10 @@ subroutine restart_rd use mod_calendar, only: date_type, daynum_diff, operator(/=) use mod_time, only: date0, date, nday1, nstep0, nstep1 use mod_xc - use mod_vcoord, only: vcoord_type_tag, cntiso_hybrid + use mod_vcoord, only: vcoord_type_tag, isopyc_bulkml, + . cntiso_hybrid use mod_inicon, only: icfile - use mod_state, only: u, v, dp, temp, saln, sigma, + use mod_state, only: u, v, dp, dpu, dpv, temp, saln, sigma, . uflx, vflx, utflx, vtflx, usflx, vsflx, . phi, ubflxs, vbflxs, . ub, vb, pb, pbu, pbv, ubflxs_p, vbflxs_p, @@ -46,7 +47,8 @@ subroutine restart_rd . prfac, eiacc, pracc, . flxco2, flxdms, ustarb, buoyfl use mod_niw, only: uml, vml, umlres, vmlres - use mod_diffusion, only: Kvisc_m, Kdiff_t, Kdiff_s + use mod_difest, only: OBLdepth + use mod_diffusion, only: difiso, Kvisc_m, Kdiff_t, Kdiff_s 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, ustarw_da, @@ -398,7 +400,6 @@ subroutine restart_rd call ncread('phi',phi(1-nbdy,1-nbdy,kk+1),ip,1,0.) call ncread('sealv',sealv,ip,1,0.) call ncread('ustar',ustar,ip,1,0.) - call ncread('buoyfl',buoyfl,ip,1,0.) call ncread('kfpla',rkfpla,ip,1,0.) call ncread('ficem',ficem,ip,1,0.) c @@ -445,11 +446,16 @@ subroutine restart_rd write (lp,*) . 'will be initialized to zero.' endif +c + if (vcoord_type_tag.eq.isopyc_bulkml) then + call ncread('buoyfl',buoyfl,ip,1,0.) + endif c if (vcoord_type_tag.eq.cntiso_hybrid) then - call ncread('Kvisc_m',Kvisc_m,ip,1,0.) - call ncread('Kdiff_t',Kdiff_t,ip,1,0.) - call ncread('Kdiff_s',Kdiff_s,ip,1,0.) + call ncread('dpu',dpu,iu,1,0.) + call ncread('dpv',dpv,iv,1,0.) + call ncread('difiso',difiso,ip,1,0.) + call ncread('OBLdepth',OBLdepth,ip,1,0.) endif c if (sprfac) then diff --git a/phy/restart_wt.F b/phy/restart_wt.F index 0bb97401..1f5beebf 100644 --- a/phy/restart_wt.F +++ b/phy/restart_wt.F @@ -1,5 +1,5 @@ ! ------------------------------------------------------------------------------ -! Copyright (C) 2006-2021 Mats Bentsen, Mehmet Ilicak, Alok Kumar Gupta, +! Copyright (C) 2006-2022 Mats Bentsen, Mehmet Ilicak, Alok Kumar Gupta, ! Ingo Bethke, Jerry Tjiputra, Ping-Gin Chiu, ! Aleksi Nummelin ! @@ -28,8 +28,9 @@ subroutine restart_wt use mod_config, only: expcnf, runid, inst_suffix use mod_time, only: date0, date, nstep, nstep_in_day, nday_of_year use mod_xc - use mod_vcoord, only: vcoord_type_tag, cntiso_hybrid - use mod_state, only: u, v, dp, temp, saln, sigma, + use mod_vcoord, only: vcoord_type_tag, isopyc_bulkml, + . cntiso_hybrid + use mod_state, only: u, v, dp, dpu, dpv, temp, saln, sigma, . uflx, vflx, utflx, vtflx, usflx, vsflx, . phi, ubflxs, vbflxs, . ub, vb, pb, pbu, pbv, ubflxs_p, vbflxs_p, @@ -45,7 +46,8 @@ subroutine restart_wt . prfac, eiacc, pracc, . flxco2, flxdms, ustarb, buoyfl use mod_niw, only: uml, vml, umlres, vmlres - use mod_diffusion, only: Kvisc_m, Kdiff_t, Kdiff_s + use mod_difest, only: OBLdepth + use mod_diffusion, only: difiso, Kvisc_m, Kdiff_t, Kdiff_s 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, ustarw_da, @@ -281,18 +283,22 @@ subroutine restart_wt call wrtrst('phi',trim(c5p)//' time',phi(1-nbdy,1-nbdy,kk+1),ip) call wrtrst('sealv',trim(c5p)//' time',sealv,ip) call wrtrst('ustar',trim(c5p)//' time',ustar,ip) - call wrtrst('buoyfl',trim(c5p)//' time',buoyfl,ip) call wrtrst('kfpla',trim(c5p)//' k2 time',rkfpla,ip) call wrtrst('ficem',trim(c5p)//' time',ficem,ip) call wrtrst('uml',trim(c5u)//' k4 time',uml,iuu) call wrtrst('vml',trim(c5v)//' k4 time',vml,ivv) call wrtrst('umlres',trim(c5u)//' k2 time',umlres,iuu) call wrtrst('vmlres',trim(c5v)//' k2 time',vmlres,ivv) +c + if (vcoord_type_tag.eq.isopyc_bulkml) then + call wrtrst('buoyfl',trim(c5p)//' time',buoyfl,ip) + endif c if (vcoord_type_tag.eq.cntiso_hybrid) then - call wrtrst('Kvisc_m',trim(c5p)//' kkp1 time',Kvisc_m,ip) - call wrtrst('Kdiff_t',trim(c5p)//' kkp1 time',Kdiff_t,ip) - call wrtrst('Kdiff_s',trim(c5p)//' kkp1 time',Kdiff_s,ip) + call wrtrst('dpu',trim(c5p)//' kk2 time',dpu,iu) + call wrtrst('dpv',trim(c5p)//' kk2 time',dpv,iv) + call wrtrst('difiso',trim(c5p)//' kk time',difiso,ip) + call wrtrst('OBLdepth',trim(c5p)//' time',OBLdepth,ip) endif c if (sprfac) then @@ -877,18 +883,22 @@ subroutine defvar_restart(c5p,c5u,c5v,c5q) call defvarrst('phi',trim(c5p)//' time') call defvarrst('sealv',trim(c5p)//' time') call defvarrst('ustar',trim(c5p)//' time') - call defvarrst('buoyfl',trim(c5p)//' time') call defvarrst('kfpla',trim(c5p)//' k2 time') call defvarrst('ficem',trim(c5p)//' time') call defvarrst('uml',trim(c5u)//' k4 time') call defvarrst('vml',trim(c5v)//' k4 time') call defvarrst('umlres',trim(c5u)//' k2 time') call defvarrst('vmlres',trim(c5v)//' k2 time') +c + if (vcoord_type_tag.eq.isopyc_bulkml) then + call defvarrst('buoyfl',trim(c5p)//' time') + endif c if (vcoord_type_tag.eq.cntiso_hybrid) then - call defvarrst('Kvisc_m',trim(c5p)//' kkp1 time') - call defvarrst('Kdiff_t',trim(c5p)//' kkp1 time') - call defvarrst('Kdiff_s',trim(c5p)//' kkp1 time') + call defvarrst('dpu',trim(c5p)//' kk2 time') + call defvarrst('dpv',trim(c5p)//' kk2 time') + call defvarrst('difiso',trim(c5p)//' kk time') + call defvarrst('OBLdepth',trim(c5p)//' time') endif c if (sprfac) then From 3862ef5e959a9c6dba274a406b2b52f315a10fc2 Mon Sep 17 00:00:00 2001 From: Mats Bentsen Date: Wed, 25 May 2022 16:21:31 +0200 Subject: [PATCH 096/366] For hybrid vertical coordinate, distribute the eddy-induced transport to achieve a constant eddy-induced velocity in the mixed layer. --- phy/mod_eddtra.F90 | 100 ++++++++++++++++++++++++++++++--------------- 1 file changed, 67 insertions(+), 33 deletions(-) diff --git a/phy/mod_eddtra.F90 b/phy/mod_eddtra.F90 index 0b12283c..8d2ee510 100644 --- a/phy/mod_eddtra.F90 +++ b/phy/mod_eddtra.F90 @@ -1,5 +1,5 @@ ! ------------------------------------------------------------------------------ -! Copyright (C) 2015-2021 Mats Bentsen +! Copyright (C) 2015-2022 Mats Bentsen ! ! This file is part of BLOM. ! @@ -24,7 +24,7 @@ module mod_eddtra ! ------------------------------------------------------------------------------ use mod_types, only: r8 - use mod_constants, only: g, alpha0, epsil, onemm + use mod_constants, only: g, alpha0, epsil, onecm, onemm use mod_time, only: delt1 use mod_xc use mod_vcoord, only: vcoord_type_tag, isopyc_bulkml, cntiso_hybrid @@ -33,7 +33,7 @@ module mod_eddtra use mod_state, only: dp, dpu, dpv, temp, saln, p, pbu, pbv, kfpla use mod_diffusion, only: eitmth, difint, umfltd, vmfltd, & utfltd, vtfltd, usfltd, vsfltd - use mod_cmnfld, only: nslpx, nslpy + use mod_cmnfld, only: nslpx, nslpy, mlts use mod_checksum, only: csdiag, chksummsk implicit none @@ -969,9 +969,9 @@ subroutine eddtra_gm_cntiso_hybrid(m, n, mm, nn, k1m, k1n) real(r8), dimension(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy) :: ptu, ptv real(r8), dimension(kdm+1) :: mfl - real(r8), dimension(kdm) :: dlm, dlp - real(r8) :: rho0, q, et2mf, kappa - integer :: i, j, k, l, km, kn, kmax, niter, kdir + real(r8), dimension(kdm) :: puv, dlm, dlp + real(r8) :: rho0, q, et2mf, mlp, kappa + integer :: i, j, k, l, km, kn, kmax, kml, niter, kdir logical :: changed rho0 = 1._r8/alpha0 @@ -979,7 +979,7 @@ subroutine eddtra_gm_cntiso_hybrid(m, n, mm, nn, k1m, k1n) call xctilr(difint, 1, kk, 2, 2, halo_ps) call xctilr(pbu, 1, 2, 2, 2, halo_us) call xctilr(pbv, 1, 2, 2, 2, halo_vs) - + call xctilr(mlts, 1, 1, 1, 1, halo_ps) ! Compute top pressure at velocity points. !$omp parallel do private(l, i) @@ -1005,8 +1005,8 @@ subroutine eddtra_gm_cntiso_hybrid(m, n, mm, nn, k1m, k1n) ! Compute u-component of eddy-induced mass fluxes. ! ------------------------------------------------------------------------- - !$omp parallel do private(l, i, k, km, et2mf, kmax, kn, kappa, mfl, & - !$omp dlm, dlp, changed, niter, kdir, q) + !$omp parallel do private(l, i, k, km, et2mf, kmax, puv, kn, mlp, kml, & + !$omp kappa, mfl, dlm, dlp, changed, niter, kdir, q) do j = - 1, jj + 2 do l = 1, isu(j) do i = max(0, ifu(j, l)), min(ii + 2, ilu(j, l)) @@ -1020,25 +1020,42 @@ subroutine eddtra_gm_cntiso_hybrid(m, n, mm, nn, k1m, k1n) ! Eddy transport to mass flux conversion factor. et2mf = - g*rho0*delt1*scuy(i, j) - ! Index of last layer containing mass at either of the scalar points - ! adjacent to the velocity point. + ! Find index of last layer containing mass at either of the scalar + ! points adjacent to the velocity point and pressure at interfaces. kmax = 1 + puv(1) = ptu(i,j) do k = 2, kk kn = k + nn + puv(k) = puv(k - 1) + dpu(i, j, kn - 1) if (dp(i - 1, j, kn) > epsil .or. dp(i, j, kn) > epsil) kmax = k enddo - ! Compute the eddy induced mass flux at layer interfaces. + ! Compute the eddy induced mass flux at layer interfaces below the + ! mixed layer. + mlp = .5_r8*(mlts(i - 1, j) + mlts(i, j))*onecm + kml = kmax + 1 + mfl(kmax + 1) = 0._r8 + do k = kmax, 2, -1 + if (puv(k) > mlp) then + kappa = .25_r8*( difint(i - 1, j, k - 1) & + + difint(i , j, k - 1) & + + difint(i - 1, j, k ) & + + difint(i , j, k )) + mfl(k) = - kappa*nslpx(i, j, k)*et2mf + kml = k + else + exit + endif + enddo + + ! In the mixed layer, let the eddy induced mass flux change + ! linearly, with respect to interface pressure, from zero at the + ! surface to the mass flux below the mixed layer. mfl(1) = 0._r8 - do k = 2, kmax - kn = k + nn - kappa = .25_r8*( difint(i - 1, j, k - 1) & - + difint(i , j, k - 1) & - + difint(i - 1, j, k ) & - + difint(i , j, k )) - mfl(k) = - kappa*nslpx(i, j, k)*et2mf + q = 1._r8/(mlp - puv(1)) + do k = 2, kml - 1 + mfl(k) = mfl(kml)*(puv(k) - puv(1))*q enddo - mfl(kmax + 1) = 0._r8 ! ------------------------------------------------------------------ ! Ensure that mass fluxes do not create negative layer thicknesses. @@ -1182,8 +1199,8 @@ subroutine eddtra_gm_cntiso_hybrid(m, n, mm, nn, k1m, k1n) ! Compute v-component of eddy-induced mass fluxes. ! ------------------------------------------------------------------------- - !$omp parallel do private(l, i, k, km, et2mf, kmax, kn, kappa, mfl, & - !$omp dlm, dlp, changed, niter, kdir, q) + !$omp parallel do private(l, i, k, km, et2mf, kmax, puv, kn, mlp, kml, & + !$omp kappa, mfl, dlm, dlp, changed, niter, kdir, q) do j = 0, jj + 2 do l = 1, isv(j) do i = max(- 1, ifv(j, l)), min(ii + 2, ilv(j, l)) @@ -1197,25 +1214,42 @@ subroutine eddtra_gm_cntiso_hybrid(m, n, mm, nn, k1m, k1n) ! Eddy transport to mass flux conversion factor. et2mf = - g*rho0*delt1*scvx(i, j) - ! Index of last layer containing mass at either of the scalar points - ! adjacent to the velocity point. + ! Find index of last layer containing mass at either of the scalar + ! points adjacent to the velocity point and pressure at interfaces. kmax = 1 + puv(1) = ptv(i,j) do k = 2, kk kn = k + nn + puv(k) = puv(k - 1) + dpv(i, j, kn - 1) if (dp(i, j - 1, kn) > epsil .or. dp(i, j, kn) > epsil) kmax = k enddo - ! Compute the eddy induced mass flux at layer interfaces. + ! Compute the eddy induced mass flux at layer interfaces below the + ! mixed layer. + mlp = .5_r8*(mlts(i, j - 1) + mlts(i, j))*onecm + kml = kmax + 1 + mfl(kmax + 1) = 0._r8 + do k = kmax, 2, -1 + if (puv(k) > mlp) then + kappa = .25_r8*( difint(i, j - 1, k - 1) & + + difint(i, j , k - 1) & + + difint(i, j - 1, k ) & + + difint(i, j , k )) + mfl(k) = - kappa*nslpy(i, j, k)*et2mf + kml = k + else + exit + endif + enddo + + ! In the mixed layer, let the eddy induced mass flux change + ! linearly, with respect to interface pressure, from zero at the + ! surface to the mass flux below the mixed layer. mfl(1) = 0._r8 - do k = 2, kmax - kn = k + nn - kappa = .25_r8*( difint(i, j - 1, k - 1) & - + difint(i, j , k - 1) & - + difint(i, j - 1, k ) & - + difint(i, j , k )) - mfl(k) = - kappa*nslpy(i, j, k)*et2mf + q = 1._r8/(mlp - puv(1)) + do k = 2, kml - 1 + mfl(k) = mfl(kml)*(puv(k) - puv(1))*q enddo - mfl(kmax + 1) = 0._r8 ! ------------------------------------------------------------------ ! Ensure that mass fluxes do not create negative layer thicknesses. From 2d2e181e303dfeddb769fb2aa53749dc65684af4 Mon Sep 17 00:00:00 2001 From: Mats Bentsen Date: Wed, 25 May 2022 16:30:37 +0200 Subject: [PATCH 097/366] - Added option "vcoord" in the Meson build system to support building of various vertical coordinate choices. - Added specific vertical dimension files for vcoord == isopyc_bulkml and vcoord == cntiso_hybrid for horizontal grids that can be built with Meson. --- bld/MNP2/kdm.cntiso_hybrid | 2 +- bld/channel/kdm.isopyc_bulkml | 1 + bld/fuk95/kdm.cntiso_hybrid | 1 + bld/fuk95/kdm.isopyc_bulkml | 1 + bld/meson.build | 11 ++++++++--- meson.build | 24 +++++++++++++++--------- meson_options.txt | 6 ++++-- 7 files changed, 31 insertions(+), 15 deletions(-) create mode 100644 bld/channel/kdm.isopyc_bulkml create mode 100644 bld/fuk95/kdm.cntiso_hybrid create mode 100644 bld/fuk95/kdm.isopyc_bulkml diff --git a/bld/MNP2/kdm.cntiso_hybrid b/bld/MNP2/kdm.cntiso_hybrid index 2bbd69c2..f6b91e0e 100644 --- a/bld/MNP2/kdm.cntiso_hybrid +++ b/bld/MNP2/kdm.cntiso_hybrid @@ -1 +1 @@ -70 +56 diff --git a/bld/channel/kdm.isopyc_bulkml b/bld/channel/kdm.isopyc_bulkml new file mode 100644 index 00000000..59343b09 --- /dev/null +++ b/bld/channel/kdm.isopyc_bulkml @@ -0,0 +1 @@ +53 diff --git a/bld/fuk95/kdm.cntiso_hybrid b/bld/fuk95/kdm.cntiso_hybrid new file mode 100644 index 00000000..7273c0fa --- /dev/null +++ b/bld/fuk95/kdm.cntiso_hybrid @@ -0,0 +1 @@ +25 diff --git a/bld/fuk95/kdm.isopyc_bulkml b/bld/fuk95/kdm.isopyc_bulkml new file mode 100644 index 00000000..7273c0fa --- /dev/null +++ b/bld/fuk95/kdm.isopyc_bulkml @@ -0,0 +1 @@ +25 diff --git a/bld/meson.build b/bld/meson.build index a3c43727..14db644c 100644 --- a/bld/meson.build +++ b/bld/meson.build @@ -1,17 +1,22 @@ # Generate 'dimensions.F' based on desired grid and processor count blom_dims = find_program('blom_dimensions') patch_path = meson.source_root() / 'bld' / get_option('grid') -kdm_path = get_option('grid') / 'kdm' +if get_option('vcoord') == 'isopyc_bulkml' + kdm_file = 'kdm.isopyc_bulkml' +elif get_option('vcoord') == 'cntiso_hybrid' + kdm_file = 'kdm.cntiso_hybrid' +endif +kdm_path = get_option('grid') / kdm_file # More systems which support 'cat' can be added here, once tested if host_machine.system() in ['linux', 'darwin'] dim_kdm = run_command('cat', kdm_path) elif host_machine.system() == 'windows' dim_kdm = run_command('type', kdm_path) else - error('Could not read "kdm" content due to unknown OS (' + host_machine.system() + ')') + error('Could not read ' + kdm_file + ' content due to unknown OS (' + host_machine.system() + ')') endif if dim_kdm.returncode() != 0 - error('No "kdm" file found for grid "' + get_option('grid') + '"') + error('No ' + kdm_file + ' file found for grid "' + get_option('grid') + '"') endif dimensions = configure_file( output: 'dimensions.F', diff --git a/meson.build b/meson.build index 3958cf0c..2306f6f1 100644 --- a/meson.build +++ b/meson.build @@ -71,28 +71,34 @@ subdir('pkgs/') # Handle options and add necessary flags and subfolders with source files -if get_option('iage') or get_option('turbclo').length() > 0 or get_option('ecosys') +turbclo = get_option('turbclo') +if turbclo.length() > 0 and get_option('vcoord') == 'cntiso_hybrid' + message('Setting turbclo = [] for vcoord == \'cntiso_hybrid\'') + turbclo = [] +endif + +if get_option('iage') or turbclo.length() > 0 or get_option('ecosys') add_project_arguments('-DTRC', language: 'fortran') subdir('trc') endif -if get_option('turbclo').length() > 0 - if not (get_option('turbclo').contains('oneeq') or get_option('turbclo').contains('twoeq')) +if turbclo.length() > 0 + if not (turbclo.contains('oneeq') or turbclo.contains('twoeq')) error('For turbulent closure, either twoeq or oneeq must be provided as options!') endif - if get_option('turbclo').contains('oneeq') and get_option('turbclo').contains('twoeq') + if turbclo.contains('oneeq') and turbclo.contains('twoeq') error('For turbulent closure, do not use both twoeq and oneeq as options!') endif - if get_option('turbclo').contains('oneeq') + if turbclo.contains('oneeq') add_project_arguments('-DTKE', language: 'fortran') endif - if get_option('turbclo').contains('twoeq') + if turbclo.contains('twoeq') add_project_arguments('-DTKE', '-DGLS', language: 'fortran') endif - if get_option('turbclo').contains('advection') + if turbclo.contains('advection') add_project_arguments('-DTKEADV', language: 'fortran') endif - if get_option('turbclo').contains('isodif') + if turbclo.contains('isodif') add_project_arguments('-DTKEIDF', language: 'fortran') endif endif @@ -115,7 +121,7 @@ if get_option('ecosys') endif if get_option('hamocc_ciso') if not get_option('hamocc_sedbypass') - error('hamocc_ciso=true requires hamocc_sedbypass=true!') + error('hamocc_ciso == true requires hamocc_sedbypass == true!') endif add_project_arguments('-Dcisonew', language: 'fortran') endif diff --git a/meson_options.txt b/meson_options.txt index ee2e89b2..62347e35 100644 --- a/meson_options.txt +++ b/meson_options.txt @@ -6,14 +6,16 @@ option('grid', type: 'combo', 'tnx0.25v4', 'tnx1.5v1', 'tnx1v1', 'tnx1v3', 'tnx1v4', 'tnx2v1', 'MNP2', 'fuk95', 'single_column','channel'], description: 'Grid name', value: 'fuk95') +option('vcoord', type: 'combo', + choices: ['isopyc_bulkml', 'cntiso_hybrid'], + description: 'Vertical coordinate', value: 'isopyc_bulkml') # Which executable driver should be built option('driver', type: 'combo', choices: ['nocoupler', 'noforc'], value: 'nocoupler') # List of BLOM options option('turbclo', type: 'array', choices: ['oneeq', 'twoeq', 'advection', 'isodif'], - description: 'Turbulent closure options', value: ['oneeq', - 'advection']) + description: 'Turbulent closure options', value: ['oneeq', 'advection']) option('iage', type: 'boolean', description: 'Enable ideal age tracer', value: true) option('ecosys', type: 'boolean', From 75d7494ccc2a0f1f1011685457d1244c76c0adee Mon Sep 17 00:00:00 2001 From: Mats Bentsen Date: Wed, 25 May 2022 16:31:32 +0200 Subject: [PATCH 098/366] Fixed Fortran code alignment. --- fuk95/mod_fuk95.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/fuk95/mod_fuk95.F90 b/fuk95/mod_fuk95.F90 index 74cdfd10..6dd0a7bc 100644 --- a/fuk95/mod_fuk95.F90 +++ b/fuk95/mod_fuk95.F90 @@ -383,7 +383,7 @@ subroutine ictsz_fuk95 enddo !$omp end parallel do - s0 = rho0 - 1._r8 + s0 = rho0 - 1._r8 !$omp parallel do private(k, l, i, x, s1) do j = 1, jj do k = 1, kk From 23c5b6a95150bae04d7e86d3f53dd7694bdaaebd Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Wed, 25 May 2022 17:29:12 +0200 Subject: [PATCH 099/366] introduce max temperature cutoff --- hamocc/mo_extNbioproc.F90 | 36 +++++++++++++++++++++--------------- 1 file changed, 21 insertions(+), 15 deletions(-) diff --git a/hamocc/mo_extNbioproc.F90 b/hamocc/mo_extNbioproc.F90 index b1eeeefd..fa6a4387 100644 --- a/hamocc/mo_extNbioproc.F90 +++ b/hamocc/mo_extNbioproc.F90 @@ -166,7 +166,7 @@ subroutine nitrification(kpie,kpje,kpke,pddpo,omask,ptho) integer :: i,j,k,proc_ctr real :: Tdepanh4,O2limanh4,nut1lim,anh4new,potdnh4amox,fdetamox,fno2,fn2o,ftotnh4 real :: Tdepano2,O2limano2,nut2lim,ano2new,potdno2nitr,fdetnitr,fno3,ftotno2 - real :: amoxfrac,nitrfrac,totd,amox,nitr + real :: amoxfrac,nitrfrac,totd,amox,nitr,temp real :: minlim_oxnh4,minlim_nh4,minlim_oxno2,minlim_no2 ! minimum conc for limitation functions @@ -177,7 +177,7 @@ subroutine nitrification(kpie,kpje,kpke,pddpo,omask,ptho) !$OMP PARALLEL DO PRIVATE(i,k,Tdepanh4,O2limanh4,nut1lim,anh4new,potdnh4amox,fdetamox,fno2,fn2o,ftotnh4, & !$OMP Tdepano2,O2limano2,nut2lim,ano2new,potdno2nitr,fdetnitr,fno3,ftotno2,amoxfrac, & - !$OMP nitrfrac,totd,amox,nitr,proc_ctr) + !$OMP nitrfrac,totd,amox,nitr,proc_ctr,temp) do j = 1,kpje do i = 1,kpie @@ -185,8 +185,9 @@ subroutine nitrification(kpie,kpje,kpke,pddpo,omask,ptho) if(pddpo(i,j,k) > dp_min .and. omask(i,j) > 0.5) then proc_ctr = 0 if(ocetra(i,j,k,ioxygen)>minlim_oxnh4 .and. ocetra(i,j,k,ianh4)>minlim_nh4)then + temp = merge(ptho(i,j,k),10.,ptho(i,j,k)<40.) ! Ammonium oxidation step of nitrification - Tdepanh4 = q10anh4nitr**((ptho(i,j,k)-Trefanh4nitr)/10.) + Tdepanh4 = q10anh4nitr**((temp-Trefanh4nitr)/10.) O2limanh4 = ocetra(i,j,k,ioxygen)/(ocetra(i,j,k,ioxygen) + bkoxamox) nut1lim = ocetra(i,j,k,ianh4)/(ocetra(i,j,k,ianh4) + bkanh4nitr) anh4new = ocetra(i,j,k,ianh4)/(1. + ranh4nitr*Tdepanh4*O2limanh4*nut1lim) @@ -212,8 +213,9 @@ subroutine nitrification(kpie,kpje,kpke,pddpo,omask,ptho) endif if(ocetra(i,j,k,ioxygen)>minlim_oxno2 .and. ocetra(i,j,k,iano2)>minlim_no2)then + temp = merge(ptho(i,j,k),10.,ptho(i,j,k)<40.) ! NO2 oxidizing step of nitrification - Tdepano2 = q10ano2nitr**((ptho(i,j,k)-Trefano2nitr)/10.) + Tdepano2 = q10ano2nitr**((temp-Trefano2nitr)/10.) O2limano2 = ocetra(i,j,k,ioxygen)/(ocetra(i,j,k,ioxygen) + bkoxnitr) nut2lim = ocetra(i,j,k,iano2)/(ocetra(i,j,k,iano2) + bkano2nitr) ano2new = ocetra(i,j,k,iano2)/(1. + rano2nitr*Tdepano2*O2limano2*nut2lim) @@ -284,20 +286,21 @@ subroutine denit_NO3_to_NO2(kpie,kpje,kpke,pddpo,omask,ptho) !local variables integer :: i,j,k - real :: Tdep,O2inhib,nutlim,ano3new,ano3denit + real :: Tdep,O2inhib,nutlim,ano3new,ano3denit,temp real :: minlim_ox,minlim_no3 ! minimum conc for limitation functions minlim_ox = log(2./minlim-1.)/(2.*sc_ano3denit) minlim_no3 = bkano3denit*minlim/(1.-minlim) - !$OMP PARALLEL DO PRIVATE(i,k,Tdep,O2inhib,nutlim,ano3new,ano3denit) + !$OMP PARALLEL DO PRIVATE(i,k,Tdep,O2inhib,nutlim,ano3new,ano3denit,temp) do j = 1,kpje do i = 1,kpie do k = 1,kpke if(pddpo(i,j,k) > dp_min .and. omask(i,j) > 0.5) then if(ocetra(i,j,k,ioxygen) < minlim_ox .and. ocetra(i,j,k,iano3)>minlim_no3)then - Tdep = q10ano3denit**((ptho(i,j,k)-Trefano3denit)/10.) + temp = merge(ptho(i,j,k),10.,ptho(i,j,k)<40.) + Tdep = q10ano3denit**((temp-Trefano3denit)/10.) O2inhib = 1. - tanh(sc_ano3denit*ocetra(i,j,k,ioxygen)) nutlim = ocetra(i,j,k,iano3)/(ocetra(i,j,k,iano3) + bkano3denit) @@ -333,7 +336,7 @@ subroutine anammox(kpie,kpje,kpke,pddpo,omask,ptho) !local variables integer :: i,j,k - real :: Tdep,O2inhib,nut1lim,nut2lim,ano2new,ano2anmx + real :: Tdep,O2inhib,nut1lim,nut2lim,ano2new,ano2anmx,temp real :: minlim_ox,minlim_nh4,minlim_no2 ! minimum conc for limitation functions @@ -341,13 +344,14 @@ subroutine anammox(kpie,kpje,kpke,pddpo,omask,ptho) minlim_nh4 = bkanh4anmx*minlim/(1.-minlim) minlim_no2 = bkano2anmx*minlim/(1.-minlim) - !$OMP PARALLEL DO PRIVATE(i,k,Tdep,O2inhib,nut1lim,nut2lim,ano2new,ano2anmx) + !$OMP PARALLEL DO PRIVATE(i,k,Tdep,O2inhib,nut1lim,nut2lim,ano2new,ano2anmx,temp) do j = 1,kpje do i = 1,kpie do k = 1,kpke if(pddpo(i,j,k) > dp_min .and. omask(i,j) > 0.5) then if(ocetra(i,j,k,iano2)>minlim_no2 .and. ocetra(i,j,k,ianh4)>minlim_nh4 .and. ocetra(i,j,k,ioxygen)minlim_n2o)then + temp = merge(ptho(i,j,k),10.,ptho(i,j,k)<40.) ! === denitrification on N2O - Tdepan2o = q10an2odenit**((ptho(i,j,k)-Trefan2odenit)/10.) + Tdepan2o = q10an2odenit**((temp-Trefan2odenit)/10.) O2inhiban2o = bkoxan2odenit**2/(ocetra(i,j,k,ioxygen)**2 + bkoxan2odenit**2) nutliman2o = ocetra(i,j,k,ian2o)/(ocetra(i,j,k,ian2o) + bkan2odenit) an2onew = ocetra(i,j,k,ian2o)/(1. + ran2odenit*Tdepan2o*O2inhiban2o*nutliman2o) @@ -433,14 +438,15 @@ subroutine denit_dnra(kpie,kpje,kpke,pddpo,omask,ptho) endif if(0.<=ocetra(i,j,k,ioxygen) .and. ocetra(i,j,k,ioxygen)minlim_no2)then + temp = merge(ptho(i,j,k),10.,ptho(i,j,k)<40.) ! denitrification on NO2 - Tdepano2 = q10ano2denit**((ptho(i,j,k)-Trefano2denit)/10.) + Tdepano2 = q10ano2denit**((temp-Trefano2denit)/10.) O2inhibano2 = bkoxano2denit**2/(ocetra(i,j,k,ioxygen)**2 + bkoxano2denit**2) nutlimano2 = ocetra(i,j,k,iano2)/(ocetra(i,j,k,iano2) + bkano2denit) rpotano2denit = max(0.,rano2denit*Tdepano2*O2inhibano2*nutlimano2) ! potential rate of denit ! DNRA on NO2 - Tdepdnra = q10dnra**((ptho(i,j,k)-Trefdnra)/10.) + Tdepdnra = q10dnra**((temp-Trefdnra)/10.) O2inhibdnra = bkoxdnra**2/(ocetra(i,j,k,ioxygen)**2 + bkoxdnra**2) nutlimdnra = ocetra(i,j,k,iano2)/(ocetra(i,j,k,iano2) + bkdnra) rpotano2dnra = max(0.,rdnra*Tdepdnra*O2inhibdnra*nutlimdnra) ! pot. rate of dnra From fdae153aaa2e04c5565db02e84c2f1752acd29cf Mon Sep 17 00:00:00 2001 From: Mats Bentsen Date: Thu, 26 May 2022 00:03:34 +0200 Subject: [PATCH 100/366] Removed unused variables. --- phy/mod_hor3map.F90 | 6 ++---- 1 file changed, 2 insertions(+), 4 deletions(-) diff --git a/phy/mod_hor3map.F90 b/phy/mod_hor3map.F90 index e5ba4ed3..fd28b6e9 100644 --- a/phy/mod_hor3map.F90 +++ b/phy/mod_hor3map.F90 @@ -2319,7 +2319,7 @@ pure subroutine limit_pqm_non_oscillatory(rcss) real(r8), dimension(rcss%rcgs%n_src_actual) :: d2, sl, sr, sc logical, dimension(rcss%rcgs%n_src_actual) :: smooth - real(r8) :: min_u_0, a0, a1, a2, a3, b0, b1, b2, q1, q2, q3, s, xi + real(r8) :: a0, a1, a2, a3, b0, b1, b2, q1, q2, q3, s, xi integer :: ns, j logical :: inflex, incon_inflex @@ -2941,8 +2941,6 @@ pure function line_intersection(pc, u, u_eps, xil, xir) result(xi) real(r8) :: xi - real(r8) :: q, s, xi1, xi2, xim - if (abs(pc(2)) < u_eps) then xi = xil else @@ -4497,7 +4495,7 @@ function regrid2(rcss, u_edge_grd, x_edge_grd, missing_value, & integer :: errstat - real(r8) :: u_sgn, ue_min, ue_max + real(r8) :: u_sgn errstat = hor3map_noerr From 930d5b31a12d940525217ad2f8c4bd106d4bdcea Mon Sep 17 00:00:00 2001 From: Mats Bentsen Date: Thu, 26 May 2022 00:07:36 +0200 Subject: [PATCH 101/366] Removed unused variables, corrected OpenMP statements and updated copyright notices. --- cesm/mod_cesm.F90 | 4 ++-- phy/bigrid.F | 5 +---- phy/mod_checksum.F90 | 2 +- phy/mod_cmnfld_routines.F90 | 4 +--- phy/mod_dia.F | 4 ++-- phy/mod_diffusion.F90 | 11 ++++++----- phy/mod_nctools.F | 5 ++--- phy/mod_vcoord.F90 | 5 +---- 8 files changed, 16 insertions(+), 24 deletions(-) diff --git a/cesm/mod_cesm.F90 b/cesm/mod_cesm.F90 index 2fbdc4a4..eeab591e 100644 --- a/cesm/mod_cesm.F90 +++ b/cesm/mod_cesm.F90 @@ -1,5 +1,5 @@ ! ------------------------------------------------------------------------------ -! Copyright (C) 2011-2020 Mats Bentsen +! Copyright (C) 2011-2022 Mats Bentsen ! ! This file is part of BLOM. ! @@ -91,7 +91,7 @@ subroutine inicon_cesm ! Set initial conditions for variables specifically when coupled to CESM. ! --------------------------------------------------------------------------- - integer :: i, j, l + integer :: i, j !$omp parallel do private(i) do j = 1, jj diff --git a/phy/bigrid.F b/phy/bigrid.F index 23c40e86..f79fe7e1 100644 --- a/phy/bigrid.F +++ b/phy/bigrid.F @@ -1,6 +1,6 @@ ! ------------------------------------------------------------------------------ ! Copyright (C) 2000 HYCOM Consortium and contributors -! Copyright (C) 2001-2020 Mats Bentsen, Lars Inge Enstad +! Copyright (C) 2001-2022 Mats Bentsen, Lars Inge Enstad ! ! This file is part of BLOM. ! @@ -38,9 +38,6 @@ subroutine bigrid(depth) c integer i,j,nfill,nzero real depmax -c - character fmt*13 - data fmt/'(i4,1x,120i1)'/ c c --- is the domain periodic in i-index? depmax=0.0 diff --git a/phy/mod_checksum.F90 b/phy/mod_checksum.F90 index e2a4aeb0..d78a968c 100644 --- a/phy/mod_checksum.F90 +++ b/phy/mod_checksum.F90 @@ -1,5 +1,5 @@ ! ------------------------------------------------------------------------------ -! Copyright (C) 2006-2020 Mats Bentsen +! Copyright (C) 2006-2021 Mats Bentsen ! ! This file is part of BLOM. ! diff --git a/phy/mod_cmnfld_routines.F90 b/phy/mod_cmnfld_routines.F90 index b01913e4..177c2730 100644 --- a/phy/mod_cmnfld_routines.F90 +++ b/phy/mod_cmnfld_routines.F90 @@ -832,7 +832,7 @@ subroutine cmnfld_nnslope_cntiso_hybrid(m, n, mm, nn, k1m, k1n) enddo !$omp end parallel do - !$omp parallel do private(k, l, i, k, bfsqm) + !$omp parallel do private(k, l, i, bfsqm) do j = 0, jj + 2 do k = 1, kk do l = 1, isv(j) @@ -971,8 +971,6 @@ subroutine cmnfld1(m, n, mm, nn, k1m, k1n) integer, intent(in) :: m, n, mm, nn, k1m, k1n - integer :: i, j, l - ! ------------------------------------------------------------------------ ! Compute fields depending on selection of physics and diagnostics. ! ------------------------------------------------------------------------ diff --git a/phy/mod_dia.F b/phy/mod_dia.F index ef1f489c..715f811b 100644 --- a/phy/mod_dia.F +++ b/phy/mod_dia.F @@ -1,5 +1,5 @@ ! ------------------------------------------------------------------------------ -! Copyright (C) 2010-2021 Ingo Bethke, Mats Bentsen, Mehmet Ilicak, +! Copyright (C) 2010-2022 Ingo Bethke, Mats Bentsen, Mehmet Ilicak, ! Alok Kumar Gupta, Jörg Schwinger, Ping-Gin Chiu ! ! This file is part of BLOM. @@ -1000,7 +1000,7 @@ subroutine diaacc(m,n,mm,nn,k1m,k1n) . avdsg_p,dpvor_p,pv_p,dummy real, dimension(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy) :: . dpml,sbot,tbot,dps,t20d - real dsig,q,zup,zlo,plo,tup,tlo + real dsig,q,zup,zlo,tup,tlo c c --- Increase counter do iogrp=1,nphy diff --git a/phy/mod_diffusion.F90 b/phy/mod_diffusion.F90 index fe744461..c0e923e1 100644 --- a/phy/mod_diffusion.F90 +++ b/phy/mod_diffusion.F90 @@ -168,7 +168,8 @@ subroutine inivar_diffusion enddo !$omp end parallel do - ! Initialize isopycnal diffusivity . + ! Initialize isopycnal diffusivity. + !$omp parallel do private(k, l, i) do j = 1, jj do k = 1, kk do l = 1, isp(j) @@ -181,8 +182,8 @@ subroutine inivar_diffusion !$omp end parallel do call xctilr(difiso, 1, kk, nbdy, nbdy, halo_ps) - ! Initialize diffusive fluxes at points located upstream and downstream (in - ! i-direction) of p-points. + ! Initialize diffusive fluxes at points located upstream and downstream + ! (in i-direction) of p-points. !$omp parallel do private(k, l, i) do j = 1, jj do k = 1, 2*kk @@ -202,8 +203,8 @@ subroutine inivar_diffusion call xctilr(utflld, 1, 2*kk, nbdy, nbdy, halo_us) call xctilr(usflld, 1, 2*kk, nbdy, nbdy, halo_us) - ! Initialize diffusive fluxes at points located upstream and downstream (in - ! j-direction) of p-points. + ! Initialize diffusive fluxes at points located upstream and downstream + ! (in j-direction) of p-points. !$omp parallel do private(k, l, j) do i = 1, ii do k = 1, 2*kk diff --git a/phy/mod_nctools.F b/phy/mod_nctools.F index 160becb5..dc27e695 100644 --- a/phy/mod_nctools.F +++ b/phy/mod_nctools.F @@ -1,5 +1,5 @@ ! ------------------------------------------------------------------------------ -! Copyright (C) 2004-2020 Ingo Bethke, Mats Bentsen, Alok Kumar Gupta +! Copyright (C) 2004-2022 Ingo Bethke, Mats Bentsen, Alok Kumar Gupta ! ! This file is part of BLOM. ! @@ -869,8 +869,7 @@ subroutine ncread(vnm,fld,msk,mskflg,fill) character*100 :: dimname integer :: i,j,ij,k,kd,n,ndm integer, parameter :: maxdm=5, ijdm=(idm+2*nbdy)*(jdm+2*nbdy) - integer ndims,dimids(maxdm),dimlen,strind(2,maxdm), - . msk(*),mskflg + integer ndims,dimids(maxdm),dimlen,msk(*),mskflg #ifdef PNETCDF integer(kind=MPI_OFFSET_KIND) tdimlen #endif diff --git a/phy/mod_vcoord.F90 b/phy/mod_vcoord.F90 index cd6f87a6..6003d835 100644 --- a/phy/mod_vcoord.F90 +++ b/phy/mod_vcoord.F90 @@ -540,9 +540,6 @@ subroutine cntiso_regrid_nudge_jslice(p_src, p_dst, i_lb, i_ub, j, j_rs, nn) integer :: l, i, nt, k, kr, kl, klastok, kt, errstat logical :: ok - real(r8) :: x,tt,st - - nudge_factor = 1._r8 nudge_factor = 1._r8/10._r8 do l = 1, isp(j) @@ -1209,7 +1206,7 @@ subroutine remap_velocity(m, n, mm, nn, k1m, k1n) real(r8) :: q integer :: i, j, k, l, kn, errstat - !$omp parallel do private(k, km, l, i) + !$omp parallel do private(k, kn, l, i) do j = 1, jj do k = 1, kk kn = k + nn From 76592304e2f6403cb0e141d94f4c8042c3f115bf Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Thu, 26 May 2022 00:21:08 +0200 Subject: [PATCH 102/366] resetting INITIAL CONDITIONS - particularly for N2O --- hamocc/beleg_vars.F90 | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/hamocc/beleg_vars.F90 b/hamocc/beleg_vars.F90 index 9600a16a..56fa34d7 100644 --- a/hamocc/beleg_vars.F90 +++ b/hamocc/beleg_vars.F90 @@ -216,8 +216,9 @@ SUBROUTINE BELEG_VARS(kpaufr,kpie,kpje,kpke,kbnd,pddpo,prho,omask, & ocetra(i,j,k,ibromo)= 1.e-14/prho(i,j,k) #endif #ifdef extNcycle - ocetra(i,j,k,iano2) =1.e-10 - ocetra(i,j,k,ianh4) =0.5e-10 + ocetra(i,j,k,iano2) =1.e-9 ! expecting fast cycling + ocetra(i,j,k,ianh4) =0.5e-9 ! expecting fast cycling + ocetra(i,j,k,ian2o) =20.e-9 ! 20nmol/kg = ca. value deep ocean Toyoda et al. 2019 #endif ENDIF ! omask > 0.5 From 8c3715f9760b25acee0483e0369aa813af1c494c Mon Sep 17 00:00:00 2001 From: Mats Bentsen Date: Thu, 26 May 2022 16:37:33 +0200 Subject: [PATCH 103/366] Added regridding nudge factor as namelist variable. --- phy/mod_vcoord.F90 | 18 ++++++++++-------- 1 file changed, 10 insertions(+), 8 deletions(-) diff --git a/phy/mod_vcoord.F90 b/phy/mod_vcoord.F90 index 6003d835..8356cfca 100644 --- a/phy/mod_vcoord.F90 +++ b/phy/mod_vcoord.F90 @@ -67,7 +67,8 @@ module mod_vcoord real(r8) :: & dpmin_surface = 1.5_r8, & dpmin_inflation_factor = 1._r8, & - dpmin_interior = .1_r8 + dpmin_interior = .1_r8, & + regrid_nudge_factor = .1_r8 ! Options derived from string options. integer :: & @@ -536,12 +537,10 @@ subroutine cntiso_regrid_nudge_jslice(p_src, p_dst, i_lb, i_ub, j, j_rs, nn) integer, dimension(1-nbdy:idm+nbdy) :: ksmx, kdmx real(r8), dimension(kdm+1) :: sigmar_1d, pmin, sig_pmin - real(r8) :: nudge_factor, sig_max, dpmin_sfc, dsig, dsigdx, q + real(r8) :: sig_max, dpmin_sfc, dsig, dsigdx, q integer :: l, i, nt, k, kr, kl, klastok, kt, errstat logical :: ok - nudge_factor = 1._r8/10._r8 - do l = 1, isp(j) do i = max(i_lb, ifp(j, l)), min(i_ub, ilp(j, l)) @@ -623,7 +622,7 @@ subroutine cntiso_regrid_nudge_jslice(p_src, p_dst, i_lb, i_ub, j, j_rs, nn) ok = .true. if (sigmar_1d(k) < sig_srcdi(2,k-1) .and. & sigmar_1d(k) < sig_srcdi(1,k )) then - dsig = (sigmar_1d(k) - sig_srcdi(2,k-1))*nudge_factor + dsig = (sigmar_1d(k) - sig_srcdi(2,k-1))*regrid_nudge_factor 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)) & @@ -636,7 +635,7 @@ subroutine cntiso_regrid_nudge_jslice(p_src, p_dst, i_lb, i_ub, j, j_rs, nn) + dsig*(p_src(k,i) - p_src(k-1,i))/dsigdx elseif (sigmar_1d(k) > sig_srcdi(2,k-1) .and. & sigmar_1d(k) > sig_srcdi(1,k )) then - dsig = (sigmar_1d(k) - sig_srcdi(1,k))*nudge_factor + dsig = (sigmar_1d(k) - sig_srcdi(1,k))*regrid_nudge_factor 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)) & @@ -669,7 +668,7 @@ subroutine cntiso_regrid_nudge_jslice(p_src, p_dst, i_lb, i_ub, j, j_rs, nn) do k = max(kr, min(ksmx(i), kdmx(i))) + 1, kdmx(i) ok = .true. if (sigmar_1d(k) < sig_srcdi(2,ksmx(i))) then - dsig = (sigmar_1d(k) - sig_srcdi(2,ksmx(i)))*nudge_factor + dsig = (sigmar_1d(k) - sig_srcdi(2,ksmx(i)))*regrid_nudge_factor dsigdx = dsigdt(t_srcdi(2,ksmx(i),it,i), & t_srcdi(2,ksmx(i),is,i)) & *dpeval1(tpc_src(:,ksmx(i),it,i)) & @@ -760,7 +759,8 @@ subroutine readnml_vcoord 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 + dpmin_surface, dpmin_inflation_factor, dpmin_interior, & + regrid_nudge_factor ! Read variables in the namelist group 'vcoord'. if (mnproc == 1) then @@ -803,6 +803,7 @@ subroutine readnml_vcoord call xcbcst(dpmin_surface) call xcbcst(dpmin_inflation_factor) call xcbcst(dpmin_interior) + call xcbcst(regrid_nudge_factor) endif if (mnproc == 1) then write (lp,*) 'readnml_vcoord: vertical coordinate variables:' @@ -825,6 +826,7 @@ subroutine readnml_vcoord write (lp,*) ' dpmin_surface = ', dpmin_surface write (lp,*) ' dpmin_inflation_factor = ', dpmin_inflation_factor write (lp,*) ' dpmin_interior = ', dpmin_interior + write (lp,*) ' regrid_nudge_factor = ', regrid_nudge_factor endif ! Resolve options. From fd118b30a7b5a71f827b27abc321b5754821686f Mon Sep 17 00:00:00 2001 From: Mats Bentsen Date: Mon, 30 May 2022 00:20:02 +0200 Subject: [PATCH 104/366] Created a namelist group for diffusion parameters and added type of lateral tracer eddy diffusion as namelist parameter. --- phy/diffus.F | 4 +- phy/mod_cmnfld_routines.F90 | 10 ++- phy/mod_difest.F | 48 +++------- phy/mod_diffusion.F90 | 172 ++++++++++++++++++++++++++++++++++-- phy/mod_eddtra.F90 | 17 ++-- phy/mod_vcoord.F90 | 8 +- phy/rdlim.F | 43 ++------- tests/fuk95/limits | 96 +++++++++++--------- 8 files changed, 260 insertions(+), 138 deletions(-) diff --git a/phy/diffus.F b/phy/diffus.F index 7f810ab8..e99a4983 100644 --- a/phy/diffus.F +++ b/phy/diffus.F @@ -29,7 +29,7 @@ subroutine diffus(m,n,mm,nn,k1m,k1n) use mod_eos, only: sig use mod_state, only: dp, temp, saln, sigma, . utflx, vtflx, usflx, vsflx - use mod_diffusion, only: ntrdif,difiso, + use mod_diffusion, only: ltedtp_opt, ltedtp_neutral, difiso, . utflld, vtflld, usflld, vsflld use mod_checksum, only: csdiag, chksummsk #ifdef TRC @@ -50,7 +50,7 @@ subroutine diffus(m,n,mm,nn,k1m,k1n) parameter (dpeps=1.e-4) c call xctilr(dp(1-nbdy,1-nbdy,k1n), 1,kk, 3,3, halo_ps) - if (ntrdif) then + if (ltedtp_opt.eq.ltedtp_neutral) then 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) #ifdef TRC diff --git a/phy/mod_cmnfld_routines.F90 b/phy/mod_cmnfld_routines.F90 index 177c2730..761ac198 100644 --- a/phy/mod_cmnfld_routines.F90 +++ b/phy/mod_cmnfld_routines.F90 @@ -35,7 +35,9 @@ module mod_cmnfld_routines use mod_cmnfld, only: sls0, slsmfq, slsels, bfsqmn, dbcrit, & bfsqi, bfsqf, z, bfsql, nslpx, nslpy, nnslpx, nnslpy, & dz, mlts - use mod_diffusion, only: eitmth, edritp, ntrdif + use mod_diffusion, only: eitmth_opt, eitmth_gm, & + edritp_opt, edritp_large_scale, & + ltedtp_opt, ltedtp_neutral use mod_utility, only: util1 use mod_checksum, only: csdiag, chksummsk @@ -1051,7 +1053,7 @@ subroutine cmnfld2(m, n, mm, nn, k1m, k1n) ! edritp == 'large scale' .or. eitmth == 'gm' .or. & ! sum(ACC_BFSQ(1:nphy)) /= 0) then if (vcoord_type_tag == cntiso_hybrid .or. & - edritp == 'large scale' .or. eitmth == 'gm') then + edritp_opt == edritp_large_scale .or. eitmth_opt == eitmth_gm) then ! --------------------------------------------------------------------- ! Compute filtered buoyancy frequency squared. @@ -1065,7 +1067,7 @@ subroutine cmnfld2(m, n, mm, nn, k1m, k1n) endif - if (edritp == 'large scale' .or. eitmth == 'gm') then + if (edritp_opt == edritp_large_scale .or. eitmth_opt == eitmth_gm) then ! --------------------------------------------------------------------- ! Estimate slope of local neutral surface. @@ -1074,7 +1076,7 @@ subroutine cmnfld2(m, n, mm, nn, k1m, k1n) if (vcoord_type_tag == isopyc_bulkml) then call cmnfld_nslope_isopyc_bulkml(m, n, mm, nn, k1m, k1n) else - if (ntrdif) then + if (ltedtp_opt == ltedtp_neutral) then call cmnfld_nnslope_cntiso_hybrid(m, n, mm, nn, k1m, k1n) else call cmnfld_nslope_cntiso_hybrid(m, n, mm, nn, k1m, k1n) diff --git a/phy/mod_difest.F b/phy/mod_difest.F index e84bf2f6..e661e8ba 100644 --- a/phy/mod_difest.F +++ b/phy/mod_difest.F @@ -32,7 +32,9 @@ module mod_difest . pbu, pbv, ubflxs_p, vbflxs_p, kfpla use mod_diffusion, only: egc, eggam, eglsmn, egmndf, egmxdf, . egidfq, ri0, bdmc1, bdmc2, tkepf, bdmtyp, - . edsprs, edritp, edwmth, + . edsprs, edritp_opt, edritp_shear, + . edritp_large_scale, edwmth_opt, + . edwmth_smooth, edwmth_step, . difint, difiso, difdia, difmxp, difwgt, . Kvisc_m, Kdiff_t, Kdiff_s, . t_ns_nonloc, s_nonloc @@ -1337,7 +1339,7 @@ subroutine difest_lateral_hyb(m,n,mm,nn,k1m,k1n) c c --- - Compute diffusivity weigth to reduce eddy diffusivity when the c --- - Rossby radius is resolved by the grid. - if (edwmth.eq.'smooth') then + if (edwmth_opt.eq.edwmth_smooth) then do l=1,isp(j) do i=max(1,ifp(j,l)),min(ii,ilp(j,l)) q=bcrrd(i)/sqrt(.5*(scpx(i,j)*scpx(i,j) @@ -1345,7 +1347,7 @@ subroutine difest_lateral_hyb(m,n,mm,nn,k1m,k1n) difwgt(i,j)=1./(1.+.25*q**4) enddo enddo - elseif (edwmth.eq.'step') then + elseif (edwmth_opt.eq.edwmth_step) then do l=1,isp(j) do i=max(1,ifp(j,l)),min(ii,ilp(j,l)) q=bcrrd(i)/sqrt(.5*(scpx(i,j)*scpx(i,j) @@ -1357,13 +1359,6 @@ subroutine difest_lateral_hyb(m,n,mm,nn,k1m,k1n) endif enddo enddo - else - if (mnproc.eq.1) then - write (lp,'(3a)') ' edwmth=',trim(edwmth), - . ' is unsupported!' - endif - call xcstop('(difest_lateral_hyb)') - stop '(difest_lateral_hyb)' endif c c --- ------------------------------------------------------------------ @@ -1404,7 +1399,7 @@ subroutine difest_lateral_hyb(m,n,mm,nn,k1m,k1n) enddo enddo endif - if (edritp.eq.'shear') then + if (edritp_opt.eq.edritp_shear) then do k=2,kk do l=1,isp(j) do i=max(1,ifp(j,l)),min(ii,ilp(j,l)) @@ -1422,7 +1417,7 @@ subroutine difest_lateral_hyb(m,n,mm,nn,k1m,k1n) enddo enddo enddo - elseif (edritp.eq.'large scale') then + elseif (edritp_opt.eq.edritp_large_scale) then do l=1,isp(j) do i=max(1,ifp(j,l)),min(ii,ilp(j,l)) if (kmax(i,j)-kfil(i,j).ge.1) then @@ -1484,13 +1479,6 @@ subroutine difest_lateral_hyb(m,n,mm,nn,k1m,k1n) enddo enddo enddo - else - if (mnproc.eq.1) then - write (lp,'(3a)') ' edritp=',trim(edritp), - . ' is unsupported!' - endif - call xcstop('(difest)') - stop '(difest)' endif if (edsprs) then do l=1,isp(j) @@ -1748,7 +1736,7 @@ subroutine difest_lateral_iso(m,n,mm,nn,k1m,k1n) c c --- - Compute diffusivity weigth to reduce eddy diffusivity when the c --- - Rossby radius is resolved by the grid. - if (edwmth.eq.'smooth') then + if (edwmth_opt.eq.edwmth_smooth) then do l=1,isp(j) do i=max(1,ifp(j,l)),min(ii,ilp(j,l)) q=bcrrd(i)/sqrt(.5*(scpx(i,j)*scpx(i,j) @@ -1756,7 +1744,7 @@ subroutine difest_lateral_iso(m,n,mm,nn,k1m,k1n) difwgt(i,j)=1./(1.+.25*q**4) enddo enddo - elseif (edwmth.eq.'step') then + elseif (edwmth_opt.eq.edwmth_step) then do l=1,isp(j) do i=max(1,ifp(j,l)),min(ii,ilp(j,l)) q=bcrrd(i)/sqrt(.5*(scpx(i,j)*scpx(i,j) @@ -1768,13 +1756,6 @@ subroutine difest_lateral_iso(m,n,mm,nn,k1m,k1n) endif enddo enddo - else - if (mnproc.eq.1) then - write (lp,'(3a)') ' edwmth=',trim(edwmth), - . ' is unsupported!' - endif - call xcstop('(difest)') - stop '(difest)' endif c c --- ------------------------------------------------------------------ @@ -1815,7 +1796,7 @@ subroutine difest_lateral_iso(m,n,mm,nn,k1m,k1n) enddo enddo endif - if (edritp.eq.'shear') then + if (edritp_opt.eq.edritp_shear) then do k=2,kk do l=1,isp(j) do i=max(1,ifp(j,l)),min(ii,ilp(j,l)) @@ -1832,7 +1813,7 @@ subroutine difest_lateral_iso(m,n,mm,nn,k1m,k1n) enddo enddo enddo - elseif (edritp.eq.'large scale') then + elseif (edritp_opt.eq.edritp_large_scale) then do l=1,isp(j) do i=max(1,ifp(j,l)),min(ii,ilp(j,l)) if (kmax(i,j)-kfil(i,j).ge.1) then @@ -1894,13 +1875,6 @@ subroutine difest_lateral_iso(m,n,mm,nn,k1m,k1n) enddo enddo enddo - else - if (mnproc.eq.1) then - write (lp,'(3a)') ' edritp=',trim(edritp), - . ' is unsupported!' - endif - call xcstop('(difest)') - stop '(difest)' endif if (edsprs) then do l=1,isp(j) diff --git a/phy/mod_diffusion.F90 b/phy/mod_diffusion.F90 index c0e923e1..638a5f6d 100644 --- a/phy/mod_diffusion.F90 +++ b/phy/mod_diffusion.F90 @@ -23,6 +23,7 @@ module mod_diffusion ! ------------------------------------------------------------------------------ use mod_types, only: r8 + use mod_config, only: inst_suffix use mod_constants, only: spval, epsil use mod_xc @@ -65,11 +66,35 @@ module mod_diffusion ! methods: 'intdif', 'gm'. edritp, & ! Type of Richardson number used in eddy diffusivity ! computation. Valid types: 'shear', 'large scale'. - edwmth ! Method to estimate eddy diffusivity weight as a function of + edwmth, & ! Method to estimate eddy diffusivity weight as a function of ! the ration of Rossby radius of deformation to the horizontal ! grid spacing. Valid methods: 'smooth', 'step'. - logical :: & - ntrdif = .false. + ltedtp ! Type of lateral tracer eddy diffusion: Valid methods: 'layer', + ! 'neutral'. + + ! Options derived from string options. + integer :: & + eitmth_opt, & + edritp_opt, & + edwmth_opt, & + ltedtp_opt + + ! Parameters: + integer, parameter :: & + ! Eddy-induced transport parameterization methods: + eitmth_intdif = 1, & ! Interface diffusion. + eitmth_gm = 2, & ! Gent-McWilliams. + ! Type of Richardson number used in eddy diffusivity computation: + edritp_shear = 1, & ! Using local vertical velocity shear. + edritp_large_scale = 2, & ! Using large scale variables. + ! Method to estimate eddy diffusivity weight: + edwmth_smooth = 1, & ! Smooth function of Rossby radius over grid + ! spacing. + edwmth_step = 2, & ! Step function of Rossby radius over grid + ! spacing. + ! Lateral tracer eddy diffusion type: + ltedtp_layer = 1, & ! Diffusion along model layers. + ltedtp_neutral = 2 ! Diffusion along neutral sublayers. real(r8), dimension(1 - nbdy:idm + nbdy,1 - nbdy:jdm + nbdy, kdm) :: & difint, & ! Layer interface diffusivity [cm2 s-1]. @@ -90,7 +115,6 @@ module mod_diffusion difmxq, & ! Maximum lateral diffusivity at q-points [cm2 s-1]. difwgt ! Eddy diffusivity weight []. - real(r8), dimension(1 - nbdy:idm + nbdy,1 - nbdy:jdm + nbdy, 2*kdm) :: & umfltd, & ! u-component of horizontal mass flux due to thickness diffusion ! [g cm s-2]. @@ -114,15 +138,151 @@ module mod_diffusion ! [g2 cm kg-1 s-2]. public :: egc, eggam, eglsmn, egmndf, egmxdf, egidfq, ri0, bdmc1, bdmc2, & - tkepf, bdmtyp, edsprs, eitmth, edritp, edwmth, ntrdif, & + tkepf, bdmtyp, edsprs, eitmth_opt, eitmth_intdif, eitmth_gm, & + edritp_opt, edritp_shear, edritp_large_scale, & + edwmth_opt, edwmth_smooth, edwmth_step, & + ltedtp_opt, ltedtp_layer, ltedtp_neutral, & difint, difiso, difdia, difmxp, difmxq, difwgt, & umfltd, vmfltd, utfltd, vtfltd, utflld, vtflld, & usfltd, vsfltd, usflld, vsflld, & Kvisc_m, Kdiff_t, Kdiff_s, t_ns_nonloc, s_nonloc, & - inivar_diffusion + readnml_diffusion, inivar_diffusion contains + subroutine readnml_diffusion + ! --------------------------------------------------------------------------- + ! Read variables in the namelist group 'diffusion' and resolve options. + ! --------------------------------------------------------------------------- + + character(len = 80) :: nml_fname + integer :: ios + logical :: fexist + + namelist /diffusion/ & + egc, eggam, eglsmn, egmndf, egmxdf, egidfq, ri0, bdmc1, bdmc2, tkepf, & + bdmtyp, edsprs, eitmth, edritp, edwmth, ltedtp + + ! Read variables in the namelist group 'diffusion'. + if (mnproc == 1) then + nml_fname = 'ocn_in'//trim(inst_suffix) + inquire(file = nml_fname, exist = fexist) + if (fexist) then + open (unit = 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 (unit = nfu, file = nml_fname, status = 'old', & + action = 'read') + else + write (lp,*) 'readnml_diffusion: could not find namelist file!' + call xchalt('(readnml_diffusion)') + stop '(readnml_diffusion)' + endif + endif + read (unit = nfu, nml = diffusion, iostat = ios) + close (unit = nfu) + endif + call xcbcst(ios) + if (ios /= 0) then + if (mnproc == 1) & + write (lp,*) 'readnml_diffusion: No diffusion variable '// & + 'group found in namelist. Using defaults.' + else + call xcbcst(egc) + call xcbcst(eggam) + call xcbcst(eglsmn) + call xcbcst(egmndf) + call xcbcst(egmxdf) + call xcbcst(egidfq) + call xcbcst(ri0) + call xcbcst(bdmc1) + call xcbcst(bdmc2) + call xcbcst(tkepf) + call xcbcst(bdmtyp) + call xcbcst(edsprs) + call xcbcst(eitmth) + call xcbcst(edritp) + call xcbcst(edwmth) + call xcbcst(ltedtp) + endif + if (mnproc == 1) then + write (lp,*) 'readnml_diffusion: diffusion variables:' + write (lp,*) ' egc = ', egc + write (lp,*) ' eggam = ', eggam + write (lp,*) ' eglsmn = ', eglsmn + write (lp,*) ' egmndf = ', egmndf + write (lp,*) ' egmxdf = ', egmxdf + write (lp,*) ' egidfq = ', egidfq + write (lp,*) ' ri0 = ', ri0 + write (lp,*) ' bdmc1 = ', bdmc1 + write (lp,*) ' bdmc2 = ', bdmc2 + write (lp,*) ' tkepf = ', tkepf + write (lp,*) ' bdmtyp = ', bdmtyp + write (lp,*) ' edsprs = ', edsprs + write (lp,*) ' eitmth = ', trim(eitmth) + write (lp,*) ' edritp = ', trim(edritp) + write (lp,*) ' edwmth = ', trim(edwmth) + write (lp,*) ' ltedtp = ', trim(ltedtp) + endif + + ! Resolve options. + select case (trim(eitmth)) + case ('intdif') + eitmth_opt = eitmth_intdif + case ('gm') + eitmth_opt = eitmth_gm + case default + if (mnproc == 1) & + write (lp,'(3a)') & + ' readnml_diffusion: eitmth = ', trim(eitmth), & + ' is unsupported!' + call xcstop('(readnml_diffusion)') + stop '(readnml_diffusion)' + end select + select case (trim(edritp)) + case ('shear') + edritp_opt = edritp_shear + case ('large scale') + edritp_opt = edritp_large_scale + case default + if (mnproc == 1) & + write (lp,'(3a)') & + ' readnml_diffusion: edritp = ', trim(edritp), & + ' is unsupported!' + call xcstop('(readnml_diffusion)') + stop '(readnml_diffusion)' + end select + select case (trim(edwmth)) + case ('smooth') + edwmth_opt = edwmth_smooth + case ('step') + edwmth_opt = edwmth_step + case default + if (mnproc == 1) & + write (lp,'(3a)') & + ' readnml_diffusion: edwmth = ', trim(edwmth), & + ' is unsupported!' + call xcstop('(readnml_diffusion)') + stop '(readnml_diffusion)' + end select + select case (trim(ltedtp)) + case ('layer') + ltedtp_opt = ltedtp_layer + case ('neutral') + ltedtp_opt = ltedtp_neutral + case default + if (mnproc == 1) & + write (lp,'(3a)') & + ' readnml_diffusion: ltedtp = ', trim(ltedtp), & + ' is unsupported!' + call xcstop('(readnml_diffusion)') + stop '(readnml_diffusion)' + end select + + end subroutine readnml_diffusion + subroutine inivar_diffusion ! --------------------------------------------------------------------------- ! Initialize arrays. diff --git a/phy/mod_eddtra.F90 b/phy/mod_eddtra.F90 index 8d2ee510..87df3bda 100644 --- a/phy/mod_eddtra.F90 +++ b/phy/mod_eddtra.F90 @@ -31,8 +31,9 @@ module mod_eddtra use mod_grid, only: scuy, scvx, scp2, scu2, scv2, scuxi, scvyi use mod_eos, only: rho use mod_state, only: dp, dpu, dpv, temp, saln, p, pbu, pbv, kfpla - use mod_diffusion, only: eitmth, difint, umfltd, vmfltd, & - utfltd, vtfltd, usfltd, vsfltd + use mod_diffusion, only: eitmth_opt, eitmth_intdif, eitmth_gm, & + difint, umfltd, vmfltd, utfltd, vtfltd, & + usfltd, vsfltd use mod_cmnfld, only: nslpx, nslpy, mlts use mod_checksum, only: csdiag, chksummsk @@ -1406,24 +1407,26 @@ subroutine eddtra(m, n, mm, nn, k1m, k1n) ! Compute eddy-induced transport of mass. if (vcoord_type_tag == isopyc_bulkml) then - if (eitmth == 'intdif') then + if (eitmth_opt == eitmth_intdif) then call eddtra_intdif_isopyc_bulkml(m, n, mm, nn, k1m, k1n) - elseif (eitmth == 'gm') then + elseif (eitmth_opt == eitmth_gm) then call eddtra_gm_isopyc_bulkml(m, n, mm, nn, k1m, k1n) else if (mnproc == 1) then - write(lp,'(4a)') ' eitmth=', trim(eitmth), ' is unsupported ', & + write(lp,'(a,i1,2a)') & + ' eitmth_opt = ', eitmth_opt, ' is unsupported ', & 'for vcoord_type = ''isopyc_bulkml''!' endif call xcstop('(eddtra)') stop '(eddtra)' endif else - if (eitmth == 'gm') then + if (eitmth_opt == eitmth_gm) then call eddtra_gm_cntiso_hybrid(m, n, mm, nn, k1m, k1n) else if (mnproc == 1) then - write(lp,'(3a)') ' eitmth=', trim(eitmth), ' is unsupported!', & + write(lp,'(a,i1,2a)') & + ' eitmth_opt = ', eitmth_opt, ' is unsupported ', & 'for vcoord_type = ''cntiso_hybrid''!' endif call xcstop('(eddtra)') diff --git a/phy/mod_vcoord.F90 b/phy/mod_vcoord.F90 index 8356cfca..63a92a4c 100644 --- a/phy/mod_vcoord.F90 +++ b/phy/mod_vcoord.F90 @@ -38,7 +38,7 @@ module mod_vcoord extract_polycoeff, regrid2, & prepare_remapping, remap, & hor3map_noerr, hor3map_errstr - use mod_diffusion, only : ntrdif, difiso + use mod_diffusion, only : ltedtp_opt, ltedtp_neutral, difiso use mod_ndiff, only: ndiff_prep_jslice, ndiff_uflx_jslice, & ndiff_vflx_jslice, ndiff_update_trc_jslice use mod_checksum, only: csdiag, chksummsk @@ -922,7 +922,7 @@ subroutine inivar_vcoord ! Configuration of the reconstruction data structure that only depends on ! the source grid. rcgs%n_src = kk - if (ntrdif) then + if (ltedtp_opt == ltedtp_neutral) then rcgs%i_lbound = 0 rcgs%i_ubound = ii + 1 else @@ -1015,7 +1015,7 @@ subroutine cntiso_hybrid_regrid_direct_remap(m, n, mm, nn, k1m, k1n) real(r8), dimension(kdm,ntr_loc,1-nbdy:idm+nbdy) :: trc_rm integer :: j_rs, jm_rs, jp_rs, j, nt - if (.not.ntrdif) then + if (ltedtp_opt /= ltedtp_neutral) then j_rs = 1 @@ -1111,7 +1111,7 @@ subroutine cntiso_hybrid_regrid_remap(m, n, mm, nn, k1m, k1n) real(r8), dimension(kdm,ntr_loc,1-nbdy:idm+nbdy) :: trc_rm integer :: j_rs, jm_rs, jp_rs, j, nt - if (.not.ntrdif) then + if (ltedtp_opt /= ltedtp_neutral) then j_rs = 1 diff --git a/phy/rdlim.F b/phy/rdlim.F index 888c31b1..e45667f0 100644 --- a/phy/rdlim.F +++ b/phy/rdlim.F @@ -46,9 +46,7 @@ subroutine rdlim . trxday, srxday, trxdpt, srxdpt, trxlim, . srxlim, srxbal, sprfac use mod_swabs, only: swamth, jwtype, chlopt, ccfile - use mod_diffusion, only: egc, eggam, eglsmn, egmndf, egmxdf, - . egidfq, ri0, bdmc1, bdmc2, tkepf, bdmtyp, - . edsprs, eitmth, edritp, edwmth + use mod_diffusion, only: readnml_diffusion use mod_mxlayr, only: rm0, rm5, ce, mlrttp use mod_niw, only: niwgf, niwbf, niwlf use mod_tidaldissip, only: tdfile @@ -72,9 +70,9 @@ subroutine rdlim . grfile,icfile,pref,baclin,batrop, . mdv2hi,mdv2lo,mdv4hi,mdv4lo,mdc2hi,mdc2lo, . vsc2hi,vsc2lo,vsc4hi,vsc4lo,cbar,cb,cwbdts,cwbdls, - . mommth,eitmth,edritp,bmcmth,rmpmth,edwmth,mlrttp, - . edsprs,egc,eggam,eglsmn,egmndf,egmxdf,egidfq,ri0, - . rm0,rm5,ce,bdmtyp,bdmc1,bdmc2,tdfile,tkepf,niwgf,niwbf,niwlf, + . mommth,bmcmth,rmpmth,mlrttp, + . + . rm0,rm5,ce,tdfile,niwgf,niwbf,niwlf, . swamth,jwtype,chlopt,ccfile, . trxday,srxday,trxdpt,srxdpt,trxlim,srxlim, . aptflx,apsflx,ditflx,disflx,srxbal,scfile,smtfrc,sprfac, @@ -135,27 +133,12 @@ subroutine rdlim write (lp,*) 'CWBDTS',CWBDTS write (lp,*) 'CWBDLS',CWBDLS write (lp,*) 'MOMMTH ',trim(MOMMTH) - write (lp,*) 'EITMTH ',trim(EITMTH) - write (lp,*) 'EDRITP ',trim(EDRITP) write (lp,*) 'BMCMTH ',trim(BMCMTH) write (lp,*) 'RMPMTH ',trim(RMPMTH) - write (lp,*) 'EDWMTH ',trim(EDWMTH) - write (lp,*) 'EDSPRS ',EDSPRS - write (lp,*) 'EGC',EGC - write (lp,*) 'EGGAM',EGGAM - write (lp,*) 'EGLSMN',EGLSMN - write (lp,*) 'EGMNDF',EGMNDF - write (lp,*) 'EGMXDF',EGMXDF - write (lp,*) 'EGIDFQ',EGIDFQ - write (lp,*) 'RI0',RI0 write (lp,*) 'RM0',RM0 write (lp,*) 'RM5',RM5 write (lp,*) 'CE',CE - write (lp,*) 'BDMTYP',BDMTYP - write (lp,*) 'BDMC1',BDMC1 - write (lp,*) 'BDMC2',BDMC2 write (lp,*) 'TDFILE',trim(TDFILE) - write (lp,*) 'TKEPF',TKEPF write (lp,*) 'NIWGF',NIWGF write (lp,*) 'NIWBF',NIWBF write (lp,*) 'NIWLF',NIWLF @@ -217,28 +200,13 @@ subroutine rdlim call xcbcst(cwbdts) call xcbcst(cwbdls) call xcbcst(mommth) - call xcbcst(eitmth) - call xcbcst(edritp) call xcbcst(bmcmth) call xcbcst(rmpmth) - call xcbcst(edwmth) call xcbcst(mlrttp) - call xcbcst(edsprs) - call xcbcst(egc) - call xcbcst(eggam) - call xcbcst(eglsmn) - call xcbcst(egmndf) - call xcbcst(egmxdf) - call xcbcst(egidfq) - call xcbcst(ri0) call xcbcst(rm0) call xcbcst(rm5) call xcbcst(ce) - call xcbcst(bdmtyp) - call xcbcst(bdmc1) - call xcbcst(bdmc2) call xcbcst(tdfile) - call xcbcst(tkepf) call xcbcst(niwgf) call xcbcst(niwbf) call xcbcst(niwlf) @@ -271,6 +239,9 @@ subroutine rdlim c --- read vertical coordinate namelist variables call readnml_vcoord c +c --- read diffusion namelist variables + call readnml_diffusion +c c --- read diaphy namelist c if (mnproc.eq.1) then diff --git a/tests/fuk95/limits b/tests/fuk95/limits index 3942bbad..fdcb58e3 100644 --- a/tests/fuk95/limits +++ b/tests/fuk95/limits @@ -34,48 +34,21 @@ ! 'enscon' (Sadourny (1975) enstrophy conserving), 'enecon' ! (Sadourny (1975) energy conserving), 'enedis' (Sadourny ! (1975) energy conserving with some dissipation) (a) -! EITMTH : Eddy-induced transport parameterization method. Valid -! methods: 'intdif', 'gm' (a) -! EDRITP : Type of Richardson number used in eddy diffusivity -! computation. Valid types: 'shear', 'large scale' (a) ! BMCMTH : Baroclinic mass flux correction method. Valid methods: ! 'uc' (upstream column), 'dluc' (depth limited upstream ! column) (a) ! RMPMTH : Method of applying eddy-induced transport in the remap ! transport algorithm. Valid methods: 'eitvel', 'eitflx' (a) -! EDWMTH : Method to estimate eddy diffusivity weight as a function of -! the ration of Rossby radius of deformation to the -! horizontal grid spacing. Valid methods: 'smooth', 'step' (a) ! MLRTTP : Type of mixed layer restratification time scale. Valid ! types: 'variable', 'constant', 'limited' (a) -! EDSPRS : Apply eddy mixing suppression away from steering level (l) -! EGC : Parameter c in Eden and Greatbatch (2008) parameterization (f) -! EGGAM : Parameter gamma in E. & G. (2008) param. (f) -! EGLSMN : Minimum eddy length scale in E. & G. (2008) param. (cm) (f) -! EGMNDF : Minimum diffusivity in E. & G. (2008) param. (cm**2/s) (f) -! EGMXDF : Maximum diffusivity in E. & G. (2008) param. (cm**2/s) (f) -! EGIDFQ : Factor relating the isopycnal diffusivity to the layer -! interface diffusivity in the Eden and Greatbatch (2008) -! parameterization. egidfq=difint/difiso () (f) -! RI0 : Critical gradient richardson number for shear driven -! vertical mixing () (f) ! RM0 : Efficiency factor of wind TKE generation in the Oberhuber ! (1993) TKE closure () (f) ! RM5 : Efficiency factor of TKE generation by momentum ! entrainment in the Oberhuber (1993) TKE closure () (f) ! CE : Efficiency factor for the restratification by mixed layer ! eddies (Fox-Kemper et al., 2008) () (f) -! BDMTYP : Type of background diapycnal mixing. If bdmtyp=1 the -! background diffusivity is a constant divided by the -! Brunt-Vaisala frequency, if bdmtyp=2 the background -! diffusivity is constant () (i) -! BDMC1 : Background diapycnal diffusivity times buoyancy frequency -! frequency (cm**2/s**2) (f) -! BDMC2 : Background diapycnal diffusivity (cm**2/s) (f) ! TDFILE : Name of file containing tidal wave energy dissipation ! divided by by bottom buoyancy frequency (a) -! TKEPF : Fraction of surface TKE that penetrates beneath mixed layer -! () (f) ! NIWGF : Global factor applied to the energy input by near-intertial ! motions () (f) ! NIWBF : Fraction of near-inertial energy dissipated in the boundary @@ -139,28 +112,13 @@ CWBDTS = 0. CWBDLS = 25. MOMMTH = 'enscon' - EITMTH = 'gm' - EDRITP = 'large scale' BMCMTH = 'uc' RMPMTH = 'eitvel' - EDWMTH = 'smooth' MLRTTP = 'constant' - EDSPRS = .true. - EGC = 0. - EGGAM = 200. - EGLSMN = 4000.e2 - EGMNDF = 0. - EGMXDF = 1500.e4 - EGIDFQ = 1. - RI0 = 1.2 RM0 = 1.2 RM5 = 0. CE = 0. - BDMTYP = 2 - BDMC1 = 5.e-4 - BDMC2 = .15 TDFILE = 'unset' - TKEPF = 0. NIWGF = 0. NIWBF = .35 NIWLF = .5 @@ -191,6 +149,60 @@ IOTYPE = 0 / +! NAMELIST FOR DIFFUSION PARAMETERS +! +! CONTENTS: +! +! EITMTH : Eddy-induced transport parameterization method. Valid +! methods: 'intdif', 'gm' (a) +! EDRITP : Type of Richardson number used in eddy diffusivity +! computation. Valid types: 'shear', 'large scale' (a) +! EDWMTH : Method to estimate eddy diffusivity weight as a function of +! the ration of Rossby radius of deformation to the +! horizontal grid spacing. Valid methods: 'smooth', 'step' (a) +! MLRTTP : Type of mixed layer restratification time scale. Valid +! types: 'variable', 'constant', 'limited' (a) +! EDSPRS : Apply eddy mixing suppression away from steering level (l) +! EGC : Parameter c in Eden and Greatbatch (2008) parameterization (f) +! EGGAM : Parameter gamma in E. & G. (2008) param. (f) +! EGLSMN : Minimum eddy length scale in E. & G. (2008) param. (cm) (f) +! EGMNDF : Minimum diffusivity in E. & G. (2008) param. (cm**2/s) (f) +! EGMXDF : Maximum diffusivity in E. & G. (2008) param. (cm**2/s) (f) +! EGIDFQ : Factor relating the isopycnal diffusivity to the layer +! interface diffusivity in the Eden and Greatbatch (2008) +! parameterization. egidfq=difint/difiso () (f) +! RI0 : Critical gradient richardson number for shear driven +! vertical mixing () (f) +! BDMTYP : Type of background diapycnal mixing. If bdmtyp=1 the +! background diffusivity is a constant divided by the +! Brunt-Vaisala frequency, if bdmtyp=2 the background +! diffusivity is constant () (i) +! BDMC1 : Background diapycnal diffusivity times buoyancy frequency +! frequency (cm**2/s**2) (f) +! BDMC2 : Background diapycnal diffusivity (cm**2/s) (f) +! TKEPF : Fraction of surface TKE that penetrates beneath mixed layer +! () (f) +! LTEDTP : Type of lateral tracer eddy diffusion: Valid methods: +! 'layer', 'neutral'. +&DIFFUSION + EITMTH = 'gm' + EDRITP = 'large scale' + EDWMTH = 'smooth' + EDSPRS = .true. + EGC = 0. + EGGAM = 200. + EGLSMN = 4000.e2 + EGMNDF = 0. + EGMXDF = 1500.e4 + EGIDFQ = 1. + RI0 = 1.2 + BDMTYP = 2 + BDMC1 = 5.e-4 + BDMC2 = .15 + TKEPF = 0. + LTEDTP = 'layer' +/ + ! NAMELIST FOR CHANNEL WIDTH MODIFICATIONS ! ! CONTENTS: From dd5fd2c0a834d9cc6c797821bfae47534cd1bd08 Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Mon, 30 May 2022 18:16:18 +0200 Subject: [PATCH 105/366] fixing indexing issue for ptho in extNcycle --- hamocc/mo_extNbioproc.F90 | 24 ++++++++++++------------ hamocc/ocprod.F90 | 8 ++++---- 2 files changed, 16 insertions(+), 16 deletions(-) diff --git a/hamocc/mo_extNbioproc.F90 b/hamocc/mo_extNbioproc.F90 index fa6a4387..73ab24be 100644 --- a/hamocc/mo_extNbioproc.F90 +++ b/hamocc/mo_extNbioproc.F90 @@ -153,14 +153,14 @@ subroutine extNbioparam_init() end subroutine extNbioparam_init !================================================================================================================================== - subroutine nitrification(kpie,kpje,kpke,pddpo,omask,ptho) + subroutine nitrification(kpie,kpje,kpke,kbnd,pddpo,omask,ptho) ! Nitrification processes (NH4 -> NO2, NO2 -> NO3) accompanied ! by dark carbon fixation and O2-dependent N2O production - integer, intent(in) :: kpie,kpje,kpke + integer, intent(in) :: kpie,kpje,kpke,kbnd real, intent(in) :: omask(kpie,kpje) real, intent(in) :: pddpo(kpie,kpje,kpke) - real, intent(in) :: ptho(kpie,kpje,kpke) + real, intent(in) :: ptho(1-kbnd:kpie+kbnd,1-kbnd:kpje+kbnd,kpke) !local variables integer :: i,j,k,proc_ctr @@ -276,13 +276,13 @@ subroutine nitrification(kpie,kpje,kpke,pddpo,omask,ptho) end subroutine nitrification !================================================================================================================================== - subroutine denit_NO3_to_NO2(kpie,kpje,kpke,pddpo,omask,ptho) + subroutine denit_NO3_to_NO2(kpie,kpje,kpke,kbnd,pddpo,omask,ptho) ! Denitrification / dissimilatory nitrate reduction (NO3 -> NO2) - integer, intent(in) :: kpie,kpje,kpke + integer, intent(in) :: kpie,kpje,kpke,kbnd real, intent(in) :: omask(kpie,kpje) real, intent(in) :: pddpo(kpie,kpje,kpke) - real, intent(in) :: ptho(kpie,kpje,kpke) + real, intent(in) :: ptho(1-kbnd:kpie+kbnd,1-kbnd:kpje+kbnd,kpke) !local variables integer :: i,j,k @@ -326,13 +326,13 @@ subroutine denit_NO3_to_NO2(kpie,kpje,kpke,pddpo,omask,ptho) end subroutine denit_NO3_to_NO2 !================================================================================================================================== - subroutine anammox(kpie,kpje,kpke,pddpo,omask,ptho) + subroutine anammox(kpie,kpje,kpke,kbnd,pddpo,omask,ptho) ! Aanammox - integer, intent(in) :: kpie,kpje,kpke + integer, intent(in) :: kpie,kpje,kpke,kbnd real, intent(in) :: omask(kpie,kpje) real, intent(in) :: pddpo(kpie,kpje,kpke) - real, intent(in) :: ptho(kpie,kpje,kpke) + real, intent(in) :: ptho(1-kbnd:kpie+kbnd,1-kbnd:kpje+kbnd,kpke) !local variables integer :: i,j,k @@ -380,13 +380,13 @@ subroutine anammox(kpie,kpje,kpke,pddpo,omask,ptho) end subroutine anammox !================================================================================================================================== - subroutine denit_dnra(kpie,kpje,kpke,pddpo,omask,ptho) + subroutine denit_dnra(kpie,kpje,kpke,kbnd,pddpo,omask,ptho) ! Denitrification processes (NO2 -> N2O -> N2) and dissmilatory nitrite reduction (NO2 -> NH4) - integer, intent(in) :: kpie,kpje,kpke + integer, intent(in) :: kpie,kpje,kpke,kbnd real, intent(in) :: omask(kpie,kpje) real, intent(in) :: pddpo(kpie,kpje,kpke) - real, intent(in) :: ptho(kpie,kpje,kpke) + real, intent(in) :: ptho(1-kbnd:kpie+kbnd,1-kbnd:kpje+kbnd,kpke) !local variables integer :: i,j,k,n2oden,dnra_use diff --git a/hamocc/ocprod.F90 b/hamocc/ocprod.F90 index 5f31120d..ea1daaf6 100644 --- a/hamocc/ocprod.F90 +++ b/hamocc/ocprod.F90 @@ -879,19 +879,19 @@ subroutine ocprod(kpie,kpje,kpke,kbnd,pdlxp,pdlyp,pddpo,omask,dust,ptho) #else !======>>>> extended nitrogen cycle processes (aerobic and anaerobic) that follow ammonification inv_message = 'in OCPROD after extNcycle nitrification' - CALL nitrification(kpie,kpje,kpke,pddpo,omask,ptho) + CALL nitrification(kpie,kpje,kpke,kbnd,pddpo,omask,ptho) CALL extN_inv_check(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask,inv_message) inv_message = 'in OCPROD after extNcycle denitrification NO3 -> NO2' - CALL denit_NO3_to_NO2(kpie,kpje,kpke,pddpo,omask,ptho) + CALL denit_NO3_to_NO2(kpie,kpje,kpke,kbnd,pddpo,omask,ptho) CALL extN_inv_check(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask,inv_message) inv_message = 'in OCPROD after extNcycle anammox' - CALL anammox(kpie,kpje,kpke,pddpo,omask,ptho) + CALL anammox(kpie,kpje,kpke,kbnd,pddpo,omask,ptho) CALL extN_inv_check(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask,inv_message) inv_message = 'in OCPROD after extNcycle denitrification / DNRA' - CALL denit_dnra(kpie,kpje,kpke,pddpo,omask,ptho) + CALL denit_dnra(kpie,kpje,kpke,kbnd,pddpo,omask,ptho) CALL extN_inv_check(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask,inv_message) ! inv_message = 'in OCPROD after extNcycle denitrification NO2 ' From 0fdaa5a18dd93166c003cfdb5f8623c0e851661c Mon Sep 17 00:00:00 2001 From: Mats Bentsen Date: Tue, 31 May 2022 22:45:52 +0200 Subject: [PATCH 106/366] Corrected inconsistencies related to tracer array allocation after merge with 'upstream/master'. --- phy/blom_init.F | 7 +++++++ phy/inivar.F90 | 6 +++--- phy/mod_ndiff.F90 | 49 ++++++++++++++++++++++++++++++++++------------ phy/mod_vcoord.F90 | 35 +++++++++++++++++++++------------ 4 files changed, 68 insertions(+), 29 deletions(-) diff --git a/phy/blom_init.F b/phy/blom_init.F index 0c186891..629c02d2 100644 --- a/phy/blom_init.F +++ b/phy/blom_init.F @@ -36,6 +36,7 @@ subroutine blom_init use mod_niw, only: uml, vml, umlres, vmlres use mod_eos, only: inieos use mod_swabs, only: iniswa + use mod_ndiff, only: ndiff_init use mod_tmsmt, only: initms use mod_dia use mod_inicon, only: inicon @@ -141,6 +142,12 @@ subroutine blom_init c #endif c --- ------------------------------------------------------------------ +c --- Initialize neutral diffusion +c --- ------------------------------------------------------------------ +c + call ndiff_init +c +c --- ------------------------------------------------------------------ c --- Initialize diagnostic accumulation fields c --- ------------------------------------------------------------------ c diff --git a/phy/inivar.F90 b/phy/inivar.F90 index 780095bf..cebbcb8f 100644 --- a/phy/inivar.F90 +++ b/phy/inivar.F90 @@ -48,6 +48,9 @@ subroutine inivar ! --------------------------------------------------------------------------- ! Call initialization routines for various modules. ! --------------------------------------------------------------------------- +#ifdef TRC + call inivar_tracers +#endif call inivar_vcoord call inivar_state call inivar_pgforc @@ -63,8 +66,5 @@ subroutine inivar call inivar_cmnfld call inivar_niw call inivar_tidaldissip -#ifdef TRC - call inivar_tracers -#endif end subroutine inivar diff --git a/phy/mod_ndiff.F90 b/phy/mod_ndiff.F90 index 2a27bcab..5f875313 100644 --- a/phy/mod_ndiff.F90 +++ b/phy/mod_ndiff.F90 @@ -47,24 +47,19 @@ module mod_ndiff integer, parameter :: & p_ord = 4, & it = 1, & - is = 2, & -#ifdef TRC - ntr_loc = ntr + 2 ! Local number of tracers where temperature - ! and salinity is added to the ntr parameter. -#else - ntr_loc = 2 ! Local number of tracers consisting of - ! temperature and salinity. -#endif + is = 2 + + integer :: ntr_loc - real(r8), dimension(p_ord+1,kdm,ntr_loc,1-nbdy:idm+nbdy,2), target :: & - tpc_src_rs + real(r8), allocatable, dimension(:,:,:,:,:), target :: & + tpc_src_rs, t_srcdi_rs + real(r8), allocatable, dimension(:,:,:,:) :: flxconv_rs real(r8), dimension(2,kdm,1-nbdy:idm+nbdy,2), target :: & p_srcdi_rs, drhodt_srcdi_rs, drhods_srcdi_rs - real(r8), dimension(2,kdm,ntr_loc,1-nbdy:idm+nbdy,2), target :: t_srcdi_rs - real(r8), dimension(kdm,ntr_loc,1-nbdy:idm+nbdy,2) :: flxconv_rs integer, dimension(1-nbdy:idm+nbdy,2) :: ksmx_rs, kdmx_rs - public :: ndiff_prep_jslice, ndiff_uflx_jslice, ndiff_vflx_jslice, & + public :: ndiff_init, ndiff_prep_jslice, & + ndiff_uflx_jslice, ndiff_vflx_jslice, & ndiff_update_trc_jslice contains @@ -879,6 +874,7 @@ subroutine ndiff_flx(p_srcdi_m, t_srcdi_m, tpc_src_m, & enddo endif +#ifdef TRC 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) & @@ -892,6 +888,7 @@ subroutine ndiff_flx(p_srcdi_m, t_srcdi_m, tpc_src_m, & flxconv_rs(kd_p,nt,i_p,j_rs_p) - tflx endif enddo +#endif endif @@ -938,6 +935,32 @@ end subroutine ndiff_flx ! Public procedures. ! --------------------------------------------------------------------------- + subroutine ndiff_init + + integer :: errstat + +#ifdef TRC + ! 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 +#endif + + ! Allocate arrays depending on the tracer count. + allocate(tpc_src_rs(p_ord+1,kdm,ntr_loc,1-nbdy:idm+nbdy,2), & + t_srcdi_rs(2,kdm,ntr_loc,1-nbdy:idm+nbdy,2), & + flxconv_rs(kdm,ntr_loc,1-nbdy:idm+nbdy,2), & + stat = errstat) + if (errstat /= 0) then + write(lp,*) 'Failed to allocate neutral diffusion arrays!' + call xchalt('(ndiff_init)') + stop '(ndiff_init)' + endif + + end subroutine ndiff_init + subroutine ndiff_prep_jslice(p_src_rs, p_dst_rs, trc_rcss, & i_lb, i_ub, j, j_rs, mm) diff --git a/phy/mod_vcoord.F90 b/phy/mod_vcoord.F90 index 63a92a4c..849380b9 100644 --- a/phy/mod_vcoord.F90 +++ b/phy/mod_vcoord.F90 @@ -82,16 +82,10 @@ module mod_vcoord integer, parameter :: & isopyc_bulkml = 1, & ! Vertical coordinate type: bulk surface mixed ! layer with isopycnic layers below. - cntiso_hybrid = 2, & ! Vertical coordinate type: Hybrid coordinate + cntiso_hybrid = 2 ! Vertical coordinate type: Hybrid coordinate ! with pressure coordinates towards the ! surface and continuous isopycnal below. -#ifdef TRC - ntr_loc = ntr + 2 ! Local number of tracers where temperature - ! and salinity is added to the ntr parameter. -#else - ntr_loc = 2 ! Local number of tracers consisting of - ! temperature and salinity. -#endif + real(r8), parameter :: & bfsq_min = 1.e-7_r8, & ! Minimum buoyancy frequency squared in ! monotonized potential density to be used in @@ -99,9 +93,11 @@ module mod_vcoord regrid_mval = - 1.e33_r8 ! Missing value for regridding. + integer :: ntr_loc + type(recon_grd_struct) :: rcgs type(recon_src_struct) :: d_rcss, v_rcss - type(recon_src_struct) , dimension(ntr_loc) :: trc_rcss + type(recon_src_struct), allocatable, dimension(:) :: trc_rcss type(remap_struct) :: rms real(r8), dimension(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy,kdm) :: & @@ -919,6 +915,23 @@ subroutine inivar_vcoord enddo !$omp end parallel do +#ifdef TRC + ! 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 +#endif + + ! 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 @@ -942,21 +955,17 @@ subroutine inivar_vcoord 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 -#ifdef TRC 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 -#endif else -#ifdef TRC 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 endif v_rcss%limiting = velocity_limiting_tag From 005ae41d9862a9d1d2d2809c3483c4617742d236 Mon Sep 17 00:00:00 2001 From: Mats Bentsen Date: Wed, 1 Jun 2022 18:05:48 +0200 Subject: [PATCH 107/366] Updated the functionality to configure the vertical coordinate of BLOM in NorESM. --- bld/MNP2/kdm | 1 - bld/fuk95/kdm | 1 - bld/gx1v5/{kdm => kdm.isopyc_bulkml} | 0 bld/{channel/kdm => gx1v6/kdm.isopyc_bulkml} | 0 bld/gx3v7/{kdm => kdm.isopyc_bulkml} | 0 bld/single_column/kdm | 1 - .../kdm => tnx0.125v4/kdm.isopyc_bulkml} | 0 .../kdm => tnx0.25v1/kdm.isopyc_bulkml} | 0 .../kdm => tnx0.25v3/kdm.isopyc_bulkml} | 0 .../kdm => tnx0.25v4/kdm.isopyc_bulkml} | 0 .../kdm => tnx1.5v1/kdm.isopyc_bulkml} | 0 .../kdm => tnx1v1/kdm.isopyc_bulkml} | 0 bld/{tnx1v1/kdm => tnx1v3/kdm.isopyc_bulkml} | 0 bld/tnx1v4/kdm.cntiso_hybrid | 1 + bld/{tnx1v3/kdm => tnx1v4/kdm.isopyc_bulkml} | 0 bld/tnx2v1/kdm | 1 - bld/{tnx1v4/kdm => tnx2v1/kdm.isopyc_bulkml} | 0 cime_config/buildcpp | 12 +- cime_config/buildlib_2.1 | 4 +- cime_config/buildlib_2.2 | 4 +- cime_config/buildnml | 161 +++++++++++------- cime_config/config_component.xml | 9 + 22 files changed, 117 insertions(+), 78 deletions(-) delete mode 100644 bld/MNP2/kdm delete mode 100644 bld/fuk95/kdm rename bld/gx1v5/{kdm => kdm.isopyc_bulkml} (100%) rename bld/{channel/kdm => gx1v6/kdm.isopyc_bulkml} (100%) rename bld/gx3v7/{kdm => kdm.isopyc_bulkml} (100%) delete mode 100644 bld/single_column/kdm rename bld/{gx1v6/kdm => tnx0.125v4/kdm.isopyc_bulkml} (100%) rename bld/{tnx0.125v4/kdm => tnx0.25v1/kdm.isopyc_bulkml} (100%) rename bld/{tnx0.25v1/kdm => tnx0.25v3/kdm.isopyc_bulkml} (100%) rename bld/{tnx0.25v3/kdm => tnx0.25v4/kdm.isopyc_bulkml} (100%) rename bld/{tnx0.25v4/kdm => tnx1.5v1/kdm.isopyc_bulkml} (100%) rename bld/{tnx1.5v1/kdm => tnx1v1/kdm.isopyc_bulkml} (100%) rename bld/{tnx1v1/kdm => tnx1v3/kdm.isopyc_bulkml} (100%) create mode 100644 bld/tnx1v4/kdm.cntiso_hybrid rename bld/{tnx1v3/kdm => tnx1v4/kdm.isopyc_bulkml} (100%) delete mode 100644 bld/tnx2v1/kdm rename bld/{tnx1v4/kdm => tnx2v1/kdm.isopyc_bulkml} (100%) diff --git a/bld/MNP2/kdm b/bld/MNP2/kdm deleted file mode 100644 index 2bbd69c2..00000000 --- a/bld/MNP2/kdm +++ /dev/null @@ -1 +0,0 @@ -70 diff --git a/bld/fuk95/kdm b/bld/fuk95/kdm deleted file mode 100644 index 7273c0fa..00000000 --- a/bld/fuk95/kdm +++ /dev/null @@ -1 +0,0 @@ -25 diff --git a/bld/gx1v5/kdm b/bld/gx1v5/kdm.isopyc_bulkml similarity index 100% rename from bld/gx1v5/kdm rename to bld/gx1v5/kdm.isopyc_bulkml diff --git a/bld/channel/kdm b/bld/gx1v6/kdm.isopyc_bulkml similarity index 100% rename from bld/channel/kdm rename to bld/gx1v6/kdm.isopyc_bulkml diff --git a/bld/gx3v7/kdm b/bld/gx3v7/kdm.isopyc_bulkml similarity index 100% rename from bld/gx3v7/kdm rename to bld/gx3v7/kdm.isopyc_bulkml diff --git a/bld/single_column/kdm b/bld/single_column/kdm deleted file mode 100644 index 2bbd69c2..00000000 --- a/bld/single_column/kdm +++ /dev/null @@ -1 +0,0 @@ -70 diff --git a/bld/gx1v6/kdm b/bld/tnx0.125v4/kdm.isopyc_bulkml similarity index 100% rename from bld/gx1v6/kdm rename to bld/tnx0.125v4/kdm.isopyc_bulkml diff --git a/bld/tnx0.125v4/kdm b/bld/tnx0.25v1/kdm.isopyc_bulkml similarity index 100% rename from bld/tnx0.125v4/kdm rename to bld/tnx0.25v1/kdm.isopyc_bulkml diff --git a/bld/tnx0.25v1/kdm b/bld/tnx0.25v3/kdm.isopyc_bulkml similarity index 100% rename from bld/tnx0.25v1/kdm rename to bld/tnx0.25v3/kdm.isopyc_bulkml diff --git a/bld/tnx0.25v3/kdm b/bld/tnx0.25v4/kdm.isopyc_bulkml similarity index 100% rename from bld/tnx0.25v3/kdm rename to bld/tnx0.25v4/kdm.isopyc_bulkml diff --git a/bld/tnx0.25v4/kdm b/bld/tnx1.5v1/kdm.isopyc_bulkml similarity index 100% rename from bld/tnx0.25v4/kdm rename to bld/tnx1.5v1/kdm.isopyc_bulkml diff --git a/bld/tnx1.5v1/kdm b/bld/tnx1v1/kdm.isopyc_bulkml similarity index 100% rename from bld/tnx1.5v1/kdm rename to bld/tnx1v1/kdm.isopyc_bulkml diff --git a/bld/tnx1v1/kdm b/bld/tnx1v3/kdm.isopyc_bulkml similarity index 100% rename from bld/tnx1v1/kdm rename to bld/tnx1v3/kdm.isopyc_bulkml diff --git a/bld/tnx1v4/kdm.cntiso_hybrid b/bld/tnx1v4/kdm.cntiso_hybrid new file mode 100644 index 00000000..f6b91e0e --- /dev/null +++ b/bld/tnx1v4/kdm.cntiso_hybrid @@ -0,0 +1 @@ +56 diff --git a/bld/tnx1v3/kdm b/bld/tnx1v4/kdm.isopyc_bulkml similarity index 100% rename from bld/tnx1v3/kdm rename to bld/tnx1v4/kdm.isopyc_bulkml diff --git a/bld/tnx2v1/kdm b/bld/tnx2v1/kdm deleted file mode 100644 index 59343b09..00000000 --- a/bld/tnx2v1/kdm +++ /dev/null @@ -1 +0,0 @@ -53 diff --git a/bld/tnx1v4/kdm b/bld/tnx2v1/kdm.isopyc_bulkml similarity index 100% rename from bld/tnx1v4/kdm rename to bld/tnx2v1/kdm.isopyc_bulkml diff --git a/cime_config/buildcpp b/cime_config/buildcpp index 116c2fe8..e237d1a4 100644 --- a/cime_config/buildcpp +++ b/cime_config/buildcpp @@ -35,11 +35,12 @@ def create_dimmod(case): comp_root_dir_ocn = case.get_value("COMP_ROOT_DIR_OCN") ocn_grid = case.get_value("OCN_GRID") + blom_vcoord = case.get_value("BLOM_VCOORD") ntasks_ocn = case.get_value("NTASKS_OCN") objroot = case.get_value("OBJROOT") gridconf_dir = os.path.join(comp_root_dir_ocn, "bld", ocn_grid) - kdm_file = os.path.join(gridconf_dir, "kdm") + kdm_file = os.path.join(gridconf_dir, "kdm." + blom_vcoord) blom_dimensions_script = os.path.join(comp_root_dir_ocn, "bld", "blom_dimensions") try: @@ -77,6 +78,7 @@ def buildcpp(case): # Determine the CPP flags values needed to build the blom component ocn_grid = case.get_value("OCN_GRID") + blom_vcoord = case.get_value("BLOM_VCOORD") turbclo = case.get_value("BLOM_TURBULENT_CLOSURE") tracers = case.get_value("BLOM_TRACER_MODULES") co2type = case.get_value("OCN_CO2_TYPE") @@ -86,6 +88,8 @@ def buildcpp(case): hamocc_ciso = case.get_value("HAMOCC_CISO") hamocc_vsls = case.get_value("HAMOCC_VSLS") + expect(blom_vcoord != "cntiso_hybrid" or not turbclo, "BLOM_VCOORD == {} and BLOM_TURBULENT_CLOSURE == {} is not a valid combination".format(blom_vcoord, turbclo)) + blom_cppdefs = "" if ocn_grid in ["tnx2v1", "tnx1.5v1", "tnx1v1", "tnx1v3", "tnx1v4", "tnx0.25v1", "tnx0.25v3", "tnx0.25v4", "tnx0.125v4"]: @@ -94,10 +98,10 @@ def buildcpp(case): if ocn_grid in ["gx1v5", "gx1v6", "tnx1v1", "tnx1v3", "tnx1v4", "tnx0.25v1", "tnx0.25v3", "tnx0.25v4", "tnx0.125v4"]: blom_cppdefs = blom_cppdefs + " -DLEVITUS2X" - if turbclo != 0 or tracers != 0: + if turbclo or tracers: blom_cppdefs = blom_cppdefs + " -DTRC" - if turbclo != 0: + if turbclo: twoeq = False oneeq = False for option in turbclo.split(): @@ -116,7 +120,7 @@ def buildcpp(case): expect(twoeq or oneeq, "For turbulent closure either twoeq or oneeq must be provided as options") expect(not twoeq or not oneeq, "Do not use both twoeq and oneeq as options for turbulent closure") - if tracers != 0: + if tracers: for module in tracers.split(): if module == "iage": blom_cppdefs = blom_cppdefs + " -DIDLAGE" diff --git a/cime_config/buildlib_2.1 b/cime_config/buildlib_2.1 index 7d3c9ea9..99f5315d 100755 --- a/cime_config/buildlib_2.1 +++ b/cime_config/buildlib_2.1 @@ -64,6 +64,7 @@ def _main_func(): os.path.join(comp_root_dir_ocn, "fuk95"), 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, "phy")] if turbclo != 0 and tracers != 0: @@ -78,8 +79,7 @@ def _main_func(): else: expect(False, "tracer module {} is not recognized".format(module)) - if driver == "nuopc": - expect(False, "NUOPC driver not supported") + expect(driver != "nuopc", "NUOPC driver not supported") if driver == "mct": paths.append(os.path.join(comp_root_dir_ocn, "drivers", "cpl_share")) paths.append(os.path.join(comp_root_dir_ocn, "drivers", "cpl_mct")) diff --git a/cime_config/buildlib_2.2 b/cime_config/buildlib_2.2 index 558d965e..956c3116 100755 --- a/cime_config/buildlib_2.2 +++ b/cime_config/buildlib_2.2 @@ -65,6 +65,7 @@ def _main_func(): os.path.join(comp_root_dir_ocn, "fuk95"), 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, "phy")] if turbclo != 0 and tracers != 0: @@ -79,8 +80,7 @@ def _main_func(): else: expect(False, "tracer module {} is not recognized".format(module)) - if driver == "nuopc": - expect(False, "NUOPC driver not supported") + expect(driver != "nuopc", "NUOPC driver not supported") if driver == "mct": paths.append(os.path.join(comp_root_dir_ocn, "drivers", "cpl_share")) paths.append(os.path.join(comp_root_dir_ocn, "drivers", "cpl_mct")) diff --git a/cime_config/buildnml b/cime_config/buildnml index 0152630c..0154e8a1 100755 --- a/cime_config/buildnml +++ b/cime_config/buildnml @@ -6,6 +6,7 @@ set CASEROOT = `./xmlquery CASEROOT --value` set OCN_GRID = `./xmlquery OCN_GRID --value` +set BLOM_VCOORD = `./xmlquery BLOM_VCOORD --value` set DIN_LOC_ROOT = `./xmlquery DIN_LOC_ROOT --value` set RUN_TYPE = `./xmlquery RUN_TYPE --value` set CONTINUE_RUN = `./xmlquery CONTINUE_RUN --value` @@ -91,28 +92,13 @@ set CB = .002 set CWBDTS = 5.e-5 set CWBDLS = 25. set MOMMTH = "'enscon'" -set EITMTH = "'gm'" -set EDRITP = "'large scale'" set BMCMTH = "'uc'" set RMPMTH = "'eitvel'" -set EDWMTH = "'smooth'" set MLRTTP = "'constant'" -set EDSPRS = .true. -set EGC = 0.85 -set EGGAM = 200. -set EGLSMN = 4000.e2 -set EGMNDF = 100.e4 -set EGMXDF = 1500.e4 -set EGIDFQ = 1. -set RI0 = 1.2 set RM0 = 1.2 set RM5 = 0. set CE = .06 -set BDMTYP = 2 -set BDMC1 = 5.e-4 -set BDMC2 = .1 set TDFILE = "'unset'" -set TKEPF = .006 set NIWGF = 0. set NIWBF = .35 set NIWLF = .5 @@ -150,11 +136,12 @@ else set IOTYPE = 0 endif -set VCOORD_TYPE = "'isopyc_bulkml'" +# set VCOORD defaults +set VCOORD_TYPE = "'$BLOM_VCOORD'" set RECONSTRUCTION_METHOD = "'ppm'" set DENSITY_LIMITING = "'monotonic'" -set TRACER_LIMITING = "'monotonic'" -set VELOCITY_LIMITING = "'monotonic'" +set TRACER_LIMITING = "'non_oscillatory'" +set VELOCITY_LIMITING = "'non_oscillatory'" set DENSITY_PC_UPPER_BNDR = .false. set DENSITY_PC_LOWER_BNDR = .false. set TRACER_PC_UPPER_BNDR = .true. @@ -162,9 +149,31 @@ set TRACER_PC_LOWER_BNDR = .false. set VELOCITY_PC_UPPER_BNDR = .true. set VELOCITY_PC_LOWER_BNDR = .false. set DPMIN_SURFACE = 2.5 -set DPMIN_INFLATION_FACTOR = 1.05 +set DPMIN_INFLATION_FACTOR = 1.08 set DPMIN_INTERIOR = .1 +# set DIFFUSION defaults +set EITMTH = "'gm'" +set EDRITP = "'large scale'" +set EDWMTH = "'smooth'" +set EDSPRS = .true. +set EGC = 0.85 +set EGGAM = 200. +set EGLSMN = 4000.e2 +set EGMNDF = 100.e4 +set EGMXDF = 1500.e4 +set EGIDFQ = 1. +set RI0 = 1.2 +set BDMTYP = 2 +set BDMC1 = 5.e-4 +set BDMC2 = .1 +set TKEPF = .006 +if ($BLOM_VCOORD == isopyc_bulkml) then + set LTEDTP = "'layer'" +else + set LTEDTP = "'neutral'" +endif + # set BGCNML defaults set ATM_CO2 = $CCSM_CO2_PPMV if ($BLOM_RIVER_NUTRIENTS == TRUE) then @@ -319,11 +328,11 @@ set LYR_UVEL = '0, 4, 0' set LYR_VFLX = '0, 4, 0' set LYR_VTFLX = '0, 4, 0' set LYR_VSFLX = '0, 4, 0' -set LYR_VMFLTD = '0, 4, 0' -set LYR_VTFLTD = '0, 4, 0' -set LYR_VTFLLD = '0, 4, 0' -set LYR_VSFLTD = '0, 4, 0' -set LYR_VSFLLD = '0, 4, 0' +set LYR_VMFLTD = '0, 0, 4' +set LYR_VTFLTD = '0, 0, 4' +set LYR_VTFLLD = '0, 0, 4' +set LYR_VSFLTD = '0, 0, 4' +set LYR_VSFLLD = '0, 0, 4' set LYR_VVEL = '0, 4, 0' set LYR_WFLX = '0, 4, 0' set LYR_WFLX2 = '0, 4, 0' @@ -831,48 +840,21 @@ cat >! $RUNDIR/ocn_in$inststr << EOF ! 'enscon' (Sadourny (1975) enstrophy conserving), 'enecon' ! (Sadourny (1975) energy conserving), 'enedis' (Sadourny ! (1975) energy conserving with some dissipation) (a) -! EITMTH : Eddy-induced transport parameterization method. Valid -! methods: 'intdif', 'gm' (a) -! EDRITP : Type of Richardson number used in eddy diffusivity -! computation. Valid types: 'shear', 'large scale' (a) ! BMCMTH : Baroclinic mass flux correction method. Valid methods: ! 'uc' (upstream column), 'dluc' (depth limited upstream ! column) (a) ! RMPMTH : Method of applying eddy-induced transport in the remap ! transport algorithm. Valid methods: 'eitvel', 'eitflx' (a) -! EDWMTH : Method to estimate eddy diffusivity weight as a function of -! the ration of Rossby radius of deformation to the -! horizontal grid spacing. Valid methods: 'smooth', 'step' (a) ! MLRTTP : Type of mixed layer restratification time scale. Valid ! types: 'variable', 'constant', 'limited' (a) -! EDSPRS : Apply eddy mixing suppression away from steering level (l) -! EGC : Parameter c in Eden and Greatbatch (2008) parameterization (f) -! EGGAM : Parameter gamma in E. & G. (2008) param. (f) -! EGLSMN : Minimum eddy length scale in E. & G. (2008) param. (cm) (f) -! EGMNDF : Minimum diffusivity in E. & G. (2008) param. (cm**2/s) (f) -! EGMXDF : Maximum diffusivity in E. & G. (2008) param. (cm**2/s) (f) -! EGIDFQ : Factor relating the isopycnal diffusivity to the layer -! interface diffusivity in the Eden and Greatbatch (2008) -! parameterization. egidfq=difint/difiso () (f) -! RI0 : Critical gradient richardson number for shear driven -! vertical mixing () (f) ! RM0 : Efficiency factor of wind TKE generation in the Oberhuber ! (1993) TKE closure () (f) ! RM5 : Efficiency factor of TKE generation by momentum ! entrainment in the Oberhuber (1993) TKE closure () (f) ! CE : Efficiency factor for the restratification by mixed layer ! eddies (Fox-Kemper et al., 2008) () (f) -! BDMTYP : Type of background diapycnal mixing. If bdmtyp=1 the -! background diffusivity is a constant divided by the -! Brunt-Vaisala frequency, if bdmtyp=2 the background -! diffusivity is constant () (i) -! BDMC1 : Background diapycnal diffusivity times buoyancy frequency -! frequency (cm**2/s**2) (f) -! BDMC2 : Background diapycnal diffusivity (cm**2/s) (f) ! TDFILE : Name of file containing tidal wave energy dissipation ! divided by by bottom buoyancy frequency (a) -! TKEPF : Fraction of surface TKE that penetrates beneath mixed layer -! () (f) ! NIWGF : Global factor applied to the energy input by near-intertial ! motions () (f) ! NIWBF : Fraction of near-inertial energy dissipated in the boundary @@ -936,28 +918,13 @@ cat >! $RUNDIR/ocn_in$inststr << EOF CWBDTS = $CWBDTS CWBDLS = $CWBDLS MOMMTH = $MOMMTH - EITMTH = $EITMTH - EDRITP = $EDRITP BMCMTH = $BMCMTH RMPMTH = $RMPMTH - EDWMTH = $EDWMTH MLRTTP = $MLRTTP - EDSPRS = $EDSPRS - EGC = $EGC - EGGAM = $EGGAM - EGLSMN = $EGLSMN - EGMNDF = $EGMNDF - EGMXDF = $EGMXDF - EGIDFQ = $EGIDFQ - RI0 = $RI0 RM0 = $RM0 RM5 = $RM5 CE = $CE - BDMTYP = $BDMTYP - BDMC1 = $BDMC1 - BDMC2 = $BDMC2 TDFILE = $TDFILE - TKEPF = $TKEPF NIWGF = $NIWGF NIWBF = $NIWBF NIWLF = $NIWLF @@ -987,6 +954,10 @@ cat >! $RUNDIR/ocn_in$inststr << EOF RSTCMP = $RSTCMP IOTYPE = $IOTYPE / +EOF + +if ($BLOM_VCOORD == cntiso_hybrid) then +cat >>! $RUNDIR/ocn_in$inststr << EOF &VCOORD VCOORD_TYPE = $VCOORD_TYPE @@ -1005,6 +976,64 @@ cat >! $RUNDIR/ocn_in$inststr << EOF DPMIN_INTERIOR = $DPMIN_INTERIOR / EOF +endif + +cat >>! $RUNDIR/ocn_in$inststr << EOF + +! NAMELIST FOR DIFFUSION PARAMETERS +! +! CONTENTS: +! +! EITMTH : Eddy-induced transport parameterization method. Valid +! methods: 'intdif', 'gm' (a) +! EDRITP : Type of Richardson number used in eddy diffusivity +! computation. Valid types: 'shear', 'large scale' (a) +! EDWMTH : Method to estimate eddy diffusivity weight as a function of +! the ration of Rossby radius of deformation to the +! horizontal grid spacing. Valid methods: 'smooth', 'step' (a) +! MLRTTP : Type of mixed layer restratification time scale. Valid +! types: 'variable', 'constant', 'limited' (a) +! EDSPRS : Apply eddy mixing suppression away from steering level (l) +! EGC : Parameter c in Eden and Greatbatch (2008) parameterization (f) +! EGGAM : Parameter gamma in E. & G. (2008) param. (f) +! EGLSMN : Minimum eddy length scale in E. & G. (2008) param. (cm) (f) +! EGMNDF : Minimum diffusivity in E. & G. (2008) param. (cm**2/s) (f) +! EGMXDF : Maximum diffusivity in E. & G. (2008) param. (cm**2/s) (f) +! EGIDFQ : Factor relating the isopycnal diffusivity to the layer +! interface diffusivity in the Eden and Greatbatch (2008) +! parameterization. egidfq=difint/difiso () (f) +! RI0 : Critical gradient richardson number for shear driven +! vertical mixing () (f) +! BDMTYP : Type of background diapycnal mixing. If bdmtyp=1 the +! background diffusivity is a constant divided by the +! Brunt-Vaisala frequency, if bdmtyp=2 the background +! diffusivity is constant () (i) +! BDMC1 : Background diapycnal diffusivity times buoyancy frequency +! frequency (cm**2/s**2) (f) +! BDMC2 : Background diapycnal diffusivity (cm**2/s) (f) +! TKEPF : Fraction of surface TKE that penetrates beneath mixed layer +! () (f) +! LTEDTP : Type of lateral tracer eddy diffusion: Valid methods: +! 'layer', 'neutral'. +&DIFFUSION + EITMTH = $EITMTH + EDRITP = $EDRITP + EDWMTH = $EDWMTH + EDSPRS = $EDSPRS + EGC = $EGC + EGGAM = $EGGAM + EGLSMN = $EGLSMN + EGMNDF = $EGMNDF + EGMXDF = $EGMXDF + EGIDFQ = $EGIDFQ + RI0 = $RI0 + BDMTYP = $BDMTYP + BDMC1 = $BDMC1 + BDMC2 = $BDMC2 + TKEPF = $TKEPF + LTEDTP = $LTEDTP +/ +EOF if ($?CWMTAG) then cat >>! $RUNDIR/ocn_in$inststr << EOF diff --git a/cime_config/config_component.xml b/cime_config/config_component.xml index 2c88e51e..b93336d6 100644 --- a/cime_config/config_component.xml +++ b/cime_config/config_component.xml @@ -31,6 +31,15 @@ The default is constant. + + char + isopyc_bulkml,cntiso_hybrid + isopyc_bulkml + build_component_blom + env_build.xml + Vertical coordinate type of BLOM + + char iage,iage ecosys From 80fa2592da746ee20a5937c2383da84e07b8caf8 Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Wed, 15 Jun 2022 12:32:36 +0200 Subject: [PATCH 108/366] fix missing & --- hamocc/mo_bgcmean.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/hamocc/mo_bgcmean.F90 b/hamocc/mo_bgcmean.F90 index fdde9858..cfdf2842 100644 --- a/hamocc/mo_bgcmean.F90 +++ b/hamocc/mo_bgcmean.F90 @@ -254,7 +254,7 @@ MODULE mo_bgcmean & jiralk =19, & & jiriron =20, & & jirdoc =21, & - & jirdet =22, + & jirdet =22, & & jnh3flux =23, & & nbgct2d =23 From dc15f70cbf3d6333b2745d02ad557e6623690d9e Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Wed, 22 Jun 2022 12:25:17 +0200 Subject: [PATCH 109/366] Rewind overhead for debugging and clean-up of extNcycle-related routines --- hamocc/mo_extNbioproc.F90 | 350 ++++++++------------------------------ hamocc/ocprod.F90 | 13 -- 2 files changed, 69 insertions(+), 294 deletions(-) diff --git a/hamocc/mo_extNbioproc.F90 b/hamocc/mo_extNbioproc.F90 index 73ab24be..a2605a12 100644 --- a/hamocc/mo_extNbioproc.F90 +++ b/hamocc/mo_extNbioproc.F90 @@ -62,7 +62,6 @@ MODULE mo_extNbioproc public :: extNbioparam_init,nitrification,denit_NO3_to_NO2,& & anammox,denit_dnra,extN_inv_check - public :: denit_NO2,denit_N2O, dnra ! public parameters public :: bkphyanh4,bkphyano3,bkphosph,bkiron @@ -147,8 +146,8 @@ subroutine extNbioparam_init() bkoxnitr = 0.788e-6 ! Half-saturation constant for oxygen limitation of nitrification on NO2 (kmol/m3) bkano2nitr = 0.287e-6 ! Half-saturation constant for NO2 for nitrification on NO2 (kmol/m3) - eps = 1.e-16 ! safe division etc. - minlim = 1.e-3 ! minimum for limitation functions (e.g. nutlim or oxlim/inh can only decrease to 1/1000) + eps = 1.e-25 ! safe division etc. + minlim = 1.e-9 ! minimum for limitation functions (e.g. nutlim or oxlim/inh can only decrease to minlim) !=========================================================================== end subroutine extNbioparam_init @@ -163,7 +162,7 @@ subroutine nitrification(kpie,kpje,kpke,kbnd,pddpo,omask,ptho) real, intent(in) :: ptho(1-kbnd:kpie+kbnd,1-kbnd:kpje+kbnd,kpke) !local variables - integer :: i,j,k,proc_ctr + integer :: i,j,k real :: Tdepanh4,O2limanh4,nut1lim,anh4new,potdnh4amox,fdetamox,fno2,fn2o,ftotnh4 real :: Tdepano2,O2limano2,nut2lim,ano2new,potdno2nitr,fdetnitr,fno3,ftotno2 real :: amoxfrac,nitrfrac,totd,amox,nitr,temp @@ -175,15 +174,22 @@ subroutine nitrification(kpie,kpje,kpke,kbnd,pddpo,omask,ptho) minlim_nh4 = bkanh4nitr*minlim/(1. - minlim) minlim_no2 = bkano2nitr*minlim/(1. - minlim) - !$OMP PARALLEL DO PRIVATE(i,k,Tdepanh4,O2limanh4,nut1lim,anh4new,potdnh4amox,fdetamox,fno2,fn2o,ftotnh4, & + !$OMP PARALLEL DO PRIVATE(i,k,Tdepanh4,O2limanh4,nut1lim,anh4new,potdnh4amox,fdetamox,fno2,fn2o,ftotnh4, & !$OMP Tdepano2,O2limano2,nut2lim,ano2new,potdno2nitr,fdetnitr,fno3,ftotno2,amoxfrac, & - !$OMP nitrfrac,totd,amox,nitr,proc_ctr,temp) + !$OMP nitrfrac,totd,amox,nitr,temp) do j = 1,kpje do i = 1,kpie do k = 1,kpke if(pddpo(i,j,k) > dp_min .and. omask(i,j) > 0.5) then - proc_ctr = 0 + potdnh4amox = 0. + fn2o = 0. + fno2 = 0. + fdetamox = 0. + potdno2nitr = 0. + fno3 = 0. + fdetnitr = 0. + if(ocetra(i,j,k,ioxygen)>minlim_oxnh4 .and. ocetra(i,j,k,ianh4)>minlim_nh4)then temp = merge(ptho(i,j,k),10.,ptho(i,j,k)<40.) ! Ammonium oxidation step of nitrification @@ -204,12 +210,6 @@ subroutine nitrification(kpie,kpje,kpke,kbnd,pddpo,omask,ptho) fn2o = fn2o/ftotnh4 fno2 = fno2/ftotnh4 fdetamox = 1. - (fn2o + fno2) - proc_ctr = proc_ctr + 1 - else - potdnh4amox = 0. - fn2o = 0. - fno2 = 0. - fdetamox = 0. endif if(ocetra(i,j,k,ioxygen)>minlim_oxno2 .and. ocetra(i,j,k,iano2)>minlim_no2)then @@ -229,44 +229,36 @@ subroutine nitrification(kpie,kpje,kpke,kbnd,pddpo,omask,ptho) ftotno2 = fno2 + fdetamox + eps fno3 = fno3/ftotno2 fdetnitr = 1. - fno3 - - proc_ctr = proc_ctr + 1 - else - potdno2nitr = 0. - fno3 = 0. - fdetnitr = 0. endif - if (proc_ctr>0)then - ! limitation of the two processes through available nutrients, etc. - totd = potdnh4amox + potdno2nitr - amoxfrac = potdnh4amox/(totd + eps) - nitrfrac = 1. - amoxfrac - totd = max(0., & - & min(totd, & - & ocetra(i,j,k,ianh4)/(amoxfrac + fdetamox*nitrfrac + eps), & ! ammonium - & ocetra(i,j,k,isco212)/((122./16.)*(fdetamox*amoxfrac + fdetnitr*nitrfrac) + eps), & ! CO2 - & ocetra(i,j,k,iphosph)/((fdetamox*amoxfrac + fdetnitr*nitrfrac)/16. + eps), & ! PO4 - & ocetra(i,j,k,iiron)/((fdetamox*amoxfrac + fdetnitr*nitrfrac)/(16.*riron) + eps), & ! Fe - & ocetra(i,j,k,ioxygen) & - & /((1.5*fno2 + fn2o - 140./16.*fdetamox)*amoxfrac + (0.5*fno3 + 140./16.*fdetnitr)*nitrfrac +eps), & ! O2 - & ocetra(i,j,k,ialkali) & - & /((2.*fno2 + fn2o + 15./16.*fdetamox)*amoxfrac + (15./16.*fdetnitr)*nitrfrac + eps))) ! alkalinity - amox = amoxfrac*totd - nitr = nitrfrac*totd - - ocetra(i,j,k,ianh4) = ocetra(i,j,k,ianh4) - amox - fdetnitr*nitr - ocetra(i,j,k,ian2o) = ocetra(i,j,k,ian2o) + 0.5*fn2o*amox - ocetra(i,j,k,iano2) = ocetra(i,j,k,iano2) + fno2*amox - nitr - ocetra(i,j,k,iano3) = ocetra(i,j,k,iano3) + nitr - ocetra(i,j,k,idet) = ocetra(i,j,k,idet) + fdetamox/16.*amox + fdetnitr/16.*nitr - ocetra(i,j,k,isco212) = ocetra(i,j,k,isco212) - 122./16.*fdetamox*amox - 122./16.*fdetnitr*nitr - ocetra(i,j,k,iphosph) = ocetra(i,j,k,iphosph) - fdetamox/16.*amox - fdetnitr/16.*nitr - ocetra(i,j,k,iiron) = ocetra(i,j,k,iiron) - riron/16.*fdetamox*amox - riron/16.*fdetnitr*nitr - ocetra(i,j,k,ioxygen) = ocetra(i,j,k,ioxygen) - (1.5*fno2 + fn2o - 140./16.*fdetamox)*amox & - & - (0.5*fno3 - 140./16.*fdetnitr)*nitr - ocetra(i,j,k,ialkali) = ocetra(i,j,k,ialkali) - (2.*fno2 + fn2o + 15./16.*fdetamox)*amox - 15./16.*fdetnitr*nitr - endif + ! limitation of the two processes through available nutrients, etc. + totd = potdnh4amox + potdno2nitr + amoxfrac = potdnh4amox/(totd + eps) + nitrfrac = 1. - amoxfrac + totd = max(0., & + & min(totd, & + & ocetra(i,j,k,ianh4)/(amoxfrac + fdetamox*nitrfrac + eps), & ! ammonium + & ocetra(i,j,k,isco212)/((122./16.)*(fdetamox*amoxfrac + fdetnitr*nitrfrac) + eps), & ! CO2 + & ocetra(i,j,k,iphosph)/((fdetamox*amoxfrac + fdetnitr*nitrfrac)/16. + eps), & ! PO4 + & ocetra(i,j,k,iiron)/((fdetamox*amoxfrac + fdetnitr*nitrfrac)/(16.*riron) + eps), & ! Fe + & ocetra(i,j,k,ioxygen) & + & /((1.5*fno2 + fn2o - 140./16.*fdetamox)*amoxfrac + (0.5*fno3 + 140./16.*fdetnitr)*nitrfrac +eps), & ! O2 + & ocetra(i,j,k,ialkali) & + & /((2.*fno2 + fn2o + 15./16.*fdetamox)*amoxfrac + (15./16.*fdetnitr)*nitrfrac + eps))) ! alkalinity + amox = amoxfrac*totd + nitr = nitrfrac*totd + + ocetra(i,j,k,ianh4) = ocetra(i,j,k,ianh4) - amox - fdetnitr*nitr + ocetra(i,j,k,ian2o) = ocetra(i,j,k,ian2o) + 0.5*fn2o*amox + ocetra(i,j,k,iano2) = ocetra(i,j,k,iano2) + fno2*amox - nitr + ocetra(i,j,k,iano3) = ocetra(i,j,k,iano3) + nitr + ocetra(i,j,k,idet) = ocetra(i,j,k,idet) + fdetamox/16.*amox + fdetnitr/16.*nitr + ocetra(i,j,k,isco212) = ocetra(i,j,k,isco212) - 122./16.*fdetamox*amox - 122./16.*fdetnitr*nitr + ocetra(i,j,k,iphosph) = ocetra(i,j,k,iphosph) - fdetamox/16.*amox - fdetnitr/16.*nitr + ocetra(i,j,k,iiron) = ocetra(i,j,k,iiron) - riron/16.*fdetamox*amox - riron/16.*fdetnitr*nitr + ocetra(i,j,k,ioxygen) = ocetra(i,j,k,ioxygen) - (1.5*fno2 + fn2o - 140./16.*fdetamox)*amox & + & - (0.5*fno3 - 140./16.*fdetnitr)*nitr + ocetra(i,j,k,ialkali) = ocetra(i,j,k,ialkali) - (2.*fno2 + fn2o + 15./16.*fdetamox)*amox - 15./16.*fdetnitr*nitr endif enddo enddo @@ -389,13 +381,13 @@ subroutine denit_dnra(kpie,kpje,kpke,kbnd,pddpo,omask,ptho) real, intent(in) :: ptho(1-kbnd:kpie+kbnd,1-kbnd:kpje+kbnd,kpke) !local variables - integer :: i,j,k,n2oden,dnra_use + integer :: i,j,k real :: Tdepano2,O2inhibano2,nutlimano2,detlimano2,rpotano2denit,ano2denit real :: Tdepdnra,O2inhibdnra,nutlimdnra,detlimdnra,rpotano2dnra,ano2dnra real :: fdenit,fdnra,potano2new,potdano2,potddet,fdetano2denit,fdetan2odenit,fdetdnra real :: Tdepan2o,O2inhiban2o,nutliman2o,detliman2o,an2onew,an2odenit - real :: dano2,dan2o,dgasnit,danh4,ddet,dsco212,dphosph,diron,dalk,sc,temp + real :: temp real :: minlim_ox,minlim_oxn2o,minlim_no2,minlim_n2o @@ -405,26 +397,22 @@ subroutine denit_dnra(kpie,kpje,kpke,kbnd,pddpo,omask,ptho) minlim_no2 = min(bkdnra,bkano2denit)*minlim/(1. - minlim) minlim_n2o = bkan2odenit*minlim/(1. - minlim) - sc = 1.e8 ! scaling factor - - !$OMP PARALLEL DO PRIVATE(i,k,Tdepano2,O2inhibano2,nutlimano2,detlimano2,ano2denit, & + !$OMP PARALLEL DO PRIVATE(i,k,Tdepano2,O2inhibano2,nutlimano2,detlimano2,ano2denit, & !$OMP Tdepan2o,O2inhiban2o,nutliman2o,detliman2o,an2onew,an2odenit, & !$OMP rpotano2denit,rpotano2dnra, & !$OMP fdenit,fdnra,potano2new,potdano2,potddet,fdetano2denit, & !$OMP fdetan2odenit,fdetdnra, & - !$OMP Tdepdnra,O2inhibdnra,nutlimdnra,detlimdnra,ano2dnra,dnra_use,n2oden,& - !$OMP dano2,dan2o,dgasnit,danh4,ddet,dsco212,dphosph,diron,dalk,temp) + !$OMP Tdepdnra,O2inhibdnra,nutlimdnra,detlimdnra,ano2dnra,temp) do j = 1,kpje do i = 1,kpie do k = 1,kpke if(pddpo(i,j,k) > dp_min .and. omask(i,j) > 0.5) then - n2oden = 0 - dnra_use = 0 - potddet = 0. - fdetano2denit = 0. - fdetdnra = 0. + an2odenit = 0. + ano2denit = 0. + ano2dnra = 0. + if(0.<=ocetra(i,j,k,ioxygen) .and. ocetra(i,j,k,ioxygen)minlim_n2o)then temp = merge(ptho(i,j,k),10.,ptho(i,j,k)<40.) ! === denitrification on N2O @@ -433,8 +421,6 @@ subroutine denit_dnra(kpie,kpje,kpke,kbnd,pddpo,omask,ptho) nutliman2o = ocetra(i,j,k,ian2o)/(ocetra(i,j,k,ian2o) + bkan2odenit) an2onew = ocetra(i,j,k,ian2o)/(1. + ran2odenit*Tdepan2o*O2inhiban2o*nutliman2o) an2odenit = max(0.,min(ocetra(i,j,k,ian2o),ocetra(i,j,k,ian2o) - an2onew)) - potddet = 1./280.*an2odenit !P-units - n2oden = 1 endif if(0.<=ocetra(i,j,k,ioxygen) .and. ocetra(i,j,k,ioxygen)minlim_no2)then @@ -457,245 +443,47 @@ subroutine denit_dnra(kpie,kpje,kpke,kbnd,pddpo,omask,ptho) ! === limitation due to NO2: ! fraction on potential change of NO2: - rpotano2denit = rpotano2denit*sc ! to avoid potential numerical issues - rpotano2dnra = rpotano2dnra *sc fdenit = rpotano2denit/(rpotano2denit + rpotano2dnra + eps) fdnra = 1. - fdenit ! potential fractional change - ano2denit = fdenit * potdano2 / 280. ! P units - ano2dnra = fdnra * potdano2 / (93. + 1./3.) ! P units - potddet = potddet + ano2denit + ano2dnra ! P units - - ! limitation of processes due to detritus - fdetano2denit = ano2denit /(potddet + eps) - fdetdnra = ano2dnra /(potddet + eps) - dnra_use = 1 - + ano2denit = fdenit * potdano2 + ano2dnra = fdnra * potdano2 endif ! limitation of processes due to detritus + potddet = 1./280.*(ano2denit + an2odenit) + 1./(93. + 1./3.)*ano2dnra ! P units + fdetano2denit = 1./280.*ano2denit/(potddet + eps) + fdetan2odenit = 1./280.*an2odenit/(potddet + eps) + fdetdnra = 1. - fdetano2denit - fdetan2odenit potddet = max(0.,min(potddet,ocetra(i,j,k,idet))) - if((n2oden+dnra_use)>0 .and. potddet>0.)then - dano2 = 0. - dan2o = 0. - dgasnit = 0. - danh4 = 0. - ddet = 0. - dsco212 = 0. - dphosph = 0. - diron = 0. - dalk = 0. - - if (n2oden == 1) then ! change due to N2O denitrification - fdetan2odenit = 1. - fdetano2denit - fdetdnra - an2odenit = fdetan2odenit*280.*potddet - dan2o = -an2odenit - dgasnit = an2odenit - danh4 = 16./280.*an2odenit - ddet = -an2odenit/280. - dsco212 = 122./280.*an2odenit - dphosph = an2odenit/280. - diron = riron/280.*an2odenit - dalk = 15.*an2odenit/280. - endif - - if (dnra_use == 1)then - ! change of NO2 and N2O in N units - ano2denit = fdetano2denit*280.*potddet - ano2dnra = fdetdnra * (93. + 1./3.)*potddet - dano2 = -(ano2denit + ano2dnra) - dan2o = dan2o + 0.5*ano2denit - danh4 = danh4 + 16./280.*ano2denit + (109.+1./3.)/(93.+1./3.)*ano2dnra - ddet = ddet - ano2denit/280. - ano2dnra/(93.+1./3.) - dsco212 = dsco212 + 122./280.*ano2denit + 122./(93.+1./3.)*ano2dnra - dphosph = dphosph + ano2denit/280. + ano2dnra/(93.+1./3.) - diron = diron + riron/280.*ano2denit + riron/(93.+1./3.)*ano2dnra - dalk = dalk + 295.*ano2denit/280. + (201.+1./3.)/(93.+1./3.)*ano2dnra - endif - - - ! change in tracer concentrations due to denit (NO2->N2O->N2) and DNRA (NO2->NH4) - ocetra(i,j,k,iano2) = ocetra(i,j,k,iano2) + dano2 !- ano2denit - ano2dnra - ocetra(i,j,k,ian2o) = ocetra(i,j,k,ian2o) + dan2o !- an2odenit + 0.5*ano2denit - ocetra(i,j,k,igasnit) = ocetra(i,j,k,igasnit) + dgasnit ! an2odenit - ocetra(i,j,k,ianh4) = ocetra(i,j,k,ianh4) + danh4 ! 16./280. * (ano2denit+an2odenit) + (109.+1./3.)/(93.+1./3.)*ano2dnra - ocetra(i,j,k,idet) = ocetra(i,j,k,idet) + ddet !- (ano2denit + an2odenit)/280. - ano2dnra/(93.+1./3.) - ocetra(i,j,k,isco212) = ocetra(i,j,k,isco212) + dsco212 !122./280.*(ano2denit + an2odenit) + 122./(93.+1./3.) * ano2dnra - ocetra(i,j,k,iphosph) = ocetra(i,j,k,iphosph) + dphosph !(ano2denit + an2odenit)/280. + ano2dnra/(93.+1./3.) - ocetra(i,j,k,iiron) = ocetra(i,j,k,iiron) + diron ! riron/280.*(ano2denit + an2odenit) + riron/(93.+1./3.) * ano2dnra - ocetra(i,j,k,ialkali) = ocetra(i,j,k,ialkali) + dalk ! (295.*ano2denit + 15.*an2odenit)/280. & - ! & + (201.+1./3.)/(93.+1./3.) * ano2dnra - endif - endif - enddo - enddo - enddo - !$OMP END PARALLEL DO - end subroutine denit_dnra - -!##### FOR DEBUGGING PURPOSES ONLY ################# - subroutine dnra(kpie,kpje,kpke,pddpo,omask,ptho) - ! Denitrification processes (N2O -> N2) - - integer, intent(in) :: kpie,kpje,kpke - real, intent(in) :: omask(kpie,kpje) - real, intent(in) :: pddpo(kpie,kpje,kpke) - real, intent(in) :: ptho(kpie,kpje,kpke) - - !local variables - integer :: i,j,k - real :: Tdepdnra,O2inhibdnra,nutlimdnra,rpotano2dnra,potano2new,potdano2,ano2dnra,potddet - - - !$OMP PARALLEL DO PRIVATE(i,k,Tdepdnra,O2inhibdnra,nutlimdnra,rpotano2dnra,potano2new,potdano2,ano2dnra,potddet) - - do j = 1,kpje - do i = 1,kpie - do k = 1,kpke - if(pddpo(i,j,k) > dp_min .and. omask(i,j) > 0.5) then - if(ocetra(i,j,k,ioxygen) bkdnra*minlim)then - ! DNRA on NO2 - Tdepdnra = q10dnra**((ptho(i,j,k)-Trefdnra)/10.) - O2inhibdnra = 1. - ocetra(i,j,k,ioxygen)**2/(ocetra(i,j,k,ioxygen)**2 + bkoxdnra**2) - nutlimdnra = ocetra(i,j,k,iano2)/(ocetra(i,j,k,iano2) + bkdnra) - rpotano2dnra = max(0.,rdnra*Tdepdnra*O2inhibdnra*nutlimdnra) ! pot. rate of dnra - - ! potential new conc of NO2 due to denitrification and DNRA - potano2new = ocetra(i,j,k,iano2)/(1. + rpotano2dnra) - potdano2 = max(0.,min(ocetra(i,j,k,iano2), ocetra(i,j,k,iano2) - potano2new)) - - ! potential fractional change - ano2dnra = potdano2 - ! limitation of processes due to detritus - potddet = 1./(93. + 1./3.)*ano2dnra ! P units - potddet = max(0.,min(potddet,ocetra(i,j,k,idet))) + if(potddet>0.)then ! change of NO2 and N2O in N units - ano2dnra = (93. + 1./3.)*potddet + ano2denit = fdetano2denit*280.*potddet + an2odenit = fdetan2odenit*280.*potddet + ano2dnra = fdetdnra * (93. + 1./3.)*potddet ! change in tracer concentrations due to denit (NO2->N2O->N2) and DNRA (NO2->NH4) - ocetra(i,j,k,iano2) = ocetra(i,j,k,iano2) - ano2dnra - ocetra(i,j,k,ianh4) = ocetra(i,j,k,ianh4) + (109.+1./3.)/(93.+1./3.)*ano2dnra - ocetra(i,j,k,idet) = ocetra(i,j,k,idet) - ano2dnra/(93.+1./3.) - ocetra(i,j,k,isco212) = ocetra(i,j,k,isco212) + 122./(93.+1./3.) * ano2dnra - ocetra(i,j,k,iphosph) = ocetra(i,j,k,iphosph) + ano2dnra/(93.+1./3.) - ocetra(i,j,k,iiron) = ocetra(i,j,k,iiron) + riron/(93.+1./3.) * ano2dnra - ocetra(i,j,k,ialkali) = ocetra(i,j,k,ialkali) + (201.+1./3.)/(93.+1./3.) * ano2dnra - endif - endif - enddo - enddo - enddo - !$OMP END PARALLEL DO - end subroutine dnra - - !---------------------------------------------------------------- - subroutine denit_N2O(kpie,kpje,kpke,pddpo,omask,ptho) - ! Denitrification processes (N2O -> N2) - - integer, intent(in) :: kpie,kpje,kpke - real, intent(in) :: omask(kpie,kpje) - real, intent(in) :: pddpo(kpie,kpje,kpke) - real, intent(in) :: ptho(kpie,kpje,kpke) - - !local variables - integer :: i,j,k - real :: Tdepan2o,O2inhiban2o,nutliman2o,an2onew,an2odenit,potddet - !$OMP PARALLEL DO PRIVATE(i,k,Tdepan2o,O2inhiban2o,nutliman2o,an2onew,an2odenit,potddet) - do j = 1,kpje - do i = 1,kpie - do k = 1,kpke - if(pddpo(i,j,k) > dp_min .and. omask(i,j) > 0.5) then - if(ocetra(i,j,k,ioxygen) bkan2odenit*minlim)then - ! === denitrification on N2O - Tdepan2o = q10an2odenit**((ptho(i,j,k)-Trefan2odenit)/10.) - O2inhiban2o = 1. - ocetra(i,j,k,ioxygen)**2/(ocetra(i,j,k,ioxygen)**2 + bkoxan2odenit**2) - nutliman2o = ocetra(i,j,k,ian2o)/(ocetra(i,j,k,ian2o) + bkan2odenit) - an2onew = ocetra(i,j,k,ian2o)/(1. + ran2odenit*Tdepan2o*O2inhiban2o*nutliman2o) - an2odenit = max(0.,min(ocetra(i,j,k,ian2o),ocetra(i,j,k,ian2o) - an2onew)) - - ! limitation of processes due to detritus - potddet = 1./280.*an2odenit !P units - potddet = max(0.,min(potddet,ocetra(i,j,k,idet))) - - ! change of N2O in N units - an2odenit = 280.*potddet - - ! change in tracer concentrations due to denit (NO2->N2O->N2) and DNRA (NO2->NH4) - ocetra(i,j,k,ian2o) = ocetra(i,j,k,ian2o) - an2odenit + ocetra(i,j,k,iano2) = ocetra(i,j,k,iano2) - ano2denit - ano2dnra + ocetra(i,j,k,ian2o) = ocetra(i,j,k,ian2o) - an2odenit + 0.5*ano2denit ocetra(i,j,k,igasnit) = ocetra(i,j,k,igasnit) + an2odenit - ocetra(i,j,k,ianh4) = ocetra(i,j,k,ianh4) + 16./280. *an2odenit - ocetra(i,j,k,idet) = ocetra(i,j,k,idet) - an2odenit/280. - ocetra(i,j,k,isco212) = ocetra(i,j,k,isco212) + 122./280.*an2odenit - ocetra(i,j,k,iphosph) = ocetra(i,j,k,iphosph) + an2odenit/280. - ocetra(i,j,k,iiron) = ocetra(i,j,k,iiron) + riron/280.*an2odenit - ocetra(i,j,k,ialkali) = ocetra(i,j,k,ialkali) + 15.*an2odenit/280. + ocetra(i,j,k,ianh4) = ocetra(i,j,k,ianh4) + 16./280. * (ano2denit+an2odenit) + (109.+1./3.)/(93.+1./3.)*ano2dnra + ocetra(i,j,k,idet) = ocetra(i,j,k,idet) - (ano2denit + an2odenit)/280. - ano2dnra/(93.+1./3.) + ocetra(i,j,k,isco212) = ocetra(i,j,k,isco212) + 122./280.*(ano2denit + an2odenit) + 122./(93.+1./3.) * ano2dnra + ocetra(i,j,k,iphosph) = ocetra(i,j,k,iphosph) + (ano2denit + an2odenit)/280. + ano2dnra/(93.+1./3.) + ocetra(i,j,k,iiron) = ocetra(i,j,k,iiron) + riron/280.*(ano2denit + an2odenit) + riron/(93.+1./3.) * ano2dnra + ocetra(i,j,k,ialkali) = ocetra(i,j,k,ialkali) + (295.*ano2denit + 15.*an2odenit)/280. & + & + (201.+1./3.)/(93.+1./3.) * ano2dnra endif endif enddo enddo enddo !$OMP END PARALLEL DO - end subroutine denit_N2O - - !---------------------------------------------------------------- - subroutine denit_NO2(kpie,kpje,kpke,pddpo,omask,ptho) - ! Denitrification processes (NO2 -> N2O) - - integer, intent(in) :: kpie,kpje,kpke - real, intent(in) :: omask(kpie,kpje) - real, intent(in) :: pddpo(kpie,kpje,kpke) - real, intent(in) :: ptho(kpie,kpje,kpke) - - !local variables - integer :: i,j,k - real :: Tdepano2,O2inhibano2,nutlimano2,detlimano2,rpotano2denit,ano2denit,potddet,potano2new,potdano2 - - !$OMP PARALLEL DO PRIVATE(i,k,Tdepano2,O2inhibano2,nutlimano2,detlimano2,rpotano2denit,ano2denit,potddet,potano2new, & - !$OMP potdano2) - - do j = 1,kpje - do i = 1,kpie - do k = 1,kpke - if(pddpo(i,j,k) > dp_min .and. omask(i,j) > 0.5) then - if(ocetra(i,j,k,ioxygen) bkano2denit*minlim)then - ! denitrification on NO2 - Tdepano2 = q10ano2denit**((ptho(i,j,k)-Trefano2denit)/10.) - O2inhibano2 = 1. - ocetra(i,j,k,ioxygen)**2/(ocetra(i,j,k,ioxygen)**2 + bkoxano2denit**2) - nutlimano2 = ocetra(i,j,k,iano2)/(ocetra(i,j,k,iano2) + bkano2denit) - rpotano2denit = max(0.,rano2denit*Tdepano2*O2inhibano2*nutlimano2) ! potential rate of denit - - ! potential new conc of NO2 due to denitrification and DNRA - potano2new = ocetra(i,j,k,iano2)/(1. + rpotano2denit) - potdano2 = max(0.,min(ocetra(i,j,k,iano2), ocetra(i,j,k,iano2) - potano2new)) - ano2denit = potdano2 - - ! limitation of processes due to detritus - potddet = 1./280.*ano2denit ! P units - potddet = max(0.,min(potddet,ocetra(i,j,k,idet))) - - ! change of NO2 in N units - ano2denit = 280.*potddet + end subroutine denit_dnra - ! change in tracer concentrations due to denit (NO2->N2O->N2) and DNRA (NO2->NH4) - ocetra(i,j,k,iano2) = ocetra(i,j,k,iano2) - ano2denit - ocetra(i,j,k,ian2o) = ocetra(i,j,k,ian2o) + 0.5*ano2denit - ocetra(i,j,k,ianh4) = ocetra(i,j,k,ianh4) + 16./280. * ano2denit - ocetra(i,j,k,idet) = ocetra(i,j,k,idet) - ano2denit/280. - ocetra(i,j,k,isco212) = ocetra(i,j,k,isco212) + 122./280.*ano2denit - ocetra(i,j,k,iphosph) = ocetra(i,j,k,iphosph) + ano2denit/280. - ocetra(i,j,k,iiron) = ocetra(i,j,k,iiron) + riron/280.*ano2denit - ocetra(i,j,k,ialkali) = ocetra(i,j,k,ialkali) + 295.*ano2denit/280. - endif - endif - enddo - enddo - enddo - !$OMP END PARALLEL DO - end subroutine denit_NO2 -!################################################### !================================================================================================================================== subroutine extN_inv_check(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask,inv_message) diff --git a/hamocc/ocprod.F90 b/hamocc/ocprod.F90 index 8371cb55..d83c9e97 100644 --- a/hamocc/ocprod.F90 +++ b/hamocc/ocprod.F90 @@ -122,7 +122,6 @@ subroutine ocprod(kpie,kpje,kpke,kbnd,pdlxp,pdlyp,pddpo,omask,ptho,pi_ph) #endif #ifdef extNcycle use mo_extNbioproc, only: nitrification,denit_NO3_to_NO2,anammox,denit_dnra,extN_inv_check - use mo_extNbioproc, only: denit_NO2,denit_N2O,dnra use mo_extNbioproc, only: bkphyanh4,bkphyano3,bkphosph,bkiron use mo_param1_bgc, only: ianh4 #endif @@ -878,18 +877,6 @@ subroutine ocprod(kpie,kpje,kpke,kbnd,pdlxp,pdlyp,pddpo,omask,ptho,pi_ph) inv_message = 'in OCPROD after extNcycle denitrification / DNRA' CALL denit_dnra(kpie,kpje,kpke,kbnd,pddpo,omask,ptho) CALL extN_inv_check(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask,inv_message) - -! inv_message = 'in OCPROD after extNcycle denitrification NO2 ' -! CALL denit_NO2(kpie,kpje,kpke,pddpo,omask,ptho) -! CALL extN_inv_check(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask,inv_message) - -! inv_message = 'in OCPROD after extNcycle denitrification DNRA ' -! CALL dnra(kpie,kpje,kpke,pddpo,omask,ptho) -! CALL extN_inv_check(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask,inv_message) - -! inv_message = 'in OCPROD after extNcycle denitrification N2O ' -! CALL denit_N2O(kpie,kpje,kpke,pddpo,omask,ptho) -! CALL extN_inv_check(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask,inv_message) #endif From 5aec8789a42b04a6e92c0d9dc210131e0b7ab8ad Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Thu, 23 Jun 2022 11:15:13 +0200 Subject: [PATCH 110/366] Fix time step-based inventory calculation --- hamocc/inventory_bgc.F90 | 9 +++++++-- 1 file changed, 7 insertions(+), 2 deletions(-) diff --git a/hamocc/inventory_bgc.F90 b/hamocc/inventory_bgc.F90 index 1b443bff..93908b95 100644 --- a/hamocc/inventory_bgc.F90 +++ b/hamocc/inventory_bgc.F90 @@ -366,6 +366,7 @@ SUBROUTINE INVENTORY_BGC(kpie,kpje,kpke,dlxp,dlyp,ddpo,omask,iogrp) & +zocetratot(izoo))*rcar+zocetratot(isco212)+zocetratot(icalc) & & +zpowtratot(ipowaic)+zsedlayto(isssc12)+zsedlayto(issso12)*rcar & & +zburial(isssc12)+zburial(issso12)*rcar & + & +zprorca*rcar+zprcaca & #if defined(BOXATM) & +zatmco2*ppm2con #else @@ -379,6 +380,7 @@ SUBROUTINE INVENTORY_BGC(kpie,kpje,kpke,dlxp,dlyp,ddpo,omask,iogrp) & +zsedlayto(issso12)*rnit+zburial(issso12)*rnit & & +zocetratot(ian2o)*2 & & - sndepflux & + & +zprorca*rnit & #ifdef extNcycle & +zocetratot(ianh4)+zocetratot(iano2)+snh3flux & #endif @@ -393,11 +395,13 @@ SUBROUTINE INVENTORY_BGC(kpie,kpje,kpke,dlxp,dlyp,ddpo,omask,iogrp) & zocetratot(idet)+zocetratot(idoc)+zocetratot(iphy) & & +zocetratot(izoo)+zocetratot(iphosph) & & +zpowtratot(ipowaph)+zsedlayto(issso12) & - & +zburial(issso12) + & +zburial(issso12) & + & +zprorca totalsil= & & zocetratot(isilica)+zocetratot(iopal) & - & +zpowtratot(ipowasi)+zsedlayto(issssil)+zburial(issssil) + & +zpowtratot(ipowasi)+zsedlayto(issssil)+zburial(issssil) & + & +zsilpro totaloxy= & & (zocetratot(idet)+zocetratot(idoc)+zocetratot(iphy) & @@ -409,6 +413,7 @@ SUBROUTINE INVENTORY_BGC(kpie,kpje,kpke,dlxp,dlyp,ddpo,omask,iogrp) & +zpowtratot(ipowno3)*1.5+zpowtratot(ipowaic) & & +zpowtratot(ipowaox)+zpowtratot(ipowaph)*2 & & - sndepflux*1.5 & + & +zprorca*(-24.)+zprcaca & #ifdef extNcycle & +zocetratot(iano2) & #endif From 4a95c9c8e3824a2c041bc20cb30a84bf395c7153 Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Thu, 23 Jun 2022 12:06:09 +0200 Subject: [PATCH 111/366] Fix alkalinity change for DNRA process --- hamocc/mo_extNbioproc.F90 | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/hamocc/mo_extNbioproc.F90 b/hamocc/mo_extNbioproc.F90 index a2605a12..9f4bcd65 100644 --- a/hamocc/mo_extNbioproc.F90 +++ b/hamocc/mo_extNbioproc.F90 @@ -52,7 +52,7 @@ MODULE mo_extNbioproc use mo_control_bgc, only: io_stdo_bgc,dtb use mo_param1_bgc, only: ialkali,ianh4,iano2,ian2o,iano3,idet,igasnit,iiron,ioxygen,iphosph,isco212 use mo_carbch, only: ocetra - use mo_biomod, only: riron + use mo_biomod, only: riron,rnit,rnoi,rcar implicit none @@ -74,7 +74,9 @@ MODULE mo_extNbioproc & Trefanh4nitr,bkoxamox,bkanh4nitr,bkamoxn2o,bkamoxno2,bkyamox, & & rano2nitr,q10ano2nitr,Trefano2nitr,bkoxnitr,bkano2nitr,n2omaxy, & & n2oybeta,bkphyanh4,bkphyano3,bkphosph,bkiron - + + real :: + real :: eps,minlim CONTAINS @@ -474,7 +476,7 @@ subroutine denit_dnra(kpie,kpje,kpke,kbnd,pddpo,omask,ptho) ocetra(i,j,k,iphosph) = ocetra(i,j,k,iphosph) + (ano2denit + an2odenit)/280. + ano2dnra/(93.+1./3.) ocetra(i,j,k,iiron) = ocetra(i,j,k,iiron) + riron/280.*(ano2denit + an2odenit) + riron/(93.+1./3.) * ano2dnra ocetra(i,j,k,ialkali) = ocetra(i,j,k,ialkali) + (295.*ano2denit + 15.*an2odenit)/280. & - & + (201.+1./3.)/(93.+1./3.) * ano2dnra + & + (201.+2./3.)/(93.+1./3.) * ano2dnra endif endif enddo From 2df5fb3cb78776190716104c4924f8191cc8f19c Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Thu, 23 Jun 2022 12:29:27 +0200 Subject: [PATCH 112/366] Revert "Fix alkalinity change for DNRA process" This reverts commit 4a95c9c8e3824a2c041bc20cb30a84bf395c7153. --- hamocc/mo_extNbioproc.F90 | 8 +++----- 1 file changed, 3 insertions(+), 5 deletions(-) diff --git a/hamocc/mo_extNbioproc.F90 b/hamocc/mo_extNbioproc.F90 index 9f4bcd65..a2605a12 100644 --- a/hamocc/mo_extNbioproc.F90 +++ b/hamocc/mo_extNbioproc.F90 @@ -52,7 +52,7 @@ MODULE mo_extNbioproc use mo_control_bgc, only: io_stdo_bgc,dtb use mo_param1_bgc, only: ialkali,ianh4,iano2,ian2o,iano3,idet,igasnit,iiron,ioxygen,iphosph,isco212 use mo_carbch, only: ocetra - use mo_biomod, only: riron,rnit,rnoi,rcar + use mo_biomod, only: riron implicit none @@ -74,9 +74,7 @@ MODULE mo_extNbioproc & Trefanh4nitr,bkoxamox,bkanh4nitr,bkamoxn2o,bkamoxno2,bkyamox, & & rano2nitr,q10ano2nitr,Trefano2nitr,bkoxnitr,bkano2nitr,n2omaxy, & & n2oybeta,bkphyanh4,bkphyano3,bkphosph,bkiron - - real :: - + real :: eps,minlim CONTAINS @@ -476,7 +474,7 @@ subroutine denit_dnra(kpie,kpje,kpke,kbnd,pddpo,omask,ptho) ocetra(i,j,k,iphosph) = ocetra(i,j,k,iphosph) + (ano2denit + an2odenit)/280. + ano2dnra/(93.+1./3.) ocetra(i,j,k,iiron) = ocetra(i,j,k,iiron) + riron/280.*(ano2denit + an2odenit) + riron/(93.+1./3.) * ano2dnra ocetra(i,j,k,ialkali) = ocetra(i,j,k,ialkali) + (295.*ano2denit + 15.*an2odenit)/280. & - & + (201.+2./3.)/(93.+1./3.) * ano2dnra + & + (201.+1./3.)/(93.+1./3.) * ano2dnra endif endif enddo From 63efed3e27efa9b120d388c3d60d1050173377e1 Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Thu, 23 Jun 2022 12:32:22 +0200 Subject: [PATCH 113/366] Fix alkalinity change for DNRA --- hamocc/mo_extNbioproc.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/hamocc/mo_extNbioproc.F90 b/hamocc/mo_extNbioproc.F90 index a2605a12..eea5d999 100644 --- a/hamocc/mo_extNbioproc.F90 +++ b/hamocc/mo_extNbioproc.F90 @@ -474,7 +474,7 @@ subroutine denit_dnra(kpie,kpje,kpke,kbnd,pddpo,omask,ptho) ocetra(i,j,k,iphosph) = ocetra(i,j,k,iphosph) + (ano2denit + an2odenit)/280. + ano2dnra/(93.+1./3.) ocetra(i,j,k,iiron) = ocetra(i,j,k,iiron) + riron/280.*(ano2denit + an2odenit) + riron/(93.+1./3.) * ano2dnra ocetra(i,j,k,ialkali) = ocetra(i,j,k,ialkali) + (295.*ano2denit + 15.*an2odenit)/280. & - & + (201.+1./3.)/(93.+1./3.) * ano2dnra + & + (201.+2./3.)/(93.+1./3.) * ano2dnra endif endif enddo From e334b1a0dbea561de8de0e0f5ad5ab500106311c Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Thu, 23 Jun 2022 13:28:33 +0200 Subject: [PATCH 114/366] fix limitations for nitrification --- hamocc/mo_extNbioproc.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/hamocc/mo_extNbioproc.F90 b/hamocc/mo_extNbioproc.F90 index eea5d999..e5665709 100644 --- a/hamocc/mo_extNbioproc.F90 +++ b/hamocc/mo_extNbioproc.F90 @@ -240,9 +240,9 @@ subroutine nitrification(kpie,kpje,kpke,kbnd,pddpo,omask,ptho) & ocetra(i,j,k,ianh4)/(amoxfrac + fdetamox*nitrfrac + eps), & ! ammonium & ocetra(i,j,k,isco212)/((122./16.)*(fdetamox*amoxfrac + fdetnitr*nitrfrac) + eps), & ! CO2 & ocetra(i,j,k,iphosph)/((fdetamox*amoxfrac + fdetnitr*nitrfrac)/16. + eps), & ! PO4 - & ocetra(i,j,k,iiron)/((fdetamox*amoxfrac + fdetnitr*nitrfrac)/(16.*riron) + eps), & ! Fe + & ocetra(i,j,k,iiron)/((fdetamox*amoxfrac + fdetnitr*nitrfrac)*riron/16. + eps), & ! Fe & ocetra(i,j,k,ioxygen) & - & /((1.5*fno2 + fn2o - 140./16.*fdetamox)*amoxfrac + (0.5*fno3 + 140./16.*fdetnitr)*nitrfrac +eps), & ! O2 + & /((1.5*fno2 + fn2o - 140./16.*fdetamox)*amoxfrac + (0.5*fno3 - 140./16.*fdetnitr)*nitrfrac +eps), & ! O2 & ocetra(i,j,k,ialkali) & & /((2.*fno2 + fn2o + 15./16.*fdetamox)*amoxfrac + (15./16.*fdetnitr)*nitrfrac + eps))) ! alkalinity amox = amoxfrac*totd From d096bc140e9de9195d7a70959d33556f4552e29d Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Thu, 23 Jun 2022 13:29:26 +0200 Subject: [PATCH 115/366] fix iron limitation and changes in anammox --- hamocc/mo_extNbioproc.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/hamocc/mo_extNbioproc.F90 b/hamocc/mo_extNbioproc.F90 index e5665709..2bbbea9b 100644 --- a/hamocc/mo_extNbioproc.F90 +++ b/hamocc/mo_extNbioproc.F90 @@ -351,7 +351,7 @@ subroutine anammox(kpie,kpje,kpke,kbnd,pddpo,omask,ptho) ano2new = ocetra(i,j,k,iano2)/(1. + rano2anmx*Tdep*O2inhib*nut1lim*nut2lim) ano2anmx = max(0.,min(ocetra(i,j,k,iano2) - ano2new, ocetra(i,j,k,ianh4)*1144./880., ocetra(i,j,k,isco212)*1144./122., & - & ocetra(i,j,k,iphosph)*1144., ocetra(i,j,k,iiron)*1144./(riron*16.), ocetra(i,j,k,ialkali)*1144./15.)) + & ocetra(i,j,k,iphosph)*1144., ocetra(i,j,k,iiron)*1144./riron, ocetra(i,j,k,ialkali)*1144./15.)) ocetra(i,j,k,iano2) = ocetra(i,j,k,iano2) - ano2anmx ocetra(i,j,k,ianh4) = ocetra(i,j,k,ianh4) - ano2anmx*880./1144. @@ -360,7 +360,7 @@ subroutine anammox(kpie,kpje,kpke,kbnd,pddpo,omask,ptho) ocetra(i,j,k,idet) = ocetra(i,j,k,idet) + ano2anmx/1144. ocetra(i,j,k,isco212) = ocetra(i,j,k,isco212) - ano2anmx*122./1144. ocetra(i,j,k,iphosph) = ocetra(i,j,k,iphosph) - ano2anmx/1144. - ocetra(i,j,k,iiron) = ocetra(i,j,k,iiron) - ano2anmx*riron*16./1144. + ocetra(i,j,k,iiron) = ocetra(i,j,k,iiron) - ano2anmx*riron/1144. ocetra(i,j,k,ialkali) = ocetra(i,j,k,ialkali) - ano2anmx*15./1144. endif endif From 8839fcceb900d08528287e9a4484611506b80598 Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Thu, 23 Jun 2022 15:48:50 +0200 Subject: [PATCH 116/366] introducing extended nitrogen cycle-relevant utilization ratios --- hamocc/mo_extNbioproc.F90 | 23 ++++++++++++++++++++--- 1 file changed, 20 insertions(+), 3 deletions(-) diff --git a/hamocc/mo_extNbioproc.F90 b/hamocc/mo_extNbioproc.F90 index 2bbbea9b..73ec1cd8 100644 --- a/hamocc/mo_extNbioproc.F90 +++ b/hamocc/mo_extNbioproc.F90 @@ -52,7 +52,7 @@ MODULE mo_extNbioproc use mo_control_bgc, only: io_stdo_bgc,dtb use mo_param1_bgc, only: ialkali,ianh4,iano2,ian2o,iano3,idet,igasnit,iiron,ioxygen,iphosph,isco212 use mo_carbch, only: ocetra - use mo_biomod, only: riron + use mo_biomod, only: riron,rnit,rcar,rnoi implicit none @@ -63,7 +63,7 @@ MODULE mo_extNbioproc & anammox,denit_dnra,extN_inv_check ! public parameters - public :: bkphyanh4,bkphyano3,bkphosph,bkiron + public :: bkphyanh4,bkphyano3,bkphosph,bkiron,ro2utammo real :: q10ano3denit,sc_ano3denit,Trefano3denit,rano3denit,bkano3denit, & @@ -75,6 +75,9 @@ MODULE mo_extNbioproc & rano2nitr,q10ano2nitr,Trefano2nitr,bkoxnitr,bkano2nitr,n2omaxy, & & n2oybeta,bkphyanh4,bkphyano3,bkphosph,bkiron + real :: rc2n,ro2utammo,ro2nnit,rnoxp,rnoxpi,rno2anmx,rno2anmxi,rnh4anmx, & + & rnh4anmxi,rno2dnra,rno2dnrai,rnh4dnra,rnh4dnrai,rnm1 + real :: eps,minlim CONTAINS @@ -83,7 +86,21 @@ MODULE mo_extNbioproc subroutine extNbioparam_init() !=========================================================================== ! Initialization of model parameters for the extended nitrogen cycle - + rc2n = rcar/rnit ! iHAMOCC C:N ratio + ro2utammo = 140. ! Oxygen utilization per mol detitus during ammonification + ro2nnit = ro2utammo/rnit ! + rnoxp = 280. ! consumption of NOx per mol detritus during denitrification + rnoxpi = 1./rnoxp ! inverse + rno2anmx = 1144. ! consumption of NO2 per mol organic production by anammox + rno2anmxi = 1./rno2anmx ! inverse + rnh4anmx = 880. ! consumption of NH4 per mol organic production by anammox + rnh4anmxi = 1./rnh4anmx ! inverse + rno2dnra = 93. + 1./3 ! consumption of NO2 per mol OM degradation during DNRA + rno2dnrai = 1./rno2dnra ! inverse + rnh4dnra = rno2dnra + rnit ! production of NH4 per mol OM during DNRA + rnh4dnrai = 1./rnh4dnra ! inverse + rnm1 = rnit - 1. + ! Phytoplankton growth bkphyanh4 = 0.1e-6 ! Half-saturation constant for NH4 uptake by bulk phytoplankton (kmol/m3) bkphyano3 = 0.16e-6 ! Half-saturation constant for NO3 uptake by bulk phytoplankton (kmol/m3) From 788d2dcb59e49147b8839c4e32b994cd28d32e83 Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Thu, 23 Jun 2022 16:24:26 +0200 Subject: [PATCH 117/366] exchange hard coded values by introduced extNcycle parameters --- hamocc/mo_extNbioproc.F90 | 87 ++++++++++++++++++++------------------- hamocc/ocprod.F90 | 14 +++---- 2 files changed, 51 insertions(+), 50 deletions(-) diff --git a/hamocc/mo_extNbioproc.F90 b/hamocc/mo_extNbioproc.F90 index 73ec1cd8..84c5b540 100644 --- a/hamocc/mo_extNbioproc.F90 +++ b/hamocc/mo_extNbioproc.F90 @@ -121,7 +121,7 @@ subroutine extNbioparam_init() alphaanmx = 0.45e6 ! Shape factor for anammox oxygen inhibition function (m3/kmol) bkoxanmx = 11.3e-6 ! Half-saturation constant for oxygen inhibition function (kmol/m3) bkano2anmx = 5.e-6 ! Half-saturation constant for NO2 limitation (kmol/m3) - bkanh4anmx = bkano2anmx * 880./1144. !Half-saturation constant for NH4 limitation of anammox (kmol/m3) + bkanh4anmx = bkano2anmx * rnh4anmx/rno2anmx !Half-saturation constant for NH4 limitation of anammox (kmol/m3) ! === Denitrification step NO2 -> N2O rano2denit = 0.12*dtb ! Maximum growth rate denitrification on NO2 at reference T (1/d -> 1/dt) @@ -255,13 +255,13 @@ subroutine nitrification(kpie,kpje,kpke,kbnd,pddpo,omask,ptho) totd = max(0., & & min(totd, & & ocetra(i,j,k,ianh4)/(amoxfrac + fdetamox*nitrfrac + eps), & ! ammonium - & ocetra(i,j,k,isco212)/((122./16.)*(fdetamox*amoxfrac + fdetnitr*nitrfrac) + eps), & ! CO2 - & ocetra(i,j,k,iphosph)/((fdetamox*amoxfrac + fdetnitr*nitrfrac)/16. + eps), & ! PO4 - & ocetra(i,j,k,iiron)/((fdetamox*amoxfrac + fdetnitr*nitrfrac)*riron/16. + eps), & ! Fe + & ocetra(i,j,k,isco212)/(rc2n*(fdetamox*amoxfrac + fdetnitr*nitrfrac) + eps), & ! CO2 + & ocetra(i,j,k,iphosph)/((fdetamox*amoxfrac + fdetnitr*nitrfrac)*rnoi + eps), & ! PO4 + & ocetra(i,j,k,iiron)/((fdetamox*amoxfrac + fdetnitr*nitrfrac)*riron*rnoi + eps), & ! Fe & ocetra(i,j,k,ioxygen) & - & /((1.5*fno2 + fn2o - 140./16.*fdetamox)*amoxfrac + (0.5*fno3 - 140./16.*fdetnitr)*nitrfrac +eps), & ! O2 + & /((1.5*fno2 + fn2o - ro2nnit*fdetamox)*amoxfrac + (0.5*fno3 - ro2nnit*fdetnitr)*nitrfrac +eps), & ! O2 & ocetra(i,j,k,ialkali) & - & /((2.*fno2 + fn2o + 15./16.*fdetamox)*amoxfrac + (15./16.*fdetnitr)*nitrfrac + eps))) ! alkalinity + & /((2.*fno2 + fn2o + rnm1*rnoi*fdetamox)*amoxfrac + (rnm1*rnoi*fdetnitr)*nitrfrac + eps))) ! alkalinity amox = amoxfrac*totd nitr = nitrfrac*totd @@ -269,13 +269,13 @@ subroutine nitrification(kpie,kpje,kpke,kbnd,pddpo,omask,ptho) ocetra(i,j,k,ian2o) = ocetra(i,j,k,ian2o) + 0.5*fn2o*amox ocetra(i,j,k,iano2) = ocetra(i,j,k,iano2) + fno2*amox - nitr ocetra(i,j,k,iano3) = ocetra(i,j,k,iano3) + nitr - ocetra(i,j,k,idet) = ocetra(i,j,k,idet) + fdetamox/16.*amox + fdetnitr/16.*nitr - ocetra(i,j,k,isco212) = ocetra(i,j,k,isco212) - 122./16.*fdetamox*amox - 122./16.*fdetnitr*nitr - ocetra(i,j,k,iphosph) = ocetra(i,j,k,iphosph) - fdetamox/16.*amox - fdetnitr/16.*nitr - ocetra(i,j,k,iiron) = ocetra(i,j,k,iiron) - riron/16.*fdetamox*amox - riron/16.*fdetnitr*nitr - ocetra(i,j,k,ioxygen) = ocetra(i,j,k,ioxygen) - (1.5*fno2 + fn2o - 140./16.*fdetamox)*amox & - & - (0.5*fno3 - 140./16.*fdetnitr)*nitr - ocetra(i,j,k,ialkali) = ocetra(i,j,k,ialkali) - (2.*fno2 + fn2o + 15./16.*fdetamox)*amox - 15./16.*fdetnitr*nitr + ocetra(i,j,k,idet) = ocetra(i,j,k,idet) + rnoi*(fdetamox*amox + fdetnitr*nitr) + ocetra(i,j,k,isco212) = ocetra(i,j,k,isco212) - rc2n*(fdetamox*amox + fdetnitr*nitr) + ocetra(i,j,k,iphosph) = ocetra(i,j,k,iphosph) - rnoi*(fdetamox*amox + fdetnitr*nitr) + ocetra(i,j,k,iiron) = ocetra(i,j,k,iiron) - riron*rnoi*(fdetamox*amox + fdetnitr*nitr) + ocetra(i,j,k,ioxygen) = ocetra(i,j,k,ioxygen) - (1.5*fno2 + fn2o - ro2nnit*fdetamox)*amox & + & - (0.5*fno3 - ro2nnit*fdetnitr)*nitr + ocetra(i,j,k,ialkali) = ocetra(i,j,k,ialkali) - (2.*fno2 + fn2o + rnm1*rnoi*fdetamox)*amox - rnm1*rnoi*fdetnitr*nitr endif enddo enddo @@ -315,16 +315,16 @@ subroutine denit_NO3_to_NO2(kpie,kpje,kpke,kbnd,pddpo,omask,ptho) ano3new = ocetra(i,j,k,iano3)/(1. + rano3denit*Tdep*O2inhib*nutlim) - ano3denit = max(0.,min(ocetra(i,j,k,iano3) - ano3new, ocetra(i,j,k,idet)*280.)) + ano3denit = max(0.,min(ocetra(i,j,k,iano3) - ano3new, ocetra(i,j,k,idet)*rnoxp)) ocetra(i,j,k,iano3) = ocetra(i,j,k,iano3) - ano3denit ocetra(i,j,k,iano2) = ocetra(i,j,k,iano2) + ano3denit - ocetra(i,j,k,idet) = ocetra(i,j,k,idet) - ano3denit/280. - ocetra(i,j,k,ianh4) = ocetra(i,j,k,ianh4) + ano3denit*16./280. - ocetra(i,j,k,isco212) = ocetra(i,j,k,isco212) + ano3denit*122./280. - ocetra(i,j,k,iphosph) = ocetra(i,j,k,iphosph) + ano3denit/280. - ocetra(i,j,k,iiron) = ocetra(i,j,k,iiron) + ano3denit*riron/280. - ocetra(i,j,k,ialkali) = ocetra(i,j,k,ialkali) + ano3denit*15./280. + ocetra(i,j,k,idet) = ocetra(i,j,k,idet) - ano3denit*rnoxpi + ocetra(i,j,k,ianh4) = ocetra(i,j,k,ianh4) + ano3denit*rnit*rnoxpi + ocetra(i,j,k,isco212) = ocetra(i,j,k,isco212) + ano3denit*rcar*rnoxpi + ocetra(i,j,k,iphosph) = ocetra(i,j,k,iphosph) + ano3denit*rnoxpi + ocetra(i,j,k,iiron) = ocetra(i,j,k,iiron) + ano3denit*riron*rnoxpi + ocetra(i,j,k,ialkali) = ocetra(i,j,k,ialkali) + ano3denit*rnm1*rnoxpi endif endif enddo @@ -367,18 +367,19 @@ subroutine anammox(kpie,kpje,kpke,kbnd,pddpo,omask,ptho) ano2new = ocetra(i,j,k,iano2)/(1. + rano2anmx*Tdep*O2inhib*nut1lim*nut2lim) - ano2anmx = max(0.,min(ocetra(i,j,k,iano2) - ano2new, ocetra(i,j,k,ianh4)*1144./880., ocetra(i,j,k,isco212)*1144./122., & - & ocetra(i,j,k,iphosph)*1144., ocetra(i,j,k,iiron)*1144./riron, ocetra(i,j,k,ialkali)*1144./15.)) + ano2anmx = max(0.,min(ocetra(i,j,k,iano2) - ano2new, ocetra(i,j,k,ianh4)*rno2anmx*rnh4anmxi, & + ocetra(i,j,k,isco212)*rno2anmx/rcar, ocetra(i,j,k,iphosph)*rno2anmx, & + ocetra(i,j,k,iiron)*rno2anmx/riron, ocetra(i,j,k,ialkali)*rno2anmx/rnm1)) ocetra(i,j,k,iano2) = ocetra(i,j,k,iano2) - ano2anmx - ocetra(i,j,k,ianh4) = ocetra(i,j,k,ianh4) - ano2anmx*880./1144. - ocetra(i,j,k,igasnit) = ocetra(i,j,k,igasnit) + ano2anmx*864./1144. - ocetra(i,j,k,iano3) = ocetra(i,j,k,iano3) + ano2anmx*280./1144. - ocetra(i,j,k,idet) = ocetra(i,j,k,idet) + ano2anmx/1144. - ocetra(i,j,k,isco212) = ocetra(i,j,k,isco212) - ano2anmx*122./1144. - ocetra(i,j,k,iphosph) = ocetra(i,j,k,iphosph) - ano2anmx/1144. - ocetra(i,j,k,iiron) = ocetra(i,j,k,iiron) - ano2anmx*riron/1144. - ocetra(i,j,k,ialkali) = ocetra(i,j,k,ialkali) - ano2anmx*15./1144. + ocetra(i,j,k,ianh4) = ocetra(i,j,k,ianh4) - ano2anmx*rnh4anmx*rno2anmxi + ocetra(i,j,k,igasnit) = ocetra(i,j,k,igasnit) + ano2anmx*(rnh4anmx-rnit)*rno2anmxi + ocetra(i,j,k,iano3) = ocetra(i,j,k,iano3) + ano2anmx*rnoxp*rno2anmxi + ocetra(i,j,k,idet) = ocetra(i,j,k,idet) + ano2anmx*rno2anmxi + ocetra(i,j,k,isco212) = ocetra(i,j,k,isco212) - ano2anmx*rcar*rno2anmxi + ocetra(i,j,k,iphosph) = ocetra(i,j,k,iphosph) - ano2anmx*rno2anmxi + ocetra(i,j,k,iiron) = ocetra(i,j,k,iiron) - ano2anmx*riron*rno2anmxi + ocetra(i,j,k,ialkali) = ocetra(i,j,k,ialkali) - ano2anmx*rnm1*rno2anmxi endif endif enddo @@ -469,29 +470,29 @@ subroutine denit_dnra(kpie,kpje,kpke,kbnd,pddpo,omask,ptho) endif ! limitation of processes due to detritus - potddet = 1./280.*(ano2denit + an2odenit) + 1./(93. + 1./3.)*ano2dnra ! P units - fdetano2denit = 1./280.*ano2denit/(potddet + eps) - fdetan2odenit = 1./280.*an2odenit/(potddet + eps) + potddet = rnoxpi*(ano2denit + an2odenit) + rno2dnrai*ano2dnra ! P units + fdetano2denit = rnoxpi*ano2denit/(potddet + eps) + fdetan2odenit = rnoxpi*an2odenit/(potddet + eps) fdetdnra = 1. - fdetano2denit - fdetan2odenit potddet = max(0.,min(potddet,ocetra(i,j,k,idet))) if(potddet>0.)then ! change of NO2 and N2O in N units - ano2denit = fdetano2denit*280.*potddet - an2odenit = fdetan2odenit*280.*potddet - ano2dnra = fdetdnra * (93. + 1./3.)*potddet + ano2denit = fdetano2denit*rnoxp*potddet + an2odenit = fdetan2odenit*rnoxp*potddet + ano2dnra = fdetdnra*rno2dnra*potddet ! change in tracer concentrations due to denit (NO2->N2O->N2) and DNRA (NO2->NH4) ocetra(i,j,k,iano2) = ocetra(i,j,k,iano2) - ano2denit - ano2dnra ocetra(i,j,k,ian2o) = ocetra(i,j,k,ian2o) - an2odenit + 0.5*ano2denit ocetra(i,j,k,igasnit) = ocetra(i,j,k,igasnit) + an2odenit - ocetra(i,j,k,ianh4) = ocetra(i,j,k,ianh4) + 16./280. * (ano2denit+an2odenit) + (109.+1./3.)/(93.+1./3.)*ano2dnra - ocetra(i,j,k,idet) = ocetra(i,j,k,idet) - (ano2denit + an2odenit)/280. - ano2dnra/(93.+1./3.) - ocetra(i,j,k,isco212) = ocetra(i,j,k,isco212) + 122./280.*(ano2denit + an2odenit) + 122./(93.+1./3.) * ano2dnra - ocetra(i,j,k,iphosph) = ocetra(i,j,k,iphosph) + (ano2denit + an2odenit)/280. + ano2dnra/(93.+1./3.) - ocetra(i,j,k,iiron) = ocetra(i,j,k,iiron) + riron/280.*(ano2denit + an2odenit) + riron/(93.+1./3.) * ano2dnra - ocetra(i,j,k,ialkali) = ocetra(i,j,k,ialkali) + (295.*ano2denit + 15.*an2odenit)/280. & - & + (201.+2./3.)/(93.+1./3.) * ano2dnra + ocetra(i,j,k,ianh4) = ocetra(i,j,k,ianh4) + rnit*rnoxpi*(ano2denit+an2odenit) + rnh4dnra*rno2dnrai*ano2dnra + ocetra(i,j,k,idet) = ocetra(i,j,k,idet) - (ano2denit + an2odenit)*rnoxpi - ano2dnra*rno2dnrai + ocetra(i,j,k,isco212) = ocetra(i,j,k,isco212) + rcar*rnoxpi*(ano2denit + an2odenit) + rcar*rno2dnrai*ano2dnra + ocetra(i,j,k,iphosph) = ocetra(i,j,k,iphosph) + (ano2denit + an2odenit)*rnoxpi + ano2dnra*rno2dnrai + ocetra(i,j,k,iiron) = ocetra(i,j,k,iiron) + riron*rnoxpi*(ano2denit + an2odenit) + riron*rno2dnrai*ano2dnra + ocetra(i,j,k,ialkali) = ocetra(i,j,k,ialkali) + (295.*ano2denit + rnm1*an2odenit)*rnoxpi & + & + (rno2dnra + rnh4dnra - 1.)*rno2dnrai * ano2dnra endif endif enddo diff --git a/hamocc/ocprod.F90 b/hamocc/ocprod.F90 index d83c9e97..8e39a7a0 100644 --- a/hamocc/ocprod.F90 +++ b/hamocc/ocprod.F90 @@ -122,7 +122,7 @@ subroutine ocprod(kpie,kpje,kpke,kbnd,pdlxp,pdlyp,pddpo,omask,ptho,pi_ph) #endif #ifdef extNcycle use mo_extNbioproc, only: nitrification,denit_NO3_to_NO2,anammox,denit_dnra,extN_inv_check - use mo_extNbioproc, only: bkphyanh4,bkphyano3,bkphosph,bkiron + use mo_extNbioproc, only: bkphyanh4,bkphyano3,bkphosph,bkiron,ro2utammo use mo_param1_bgc, only: ianh4 #endif @@ -487,9 +487,9 @@ subroutine ocprod(kpie,kpje,kpke,kbnd,pdlxp,pdlyp,pddpo,omask,ptho,pi_ph) ocetra(i,j,k,ialkali) = ocetra(i,j,k,ialkali) - nh4uptfrac*phosy*(rnit-1.) & ! NH4 + PO4 Uptake & + (1.-nh4uptfrac)*phosy*(rnit+1.) & ! NO3 + PO4 Uptake & + (dtr+phosy)*(rnit-1.) - 2.*delcar ! Remin to (NH4 + PO4) and CaCO3 formation - ocetra(i,j,k,ioxygen) = ocetra(i,j,k,ioxygen) + nh4uptfrac*phosy*140. & ! NH4 uptake + ocetra(i,j,k,ioxygen) = ocetra(i,j,k,ioxygen) + nh4uptfrac*phosy*ro2utammo & ! NH4 uptake & + (1.-nh4uptfrac)*phosy*ro2ut & ! NO3 uptake - & - (dtr+phosy)*140. ! Remin to NH4 + & - (dtr+phosy)*ro2utammo ! Remin to NH4 #endif ocetra(i,j,k,idet) = ocetra(i,j,k,idet)+export ocetra(i,j,k,idms) = ocetra(i,j,k,idms)+dmsprod-dms_bac-dms_uv @@ -659,9 +659,9 @@ subroutine ocprod(kpie,kpje,kpke,kbnd,pdlxp,pdlyp,pddpo,omask,ptho,pi_ph) docrem = MIN( remido*ocetra(i,j,k,idoc),0.33*ocetra(i,j,k,ioxygen)/ro2ut) phyrem = MIN(0.5*dyphy*phythresh, 0.33*ocetra(i,j,k,ioxygen)/ro2ut) #else - pocrem = MIN(drempoc*ocetra(i,j,k,idet),0.33*ocetra(i,j,k,ioxygen)/140.) - docrem = MIN( remido*ocetra(i,j,k,idoc),0.33*ocetra(i,j,k,ioxygen)/140.) - phyrem = MIN(0.5*dyphy*phythresh, 0.33*ocetra(i,j,k,ioxygen)/140.) + pocrem = MIN(drempoc*ocetra(i,j,k,idet),0.33*ocetra(i,j,k,ioxygen)/ro2utammo) + docrem = MIN( remido*ocetra(i,j,k,idoc),0.33*ocetra(i,j,k,ioxygen)/ro2utammo) + phyrem = MIN(0.5*dyphy*phythresh, 0.33*ocetra(i,j,k,ioxygen)/ro2utammo) #endif #ifdef cisonew pocrem13 = pocrem*rdet13 @@ -699,7 +699,7 @@ subroutine ocprod(kpie,kpje,kpke,kbnd,pdlxp,pdlyp,pddpo,omask,ptho,pi_ph) #else ocetra(i,j,k,ianh4) = ocetra(i,j,k,ianh4) + remin*rnit ocetra(i,j,k,ialkali) = ocetra(i,j,k,ialkali) + (rnit-1.)*remin - ocetra(i,j,k,ioxygen) = ocetra(i,j,k,ioxygen) - 140.*remin + ocetra(i,j,k,ioxygen) = ocetra(i,j,k,ioxygen) - ro2utammo*remin #endif ocetra(i,j,k,isco212) = ocetra(i,j,k,isco212)+rcar*remin ocetra(i,j,k,iiron) = ocetra(i,j,k,iiron)+remin*riron & From a58660716cbe031bc84e7597a14b49255e79a7f2 Mon Sep 17 00:00:00 2001 From: Mats Bentsen Date: Mon, 27 Jun 2022 01:32:47 +0200 Subject: [PATCH 118/366] Changed CVMix URL from https to ssh and ensured that tag v0.98-beta is checked out. --- .gitmodules | 4 ++-- pkgs/CVMix-src | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/.gitmodules b/.gitmodules index a4940a8b..18c11683 100644 --- a/.gitmodules +++ b/.gitmodules @@ -1,3 +1,3 @@ -[submodule "pkgs/CVMix-src"] +[submodule "CVMix-src"] path = pkgs/CVMix-src - url = https://github.com/CVMix/CVMix-src.git + url = git@github.com:CVMix/CVMix-src.git diff --git a/pkgs/CVMix-src b/pkgs/CVMix-src index 365591d2..9423197f 160000 --- a/pkgs/CVMix-src +++ b/pkgs/CVMix-src @@ -1 +1 @@ -Subproject commit 365591d2269cbffe4e5873d7a7254b3d092fbb68 +Subproject commit 9423197f894112edfcb1502245f7d7b873d551f9 From b29db3367d86e08eef8c1ac20a22909c3a02c9ef Mon Sep 17 00:00:00 2001 From: Mats Bentsen Date: Mon, 27 Jun 2022 16:52:20 +0200 Subject: [PATCH 119/366] Ensure that tag v0.98-beta of CVMix is checked out by CESM's checkout_externals tool. --- Externals_BLOM.cfg | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Externals_BLOM.cfg b/Externals_BLOM.cfg index 4e31ea00..7952afd5 100644 --- a/Externals_BLOM.cfg +++ b/Externals_BLOM.cfg @@ -1,5 +1,5 @@ [CVMix] -tag = master +tag = v0.98-beta protocol = git repo_url = https://github.com/CVMix/CVMix-src local_path = pkgs/CVMix-src From f9fedeacc656e6bec2724f682bb2aa78677374b6 Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Mon, 27 Jun 2022 19:52:50 +0200 Subject: [PATCH 120/366] EXTENDED the OUTPUT DIAGNOSTICS by process rates --- cime_config/buildnml | 75 +++++++++++ hamocc/accfields.F90 | 49 +++++++- hamocc/mo_bgcmean.F90 | 114 ++++++++++++++++- hamocc/mo_biomod.F90 | 47 +++++++ hamocc/mo_extNbioproc.F90 | 42 ++++++- hamocc/ncout_hamocc.F | 255 +++++++++++++++++++++++++++++++++++++- hamocc/ocprod.F90 | 17 ++- 7 files changed, 589 insertions(+), 10 deletions(-) diff --git a/cime_config/buildnml b/cime_config/buildnml index 9483b950..ef7c5ab0 100755 --- a/cime_config/buildnml +++ b/cime_config/buildnml @@ -453,6 +453,21 @@ set LYR_IRON = '0, 0, 2' set LYR_ANO3 = '0, 0, 2' set LYR_ANO2 = '0, 0, 2' set LYR_ANH4 = '0, 0, 2' +set LYR_nitr_NH4 = '0, 0, 2' +set LYR_nitr_NO2 = '0, 0, 2' +set LYR_nitr_N2O_prod = '0, 0, 2' +set LYR_nitr_NH4_OM = '0, 0, 2' +set LYR_nitr_NO2_OM = '0, 0, 2' +set LYR_denit_NO3 = '0, 0, 2' +set LYR_denit_NO2 = '0, 0, 2' +set LYR_denit_N2O = '0, 0, 2' +set LYR_DNRA_NO2 = '0, 0, 2' +set LYR_anmx_N2_prod = '0, 0, 2' +set LYR_anmx_OM_prod = '0, 0, 2' +set LYR_phosy_NH4 = '0, 0, 2' +set LYR_phosy_NO3 = '0, 0, 2' +set LYR_remin_aerob = '0, 0, 2' +set LYR_remin_sulf = '0, 0, 2' set LYR_ALKALI = '0, 0, 2' set LYR_SILICA = '0, 0, 2' set LYR_DIC = '0, 0, 2' @@ -507,6 +522,21 @@ set LVL_IRON = '0, 2, 2' set LVL_ANO3 = '0, 2, 2' set LVL_ANO2 = '0, 2, 2' set LVL_ANH4 = '0, 2, 2' +set LVL_nitr_NH4 = '0, 2, 2' +set LVL_nitr_NO2 = '0, 2, 2' +set LVL_nitr_N2O_prod = '0, 2, 2' +set LVL_nitr_NH4_OM = '0, 2, 2' +set LVL_nitr_NO2_OM = '0, 2, 2' +set LVL_denit_NO3 = '0, 2, 2' +set LVL_denit_NO2 = '0, 2, 2' +set LVL_denit_N2O = '0, 2, 2' +set LVL_DNRA_NO2 = '0, 2, 2' +set LVL_anmx_N2_prod = '0, 2, 2' +set LVL_anmx_OM_prod = '0, 2, 2' +set LVL_phosy_NH4 = '0, 2, 2' +set LVL_phosy_NO3 = '0, 2, 2' +set LVL_remin_aerob = '0, 2, 2' +set LVL_remin_sulf = '0, 2, 2' set LVL_ALKALI = '0, 2, 2' set LVL_SILICA = '0, 2, 2' set LVL_DIC = '0, 2, 2' @@ -1470,6 +1500,21 @@ cat >>! $RUNDIR/ocn_in$inststr << EOF ! PHOSY - Primary production (pp) [mol C m-3 s-1] ! CO3 - Carbonate ions (co3) [mol C m-3] ! N2O - Nitrous oxide concentration [mol N2O m-3] +! nitr_NH4 - nitrification rate on NH4 [mol NH4 m-3 s-1] - extended N cycle only +! nitr_NO2 - nitrification rate on NO2 [mol NO2 m-3 s-1] - extended N cycle only +! nitr_N2O_prod - N2O production rate during nitrification on NH4 [mol N2O m-3 s-1] - ext. N cycle only +! nitr_NH4_OM - detritus production during nitrification on NH4 [mol P m-3 s-1] - ext. N cycle only +! nitr_NO2_OM - detritus production during nitrification on NO2 [mol P m-3 s-1] - ext. N cycle only +! denit_NO3 - denitrification rate on NO3 [mol NO3 m-3 s-1] - ext. N cycle only +! denit_NO2 - denitrification rate on NO2 [mol NO2 m-3 s-1] - ext. N cycle only +! denit_N2O - denitrification rate on N20 [mol N20 m-3 s-1] - ext. N cycle only +! DNRA_NO2 - DNRA on NO2 [mol NO2 m-3 s-1] - ext. N cycle only +! anmx_N2_prod - anammox N2 production [mol N2 m-3 s-1] - ext. N cycle only +! anmx_OM_prod - anammox detritus production [mol P m-3 s-1] - ext. N cycle only +! phosy_NH4 - PP consumption of NH4 [mol NH4 m-3 s-1] - ext. N cycle only +! phosy_NO3 - PP consumption of NH4 [mol NH4 m-3 s-1] - ext. N cycle only +! remin_aerob - aerob remineralization rate (sev. sources) [mol NH4 m-3 s-1] - ext. N cycle only +! remin_sulf - sulfate-based remin rate on det [mol P m-3 s-1] - ext. N cycle only ! PH - pH (ph) [-log10([h+])] ! OMEGAA - Aragonite saturation state (omegaa) [1] ! OMEGAC - Calcite saturation state (omegac) [1] @@ -1648,6 +1693,21 @@ cat >>! $RUNDIR/ocn_in$inststr << EOF LYR_ANO3 = $LYR_ANO3 LYR_ANO2 = $LYR_ANO2 LYR_ANH4 = $LYR_ANH4 + LYR_nitr_NH4 = $LYR_nitr_NH4 + LYR_nitr_NO2 = $LYR_nitr_NO2 + LYR_nitr_N2O_prod = $LYR_nitr_N2O_prod + LYR_nitr_NH4_OM = $LYR_nitr_NH4_OM + LYR_nitr_NO2_OM = $LYR_nitr_NO2_OM + LYR_denit_NO3 = $LYR_denit_NO3 + LYR_denit_NO2 = $LYR_denit_NO2 + LYR_denit_N2O = $LYR_denit_N2O + LYR_DNRA_NO2 = $LYR_DNRA_NO2 + LYR_anmx_N2_prod = $LYR_anmx_N2_prod + LYR_anmx_OM_prod = $LYR_anmx_OM_prod + LYR_phosy_NH4 = $LYR_phosy_NH4 + LYR_phosy_NO3 = $LYR_phosy_NO3 + LYR_remin_aerob = $LYR_remin_aerob + LYR_remin_sulf = $LYR_remin_sulf LYR_ALKALI = $LYR_ALKALI LYR_SILICA = $LYR_SILICA LYR_DIC = $LYR_DIC @@ -1702,6 +1762,21 @@ cat >>! $RUNDIR/ocn_in$inststr << EOF LVL_ANO3 = $LVL_ANO3 LVL_ANO2 = $LVL_ANO2 LVL_ANH4 = $LVL_ANH4 + LVL_nitr_NH4 = $LVL_nitr_NH4 + LVL_nitr_NO2 = $LVL_nitr_NO2 + LVL_nitr_N2O_prod = $LVL_nitr_N2O_prod + LVL_nitr_NH4_OM = $LVL_nitr_NH4_OM + LVL_nitr_NO2_OM = $LVL_nitr_NO2_OM + LVL_denit_NO3 = $LVL_denit_NO3 + LVL_denit_NO2 = $LVL_denit_NO2 + LVL_denit_N2O = $LVL_denit_N2O + LVL_DNRA_NO2 = $LVL_DNRA_NO2 + LVL_anmx_N2_prod = $LVL_anmx_N2_prod + LVL_anmx_OM_prod = $LVL_anmx_OM_prod + LVL_phosy_NH4 = $LVL_phosy_NH4 + LVL_phosy_NO3 = $LVL_phosy_NO3 + LVL_remin_aerob = $LVL_remin_aerob + LVL_remin_sulf = $LVL_remin_sulf LVL_ALKALI = $LVL_ALKALI LVL_SILICA = $LVL_SILICA LVL_DIC = $LVL_DIC diff --git a/hamocc/accfields.F90 b/hamocc/accfields.F90 index 19dd81e9..75a76b47 100644 --- a/hamocc/accfields.F90 +++ b/hamocc/accfields.F90 @@ -108,7 +108,14 @@ SUBROUTINE ACCFIELDS(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask) #endif #ifdef extNcycle use mo_param1_bgc, only: iatmnh3,ianh4,iano2 - use mo_bgcmean, only: jnh3flux,janh3fx,janh4,jano2,jsrfanh4,jsrfano2 + use mo_bgcmean, only: jnh3flux,janh3fx,janh4,jano2,jsrfanh4,jsrfano2, & + & jnitr_NH4,jnitr_NO2,jnitr_N2O_prod,jnitr_NH4_OM,jnitr_NO2_OM,jdenit_NO3,jdenit_NO2,jdenit_N2O, & + & jDNRA_NO2,janmx_N2_prod,janmx_OM_prod,jphosy_NH4,jphosy_NO3,jremin_aerob,jremin_sulf,jlvl_nitr_NH4, & + & jlvl_nitr_NO2,jlvl_nitr_N2O_prod,jlvl_nitr_NH4_OM,jlvl_nitr_NO2_OM,jlvl_denit_NO3,jlvl_denit_NO2, & + & jlvl_denit_N2O,jlvl_DNRA_NO2,jlvl_anmx_N2_prod,jlvl_anmx_OM_prod,jlvl_phosy_NH4,jlvl_phosy_NO3, & + & jlvl_remin_aerob,jlvl_remin_sulf + use mo_biomod, only: nitr_NH4,nitr_NO2,nitr_N2O_prod,nitr_NH4_OM,nitr_NO2_OM,denit_NO3,denit_NO2,denit_N2O,DNRA_NO2, & + & anmx_N2_prod,anmx_OM_prod,phosy_NH4,phosy_NO3,remin_aerob,remin_sulf #endif implicit none @@ -368,7 +375,22 @@ SUBROUTINE ACCFIELDS(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask) #endif #ifdef extNcycle call acclyr(janh4,ocetra(1,1,1,ianh4),pddpo,1) - call acclyr(jano2,ocetra(1,1,1,iano2),pddpo,1) + call acclyr(jano2,ocetra(1,1,1,iano2),pddpo,1) + call acclyr(jnitr_NH4,nitr_NH4,pddpo,1) + call acclyr(jnitr_NO2,nitr_NO2,pddpo,1) + call acclyr(jnitr_N2O_prod,nitr_N2O_prod,pddpo,1) + call acclyr(jnitr_NH4_OM,nitr_NH4_OM,pddpo,1) + call acclyr(jnitr_NO2_OM,nitr_NO2_OM,pddpo,1) + call acclyr(jdenit_NO3,denit_NO3,pddpo,1) + call acclyr(jdenit_NO2,denit_NO2,pddpo,1) + call acclyr(jdenit_N2O,denit_N2O,pddpo,1) + call acclyr(jDNRA_NO2,DNRA_NO2,pddpo,1) + call acclyr(janmx_N2_prod,anmx_N2_prod,pddpo,1) + call acclyr(janmx_OM_prod,anmx_OM_prod,pddpo,1) + call acclyr(jphosy_NH4,phosy_NH4,pddpo,1) + call acclyr(jphosy_NO3,phosy_NO3,pddpo,1) + call acclyr(jremin_aerob,remin_aerob,pddpo,1) + call acclyr(jremin_sulf,remin_sulf,pddpo,1) #endif ! Accumulate level diagnostics @@ -380,7 +402,12 @@ SUBROUTINE ACCFIELDS(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask) & jlvlnatomegaa+jlvlnatomegac+jlvldic13+jlvldic14+jlvld13c+ & & jlvld14c+jlvlbigd14c+jlvlpoc13+jlvldoc13+jlvlcalc13+jlvlphyto13+& & jlvlgrazer13+jlvlnos+jlvlwphy+jlvlwnos+jlvleps+jlvlasize+ & - & jlvlcfc11+jlvlcfc12+jlvlsf6+jlvlbromo+jlvlanh4+jlvlano2).NE.0) THEN + & jlvlcfc11+jlvlcfc12+jlvlsf6+jlvlbromo+jlvlanh4+jlvlano2+ & + & jlvl_nitr_NH4+jlvl_nitr_NO2+jlvl_nitr_N2O_prod+jlvl_nitr_NH4_OM+& + & jlvl_nitr_NO2_OM+jlvl_denit_NO3+jlvl_denit_NO2+jlvl_denit_N2O+ & + & jlvl_DNRA_NO2+jlvl_anmx_N2_prod+jlvl_anmx_OM_prod+ & + & jlvl_phosy_NH4+jlvl_phosy_NO3+jlvl_remin_aerob+jlvl_remin_sulf & + & ).NE.0) THEN DO k=1,kpke call bgczlv(pddpo,k,ind1,ind2,wghts) call acclvl(jlvlphyto,ocetra(1,1,1,iphy),k,ind1,ind2,wghts) @@ -447,6 +474,22 @@ SUBROUTINE ACCFIELDS(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask) #ifdef extNcycle call acclvl(jlvlanh4,ocetra(1,1,1,ianh4),k,ind1,ind2,wghts) call acclvl(jlvlano2,ocetra(1,1,1,iano2),k,ind1,ind2,wghts) + + call acclvl(jlvl_nitr_NH4,nitr_NH4,k,ind1,ind2,wghts) + call acclvl(jlvl_nitr_NO2,nitr_NO2,k,ind1,ind2,wghts) + call acclvl(jlvl_nitr_N2O_prod,nitr_N2O_prod,k,ind1,ind2,wghts) + call acclvl(jlvl_nitr_NH4_OM,nitr_NH4_OM,k,ind1,ind2,wghts) + call acclvl(jlvl_nitr_NO2_OM,nitr_NO2_OM,k,ind1,ind2,wghts) + call acclvl(jlvl_denit_NO3,denit_NO3,k,ind1,ind2,wghts) + call acclvl(jlvl_denit_NO2,denit_NO2,k,ind1,ind2,wghts) + call acclvl(jlvl_denit_N2O,denit_N2O,k,ind1,ind2,wghts) + call acclvl(jlvl_DNRA_NO2,DNRA_NO2,k,ind1,ind2,wghts) + call acclvl(jlvl_anmx_N2_prod,anmx_N2_prod,k,ind1,ind2,wghts) + call acclvl(jlvl_anmx_OM_prod,anmx_OM_prod,k,ind1,ind2,wghts) + call acclvl(jlvl_phosy_NH4,phosy_NH4,k,ind1,ind2,wghts) + call acclvl(jlvl_phosy_NO3,phosy_NO3,k,ind1,ind2,wghts) + call acclvl(jlvl_remin_aerob,remin_aerob,k,ind1,ind2,wghts) + call acclvl(jlvl_remin_sulf,remin_sulf,k,ind1,ind2,wghts) #endif ENDDO ENDIF diff --git a/hamocc/mo_bgcmean.F90 b/hamocc/mo_bgcmean.F90 index cfdf2842..c252676c 100644 --- a/hamocc/mo_bgcmean.F90 +++ b/hamocc/mo_bgcmean.F90 @@ -121,7 +121,13 @@ MODULE mo_bgcmean & LYR_D13C =0 ,LYR_D14C =0 ,LYR_BIGD14C =0 , & & LYR_POC13 =0 ,LYR_DOC13 =0 ,LYR_CALC13 =0 , & & LYR_PHYTO13 =0 ,LYR_GRAZER13 =0 , & + ! extNcycle LYR & LYR_ANH4 =0 ,LYR_ANO2 =0 , & + & LYR_nitr_NH4 =0 ,LYR_nitr_NO2 =0 ,LYR_nitr_N2O_prod =0, & + & LYR_nitr_NH4_OM =0 ,LYR_nitr_NO2_OM =0 ,LYR_denit_NO3 =0, & + & LYR_denit_NO2 = 0 ,LYR_denit_N2O = 0 ,LYR_DNRA_NO2 =0, & + & LYR_anmx_N2_prod=0 ,LYR_anmx_OM_prod=0 ,LYR_phosy_NH4 =0, & + & LYR_phosy_NO3 = 0 ,LYR_remin_aerob =0 ,LYR_remin_sulf =0, & & LVL_PHYTO =0 ,LVL_GRAZER =0 ,LVL_DOC =0 , & & LVL_PHOSY =0 ,LVL_PHOSPH =0 ,LVL_OXYGEN =0 , & & LVL_IRON =0 ,LVL_ANO3 =0 ,LVL_ALKALI =0 , & @@ -141,7 +147,13 @@ MODULE mo_bgcmean & LVL_D13C =0 ,LVL_D14C =0 ,LVL_BIGD14C =0 , & & LVL_POC13 =0 ,LVL_DOC13 =0 ,LVL_CALC13 =0 , & & LVL_PHYTO13 =0 ,LVL_GRAZER13 =0 , & + ! extNcycle LVL & LVL_ANH4 =0 ,LVL_ANO2 =0 , & + & LVL_nitr_NH4 =0 ,LVL_nitr_NO2 =0 ,LVL_nitr_N2O_prod =0, & + & LVL_nitr_NH4_OM =0 ,LVL_nitr_NO2_OM =0 ,LVL_denit_NO3 =0, & + & LVL_denit_NO2 = 0 ,LVL_denit_N2O = 0 ,LVL_DNRA_NO2 =0, & + & LVL_anmx_N2_prod=0 ,LVL_anmx_OM_prod=0 ,LVL_phosy_NH4 =0, & + & LVL_phosy_NO3 = 0 ,LVL_remin_aerob =0 ,LVL_remin_sulf =0, & & SDM_POWAIC =0 ,SDM_POWAAL =0 ,SDM_POWAPH =0 , & & SDM_POWAOX =0 ,SDM_POWN2 =0 ,SDM_POWNO3 =0 , & & SDM_POWASI =0 ,SDM_SSSO12 =0 ,SDM_SSSSIL =0 , & @@ -199,6 +211,11 @@ MODULE mo_bgcmean & LYR_PHYTO13 ,LYR_GRAZER13 ,LYR_POC13 , & & LYR_DOC13 ,LYR_CALC13 , & & LYR_ANH4 ,LYR_ANO2 , & + & LYR_nitr_NH4 ,LYR_nitr_NO2 ,LYR_nitr_N2O_prod , & + & LYR_nitr_NH4_OM ,LYR_nitr_NO2_OM ,LYR_denit_NO3 , & + & LYR_denit_NO2 ,LYR_denit_N2O ,LYR_DNRA_NO2 , & + & LYR_anmx_N2_prod ,LYR_anmx_OM_prod ,LYR_phosy_NH4 , & + & LYR_phosy_NO3 ,LYR_remin_aerob ,LYR_remin_sulf , & & LVL_PHYTO ,LVL_GRAZER ,LVL_DOC , & & LVL_PHOSY ,LVL_PHOSPH ,LVL_OXYGEN , & & LVL_IRON ,LVL_ANO3 ,LVL_ALKALI , & @@ -219,6 +236,11 @@ MODULE mo_bgcmean & LVL_PHYTO13 ,LVL_GRAZER13 ,LVL_POC13 , & & LVL_DOC13 ,LVL_CALC13 , & & LVL_ANH4 ,LVL_ANO2 , & + & LVL_nitr_NH4 ,LVL_nitr_NO2 ,LVL_nitr_N2O_prod , & + & LVL_nitr_NH4_OM ,LVL_nitr_NO2_OM ,LVL_denit_NO3 , & + & LVL_denit_NO2 ,LVL_denit_N2O ,LVL_DNRA_NO2 , & + & LVL_anmx_N2_prod ,LVL_anmx_OM_prod ,LVL_phosy_NH4 , & + & LVL_phosy_NO3 ,LVL_remin_aerob ,LVL_remin_sulf , & & SDM_POWAIC ,SDM_POWAAL ,SDM_POWAPH , & & SDM_POWAOX ,SDM_POWN2 ,SDM_POWNO3 , & & SDM_POWASI ,SDM_SSSO12 ,SDM_SSSSIL , & @@ -470,8 +492,38 @@ MODULE mo_bgcmean INTEGER, DIMENSION(nbgcmax), SAVE :: & & janh4 = 0 , & & jano2 = 0 , & + & jnitr_NH4 = 0 , & + & jnitr_NO2 = 0 , & + & jnitr_N2O_prod = 0 , & + & jnitr_NH4_OM = 0 , & + & jnitr_NO2_OM = 0 , & + & jdenit_NO3 = 0 , & + & jdenit_NO2 = 0 , & + & jdenit_N2O = 0 , & + & jDNRA_NO2 = 0 , & + & janmx_N2_prod = 0 , & + & janmx_OM_prod = 0 , & + & jphosy_NH4 = 0 , & + & jphosy_NO3 = 0 , & + & jremin_aerob = 0 , & + & jremin_sulf = 0, & & jlvlanh4 = 0 , & - & jlvlano2 = 0 + & jlvlano2 = 0 , & + & jlvl_nitr_NH4 = 0 , & + & jlvl_nitr_NO2 = 0 , & + & jlvl_nitr_N2O_prod = 0 , & + & jlvl_nitr_NH4_OM = 0 , & + & jlvl_nitr_NO2_OM = 0 , & + & jlvl_denit_NO3 = 0 , & + & jlvl_denit_NO2 = 0 , & + & jlvl_denit_N2O = 0 , & + & jlvl_DNRA_NO2 = 0 , & + & jlvl_anmx_N2_prod = 0 , & + & jlvl_anmx_OM_prod = 0 , & + & jlvl_phosy_NH4 = 0 , & + & jlvl_phosy_NO3 = 0 , & + & jlvl_remin_aerob = 0 , & + & jlvl_remin_sulf = 0 INTEGER, SAVE :: nbgcm3d,nbgcm3dlvl @@ -883,6 +935,36 @@ SUBROUTINE ALLOC_MEM_BGCMEAN(kpie,kpje,kpke) janh4(n)=i_bsc_m3d*min(1,LYR_ANH4(n)) IF (LYR_ANO2(n).GT.0) i_bsc_m3d=i_bsc_m3d+1 jano2(n)=i_bsc_m3d*min(1,LYR_ANO2(n)) + IF (LYR_nitr_NH4(n).GT.0) i_bsc_m3d=i_bsc_m3d+1 + jnitr_NH4(n)=i_bsc_m3d*min(1,LYR_nitr_NH4(n)) + IF (LYR_nitr_NO2(n).GT.0) i_bsc_m3d=i_bsc_m3d+1 + jnitr_NO2(n)=i_bsc_m3d*min(1,LYR_nitr_NO2(n)) + IF (LYR_nitr_N2O_prod(n).GT.0) i_bsc_m3d=i_bsc_m3d+1 + jnitr_N2O_prod(n)=i_bsc_m3d*min(1,LYR_nitr_N2O_prod(n)) + IF (LYR_nitr_NH4_OM(n).GT.0) i_bsc_m3d=i_bsc_m3d+1 + jnitr_NH4_OM(n)=i_bsc_m3d*min(1,LYR_nitr_NH4_OM(n)) + IF (LYR_nitr_NO2_OM(n).GT.0) i_bsc_m3d=i_bsc_m3d+1 + jnitr_NO2_OM(n)=i_bsc_m3d*min(1,LYR_nitr_NO2_OM(n)) + IF (LYR_denit_NO3(n).GT.0) i_bsc_m3d=i_bsc_m3d+1 + jdenit_NO3(n)=i_bsc_m3d*min(1,LYR_denit_NO3(n)) + IF (LYR_denit_NO2(n).GT.0) i_bsc_m3d=i_bsc_m3d+1 + jdenit_NO2(n)=i_bsc_m3d*min(1,LYR_denit_NO2(n)) + IF (LYR_denit_N2O(n).GT.0) i_bsc_m3d=i_bsc_m3d+1 + jdenit_N2O(n)=i_bsc_m3d*min(1,LYR_denit_N2O(n)) + IF (LYR_DNRA_NO2(n).GT.0) i_bsc_m3d=i_bsc_m3d+1 + jDNRA_NO2(n)=i_bsc_m3d*min(1,LYR_DNRA_NO2(n)) + IF (LYR_anmx_N2_prod(n).GT.0) i_bsc_m3d=i_bsc_m3d+1 + janmx_N2_prod(n)=i_bsc_m3d*min(1,LYR_anmx_N2_prod(n)) + IF (LYR_anmx_OM_prod(n).GT.0) i_bsc_m3d=i_bsc_m3d+1 + janmx_OM_prod(n)=i_bsc_m3d*min(1,LYR_anmx_OM_prod(n)) + IF (LYR_phosy_NH4(n).GT.0) i_bsc_m3d=i_bsc_m3d+1 + jphosy_NH4(n)=i_bsc_m3d*min(1,LYR_phosy_NH4(n)) + IF (LYR_phosy_NO3(n).GT.0) i_bsc_m3d=i_bsc_m3d+1 + jphosy_NO3(n)=i_bsc_m3d*min(1,LYR_phosy_NO3(n)) + IF (LYR_remin_aerob(n).GT.0) i_bsc_m3d=i_bsc_m3d+1 + jremin_aerob(n)=i_bsc_m3d*min(1,LYR_remin_aerob(n)) + IF (LYR_remin_sulf(n).GT.0) i_bsc_m3d=i_bsc_m3d+1 + jremin_sulf(n)=i_bsc_m3d*min(1,LYR_remin_sulf(n)) #endif IF (LVL_PHYTO(n).GT.0) ilvl_bsc_m3d=ilvl_bsc_m3d+1 @@ -1002,6 +1084,36 @@ SUBROUTINE ALLOC_MEM_BGCMEAN(kpie,kpje,kpke) jlvlanh4(n)=ilvl_bsc_m3d*min(1,LVL_ANH4(n)) IF (LVL_ANO2(n).GT.0) ilvl_bsc_m3d=ilvl_bsc_m3d+1 jlvlano2(n)=ilvl_bsc_m3d*min(1,LVL_ANO2(n)) + IF (LVL_nitr_NH4(n).GT.0) ilvl_bsc_m3d=ilvl_bsc_m3d+1 + jlvl_nitr_NH4(n)=ilvl_bsc_m3d*min(1,LVL_nitr_NH4(n)) + IF (LVL_nitr_NO2(n).GT.0) ilvl_bsc_m3d=ilvl_bsc_m3d+1 + jlvl_nitr_NO2(n)=ilvl_bsc_m3d*min(1,LVL_nitr_NO2(n)) + IF (LVL_nitr_N2O_prod(n).GT.0) ilvl_bsc_m3d=ilvl_bsc_m3d+1 + jlvl_nitr_N2O_prod(n)=ilvl_bsc_m3d*min(1,LVL_nitr_N2O_prod(n)) + IF (LVL_nitr_NH4_OM(n).GT.0) ilvl_bsc_m3d=ilvl_bsc_m3d+1 + jlvl_nitr_NH4_OM(n)=ilvl_bsc_m3d*min(1,LVL_nitr_NH4_OM(n)) + IF (LVL_nitr_NO2_OM(n).GT.0) ilvl_bsc_m3d=ilvl_bsc_m3d+1 + jlvl_nitr_NO2_OM(n)=ilvl_bsc_m3d*min(1,LVL_nitr_NO2_OM(n)) + IF (LVL_denit_NO3(n).GT.0) ilvl_bsc_m3d=ilvl_bsc_m3d+1 + jlvl_denit_NO3(n)=ilvl_bsc_m3d*min(1,LVL_denit_NO3(n)) + IF (LVL_denit_NO2(n).GT.0) ilvl_bsc_m3d=ilvl_bsc_m3d+1 + jlvl_denit_NO2(n)=ilvl_bsc_m3d*min(1,LVL_denit_NO2(n)) + IF (LVL_denit_N2O(n).GT.0) ilvl_bsc_m3d=ilvl_bsc_m3d+1 + jlvl_denit_N2O(n)=ilvl_bsc_m3d*min(1,LVL_denit_N2O(n)) + IF (LVL_DNRA_NO2(n).GT.0) ilvl_bsc_m3d=ilvl_bsc_m3d+1 + jlvl_DNRA_NO2(n)=ilvl_bsc_m3d*min(1,LVL_DNRA_NO2(n)) + IF (LVL_anmx_N2_prod(n).GT.0) ilvl_bsc_m3d=ilvl_bsc_m3d+1 + jlvl_anmx_N2_prod(n)=ilvl_bsc_m3d*min(1,LVL_anmx_N2_prod(n)) + IF (LVL_anmx_OM_prod(n).GT.0) ilvl_bsc_m3d=ilvl_bsc_m3d+1 + jlvl_anmx_OM_prod(n)=ilvl_bsc_m3d*min(1,LVL_anmx_OM_prod(n)) + IF (LVL_phosy_NH4(n).GT.0) ilvl_bsc_m3d=ilvl_bsc_m3d+1 + jlvl_phosy_NH4(n)=ilvl_bsc_m3d*min(1,LVL_phosy_NH4(n)) + IF (LVL_phosy_NO3(n).GT.0) ilvl_bsc_m3d=ilvl_bsc_m3d+1 + jlvl_phosy_NO3(n)=ilvl_bsc_m3d*min(1,LVL_phosy_NO3(n)) + IF (LVL_remin_aerob(n).GT.0) ilvl_bsc_m3d=ilvl_bsc_m3d+1 + jlvl_remin_aerob(n)=ilvl_bsc_m3d*min(1,LVL_remin_aerob(n)) + IF (LVL_remin_sulf(n).GT.0) ilvl_bsc_m3d=ilvl_bsc_m3d+1 + jlvl_remin_sulf(n)=ilvl_bsc_m3d*min(1,LVL_remin_sulf(n)) #endif IF (i_bsc_m3d.NE.0) checkdp(n)=1 diff --git a/hamocc/mo_biomod.F90 b/hamocc/mo_biomod.F90 index 0703211d..5f373e8b 100644 --- a/hamocc/mo_biomod.F90 +++ b/hamocc/mo_biomod.F90 @@ -92,6 +92,11 @@ MODULE mo_biomod REAL, DIMENSION (:,:), ALLOCATABLE :: int_chbr3_prod REAL, DIMENSION (:,:), ALLOCATABLE :: int_chbr3_uv #endif +#ifdef extNcycle + REAL, DIMENSION (:,:,:), ALLOCATABLE :: nitr_NH4,nitr_NO2,nitr_N2O_prod,nitr_NH4_OM,nitr_NO2_OM,denit_NO3,denit_NO2, & + & denit_N2O,DNRA_NO2,anmx_N2_prod,anmx_OM_prod,phosy_NH4,phosy_NO3,remin_aerob, & + & remin_sulf +#endif REAL :: phytomi,grami,grazra,pi_alpha REAL :: remido,dyphy,zinges,epsher,spemor,gammap,gammaz,ecan @@ -385,6 +390,48 @@ SUBROUTINE ALLOC_MEM_BIOMOD(kpie,kpje,kpke) int_chbr3_uv(:,:) = 0.0 #endif +#ifdef extNcycle + IF (mnproc.eq.1) THEN + WRITE(io_stdo_bgc,*)'Memory allocation for variable of the extended nitrogen cycle ...' + WRITE(io_stdo_bgc,*)'First dimension : ',kpie + WRITE(io_stdo_bgc,*)'Second dimension : ',kpje + WRITE(io_stdo_bgc,*)'Third dimension : ',kpke + ENDIF + + ALLOCATE (nitr_NH4(kpie,kpje,kpke),stat=errstat) + ALLOCATE (nitr_NO2(kpie,kpje,kpke),stat=errstat) + ALLOCATE (nitr_N2O_prod(kpie,kpje,kpke),stat=errstat) + ALLOCATE (nitr_NH4_OM(kpie,kpje,kpke),stat=errstat) + ALLOCATE (nitr_NO2_OM(kpie,kpje,kpke),stat=errstat) + ALLOCATE (denit_NO3(kpie,kpje,kpke),stat=errstat) + ALLOCATE (denit_NO2(kpie,kpje,kpke),stat=errstat) + ALLOCATE (denit_N2O(kpie,kpje,kpke),stat=errstat) + ALLOCATE (DNRA_NO2(kpie,kpje,kpke),stat=errstat) + ALLOCATE (anmx_N2_prod(kpie,kpje,kpke),stat=errstat) + ALLOCATE (anmx_OM_prod(kpie,kpje,kpke),stat=errstat) + ALLOCATE (phosy_NH4(kpie,kpje,kpke),stat=errstat) + ALLOCATE (phosy_NO3(kpie,kpje,kpke),stat=errstat) + ALLOCATE (remin_aerob(kpie,kpje,kpke),stat=errstat) + ALLOCATE (remin_sulf(kpie,kpje,kpke),stat=errstat) + + if(errstat.ne.0) stop 'not enough memory extended nitrogen cycle' + nitr_NH4 = 0. + nitr_NO2 = 0. + nitr_N2O_prod = 0. + nitr_NH4_OM = 0. + nitr_NO2_OM = 0. + denit_NO3 = 0. + denit_NO2 = 0. + denit_N2O = 0. + DNRA_NO2 = 0. + anmx_N2_prod = 0. + anmx_OM_prod = 0. + phosy_NH4 = 0. + phosy_NO3 = 0. + remin_aerob = 0. + remin_sulf = 0. +#endif + !****************************************************************************** END SUBROUTINE ALLOC_MEM_BIOMOD diff --git a/hamocc/mo_extNbioproc.F90 b/hamocc/mo_extNbioproc.F90 index 84c5b540..4590d08a 100644 --- a/hamocc/mo_extNbioproc.F90 +++ b/hamocc/mo_extNbioproc.F90 @@ -52,7 +52,8 @@ MODULE mo_extNbioproc use mo_control_bgc, only: io_stdo_bgc,dtb use mo_param1_bgc, only: ialkali,ianh4,iano2,ian2o,iano3,idet,igasnit,iiron,ioxygen,iphosph,isco212 use mo_carbch, only: ocetra - use mo_biomod, only: riron,rnit,rcar,rnoi + use mo_biomod, only: riron,rnit,rcar,rnoi, nitr_NH4,nitr_NO2,nitr_N2O_prod,nitr_NH4_OM,nitr_NO2_OM,denit_NO3,denit_NO2, & + & denit_N2O,DNRA_NO2,anmx_N2_prod,anmx_OM_prod implicit none @@ -191,6 +192,13 @@ subroutine nitrification(kpie,kpje,kpke,kbnd,pddpo,omask,ptho) minlim_nh4 = bkanh4nitr*minlim/(1. - minlim) minlim_no2 = bkano2nitr*minlim/(1. - minlim) + ! Set output-related fields to zero + nitr_NH4 = 0. + nitr_NO2 = 0. + nitr_N2O_prod = 0. + nitr_NH4_OM = 0. + nitr_NO2_OM = 0. + !$OMP PARALLEL DO PRIVATE(i,k,Tdepanh4,O2limanh4,nut1lim,anh4new,potdnh4amox,fdetamox,fno2,fn2o,ftotnh4, & !$OMP Tdepano2,O2limano2,nut2lim,ano2new,potdno2nitr,fdetnitr,fno3,ftotno2,amoxfrac, & !$OMP nitrfrac,totd,amox,nitr,temp) @@ -276,6 +284,13 @@ subroutine nitrification(kpie,kpje,kpke,kbnd,pddpo,omask,ptho) ocetra(i,j,k,ioxygen) = ocetra(i,j,k,ioxygen) - (1.5*fno2 + fn2o - ro2nnit*fdetamox)*amox & & - (0.5*fno3 - ro2nnit*fdetnitr)*nitr ocetra(i,j,k,ialkali) = ocetra(i,j,k,ialkali) - (2.*fno2 + fn2o + rnm1*rnoi*fdetamox)*amox - rnm1*rnoi*fdetnitr*nitr + + ! Output + nitr_NH4(i,j,k) = amox ! kmol N/m3/dtb - NH4 consumption for nitrification on NH4-incl. usage for biomass + nitr_NO2(i,j,k) = nitr ! kmol N/m3/dtb - NO2 consumption for nitrification on NO2 + nitr_N2O_prod(i,j,k) = 0.5*fn2o*amox ! kmol N2O/m3/dtb - N2O production during aerob ammonium oxidation + nitr_NH4_OM(i,j,k) = rnoi*fdetamox*amox ! kmol P/m3/dtb - organic matter production during aerob NH4 oxidation + nitr_NO2_OM(i,j,k) = rnoi*fdetnitr*nitr ! kmol P/m3/dtb - organic matter production during aerob NO2 oxidation endif enddo enddo @@ -302,6 +317,9 @@ subroutine denit_NO3_to_NO2(kpie,kpje,kpke,kbnd,pddpo,omask,ptho) minlim_ox = log(2./minlim-1.)/(2.*sc_ano3denit) minlim_no3 = bkano3denit*minlim/(1.-minlim) + ! Sett output-related field to zero + denit_NO3 = 0. + !$OMP PARALLEL DO PRIVATE(i,k,Tdep,O2inhib,nutlim,ano3new,ano3denit,temp) do j = 1,kpje do i = 1,kpie @@ -324,7 +342,10 @@ subroutine denit_NO3_to_NO2(kpie,kpje,kpke,kbnd,pddpo,omask,ptho) ocetra(i,j,k,isco212) = ocetra(i,j,k,isco212) + ano3denit*rcar*rnoxpi ocetra(i,j,k,iphosph) = ocetra(i,j,k,iphosph) + ano3denit*rnoxpi ocetra(i,j,k,iiron) = ocetra(i,j,k,iiron) + ano3denit*riron*rnoxpi - ocetra(i,j,k,ialkali) = ocetra(i,j,k,ialkali) + ano3denit*rnm1*rnoxpi + ocetra(i,j,k,ialkali) = ocetra(i,j,k,ialkali) + ano3denit*rnm1*rnoxpi + + ! Output + denit_NO3(i,j,k) = ano3denit ! kmol NO3/m3/dtb - NO3 usage for denit on NO3 endif endif enddo @@ -353,6 +374,10 @@ subroutine anammox(kpie,kpje,kpke,kbnd,pddpo,omask,ptho) minlim_nh4 = bkanh4anmx*minlim/(1.-minlim) minlim_no2 = bkano2anmx*minlim/(1.-minlim) + ! Set output-related field to zero + anmx_N2_prod = 0. + anmx_OM_prod = 0. + !$OMP PARALLEL DO PRIVATE(i,k,Tdep,O2inhib,nut1lim,nut2lim,ano2new,ano2anmx,temp) do j = 1,kpje do i = 1,kpie @@ -380,6 +405,10 @@ subroutine anammox(kpie,kpje,kpke,kbnd,pddpo,omask,ptho) ocetra(i,j,k,iphosph) = ocetra(i,j,k,iphosph) - ano2anmx*rno2anmxi ocetra(i,j,k,iiron) = ocetra(i,j,k,iiron) - ano2anmx*riron*rno2anmxi ocetra(i,j,k,ialkali) = ocetra(i,j,k,ialkali) - ano2anmx*rnm1*rno2anmxi + + ! Output + anmx_N2_prod(i,j,k) = ano2anmx*(rnh4anmx-rnit)*rno2anmxi ! kmol N2/m3/dtb - N2 prod through anammox + anmx_OM_prod(i,j,k) = ano2anmx*rno2anmxi ! kmol P/m3/dtb - OM production by anammox endif endif enddo @@ -414,6 +443,11 @@ subroutine denit_dnra(kpie,kpje,kpke,kbnd,pddpo,omask,ptho) minlim_oxn2o = bkoxan2odenit/sqrt(minlim) minlim_no2 = min(bkdnra,bkano2denit)*minlim/(1. - minlim) minlim_n2o = bkan2odenit*minlim/(1. - minlim) + + ! Set output-related field to zero + denit_NO2 = 0. + denit_N2O = 0. + DNRA_NO2 = 0. !$OMP PARALLEL DO PRIVATE(i,k,Tdepano2,O2inhibano2,nutlimano2,detlimano2,ano2denit, & !$OMP Tdepan2o,O2inhiban2o,nutliman2o,detliman2o,an2onew,an2odenit, & @@ -493,6 +527,10 @@ subroutine denit_dnra(kpie,kpje,kpke,kbnd,pddpo,omask,ptho) ocetra(i,j,k,iiron) = ocetra(i,j,k,iiron) + riron*rnoxpi*(ano2denit + an2odenit) + riron*rno2dnrai*ano2dnra ocetra(i,j,k,ialkali) = ocetra(i,j,k,ialkali) + (295.*ano2denit + rnm1*an2odenit)*rnoxpi & & + (rno2dnra + rnh4dnra - 1.)*rno2dnrai * ano2dnra + ! Output + denit_NO2(i,j,k) = ano2denit ! kmol NO2/m3/dtb - denitrification on NO2 + denit_N2O(i,j,k) = an2odenit ! kmol N2O/m3/dtb - denitrification on N2O + DNRA_NO2(i,j,k) = ano2dnra ! kmol NO2/m3/dtb - DNRA on NO2 endif endif enddo diff --git a/hamocc/ncout_hamocc.F b/hamocc/ncout_hamocc.F index 45174731..193bd715 100644 --- a/hamocc/ncout_hamocc.F +++ b/hamocc/ncout_hamocc.F @@ -164,7 +164,31 @@ subroutine ncwrt_bgc(iogrp) use mo_bgcmean, only: janh4,jano2,jlvlanh4,jlvlano2,jsrfanh4, . jsrfano2,janh3fx,srf_anh4,srf_ano2, . srf_anh3fx,lyr_anh4,lyr_ano2,lvl_anh4, - . lvl_ano2 + . lvl_ano2, + . LYR_nitr_NH4,LYR_nitr_NO2,LYR_nitr_N2O_prod, + . LYR_nitr_NH4_OM,LYR_nitr_NO2_OM, + . LYR_denit_NO3,LYR_denit_NO2,LYR_denit_N2O, + . LYR_DNRA_NO2,LYR_anmx_N2_prod, + . LYR_anmx_OM_prod,LYR_phosy_NH4, + . LYR_phosy_NO3,LYR_remin_aerob,LYR_remin_sulf, + . LVL_nitr_NH4,LVL_nitr_NO2,LVL_nitr_N2O_prod, + . LVL_nitr_NH4_OM,LVL_nitr_NO2_OM, + . LVL_denit_NO3,LVL_denit_NO2,LVL_denit_N2O, + . LVL_DNRA_NO2,LVL_anmx_N2_prod, + . LVL_anmx_OM_prod,LVL_phosy_NH4, + . LVL_phosy_NO3,LVL_remin_aerob,LVL_remin_sulf, + . jnitr_NH4,jnitr_NO2,jnitr_N2O_prod, + . jnitr_NH4_OM,jnitr_NO2_OM,jdenit_NO3, + . jdenit_NO2,jdenit_N2O,jDNRA_NO2, + . janmx_N2_prod,janmx_OM_prod,jphosy_NH4, + . jphosy_NO3,jremin_aerob,jremin_sulf, + . jlvl_nitr_NH4,jlvl_nitr_NO2, + . jlvl_nitr_N2O_prod,jlvl_nitr_NH4_OM, + . jlvl_nitr_NO2_OM,jlvl_denit_NO3, + . jlvl_denit_NO2,jlvl_denit_N2O,jlvl_DNRA_NO2, + . jlvl_anmx_N2_prod,jlvl_anmx_OM_prod, + . jlvl_phosy_NH4,jlvl_phosy_NO3, + . jlvl_remin_aerob,jlvl_remin_sulf #endif c implicit none @@ -740,6 +764,54 @@ subroutine ncwrt_bgc(iogrp) . 'nh4','Ammonium',' ','mol N m-3') call wrtlyr(jano2(iogrp),LYR_ANO2(iogrp),1e3,0.,cmpflg, . 'no2','Nitrite',' ','mol N m-3') + call wrtlyr(jnitr_NH4(iogrp),LYR_nitr_NH4(iogrp),1e3/dtbgc,0., + . cmpflg, + . 'nh4nitr','NH4 nitrification rate',' ','mol N m-3 s-1') + call wrtlyr(jnitr_NO2(iogrp),LYR_nitr_NO2(iogrp),1e3/dtbgc,0., + . cmpflg, + . 'no2nitr','NO2 nitrification rate',' ','mol N m-3 s-1') + call wrtlyr(jnitr_N2O_prod(iogrp),LYR_nitr_N2O_prod(iogrp), + . 1e3/dtbgc,0.,cmpflg, + . 'nitr_n2o','N2O prod during NH4 nitrification',' ', + . 'mol N2O m-3 s-1') + call wrtlyr(jnitr_NH4_OM(iogrp),LYR_nitr_NH4_OM(iogrp),1e3/dtbgc, + . 0.,cmpflg, + . 'nh4nitr_om','OM production during NH4 nitrification',' ', + . 'mol P m-3 s-1') + call wrtlyr(jnitr_NO2_OM(iogrp),LYR_nitr_NO2_OM(iogrp),1e3/dtbgc, + . 0.,cmpflg, + . 'no2nitr_om','OM production during NO2 nitrification',' ', + . 'mol P m-3 s-1') + call wrtlyr(jdenit_NO3(iogrp),LYR_denit_NO3(iogrp),1e3/dtbgc,0., + . cmpflg, + . 'no3denit','NO3 denitrification rate',' ','mol N m-3 s-1') + call wrtlyr(jdenit_NO2(iogrp),LYR_denit_NO2(iogrp),1e3/dtbgc,0., + . cmpflg, + . 'no2denit','NO2 denitrification rate',' ','mol N m-3 s-1') + call wrtlyr(jdenit_N2O(iogrp),LYR_denit_N2O(iogrp),1e3/dtbgc,0., + . cmpflg, + . 'n2odenit','N2O denitrification rate',' ','mol N2O m-3 s-1') + call wrtlyr(jDNRA_NO2(iogrp),LYR_DNRA_NO2(iogrp),1e3/dtbgc,0., + . cmpflg, + . 'no2dnra','NO2 DNRA rate',' ','mol N m-3 s-1') + call wrtlyr(janmx_N2_prod(iogrp),LYR_anmx_N2_prod(iogrp), + . 1e3/dtbgc,0.,cmpflg, + . 'anmx_n2','Anammox N2 production rate',' ','mol N2 m-3 s-1') + call wrtlyr(janmx_OM_prod(iogrp),LYR_anmx_OM_prod(iogrp), + . 1e3/dtbgc,0.,cmpflg, + . 'anmx_om','Anammox OM production rate',' ','mol P m-3 s-1') + call wrtlyr(jphosy_NH4(iogrp),LYR_phosy_NH4(iogrp),1e3/dtbgc,0., + . cmpflg, + . 'phosy_nh4','PP consumption rate of NH4',' ','mol N m-3 s-1') + call wrtlyr(jphosy_NO3(iogrp),LYR_phosy_NO3(iogrp),1e3/dtbgc,0., + . cmpflg, + . 'phosy_no3','PP consumption rate of NO3',' ','mol N m-3 s-1') + call wrtlyr(jremin_aerob(iogrp),LYR_remin_aerob(iogrp),1e3/dtbgc, + . 0.,cmpflg, + . 'remina','Aerob remineralization rate',' ','mol N m-3 s-1') + call wrtlyr(jremin_sulf(iogrp),LYR_remin_sulf(iogrp),1e3/dtbgc, + . 0.,cmpflg, + . 'remins','Sulfate remineralization rate',' ','mol P m-3 s-1') #endif c c --- Store 3d level fields @@ -872,6 +944,56 @@ subroutine ncwrt_bgc(iogrp) . 'nh4lvl','Ammonium',' ','mol N m-3') call wrtlvl(jlvlano2(iogrp),LVL_ANO2(iogrp),rnacc*1e3,0.,cmpflg, . 'no2lvl','Nitrite',' ','mol N m-3') + call wrtlvl(jlvl_nitr_NH4(iogrp),LVL_nitr_NH4(iogrp), + . rnacc*1e3/dtbgc,0.,cmpflg, + . 'nh4nitrlvl','NH4 nitrification rate',' ','mol N m-3 s-1') + call wrtlvl(jlvl_nitr_NO2(iogrp),LVL_nitr_NO2(iogrp), + . rnacc*1e3/dtbgc,0.,cmpflg, + . 'no2nitrlvl','NO2 nitrification rate',' ','mol N m-3 s-1') + call wrtlvl(jlvl_nitr_N2O_prod(iogrp),LVL_nitr_N2O_prod(iogrp), + . rnacc*1e3/dtbgc,0.,cmpflg, + . 'nitr_n2olvl','N2O prod during NH4 nitrification',' ', + . 'mol N2O m-3 s-1') + call wrtlvl(jlvl_nitr_NH4_OM(iogrp),LVL_nitr_NH4_OM(iogrp), + . rnacc*1e3/dtbgc,0.,cmpflg, + . 'nh4nitr_omlvl','OM production during NH4 nitrification',' ', + . 'mol P m-3 s-1') + call wrtlvl(jlvl_nitr_NO2_OM(iogrp),LVL_nitr_NO2_OM(iogrp), + . rnacc*1e3/dtbgc,0.,cmpflg, + . 'no2nitr_omlvl','OM production during NO2 nitrification',' ', + . 'mol P m-3 s-1') + call wrtlvl(jlvl_denit_NO3(iogrp),LVL_denit_NO3(iogrp), + . rnacc*1e3/dtbgc,0.,cmpflg, + . 'no3denitlvl','NO3 denitrification rate',' ','mol N m-3 s-1') + call wrtlvl(jlvl_denit_NO2(iogrp),LVL_denit_NO2(iogrp), + . rnacc*1e3/dtbgc,0.,cmpflg, + . 'no2denitlvl','NO2 denitrification rate',' ','mol N m-3 s-1') + call wrtlvl(jlvl_denit_N2O(iogrp),LVL_denit_N2O(iogrp), + . rnacc*1e3/dtbgc,0.,cmpflg, + . 'n2odenitlvl','N2O denitrification rate',' ','mol N2O m-3 s-1') + call wrtlvl(jlvl_DNRA_NO2(iogrp),LVL_DNRA_NO2(iogrp), + . rnacc*1e3/dtbgc,0.,cmpflg, + . 'no2dnralvl','NO2 DNRA rate',' ','mol N m-3 s-1') + call wrtlvl(jlvl_anmx_N2_prod(iogrp),LVL_anmx_N2_prod(iogrp), + . rnacc*1e3/dtbgc,0.,cmpflg, + . 'anmx_n2lvl','Anammox N2 production rate',' ','mol N2 m-3 s-1') + call wrtlvl(jlvl_anmx_OM_prod(iogrp),LVL_anmx_OM_prod(iogrp), + . rnacc*1e3/dtbgc,0.,cmpflg, + . 'anmx_omlvl','Anammox OM production rate',' ','mol P m-3 s-1') + call wrtlvl(jlvl_phosy_NH4(iogrp),LVL_phosy_NH4(iogrp), + . rnacc*1e3/dtbgc,0.,cmpflg, + . 'phosy_nh4lvl','PP consumption rate of NH4',' ', + . 'mol N m-3 s-1') + call wrtlvl(jlvl_phosy_NO3(iogrp),LVL_phosy_NO3(iogrp), + . rnacc*1e3/dtbgc,0.,cmpflg, + . 'phosy_no3lvl','PP consumption rate of NO3',' ', + . 'mol N m-3 s-1') + call wrtlvl(jlvl_remin_aerob(iogrp),LVL_remin_aerob(iogrp), + . rnacc*1e3/dtbgc,0.,cmpflg, + . 'reminalvl','Aerob remineralization rate',' ','mol N m-3 s-1') + call wrtlvl(jlvl_remin_sulf(iogrp),LVL_remin_sulf(iogrp), + . rnacc*1e3/dtbgc,0.,cmpflg, + . 'reminslvl','Sulfate remineralization rate',' ','mol P m-3 s-1') #endif c @@ -1073,7 +1195,22 @@ subroutine ncwrt_bgc(iogrp) #endif #ifdef extNcycle call inilyr(janh4(iogrp),0.) - call inilyr(jano2(iogrp),0.) + call inilyr(jano2(iogrp),0.) + call inilyr(jnitr_NH4(iogrp),0.) + call inilyr(jnitr_NO2(iogrp),0.) + call inilyr(jnitr_N2O_prod(iogrp),0.) + call inilyr(jnitr_NH4_OM(iogrp),0.) + call inilyr(jnitr_NO2_OM(iogrp),0.) + call inilyr(jdenit_NO3(iogrp),0.) + call inilyr(jdenit_NO2(iogrp),0.) + call inilyr(jdenit_N2O(iogrp),0.) + call inilyr(jDNRA_NO2(iogrp),0.) + call inilyr(janmx_N2_prod(iogrp),0.) + call inilyr(janmx_OM_prod(iogrp),0.) + call inilyr(jphosy_NH4(iogrp),0.) + call inilyr(jphosy_NO3(iogrp),0.) + call inilyr(jremin_aerob(iogrp),0.) + call inilyr(jremin_sulf(iogrp),0.) #endif c call inilvl(jlvldic(iogrp),0.) @@ -1140,6 +1277,21 @@ subroutine ncwrt_bgc(iogrp) #ifdef extNcycle call inilvl(jlvlanh4(iogrp),0.) call inilvl(jlvlano2(iogrp),0.) + call inilvl(jlvl_nitr_NH4(iogrp),0.) + call inilvl(jlvl_nitr_NO2(iogrp),0.) + call inilvl(jlvl_nitr_N2O_prod(iogrp),0.) + call inilvl(jlvl_nitr_NH4_OM(iogrp),0.) + call inilvl(jlvl_nitr_NO2_OM(iogrp),0.) + call inilvl(jlvl_denit_NO3(iogrp),0.) + call inilvl(jlvl_denit_NO2(iogrp),0.) + call inilvl(jlvl_denit_N2O(iogrp),0.) + call inilvl(jlvl_DNRA_NO2(iogrp),0.) + call inilvl(jlvl_anmx_N2_prod(iogrp),0.) + call inilvl(jlvl_anmx_OM_prod(iogrp),0.) + call inilvl(jlvl_phosy_NH4(iogrp),0.) + call inilvl(jlvl_phosy_NO3(iogrp),0.) + call inilvl(jlvl_remin_aerob(iogrp),0.) + call inilvl(jlvl_remin_sulf(iogrp),0.) #endif c #ifndef sedbypass @@ -1231,7 +1383,31 @@ subroutine hamoccvardef(iogrp,timeunits,calendar,cmpflg) use mo_bgcmean, only: janh4,jano2,jlvlanh4,jlvlano2,jsrfanh4, . jsrfano2,janh3fx,srf_anh4,srf_ano2, . srf_anh3fx,lyr_anh4,lyr_ano2,lvl_anh4, - . lvl_ano2 + . lvl_ano2, + . LYR_nitr_NH4,LYR_nitr_NO2,LYR_nitr_N2O_prod, + . LYR_nitr_NH4_OM,LYR_nitr_NO2_OM, + . LYR_denit_NO3,LYR_denit_NO2,LYR_denit_N2O, + . LYR_DNRA_NO2,LYR_anmx_N2_prod, + . LYR_anmx_OM_prod,LYR_phosy_NH4, + . LYR_phosy_NO3,LYR_remin_aerob,LYR_remin_sulf, + . LVL_nitr_NH4,LVL_nitr_NO2,LVL_nitr_N2O_prod, + . LVL_nitr_NH4_OM,LVL_nitr_NO2_OM, + . LVL_denit_NO3,LVL_denit_NO2,LVL_denit_N2O, + . LVL_DNRA_NO2,LVL_anmx_N2_prod, + . LVL_anmx_OM_prod,LVL_phosy_NH4, + . LVL_phosy_NO3,LVL_remin_aerob,LVL_remin_sulf, + . jnitr_NH4,jnitr_NO2,jnitr_N2O_prod, + . jnitr_NH4_OM,jnitr_NO2_OM,jdenit_NO3, + . jdenit_NO2,jdenit_N2O,jDNRA_NO2, + . janmx_N2_prod,janmx_OM_prod,jphosy_NH4, + . jphosy_NO3,jremin_aerob,jremin_sulf, + . jlvl_nitr_NH4,jlvl_nitr_NO2, + . jlvl_nitr_N2O_prod,jlvl_nitr_NH4_OM, + . jlvl_nitr_NO2_OM,jlvl_denit_NO3, + . jlvl_denit_NO2,jlvl_denit_N2O,jlvl_DNRA_NO2, + . jlvl_anmx_N2_prod,jlvl_anmx_OM_prod, + . jlvl_phosy_NH4,jlvl_phosy_NO3, + . jlvl_remin_aerob,jlvl_remin_sulf #endif implicit none @@ -1549,6 +1725,39 @@ subroutine hamoccvardef(iogrp,timeunits,calendar,cmpflg) . 'nh4','Ammonium',' ','mol N m-3',1) call ncdefvar3d(LYR_ANO2(iogrp),cmpflg,'p', . 'no2','Nitrite',' ','mol N m-3',1) + call ncdefvar3d(LYR_nitr_NH4(iogrp),cmpflg,'p', + . 'nh4nitr','NH4 nitrification rate',' ','mol N m-3 s-1',1) + call ncdefvar3d(LYR_nitr_NO2(iogrp),cmpflg,'p', + . 'no2nitr','NO2 nitrification rate',' ','mol N m-3 s-1',1) + call ncdefvar3d(LYR_nitr_N2O_prod(iogrp),cmpflg,'p', + . 'nitr_n2o','N2O prod during NH4 nitrification',' ', + . 'mol N2O m-3 s-1',1) + call ncdefvar3d(LYR_nitr_NH4_OM(iogrp),cmpflg,'p', + . 'nh4nitr_om','OM production during NH4 nitrification',' ', + . 'mol P m-3 s-1',1) + call ncdefvar3d(LYR_nitr_NO2_OM(iogrp),cmpflg,'p', + . 'no2nitr_om','OM production during NO2 nitrification',' ', + . 'mol P m-3 s-1',1) + call ncdefvar3d(LYR_denit_NO3(iogrp),cmpflg,'p', + . 'no3denit','NO3 denitrification rate',' ','mol N m-3 s-1',1) + call ncdefvar3d(LYR_denit_NO2(iogrp),cmpflg,'p', + . 'no2denit','NO2 denitrification rate',' ','mol N m-3 s-1',1) + call ncdefvar3d(LYR_denit_N2O(iogrp),cmpflg,'p', + . 'n2odenit','N2O denitrification rate',' ','mol N2O m-3 s-1',1) + call ncdefvar3d(LYR_DNRA_NO2(iogrp),cmpflg,'p', + . 'no2dnra','NO2 DNRA rate',' ','mol N m-3 s-1',1) + call ncdefvar3d(LYR_anmx_N2_prod(iogrp),cmpflg,'p', + . 'anmx_n2','Anammox N2 production rate',' ','mol N2 m-3 s-1',1) + call ncdefvar3d(LYR_anmx_OM_prod(iogrp),cmpflg,'p', + . 'anmx_om','Anammox OM production rate',' ','mol P m-3 s-1',1) + call ncdefvar3d(LYR_phosy_NH4(iogrp),cmpflg,'p', + . 'phosy_nh4','PP consumption rate of NH4',' ','mol N m-3 s-1',1) + call ncdefvar3d(LYR_phosy_NO3(iogrp),cmpflg,'p', + . 'phosy_no3','PP consumption rate of NO3',' ','mol N m-3 s-1',1) + call ncdefvar3d(LYR_remin_aerob(iogrp),cmpflg,'p', + . 'remina','Aerob remineralization rate',' ','mol N m-3 s-1',1) + call ncdefvar3d(LYR_remin_sulf(iogrp),cmpflg,'p', + . 'remins','Sulfate remineralization rate',' ','mol P m-3 s-1',1) #endif c c --- define 3d level fields @@ -1669,6 +1878,46 @@ subroutine hamoccvardef(iogrp,timeunits,calendar,cmpflg) . 'nh4lvl','Ammonium',' ','mol N m-3',2) call ncdefvar3d(LVL_ANO2(iogrp),cmpflg,'p', . 'no2lvl','Nitrite',' ','mol N m-3',2) + + call ncdefvar3d(LVL_nitr_NH4(iogrp),cmpflg,'p', + . 'nh4nitrlvl','NH4 nitrification rate',' ','mol N m-3 s-1',2) + call ncdefvar3d(LVL_nitr_NO2(iogrp),cmpflg,'p', + . 'no2nitrlvl','NO2 nitrification rate',' ','mol N m-3 s-1',2) + call ncdefvar3d(LVL_nitr_N2O_prod(iogrp),cmpflg,'p', + . 'nitr_n2olvl','N2O prod during NH4 nitrification',' ', + . 'mol N2O m-3 s-1',2) + call ncdefvar3d(LVL_nitr_NH4_OM(iogrp),cmpflg,'p', + . 'nh4nitr_omlvl','OM production during NH4 nitrification',' ', + . 'mol P m-3 s-1',2) + call ncdefvar3d(LVL_nitr_NO2_OM(iogrp),cmpflg,'p', + . 'no2nitr_omlvl','OM production during NO2 nitrification',' ', + . 'mol P m-3 s-1',2) + call ncdefvar3d(LVL_denit_NO3(iogrp),cmpflg,'p', + . 'no3denitlvl','NO3 denitrification rate',' ','mol N m-3 s-1',2) + call ncdefvar3d(LVL_denit_NO2(iogrp),cmpflg,'p', + . 'no2denitlvl','NO2 denitrification rate',' ','mol N m-3 s-1',2) + call ncdefvar3d(LVL_denit_N2O(iogrp),cmpflg,'p', + . 'n2odenitlvl','N2O denitrification rate',' ', + . 'mol N2O m-3 s-1',2) + call ncdefvar3d(LVL_DNRA_NO2(iogrp),cmpflg,'p', + . 'no2dnralvl','NO2 DNRA rate',' ','mol N m-3 s-1',2) + call ncdefvar3d(LVL_anmx_N2_prod(iogrp),cmpflg,'p', + . 'anmx_n2lvl','Anammox N2 production rate',' ', + . 'mol N2 m-3 s-1',2) + call ncdefvar3d(LVL_anmx_OM_prod(iogrp),cmpflg,'p', + . 'anmx_omlvl','Anammox OM production rate',' ','mol P m-3 s-1',2) + call ncdefvar3d(LVL_phosy_NH4(iogrp),cmpflg,'p', + . 'phosy_nh4lvl','PP consumption rate of NH4',' ', + . 'mol N m-3 s-1',2) + call ncdefvar3d(LVL_phosy_NO3(iogrp),cmpflg,'p', + . 'phosy_no3lvl','PP consumption rate of NO3',' ', + . 'mol N m-3 s-1',2) + call ncdefvar3d(LVL_remin_aerob(iogrp),cmpflg,'p', + . 'reminalvl','Aerob remineralization rate',' ', + . 'mol N m-3 s-1',2) + call ncdefvar3d(LVL_remin_sulf(iogrp),cmpflg,'p', + . 'reminslvl','Sulfate remineralization rate',' ', + . 'mol P m-3 s-1',2) #endif c c --- define sediment fields diff --git a/hamocc/ocprod.F90 b/hamocc/ocprod.F90 index 8e39a7a0..e1fe9879 100644 --- a/hamocc/ocprod.F90 +++ b/hamocc/ocprod.F90 @@ -124,6 +124,7 @@ subroutine ocprod(kpie,kpje,kpke,kbnd,pdlxp,pdlyp,pddpo,omask,ptho,pi_ph) use mo_extNbioproc, only: nitrification,denit_NO3_to_NO2,anammox,denit_dnra,extN_inv_check use mo_extNbioproc, only: bkphyanh4,bkphyano3,bkphosph,bkiron,ro2utammo use mo_param1_bgc, only: ianh4 + use mo_biomod, only: phosy_NH4, phosy_NO3, remin_aerob,remin_sulf #endif @@ -238,6 +239,12 @@ subroutine ocprod(kpie,kpje,kpke,kbnd,pdlxp,pdlyp,pddpo,omask,ptho,pi_ph) eps3d(:,:,:) = 0. asize3d(:,:,:) = 0. #endif +#ifdef extNcycle + phosy_NH4(:,:,:) = 0. + phosy_NO3(:,:,:) = 0. + remin_aerob(:,:,:) = 0. + remin_sulf(:,:,:) = 0. +#endif ! parameter for DMS scheme (dmspar defined in BELEG_PARM) dmsp6 = dmspar(6) @@ -490,6 +497,10 @@ subroutine ocprod(kpie,kpje,kpke,kbnd,pdlxp,pdlyp,pddpo,omask,ptho,pi_ph) ocetra(i,j,k,ioxygen) = ocetra(i,j,k,ioxygen) + nh4uptfrac*phosy*ro2utammo & ! NH4 uptake & + (1.-nh4uptfrac)*phosy*ro2ut & ! NO3 uptake & - (dtr+phosy)*ro2utammo ! Remin to NH4 + ! Output + phosy_NH4(i,j,k) = nh4uptfrac*phosy*rnit ! kmol N/m3/dtb - NH4 uptake during PP growth + phosy_NO3(i,j,k) = (1.-nh4uptfrac)*phosy*rnit ! kmol N/m3/dtb - NO3 uptake during PP growth + remin_aerob(i,j,k) = (dtr+phosy)*rnit ! kmol N/m3/dtb - Aerob remin to ammonium (var. sources) #endif ocetra(i,j,k,idet) = ocetra(i,j,k,idet)+export ocetra(i,j,k,idms) = ocetra(i,j,k,idms)+dmsprod-dms_bac-dms_uv @@ -700,6 +711,7 @@ subroutine ocprod(kpie,kpje,kpke,kbnd,pdlxp,pdlyp,pddpo,omask,ptho,pi_ph) ocetra(i,j,k,ianh4) = ocetra(i,j,k,ianh4) + remin*rnit ocetra(i,j,k,ialkali) = ocetra(i,j,k,ialkali) + (rnit-1.)*remin ocetra(i,j,k,ioxygen) = ocetra(i,j,k,ioxygen) - ro2utammo*remin + remin_aerob(i,j,k) = remin*rnit ! kmol/NH4/dtb - remin to NH4 from various sources #endif ocetra(i,j,k,isco212) = ocetra(i,j,k,isco212)+rcar*remin ocetra(i,j,k,iiron) = ocetra(i,j,k,iiron)+remin*riron & @@ -926,7 +938,10 @@ subroutine ocprod(kpie,kpje,kpke,kbnd,pdlxp,pdlyp,pddpo,omask,ptho,pi_ph) ocetra(i,j,k,isco213) = ocetra(i,j,k,isco213)+rcar*rem13 ocetra(i,j,k,isco214) = ocetra(i,j,k,isco214)+rcar*rem14 #endif - +#ifdef extNcycle + ! Output + remin_sulf(i,j,k) = remin ! kmol P/m3/dtb +#endif #ifdef AGG !*********************************************************************** ! loss of snow numbers due to remineralization of poc From 64388a6141f2c19952948eeb72869e7d0d9de157 Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Tue, 28 Jun 2022 16:15:36 +0200 Subject: [PATCH 121/366] **FIX** nitrification --- hamocc/mo_extNbioproc.F90 | 32 ++++++++++++++++---------------- 1 file changed, 16 insertions(+), 16 deletions(-) diff --git a/hamocc/mo_extNbioproc.F90 b/hamocc/mo_extNbioproc.F90 index 4590d08a..88b935b1 100644 --- a/hamocc/mo_extNbioproc.F90 +++ b/hamocc/mo_extNbioproc.F90 @@ -182,7 +182,7 @@ subroutine nitrification(kpie,kpje,kpke,kbnd,pddpo,omask,ptho) !local variables integer :: i,j,k real :: Tdepanh4,O2limanh4,nut1lim,anh4new,potdnh4amox,fdetamox,fno2,fn2o,ftotnh4 - real :: Tdepano2,O2limano2,nut2lim,ano2new,potdno2nitr,fdetnitr,fno3,ftotno2 + real :: Tdepano2,O2limano2,nut2lim,ano2new,potdno2nitr,fdetnitr,ftotno2,no2fn2o,no2fno2,no2fdetamox real :: amoxfrac,nitrfrac,totd,amox,nitr,temp real :: minlim_oxnh4,minlim_nh4,minlim_oxno2,minlim_no2 ! minimum conc for limitation functions @@ -200,8 +200,8 @@ subroutine nitrification(kpie,kpje,kpke,kbnd,pddpo,omask,ptho) nitr_NO2_OM = 0. !$OMP PARALLEL DO PRIVATE(i,k,Tdepanh4,O2limanh4,nut1lim,anh4new,potdnh4amox,fdetamox,fno2,fn2o,ftotnh4, & - !$OMP Tdepano2,O2limano2,nut2lim,ano2new,potdno2nitr,fdetnitr,fno3,ftotno2,amoxfrac, & - !$OMP nitrfrac,totd,amox,nitr,temp) + !$OMP Tdepano2,O2limano2,nut2lim,ano2new,potdno2nitr,fdetnitr,ftotno2,amoxfrac, & + !$OMP nitrfrac,totd,amox,nitr,temp,no2fn2o,no2fno2,no2fdetamox) do j = 1,kpje do i = 1,kpie @@ -212,7 +212,6 @@ subroutine nitrification(kpie,kpje,kpke,kbnd,pddpo,omask,ptho) fno2 = 0. fdetamox = 0. potdno2nitr = 0. - fno3 = 0. fdetnitr = 0. if(ocetra(i,j,k,ioxygen)>minlim_oxnh4 .and. ocetra(i,j,k,ianh4)>minlim_nh4)then @@ -247,29 +246,29 @@ subroutine nitrification(kpie,kpje,kpke,kbnd,pddpo,omask,ptho) potdno2nitr = max(0.,ocetra(i,j,k,iano2) - ano2new) ! pathway splitting functions for NO2 nitrification - assuming to be the same as for NH4 - fno3 = fno2 + fn2o! no N2O prod in this step - NO2 enters instead NO3 - fdetnitr = fdetamox + no2fn2o = 1. - ocetra(i,j,k,ioxygen)/(ocetra(i,j,k,ioxygen) + bkamoxn2o) + no2fno2 = ocetra(i,j,k,ioxygen)/(ocetra(i,j,k,ioxygen) + bkamoxno2) + no2fdetamox = n2omaxy*2.*(1. + n2oybeta)*ocetra(i,j,k,ioxygen)*bkyamox & + & /(ocetra(i,j,k,ioxygen)**2 + 2.*ocetra(i,j,k,ioxygen)*bkyamox + bkyamox**2) - ! normalization of pathway splitting functions for NO2 nitrification - ftotno2 = fno2 + fdetamox + eps - fno3 = fno3/ftotno2 - fdetnitr = 1. - fno3 + fdetnitr = no2fdetamox/(no2fno2 + no2fn2o) ! yield to energy usage ratio for NO2 -> ratio equals 16:x endif ! limitation of the two processes through available nutrients, etc. totd = potdnh4amox + potdno2nitr amoxfrac = potdnh4amox/(totd + eps) nitrfrac = 1. - amoxfrac + totd = max(0., & & min(totd, & - & ocetra(i,j,k,ianh4)/(amoxfrac + fdetamox*nitrfrac + eps), & ! ammonium + & ocetra(i,j,k,ianh4)/(amoxfrac + fdetnitr*nitrfrac + eps), & ! ammonium & ocetra(i,j,k,isco212)/(rc2n*(fdetamox*amoxfrac + fdetnitr*nitrfrac) + eps), & ! CO2 - & ocetra(i,j,k,iphosph)/((fdetamox*amoxfrac + fdetnitr*nitrfrac)*rnoi + eps), & ! PO4 - & ocetra(i,j,k,iiron)/((fdetamox*amoxfrac + fdetnitr*nitrfrac)*riron*rnoi + eps), & ! Fe + & ocetra(i,j,k,iphosph)/(rnoi*(fdetamox*amoxfrac + fdetnitr*nitrfrac) + eps), & ! PO4 + & ocetra(i,j,k,iiron)/(riron*rnoi*(fdetamox*amoxfrac + fdetnitr*nitrfrac) + eps), & ! Fe & ocetra(i,j,k,ioxygen) & - & /((1.5*fno2 + fn2o - ro2nnit*fdetamox)*amoxfrac + (0.5*fno3 - ro2nnit*fdetnitr)*nitrfrac +eps), & ! O2 + & /((1.5*fno2 + fn2o - ro2nnit*fdetamox)*amoxfrac + (0.5 - ro2nnit*fdetnitr)*nitrfrac + eps), & ! O2 & ocetra(i,j,k,ialkali) & - & /((2.*fno2 + fn2o + rnm1*rnoi*fdetamox)*amoxfrac + (rnm1*rnoi*fdetnitr)*nitrfrac + eps))) ! alkalinity + & /((2.*fno2 + fn2o + rnm1*rnoi*fdetamox)*amoxfrac + (rnm1*rnoi*fdetnitr)*nitrfrac + eps))) ! alkalinity amox = amoxfrac*totd nitr = nitrfrac*totd @@ -282,7 +281,7 @@ subroutine nitrification(kpie,kpje,kpke,kbnd,pddpo,omask,ptho) ocetra(i,j,k,iphosph) = ocetra(i,j,k,iphosph) - rnoi*(fdetamox*amox + fdetnitr*nitr) ocetra(i,j,k,iiron) = ocetra(i,j,k,iiron) - riron*rnoi*(fdetamox*amox + fdetnitr*nitr) ocetra(i,j,k,ioxygen) = ocetra(i,j,k,ioxygen) - (1.5*fno2 + fn2o - ro2nnit*fdetamox)*amox & - & - (0.5*fno3 - ro2nnit*fdetnitr)*nitr + & - (0.5 - ro2nnit*fdetnitr)*nitr ocetra(i,j,k,ialkali) = ocetra(i,j,k,ialkali) - (2.*fno2 + fn2o + rnm1*rnoi*fdetamox)*amox - rnm1*rnoi*fdetnitr*nitr ! Output @@ -291,6 +290,7 @@ subroutine nitrification(kpie,kpje,kpke,kbnd,pddpo,omask,ptho) nitr_N2O_prod(i,j,k) = 0.5*fn2o*amox ! kmol N2O/m3/dtb - N2O production during aerob ammonium oxidation nitr_NH4_OM(i,j,k) = rnoi*fdetamox*amox ! kmol P/m3/dtb - organic matter production during aerob NH4 oxidation nitr_NO2_OM(i,j,k) = rnoi*fdetnitr*nitr ! kmol P/m3/dtb - organic matter production during aerob NO2 oxidation + endif enddo enddo From b9a01a1869b1eae7b96721d8cb3bdbb33d53ccc2 Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Mon, 4 Jul 2022 12:13:46 +0200 Subject: [PATCH 122/366] **FIX** output masking and accumulation finalization --- hamocc/ncout_hamocc.F | 30 ++++++++++++++++++++++++++++++ 1 file changed, 30 insertions(+) diff --git a/hamocc/ncout_hamocc.F b/hamocc/ncout_hamocc.F index 193bd715..2b3e371e 100644 --- a/hamocc/ncout_hamocc.F +++ b/hamocc/ncout_hamocc.F @@ -334,6 +334,21 @@ subroutine ncwrt_bgc(iogrp) #ifdef extNcycle call finlyr(janh4(iogrp),jdp(iogrp)) call finlyr(jano2(iogrp),jdp(iogrp)) + call finlyr(jnitr_NH4(iogrp),jdp(iogrp)) + call finlyr(jnitr_NO2(iogrp),jdp(iogrp)) + call finlyr(jnitr_N2O_prod(iogrp),jdp(iogrp)) + call finlyr(jnitr_NH4_OM(iogrp),jdp(iogrp)) + call finlyr(jnitr_NO2_OM(iogrp),jdp(iogrp)) + call finlyr(jdenit_NO3(iogrp),jdp(iogrp)) + call finlyr(jdenit_NO2(iogrp),jdp(iogrp)) + call finlyr(jdenit_N2O(iogrp),jdp(iogrp)) + call finlyr(jDNRA_NO2(iogrp),jdp(iogrp)) + call finlyr(janmx_N2_prod(iogrp),jdp(iogrp)) + call finlyr(janmx_OM_prod(iogrp),jdp(iogrp)) + call finlyr(jphosy_NH4(iogrp),jdp(iogrp)) + call finlyr(jphosy_NO3(iogrp),jdp(iogrp)) + call finlyr(jremin_aerob(iogrp),jdp(iogrp)) + call finlyr(jremin_sulf(iogrp),jdp(iogrp)) #endif c @@ -419,6 +434,21 @@ subroutine ncwrt_bgc(iogrp) #ifdef extNcycle call msklvl(jlvlanh4(iogrp),depths) call msklvl(jlvlano2(iogrp),depths) + call msklvl(jlvl_nitr_NH4(iogrp),depths) + call msklvl(jlvl_nitr_NO2(iogrp),depths) + call msklvl(jlvl_nitr_N2O_prod(iogrp),depths) + call msklvl(jlvl_nitr_NH4_OM(iogrp),depths) + call msklvl(jlvl_nitr_NO2_OM(iogrp),depths) + call msklvl(jlvl_denit_NO3(iogrp),depths) + call msklvl(jlvl_denit_NO2(iogrp),depths) + call msklvl(jlvl_denit_N2O(iogrp),depths) + call msklvl(jlvl_DNRA_NO2(iogrp),depths) + call msklvl(jlvl_anmx_N2_prod(iogrp),depths) + call msklvl(jlvl_anmx_OM_prod(iogrp),depths) + call msklvl(jlvl_phosy_NH4(iogrp),depths) + call msklvl(jlvl_phosy_NO3(iogrp),depths) + call msklvl(jlvl_remin_aerob(iogrp),depths) + call msklvl(jlvl_remin_sulf(iogrp),depths) #endif c From 0d6d6ed2cdd2525096345043cdb11520979ea448 Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Fri, 8 Jul 2022 19:19:58 +0200 Subject: [PATCH 123/366] add OM prod/energy yield factor for NOB and FIRST TUNING wrt to initial parameter set --- hamocc/mo_extNbioproc.F90 | 15 ++++++++++----- 1 file changed, 10 insertions(+), 5 deletions(-) diff --git a/hamocc/mo_extNbioproc.F90 b/hamocc/mo_extNbioproc.F90 index 88b935b1..26f3a5b8 100644 --- a/hamocc/mo_extNbioproc.F90 +++ b/hamocc/mo_extNbioproc.F90 @@ -74,7 +74,7 @@ MODULE mo_extNbioproc & rdnra,q10dnra,Trefdnra,bkoxdnra,bkdnra,ranh4nitr,q10anh4nitr, & & Trefanh4nitr,bkoxamox,bkanh4nitr,bkamoxn2o,bkamoxno2,bkyamox, & & rano2nitr,q10ano2nitr,Trefano2nitr,bkoxnitr,bkano2nitr,n2omaxy, & - & n2oybeta,bkphyanh4,bkphyano3,bkphosph,bkiron + & n2oybeta,bkphyanh4,bkphyano3,bkphosph,bkiron,NOB2AOAy real :: rc2n,ro2utammo,ro2nnit,rnoxp,rnoxpi,rno2anmx,rno2anmxi,rnh4anmx, & & rnh4anmxi,rno2dnra,rno2dnrai,rnh4dnra,rnh4dnrai,rnm1 @@ -109,10 +109,12 @@ subroutine extNbioparam_init() bkiron = bkphosph*riron ! Half-saturation constant for Fe uptake by bulk phytoplankton (kmol/m3) ! === Denitrification step NO3 -> NO2: - rano3denit = 0.15*dtb ! Maximum growth rate denitrification on NO3 at reference T (1/d -> 1/dt) + !rano3denit = 0.15*dtb ! Maximum growth rate denitrification on NO3 at reference T (1/d -> 1/dt) + rano3denit = 0.05*dtb ! Maximum growth rate denitrification on NO3 at reference T (1/d -> 1/dt) q10ano3denit = 2. ! Q10 factor for denitrification on NO3 (-) Trefano3denit = 10. ! Reference temperature for denitrification on NO3 (degr C) - sc_ano3denit = 0.05e6 ! Shape factor for NO3 denitrification oxygen inhibition function (m3/kmol) + !sc_ano3denit = 0.05e6 ! Shape factor for NO3 denitrification oxygen inhibition function (m3/kmol) + sc_ano3denit = 0.08e6 ! Shape factor for NO3 denitrification oxygen inhibition function (m3/kmol) bkano3denit = 5.e-6 ! Half-saturation constant for NO3 denitrification (kmol/m3) ! === Anammox @@ -152,7 +154,8 @@ subroutine extNbioparam_init() bkoxamox = 0.333e-6 ! Half-saturation constant for oxygen limitation of nitrification on NH4 (kmol/m3) bkanh4nitr = 0.133e-6 ! Half-saturation constant for nitrification on NH4 (kmol/m3) bkamoxn2o = 0.453e-6 ! Half saturation constant for pathway splitting function N2O for nitrification on NH4 (kmol/m3) - bkamoxno2 = 0.479e-6 ! Half saturation constant for pathway splitting function N2O for nitrification on NH4 (kmol/m3) + !bkamoxno2 = 0.479e-6 ! Half saturation constant for pathway splitting function N2O for nitrification on NH4 (kmol/m3) + bkamoxno2 = 0.1-6 ! Half saturation constant for pathway splitting function N2O for nitrification on NH4 (kmol/m3) n2omaxy = 0.006 ! Maximum yield of OM on NH4 nitrification (-) n2oybeta = 18. ! Decay factor for inhibition function for yield during nitrification on NH4 (kmol/m3) bkyamox = 0.333e-6 ! Half saturation constant for pathway splitting function OM-yield for nitrification on NH4 (kmol/m3) @@ -163,6 +166,7 @@ subroutine extNbioparam_init() Trefano2nitr = 20. ! Reference temperature for nitrification on NO2 (degr C) bkoxnitr = 0.788e-6 ! Half-saturation constant for oxygen limitation of nitrification on NO2 (kmol/m3) bkano2nitr = 0.287e-6 ! Half-saturation constant for NO2 for nitrification on NO2 (kmol/m3) + NOB2AOAy = 0.44 ! Ratio of NOB versus AOA yield per energy source ~0.043/0.098 according to Zakem et al. 2022 eps = 1.e-25 ! safe division etc. minlim = 1.e-9 ! minimum for limitation functions (e.g. nutlim or oxlim/inh can only decrease to minlim) @@ -246,9 +250,10 @@ subroutine nitrification(kpie,kpje,kpke,kbnd,pddpo,omask,ptho) potdno2nitr = max(0.,ocetra(i,j,k,iano2) - ano2new) ! pathway splitting functions for NO2 nitrification - assuming to be the same as for NH4 + ! but with reduced OM gain per used NO2 as energy source (in amox: NH4) no2fn2o = 1. - ocetra(i,j,k,ioxygen)/(ocetra(i,j,k,ioxygen) + bkamoxn2o) no2fno2 = ocetra(i,j,k,ioxygen)/(ocetra(i,j,k,ioxygen) + bkamoxno2) - no2fdetamox = n2omaxy*2.*(1. + n2oybeta)*ocetra(i,j,k,ioxygen)*bkyamox & + no2fdetamox = NOB2AOAy*n2omaxy*2.*(1. + n2oybeta)*ocetra(i,j,k,ioxygen)*bkyamox & & /(ocetra(i,j,k,ioxygen)**2 + 2.*ocetra(i,j,k,ioxygen)*bkyamox + bkyamox**2) fdetnitr = no2fdetamox/(no2fno2 + no2fn2o) ! yield to energy usage ratio for NO2 -> ratio equals 16:x From 1ff4b748fdbf1716c836c01349370a7428f6a45f Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Mon, 11 Jul 2022 12:17:25 +0200 Subject: [PATCH 124/366] Fix parameter value --- hamocc/mo_extNbioproc.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/hamocc/mo_extNbioproc.F90 b/hamocc/mo_extNbioproc.F90 index 26f3a5b8..a7eb1f4a 100644 --- a/hamocc/mo_extNbioproc.F90 +++ b/hamocc/mo_extNbioproc.F90 @@ -155,7 +155,7 @@ subroutine extNbioparam_init() bkanh4nitr = 0.133e-6 ! Half-saturation constant for nitrification on NH4 (kmol/m3) bkamoxn2o = 0.453e-6 ! Half saturation constant for pathway splitting function N2O for nitrification on NH4 (kmol/m3) !bkamoxno2 = 0.479e-6 ! Half saturation constant for pathway splitting function N2O for nitrification on NH4 (kmol/m3) - bkamoxno2 = 0.1-6 ! Half saturation constant for pathway splitting function N2O for nitrification on NH4 (kmol/m3) + bkamoxno2 = 0.1e-6 ! Half saturation constant for pathway splitting function N2O for nitrification on NH4 (kmol/m3) n2omaxy = 0.006 ! Maximum yield of OM on NH4 nitrification (-) n2oybeta = 18. ! Decay factor for inhibition function for yield during nitrification on NH4 (kmol/m3) bkyamox = 0.333e-6 ! Half saturation constant for pathway splitting function OM-yield for nitrification on NH4 (kmol/m3) From 7b5c428212c09c052b8fefe47308deabc92f12e4 Mon Sep 17 00:00:00 2001 From: Ping-Gin Chiu Date: Fri, 15 Jul 2022 15:45:15 +0200 Subject: [PATCH 125/366] Add pause-resume function --- drivers/cpl_mct/ocn_comp_mct.F90 | 15 ++++++++++++--- phy/mod_config.F90 | 4 +++- phy/restart_rd.F | 6 +++--- 3 files changed, 18 insertions(+), 7 deletions(-) diff --git a/drivers/cpl_mct/ocn_comp_mct.F90 b/drivers/cpl_mct/ocn_comp_mct.F90 index 25a7e6a4..15230d3c 100644 --- a/drivers/cpl_mct/ocn_comp_mct.F90 +++ b/drivers/cpl_mct/ocn_comp_mct.F90 @@ -34,7 +34,7 @@ module ocn_comp_mct use seq_flds_mod use seq_timemgr_mod, only: & seq_timemgr_EClockGetData, seq_timemgr_RestartAlarmIsOn, & - seq_timemgr_EClockDateInSync + seq_timemgr_EClockDateInSync,seq_timemgr_pauseAlarmIsOn use seq_comm_mct, only: seq_comm_suffix, seq_comm_inst, seq_comm_name use shr_file_mod, only: & shr_file_getUnit, shr_file_setIO, & @@ -46,7 +46,7 @@ module ocn_comp_mct use perf_mod, only: t_startf, t_stopf use mod_types, only: r8 - use mod_config, only: inst_index, inst_name, inst_suffix + use mod_config, only: inst_index, inst_name, inst_suffix, resume_flag use mod_time, only: blom_time use mod_cesm, only: runid_cesm, runtyp_cesm, ocn_cpl_dt_cesm use mod_xc @@ -275,6 +275,14 @@ subroutine ocn_run_mct(EClock, cdata_o, x2o_o, o2x_o) call seq_cdata_setptrs(cdata_o, infodata=infodata) + if (resume_flag) then + if (mnproc == 1) then + call blom_time(ymd, tod) + write(lp,*)'Resume from restart: ymd=',ymd,' tod= ',tod + endif + call restart_rd !! resume_flag is applied + resume_flag = .false. + end if !----------------------------------------------------------------- ! Advance the model in time over a coupling interval !----------------------------------------------------------------- @@ -314,9 +322,10 @@ subroutine ocn_run_mct(EClock, cdata_o, x2o_o, o2x_o) ! if requested, write restart file !----------------------------------------------------------------- - if (seq_timemgr_RestartAlarmIsOn(EClock)) then + if (seq_timemgr_RestartAlarmIsOn(EClock).or.seq_timemgr_pauseAlarmIsOn(EClock)) then call restart_wt endif + if (seq_timemgr_pauseAlarmIsOn(EClock)) resume_flag = .true. !----------------------------------------------------------------- ! check that internal clock is in sync with master clock diff --git a/phy/mod_config.F90 b/phy/mod_config.F90 index 860d940b..098d9589 100644 --- a/phy/mod_config.F90 +++ b/phy/mod_config.F90 @@ -34,7 +34,9 @@ module mod_config inst_suffix = '' ! Instance suffix. integer :: & inst_index = 0 ! Instance index. + logical :: & + resume_flag = .false. ! resume flag, use at ocn_run_mct() - public :: expcnf, runid, inst_name, inst_suffix, inst_index + public :: expcnf, runid, inst_name, inst_suffix, inst_index, resume_flag end module mod_config diff --git a/phy/restart_rd.F b/phy/restart_rd.F index 881a4641..4a9edc36 100644 --- a/phy/restart_rd.F +++ b/phy/restart_rd.F @@ -25,7 +25,7 @@ subroutine restart_rd c --- Read initial conditions from restart file c --- ------------------------------------------------------------------ c - use mod_config, only: expcnf, runid, inst_suffix + use mod_config, only: expcnf, runid, inst_suffix, resume_flag use mod_calendar, only: date_type, daynum_diff, operator(/=) use mod_time, only: date0, date, nday1, nstep0, nstep1 use mod_xc @@ -83,7 +83,7 @@ subroutine restart_rd c c --- open restart file and adjust time information if needed c - if (nday1+nint(time0).eq.0) then + if (nday1+nint(time0).eq.0 .and. (.not.resume_flag)) then c c --- - open restart file for initial conditions and adjust integration c --- - time corresponding to start date @@ -955,7 +955,7 @@ subroutine restart_rd call settemmin c #ifdef TRC - call restart_trcrd(rstfnm) + if (.not.resume_flag) call restart_trcrd(rstfnm) #endif c if (ditflx) then From a502680761ecd46b4e5779921f1c09edb431b579 Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Tue, 2 Aug 2022 19:16:23 +0200 Subject: [PATCH 126/366] Introducing NEW PATHWAY splitting function for nitrification similar to Santoros et al. 2021, Ji et al. 2018 --- hamocc/mo_extNbioproc.F90 | 16 +++++++++++++--- 1 file changed, 13 insertions(+), 3 deletions(-) diff --git a/hamocc/mo_extNbioproc.F90 b/hamocc/mo_extNbioproc.F90 index a7eb1f4a..69b116e5 100644 --- a/hamocc/mo_extNbioproc.F90 +++ b/hamocc/mo_extNbioproc.F90 @@ -96,7 +96,7 @@ subroutine extNbioparam_init() rno2anmxi = 1./rno2anmx ! inverse rnh4anmx = 880. ! consumption of NH4 per mol organic production by anammox rnh4anmxi = 1./rnh4anmx ! inverse - rno2dnra = 93. + 1./3 ! consumption of NO2 per mol OM degradation during DNRA + rno2dnra = 93. + 1./3. ! consumption of NO2 per mol OM degradation during DNRA rno2dnrai = 1./rno2dnra ! inverse rnh4dnra = rno2dnra + rnit ! production of NH4 per mol OM during DNRA rnh4dnrai = 1./rnh4dnra ! inverse @@ -153,7 +153,12 @@ subroutine extNbioparam_init() Trefanh4nitr = 20. ! Reference temperature for nitrification on NH4 (degr C) bkoxamox = 0.333e-6 ! Half-saturation constant for oxygen limitation of nitrification on NH4 (kmol/m3) bkanh4nitr = 0.133e-6 ! Half-saturation constant for nitrification on NH4 (kmol/m3) - bkamoxn2o = 0.453e-6 ! Half saturation constant for pathway splitting function N2O for nitrification on NH4 (kmol/m3) +!====== +! OLD VERSION OF pathway splitting function + !bkamoxn2o = 0.453e-6 ! Half saturation constant for pathway splitting function N2O for nitrification on NH4 (kmol/m3) +! NEW version similar to Santoros 2021, Ji 2018: + bkamoxn2o = 0.002e-6 ! Half saturation constant for pathway splitting function N2O for nitrification on NH4 (kmol/m3) +!====== !bkamoxno2 = 0.479e-6 ! Half saturation constant for pathway splitting function N2O for nitrification on NH4 (kmol/m3) bkamoxno2 = 0.1e-6 ! Half saturation constant for pathway splitting function N2O for nitrification on NH4 (kmol/m3) n2omaxy = 0.006 ! Maximum yield of OM on NH4 nitrification (-) @@ -228,7 +233,12 @@ subroutine nitrification(kpie,kpje,kpke,kbnd,pddpo,omask,ptho) potdnh4amox = max(0.,ocetra(i,j,k,ianh4) - anh4new) ! pathway splitting functions according to Goreau 1980 - fn2o = 1. - ocetra(i,j,k,ioxygen)/(ocetra(i,j,k,ioxygen) + bkamoxn2o) + !===== + ! OLD version according to Goreau + !fn2o = 1. - ocetra(i,j,k,ioxygen)/(ocetra(i,j,k,ioxygen) + bkamoxn2o) + ! NEW version similar to Santoros et al. 2021, Ji et al. 2018 + fn2o = 1. - (1.-0.00157)*ocetra(i,j,k,ioxygen)/(ocetra(i,j,k,ioxygen) + bkamoxn2o) + !===== fno2 = ocetra(i,j,k,ioxygen)/(ocetra(i,j,k,ioxygen) + bkamoxno2) fdetamox = n2omaxy*2.*(1. + n2oybeta)*ocetra(i,j,k,ioxygen)*bkyamox & & /(ocetra(i,j,k,ioxygen)**2 + 2.*ocetra(i,j,k,ioxygen)*bkyamox + bkyamox**2) From da9d05116756dd4e33d9fab02bbcc5b1df694686 Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Fri, 12 Aug 2022 15:04:07 +0200 Subject: [PATCH 127/366] CAPITALIZED nml input for extended nitrogen cycle - to function with CIME chaining --- cime_config/buildnml | 112 +++++++++++++++++++++---------------------- 1 file changed, 56 insertions(+), 56 deletions(-) diff --git a/cime_config/buildnml b/cime_config/buildnml index ef7c5ab0..cd6b3f8a 100755 --- a/cime_config/buildnml +++ b/cime_config/buildnml @@ -453,21 +453,21 @@ set LYR_IRON = '0, 0, 2' set LYR_ANO3 = '0, 0, 2' set LYR_ANO2 = '0, 0, 2' set LYR_ANH4 = '0, 0, 2' -set LYR_nitr_NH4 = '0, 0, 2' -set LYR_nitr_NO2 = '0, 0, 2' -set LYR_nitr_N2O_prod = '0, 0, 2' -set LYR_nitr_NH4_OM = '0, 0, 2' -set LYR_nitr_NO2_OM = '0, 0, 2' -set LYR_denit_NO3 = '0, 0, 2' -set LYR_denit_NO2 = '0, 0, 2' -set LYR_denit_N2O = '0, 0, 2' +set LYR_NITR_NH4 = '0, 0, 2' +set LYR_NITR_NO2 = '0, 0, 2' +set LYR_NITR_N2O_PROD = '0, 0, 2' +set LYR_NITR_NH4_OM = '0, 0, 2' +set LYR_NITR_NO2_OM = '0, 0, 2' +set LYR_DENIT_NO3 = '0, 0, 2' +set LYR_DENIT_NO2 = '0, 0, 2' +set LYR_DENIT_N2O = '0, 0, 2' set LYR_DNRA_NO2 = '0, 0, 2' -set LYR_anmx_N2_prod = '0, 0, 2' -set LYR_anmx_OM_prod = '0, 0, 2' -set LYR_phosy_NH4 = '0, 0, 2' -set LYR_phosy_NO3 = '0, 0, 2' -set LYR_remin_aerob = '0, 0, 2' -set LYR_remin_sulf = '0, 0, 2' +set LYR_ANMX_N2_PROD = '0, 0, 2' +set LYR_ANMX_OM_PROD = '0, 0, 2' +set LYR_PHOSY_NH4 = '0, 0, 2' +set LYR_PHOSY_NO3 = '0, 0, 2' +set LYR_REMIN_AEROB = '0, 0, 2' +set LYR_REMIN_SULF = '0, 0, 2' set LYR_ALKALI = '0, 0, 2' set LYR_SILICA = '0, 0, 2' set LYR_DIC = '0, 0, 2' @@ -1500,21 +1500,21 @@ cat >>! $RUNDIR/ocn_in$inststr << EOF ! PHOSY - Primary production (pp) [mol C m-3 s-1] ! CO3 - Carbonate ions (co3) [mol C m-3] ! N2O - Nitrous oxide concentration [mol N2O m-3] -! nitr_NH4 - nitrification rate on NH4 [mol NH4 m-3 s-1] - extended N cycle only -! nitr_NO2 - nitrification rate on NO2 [mol NO2 m-3 s-1] - extended N cycle only -! nitr_N2O_prod - N2O production rate during nitrification on NH4 [mol N2O m-3 s-1] - ext. N cycle only -! nitr_NH4_OM - detritus production during nitrification on NH4 [mol P m-3 s-1] - ext. N cycle only -! nitr_NO2_OM - detritus production during nitrification on NO2 [mol P m-3 s-1] - ext. N cycle only -! denit_NO3 - denitrification rate on NO3 [mol NO3 m-3 s-1] - ext. N cycle only -! denit_NO2 - denitrification rate on NO2 [mol NO2 m-3 s-1] - ext. N cycle only -! denit_N2O - denitrification rate on N20 [mol N20 m-3 s-1] - ext. N cycle only +! NITR_NH4 - nitrification rate on NH4 [mol NH4 m-3 s-1] - extended N cycle only +! NITR_NO2 - nitrification rate on NO2 [mol NO2 m-3 s-1] - extended N cycle only +! NITR_N2O_PROD - N2O production rate during nitrification on NH4 [mol N2O m-3 s-1] - ext. N cycle only +! NITR_NH4_OM - detritus production during nitrification on NH4 [mol P m-3 s-1] - ext. N cycle only +! NITR_NO2_OM - detritus production during nitrification on NO2 [mol P m-3 s-1] - ext. N cycle only +! DENIT_NO3 - denitrification rate on NO3 [mol NO3 m-3 s-1] - ext. N cycle only +! DENIT_NO2 - denitrification rate on NO2 [mol NO2 m-3 s-1] - ext. N cycle only +! DENIT_N2O - denitrification rate on N20 [mol N20 m-3 s-1] - ext. N cycle only ! DNRA_NO2 - DNRA on NO2 [mol NO2 m-3 s-1] - ext. N cycle only -! anmx_N2_prod - anammox N2 production [mol N2 m-3 s-1] - ext. N cycle only -! anmx_OM_prod - anammox detritus production [mol P m-3 s-1] - ext. N cycle only -! phosy_NH4 - PP consumption of NH4 [mol NH4 m-3 s-1] - ext. N cycle only -! phosy_NO3 - PP consumption of NH4 [mol NH4 m-3 s-1] - ext. N cycle only -! remin_aerob - aerob remineralization rate (sev. sources) [mol NH4 m-3 s-1] - ext. N cycle only -! remin_sulf - sulfate-based remin rate on det [mol P m-3 s-1] - ext. N cycle only +! ANMX_N2_PROD - anammox N2 production [mol N2 m-3 s-1] - ext. N cycle only +! ANMX_OM_PROD - anammox detritus production [mol P m-3 s-1] - ext. N cycle only +! PHOSY_NH4 - PP consumption of NH4 [mol NH4 m-3 s-1] - ext. N cycle only +! PHOSY_NO3 - PP consumption of NH4 [mol NH4 m-3 s-1] - ext. N cycle only +! REMIN_AEROB - aerob remineralization rate (sev. sources) [mol NH4 m-3 s-1] - ext. N cycle only +! REMIN_SULF - sulfate-based remin rate on det [mol P m-3 s-1] - ext. N cycle only ! PH - pH (ph) [-log10([h+])] ! OMEGAA - Aragonite saturation state (omegaa) [1] ! OMEGAC - Calcite saturation state (omegac) [1] @@ -1693,21 +1693,21 @@ cat >>! $RUNDIR/ocn_in$inststr << EOF LYR_ANO3 = $LYR_ANO3 LYR_ANO2 = $LYR_ANO2 LYR_ANH4 = $LYR_ANH4 - LYR_nitr_NH4 = $LYR_nitr_NH4 - LYR_nitr_NO2 = $LYR_nitr_NO2 - LYR_nitr_N2O_prod = $LYR_nitr_N2O_prod - LYR_nitr_NH4_OM = $LYR_nitr_NH4_OM - LYR_nitr_NO2_OM = $LYR_nitr_NO2_OM - LYR_denit_NO3 = $LYR_denit_NO3 - LYR_denit_NO2 = $LYR_denit_NO2 - LYR_denit_N2O = $LYR_denit_N2O + LYR_NITR_NH4 = $LYR_NITR_NH4 + LYR_NITR_NO2 = $LYR_NITR_NO2 + LYR_NITR_N2O_PROD = $LYR_NITR_N2O_PROD + LYR_NITR_NH4_OM = $LYR_NITR_NH4_OM + LYR_NITR_NO2_OM = $LYR_NITR_NO2_OM + LYR_DENIT_NO3 = $LYR_DENIT_NO3 + LYR_DENIT_NO2 = $LYR_DENIT_NO2 + LYR_DENIT_N2O = $LYR_DENIT_N2O LYR_DNRA_NO2 = $LYR_DNRA_NO2 - LYR_anmx_N2_prod = $LYR_anmx_N2_prod - LYR_anmx_OM_prod = $LYR_anmx_OM_prod - LYR_phosy_NH4 = $LYR_phosy_NH4 - LYR_phosy_NO3 = $LYR_phosy_NO3 - LYR_remin_aerob = $LYR_remin_aerob - LYR_remin_sulf = $LYR_remin_sulf + LYR_ANMX_N2_PROD = $LYR_ANMX_N2_PROD + LYR_ANMX_OM_PROD = $LYR_ANMX_OM_PROD + LYR_PHOSY_NH4 = $LYR_PHOSY_NH4 + LYR_PHOSY_NO3 = $LYR_PHOSY_NO3 + LYR_REMIN_AEROB = $LYR_REMIN_AEROB + LYR_REMIN_SULF = $LYR_REMIN_SULF LYR_ALKALI = $LYR_ALKALI LYR_SILICA = $LYR_SILICA LYR_DIC = $LYR_DIC @@ -1762,21 +1762,21 @@ cat >>! $RUNDIR/ocn_in$inststr << EOF LVL_ANO3 = $LVL_ANO3 LVL_ANO2 = $LVL_ANO2 LVL_ANH4 = $LVL_ANH4 - LVL_nitr_NH4 = $LVL_nitr_NH4 - LVL_nitr_NO2 = $LVL_nitr_NO2 - LVL_nitr_N2O_prod = $LVL_nitr_N2O_prod - LVL_nitr_NH4_OM = $LVL_nitr_NH4_OM - LVL_nitr_NO2_OM = $LVL_nitr_NO2_OM - LVL_denit_NO3 = $LVL_denit_NO3 - LVL_denit_NO2 = $LVL_denit_NO2 - LVL_denit_N2O = $LVL_denit_N2O + LVL_NITR_NH4 = $LVL_NITR_NH4 + LVL_NITR_NO2 = $LVL_NITR_NO2 + LVL_NITR_N2O_PROD = $LVL_NITR_N2O_PROD + LVL_NITR_NH4_OM = $LVL_NITR_NH4_OM + LVL_NITR_NO2_OM = $LVL_NITR_NO2_OM + LVL_DENIT_NO3 = $LVL_DENIT_NO3 + LVL_DENIT_NO2 = $LVL_DENIT_NO2 + LVL_DENIT_N2O = $LVL_DENIT_N2O LVL_DNRA_NO2 = $LVL_DNRA_NO2 - LVL_anmx_N2_prod = $LVL_anmx_N2_prod - LVL_anmx_OM_prod = $LVL_anmx_OM_prod - LVL_phosy_NH4 = $LVL_phosy_NH4 - LVL_phosy_NO3 = $LVL_phosy_NO3 - LVL_remin_aerob = $LVL_remin_aerob - LVL_remin_sulf = $LVL_remin_sulf + LVL_ANMX_N2_PROD = $LVL_ANMX_N2_PROD + LVL_ANMX_OM_PROD = $LVL_ANMX_OM_PROD + LVL_PHOSY_NH4 = $LVL_PHOSY_NH4 + LVL_PHOSY_NO3 = $LVL_PHOSY_NO3 + LVL_REMIN_AEROB = $LVL_REMIN_AEROB + LVL_REMIN_SULF = $LVL_REMIN_SULF LVL_ALKALI = $LVL_ALKALI LVL_SILICA = $LVL_SILICA LVL_DIC = $LVL_DIC From e20541ac635ff3c7f486d3be474495ceecae340f Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Mon, 15 Aug 2022 09:38:10 +0200 Subject: [PATCH 128/366] capitalized missing nml parameters --- cime_config/buildnml | 28 ++++++++++++++-------------- 1 file changed, 14 insertions(+), 14 deletions(-) diff --git a/cime_config/buildnml b/cime_config/buildnml index cd6b3f8a..52018d93 100755 --- a/cime_config/buildnml +++ b/cime_config/buildnml @@ -522,21 +522,21 @@ set LVL_IRON = '0, 2, 2' set LVL_ANO3 = '0, 2, 2' set LVL_ANO2 = '0, 2, 2' set LVL_ANH4 = '0, 2, 2' -set LVL_nitr_NH4 = '0, 2, 2' -set LVL_nitr_NO2 = '0, 2, 2' -set LVL_nitr_N2O_prod = '0, 2, 2' -set LVL_nitr_NH4_OM = '0, 2, 2' -set LVL_nitr_NO2_OM = '0, 2, 2' -set LVL_denit_NO3 = '0, 2, 2' -set LVL_denit_NO2 = '0, 2, 2' -set LVL_denit_N2O = '0, 2, 2' +set LVL_NITR_NH4 = '0, 2, 2' +set LVL_NITR_NO2 = '0, 2, 2' +set LVL_NITR_N2O_PROD = '0, 2, 2' +set LVL_NITR_NH4_OM = '0, 2, 2' +set LVL_NITR_NO2_OM = '0, 2, 2' +set LVL_DENIT_NO3 = '0, 2, 2' +set LVL_DENIT_NO2 = '0, 2, 2' +set LVL_DENIT_N2O = '0, 2, 2' set LVL_DNRA_NO2 = '0, 2, 2' -set LVL_anmx_N2_prod = '0, 2, 2' -set LVL_anmx_OM_prod = '0, 2, 2' -set LVL_phosy_NH4 = '0, 2, 2' -set LVL_phosy_NO3 = '0, 2, 2' -set LVL_remin_aerob = '0, 2, 2' -set LVL_remin_sulf = '0, 2, 2' +set LVL_ANMX_N2_PROD = '0, 2, 2' +set LVL_ANMX_OM_PROD = '0, 2, 2' +set LVL_PHOSY_NH4 = '0, 2, 2' +set LVL_PHOSY_NO3 = '0, 2, 2' +set LVL_REMIN_AEROB = '0, 2, 2' +set LVL_REMIN_SULF = '0, 2, 2' set LVL_ALKALI = '0, 2, 2' set LVL_SILICA = '0, 2, 2' set LVL_DIC = '0, 2, 2' From 8ce8afde4f9c91fb6d1aaca564422784f4878739 Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Tue, 16 Aug 2022 17:57:44 +0200 Subject: [PATCH 129/366] Introduce M4AGO to iHAMOCC Merged with private branch extN-M4AGO --- cime_config/buildnml | 60 +++ hamocc/accfields.F90 | 39 +- hamocc/beleg_parm.F90 | 16 +- hamocc/hamocc4bcm.F90 | 2 +- hamocc/hamocc_init.F | 4 +- hamocc/meson.build | 3 +- hamocc/mo_bgcmean.F90 | 101 ++++- hamocc/mo_biomod.F90 | 2 +- hamocc/mo_control_bgc.F90 | 2 +- hamocc/mo_m4ago.F90 | 932 ++++++++++++++++++++++++++++++++++++++ hamocc/ncout_hamocc.F | 192 +++++++- hamocc/ocprod.F90 | 108 ++++- 12 files changed, 1422 insertions(+), 39 deletions(-) create mode 100644 hamocc/mo_m4ago.F90 diff --git a/cime_config/buildnml b/cime_config/buildnml index 52018d93..1e94281a 100755 --- a/cime_config/buildnml +++ b/cime_config/buildnml @@ -468,6 +468,18 @@ set LYR_PHOSY_NH4 = '0, 0, 2' set LYR_PHOSY_NO3 = '0, 0, 2' set LYR_REMIN_AEROB = '0, 0, 2' set LYR_REMIN_SULF = '0, 0, 2' +set LYR_AGG_WS = '0, 0, 2' +set LYR_DYNVIS = '0, 0, 2' +set LYR_AGG_STICK = '0, 0, 2' +set LYR_AGG_STICKF = '0, 0, 2' +set LYR_AGG_DMAX = '0, 0, 2' +set LYR_AGG_AVDP = '0, 0, 2' +set LYR_AGG_AVRHOP = '0, 0, 2' +set LYR_AGG_AVDC = '0, 0, 2' +set LYR_AGG_DF = '0, 0, 2' +set LYR_AGG_B = '0, 0, 2' +set LYR_AGG_VRHOF = '0, 0, 2' +set LYR_AGG_VPOR = '0, 0, 2' set LYR_ALKALI = '0, 0, 2' set LYR_SILICA = '0, 0, 2' set LYR_DIC = '0, 0, 2' @@ -537,6 +549,18 @@ set LVL_PHOSY_NH4 = '0, 2, 2' set LVL_PHOSY_NO3 = '0, 2, 2' set LVL_REMIN_AEROB = '0, 2, 2' set LVL_REMIN_SULF = '0, 2, 2' +set LVL_AGG_WS = '0, 2, 2' +set LVL_DYNVIS = '0, 2, 2' +set LVL_AGG_STICK = '0, 0, 2' +set LVL_AGG_STICKF = '0, 0, 2' +set LVL_AGG_DMAX = '0, 2, 2' +set LVL_AGG_AVDP = '0, 2, 2' +set LVL_AGG_AVRHOP = '0, 2, 2' +set LVL_AGG_AVDC = '0, 0, 2' +set LVL_AGG_DF = '0, 2, 2' +set LVL_AGG_B = '0, 2, 2' +set LVL_AGG_VRHOF = '0, 2, 2' +set LVL_AGG_VPOR = '0, 0, 2' set LVL_ALKALI = '0, 2, 2' set LVL_SILICA = '0, 2, 2' set LVL_DIC = '0, 2, 2' @@ -1515,6 +1539,18 @@ cat >>! $RUNDIR/ocn_in$inststr << EOF ! PHOSY_NO3 - PP consumption of NH4 [mol NH4 m-3 s-1] - ext. N cycle only ! REMIN_AEROB - aerob remineralization rate (sev. sources) [mol NH4 m-3 s-1] - ext. N cycle only ! REMIN_SULF - sulfate-based remin rate on det [mol P m-3 s-1] - ext. N cycle only +! AGG_WS - M4AGO aggregate mean settling velocity [m/d] +! DYNVIS - molecular dynamic viscosity of sea water [kg m-1 s-1] +! AGG_STICK - mean stickiness of marine aggregates [-] +! AGG_STICKF - stickiness of opal frustule [-] +! AGG_DMAX - maximum aggregate diameter [m] +! AGG_AVDP - mean primary particle diameter [m] +! AGG_AVRHOP - mean primary particle density [kg/m3] +! AGG_AVDC - concentration weighted mean diameter of aggregates [m] +! AGG_DF - fractal dimension of aggregates [-] +! AGG_B - slope of aggregate number distribution [-] +! AGG_VRHOF - Volume-weighted mean aggregate density [kg m-3] +! AGG_VPOR - Volume weighted mean aggregate porosity [-] ! PH - pH (ph) [-log10([h+])] ! OMEGAA - Aragonite saturation state (omegaa) [1] ! OMEGAC - Calcite saturation state (omegac) [1] @@ -1708,6 +1744,18 @@ cat >>! $RUNDIR/ocn_in$inststr << EOF LYR_PHOSY_NO3 = $LYR_PHOSY_NO3 LYR_REMIN_AEROB = $LYR_REMIN_AEROB LYR_REMIN_SULF = $LYR_REMIN_SULF + LYR_AGG_WS = $LYR_AGG_WS + LYR_DYNVIS = $LYR_DYNVIS + LYR_AGG_STICK = $LYR_AGG_STICK + LYR_AGG_STICKF = $LYR_AGG_STICKF + LYR_AGG_DMAX = $LYR_AGG_DMAX + LYR_AGG_AVDP = $LYR_AGG_AVDP + LYR_AGG_AVRHOP = $LYR_AGG_AVRHOP + LYR_AGG_AVDC = $LYR_AGG_AVDC + LYR_AGG_DF = $LYR_AGG_DF + LYR_AGG_B = $LYR_AGG_B + LYR_AGG_VRHOF = $LYR_AGG_VRHOF + LYR_AGG_VPOR = $LYR_AGG_VPOR LYR_ALKALI = $LYR_ALKALI LYR_SILICA = $LYR_SILICA LYR_DIC = $LYR_DIC @@ -1777,6 +1825,18 @@ cat >>! $RUNDIR/ocn_in$inststr << EOF LVL_PHOSY_NO3 = $LVL_PHOSY_NO3 LVL_REMIN_AEROB = $LVL_REMIN_AEROB LVL_REMIN_SULF = $LVL_REMIN_SULF + LVL_AGG_WS = $LVL_AGG_WS + LVL_DYNVIS = $LVL_DYNVIS + LVL_AGG_STICK = $LVL_AGG_STICK + LVL_AGG_STICKF = $LVL_AGG_STICKF + LVL_AGG_DMAX = $LVL_AGG_DMAX + LVL_AGG_AVDP = $LVL_AGG_AVDP + LVL_AGG_AVRHOP = $LVL_AGG_AVRHOP + LVL_AGG_AVDC = $LVL_AGG_AVDC + LVL_AGG_DF = $LVL_AGG_DF + LVL_AGG_B = $LVL_AGG_B + LVL_AGG_VRHOF = $LVL_AGG_VRHOF + LVL_AGG_VPOR = $LVL_AGG_VPOR LVL_ALKALI = $LVL_ALKALI LVL_SILICA = $LVL_SILICA LVL_DIC = $LVL_DIC diff --git a/hamocc/accfields.F90 b/hamocc/accfields.F90 index 75a76b47..aaf91fa0 100644 --- a/hamocc/accfields.F90 +++ b/hamocc/accfields.F90 @@ -66,12 +66,16 @@ SUBROUTINE ACCFIELDS(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask) & jniflux,jnos,jo2flux,jo2sat,jomegaa,jomegac,jopal,joxflux,joxygen,jpco2,jph,jphosph,jphosy,jphyto, & & jpoc,jprefalk,jprefdic,jprefo2,jprefpo4,jsilica,jsrfalkali,jsrfano3,jsrfdic,jsrfiron,jsrfoxygen, & & jsrfphosph,jsrfphyto,jsrfsilica,jwnos,jwphy,nbgc,nacc_bgc,bgcwrt,glb_inventory,bgct2d,acclvl, & - & acclyr,accsrf,bgczlv,jlvlanh4,jlvlano2 + & acclyr,accsrf,bgczlv,jlvlanh4,jlvlano2, & + & jagg_ws,jdynvis,jagg_stick,jagg_stickf,jagg_dmax,jagg_avdp,jagg_avrhop,jagg_avdC,jagg_df,jagg_b, & + & jagg_Vrhof,jagg_Vpor,jlvl_agg_ws,jlvl_dynvis,jlvl_agg_stick,jlvl_agg_stickf,jlvl_agg_dmax, & + & jlvl_agg_avdp,jlvl_agg_avrhop,jlvl_agg_avdC,jlvl_agg_df,jlvl_agg_b,jlvl_agg_Vrhof,jlvl_agg_Vpor use mo_control_bgc, only: io_stdo_bgc use mo_param1_bgc, only: ialkali,ian2o,iano3,iatmco2,iatmdms,iatmn2,iatmn2o,iatmo2,icalc,idet,idms,idicsat,idoc,iiron,iopal,& & ioxygen,iphosph,iphy,iprefalk,iprefdic,iprefpo4,iprefo2,isco212,isilica,izoo, & & irdin,irdip,irsi,iralk,iriron,irdoc,irdet - + use mo_m4ago, only: aggregate_diagnostics,kav_dp,kav_rho_p,kav_d_C,kws_agg,kdf_agg,kstickiness_agg,kb_agg, & + & kstickiness_frustule,kLmax_agg,kdynvis,kav_rhof_V,kav_por_V #ifdef AGG use mo_biomod, only: asize3d,eps3d,wnumb,wmass use mo_param1_bgc, only: inos @@ -392,6 +396,19 @@ SUBROUTINE ACCFIELDS(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask) call acclyr(jremin_aerob,remin_aerob,pddpo,1) call acclyr(jremin_sulf,remin_sulf,pddpo,1) #endif + ! M4AGO + call acclyr(jagg_ws,aggregate_diagnostics(1,1,1,kws_agg),pddpo,1) + call acclyr(jdynvis,aggregate_diagnostics(1,1,1,kdynvis),pddpo,1) + call acclyr(jagg_stick,aggregate_diagnostics(1,1,1,kstickiness_agg),pddpo,1) + call acclyr(jagg_stickf,aggregate_diagnostics(1,1,1,kstickiness_frustule),pddpo,1) + call acclyr(jagg_dmax,aggregate_diagnostics(1,1,1,kLmax_agg),pddpo,1) + call acclyr(jagg_avdp,aggregate_diagnostics(1,1,1,kav_dp),pddpo,1) + call acclyr(jagg_avrhop,aggregate_diagnostics(1,1,1,kav_rho_p),pddpo,1) + call acclyr(jagg_avdC,aggregate_diagnostics(1,1,1,kav_d_C),pddpo,1) + call acclyr(jagg_df,aggregate_diagnostics(1,1,1,kdf_agg),pddpo,1) + call acclyr(jagg_b,aggregate_diagnostics(1,1,1,kb_agg),pddpo,1) + call acclyr(jagg_Vrhof,aggregate_diagnostics(1,1,1,kav_rhof_V),pddpo,1) + call acclyr(jagg_Vpor,aggregate_diagnostics(1,1,1,kav_por_V),pddpo,1) ! Accumulate level diagnostics IF (SUM(jlvlphyto+jlvlgrazer+jlvlphosph+jlvloxygen+jlvliron+ & @@ -406,7 +423,10 @@ SUBROUTINE ACCFIELDS(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask) & jlvl_nitr_NH4+jlvl_nitr_NO2+jlvl_nitr_N2O_prod+jlvl_nitr_NH4_OM+& & jlvl_nitr_NO2_OM+jlvl_denit_NO3+jlvl_denit_NO2+jlvl_denit_N2O+ & & jlvl_DNRA_NO2+jlvl_anmx_N2_prod+jlvl_anmx_OM_prod+ & - & jlvl_phosy_NH4+jlvl_phosy_NO3+jlvl_remin_aerob+jlvl_remin_sulf & + & jlvl_phosy_NH4+jlvl_phosy_NO3+jlvl_remin_aerob+jlvl_remin_sulf+ & + & jlvl_agg_ws+jlvl_dynvis+jlvl_agg_stick+jlvl_agg_stickf+ & + & jlvl_agg_dmax+jlvl_agg_avdp+jlvl_agg_avrhop+jlvl_agg_avdC+ & + & jlvl_agg_df+jlvl_agg_b+jlvl_agg_Vrhof+jlvl_agg_Vpor & & ).NE.0) THEN DO k=1,kpke call bgczlv(pddpo,k,ind1,ind2,wghts) @@ -491,6 +511,19 @@ SUBROUTINE ACCFIELDS(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask) call acclvl(jlvl_remin_aerob,remin_aerob,k,ind1,ind2,wghts) call acclvl(jlvl_remin_sulf,remin_sulf,k,ind1,ind2,wghts) #endif + !M4AGO + call acclvl(jlvl_agg_ws,aggregate_diagnostics(1,1,1,kws_agg),k,ind1,ind2,wghts) + call acclvl(jlvl_dynvis,aggregate_diagnostics(1,1,1,kdynvis),k,ind1,ind2,wghts) + call acclvl(jlvl_agg_stick,aggregate_diagnostics(1,1,1,kstickiness_agg),k,ind1,ind2,wghts) + call acclvl(jlvl_agg_stickf,aggregate_diagnostics(1,1,1,kstickiness_frustule),k,ind1,ind2,wghts) + call acclvl(jlvl_agg_dmax,aggregate_diagnostics(1,1,1,kLmax_agg),k,ind1,ind2,wghts) + call acclvl(jlvl_agg_avdp,aggregate_diagnostics(1,1,1,kav_dp),k,ind1,ind2,wghts) + call acclvl(jlvl_agg_avrhop,aggregate_diagnostics(1,1,1,kav_rho_p),k,ind1,ind2,wghts) + call acclvl(jlvl_agg_avdC,aggregate_diagnostics(1,1,1,kav_d_C),k,ind1,ind2,wghts) + call acclvl(jlvl_agg_df,aggregate_diagnostics(1,1,1,kdf_agg),k,ind1,ind2,wghts) + call acclvl(jlvl_agg_b,aggregate_diagnostics(1,1,1,kb_agg),k,ind1,ind2,wghts) + call acclvl(jlvl_agg_Vrhof,aggregate_diagnostics(1,1,1,kav_rhof_V),k,ind1,ind2,wghts) + call acclvl(jlvl_agg_Vpor,aggregate_diagnostics(1,1,1,kav_por_V),k,ind1,ind2,wghts) ENDDO ENDIF diff --git a/hamocc/beleg_parm.F90 b/hamocc/beleg_parm.F90 index a9d07bd5..6c693c7a 100644 --- a/hamocc/beleg_parm.F90 +++ b/hamocc/beleg_parm.F90 @@ -45,12 +45,12 @@ SUBROUTINE BELEG_PARM(kpie,kpje) use mo_biomod, only: atten_c,atten_f,atten_uv,atten_w,bkopal,bkphy,bkopal,bkzoo,bluefix,ctochl,dremn2o,dremopal, & & drempoc,dremsul,dyphy,ecan,epsher,fesoly,fetune,gammap,gammaz,grami,grazra,perc_diron,phytomi, & & pi_alpha,rcalc,rcar, rdn2o1,rdn2o2,rdnit0,rdnit1,rdnit2,relaxfe,remido,riron,rnit,rnoi,ro2ut, & - & ropal,spemor,tf0,tf1,tf2,tff,wcal,wdust,wopal,wpoc,zinges + & ropal,spemor,tf0,tf1,tf2,tff,wcal,wdust,wopal,wpoc,zinges,drempoc_anaerob use mo_sedmnt, only: claydens,o2ut,rno3 - use mo_control_bgc, only: dtb,io_stdo_bgc + use mo_control_bgc, only: dtb,io_stdo_bgc,lm4ago use mo_param1_bgc, only: iatmco2,iatmnco2,iatmo2,iatmn2,iatmc13,iatmc14,iatmbromo use mod_xc, only: mnproc - + use mo_m4ago, only: init_m4ago_nml_params, init_m4ago_params #ifdef AGG use mo_biomod, only: alar1,alar2,alar3,alow1,alow2,alow3,calmax,cellmass,cellsink,dustd1,dustd2,dustd3,dustsink, & & fractdim,fse,fsh,nmldmin,plower,pupper,safe,sinkexp,stick,tmfac,tsfac,vsmall,zdis @@ -216,7 +216,7 @@ SUBROUTINE BELEG_PARM(kpie,kpje) dremopal = 0.003*dtb !1/d dremn2o = 0.01*dtb !1/d dremsul = 0.005*dtb ! remineralization rate for sulphate reduction - + drempoc_anaerob = 0.05*drempoc ! remin in sub-/anoxic environm. - not be overwritten by lm4ago ! nirogen fixation by blue green algae bluefix=0.005*dtb !1/d @@ -280,6 +280,14 @@ SUBROUTINE BELEG_PARM(kpie,kpje) ropal = 30. ! iris 25 !opal to organic phosphorous production ratio #endif + ! M4AGO parameters - requires ropal, opalwei, claydens and calcdens to be set + call init_m4ago_nml_params + call init_m4ago_params + if(lm4ago)then + ! reset drempoc and dremopal for T-dep remin/dissolution + drempoc = 0.12*dtb + dremopal = 0.023*dtb + endif ! parameters for sw-radiation attenuation ! Analog to Moore et al., Deep-Sea Research II 49 (2002), 403-462 ! 1 kmolP = (122*12/60)*10^6 mg[Chlorophyl] diff --git a/hamocc/hamocc4bcm.F90 b/hamocc/hamocc4bcm.F90 index 0dd3e6a3..9adc5579 100644 --- a/hamocc/hamocc4bcm.F90 +++ b/hamocc/hamocc4bcm.F90 @@ -219,7 +219,7 @@ SUBROUTINE HAMOCC4BCM(kpie,kpje,kpke,kbnd,kplyear,kplmon,kplday,kldtday,& ! the model CALL apply_fedep(kpie,kpje,kpke,pddpo,omask,dust) - CALL OCPROD(kpie,kpje,kpke,kbnd,pdlxp,pdlyp,pddpo,omask,ptho,pi_ph) + CALL OCPROD(kpie,kpje,kpke,kbnd,pdlxp,pdlyp,pddpo,omask,ptho,pi_ph,psao,ppao,prho) #ifdef PBGC_CK_TIMESTEP IF (mnproc.eq.1) THEN diff --git a/hamocc/hamocc_init.F b/hamocc/hamocc_init.F index 49e26675..3d04a8ed 100644 --- a/hamocc/hamocc_init.F +++ b/hamocc/hamocc_init.F @@ -46,7 +46,7 @@ subroutine hamocc_init(read_rest,rstfnm_hamocc) . do_ndep,do_rivinpt,do_sedspinup, . sedspin_yr_s,sedspin_yr_e,sedspin_ncyc, . dtb,dtbgc,io_stdo_bgc,ldtbgc, - . ldtrunbgc,ndtdaybgc,with_dmsph + . ldtrunbgc,ndtdaybgc,with_dmsph,lm4ago use mo_param1_bgc, only: ks,nsedtra,npowtra use mo_carbch, only: alloc_mem_carbch,ocetra,atm,atm_co2 use mo_biomod, only: alloc_mem_biomod @@ -64,6 +64,7 @@ subroutine hamocc_init(read_rest,rstfnm_hamocc) . bgc_dx,bgc_dy,bgc_dp,bgc_rho, . omask,sedlay2,powtra2,burial2, . blom2hamocc + use mo_m4ago, only: alloc_mem_m4ago #ifdef BOXATM use mo_intfcblom, only: atm2 #endif @@ -139,6 +140,7 @@ subroutine hamocc_init(read_rest,rstfnm_hamocc) CALL ALLOC_MEM_BIOMOD(idm,jdm,kdm) CALL ALLOC_MEM_SEDMNT(idm,jdm) CALL ALLOC_MEM_CARBCH(idm,jdm,kdm) + CALL ALLOC_MEM_M4AGO(idm,jdm,kdm) c c --- initialise trc array (two time levels) c diff --git a/hamocc/meson.build b/hamocc/meson.build index 60b4b817..6000bb22 100644 --- a/hamocc/meson.build +++ b/hamocc/meson.build @@ -46,4 +46,5 @@ sources += files( 'sedshi.F90', 'trc_limitc.F', 'write_netcdf_var.F90', - 'mo_extNbioproc.F90') + 'mo_extNbioproc.F90', + 'mo_m4ago.F90') diff --git a/hamocc/mo_bgcmean.F90 b/hamocc/mo_bgcmean.F90 index c252676c..b9be3f55 100644 --- a/hamocc/mo_bgcmean.F90 +++ b/hamocc/mo_bgcmean.F90 @@ -127,7 +127,13 @@ MODULE mo_bgcmean & LYR_nitr_NH4_OM =0 ,LYR_nitr_NO2_OM =0 ,LYR_denit_NO3 =0, & & LYR_denit_NO2 = 0 ,LYR_denit_N2O = 0 ,LYR_DNRA_NO2 =0, & & LYR_anmx_N2_prod=0 ,LYR_anmx_OM_prod=0 ,LYR_phosy_NH4 =0, & - & LYR_phosy_NO3 = 0 ,LYR_remin_aerob =0 ,LYR_remin_sulf =0, & + & LYR_phosy_NO3 = 0 ,LYR_remin_aerob =0 ,LYR_remin_sulf =0, & + ! M4AGO LYR + & LYR_agg_ws =0 ,LYR_dynvis =0 ,LYR_agg_stick =0 , & + & LYR_agg_stickf=0 ,LYR_agg_dmax =0 ,LYR_agg_avdp =0 , & + & LYR_agg_avrhop=0 ,LYR_agg_avdC =0 ,LYR_agg_df =0 , & + & LYR_agg_b =0 ,LYR_agg_Vrhof =0 ,LYR_agg_Vpor =0 , & + !========== LVLs & LVL_PHYTO =0 ,LVL_GRAZER =0 ,LVL_DOC =0 , & & LVL_PHOSY =0 ,LVL_PHOSPH =0 ,LVL_OXYGEN =0 , & & LVL_IRON =0 ,LVL_ANO3 =0 ,LVL_ALKALI =0 , & @@ -154,6 +160,11 @@ MODULE mo_bgcmean & LVL_denit_NO2 = 0 ,LVL_denit_N2O = 0 ,LVL_DNRA_NO2 =0, & & LVL_anmx_N2_prod=0 ,LVL_anmx_OM_prod=0 ,LVL_phosy_NH4 =0, & & LVL_phosy_NO3 = 0 ,LVL_remin_aerob =0 ,LVL_remin_sulf =0, & + ! M4AGO LVL + & LVL_agg_ws =0 ,LVL_dynvis =0 ,LVL_agg_stick =0 , & + & LVL_agg_stickf=0 ,LVL_agg_dmax =0 ,LVL_agg_avdp =0 , & + & LVL_agg_avrhop=0 ,LVL_agg_avdC =0 ,LVL_agg_df =0 , & + & LVL_agg_b =0 ,LVL_agg_Vrhof =0 ,LVL_agg_Vpor =0 , & & SDM_POWAIC =0 ,SDM_POWAAL =0 ,SDM_POWAPH =0 , & & SDM_POWAOX =0 ,SDM_POWN2 =0 ,SDM_POWNO3 =0 , & & SDM_POWASI =0 ,SDM_SSSO12 =0 ,SDM_SSSSIL =0 , & @@ -216,6 +227,10 @@ MODULE mo_bgcmean & LYR_denit_NO2 ,LYR_denit_N2O ,LYR_DNRA_NO2 , & & LYR_anmx_N2_prod ,LYR_anmx_OM_prod ,LYR_phosy_NH4 , & & LYR_phosy_NO3 ,LYR_remin_aerob ,LYR_remin_sulf , & + & LYR_agg_ws ,LYR_dynvis ,LYR_agg_stick , & + & LYR_agg_stickf ,LYR_agg_dmax ,LYR_agg_avdp , & + & LYR_agg_avrhop ,LYR_agg_avdC ,LYR_agg_df , & + & LYR_agg_b ,LYR_agg_Vrhof ,LYR_agg_Vpor , & & LVL_PHYTO ,LVL_GRAZER ,LVL_DOC , & & LVL_PHOSY ,LVL_PHOSPH ,LVL_OXYGEN , & & LVL_IRON ,LVL_ANO3 ,LVL_ALKALI , & @@ -241,6 +256,10 @@ MODULE mo_bgcmean & LVL_denit_NO2 ,LVL_denit_N2O ,LVL_DNRA_NO2 , & & LVL_anmx_N2_prod ,LVL_anmx_OM_prod ,LVL_phosy_NH4 , & & LVL_phosy_NO3 ,LVL_remin_aerob ,LVL_remin_sulf , & + & LVL_agg_ws ,LVL_dynvis ,LVL_agg_stick , & + & LVL_agg_stickf ,LVL_agg_dmax ,LVL_agg_avdp , & + & LVL_agg_avrhop ,LVL_agg_avdC ,LVL_agg_df , & + & LVL_agg_b ,LVL_agg_Vrhof ,LVL_agg_Vpor , & & SDM_POWAIC ,SDM_POWAAL ,SDM_POWAPH , & & SDM_POWAOX ,SDM_POWN2 ,SDM_POWNO3 , & & SDM_POWASI ,SDM_SSSO12 ,SDM_SSSSIL , & @@ -506,7 +525,19 @@ MODULE mo_bgcmean & jphosy_NH4 = 0 , & & jphosy_NO3 = 0 , & & jremin_aerob = 0 , & - & jremin_sulf = 0, & + & jremin_sulf = 0 , & + & jagg_ws = 0 , & + & jdynvis = 0 , & + & jagg_stick = 0 , & + & jagg_stickf = 0 , & + & jagg_dmax = 0 , & + & jagg_avdp = 0 , & + & jagg_avrhop = 0 , & + & jagg_avdC = 0 , & + & jagg_df = 0 , & + & jagg_b = 0 , & + & jagg_Vrhof = 0 , & + & jagg_Vpor = 0 , & & jlvlanh4 = 0 , & & jlvlano2 = 0 , & & jlvl_nitr_NH4 = 0 , & @@ -523,8 +554,19 @@ MODULE mo_bgcmean & jlvl_phosy_NH4 = 0 , & & jlvl_phosy_NO3 = 0 , & & jlvl_remin_aerob = 0 , & - & jlvl_remin_sulf = 0 - + & jlvl_remin_sulf = 0 , & + & jlvl_agg_ws = 0 , & + & jlvl_dynvis = 0 , & + & jlvl_agg_stick = 0 , & + & jlvl_agg_stickf = 0 , & + & jlvl_agg_dmax = 0 , & + & jlvl_agg_avdp = 0 , & + & jlvl_agg_avrhop = 0 , & + & jlvl_agg_avdC = 0 , & + & jlvl_agg_df = 0 , & + & jlvl_agg_b = 0 , & + & jlvl_agg_Vrhof = 0 , & + & jlvl_agg_Vpor = 0 INTEGER, SAVE :: nbgcm3d,nbgcm3dlvl !---------------------------------------------------------------- @@ -966,6 +1008,32 @@ SUBROUTINE ALLOC_MEM_BGCMEAN(kpie,kpje,kpke) IF (LYR_remin_sulf(n).GT.0) i_bsc_m3d=i_bsc_m3d+1 jremin_sulf(n)=i_bsc_m3d*min(1,LYR_remin_sulf(n)) #endif + ! M4AGO + IF (LYR_agg_ws(n).GT.0) i_bsc_m3d=i_bsc_m3d+1 + jagg_ws(n)=i_bsc_m3d*min(1,LYR_agg_ws(n)) + IF (LYR_dynvis(n).GT.0) i_bsc_m3d=i_bsc_m3d+1 + jdynvis(n)=i_bsc_m3d*min(1,LYR_dynvis(n)) + IF (LYR_agg_stick(n).GT.0) i_bsc_m3d=i_bsc_m3d+1 + jagg_stick(n)=i_bsc_m3d*min(1,LYR_agg_stick(n)) + IF (LYR_agg_stickf(n).GT.0) i_bsc_m3d=i_bsc_m3d+1 + jagg_stickf(n)=i_bsc_m3d*min(1,LYR_agg_stickf(n)) + IF (LYR_agg_dmax(n).GT.0) i_bsc_m3d=i_bsc_m3d+1 + jagg_dmax(n)=i_bsc_m3d*min(1,LYR_agg_dmax(n)) + IF (LYR_agg_avdp(n).GT.0) i_bsc_m3d=i_bsc_m3d+1 + jagg_avdp(n)=i_bsc_m3d*min(1,LYR_agg_avdp(n)) + IF (LYR_agg_avrhop(n).GT.0) i_bsc_m3d=i_bsc_m3d+1 + jagg_avrhop(n)=i_bsc_m3d*min(1,LYR_agg_avrhop(n)) + IF (LYR_agg_avdC(n).GT.0) i_bsc_m3d=i_bsc_m3d+1 + jagg_avdC(n)=i_bsc_m3d*min(1,LYR_agg_avdC(n)) + IF (LYR_agg_df(n).GT.0) i_bsc_m3d=i_bsc_m3d+1 + jagg_df(n)=i_bsc_m3d*min(1,LYR_agg_df(n)) + IF (LYR_agg_b(n).GT.0) i_bsc_m3d=i_bsc_m3d+1 + jagg_b(n)=i_bsc_m3d*min(1,LYR_agg_b(n)) + IF (LYR_agg_Vrhof(n).GT.0) i_bsc_m3d=i_bsc_m3d+1 + jagg_Vrhof(n)=i_bsc_m3d*min(1,LYR_agg_Vrhof(n)) + IF (LYR_agg_Vpor(n).GT.0) i_bsc_m3d=i_bsc_m3d+1 + jagg_Vpor(n)=i_bsc_m3d*min(1,LYR_agg_Vpor(n)) + IF (LVL_PHYTO(n).GT.0) ilvl_bsc_m3d=ilvl_bsc_m3d+1 jlvlphyto(n)=ilvl_bsc_m3d*min(1,LVL_PHYTO(n)) @@ -1115,6 +1183,31 @@ SUBROUTINE ALLOC_MEM_BGCMEAN(kpie,kpje,kpke) IF (LVL_remin_sulf(n).GT.0) ilvl_bsc_m3d=ilvl_bsc_m3d+1 jlvl_remin_sulf(n)=ilvl_bsc_m3d*min(1,LVL_remin_sulf(n)) #endif + ! M4AGO + IF (LVL_agg_ws(n).GT.0) ilvl_bsc_m3d=ilvl_bsc_m3d+1 + jlvl_agg_ws(n)=ilvl_bsc_m3d*min(1,LVL_agg_ws(n)) + IF (LVL_dynvis(n).GT.0) ilvl_bsc_m3d=ilvl_bsc_m3d+1 + jlvl_dynvis(n)=ilvl_bsc_m3d*min(1,LVL_dynvis(n)) + IF (LVL_agg_stick(n).GT.0) ilvl_bsc_m3d=ilvl_bsc_m3d+1 + jlvl_agg_stick(n)=ilvl_bsc_m3d*min(1,LVL_agg_stick(n)) + IF (LVL_agg_stickf(n).GT.0) ilvl_bsc_m3d=ilvl_bsc_m3d+1 + jlvl_agg_stickf(n)=ilvl_bsc_m3d*min(1,LVL_agg_stickf(n)) + IF (LVL_agg_dmax(n).GT.0) ilvl_bsc_m3d=ilvl_bsc_m3d+1 + jlvl_agg_dmax(n)=ilvl_bsc_m3d*min(1,LVL_agg_dmax(n)) + IF (LVL_agg_avdp(n).GT.0) ilvl_bsc_m3d=ilvl_bsc_m3d+1 + jlvl_agg_avdp(n)=ilvl_bsc_m3d*min(1,LVL_agg_avdp(n)) + IF (LVL_agg_avrhop(n).GT.0) ilvl_bsc_m3d=ilvl_bsc_m3d+1 + jlvl_agg_avrhop(n)=ilvl_bsc_m3d*min(1,LVL_agg_avrhop(n)) + IF (LVL_agg_avdC(n).GT.0) ilvl_bsc_m3d=ilvl_bsc_m3d+1 + jlvl_agg_avdC(n)=ilvl_bsc_m3d*min(1,LVL_agg_avdC(n)) + IF (LVL_agg_df(n).GT.0) ilvl_bsc_m3d=ilvl_bsc_m3d+1 + jlvl_agg_df(n)=ilvl_bsc_m3d*min(1,LVL_agg_df(n)) + IF (LVL_agg_b(n).GT.0) ilvl_bsc_m3d=ilvl_bsc_m3d+1 + jlvl_agg_b(n)=ilvl_bsc_m3d*min(1,LVL_agg_b(n)) + IF (LVL_agg_Vrhof(n).GT.0) ilvl_bsc_m3d=ilvl_bsc_m3d+1 + jlvl_agg_Vrhof(n)=ilvl_bsc_m3d*min(1,LVL_agg_Vrhof(n)) + IF (LVL_agg_Vpor(n).GT.0) ilvl_bsc_m3d=ilvl_bsc_m3d+1 + jlvl_agg_Vpor(n)=ilvl_bsc_m3d*min(1,LVL_agg_Vpor(n)) IF (i_bsc_m3d.NE.0) checkdp(n)=1 ENDDO diff --git a/hamocc/mo_biomod.F90 b/hamocc/mo_biomod.F90 index 5f373e8b..f69edade 100644 --- a/hamocc/mo_biomod.F90 +++ b/hamocc/mo_biomod.F90 @@ -104,7 +104,7 @@ MODULE mo_biomod REAL :: bluefix,tf2,tf1,tf0,tff REAL :: bkphy,bkzoo,bkopal REAL :: wpoc,wcal,wopal - REAL :: drempoc,dremopal,dremn2o,dremsul + REAL :: drempoc,dremopal,dremn2o,dremsul,drempoc_anaerob REAL :: perc_diron, riron, fesoly, relaxfe, fetune, wdust REAL :: ctochl, atten_w, atten_c, atten_uv, atten_f #ifdef cisonew diff --git a/hamocc/mo_control_bgc.F90 b/hamocc/mo_control_bgc.F90 index 4c36ce1e..9372c831 100644 --- a/hamocc/mo_control_bgc.F90 +++ b/hamocc/mo_control_bgc.F90 @@ -63,7 +63,7 @@ MODULE mo_control_bgc LOGICAL, save :: do_rivinpt =.true. ! apply riverine input LOGICAL, save :: do_sedspinup=.false. ! apply sediment spin-up logical, save :: with_dmsph =.false. ! apply DMS with pH dependence - + LOGICAL, save :: lm4ago =.true. ! run with M4AGO settling scheme contains subroutine get_bgc_namelist diff --git a/hamocc/mo_m4ago.F90 b/hamocc/mo_m4ago.F90 new file mode 100644 index 00000000..11b360f0 --- /dev/null +++ b/hamocc/mo_m4ago.F90 @@ -0,0 +1,932 @@ +!> +!! @par (c) Copyright +!! This software is provided under: +!! +!! The 3-Clause BSD License +!! SPDX short identifier: BSD-3-Clause +!! See https://opensource.org/licenses/BSD-3-Clause +!! +!! (c) Copyright 2016-2021 MPI-M, Joeran Maerz, Irene Stemmler; +!! first published 2020 +!! +!! Redistribution and use in source and binary forms, with or without +!! modification, are permitted provided that the following conditions are met: +!! +!! 1. Redistributions of source code must retain the above copyright notice, +!! this list of conditions and the following disclaimer. +!! 2. Redistributions in binary form must reproduce the above copyright notice, +!! this list of conditions and the following disclaimer in the documentation +!! and/or other materials provided with the distribution. +!! 3. Neither the name of the copyright holder nor the names of its contributors +!! may be used to endorse or promote products derived from this software +!! without specific prior written permission. +!! +!! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +!! AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +!! IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +!! ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE +!! LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +!! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +!! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +!! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +!! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +!! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +!! POSSIBILITY OF SUCH DAMAGE.[7] +!! +!! +!! ----------------------------------------------------------------------------- +!! ----------------------------------------------------------------------------- +!! @file mo_m4ago.F90 +!! @brief Module for Marine Aggregates: +!! The Microstructure, Multiscale, Mechanistic, Marine Aggregates +!! in the Global Ocean (M4AGO) sinking scheme +!! +!! The mo_aggregates module contains routines to calculate: +!! - aggregate properties +!! - mean sinking velocity of aggregates +!! +!! See: +!! Maerz et al. 2020: Microstructure and composition of marine aggregates +!! as co-determinants for vertical particulate organic +!! carbon transfer in the global ocean. +!! Biogeosciences, 17, 1765-1803, +!! https://doi.org/10.5194/bg-17-1765-2020 +!! +!! This module is written within the project: +!! Multiscale Approach on the Role of Marine Aggregates (MARMA) +!! funded by the Max Planck Society (MPG) +!! +!! @author: joeran maerz (joeran.maerz@mpimet.mpg.de), MPI-M, HH +!! 2019, June, revised by Irene Stemmler (refactoring, cleaning), MPI-M, HH +!! +!! 2023 adopted to iHAMOCC by joeran maerz, UiB, Bergen +!! +!! ----------------------------------------------------------------------------- +!! ----------------------------------------------------------------------------- +!! +!! + + + +MODULE mo_m4ago + USE mo_vgrid, ONLY: dp_min + USE mo_control_bgc, ONLY: dtb, dtbgc,io_stdo_bgc + USE mo_sedmnt, ONLY: calcdens, claydens, opaldens, calcwei, opalwei + USE mo_carbch, ONLY: ocetra + USE mo_param1_bgc, ONLY: iopal, ifdust, icalc, idet + USE mo_biomod, ONLY: ropal + + IMPLICIT NONE + + PRIVATE + + ! Public subroutines + PUBLIC :: mean_aggregate_sinking_speed, init_m4ago_nml_params, init_m4ago_params, alloc_mem_m4ago + + ! Public fields and parameters + PUBLIC :: ws_agg, POM_remin_q10, POM_remin_Tref, opal_remin_q10, opal_remin_Tref, & + & aggregate_diagnostics,kav_dp,kav_rho_p,kav_d_C,kws_agg,kdf_agg,kstickiness_agg,kb_agg,kstickiness_frustule, & + & kLmax_agg,kdynvis,kav_rhof_V,kav_por_V + + INTEGER :: i,j,k + + + ! model parameters + ! primary particle diameter for POM & PIM species involved in parametrized aggregation (m) + REAL :: dp_dust ! primary particle diameter dust + REAL :: dp_det ! primary particle diameter detritus + REAL :: dp_calc ! primary particle diameter calc + REAL :: dp_opal ! primary particle diameter opal + REAL :: stickiness_TEP ! stickiness of TEP (related to opal frustules) + REAL :: stickiness_det ! normal detritus stickiness + REAL :: stickiness_opal ! stickiness of opal (without TEP - just normal coating) + REAL :: stickiness_calc ! stickiness of calc particles (coated with organics) + REAL :: stickiness_dust ! stickiness of dust particles (coated with organics) + REAL :: agg_df_max ! maximum fractal dimension of aggregates (~2.5) + REAL :: agg_df_min ! minimum fractal dimension of aggregates (~1.2 - 1.6) + REAL :: rho_TEP ! density of TEP particles + REAL :: agg_org_dens ! organic detritus density (alternative to orgdens to avoid negative ws) + + REAL :: agg_Re_crit ! critical particle Reynolds number for nr-distribution limiting + REAL :: POM_remin_q10 ! Q10 factor for organic remineralization (POC) + REAL :: POM_remin_Tref + REAL :: opal_remin_q10 ! Q10 factor for silicate remineralization (OPAL) + REAL :: opal_remin_Tref + + REAL,ALLOCATABLE :: av_dp(:,:,:), & ! mean primary particle diameter + & av_rho_p(:,:,:), & ! mean primary particle density + & df_agg(:,:,:), & ! fractal dimension of aggregates + & b_agg(:,:,:), & ! aggregate number distribution slope + & Lmax_agg(:,:,:), & ! maximum diameter of aggregates + & ws_agg(:,:,:), & ! aggregate mean sinking velocity + & stickiness_agg(:,:,:), & ! mean aggregate stickiness + & stickiness_frustule(:,:,:),& ! frustule stickiness + & N_agg(:,:,:), & ! Number of aggregates + & av_d_C(:,:,:), & ! concentration-weighted mean diameter of aggs + & dyn_vis(:,:,:), & ! molecular dynamic viscosity + & m4ago_ppo(:,:,:) ! in situ pressure - potentially to replace by BLOM pressure + + INTEGER, PARAMETER :: & + kav_dp = 1, & + kav_rho_p = 2, & + kav_d_C = 3, & + kws_agg = 4, & + kdf_agg = 5, & + kstickiness_agg = 6, & + kb_agg = 7, & + kstickiness_frustule = 8, & + kLmax_agg = 9, & + kdynvis = 10, & + kav_rhof_V = 11, & + kav_por_V = 12, & + naggdiag = 12 + + REAL, DIMENSION (:,:,:,:), ALLOCATABLE, TARGET :: aggregate_diagnostics ! 3d concentration EU + + + + ! Internally used parameters and values + REAL, PARAMETER :: ONE_SIXTH = 1./6. + REAL, PARAMETER :: PI = 3.141592654 + REAL, PARAMETER :: NUM_FAC = 1.e9 ! factor to avoid numerical precision problems + REAL, PARAMETER :: EPS_ONE = EPSILON(1.) + + REAL :: det_mol2mass ! mol detritus P/m^3 to kg POM /m^3 (according to stoichiometry) + REAL :: AJ1, AJ2, AJ3, BJ1, BJ2, BJ3 ! constants for CD + REAL :: grav_acc_const ! gravitational acceleration constant + REAL :: rho_aq ! water reference density (1025 kg/m^3) + REAL :: n_det,n_opal,n_calc,n_dust ! total primary particle number (#) + REAL :: mf ! mass factor for aggregates + REAL :: V_dp_dust,V_dp_det,V_dp_calc,V_dp_opal ! volumes of primary particles (L^3) + REAL :: A_dp_dust,A_dp_det,A_dp_calc,A_dp_opal ! surface areas of primary particles (L^2) + REAL :: A_dust,A_det,A_calc,A_opal,A_total ! total surface area of primary particles per unit volume (L^2/L^3) + REAL :: stickiness_min, stickiness_max ! minimum and maximum stickiness of primary particles + REAL :: stickiness_mapped ! mapped mean stickiness of particles on range (0,1) + REAL :: df_slope ! slope for stickiness to fractal dimension mapping + REAL :: rho_V_dp_dust,rho_V_dp_det,rho_V_dp_calc ! rho_V_dp_opal ! mass of primary particles (M) + REAL :: V_det,V_opal,V_calc,V_dust,V_solid ! total volume of primary particles in a unit volume (L^3/L^3) + REAL :: Rm_SiP ! molar mass ratio opal (SiO_2) to POM + REAL :: thick_shell ! diatom frustule shell thickness (L) + REAL :: d_frustule_inner ! diameter of hollow part in diatom frustule (L) + REAL :: V_frustule_inner ! volume of hollow part in diatom frustule (L^3) + REAL :: V_frustule_opal ! volume of opal shell material (L^3) + REAL :: rho_V_frustule_opal ! mass of frustule material (M) + REAL :: cell_det_mass ! mass of detritus material in diatoms + REAL :: cell_pot_det_mass ! potential (max) mass detritus material in diatoms + REAL :: free_detritus ! freely available detritus mass outside the frustule + REAL :: V_POM_cell ! volume of POM in frustule + REAL :: V_aq ! volume of water space in frustule + REAL :: rho_frustule ! density of diatom frustule incl. opal, detritus and water + REAL :: rho_diatom ! density of either hollow frustule + + CONTAINS + + !===================================================================================== m4ago_init_params + SUBROUTINE init_m4ago_nml_params + !> + !! Initialization of namelist parameters + !! + IMPLICIT NONE + ! Primary particle sizes + dp_dust = 2.e-6 ! following the classical HAMOCC parametrization + dp_det = 4.e-6 ! not well defined + dp_calc = 3.e-6 ! following Henderiks 2008, Henderiks & Pagani 2008 + dp_opal = 20.e-6 ! rough guestimate - literature search required + + ! Stickiness values + stickiness_TEP = 0.19 + stickiness_det = 0.1 + stickiness_opal = 0.08 + stickiness_calc = 0.09 + stickiness_dust = 0.07 + + ! minimum and maximum aggregate fractal dimension + agg_df_min = 1.6 + agg_df_max = 2.4 + + ! Density of primary particles + rho_TEP = 800. ! 700.-840. kg/m^3 Azetsu-Scott & Passow 2004 + agg_org_dens = 1100. ! detritus density - don't use orgdens to avoid negative ws + + agg_Re_crit = 20. ! critical particle Reynolds number for limiting nr-distribution + + POM_remin_q10 = 2.1 ! Bidle et al. 2002: Regulation of Oceanic Silicon... + opal_remin_q10 = 2.6 ! Bidle et al. 2002: Regulation of Oceanic Silicon... + POM_remin_Tref = 10. + opal_remin_Tref = 10. + END SUBROUTINE init_m4ago_nml_params + + SUBROUTINE init_m4ago_params + !> + !! Initilization of parameters + !! + + IMPLICIT NONE + det_mol2mass = 3166. ! mol detritus P/m^3 to kg POM /m^3 (according to stoichiometry) + grav_acc_const = 9.81 ! gravitational acceleration constant + rho_aq = 1025. ! water reference density (1025 kg/m^3) + + ! CD parameters (formula 16) + AJ1 = 24.00 + AJ2 = 29.03 + AJ3 = 14.15 + BJ1 = 1.0 + BJ2 = 0.871 + BJ3 = 0.547 + + V_dp_dust = ONE_SIXTH*PI*dp_dust**3.*NUM_FAC + V_dp_det = ONE_SIXTH*PI*dp_det**3.*NUM_FAC + V_dp_calc = ONE_SIXTH*PI*dp_calc**3.*NUM_FAC + V_dp_opal = ONE_SIXTH*PI*dp_opal**3.*NUM_FAC + A_dp_dust = PI*dp_dust**2.*NUM_FAC + A_dp_det = PI*dp_det**2.*NUM_FAC + A_dp_calc = PI*dp_calc**2.*NUM_FAC + A_dp_opal = PI*dp_opal**2.*NUM_FAC + + rho_V_dp_dust = V_dp_dust*claydens + rho_V_dp_det = V_dp_det*agg_org_dens + rho_V_dp_calc = V_dp_calc*calcdens + + Rm_SiP = ropal*opalwei/det_mol2mass + ! shell thickness + thick_shell = 0.5*dp_opal*(1. - (opaldens/(Rm_SiP*agg_org_dens+opaldens))**(1./3.)) + d_frustule_inner = dp_opal - 2.*thick_shell + ! volume of hollow part of frustule + V_frustule_inner = ONE_SIXTH* PI*d_frustule_inner**3.*NUM_FAC + ! volume of opal part of frustule + V_frustule_opal = ONE_SIXTH*PI*(dp_opal**3. - d_frustule_inner**3.)*NUM_FAC + rho_V_frustule_opal = V_frustule_opal*opaldens + + stickiness_min = MIN(stickiness_TEP, stickiness_det, stickiness_opal, stickiness_calc, stickiness_dust) + stickiness_max = MAX(stickiness_TEP, stickiness_det, stickiness_opal, stickiness_calc, stickiness_dust) + df_slope = LOG( agg_df_min / agg_df_max) + END SUBROUTINE init_m4ago_params + + + SUBROUTINE alloc_mem_m4ago(kpie, kpje, kpke) + !----------------------------------------------------------------------- + !> + !! Initialization/allocation fields + !! Called in ini_bgc after read_namelist + !! + + IMPLICIT NONE + + INTEGER, INTENT(in) :: kpie !< 1st REAL of model grid. + INTEGER, INTENT(in) :: kpje !< 2nd REAL of model grid. + INTEGER, INTENT(in) :: kpke !< 3rd (vertical) REAL of model grid. + + ! allocate memory space for aggregate properties + ALLOCATE(av_dp(kpie,kpje,kpke)) + ALLOCATE(av_rho_p(kpie,kpje,kpke)) + ALLOCATE(df_agg(kpie,kpje,kpke)) + ALLOCATE(b_agg(kpie,kpje,kpke)) + ALLOCATE(Lmax_agg(kpie,kpje,kpke)) + ALLOCATE(av_d_C(kpie,kpje,kpke)) + ALLOCATE(stickiness_agg(kpie,kpje,kpke)) + ALLOCATE(stickiness_frustule(kpie,kpje,kpke)) + ALLOCATE(aggregate_diagnostics(kpie, kpje, kpke, naggdiag)) + + ! mean sinking velocity + ALLOCATE(ws_agg(kpie,kpje,kpke)) + + ! molecular dynamic viscosity + ALLOCATE(dyn_vis(kpie, kpje, kpke)) + ALLOCATE(m4ago_ppo(kpie,kpje,kpke)) + + av_dp = 0. + av_rho_p = 0. + df_agg = 0. + b_agg = 0. + Lmax_agg = 0. + av_d_C = 0. + stickiness_agg = 0. + stickiness_frustule = 0. + aggregate_diagnostics = 0. + m4ago_ppo = 0. + + END SUBROUTINE alloc_mem_m4ago + + SUBROUTINE cleanup_mem_m4ago + + DEALLOCATE(av_dp) + DEALLOCATE(av_rho_p) + DEALLOCATE(df_agg) + DEALLOCATE(b_agg) + DEALLOCATE(Lmax_agg) + DEALLOCATE(av_d_C) + DEALLOCATE(stickiness_agg) + DEALLOCATE(stickiness_frustule) + DEALLOCATE(aggregate_diagnostics) + DEALLOCATE(ws_agg) + DEALLOCATE(dyn_vis) + DEALLOCATE(m4ago_ppo) + END SUBROUTINE cleanup_mem_m4ago + + !===================================================================================== pressure + SUBROUTINE calc_pressure(kpie, kpje, kpke,kbnd, pddpo,omask, ppao, prho) + IMPLICIT NONE + + INTEGER, INTENT(in) :: kpie !< 1st REAL of model grid. + INTEGER, INTENT(in) :: kpje !< 2nd REAL of model grid. + INTEGER, INTENT(in) :: kpke !< 3rd (vertical) REAL of model grid. + INTEGER, INTENT(in) :: kbnd + REAL, INTENT(in) :: pddpo(kpie,kpje,kpke) !< size of scalar grid cell (3rd dimension) [m] + REAL, INTENT(in) :: omask(kpie,kpje) + REAL, INTENT(in) :: ppao (1-kbnd:kpie+kbnd,1-kbnd:kpje+kbnd) !< pressure at sea level [Pa]. + REAL, INTENT(in) :: prho (kpie,kpje,kpke) !< salinity [psu.]. + + !$OMP PARALLEL DO PRIVATE(i,j,k) + do j = 1,kpje + do i = 1,kpie + if(omask(i,j) > 0.5) then + m4ago_ppo(i,j,1) = ppao(i,j) + prho(i,j,1)*grav_acc_const*pddpo(i,j,1) + do k = 2,kpke + if(pddpo(i,j,k) > dp_min) then + m4ago_ppo(i,j,k) = m4ago_ppo(i,j,k-1) + prho(i,j,k)*grav_acc_const*pddpo(i,j,k) + endif + enddo + endif + enddo + enddo + !$OMP END PARALLEL DO + END SUBROUTINE calc_pressure + + !===================================================================================== mean_agg_ws + SUBROUTINE mean_aggregate_sinking_speed(kpie, kpje, kpke, kbnd, pddpo, omask, ptho, psao, ppao, prho) + !----------------------------------------------------------------------- + !> + !! calculates the mass concentration-weighted mean sinking velocity of marine + !! aggregates + !! + + IMPLICIT NONE + + INTEGER, INTENT(in) :: kpie !< 1st REAL of model grid. + INTEGER, INTENT(in) :: kpje !< 2nd REAL of model grid. + INTEGER, INTENT(in) :: kpke !< 3rd (vertical) REAL of model grid. + INTEGER, INTENT(in) :: kbnd + REAL, INTENT(in) :: pddpo(kpie,kpje,kpke) !< size of scalar grid cell (3rd dimension) [m] + REAL, INTENT(in) :: omask(kpie,kpje) + REAL, INTENT(in) :: ptho (1-kbnd:kpie+kbnd,1-kbnd:kpje+kbnd,kpke) !< potential temperature [deg C] + REAL, INTENT(in) :: psao (1-kbnd:kpie+kbnd,1-kbnd:kpje+kbnd,kpke) !< salinity [psu.]. + REAL, INTENT(in) :: ppao (1-kbnd:kpie+kbnd,1-kbnd:kpje+kbnd) !< pressure at sea level [Pa]. + REAL, INTENT(in) :: prho (kpie,kpje,kpke) !< salinity [psu.]. + + CALL calc_pressure(kpie, kpje, kpke,kbnd, pddpo, omask, ppao, prho) + + ! molecular dynamic viscosity + CALL dynvis(kpie, kpje, kpke, kbnd, pddpo, omask, ptho, psao, m4ago_ppo) + + ! ======== calculate the mean sinking velocity of aggregates ======= + CALL aggregate_properties(kpie, kpje, kpke, kbnd, pddpo, omask, ptho) + CALL ws_Re_approx(kpie, kpje, kpke, pddpo, omask) + + !$OMP PARALLEL DO PRIVATE(i,j,k) + DO j = 1,kpje + DO i = 1,kpie + DO k = 1,kpke + IF(pddpo(i,j,k) > dp_min .and. omask(i,j) > 0.5) THEN + ! Limit settling velocity wrt CFL: + ws_agg(i,j,k) = MIN(ws_agg(i,j,k), 0.99*pddpo(i,j,k)) + + ! ============================== Write general diagnostics ============ + ! ----- settling velocity-related ----- + aggregate_diagnostics(i,j,k,kws_agg) = ws_agg(i,j,k)/dtb ! applied ws conversion m/time_step to m/d for output + + ! ----- settling environment ----- + aggregate_diagnostics(i,j,k,kdynvis) = dyn_vis(i,j,k) ! dynamic viscosity + + ! ----- aggregate properties ----- + av_d_C(i,j,k) = (1. + df_agg(i,j,k) - b_agg(i,j,k)) & + & /(2. + df_agg(i,j,k) - b_agg(i,j,k)) & + & *(Lmax_agg(i,j,k)**(2. + df_agg(i,j,k) - b_agg(i,j,k)) & + & - av_dp(i,j,k)**(2. + df_agg(i,j,k) - b_agg(i,j,k))) & + & / (Lmax_agg(i,j,k)**(1.+df_agg(i,j,k)-b_agg(i,j,k)) & + & - av_dp(i,j,k)**(1. + df_agg(i,j,k)-b_agg(i,j,k))) + + aggregate_diagnostics(i,j,k,kstickiness_agg) = stickiness_agg(i,j,k) ! aggre. stickiness + aggregate_diagnostics(i,j,k,kstickiness_frustule) = stickiness_frustule(i,j,k) ! frustule stickiness + + aggregate_diagnostics(i,j,k,kLmax_agg) = Lmax_agg(i,j,k) ! applied max. diameter + aggregate_diagnostics(i,j,k,kav_dp) = av_dp(i,j,k) ! mean primary particle diameter + aggregate_diagnostics(i,j,k,kav_rho_p) = av_rho_p(i,j,k) ! mean primary particle density + aggregate_diagnostics(i,j,k,kav_d_C) = av_d_C(i,j,k) ! conc-weighted mean agg. diameter + aggregate_diagnostics(i,j,k,kdf_agg) = df_agg(i,j,k) ! aggregate fractal dim + aggregate_diagnostics(i,j,k,kb_agg) = b_agg(i,j,k) ! aggre number distr. slope + + ! volume-weighted aggregate density + aggregate_diagnostics(i,j,k,kav_rhof_V) = (av_rho_p(i,j,k)-rho_aq)*av_dp(i,j,k)**(3.-df_agg(i,j,k)) & + & *(4.-b_agg(i,j,k))*(Lmax_agg(i,j,k)**(1.+df_agg(i,j,k)-b_agg(i,j,k)) & + & - av_dp(i,j,k)**(1.+df_agg(i,j,k)-b_agg(i,j,k))) & + & / ((1.+df_agg(i,j,k)-b_agg(i,j,k)) & + & *(Lmax_agg(i,j,k)**(4.-b_agg(i,j,k)) - av_dp(i,j,k)**(4.-b_agg(i,j,k)))) + rho_aq + + ! volume-weighted aggregate porosity + aggregate_diagnostics(i,j,k,kav_por_V) = 1. - ((4.-b_agg(i,j,k)) & + & *av_dp(i,j,k)**(3.-df_agg(i,j,k)) & + & *(Lmax_agg(i,j,k)**(1.+df_agg(i,j,k)-b_agg(i,j,k)) & + & - av_dp(i,j,k)**(1.+df_agg(i,j,k)-b_agg(i,j,k)))) & + & / ((1.+df_agg(i,j,k)-b_agg(i,j,k)) & + & *(Lmax_agg(i,j,k)**(4.-b_agg(i,j,k)) - av_dp(i,j,k)**(4.-b_agg(i,j,k)))) + END IF + END DO + END DO + END DO + + END SUBROUTINE mean_aggregate_sinking_speed + + !===================================================================================== aggregate_properties + SUBROUTINE aggregate_properties(kpie, kpje, kpke, kbnd, pddpo, omask, ptho) + !----------------------------------------------------------------------- + !> + !! aggregate_properties calculates + !! - mean stickiness/aggrega + !! - fractal dimension + !! - slope of aggregate spectrum + !! - mean primary particle diameter + !! - mean primary particle density + !! - maximum aggregate diameter + !! + + IMPLICIT NONE + + INTEGER, INTENT(in) :: kpie !< 1st REAL of model grid. + INTEGER, INTENT(in) :: kpje !< 2nd REAL of model grid. + INTEGER, INTENT(in) :: kpke !< 3rd (vertical) REAL of model grid. + INTEGER, INTENT(in) :: kbnd + REAL, INTENT(in) :: pddpo(kpie,kpje,kpke) !< size of scalar grid cell (3rd dimension) [m] + REAL, INTENT(in) :: omask(kpie,kpje) + REAL, INTENT(in) :: ptho (1-kbnd:kpie+kbnd,1-kbnd:kpje+kbnd,kpke) !< potential temperature [deg C] + + REAL :: C_det,C_opal,C_calc,C_dust + !$OMP PARALLEL DO PRIVATE(i,j,k,C_det,C_opal,C_calc,C_dust,n_det,n_opal,n_dust,n_calc,mf,V_det,V_opal,V_calc,V_dust,V_solid, & + !$OMP free_detritus,rho_diatom,cell_det_mass,cell_pot_det_mass,V_POM_cell,V_aq,rho_frustule,A_det,A_opal, & + !$OMP A_calc,A_dust,A_total,stickiness_mapped) + DO j = 1,kpje + DO i = 1,kpie + DO k = 1,kpke + IF(pddpo(i,j,k) > dp_min .and. omask(i,j) > 0.5) THEN + C_det = 0. + C_opal = 0. + C_calc = 0. + C_dust = 0. + + C_det = ABS(ocetra(i,j,k,idet)) + C_opal = ABS(ocetra(i,j,k,iopal)) + C_calc = ABS(ocetra(i,j,k,icalc)) + C_dust = ABS(ocetra(i,j,k,ifdust)) + + n_det = 0. ! number of primary particles + n_opal = 0. + n_dust = 0. + n_calc = 0. + mf = 0. + + V_det = 0. ! total volume of primary particles in a unit volume + V_opal = 0. + V_calc = 0. + V_dust = 0. + V_solid = 0. + + free_detritus = 0. + rho_diatom = 0. + ! n_det are detritus primary particle that are + ! NOT linked to any diatom frustule + ! n_opal are number of frustule-like primary particles possessing + ! a density i) different from pure opal ii) due to a mixture of + ! opal frustule, detritus inside the frustule and potentially water + ! inside the frustule + + ! describing diatom frustule as hollow sphere + ! that is completely or partially filled with detritus + ! and water + cell_det_mass = 0. + cell_pot_det_mass = 0. + V_POM_cell = 0. + V_aq = 0. + rho_frustule = 0. + + ! number of opal frustules (/NUM_FAC) + n_opal = C_opal*opalwei/rho_V_frustule_opal + ! maximum mass of detritus inside a frustule + cell_pot_det_mass = n_opal*V_frustule_inner*agg_org_dens + + ! detritus mass inside frustules + cell_det_mass = MIN(cell_pot_det_mass, C_det*det_mol2mass - EPS_ONE) + + ! volume of detritus component in cell + V_POM_cell = (cell_det_mass/n_opal)/agg_org_dens + + ! if not detritus is available, water is added + V_aq = V_frustule_inner - V_POM_cell + + ! density of the diatom frsutules incl. opal, detritus and water + rho_frustule = (rho_V_frustule_opal + cell_det_mass/n_opal + V_aq*rho_aq)/V_dp_opal + + ! mass of extra cellular detritus particles + free_detritus = C_det*det_mol2mass - cell_det_mass + rho_diatom = (rho_frustule + cell_det_mass/cell_pot_det_mass*rho_TEP) & + /(1. + cell_det_mass/cell_pot_det_mass) + + ! number of primary particles + n_det = free_detritus/rho_V_dp_det ! includes NUM_FAC + n_calc = C_calc*calcwei/rho_V_dp_calc + n_dust = C_dust/rho_V_dp_dust ! dust is in kg/m3 + + ! primary particles surface weighted stickiness is mapped + ! on range between 0 and 1 + ! fractal dimension of aggregates is based on that mapped df + ! number distribution slope b is based on df + + ! calc total areas + A_det = n_det*A_dp_det + A_opal = n_opal*A_dp_opal + A_calc = n_calc*A_dp_calc + A_dust = n_dust*A_dp_dust + A_total = A_det + A_opal + A_calc + A_dust + + ! calc frustule stickiness + stickiness_frustule(i,j,k) = cell_det_mass/(cell_pot_det_mass + EPS_ONE)*stickiness_TEP & + & + (1. - cell_det_mass/(cell_pot_det_mass + EPS_ONE))*stickiness_opal + + ! calc mean stickiness + stickiness_agg(i,j,k) = stickiness_frustule(i,j,k)*A_opal & + & + stickiness_det*A_det & + & + stickiness_calc*A_calc & + & + stickiness_dust*A_dust + + stickiness_agg(i,j,k) = stickiness_agg(i,j,k)/(A_total+EPS_ONE) + + stickiness_mapped = (stickiness_agg(i,j,k) - stickiness_min) & + & /(stickiness_max - stickiness_min) + + df_agg(i,j,k) = agg_df_max*EXP(df_slope*stickiness_mapped) + + ! Slope is here positive defined (as n(d)~d^-b), so *-1 of + ! Jiang & Logan 1991: Fractal dimensions of aggregates + ! determined from steady-state size distributions. + ! Environ. Sci. Technol. 25, 2031-2038. + ! + ! See also: + ! Hunt 1980: Prediction of oceanic particle size distributions + ! from coagulation and sedimentation mechanisms. + ! + ! Additional assumptions made here: + ! b in Jiang & Logan (used for Re < 0.1: b=1 + ! for 0.1 < Re < 10 : b=0.871 + ! for 10 < Re < 100 : b=0.547) + ! is set to 0.871 as an 'average for our range of 0 Formulation in Jiang & Logan 1991: + ! slope = -0.5*(3+df+(2+df-D2)/(2-b)) reduces to: + + b_agg(i,j,k) = 0.5*(3. + df_agg(i,j,k) & + & + (2. + df_agg(i,j,k) - MIN(2., df_agg(i,j,k)))/(2. - BJ2)) + + ! careful: for df=1.5904: b_agg=2*df where w_s is undefined. + + ! total volume of primary particles + V_det = n_det*V_dp_det*NUM_FAC + V_opal = n_opal*V_dp_opal*NUM_FAC + V_calc = n_calc*V_dp_calc*NUM_FAC + V_dust = n_dust*V_dp_dust*NUM_FAC + V_solid = V_det + V_opal + V_calc + V_dust + + ! primary particle mean diameter according to Bushell & Amal 1998, 2000 + ! sum(n_i) not changing - can be pulled out and thus cancels out + av_dp(i,j,k) = (n_calc*dp_calc**3. + n_dust*dp_dust**3. + n_opal*dp_opal**3. + n_det*dp_det**3.) + av_dp(i,j,k) = av_dp(i,j,k)/(n_calc*dp_calc**df_agg(i,j,k) + n_dust*dp_dust**df_agg(i,j,k) & + & + n_opal*dp_opal**df_agg(i,j,k) + n_det*dp_det**df_agg(i,j,k)) + av_dp(i,j,k) = av_dp(i,j,k)**(1./(3. - df_agg(i,j,k))) + + ! density of mean primary particles + av_rho_p(i,j,k) = (V_det*agg_org_dens + V_opal*rho_diatom + V_calc*calcdens + V_dust*claydens)/V_solid + END IF + END DO + END DO + END DO + !$OMP END PARALLEL DO + + ! calculate the maximum diameter of aggregates based on agg props + CALL max_agg_diam(kpie, kpje, kpke, pddpo, omask) + + END SUBROUTINE aggregate_properties + + + !================================== Reynolds number based on diameter + REAL FUNCTION Re_fun(ws,d,mu,rho) + !----------------------------------------------------------------------- + !> + !! Reynolds number for settling particles + !! + + IMPLICIT NONE + + REAL,INTENT(in) :: ws,d,mu,rho + + Re_fun = ABS(ws*d*rho/mu) + + END FUNCTION Re_fun + + + !================================================================================================== + !===================================================================================== ws_Re_approx + SUBROUTINE ws_Re_approx(kpie, kpje, kpke, pddpo, omask) + !----------------------------------------------------------------------- + !> + !! ws_Re_approx: distribution integrated to Lmax (Re crit dependent maximum agg size) + !! Renolds number-dependent sinking velocity. + !! Approximation for c_D-value taken from Jiang & Logan 1991: + !! c_D=a*Re^-b + !! + + IMPLICIT NONE + + INTEGER, INTENT(in) :: kpie !< 1st REAL of model grid. + INTEGER, INTENT(in) :: kpje !< 2nd REAL of model grid. + INTEGER, INTENT(in) :: kpke !< 3rd (vertical) REAL of model grid. + REAL, INTENT(in) :: pddpo(kpie,kpje,kpke) !< size of scalar grid cell (3rd dimension) [m] + REAL, INTENT(in) :: omask(kpie,kpje) + + !$OMP PARALLEL DO PRIVATE(i,j,k) + DO j = 1,kpje + DO i = 1,kpie + DO k = 1,kpke + IF(pddpo(i,j,k) > dp_min .and. omask(i,j) > 0.5) THEN + ws_agg(i,j,k) = ws_Re(i,j,k,Lmax_agg(i,j,k)) + END IF + END DO + END DO + END DO + !$OMP END PARALLEL DO + + END SUBROUTINE ws_Re_approx + + REAL FUNCTION get_dRe(i, j, k, AJ, BJ, Re) + IMPLICIT NONE + ! Arguments + INTEGER, INTENT(in) :: i !< 1st REAL of model grid. + INTEGER, INTENT(in) :: j !< 2nd REAL of model grid. + INTEGER, INTENT(in) :: k !< 3rd (vertical) REAL of model grid. + REAL, INTENT(in) :: AJ + REAL, INTENT(in) :: BJ + REAL, INTENT(in) :: Re + + ! Local variables + + REAL :: nu_vis + + nu_vis = dyn_vis(i,j,k)/rho_aq + + get_dRe = (Re*nu_vis)**((2. - BJ)/df_agg(i,j,k))/(4./3.*(av_rho_p(i,j,k) - rho_aq)/rho_aq & + *av_dp(i,j,k)**(3. - df_agg(i,j,k))*grav_acc_const/(AJ*nu_vis**(BJ)))**(1./df_agg(i,j,k)) + + END FUNCTION get_dRe + + REAL FUNCTION get_ws_agg_integral(i, j, k, AJ, BJ, lower_bound, upper_bound) + IMPLICIT NONE + + INTEGER, INTENT(in) :: i !< 1st REAL of model grid. + INTEGER, INTENT(in) :: j !< 2nd REAL of model grid. + INTEGER, INTENT(in) :: k !< 3rd (vertical) REAL of model grid. + + REAL, INTENT(in) :: AJ + REAL, INTENT(in) :: BJ + REAL, INTENT(in) :: upper_bound + REAL, INTENT(in) :: lower_bound + + ! Local variables + REAL :: nu_vis + + nu_vis = dyn_vis(i,j,k)/rho_aq + get_ws_agg_integral = (4./3.*(av_rho_p(i,j,k) - rho_aq)/rho_aq & + & *av_dp(i,j,k)**(3. - df_agg(i,j,k))*grav_acc_const & + & /(AJ*nu_vis**BJ))**(1./(2. - BJ)) & + & *(upper_bound**(1. - b_agg(i,j,k) + df_agg(i,j,k) & + & + (BJ + df_agg(i,j,k) - 2.)/(2. - BJ)) & + & /(1. - b_agg(i,j,k) + df_agg(i,j,k) + (BJ + df_agg(i,j,k) - 2.)/(2. - BJ)) & + & - lower_bound**(1. - b_agg(i,j,k) + df_agg(i,j,k) + (BJ + df_agg(i,j,k) - 2.) & + & /(2. - BJ)) & + & /(1. - b_agg(i,j,k) + df_agg(i,j,k) + (BJ + df_agg(i,j,k) - 2.)/(2. - BJ))) + + END FUNCTION get_ws_agg_integral + + !===================================================================================== ws_Re + REAL FUNCTION ws_Re(i,j,k,dmax_agg) + !----------------------------------------------------------------------- + !> + !! ws_Re: distribution integrated to Lmax (Re crit dependent maximum agg size) + !! Reynolds number-dependent sinking velocity. + !! Approximation for c_D-value taken from Jiang & Logan 1991: + !! c_D=a*Re^-b + !! written in such a way that we check the critical Reynolds + !! number (in case that we extend the maximum size by shear- + !! driven break-up). + !! + + IMPLICIT NONE + + INTEGER, INTENT(in) :: i !< 1st REAL of model grid. + INTEGER, INTENT(in) :: j !< 2nd REAL of model grid. + INTEGER, INTENT(in) :: k !< 3rd (vertical) REAL of model grid. + REAL, INTENT(in) :: dmax_agg + + ! Local + REAL :: d_Re01, d_Re10, d_low, ws_agg_ints + + ! for Re-dependent, it should always be agg_Re_crit>10 + ! for shear-driven break-up, check against integration bounds + ! calc integration limits for Re-dependent sinking: + ! Re=0.1 + d_Re01 = get_dRe(i,j,k, AJ1, BJ1, 0.1) + ! Re=10 + d_Re10 = get_dRe(i,j,k, AJ2, BJ2, 10.) + d_low = av_dp(i,j,k) + + ws_agg_ints = 0. + IF(dmax_agg >= d_Re01)THEN ! Re > 0.1 + ! - collect full range up to + ! 0.1, (dp->d_Re1) and set lower bound to + ! Re=0.1 val + ! aj=AJ1, bj=1 + ws_agg_ints = get_ws_agg_integral(i, j, k, AJ1, BJ1, av_dp(i,j,k), d_Re01) + d_low = d_Re01 + ENDIF + + IF(dmax_agg >= d_Re10)THEN ! Re > 10 + ! - collect full range Re=0.1-10 (d_Re1-> d_Re2) + ! and set lower bound to + ! Re=10 val + ! aj=AJ2, bj=0.871 + ws_agg_ints = ws_agg_ints + get_ws_agg_integral(i, j, k, AJ2, BJ2, d_Re01, d_Re10) + d_low = d_Re10 + ENDIF + + IF(d_low < d_Re01)THEN ! Re<0.1 and Lmax < d_Re1 + ws_agg_ints = get_ws_agg_integral(i, j, k, AJ1, BJ1, av_dp(i,j,k), dmax_agg) + ELSE ! Re > 10, aj=AJ3, bj=BJ3 + ws_agg_ints = ws_agg_ints + get_ws_agg_integral(i, j, k, AJ3, BJ3, d_low, dmax_agg) + ENDIF + + ! concentration-weighted mean sinking velocity + ws_Re = (ws_agg_ints & + & /((dmax_agg**(1. + df_agg(i,j,k) - b_agg(i,j,k)) & + & - av_dp(i,j,k)**(1. + df_agg(i,j,k) - b_agg(i,j,k))) & + & / (1. + df_agg(i,j,k) - b_agg(i,j,k))))*dtbgc ! (m/s -> m/d) *dtb + + END FUNCTION ws_Re + + + SUBROUTINE max_agg_diam(kpie, kpje, kpke, pddpo, omask) + !----------------------------------------------------------------------- + !> + !! max_agg_diam calculates the maximum aggregate diameter of the aggregate + !! number distribution, assumes Re_crit > 10 + !! + INTEGER, INTENT(in) :: kpie !< 1st REAL of model grid. + INTEGER, INTENT(in) :: kpje !< 2nd REAL of model grid. + INTEGER, INTENT(in) :: kpke !< 3rd (vertical) REAL of model grid. + REAL, INTENT(in) :: pddpo(kpie,kpje,kpke) !< size of scalar grid cell (3rd dimension) [m] + REAL, INTENT(in) :: omask(kpie,kpje) + + !$OMP PARALLEL DO PRIVATE(i,j,k) + ! base on analytical Jiang approximation + DO j = 1,kpje + DO i = 1,kpie + DO k = 1,kpke + IF(pddpo(i,j,k) > dp_min .and. omask(i,j) > 0.5) THEN + Lmax_agg(i,j,k) = max_agg_diam_white(i,j,k) + END IF + END DO + END DO + END DO + !$OMP END PARALLEL DO + END SUBROUTINE max_agg_diam + + !================================================ maximum diameter of agg in non-stratified fluid + REAL FUNCTION max_agg_diam_white(i,j,k) + !------------------------------------------------------------------------- + !> + !! maximum aggregate diameter in a non-stratified fluid - following the + !! White drag approaximation by Jiang & Logan 1991, assuming agg_re_crit > 10 + !! (otherwise AJX,BJX needs to be adjusted) + !! + + IMPLICIT NONE + + INTEGER,INTENT(in) :: i,j,k + REAL :: nu_vis + + nu_vis = dyn_vis(i,j,k)/rho_aq + max_agg_diam_white = (agg_Re_crit*nu_vis)**((2. - BJ3)/df_agg(i,j,k)) & + & /((4./3.)*(av_rho_p(i,j,k) - rho_aq)/rho_aq & + & *av_dp(i,j,k)**(3. - df_agg(i,j,k))*grav_acc_const & + & /(AJ3*nu_vis**BJ3))**(1./df_agg(i,j,k)) + + END FUNCTION max_agg_diam_white + + !===================================================================================== mass factor + REAL FUNCTION mass_factor(dp,df,rhop) + !----------------------------------------------------------------------- + !> + !! mass_factor calculates the mass factor for the mass of a single + !! aggregate + !! + IMPLICIT NONE + + REAL, INTENT(in) :: dp + REAL, INTENT(in) :: df + REAL, INTENT(in) :: rhop + + ! mass factor + mass_factor = ONE_SIXTH * PI * dp**(3. - df) * rhop + + END FUNCTION mass_factor + + + !===================================================================================== rho_agg + REAL FUNCTION rho_agg(d,rhop,dp,df,rho) + !----------------------------------------------------------------------- + !> + !! rho_agg provides the aggregate density + !! + + IMPLICIT NONE + + REAL, INTENT(in) :: d + REAL, INTENT(in) :: rhop + REAL, INTENT(in) :: dp + REAL, INTENT(in) :: df + REAL, INTENT(in) :: rho + + rho_agg = (rhop - rho)*(dp/d)**(3. - df) + rho + + END FUNCTION rho_agg + + !===================================================================================== dynvis + SUBROUTINE dynvis(kpie, kpje, kpke, kbnd, pddpo, omask, ptho, psao, ppo) + !----------------------------------------------------------------------- + !> + !! dynvis calculates the molecular dynamic viscosity according to + !! Richards 1998: The effect of temperature, pressure, and salinity + !! on sound attenuation in turbid seawater. J. Acoust. Soc. Am. 103 (1), + !! originally published by Matthaeus, W. (1972): Die Viskositaet des + !! Meerwassers. Beitraege zur Meereskunde, Heft 29 (in German). + !! + + IMPLICIT NONE + + INTEGER, INTENT(in) :: kpie !< 1st REAL of model grid. + INTEGER, INTENT(in) :: kpje !< 2nd REAL of model grid. + INTEGER, INTENT(in) :: kpke !< 3rd (vertical) REAL of model grid. + INTEGER, INTENT(in) :: kbnd + + REAL, INTENT(in) :: pddpo(kpie,kpje,kpke) !< size of scalar grid cell (3rd dimension) [m] + REAL, INTENT(in) :: omask(kpie,kpje) + REAL, INTENT(in) :: ptho(1-kbnd:kpie+kbnd,1-kbnd:kpje+kbnd,kpke) !< potential temperature [deg C] + REAL, INTENT(in) :: psao(1-kbnd:kpie+kbnd,1-kbnd:kpje+kbnd,kpke) !< salinity [psu.]. + REAL, INTENT(in) :: ppo(kpie,kpje,kpke) !< pressure [Pa]. + + ! Local variables + REAL:: press_val ! Pascal/rho -> dbar + REAL:: ptho_val,psao_val + INTEGER :: kch + kch = 0 + !$OMP PARALLEL DO PRIVATE(i,j,k,press_val,ptho_val,psao_val,kch) + DO j = 1,kpje + DO i = 1,kpie + DO k = 1,kpke + IF(pddpo(i,j,k) > dp_min .and. omask(i,j) > 0.5) THEN + kch = MERGE(k+1,k,k 0.5) THEN + press_val = 0.5*(ppo(i,j,k) + ppo(i,j,kch))*1.e-5 ! Pascal -> dbar + ptho_val = 0.5*(ptho(i,j,k) + ptho(i,j,kch)) + psao_val = 0.5*(psao(i,j,k) + ptho(i,j,kch)) + ELSE + press_val = ppo(i,j,k)*1.e-5 ! Pascal -> dbar + ptho_val = ptho(i,j,k) + psao_val = psao(i,j,k) + END IF + + + ! molecular dynamic viscosity + dyn_vis(i,j,k) = 0.1 & ! Unit: g / (cm*s) -> kg / (m*s) + & *(1.79e-2 & + & - 6.1299e-4*ptho_val + 1.4467e-5*ptho_val**2. & + & - 1.6826e-7*ptho_val**3. & + & - 1.8266e-7*press_val + 9.8972e-12*press_val**2. & + & + 2.4727e-5*psao_val & + & + psao_val*(4.8429e-7*ptho_val - 4.7172e-8*ptho_val**2. & + & + 7.5986e-10*ptho_val**3.) & + & + press_val*(1.3817e-8*ptho_val - 2.6363e-10*ptho_val**2.) & + & - press_val**2.*(6.3255e-13*ptho_val - 1.2116e-14*ptho_val**2.)) + END IF + END DO + END DO + END DO + !$OMP END PARALLEL DO + END SUBROUTINE dynvis + END MODULE mo_m4ago + diff --git a/hamocc/ncout_hamocc.F b/hamocc/ncout_hamocc.F index 2b3e371e..d1c90337 100644 --- a/hamocc/ncout_hamocc.F +++ b/hamocc/ncout_hamocc.F @@ -107,7 +107,23 @@ subroutine ncwrt_bgc(iogrp) . glb_fnametag,filefq_bgc,diagfq_bgc, . filemon_bgc,fileann_bgc,ip,wrtlyr,wrtlvl, . loglyr,inilvl,inilyr,inisrf,loglvl, - . msklvl,wrtsrf,msksrf,finlyr + . msklvl,wrtsrf,msksrf,finlyr, + . lyr_agg_ws,lyr_dynvis,lyr_agg_stick, + . lyr_agg_stickf,lyr_agg_dmax,lyr_agg_avdp, + . lyr_agg_avrhop,lyr_agg_avdC,lyr_agg_df, + . lyr_agg_b,lyr_agg_Vrhof,lyr_agg_Vpor, + . lvl_agg_ws,lvl_dynvis,lvl_agg_stick, + . lvl_agg_stickf,lvl_agg_dmax,lvl_agg_avdp, + . lvl_agg_avrhop,lvl_agg_avdC,lvl_agg_df, + . lvl_agg_b,lvl_agg_Vrhof,lvl_agg_Vpor, + . jagg_ws,jdynvis,jagg_stick, + . jagg_stickf,jagg_dmax,jagg_avdp, + . jagg_avrhop,jagg_avdC,jagg_df, + . jagg_b,jagg_Vrhof,jagg_Vpor, + . jlvl_agg_ws,jlvl_dynvis,jlvl_agg_stick, + . jlvl_agg_stickf,jlvl_agg_dmax,jlvl_agg_avdp, + . jlvl_agg_avrhop,jlvl_agg_avdC,jlvl_agg_df, + . jlvl_agg_b,jlvl_agg_Vrhof,jlvl_agg_Vpor #ifdef AGG use mo_bgcmean, only: lyr_nos,lyr_wphy, lyr_wnos,lyr_eps, . lyr_asize,lvl_nos,lvl_wphy,lvl_wnos,lvl_eps, @@ -350,6 +366,19 @@ subroutine ncwrt_bgc(iogrp) call finlyr(jremin_aerob(iogrp),jdp(iogrp)) call finlyr(jremin_sulf(iogrp),jdp(iogrp)) #endif +c M4AGO + call finlyr(jagg_ws(iogrp),jdp(iogrp)) + call finlyr(jdynvis(iogrp),jdp(iogrp)) + call finlyr(jagg_stick(iogrp),jdp(iogrp)) + call finlyr(jagg_stickf(iogrp),jdp(iogrp)) + call finlyr(jagg_dmax(iogrp),jdp(iogrp)) + call finlyr(jagg_avdp(iogrp),jdp(iogrp)) + call finlyr(jagg_avrhop(iogrp),jdp(iogrp)) + call finlyr(jagg_avdC(iogrp),jdp(iogrp)) + call finlyr(jagg_df(iogrp),jdp(iogrp)) + call finlyr(jagg_b(iogrp),jdp(iogrp)) + call finlyr(jagg_Vrhof(iogrp),jdp(iogrp)) + call finlyr(jagg_Vpor(iogrp),jdp(iogrp)) c c --- Mask sea floor in mass fluxes @@ -450,6 +479,19 @@ subroutine ncwrt_bgc(iogrp) call msklvl(jlvl_remin_aerob(iogrp),depths) call msklvl(jlvl_remin_sulf(iogrp),depths) #endif +c M4AGO + call msklvl(jlvl_agg_ws(iogrp),depths) + call msklvl(jlvl_dynvis(iogrp),depths) + call msklvl(jlvl_agg_stick(iogrp),depths) + call msklvl(jlvl_agg_stickf(iogrp),depths) + call msklvl(jlvl_agg_dmax(iogrp),depths) + call msklvl(jlvl_agg_avdp(iogrp),depths) + call msklvl(jlvl_agg_avrhop(iogrp),depths) + call msklvl(jlvl_agg_avdC(iogrp),depths) + call msklvl(jlvl_agg_df(iogrp),depths) + call msklvl(jlvl_agg_b(iogrp),depths) + call msklvl(jlvl_agg_Vrhof(iogrp),depths) + call msklvl(jlvl_agg_Vpor(iogrp),depths) c c --- Compute log10 of pH @@ -843,6 +885,32 @@ subroutine ncwrt_bgc(iogrp) . 0.,cmpflg, . 'remins','Sulfate remineralization rate',' ','mol P m-3 s-1') #endif +c M4AGO + call wrtlyr(jagg_ws(iogrp),LYR_agg_ws(iogrp),1.,0.,cmpflg, + . 'agg_ws','aggregate mean settling velocity',' ','m d-1') + call wrtlyr(jdynvis(iogrp),LYR_dynvis(iogrp),1.,0.,cmpflg, + . 'dynvis','dynamic viscosity of sea water',' ','kg m-1 s-1') + call wrtlyr(jagg_stick(iogrp),LYR_agg_stick(iogrp),1.,0.,cmpflg, + . 'agg_stick','aggregate mean stickiness',' ','-') + call wrtlyr(jagg_stickf(iogrp),LYR_agg_stickf(iogrp),1.,0.,cmpflg, + . 'agg_stickf','opal frustule stickiness',' ','-') + call wrtlyr(jagg_dmax(iogrp),LYR_agg_dmax(iogrp),1.,0.,cmpflg, + . 'agg_dmax','aggregate maximum diameter',' ','m') + call wrtlyr(jagg_avdp(iogrp),LYR_agg_avdp(iogrp),1.,0.,cmpflg, + . 'agg_avdp','mean primary particle diameter',' ','m') + call wrtlyr(jagg_avrhop(iogrp),LYR_agg_avrhop(iogrp),1.,0.,cmpflg, + . 'agg_avrhop','mean primary particle density',' ','kg m-3') + call wrtlyr(jagg_avdC(iogrp),LYR_agg_avdC(iogrp),1.,0.,cmpflg, + . 'agg_avdC','Conc.-weighted mean aggregate diameter',' ','m') + call wrtlyr(jagg_df(iogrp),LYR_agg_df(iogrp),1.,0.,cmpflg, + . 'agg_df','aggregate fractal dimension',' ','-') + call wrtlyr(jagg_b(iogrp),LYR_agg_b(iogrp),1.,0.,cmpflg, + . 'agg_b','aggregate number distribution slope',' ','-') + call wrtlyr(jagg_Vrhof(iogrp),LYR_agg_Vrhof(iogrp),1.,0.,cmpflg, + . 'agg_Vrhof','V-weighted aggregate mean density',' ','kg m-3') + call wrtlyr(jagg_Vpor(iogrp),LYR_agg_Vpor(iogrp),1.,0.,cmpflg, + . 'agg_Vpor','V-weighted aggregate mean porosity',' ','-') + c c --- Store 3d level fields call wrtlvl(jlvldic(iogrp),LVL_DIC(iogrp),rnacc*1e3,0.,cmpflg, @@ -1025,6 +1093,39 @@ subroutine ncwrt_bgc(iogrp) . rnacc*1e3/dtbgc,0.,cmpflg, . 'reminslvl','Sulfate remineralization rate',' ','mol P m-3 s-1') #endif +c M4AGO + call wrtlvl(jlvl_agg_ws(iogrp),LVL_agg_ws(iogrp),rnacc,0.,cmpflg, + . 'agg_wslvl','aggregate mean settling velocity',' ','m d-1') + call wrtlvl(jlvl_dynvis(iogrp),LVL_dynvis(iogrp),rnacc,0.,cmpflg, + . 'dynvislvl','dynamic viscosity of sea water',' ','kg m-1 s-1') + call wrtlvl(jlvl_agg_stick(iogrp),LVL_agg_stick(iogrp),rnacc,0., + . cmpflg, + . 'agg_sticklvl','aggregate mean stickiness',' ','-') + call wrtlvl(jlvl_agg_stickf(iogrp),LVL_agg_stickf(iogrp),rnacc,0., + . cmpflg, + . 'agg_stickflvl','opal frustule stickiness',' ','-') + call wrtlvl(jlvl_agg_dmax(iogrp),LVL_agg_dmax(iogrp),rnacc,0., + . cmpflg, + . 'agg_dmaxlvl','aggregate maximum diameter',' ','m') + call wrtlvl(jlvl_agg_avdp(iogrp),LVL_agg_avdp(iogrp),rnacc,0., + . cmpflg, + . 'agg_avdplvl','mean primary particle diameter',' ','m') + call wrtlvl(jlvl_agg_avrhop(iogrp),LVL_agg_avrhop(iogrp),rnacc,0., + . cmpflg, + . 'agg_avrhoplvl','mean primary particle density',' ','kg m-3') + call wrtlvl(jlvl_agg_avdC(iogrp),LVL_agg_avdC(iogrp),rnacc,0., + . cmpflg, + . 'agg_avdClvl','Conc.-weighted mean aggregate diameter',' ','m') + call wrtlvl(jlvl_agg_df(iogrp),LVL_agg_df(iogrp),rnacc,0.,cmpflg, + . 'agg_dflvl','aggregate fractal dimension',' ','-') + call wrtlvl(jlvl_agg_b(iogrp),LVL_agg_b(iogrp),rnacc,0.,cmpflg, + . 'agg_blvl','aggregate number distribution slope',' ','-') + call wrtlvl(jlvl_agg_Vrhof(iogrp),LVL_agg_Vrhof(iogrp),rnacc,0., + . cmpflg, + . 'agg_Vrhoflvl','V-weighted aggregate mean density',' ','kg m-3') + call wrtlvl(jlvl_agg_Vpor(iogrp),LVL_agg_Vpor(iogrp),rnacc,0., + . cmpflg, + . 'agg_Vporlvl','V-weighted aggregate mean porosity',' ','-') c c --- Store sediment fields @@ -1242,6 +1343,19 @@ subroutine ncwrt_bgc(iogrp) call inilyr(jremin_aerob(iogrp),0.) call inilyr(jremin_sulf(iogrp),0.) #endif +c M4AGO + call inilyr(jagg_ws(iogrp),0.) + call inilyr(jdynvis(iogrp),0.) + call inilyr(jagg_stick(iogrp),0.) + call inilyr(jagg_stickf(iogrp),0.) + call inilyr(jagg_dmax(iogrp),0.) + call inilyr(jagg_avdp(iogrp),0.) + call inilyr(jagg_avrhop(iogrp),0.) + call inilyr(jagg_avdC(iogrp),0.) + call inilyr(jagg_df(iogrp),0.) + call inilyr(jagg_b(iogrp),0.) + call inilyr(jagg_Vrhof(iogrp),0.) + call inilyr(jagg_Vpor(iogrp),0.) c call inilvl(jlvldic(iogrp),0.) call inilvl(jlvlalkali(iogrp),0.) @@ -1323,6 +1437,19 @@ subroutine ncwrt_bgc(iogrp) call inilvl(jlvl_remin_aerob(iogrp),0.) call inilvl(jlvl_remin_sulf(iogrp),0.) #endif +c M4AGO + call inilvl(jlvl_agg_ws(iogrp),0.) + call inilvl(jlvl_dynvis(iogrp),0.) + call inilvl(jlvl_agg_stick(iogrp),0.) + call inilvl(jlvl_agg_stickf(iogrp),0.) + call inilvl(jlvl_agg_dmax(iogrp),0.) + call inilvl(jlvl_agg_avdp(iogrp),0.) + call inilvl(jlvl_agg_avrhop(iogrp),0.) + call inilvl(jlvl_agg_avdC(iogrp),0.) + call inilvl(jlvl_agg_df(iogrp),0.) + call inilvl(jlvl_agg_b(iogrp),0.) + call inilvl(jlvl_agg_Vrhof(iogrp),0.) + call inilvl(jlvl_agg_Vpor(iogrp),0.) c #ifndef sedbypass call inisdm(jpowaic(iogrp),0.) @@ -1371,7 +1498,15 @@ subroutine hamoccvardef(iogrp,timeunits,calendar,cmpflg) . lvl_silica,lvl_doc,lvl_phyto,lvl_grazer,lvl_poc,lvl_calc, . lvl_opal,lvl_iron,lvl_phosy,lvl_co3,lvl_ph,lvl_omegaa, . lvl_omegac,lvl_n2o,lvl_prefo2,lvl_o2sat,lvl_prefpo4, - . lvl_prefalk,lvl_prefdic,lvl_dicsat + . lvl_prefalk,lvl_prefdic,lvl_dicsat, + . lyr_agg_ws,lyr_dynvis,lyr_agg_stick, + . lyr_agg_stickf,lyr_agg_dmax,lyr_agg_avdp, + . lyr_agg_avrhop,lyr_agg_avdC,lyr_agg_df, + . lyr_agg_b,lyr_agg_Vrhof,lyr_agg_Vpor, + . lvl_agg_ws,lvl_dynvis,lvl_agg_stick, + . lvl_agg_stickf,lvl_agg_dmax,lvl_agg_avdp, + . lvl_agg_avrhop,lvl_agg_avdC,lvl_agg_df, + . lvl_agg_b,lvl_agg_Vrhof,lvl_agg_Vpor #ifdef AGG use mo_bgcmean, only: lyr_nos,lyr_wphy,lyr_wnos,lyr_eps, . lyr_asize,lvl_nos,lvl_wphy,lvl_wnos,lvl_eps,lvl_asize @@ -1789,6 +1924,31 @@ subroutine hamoccvardef(iogrp,timeunits,calendar,cmpflg) call ncdefvar3d(LYR_remin_sulf(iogrp),cmpflg,'p', . 'remins','Sulfate remineralization rate',' ','mol P m-3 s-1',1) #endif +c M4AGO + call ncdefvar3d(LYR_agg_ws(iogrp),cmpflg,'p', + . 'agg_ws','aggregate mean settling velocity',' ','m d-1',1) + call ncdefvar3d(LYR_dynvis(iogrp),cmpflg,'p', + . 'dynvis','dynamic viscosity of sea water',' ','kg m-1 s-1',1) + call ncdefvar3d(LYR_agg_stick(iogrp),cmpflg,'p', + . 'agg_stick','aggregate mean stickiness',' ','-',1) + call ncdefvar3d(LYR_agg_stickf(iogrp),cmpflg,'p', + . 'agg_stickf','opal frustule stickiness',' ','-',1) + call ncdefvar3d(LYR_agg_dmax(iogrp),cmpflg,'p', + . 'agg_dmax','aggregate maximum diameter',' ','m',1) + call ncdefvar3d(LYR_agg_avdp(iogrp),cmpflg,'p', + . 'agg_avdp','mean primary particle diameter',' ','m',1) + call ncdefvar3d(LYR_agg_avrhop(iogrp),cmpflg,'p', + . 'agg_avrhop','mean primary particle density',' ','kg m-3',1) + call ncdefvar3d(LYR_agg_avdC(iogrp),cmpflg,'p', + . 'agg_avdC','Conc.-weighted mean aggregate diameter',' ','m',1) + call ncdefvar3d(LYR_agg_df(iogrp),cmpflg,'p', + . 'agg_df','aggregate fractal dimension',' ','-',1) + call ncdefvar3d(LYR_agg_b(iogrp),cmpflg,'p', + . 'agg_b','aggregate number distribution slope',' ','-',1) + call ncdefvar3d(LYR_agg_Vrhof(iogrp),cmpflg,'p', + . 'agg_Vrhof','V-weighted aggregate mean density',' ','kg m-3',1) + call ncdefvar3d(LYR_agg_Vpor(iogrp),cmpflg,'p', + . 'agg_Vpor','V-weighted aggregate mean porosity',' ','-',1) c c --- define 3d level fields call ncdefvar3d(LVL_DIC(iogrp),cmpflg,'p', @@ -1949,6 +2109,34 @@ subroutine hamoccvardef(iogrp,timeunits,calendar,cmpflg) . 'reminslvl','Sulfate remineralization rate',' ', . 'mol P m-3 s-1',2) #endif +c M4AGO + call ncdefvar3d(LVL_agg_ws(iogrp),cmpflg,'p', + . 'agg_wslvl','aggregate mean settling velocity',' ','m d-1',2) + call ncdefvar3d(LVL_dynvis(iogrp),cmpflg,'p', + . 'dynvislvl','dynamic viscosity of sea water',' ','kg m-1 s-1', + . 2) + call ncdefvar3d(LVL_agg_stick(iogrp),cmpflg,'p', + . 'agg_sticklvl','aggregate mean stickiness',' ','-',2) + call ncdefvar3d(LVL_agg_stickf(iogrp),cmpflg,'p', + . 'agg_stickflvl','opal frustule stickiness',' ','-',2) + call ncdefvar3d(LVL_agg_dmax(iogrp),cmpflg,'p', + . 'agg_dmaxlvl','aggregate maximum diameter',' ','m',2) + call ncdefvar3d(LVL_agg_avdp(iogrp),cmpflg,'p', + . 'agg_avdplvl','mean primary particle diameter',' ','m',2) + call ncdefvar3d(LVL_agg_avrhop(iogrp),cmpflg,'p', + . 'agg_avrhoplvl','mean primary particle density',' ','kg m-3',2) + call ncdefvar3d(LVL_agg_avdC(iogrp),cmpflg,'p', + . 'agg_avdClvl','Conc.-weighted mean aggregate diameter',' ', + . 'm',2) + call ncdefvar3d(LVL_agg_df(iogrp),cmpflg,'p', + . 'agg_dflvl','aggregate fractal dimension',' ','-',2) + call ncdefvar3d(LVL_agg_b(iogrp),cmpflg,'p', + . 'agg_blvl','aggregate number distribution slope',' ','-',2) + call ncdefvar3d(LVL_agg_Vrhof(iogrp),cmpflg,'p', + . 'agg_Vrhoflvl','V-weighted aggregate mean density',' ', + . 'kg m-3',2) + call ncdefvar3d(LVL_agg_Vpor(iogrp),cmpflg,'p', + . 'agg_Vporlvl','V-weighted aggregate mean porosity',' ','-',2) c c --- define sediment fields #ifndef sedbypass diff --git a/hamocc/ocprod.F90 b/hamocc/ocprod.F90 index e1fe9879..23bb6b34 100644 --- a/hamocc/ocprod.F90 +++ b/hamocc/ocprod.F90 @@ -18,7 +18,7 @@ ! along with BLOM. If not, see https://www.gnu.org/licenses/. -subroutine ocprod(kpie,kpje,kpke,kbnd,pdlxp,pdlyp,pddpo,omask,ptho,pi_ph) +subroutine ocprod(kpie,kpje,kpke,kbnd,pdlxp,pdlyp,pddpo,omask,ptho,pi_ph, psao, ppao, prho) !****************************************************************************** ! ! OCPROD - biological production, remineralization and particle sinking. @@ -78,6 +78,10 @@ subroutine ocprod(kpie,kpje,kpke,kbnd,pdlxp,pdlyp,pddpo,omask,ptho,pi_ph) ! *REAL* *pddpo* - size of scalar grid cell (3rd dimension) [m]. ! *REAL* *omask* - land/ocean mask (1=ocean) ! *REAL* *ptho* - potential temperature [deg C]. +! *REAL* *pi_ph* - +! *REAL* *psao* - salinity [psu]. +! *REAL* *ppao* - sea level pressure [Pascal]. +! *REAL* *prho* - density [kg/m^3]. ! !****************************************************************************** use mo_carbch, only: dmspar,ocetra,satoxy,hi @@ -87,15 +91,16 @@ subroutine ocprod(kpie,kpje,kpke,kbnd,pdlxp,pdlyp,pddpo,omask,ptho,pi_ph) & carflx1000,carflx2000,carflx4000,carflx_bot,dremn2o,dremopal,drempoc,dremsul,dyphy,ecan,epsher,fesoly, & & gammap,gammaz,grami,grazra,expoor,exposi,expoca,intdnit,intdms_bac,intdmsprod,intdms_uv,intphosy, & & phosy3d,pi_alpha,phytomi,rcalc,rcar,rdn2o1,rdn2o2,rdnit0,rdnit1,rdnit2,relaxfe,remido, & - & riron,rnit,strahl,rnoi,ro2ut,ropal,spemor,wcal,wdust,wopal,wpoc,zinges + & riron,rnit,strahl,rnoi,ro2ut,ropal,spemor,wcal,wdust,wopal,wpoc,zinges,drempoc_anaerob use mo_param1_bgc, only: ialkali,ian2o,iano3,icalc,idet,idms,idoc,ifdust,igasnit,iiron,iopal,ioxygen,iphosph,iphy,isco212, & & isilica,izoo - use mo_control_bgc, only: dtb,io_stdo_bgc,with_dmsph + use mo_control_bgc, only: dtb,io_stdo_bgc,with_dmsph,lm4ago use mo_vgrid, only: dp_min,dp_min_sink,k0100,k0500,k1000,k2000,k4000,kwrbioz,ptiestu use mod_xc, only: mnproc + use mo_m4ago, only: mean_aggregate_sinking_speed,ws_agg,POM_remin_q10,POM_remin_Tref,opal_remin_q10,opal_remin_Tref #ifdef AGG - use mo_biomod, only: alar1,alar2,alar3,alow1,alow2,alow3,asize3d,calmax,cellmass,cellsink,dustd1,dustd2,dustd3,dustsink, & + use mo_biomod, only: alar1,alar2,alar3,alow1,alow2,alow3,asize3d,calmax,cellmass,cellsink,dustd1,dustd2,dustd3,dustsink, & & eps3d,fractdim,fse,fsh,nmldmin,plower,pupper,sinkexp,stick,tmfac,tsfac,vsmall,zdis,wmass,wnumb use mo_param1_bgc, only: iadust,inos use mo_vgrid, only: kmle @@ -136,6 +141,9 @@ subroutine ocprod(kpie,kpje,kpke,kbnd,pdlxp,pdlyp,pddpo,omask,ptho,pi_ph) real, intent(in) :: omask(kpie,kpje) real, intent(in) :: ptho(1-kbnd:kpie+kbnd,1-kbnd:kpje+kbnd,kpke) real, intent(in) :: pi_ph(kpie,kpje) + real, intent(in) :: psao(1-kbnd:kpie+kbnd,1-kbnd:kpje+kbnd,kpke) + real, intent(in) :: ppao(1-kbnd:kpie+kbnd,1-kbnd:kpje+kbnd) + real, intent(in) :: prho(kpie,kpje,kpke) ! Local varaibles integer :: i,j,k,l @@ -156,7 +164,7 @@ subroutine ocprod(kpie,kpje,kpke,kbnd,pdlxp,pdlyp,pddpo,omask,ptho,pi_ph) real :: absorption,absorption_uv real :: dmsprod,dms_bac,dms_uv real :: dtr,dz - real :: wpocd,wcald,wopald,dagg + real :: wpocd,wcald,wopald,wdustd,dagg #ifdef sedbypass real :: florca,flcaca,flsil #endif @@ -316,11 +324,16 @@ subroutine ocprod(kpie,kpje,kpke,kbnd,pdlxp,pdlyp,pddpo,omask,ptho,pi_ph) enddo !$OMP END PARALLEL DO + if (lm4ago) then + ! even though we loose detritus, etc. we call the calculation for settling velocity by M4AGO here + ! to enable further future development... - assuming that the operator splitting decently functions + call mean_aggregate_sinking_speed(kpie, kpje, kpke, kbnd, pddpo, omask, ptho, psao, ppao, prho) + endif !$OMP PARALLEL DO PRIVATE(avphy,avgra,avsil,avanut,avanfe,pho,xa,xn & !$OMP ,phosy,ya,yn,grazing,graton,gratpoc,grawa,bacfra,phymor & !$OMP ,zoomor,excdoc,exud,export,delsil,delcar,dmsprod & -!$OMP ,dms_bac,dms_uv,dtr,phofa,temfa,zoothresh,dms_ph,dz & +!$OMP ,dms_bac,dms_uv,dtr,phofa,temfa,zoothresh,dms_ph,dz,opalrem & # ifdef AGG !$OMP ,avmass,avnos,zmornos & # endif @@ -531,8 +544,13 @@ subroutine ocprod(kpie,kpje,kpke,kbnd,pdlxp,pdlyp,pddpo,omask,ptho,pi_ph) ocetra(i,j,k,inatalkali) = ocetra(i,j,k,inatalkali)-2.*delcar-(rnit+1)*dtr ocetra(i,j,k,inatcalc) = ocetra(i,j,k,inatcalc)+delcar #endif - ocetra(i,j,k,isilica) = ocetra(i,j,k,isilica)-delsil+dremopal*ocetra(i,j,k,iopal) - ocetra(i,j,k,iopal) = ocetra(i,j,k,iopal)+delsil-dremopal*ocetra(i,j,k,iopal) + if(lm4ago)then + opalrem = dremopal*opal_remin_q10**((ptho(i,j,k)-opal_remin_Tref)/10.)*ocetra(i,j,k,iopal) + else + opalrem = dremopal*ocetra(i,j,k,iopal) + endif + ocetra(i,j,k,isilica) = ocetra(i,j,k,isilica)-delsil+opalrem + ocetra(i,j,k,iopal) = ocetra(i,j,k,iopal)+delsil-opalrem ocetra(i,j,k,iiron) = ocetra(i,j,k,iiron)+dtr*riron & & - relaxfe*MAX(ocetra(i,j,k,iiron)-fesoly,0.) #ifdef BROMO @@ -665,12 +683,17 @@ subroutine ocprod(kpie,kpje,kpke,kbnd,pdlxp,pdlyp,pddpo,omask,ptho,pi_ph) #endif if(ocetra(i,j,k,ioxygen) > 5.e-8) then + if(lm4ago) then + pocrem = drempoc*POM_remin_q10**((ptho(i,j,k)-POM_remin_Tref)/10.)*ocetra(i,j,k,idet) + else + pocrem = drempoc*ocetra(i,j,k,idet) + endif #ifndef extNcycle - pocrem = MIN(drempoc*ocetra(i,j,k,idet),0.33*ocetra(i,j,k,ioxygen)/ro2ut) + pocrem = MIN(pocrem,0.33*ocetra(i,j,k,ioxygen)/ro2ut) docrem = MIN( remido*ocetra(i,j,k,idoc),0.33*ocetra(i,j,k,ioxygen)/ro2ut) phyrem = MIN(0.5*dyphy*phythresh, 0.33*ocetra(i,j,k,ioxygen)/ro2ut) #else - pocrem = MIN(drempoc*ocetra(i,j,k,idet),0.33*ocetra(i,j,k,ioxygen)/ro2utammo) + pocrem = MIN(pocrem,0.33*ocetra(i,j,k,ioxygen)/ro2utammo) docrem = MIN( remido*ocetra(i,j,k,idoc),0.33*ocetra(i,j,k,ioxygen)/ro2utammo) phyrem = MIN(0.5*dyphy*phythresh, 0.33*ocetra(i,j,k,ioxygen)/ro2utammo) #endif @@ -737,7 +760,11 @@ subroutine ocprod(kpie,kpje,kpke,kbnd,pdlxp,pdlyp,pddpo,omask,ptho,pi_ph) ! so the expression dremopal*(Si(OH)4sat-Si(OH)4) would change the ! rate only from 0 to 100% !*********************************************************************** - opalrem = dremopal*0.1*(temp+3.)*ocetra(i,j,k,iopal) + if(lm4ago)then + opalrem = dremopal*opal_remin_q10**((ptho(i,j,k)-opal_remin_Tref)/10.)*ocetra(i,j,k,iopal) + else + opalrem = dremopal*0.1*(temp+3.)*ocetra(i,j,k,iopal) + endif ocetra(i,j,k,iopal) = ocetra(i,j,k,iopal)-opalrem ocetra(i,j,k,isilica) = ocetra(i,j,k,isilica)+opalrem @@ -814,7 +841,7 @@ subroutine ocprod(kpie,kpje,kpke,kbnd,pdlxp,pdlyp,pddpo,omask,ptho,pi_ph) avmass = ocetra(i,j,k,iphy) + ocetra(i,j,k,idet) #endif /*AGG*/ - remin = 0.05 * drempoc * MIN(ocetra(i,j,k,idet), & + remin = drempoc_anaerob * MIN(ocetra(i,j,k,idet), & & 0.5 * ocetra(i,j,k,iano3) / rdnit1) remin2o = dremn2o * MIN(ocetra(i,j,k,idet), & & 0.003 * ocetra(i,j,k,ian2o) / rdn2o1) @@ -1139,7 +1166,7 @@ subroutine ocprod(kpie,kpje,kpke,kbnd,pdlxp,pdlyp,pddpo,omask,ptho,pi_ph) ! C(k,T+dt)=(ddpo(k)*C(k,T)+w*dt*C(k-1,T+dt))/(ddpo(k)+w*dt) ! sedimentation=w*dt*C(ks,T+dt) ! -!$OMP PARALLEL DO PRIVATE(kdonor,wpoc,wpocd,wcal,wcald,wopal,wopald & +!$OMP PARALLEL DO PRIVATE(kdonor,wpoc,wpocd,wcal,wcald,wopal,wopald,wdust,wdustd & #if defined(AGG) !$OMP ,wnos,wnosd,dagg & #endif @@ -1189,29 +1216,48 @@ subroutine ocprod(kpie,kpje,kpke,kbnd,pdlxp,pdlyp,pddpo,omask,ptho,pi_ph) wnos = wnumb(i,j,k) wnosd = wnumb(i,j,kdonor) wdust = dustsink + wdustd = dustsink dagg = dustagg(i,j,k) #elif defined(WLIN) wpoc = min(wmin+wlin*ptiestu(i,j,k), wmax) wpocd = min(wmin+wlin*ptiestu(i,j,kdonor),wmax) wcald = wcal wopald = wopal + wdustd = wdust dagg = 0.0 #else wpocd = wpoc wcald = wcal wopald = wopal + wdustd = wdust dagg = 0.0 #endif + if(lm4ago)then ! superseding every other method + wpoc = ws_agg(i,j,k) + wpocd = ws_agg(i,j,kdonor) + wcal = ws_agg(i,j,k) + wcald = ws_agg(i,j,kdonor) + wopal = ws_agg(i,j,k) + wopald = ws_agg(i,j,kdonor) + wdust = ws_agg(i,j,k) + wdustd = ws_agg(i,j,kdonor) + dagg = 0.0 + endif if( k == 1 ) then wpocd = 0.0 wcald = 0.0 wopald = 0.0 + wdustd = 0.0 #if defined(AGG) wnosd = 0.0 #elif defined(WLIN) - wpoc = wmin -#endif + if (lm4ago)then + wpoc = ws_agg(i,j,k) + else + wpoc = wmin + endif +#endif endif ocetra(i,j,k,idet) = (ocetra(i,j,k ,idet) * pddpo(i,j,k) & @@ -1243,7 +1289,7 @@ subroutine ocprod(kpie,kpje,kpke,kbnd,pdlxp,pdlyp,pddpo,omask,ptho,pi_ph) & + ocetra(i,j,kdonor,iopal)*wopald)/ & & (pddpo(i,j,k)+wopal) ocetra(i,j,k,ifdust) = (ocetra(i,j,k ,ifdust) * pddpo(i,j,k) & - & + ocetra(i,j,kdonor,ifdust)*wdust)/ & + & + ocetra(i,j,kdonor,ifdust)*wdustd)/ & & (pddpo(i,j,k)+wdust) - dagg #ifdef AGG ocetra(i,j,k,iphy) = (ocetra(i,j,k ,iphy) * pddpo(i,j,k) & @@ -1412,7 +1458,11 @@ subroutine ocprod(kpie,kpje,kpke,kbnd,pdlxp,pdlyp,pddpo,omask,ptho,pi_ph) #elif defined(WLIN) wpoc = min(wmin+wlin*ptiestu(i,j,k), wmax) #endif - + if(lm4ago)then + wpoc = ws_agg(i,j,k) + wcal = ws_agg(i,j,k) + wopal = ws_agg(i,j,k) + endif #if defined(AGG) carflx0100(i,j) = (ocetra(i,j,k,idet)+ocetra(i,j,k,iphy))*rcar*wpoc #else @@ -1432,7 +1482,11 @@ subroutine ocprod(kpie,kpje,kpke,kbnd,pdlxp,pdlyp,pddpo,omask,ptho,pi_ph) #elif defined(WLIN) wpoc = min(wmin+wlin*ptiestu(i,j,k), wmax) #endif - + if(lm4ago)then + wpoc = ws_agg(i,j,k) + wcal = ws_agg(i,j,k) + wopal = ws_agg(i,j,k) + endif #if defined(AGG) carflx0500(i,j) = (ocetra(i,j,k,idet)+ocetra(i,j,k,iphy))*rcar*wpoc #else @@ -1452,7 +1506,11 @@ subroutine ocprod(kpie,kpje,kpke,kbnd,pdlxp,pdlyp,pddpo,omask,ptho,pi_ph) #elif defined(WLIN) wpoc = min(wmin+wlin*ptiestu(i,j,k), wmax) #endif - + if(lm4ago)then + wpoc = ws_agg(i,j,k) + wcal = ws_agg(i,j,k) + wopal = ws_agg(i,j,k) + endif #if defined(AGG) carflx1000(i,j) = (ocetra(i,j,k,idet)+ocetra(i,j,k,iphy))*rcar*wpoc #else @@ -1472,7 +1530,11 @@ subroutine ocprod(kpie,kpje,kpke,kbnd,pdlxp,pdlyp,pddpo,omask,ptho,pi_ph) #elif defined(WLIN) wpoc = min(wmin+wlin*ptiestu(i,j,k), wmax) #endif - + if(lm4ago)then + wpoc = ws_agg(i,j,k) + wcal = ws_agg(i,j,k) + wopal = ws_agg(i,j,k) + endif #if defined(AGG) carflx2000(i,j) = (ocetra(i,j,k,idet)+ocetra(i,j,k,iphy))*rcar*wpoc #else @@ -1492,7 +1554,11 @@ subroutine ocprod(kpie,kpje,kpke,kbnd,pdlxp,pdlyp,pddpo,omask,ptho,pi_ph) #elif defined(WLIN) wpoc = min(wmin+wlin*ptiestu(i,j,k), wmax) #endif - + if(lm4ago)then + wpoc = ws_agg(i,j,k) + wcal = ws_agg(i,j,k) + wopal = ws_agg(i,j,k) + endif #if defined(AGG) carflx4000(i,j) = (ocetra(i,j,k,idet)+ocetra(i,j,k,iphy))*rcar*wpoc #else From 4b5f0dcf6e81a646f4eaa0ce65ba91c447822d0f Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Fri, 19 Aug 2022 18:27:57 +0200 Subject: [PATCH 130/366] Introduced O2 and NH4-dependent fn2o limitation function - following Santoros with extension --- hamocc/mo_extNbioproc.F90 | 17 ++++++++++++----- 1 file changed, 12 insertions(+), 5 deletions(-) diff --git a/hamocc/mo_extNbioproc.F90 b/hamocc/mo_extNbioproc.F90 index 69b116e5..e67b2f8f 100644 --- a/hamocc/mo_extNbioproc.F90 +++ b/hamocc/mo_extNbioproc.F90 @@ -103,7 +103,7 @@ subroutine extNbioparam_init() rnm1 = rnit - 1. ! Phytoplankton growth - bkphyanh4 = 0.1e-6 ! Half-saturation constant for NH4 uptake by bulk phytoplankton (kmol/m3) + bkphyanh4 = 0.12e-6 ! Half-saturation constant for NH4 uptake by bulk phytoplankton (kmol/m3) bkphyano3 = 0.16e-6 ! Half-saturation constant for NO3 uptake by bulk phytoplankton (kmol/m3) bkphosph = 0.01e-6 ! Half-saturation constant for PO4 uptake by bulk phytoplankton (kmol/m3) bkiron = bkphosph*riron ! Half-saturation constant for Fe uptake by bulk phytoplankton (kmol/m3) @@ -114,7 +114,7 @@ subroutine extNbioparam_init() q10ano3denit = 2. ! Q10 factor for denitrification on NO3 (-) Trefano3denit = 10. ! Reference temperature for denitrification on NO3 (degr C) !sc_ano3denit = 0.05e6 ! Shape factor for NO3 denitrification oxygen inhibition function (m3/kmol) - sc_ano3denit = 0.08e6 ! Shape factor for NO3 denitrification oxygen inhibition function (m3/kmol) + sc_ano3denit = 0.12e6 ! Shape factor for NO3 denitrification oxygen inhibition function (m3/kmol) bkano3denit = 5.e-6 ! Half-saturation constant for NO3 denitrification (kmol/m3) ! === Anammox @@ -157,11 +157,11 @@ subroutine extNbioparam_init() ! OLD VERSION OF pathway splitting function !bkamoxn2o = 0.453e-6 ! Half saturation constant for pathway splitting function N2O for nitrification on NH4 (kmol/m3) ! NEW version similar to Santoros 2021, Ji 2018: - bkamoxn2o = 0.002e-6 ! Half saturation constant for pathway splitting function N2O for nitrification on NH4 (kmol/m3) + bkamoxn2o = 0.5e-6 ! Half saturation constant for pathway splitting function N2O for nitrification on NH4 (kmol/m3) !====== !bkamoxno2 = 0.479e-6 ! Half saturation constant for pathway splitting function N2O for nitrification on NH4 (kmol/m3) bkamoxno2 = 0.1e-6 ! Half saturation constant for pathway splitting function N2O for nitrification on NH4 (kmol/m3) - n2omaxy = 0.006 ! Maximum yield of OM on NH4 nitrification (-) + n2omaxy = 0.003 ! Maximum yield of OM on NH4 nitrification (-) n2oybeta = 18. ! Decay factor for inhibition function for yield during nitrification on NH4 (kmol/m3) bkyamox = 0.333e-6 ! Half saturation constant for pathway splitting function OM-yield for nitrification on NH4 (kmol/m3) @@ -237,7 +237,14 @@ subroutine nitrification(kpie,kpje,kpke,kbnd,pddpo,omask,ptho) ! OLD version according to Goreau !fn2o = 1. - ocetra(i,j,k,ioxygen)/(ocetra(i,j,k,ioxygen) + bkamoxn2o) ! NEW version similar to Santoros et al. 2021, Ji et al. 2018 - fn2o = 1. - (1.-0.00157)*ocetra(i,j,k,ioxygen)/(ocetra(i,j,k,ioxygen) + bkamoxn2o) + ! was set: bkamoxn2o = 0.002e-6 + !fn2o = 1. - (1.-0.00157)*ocetra(i,j,k,ioxygen)/(ocetra(i,j,k,ioxygen) + bkamoxn2o) + + ! 0.11/(50*1e6)=2.2e-9 - ~Santoro et al. 2011 with simple MM + fn2o = 2.2e-9/bkoxamox * (0.3 + 0.7*bkoxamox/(ocetra(i,j,k,ioxygen)+bkoxamox)) & + * ocetra(i,j,k,ianh4)/(ocetra(i,j,k,ianh4)+bkamoxn2o) + ! continue using the 'old' fno2 - neglecting NH4 term here - which doesn'y make a huge difference, + ! assuming that it's never really limited !===== fno2 = ocetra(i,j,k,ioxygen)/(ocetra(i,j,k,ioxygen) + bkamoxno2) fdetamox = n2omaxy*2.*(1. + n2oybeta)*ocetra(i,j,k,ioxygen)*bkyamox & From 0cabd5b907ce6fbaab52fc9418ca9f764ca72ac5 Mon Sep 17 00:00:00 2001 From: Tomas Torsvik Date: Fri, 19 Aug 2022 20:33:42 +0200 Subject: [PATCH 131/366] Rename hamocc/restart_hamoccwt.F -> hamocc/restart_hamoccwt.F90 --- hamocc/{restart_hamoccwt.F => restart_hamoccwt.F90} | 0 1 file changed, 0 insertions(+), 0 deletions(-) rename hamocc/{restart_hamoccwt.F => restart_hamoccwt.F90} (100%) diff --git a/hamocc/restart_hamoccwt.F b/hamocc/restart_hamoccwt.F90 similarity index 100% rename from hamocc/restart_hamoccwt.F rename to hamocc/restart_hamoccwt.F90 From abc195a086164e66e5a2ab1ecbb7278cc5198628 Mon Sep 17 00:00:00 2001 From: Tomas Torsvik Date: Fri, 19 Aug 2022 20:46:04 +0200 Subject: [PATCH 132/366] Reformat hamocc/restart_hamoccwt.F90 following free form convention. --- hamocc/restart_hamoccwt.F90 | 67 ++++++++++++++++++------------------- 1 file changed, 33 insertions(+), 34 deletions(-) diff --git a/hamocc/restart_hamoccwt.F90 b/hamocc/restart_hamoccwt.F90 index 1c152d27..728e2b5b 100644 --- a/hamocc/restart_hamoccwt.F90 +++ b/hamocc/restart_hamoccwt.F90 @@ -1,37 +1,36 @@ -c Copyright (C) 2020 K. Assmann, J. Tjiputra, J. Schwinger, M. Bentsen -c -c This file is part of BLOM/iHAMOCC. -c -c BLOM is free software: you can redistribute it and/or modify it under the -c terms of the GNU Lesser General Public License as published by the Free -c Software Foundation, either version 3 of the License, or (at your option) -c any later version. -c -c BLOM is distributed in the hope that it will be useful, but WITHOUT ANY -c WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS -c FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for -c more details. -c -c You should have received a copy of the GNU Lesser General Public License -c along with BLOM. If not, see https://www.gnu.org/licenses/. +! Copyright (C) 2020 K. Assmann, J. Tjiputra, J. Schwinger, M. Bentsen +! +! This file is part of BLOM/iHAMOCC. +! +! 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 https://www.gnu.org/licenses/. - subroutine restart_hamoccwt(rstfnm_ocn) -c -c write restart for HAMOCC -c - use mod_time, only: date,nstep - use mod_xc, only: idm,jdm,kdm - use mod_tracers, only: ntrbgc,ntr,itrbgc,trc - use mo_intfcblom, only: omask -c - implicit none -c - character(len=*) :: rstfnm_ocn +subroutine restart_hamoccwt(rstfnm_ocn) +! +! write restart for HAMOCC +! + use mod_time, only: date,nstep + use mod_xc, only: idm,jdm,kdm + use mod_tracers, only: ntrbgc,ntr,itrbgc,trc + use mo_intfcblom, only: omask - CALL AUFW_BGC(idm,jdm,kdm,ntr,ntrbgc,itrbgc,trc - . ,date%year,date%month,date%day,nstep,omask - . ,rstfnm_ocn) -c - return - end + implicit none + + character(len=*) :: rstfnm_ocn + + CALL AUFW_BGC(idm,jdm,kdm,ntr,ntrbgc,itrbgc,trc & + & ,date%year,date%month,date%day,nstep,omask & + & ,rstfnm_ocn) + +end subroutine restart_hamoccwt From d07c997e6f05cee5f3b2a09dfaa4a38f5e947c63 Mon Sep 17 00:00:00 2001 From: Tomas Torsvik Date: Fri, 19 Aug 2022 20:50:16 +0200 Subject: [PATCH 133/366] Rename hamocc/trc_limitc.F -> hamocc/trc_limitc.F90 --- hamocc/{trc_limitc.F => trc_limitc.F90} | 0 1 file changed, 0 insertions(+), 0 deletions(-) rename hamocc/{trc_limitc.F => trc_limitc.F90} (100%) diff --git a/hamocc/trc_limitc.F b/hamocc/trc_limitc.F90 similarity index 100% rename from hamocc/trc_limitc.F rename to hamocc/trc_limitc.F90 From 65ee7696b55d4cd1905bf3bcb2801907ee75b0b6 Mon Sep 17 00:00:00 2001 From: Tomas Torsvik Date: Fri, 19 Aug 2022 21:05:59 +0200 Subject: [PATCH 134/366] Reformat hamocc/trc_limitc.F90 according to free form convention. --- hamocc/trc_limitc.F90 | 258 +++++++++++++++++++++--------------------- 1 file changed, 127 insertions(+), 131 deletions(-) diff --git a/hamocc/trc_limitc.F90 b/hamocc/trc_limitc.F90 index 7e30aa77..51815398 100644 --- a/hamocc/trc_limitc.F90 +++ b/hamocc/trc_limitc.F90 @@ -1,136 +1,132 @@ -c Copyright (C) 2020 J. Schwinger, M. Bentsen -c -c This file is part of BLOM/iHAMOCC. -c -c BLOM is free software: you can redistribute it and/or modify it under the -c terms of the GNU Lesser General Public License as published by the Free -c Software Foundation, either version 3 of the License, or (at your option) -c any later version. -c -c BLOM is distributed in the hope that it will be useful, but WITHOUT ANY -c WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS -c FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for -c more details. -c -c You should have received a copy of the GNU Lesser General Public License -c along with BLOM. If not, see https://www.gnu.org/licenses/. - - - subroutine trc_limitc(nn) -c*********************************************************************** -c -c**** *SUBROUTINE trc_limitc* - remove negative tracer values. -c -c J. Schwinger *GFI, UiB initial version, 2014-06-17 -c - -c -c Modified -c -------- -c J.Schwinger, *Uni Research, Bergen* 2018-04-12 -c - fixed a bug related to the 2 time-level scheme -c -c -c -c Purpose -c ------- -c Remove negative tracer values in the first layer in a mass -c conservative fashion (i.e. the mass deficit removed is -c transfered to non-negative points by a multiplicative -c correction). This is done since the virtual tracer fluxes -c (applied in mxlayr.F directly before HAMOCC is called) can -c cause negative tracer values in regions with low concentration -c and strong precipitation. -c -c*********************************************************************** -c - use mod_xc, only: ii,jj,ips,ifp,isp,ilp,xcsum - use mod_grid, only: scp2 - use mod_state, only: dp - use mod_tracers, only: ntrbgc, itrbgc, trc - use mod_utility, only: util1 -c - implicit none -c - integer :: nn - integer :: i,j,l,nt,kn - real :: trbudo(ntrbgc),trbudn,q -c -c --- ------------------------------------------------------------------ -c --- - compute tracer budgets before removing negative values -c --- ------------------------------------------------------------------ -c - kn=1+nn -c - do nt=1,ntrbgc -c - util1(:,:)=0. -c -c$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)) - util1(i,j)=util1(i,j) - . +trc(i,j,kn,itrbgc+nt-1)*dp(i,j,kn)*scp2(i,j) - enddo - enddo +! Copyright (C) 2020 J. Schwinger, M. Bentsen +! +! This file is part of BLOM/iHAMOCC. +! +! 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 https://www.gnu.org/licenses/. + + +subroutine trc_limitc(nn) +!*********************************************************************** +! +!**** *SUBROUTINE trc_limitc* - remove negative tracer values. +! +! J. Schwinger *GFI, UiB initial version, 2014-06-17 +! - +! +! Modified +! -------- +! J.Schwinger, *Uni Research, Bergen* 2018-04-12 +! - fixed a bug related to the 2 time-level scheme +! +! +! +! Purpose +! ------- +! Remove negative tracer values in the first layer in a mass +! conservative fashion (i.e. the mass deficit removed is +! transfered to non-negative points by a multiplicative +! correction). This is done since the virtual tracer fluxes +! (applied in mxlayr.F directly before HAMOCC is called) can +! cause negative tracer values in regions with low concentration +! and strong precipitation. +! +!*********************************************************************** + use mod_xc, only: ii,jj,ips,ifp,isp,ilp,xcsum + use mod_grid, only: scp2 + use mod_state, only: dp + use mod_tracers, only: ntrbgc, itrbgc, trc + use mod_utility, only: util1 + + implicit none + + integer :: nn + integer :: i,j,l,nt,kn + real :: trbudo(ntrbgc),trbudn,q + + ! --- ------------------------------------------------------------------ + ! --- - compute tracer budgets before removing negative values + ! --- ------------------------------------------------------------------ + + kn=1+nn + + do nt=1,ntrbgc + + util1(:,:)=0. + +!$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)) + util1(i,j) = util1(i,j) & + & +trc(i,j,kn,itrbgc+nt-1)*dp(i,j,kn)*scp2(i,j) + enddo enddo -c$OMP END PARALLEL DO -c - call xcsum(trbudo(nt),util1,ips) -c - enddo -c -c -c --- ------------------------------------------------------------------ -c --- - remove negative tracer values in the surface layer -c --- ------------------------------------------------------------------ -c -c$OMP PARALLEL DO PRIVATE(j,l,i) - do nt=itrbgc,itrbgc+ntrbgc-1 - do j=1,jj - do l=1,isp(j) - do i=max(1,ifp(j,l)),min(ii,ilp(j,l)) + enddo +!$OMP END PARALLEL DO + + call xcsum(trbudo(nt),util1,ips) + + enddo + + ! --- ------------------------------------------------------------------ + ! --- - remove negative tracer values in the surface layer + ! --- ------------------------------------------------------------------ + +!$OMP PARALLEL DO PRIVATE(j,l,i) + do nt=itrbgc,itrbgc+ntrbgc-1 + do j=1,jj + do l=1,isp(j) + do i=max(1,ifp(j,l)),min(ii,ilp(j,l)) trc(i,j,kn,nt) = max(trc(i,j,kn,nt),0.0) - enddo - enddo + enddo enddo - enddo -c$OMP END PARALLEL DO -c -c -c --- ------------------------------------------------------------------ -c --- - recalculate and correct tracer budgets -c --- ------------------------------------------------------------------ -c - do nt=1,ntrbgc -c - util1(:,:)=0. -c -c$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)) - util1(i,j)=util1(i,j) - . +trc(i,j,kn,itrbgc+nt-1)*dp(i,j,kn)*scp2(i,j) - enddo - enddo + enddo + enddo +!$OMP END PARALLEL DO + + ! --- ------------------------------------------------------------------ + ! --- - recalculate and correct tracer budgets + ! --- ------------------------------------------------------------------ + + do nt=1,ntrbgc + + util1(:,:)=0. + +!$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)) + util1(i,j) = util1(i,j) & + & +trc(i,j,kn,itrbgc+nt-1)*dp(i,j,kn)*scp2(i,j) + enddo enddo -c$OMP END PARALLEL DO -c - call xcsum(trbudn,util1,ips) - q=trbudo(nt)/max(1.e-14,trbudn) -c -c$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)) - trc(i,j,kn,itrbgc+nt-1) = trc(i,j,kn,itrbgc+nt-1)*q - enddo - enddo + enddo +!$OMP END PARALLEL DO + + call xcsum(trbudn,util1,ips) + q = trbudo(nt)/max(1.e-14,trbudn) + +!$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)) + trc(i,j,kn,itrbgc+nt-1) = trc(i,j,kn,itrbgc+nt-1)*q + enddo enddo -c$OMP END PARALLEL DO -c - enddo -c - return - end + enddo +!$OMP END PARALLEL DO + + enddo + +end subroutine trc_limitc From 9406bd119e5fb2abe22b8cf3736840cd1583a39c Mon Sep 17 00:00:00 2001 From: Tomas Torsvik Date: Fri, 19 Aug 2022 21:11:23 +0200 Subject: [PATCH 135/366] Rename hamocc/ncout_hamocc.F -> hamocc/ncout_hamocc.F90 --- hamocc/{ncout_hamocc.F => ncout_hamocc.F90} | 0 1 file changed, 0 insertions(+), 0 deletions(-) rename hamocc/{ncout_hamocc.F => ncout_hamocc.F90} (100%) diff --git a/hamocc/ncout_hamocc.F b/hamocc/ncout_hamocc.F90 similarity index 100% rename from hamocc/ncout_hamocc.F rename to hamocc/ncout_hamocc.F90 From 47d3597e64504d6bc984a0032b7ae5b33673e27f Mon Sep 17 00:00:00 2001 From: Tomas Torsvik Date: Fri, 19 Aug 2022 23:04:19 +0200 Subject: [PATCH 136/366] Reformat hamocc/ncout_hamocc.F90 according to free form convention. --- hamocc/ncout_hamocc.F90 | 2946 +++++++++++++++++++-------------------- 1 file changed, 1469 insertions(+), 1477 deletions(-) diff --git a/hamocc/ncout_hamocc.F90 b/hamocc/ncout_hamocc.F90 index 9439d49d..c4bafdff 100644 --- a/hamocc/ncout_hamocc.F90 +++ b/hamocc/ncout_hamocc.F90 @@ -4,1639 +4,1631 @@ ! This file is part of BLOM/iHAMOCC. ! ! 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. +! 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 +! 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. +! more details. ! -! You should have received a copy of the GNU Lesser General Public License +! You should have received a copy of the GNU Lesser General Public License ! along with BLOM. If not, see https://www.gnu.org/licenses/. - subroutine ncwrt_bgc(iogrp) -c -c --- ------------------------------------------- -c --- output routine for HAMOCC diagnostic fields -c --- ------------------------------------------- -c - use mod_time, only: date0,date,calendar,nstep,nstep_in_day, - . nday_of_year,time0,time - use mod_xc, only: kdm,mnproc,itdm,jtdm,lp - use mod_grid, only: depths - use mod_dia, only: diafnm,sigmar1,iotype,ddm,depthslev, - . depthslev_bnds - use mo_control_bgc, only: dtbgc - use mo_vgrid, only: k0100,k0500,k1000,k2000,k4000 - use mo_param1_bgc, only: ks - use mod_nctools, only: ncwrt1,ncdims,nctime,ncfcls,ncfopn, - . ncdimc - use mo_bgcmean, only: domassfluxes, - . flx_cal0100,flx_cal0500,flx_cal1000, - . flx_cal2000,flx_cal4000,flx_cal_bot, - . flx_car0100,flx_car0500,flx_car1000, - . flx_car2000,flx_car4000,flx_car_bot, - . flx_bsi0100,flx_bsi0500,flx_bsi1000, - . flx_bsi2000,flx_bsi4000,flx_bsi_bot, - . flx_sediffic,flx_sediffal,flx_sediffph, - . flx_sediffox,flx_sediffn2,flx_sediffno3, - . flx_sediffsi, - . jsediffic,jsediffal,jsediffph,jsediffox, - . jsediffn2,jsediffno3,jsediffsi, - . jalkali,jano3,jasize,jatmco2, - . jbsiflx0100,jbsiflx0500,jbsiflx1000, - . jbsiflx2000,jbsiflx4000,jbsiflx_bot, - . jcalc,jcalflx0100,jcalflx0500,jcalflx1000, - . jcalflx2000,jcalflx4000,jcalflx_bot, - . jcarflx0100,jcarflx0500,jcarflx1000, - . jcarflx2000,jcarflx4000,jcarflx_bot, - . jco2flux,jco2fxd,jco2fxu,jco3,jdic,jdicsat, - . jdms,jdms_bac,jdms_uv,jdmsflux,jdmsprod, - . jdoc,jdp,jeps,jexpoca,jexport,jexposi, - . jgrazer, - . jintdnit,jintnfix,jintphosy,jiralk,jirdet, - . jirdin,jirdip,jirdoc,jiriron,jiron,jirsi, - . jkwco2,jlvlalkali,jlvlano3,jlvlasize, - . jlvlbigd14c,jlvlbromo,jlvlcalc,jlvlcalc13, - . jlvlcfc11,jlvlcfc12,jlvlco3,jlvld13c, - . jlvld14c,jlvldic,jlvldic13,jlvldic14, - . jlvldicsat,jlvldoc,jlvldoc13,jlvleps, - . jlvlgrazer,jlvlgrazer13,jlvliron,jlvln2o, - . jlvlnatalkali,jlvlnatcalc,jlvlnatco3, - . jlvlnatdic,jlvlnatomegaa,jlvlnatomegac, - . jlvlnos,jlvlo2sat,jlvlomegaa,jlvlomegac, - . jlvlopal,jlvloxygen,jlvlph,jlvlphosph, - . jlvlphosy,jlvlphyto,jlvlphyto13,jlvlpoc, - . jlvlpoc13,jlvlprefalk,jlvlprefdic, - . jlvlprefo2,jlvlprefpo4,jlvlsf6,jlvlsilica, - . jlvlwnos,jlvlwphy,jn2flux,jn2o,jn2oflux, - . jn2ofx,jndep,jniflux,jnos,jo2flux,jo2sat, - . jomegaa,jomegac,jopal,joxflux,joxygen,jpco2, - . jph,jphosph,jphosy,jphyto,jpoc,jprefalk, - . jprefdic,jprefo2,jprefpo4,jsilica, - . jsrfalkali,jsrfano3,jsrfdic,jsrfiron, - . jsrfoxygen,jsrfphosph,jsrfphyto,jsrfsilica, - . jwnos,jwphy, - . lyr_dp,lyr_dic,lyr_alkali,lyr_phosph, - . lyr_oxygen,lyr_ano3,lyr_silica,lyr_doc, - . lyr_phyto,lyr_grazer,lyr_poc,lyr_calc, - . lyr_opal,lyr_iron,lyr_phosy,lyr_co3,lyr_ph, - . lyr_omegaa,lyr_omegac,lyr_n2o,lyr_prefo2, - . lyr_o2sat,lyr_prefpo4,lyr_prefalk, - . lyr_prefdic,lyr_dicsat, - . lvl_dic,lvl_alkali, - . lvl_phosph,lvl_oxygen,lvl_ano3,lvl_silica, - . lvl_doc,lvl_phyto,lvl_grazer,lvl_poc, - . lvl_calc,lvl_opal,lvl_iron,lvl_phosy, - . lvl_co3,lvl_ph,lvl_omegaa,lvl_omegac, - . lvl_n2o,lvl_prefo2,lvl_o2sat,lvl_prefpo4, - . lvl_prefalk,lvl_prefdic,lvl_dicsat, - . lvl_o2sat,srf_n2ofx,srf_atmco2,srf_kwco2, - . srf_pco2,srf_dmsflux,srf_co2fxd, - . srf_co2fxu,srf_oxflux,srf_niflux,srf_dms, - . srf_dmsprod,srf_dms_bac,srf_dms_uv, - . srf_export,srf_exposi,srf_expoca,srf_dic, - . srf_alkali,srf_phosph,srf_oxygen,srf_ano3, - . srf_silica,srf_iron,srf_phyto, - . int_phosy,int_nfix,int_dnit, - . nbgc,nacc_bgc,bgcwrt,glb_inventory,bgct2d, - . nbgcmax,glb_ncformat,glb_compflag, - . glb_fnametag,filefq_bgc,diagfq_bgc, - . filemon_bgc,fileann_bgc,ip,wrtlyr,wrtlvl, - . loglyr,inilvl,inilyr,inisrf,loglvl, - , msklvl,wrtsrf,msksrf,finlyr +subroutine ncwrt_bgc(iogrp) +! +! --- ------------------------------------------- +! --- output routine for HAMOCC diagnostic fields +! --- ------------------------------------------- +! + use mod_time, only: date0,date,calendar,nstep,nstep_in_day, & + & nday_of_year,time0,time + use mod_xc, only: kdm,mnproc,itdm,jtdm,lp + use mod_grid, only: depths + use mod_dia, only: diafnm,sigmar1,iotype,ddm,depthslev, & + & depthslev_bnds + use mo_control_bgc, only: dtbgc + use mo_vgrid, only: k0100,k0500,k1000,k2000,k4000 + use mo_param1_bgc, only: ks + use mod_nctools, only: ncwrt1,ncdims,nctime,ncfcls,ncfopn, & + & ncdimc + use mo_bgcmean, only: domassfluxes, & + & flx_cal0100,flx_cal0500,flx_cal1000, & + & flx_cal2000,flx_cal4000,flx_cal_bot, & + & flx_car0100,flx_car0500,flx_car1000, & + & flx_car2000,flx_car4000,flx_car_bot, & + & flx_bsi0100,flx_bsi0500,flx_bsi1000, & + & flx_bsi2000,flx_bsi4000,flx_bsi_bot, & + & flx_sediffic,flx_sediffal,flx_sediffph, & + & flx_sediffox,flx_sediffn2,flx_sediffno3, & + & flx_sediffsi, & + & jsediffic,jsediffal,jsediffph,jsediffox, & + & jsediffn2,jsediffno3,jsediffsi, & + & jalkali,jano3,jasize,jatmco2, & + & jbsiflx0100,jbsiflx0500,jbsiflx1000, & + & jbsiflx2000,jbsiflx4000,jbsiflx_bot, & + & jcalc,jcalflx0100,jcalflx0500,jcalflx1000, & + & jcalflx2000,jcalflx4000,jcalflx_bot, & + & jcarflx0100,jcarflx0500,jcarflx1000, & + & jcarflx2000,jcarflx4000,jcarflx_bot, & + & jco2flux,jco2fxd,jco2fxu,jco3,jdic,jdicsat, & + & jdms,jdms_bac,jdms_uv,jdmsflux,jdmsprod, & + & jdoc,jdp,jeps,jexpoca,jexport,jexposi, & + & jgrazer, & + & jintdnit,jintnfix,jintphosy,jiralk,jirdet, & + & jirdin,jirdip,jirdoc,jiriron,jiron,jirsi, & + & jkwco2,jlvlalkali,jlvlano3,jlvlasize, & + & jlvlbigd14c,jlvlbromo,jlvlcalc,jlvlcalc13, & + & jlvlcfc11,jlvlcfc12,jlvlco3,jlvld13c, & + & jlvld14c,jlvldic,jlvldic13,jlvldic14, & + & jlvldicsat,jlvldoc,jlvldoc13,jlvleps, & + & jlvlgrazer,jlvlgrazer13,jlvliron,jlvln2o, & + & jlvlnatalkali,jlvlnatcalc,jlvlnatco3, & + & jlvlnatdic,jlvlnatomegaa,jlvlnatomegac, & + & jlvlnos,jlvlo2sat,jlvlomegaa,jlvlomegac, & + & jlvlopal,jlvloxygen,jlvlph,jlvlphosph, & + & jlvlphosy,jlvlphyto,jlvlphyto13,jlvlpoc, & + & jlvlpoc13,jlvlprefalk,jlvlprefdic, & + & jlvlprefo2,jlvlprefpo4,jlvlsf6,jlvlsilica, & + & jlvlwnos,jlvlwphy,jn2flux,jn2o,jn2oflux, & + & jn2ofx,jndep,jniflux,jnos,jo2flux,jo2sat, & + & jomegaa,jomegac,jopal,joxflux,joxygen,jpco2, & + & jph,jphosph,jphosy,jphyto,jpoc,jprefalk, & + & jprefdic,jprefo2,jprefpo4,jsilica, & + & jsrfalkali,jsrfano3,jsrfdic,jsrfiron, & + & jsrfoxygen,jsrfphosph,jsrfphyto,jsrfsilica, & + & jwnos,jwphy, & + & lyr_dp,lyr_dic,lyr_alkali,lyr_phosph, & + & lyr_oxygen,lyr_ano3,lyr_silica,lyr_doc, & + & lyr_phyto,lyr_grazer,lyr_poc,lyr_calc, & + & lyr_opal,lyr_iron,lyr_phosy,lyr_co3,lyr_ph, & + & lyr_omegaa,lyr_omegac,lyr_n2o,lyr_prefo2, & + & lyr_o2sat,lyr_prefpo4,lyr_prefalk, & + & lyr_prefdic,lyr_dicsat, & + & lvl_dic,lvl_alkali, & + & lvl_phosph,lvl_oxygen,lvl_ano3,lvl_silica, & + & lvl_doc,lvl_phyto,lvl_grazer,lvl_poc, & + & lvl_calc,lvl_opal,lvl_iron,lvl_phosy, & + & lvl_co3,lvl_ph,lvl_omegaa,lvl_omegac, & + & lvl_n2o,lvl_prefo2,lvl_o2sat,lvl_prefpo4, & + & lvl_prefalk,lvl_prefdic,lvl_dicsat, & + & lvl_o2sat,srf_n2ofx,srf_atmco2,srf_kwco2, & + & srf_pco2,srf_dmsflux,srf_co2fxd, & + & srf_co2fxu,srf_oxflux,srf_niflux,srf_dms, & + & srf_dmsprod,srf_dms_bac,srf_dms_uv, & + & srf_export,srf_exposi,srf_expoca,srf_dic, & + & srf_alkali,srf_phosph,srf_oxygen,srf_ano3, & + & srf_silica,srf_iron,srf_phyto, & + & int_phosy,int_nfix,int_dnit, & + & nbgc,nacc_bgc,bgcwrt,glb_inventory,bgct2d, & + & nbgcmax,glb_ncformat,glb_compflag, & + & glb_fnametag,filefq_bgc,diagfq_bgc, & + & filemon_bgc,fileann_bgc,ip,wrtlyr,wrtlvl, & + & loglyr,inilvl,inilyr,inisrf,loglvl, & + & msklvl,wrtsrf,msksrf,finlyr #ifdef AGG - use mo_bgcmean, only: lyr_nos,lyr_wphy, lyr_wnos,lyr_eps, - . lyr_asize,lvl_nos,lvl_wphy,lvl_wnos,lvl_eps, - . lvl_asize + use mo_bgcmean, only: lyr_nos,lyr_wphy, lyr_wnos,lyr_eps, & + & lyr_asize,lvl_nos,lvl_wphy,lvl_wnos,lvl_eps, & + & lvl_asize #endif #ifdef BROMO - use mo_bgcmean, only: jbromo,jbromofx,jsrfbromo,jbromo_prod, - . jbromo_uv,jatmbromo,lvl_bromo,srf_bromofx, - . srf_bromo,int_bromopro,int_bromouv, - . srf_atmbromo,lyr_bromo + use mo_bgcmean, only: jbromo,jbromofx,jsrfbromo,jbromo_prod, & + & jbromo_uv,jatmbromo,lvl_bromo,srf_bromofx, & + & srf_bromo,int_bromopro,int_bromouv, & + & srf_atmbromo,lyr_bromo #endif #ifdef CFC - use mo_bgcmean,only: jcfc11,jcfc12,jsf6,jcfc11fx,jcfc12fx,jsf6fx, - . lvl_cfc11,lvl_cfc12,lvl_sf6,srf_cfc11, - . srf_cfc12,srf_sf6,lyr_cfc11,lyr_cfc12, - . lyr_sf6 + use mo_bgcmean,only: jcfc11,jcfc12,jsf6,jcfc11fx,jcfc12fx,jsf6fx, & + & lvl_cfc11,lvl_cfc12,lvl_sf6,srf_cfc11, & + & srf_cfc12,srf_sf6,lyr_cfc11,lyr_cfc12, & + & lyr_sf6 #endif #ifdef cisonew - use mo_biomod, only: c14fac - use mo_bgcmean, only: jdic13,jdic14,jd13c,jd14c,jbigd14c,jpoc13, - . jdoc13,jcalc13,jphyto13,jgrazer13,jco213fxd, - . jco213fxu,jco214fxd,jco214fxu,jatmc13, - . jatmc14,jdic13,jdic14,jd13c,jd14c,jbigd14c, - . srf_co213fxd,srf_co213fxu,srf_co214fxd, - . srf_co214fxu,srf_atmc13,srf_atmc14,lyr_dic13, - . lyr_dic14,lyr_d13c,lyr_d14c,lyr_bigd14c, - . lyr_poc13,lyr_doc13,lyr_calc13,lyr_phyto13, - . lyr_grazer13,lvl_dic13,lvl_dic14,lvl_d13c, - . lvl_d14c,lvl_bigd14c,lvl_poc13,lvl_doc13, - . lvl_calc13,lvl_phyto13,lvl_grazer13 + use mo_biomod, only: c14fac + use mo_bgcmean, only: jdic13,jdic14,jd13c,jd14c,jbigd14c,jpoc13, & + & jdoc13,jcalc13,jphyto13,jgrazer13,jco213fxd, & + & jco213fxu,jco214fxd,jco214fxu,jatmc13, & + & jatmc14,jdic13,jdic14,jd13c,jd14c,jbigd14c, & + & srf_co213fxd,srf_co213fxu,srf_co214fxd, & + & srf_co214fxu,srf_atmc13,srf_atmc14,lyr_dic13, & + & lyr_dic14,lyr_d13c,lyr_d14c,lyr_bigd14c, & + & lyr_poc13,lyr_doc13,lyr_calc13,lyr_phyto13, & + & lyr_grazer13,lvl_dic13,lvl_dic14,lvl_d13c, & + & lvl_d14c,lvl_bigd14c,lvl_poc13,lvl_doc13, & + & lvl_calc13,lvl_phyto13,lvl_grazer13 #endif #ifdef natDIC - use mo_bgcmean, only: jnatalkali,jnatdic,jnatcalc,jnatco3,jnatph, - . jnatomegaa,jnatomegac,lyr_natph,jlvlnatph, - . lvl_natph,jsrfnatdic, - . jsrfnatalk,jnatpco2,jnatco2fx,lyr_natco3, - . lyr_natalkali,lyr_natdic,lyr_natcalc, - . lyr_natomegaa,lyr_natomegac,lvl_natco3, - . lvl_natalkali,lvl_natdic,lvl_natcalc, - . lvl_natomegaa,lvl_natomegac,srf_natdic, - . srf_natalkali,srf_natpco2,srf_natco2fx + use mo_bgcmean, only: jnatalkali,jnatdic,jnatcalc,jnatco3,jnatph, & + & jnatomegaa,jnatomegac,lyr_natph,jlvlnatph, & + & lvl_natph,jsrfnatdic, & + & jsrfnatalk,jnatpco2,jnatco2fx,lyr_natco3, & + & lyr_natalkali,lyr_natdic,lyr_natcalc, & + & lyr_natomegaa,lyr_natomegac,lvl_natco3, & + & lvl_natalkali,lvl_natdic,lvl_natcalc, & + & lvl_natomegaa,lvl_natomegac,srf_natdic, & + & srf_natalkali,srf_natpco2,srf_natco2fx #endif #ifndef sedbypass - use mo_bgcmean, only: jpowaic,jpowaal,jpowaph,jpowaox,jpown2, - . jpowno3,jpowasi,jssso12,jssssil,jssster, - . jsssc12,jbursssc12,jburssssil,jburssster, - . sdm_powaic,sdm_powaal,sdm_powaph,sdm_powaox, - . sdm_pown2,sdm_powno3,sdm_powasi,sdm_ssso12, - . sdm_ssssil,sdm_sssc12,sdm_ssster,jburssso12, - . bur_sssc12,bur_ssssil,bur_ssster,bur_ssso12, - . inisdm,inibur,wrtsdm,accbur,accsdm,wrtbur -#endif -c - implicit none -c - integer iogrp -c - integer i,j,k,l,nt - integer ny,nm,nd,dayfrac,irec(nbgcmax),cmpflg - character*256 fname(nbgcmax) - character startdate*20,timeunits*30 - real datenum,rnacc - logical append2file(nbgcmax) - data append2file /nbgcmax*.false./ - save fname,irec,append2file -c -c --- set time information - timeunits=' ' - startdate=' ' - write(timeunits,'(a11,i4.4,a1,i2.2,a1,i2.2,a6)') - . 'days since ',min(1800,date0%year),'-',1,'-',1,' 00:00' - write(startdate,'(i4.4,a1,i2.2,a1,i2.2,a6)') - . date0%year,'-',date0%month,'-',date0%day,' 00:00' - datenum=time-time0-0.5*diagfq_bgc(iogrp)/nstep_in_day -c -c --- get file name - if (.not.append2file(iogrp)) then - call diafnm(GLB_FNAMETAG(iogrp), - . filefq_bgc(iogrp)/real(nstep_in_day), - . filemon_bgc(iogrp),fileann_bgc(iogrp),fname(iogrp)) - append2file(iogrp)=.true. - irec(iogrp)=1 - else - irec(iogrp)=irec(iogrp)+1 - endif - if (((fileann_bgc(iogrp).and.nday_of_year.eq.1.or. - . filemon_bgc(iogrp).and.date%day.eq.1).and. - . mod(nstep,nstep_in_day).eq.0).or. - . .not.(fileann_bgc(iogrp).or.filemon_bgc(iogrp)).and. - . mod(nstep+.5,filefq_bgc(iogrp)).lt.1.) then - append2file(iogrp)=.false. - endif -c -c --- prepare output fields - if (mnproc.eq.1) then - write (lp,'(a,f6.2,a)') ' ncwrt_bgc: fields averaged over ', - . real(nacc_bgc(iogrp)),' steps' - write(lp,*) 'irec(iogrp)',irec(iogrp) - endif - rnacc=1./real(nacc_bgc(iogrp)) - cmpflg=GLB_COMPFLAG(iogrp) -c -c --- create output file - if (GLB_NCFORMAT(iogrp).eq.1) then - call ncfopn(fname(iogrp),'w','6',irec(iogrp),iotype) - elseif (GLB_NCFORMAT(iogrp).eq.2) then - call ncfopn(fname(iogrp),'w','h',irec(iogrp),iotype) - else - call ncfopn(fname(iogrp),'w','c',irec(iogrp),iotype) - endif -c -c --- define spatial and time dimensions - if (cmpflg.ne.0) then - call ncdimc('pcomp',ip,0) - else - call ncdims('x',itdm) - call ncdims('y',jtdm) - endif - call ncdims('sigma',kdm) - call ncdims('depth',ddm) - call ncdims('ks',ks) - call ncdims('bounds',2) - call ncdims('time',0) - call hamoccvardef(iogrp,timeunits,calendar,cmpflg) - call nctime(datenum,calendar,timeunits,startdate) -c -c --- write auxillary dimension information - call ncwrt1('sigma','sigma',sigmar1) - call ncwrt1('depth','depth',depthslev) - call ncwrt1('depth_bnds','bounds depth',depthslev_bnds) -c -c --- finalize accumulation - call finlyr(jphyto(iogrp),jdp(iogrp)) - call finlyr(jgrazer(iogrp),jdp(iogrp)) - call finlyr(jdoc(iogrp),jdp(iogrp)) - call finlyr(jphosy(iogrp),jdp(iogrp)) - call finlyr(jphosph(iogrp),jdp(iogrp)) - call finlyr(joxygen(iogrp),jdp(iogrp)) - call finlyr(jiron(iogrp),jdp(iogrp)) - call finlyr(jano3(iogrp),jdp(iogrp)) - call finlyr(jalkali(iogrp),jdp(iogrp)) - call finlyr(jsilica(iogrp),jdp(iogrp)) - call finlyr(jdic(iogrp),jdp(iogrp)) - call finlyr(jpoc(iogrp),jdp(iogrp)) - call finlyr(jcalc(iogrp),jdp(iogrp)) - call finlyr(jopal(iogrp),jdp(iogrp)) - call finlyr(jco3(iogrp),jdp(iogrp)) - call finlyr(jph(iogrp),jdp(iogrp)) - call finlyr(jomegaa(iogrp),jdp(iogrp)) - call finlyr(jomegac(iogrp),jdp(iogrp)) - call finlyr(jn2o(iogrp),jdp(iogrp)) - call finlyr(jprefo2(iogrp),jdp(iogrp)) - call finlyr(jo2sat(iogrp),jdp(iogrp)) - call finlyr(jprefpo4(iogrp),jdp(iogrp)) - call finlyr(jprefalk(iogrp),jdp(iogrp)) - call finlyr(jprefdic(iogrp),jdp(iogrp)) - call finlyr(jdicsat(iogrp),jdp(iogrp)) + use mo_bgcmean, only: jpowaic,jpowaal,jpowaph,jpowaox,jpown2, & + & jpowno3,jpowasi,jssso12,jssssil,jssster, & + & jsssc12,jbursssc12,jburssssil,jburssster, & + & sdm_powaic,sdm_powaal,sdm_powaph,sdm_powaox, & + & sdm_pown2,sdm_powno3,sdm_powasi,sdm_ssso12, & + & sdm_ssssil,sdm_sssc12,sdm_ssster,jburssso12, & + & bur_sssc12,bur_ssssil,bur_ssster,bur_ssso12, & + & inisdm,inibur,wrtsdm,accbur,accsdm,wrtbur +#endif + + implicit none + + integer iogrp + + integer i,j,k,l,nt + integer ny,nm,nd,dayfrac,irec(nbgcmax),cmpflg + character*256 fname(nbgcmax) + character startdate*20,timeunits*30 + real datenum,rnacc + logical append2file(nbgcmax) + data append2file /nbgcmax*.false./ + save fname,irec,append2file + + ! --- set time information + timeunits=' ' + startdate=' ' + write(timeunits,'(a11,i4.4,a1,i2.2,a1,i2.2,a6)') & + & 'days since ',min(1800,date0%year),'-',1,'-',1,' 00:00' + write(startdate,'(i4.4,a1,i2.2,a1,i2.2,a6)') & + & date0%year,'-',date0%month,'-',date0%day,' 00:00' + datenum=time-time0-0.5*diagfq_bgc(iogrp)/nstep_in_day + + ! --- get file name + if (.not.append2file(iogrp)) then + call diafnm(GLB_FNAMETAG(iogrp), & + & filefq_bgc(iogrp)/real(nstep_in_day), & + & filemon_bgc(iogrp),fileann_bgc(iogrp),fname(iogrp)) + append2file(iogrp)=.true. + irec(iogrp)=1 + else + irec(iogrp)=irec(iogrp)+1 + endif + if (((fileann_bgc(iogrp).and.nday_of_year.eq.1.or. & + & filemon_bgc(iogrp).and.date%day.eq.1).and. & + & mod(nstep,nstep_in_day).eq.0).or. & + & .not.(fileann_bgc(iogrp).or.filemon_bgc(iogrp)).and. & + & mod(nstep+.5,filefq_bgc(iogrp)).lt.1.) then + append2file(iogrp)=.false. + endif + + ! --- prepare output fields + if (mnproc.eq.1) then + write (lp,'(a,f6.2,a)') ' ncwrt_bgc: fields averaged over ', & + & real(nacc_bgc(iogrp)),' steps' + write(lp,*) 'irec(iogrp)',irec(iogrp) + endif + rnacc=1./real(nacc_bgc(iogrp)) + cmpflg=GLB_COMPFLAG(iogrp) + + ! --- create output file + if (GLB_NCFORMAT(iogrp).eq.1) then + call ncfopn(fname(iogrp),'w','6',irec(iogrp),iotype) + elseif (GLB_NCFORMAT(iogrp).eq.2) then + call ncfopn(fname(iogrp),'w','h',irec(iogrp),iotype) + else + call ncfopn(fname(iogrp),'w','c',irec(iogrp),iotype) + endif + + ! --- define spatial and time dimensions + if (cmpflg.ne.0) then + call ncdimc('pcomp',ip,0) + else + call ncdims('x',itdm) + call ncdims('y',jtdm) + endif + call ncdims('sigma',kdm) + call ncdims('depth',ddm) + call ncdims('ks',ks) + call ncdims('bounds',2) + call ncdims('time',0) + call hamoccvardef(iogrp,timeunits,calendar,cmpflg) + call nctime(datenum,calendar,timeunits,startdate) + + ! --- write auxillary dimension information + call ncwrt1('sigma','sigma',sigmar1) + call ncwrt1('depth','depth',depthslev) + call ncwrt1('depth_bnds','bounds depth',depthslev_bnds) + + ! --- finalize accumulation + call finlyr(jphyto(iogrp),jdp(iogrp)) + call finlyr(jgrazer(iogrp),jdp(iogrp)) + call finlyr(jdoc(iogrp),jdp(iogrp)) + call finlyr(jphosy(iogrp),jdp(iogrp)) + call finlyr(jphosph(iogrp),jdp(iogrp)) + call finlyr(joxygen(iogrp),jdp(iogrp)) + call finlyr(jiron(iogrp),jdp(iogrp)) + call finlyr(jano3(iogrp),jdp(iogrp)) + call finlyr(jalkali(iogrp),jdp(iogrp)) + call finlyr(jsilica(iogrp),jdp(iogrp)) + call finlyr(jdic(iogrp),jdp(iogrp)) + call finlyr(jpoc(iogrp),jdp(iogrp)) + call finlyr(jcalc(iogrp),jdp(iogrp)) + call finlyr(jopal(iogrp),jdp(iogrp)) + call finlyr(jco3(iogrp),jdp(iogrp)) + call finlyr(jph(iogrp),jdp(iogrp)) + call finlyr(jomegaa(iogrp),jdp(iogrp)) + call finlyr(jomegac(iogrp),jdp(iogrp)) + call finlyr(jn2o(iogrp),jdp(iogrp)) + call finlyr(jprefo2(iogrp),jdp(iogrp)) + call finlyr(jo2sat(iogrp),jdp(iogrp)) + call finlyr(jprefpo4(iogrp),jdp(iogrp)) + call finlyr(jprefalk(iogrp),jdp(iogrp)) + call finlyr(jprefdic(iogrp),jdp(iogrp)) + call finlyr(jdicsat(iogrp),jdp(iogrp)) #ifdef cisonew - call finlyr(jdic13(iogrp),jdp(iogrp)) - call finlyr(jdic14(iogrp),jdp(iogrp)) - call finlyr(jd13c(iogrp),jdp(iogrp)) - call finlyr(jd14c(iogrp),jdp(iogrp)) - call finlyr(jbigd14c(iogrp),jdp(iogrp)) - call finlyr(jpoc13(iogrp),jdp(iogrp)) - call finlyr(jdoc13(iogrp),jdp(iogrp)) - call finlyr(jcalc13(iogrp),jdp(iogrp)) - call finlyr(jphyto13(iogrp),jdp(iogrp)) - call finlyr(jgrazer13(iogrp),jdp(iogrp)) -#endif + call finlyr(jdic13(iogrp),jdp(iogrp)) + call finlyr(jdic14(iogrp),jdp(iogrp)) + call finlyr(jd13c(iogrp),jdp(iogrp)) + call finlyr(jd14c(iogrp),jdp(iogrp)) + call finlyr(jbigd14c(iogrp),jdp(iogrp)) + call finlyr(jpoc13(iogrp),jdp(iogrp)) + call finlyr(jdoc13(iogrp),jdp(iogrp)) + call finlyr(jcalc13(iogrp),jdp(iogrp)) + call finlyr(jphyto13(iogrp),jdp(iogrp)) + call finlyr(jgrazer13(iogrp),jdp(iogrp)) +#endif #ifdef AGG - call finlyr(jnos(iogrp),jdp(iogrp)) - call finlyr(jwphy(iogrp),jdp(iogrp)) - call finlyr(jwnos(iogrp),jdp(iogrp)) - call finlyr(jeps(iogrp),jdp(iogrp)) - call finlyr(jasize(iogrp),jdp(iogrp)) -#endif + call finlyr(jnos(iogrp),jdp(iogrp)) + call finlyr(jwphy(iogrp),jdp(iogrp)) + call finlyr(jwnos(iogrp),jdp(iogrp)) + call finlyr(jeps(iogrp),jdp(iogrp)) + call finlyr(jasize(iogrp),jdp(iogrp)) +#endif #ifdef CFC - call finlyr(jcfc11(iogrp),jdp(iogrp)) - call finlyr(jcfc12(iogrp),jdp(iogrp)) - call finlyr(jsf6(iogrp),jdp(iogrp)) + call finlyr(jcfc11(iogrp),jdp(iogrp)) + call finlyr(jcfc12(iogrp),jdp(iogrp)) + call finlyr(jsf6(iogrp),jdp(iogrp)) #endif #ifdef natDIC - call finlyr(jnatalkali(iogrp),jdp(iogrp)) - call finlyr(jnatdic(iogrp),jdp(iogrp)) - call finlyr(jnatcalc(iogrp),jdp(iogrp)) - call finlyr(jnatco3(iogrp),jdp(iogrp)) - call finlyr(jnatph(iogrp),jdp(iogrp)) - call finlyr(jnatomegaa(iogrp),jdp(iogrp)) - call finlyr(jnatomegac(iogrp),jdp(iogrp)) + call finlyr(jnatalkali(iogrp),jdp(iogrp)) + call finlyr(jnatdic(iogrp),jdp(iogrp)) + call finlyr(jnatcalc(iogrp),jdp(iogrp)) + call finlyr(jnatco3(iogrp),jdp(iogrp)) + call finlyr(jnatph(iogrp),jdp(iogrp)) + call finlyr(jnatomegaa(iogrp),jdp(iogrp)) + call finlyr(jnatomegac(iogrp),jdp(iogrp)) #endif #ifdef BROMO - call finlyr(jbromo(iogrp),jdp(iogrp)) + call finlyr(jbromo(iogrp),jdp(iogrp)) #endif -c -c --- Mask sea floor in mass fluxes - call msksrf(jcarflx0100(iogrp),k0100) - call msksrf(jcarflx0500(iogrp),k0500) - call msksrf(jcarflx1000(iogrp),k1000) - call msksrf(jcarflx2000(iogrp),k2000) - call msksrf(jcarflx4000(iogrp),k4000) - call msksrf(jbsiflx0100(iogrp),k0100) - call msksrf(jbsiflx0500(iogrp),k0500) - call msksrf(jbsiflx1000(iogrp),k1000) - call msksrf(jbsiflx2000(iogrp),k2000) - call msksrf(jbsiflx4000(iogrp),k4000) - call msksrf(jcalflx0100(iogrp),k0100) - call msksrf(jcalflx0500(iogrp),k0500) - call msksrf(jcalflx1000(iogrp),k1000) - call msksrf(jcalflx2000(iogrp),k2000) - call msksrf(jcalflx4000(iogrp),k4000) -c -c --- Mask sea floor in level data - call msklvl(jlvlphyto(iogrp),depths) - call msklvl(jlvlgrazer(iogrp),depths) - call msklvl(jlvldoc(iogrp),depths) - call msklvl(jlvlphosy(iogrp),depths) - call msklvl(jlvlphosph(iogrp),depths) - call msklvl(jlvloxygen(iogrp),depths) - call msklvl(jlvliron(iogrp),depths) - call msklvl(jlvlano3(iogrp),depths) - call msklvl(jlvlalkali(iogrp),depths) - call msklvl(jlvlsilica(iogrp),depths) - call msklvl(jlvldic(iogrp),depths) - call msklvl(jlvlpoc(iogrp),depths) - call msklvl(jlvlcalc(iogrp),depths) - call msklvl(jlvlopal(iogrp),depths) - call msklvl(jlvlco3(iogrp),depths) - call msklvl(jlvlph(iogrp),depths) - call msklvl(jlvlomegaa(iogrp),depths) - call msklvl(jlvlomegac(iogrp),depths) - call msklvl(jlvln2o(iogrp),depths) - call msklvl(jlvlprefo2(iogrp),depths) - call msklvl(jlvlo2sat(iogrp),depths) - call msklvl(jlvlprefpo4(iogrp),depths) - call msklvl(jlvlprefalk(iogrp),depths) - call msklvl(jlvlprefdic(iogrp),depths) - call msklvl(jlvldicsat(iogrp),depths) + ! --- Mask sea floor in mass fluxes + call msksrf(jcarflx0100(iogrp),k0100) + call msksrf(jcarflx0500(iogrp),k0500) + call msksrf(jcarflx1000(iogrp),k1000) + call msksrf(jcarflx2000(iogrp),k2000) + call msksrf(jcarflx4000(iogrp),k4000) + call msksrf(jbsiflx0100(iogrp),k0100) + call msksrf(jbsiflx0500(iogrp),k0500) + call msksrf(jbsiflx1000(iogrp),k1000) + call msksrf(jbsiflx2000(iogrp),k2000) + call msksrf(jbsiflx4000(iogrp),k4000) + call msksrf(jcalflx0100(iogrp),k0100) + call msksrf(jcalflx0500(iogrp),k0500) + call msksrf(jcalflx1000(iogrp),k1000) + call msksrf(jcalflx2000(iogrp),k2000) + call msksrf(jcalflx4000(iogrp),k4000) + + ! --- Mask sea floor in level data + call msklvl(jlvlphyto(iogrp),depths) + call msklvl(jlvlgrazer(iogrp),depths) + call msklvl(jlvldoc(iogrp),depths) + call msklvl(jlvlphosy(iogrp),depths) + call msklvl(jlvlphosph(iogrp),depths) + call msklvl(jlvloxygen(iogrp),depths) + call msklvl(jlvliron(iogrp),depths) + call msklvl(jlvlano3(iogrp),depths) + call msklvl(jlvlalkali(iogrp),depths) + call msklvl(jlvlsilica(iogrp),depths) + call msklvl(jlvldic(iogrp),depths) + call msklvl(jlvlpoc(iogrp),depths) + call msklvl(jlvlcalc(iogrp),depths) + call msklvl(jlvlopal(iogrp),depths) + call msklvl(jlvlco3(iogrp),depths) + call msklvl(jlvlph(iogrp),depths) + call msklvl(jlvlomegaa(iogrp),depths) + call msklvl(jlvlomegac(iogrp),depths) + call msklvl(jlvln2o(iogrp),depths) + call msklvl(jlvlprefo2(iogrp),depths) + call msklvl(jlvlo2sat(iogrp),depths) + call msklvl(jlvlprefpo4(iogrp),depths) + call msklvl(jlvlprefalk(iogrp),depths) + call msklvl(jlvlprefdic(iogrp),depths) + call msklvl(jlvldicsat(iogrp),depths) #ifdef cisonew - call msklvl(jlvldic13(iogrp),depths) - call msklvl(jlvldic14(iogrp),depths) - call msklvl(jlvld13c(iogrp),depths) - call msklvl(jlvld14c(iogrp),depths) - call msklvl(jlvlbigd14c(iogrp),depths) - call msklvl(jlvlpoc13(iogrp),depths) - call msklvl(jlvldoc13(iogrp),depths) - call msklvl(jlvlcalc13(iogrp),depths) - call msklvl(jlvlphyto13(iogrp),depths) - call msklvl(jlvlgrazer13(iogrp),depths) -#endif + call msklvl(jlvldic13(iogrp),depths) + call msklvl(jlvldic14(iogrp),depths) + call msklvl(jlvld13c(iogrp),depths) + call msklvl(jlvld14c(iogrp),depths) + call msklvl(jlvlbigd14c(iogrp),depths) + call msklvl(jlvlpoc13(iogrp),depths) + call msklvl(jlvldoc13(iogrp),depths) + call msklvl(jlvlcalc13(iogrp),depths) + call msklvl(jlvlphyto13(iogrp),depths) + call msklvl(jlvlgrazer13(iogrp),depths) +#endif #ifdef AGG - call msklvl(jlvlnos(iogrp),depths) - call msklvl(jlvlwphy(iogrp),depths) - call msklvl(jlvlwnos(iogrp),depths) - call msklvl(jlvleps(iogrp),depths) - call msklvl(jlvlasize(iogrp),depths) -#endif + call msklvl(jlvlnos(iogrp),depths) + call msklvl(jlvlwphy(iogrp),depths) + call msklvl(jlvlwnos(iogrp),depths) + call msklvl(jlvleps(iogrp),depths) + call msklvl(jlvlasize(iogrp),depths) +#endif #ifdef CFC - call msklvl(jlvlcfc11(iogrp),depths) - call msklvl(jlvlcfc12(iogrp),depths) - call msklvl(jlvlsf6(iogrp),depths) + call msklvl(jlvlcfc11(iogrp),depths) + call msklvl(jlvlcfc12(iogrp),depths) + call msklvl(jlvlsf6(iogrp),depths) #endif #ifdef natDIC - call msklvl(jlvlnatalkali(iogrp),depths) - call msklvl(jlvlnatdic(iogrp),depths) - call msklvl(jlvlnatcalc(iogrp),depths) - call msklvl(jlvlnatco3(iogrp),depths) - call msklvl(jlvlnatph(iogrp),depths) - call msklvl(jlvlnatomegaa(iogrp),depths) - call msklvl(jlvlnatomegac(iogrp),depths) + call msklvl(jlvlnatalkali(iogrp),depths) + call msklvl(jlvlnatdic(iogrp),depths) + call msklvl(jlvlnatcalc(iogrp),depths) + call msklvl(jlvlnatco3(iogrp),depths) + call msklvl(jlvlnatph(iogrp),depths) + call msklvl(jlvlnatomegaa(iogrp),depths) + call msklvl(jlvlnatomegac(iogrp),depths) #endif #ifdef BROMO - call msklvl(jlvlbromo(iogrp),depths) + call msklvl(jlvlbromo(iogrp),depths) #endif -c -c --- Compute log10 of pH - if (LYR_PH(iogrp).ne.0) call loglyr(jph(iogrp),1.,0.) - if (LVL_PH(iogrp).ne.0) call loglvl(jlvlph(iogrp),rnacc,0.) + ! --- Compute log10 of pH + if (LYR_PH(iogrp).ne.0) call loglyr(jph(iogrp),1.,0.) + if (LVL_PH(iogrp).ne.0) call loglvl(jlvlph(iogrp),rnacc,0.) #ifdef natDIC - if (LYR_NATPH(iogrp).ne.0) call loglyr(jnatph(iogrp),1.,0.) - if (LVL_NATPH(iogrp).ne.0) call loglvl(jlvlnatph(iogrp),rnacc,0.) -#endif -c -c --- Store 2d fields - call wrtsrf(jkwco2(iogrp),SRF_KWCO2(iogrp),rnacc,0.,cmpflg, - . 'kwco2',' ',' ',' ') - call wrtsrf(jpco2(iogrp),SRF_PCO2(iogrp),rnacc,0.,cmpflg, - . 'pco2','Surface PCO2',' ','uatm') - call wrtsrf(jdmsflux(iogrp),SRF_DMSFLUX(iogrp),rnacc*1e3/dtbgc,0., - . cmpflg,'dmsflux','DMS flux',' ','mol DMS m-2 s-1') - call wrtsrf(jco2fxd(iogrp),SRF_CO2FXD(iogrp),rnacc*12./dtbgc,0., - . cmpflg,'co2fxd','Downward CO2 flux',' ','kg C m-2 s-1') - call wrtsrf(jco2fxu(iogrp),SRF_CO2FXU(iogrp),rnacc*12./dtbgc,0., - . cmpflg,'co2fxu','Upward CO2 flux',' ','kg C m-2 s-1') - call wrtsrf(joxflux(iogrp),SRF_OXFLUX(iogrp),rnacc*1e3/dtbgc,0., - . cmpflg,'fgo2','Oxygen flux',' ','mol O2 m-2 s-1') - call wrtsrf(jniflux(iogrp),SRF_NIFLUX(iogrp),rnacc*1e3/dtbgc,0., - . cmpflg,'fgn2','Nitrogen flux',' ','mol N2 m-2 s-1') - call wrtsrf(jdms(iogrp),SRF_DMS(iogrp),rnacc,0.,cmpflg, - . 'dms','DMS',' ','kmol DMS m-3') - call wrtsrf(jdmsprod(iogrp),SRF_DMSPROD(iogrp),rnacc*1e3/dtbgc,0., - . cmpflg,'dmsprod','DMS production from phytoplankton production', - . ' ','mol DMS m-2 s-1') - call wrtsrf(jdms_bac(iogrp),SRF_DMS_BAC(iogrp),rnacc*1e3/dtbgc,0., - . cmpflg,'dms_bac','DMS bacterial consumption',' ', - . 'mol DMS m-2 s-1') - call wrtsrf(jdms_uv(iogrp),SRF_DMS_UV(iogrp),rnacc*1e3/dtbgc,0., - . cmpflg,'dms_uv','DMS photolysis reduction',' ','mol DMS m-2 s-1') - call wrtsrf(jexport(iogrp),SRF_EXPORT(iogrp),rnacc*1e3/dtbgc,0., - . cmpflg,'epc100','Export production',' ','mol C m-2 s-1') - call wrtsrf(jexposi(iogrp),SRF_EXPOSI(iogrp),rnacc*1e3/dtbgc,0., - . cmpflg,'epsi100','Si export production',' ','mol Si m-2 s-1') - call wrtsrf(jexpoca(iogrp),SRF_EXPOCA(iogrp),rnacc*1e3/dtbgc,0., - . cmpflg,'epcalc100','Ca export production',' ','mol Ca m-2 s-1') - call wrtsrf(jsrfdic(iogrp),SRF_DIC(iogrp), - . rnacc*1e3,0.,cmpflg,'srfdissic', - . 'Surface dissolved inorganic carbon',' ','mol C m-3') - call wrtsrf(jsrfalkali(iogrp),SRF_ALKALI(iogrp), - . rnacc*1e3,0.,cmpflg,'srftalk', - . 'Surface alkalinity',' ','eq m-3') - call wrtsrf(jsrfphosph(iogrp),SRF_PHOSPH(iogrp), - . rnacc*1e3,0.,cmpflg,'srfpo4', - . 'Surface phosphorus',' ','mol P m-3') - call wrtsrf(jsrfoxygen(iogrp),SRF_OXYGEN(iogrp), - . rnacc*1e3,0.,cmpflg,'srfo2', - . 'Surface oxygen',' ','mol O2 m-3') - call wrtsrf(jsrfano3(iogrp),SRF_ANO3(iogrp), - . rnacc*1e3,0.,cmpflg,'srfno3', - . 'Surface nitrate',' ','mol N m-3') - call wrtsrf(jsrfsilica(iogrp),SRF_SILICA(iogrp), - . rnacc*1e3,0.,cmpflg,'srfsi', - . 'Surface silicate',' ','mol Si m-3') - call wrtsrf(jsrfiron(iogrp),SRF_IRON(iogrp), - . rnacc*1e3,0.,cmpflg,'srfdfe', - . 'Surface dissolved iron',' ','mol Fe m-3') - call wrtsrf(jsrfphyto(iogrp),SRF_PHYTO(iogrp), - . rnacc*1e3,0.,cmpflg,'srfphyc', - . 'Surface phytoplankton',' ','mol P m-3') - call wrtsrf(jintphosy(iogrp),INT_PHOSY(iogrp), - . rnacc*1e3/dtbgc,0.,cmpflg,'ppint', - . 'Integrated primary production',' ','mol C m-2 s-1') - call wrtsrf(jintnfix(iogrp),INT_NFIX(iogrp), - . rnacc*1e3/dtbgc,0.,cmpflg,'nfixint', - . 'Integrated nitrogen fixation',' ','mol N m-2 s-1') - call wrtsrf(jintdnit(iogrp),INT_DNIT(iogrp), - . rnacc*1e3/dtbgc,0.,cmpflg,'dnitint', - . 'Integrated denitrification',' ','mol N m-2 s-1') - call wrtsrf(jcarflx0100(iogrp),FLX_CAR0100(iogrp), - . rnacc*1e3/dtbgc,0.,cmpflg,'carflx0100', - . 'C flux at 100m',' ','mol C m-2 s-1') - call wrtsrf(jcarflx0500(iogrp),FLX_CAR0500(iogrp), - . rnacc*1e3/dtbgc,0.,cmpflg,'carflx0500', - . 'C flux at 500m',' ','mol C m-2 s-1') - call wrtsrf(jcarflx1000(iogrp),FLX_CAR1000(iogrp), - . rnacc*1e3/dtbgc,0.,cmpflg,'carflx1000', - . 'C flux at 1000m',' ','mol C m-2 s-1') - call wrtsrf(jcarflx2000(iogrp),FLX_CAR2000(iogrp), - . rnacc*1e3/dtbgc,0.,cmpflg,'carflx2000', - . 'C flux at 2000m',' ','mol C m-2 s-1') - call wrtsrf(jcarflx4000(iogrp),FLX_CAR4000(iogrp), - . rnacc*1e3/dtbgc,0.,cmpflg,'carflx4000', - . 'C flux at 4000m',' ','mol C m-2 s-1') - call wrtsrf(jcarflx_bot(iogrp),FLX_CAR_BOT(iogrp), - . rnacc*1e3/dtbgc,0.,cmpflg,'carflx_bot', - . 'C flux to sediment',' ','mol C m-2 s-1') - call wrtsrf(jbsiflx0100(iogrp),FLX_BSI0100(iogrp), - . rnacc*1e3/dtbgc,0.,cmpflg,'bsiflx0100', - . 'Opal flux at 100m',' ','mol Si m-2 s-1') - call wrtsrf(jbsiflx0500(iogrp),FLX_BSI0500(iogrp), - . rnacc*1e3/dtbgc,0.,cmpflg,'bsiflx0500', - . 'Opal flux at 500m',' ','mol Si m-2 s-1') - call wrtsrf(jbsiflx1000(iogrp),FLX_BSI1000(iogrp), - . rnacc*1e3/dtbgc,0.,cmpflg,'bsiflx1000', - . 'Opal flux at 1000m',' ','mol Si m-2 s-1') - call wrtsrf(jbsiflx2000(iogrp),FLX_BSI2000(iogrp), - . rnacc*1e3/dtbgc,0.,cmpflg,'bsiflx2000', - . 'Opal flux at 2000m',' ','mol Si m-2 s-1') - call wrtsrf(jbsiflx4000(iogrp),FLX_BSI4000(iogrp), - . rnacc*1e3/dtbgc,0.,cmpflg,'bsiflx4000', - . 'Opal flux at 4000m',' ','mol Si m-2 s-1') - call wrtsrf(jbsiflx_bot(iogrp),FLX_BSI_BOT(iogrp), - . rnacc*1e3/dtbgc,0.,cmpflg,'bsiflx_bot', - . 'Opal flux to sediment',' ','mol Si m-2 s-1') - call wrtsrf(jcalflx0100(iogrp),FLX_CAL0100(iogrp), - . rnacc*1e3/dtbgc,0.,cmpflg,'calflx0100', - . 'CaCO3 flux at 100m',' ','mol Ca m-2 s-1') - call wrtsrf(jcalflx0500(iogrp),FLX_CAL0500(iogrp), - . rnacc*1e3/dtbgc,0.,cmpflg,'calflx0500', - . 'CaCO3 flux at 500m',' ','mol Ca m-2 s-1') - call wrtsrf(jcalflx1000(iogrp),FLX_CAL1000(iogrp), - . rnacc*1e3/dtbgc,0.,cmpflg,'calflx1000', - . 'CaCO3 flux at 1000m',' ','mol Ca m-2 s-1') - call wrtsrf(jcalflx2000(iogrp),FLX_CAL2000(iogrp), - . rnacc*1e3/dtbgc,0.,cmpflg,'calflx2000', - . 'CaCO3 flux at 2000m',' ','mol Ca m-2 s-1') - call wrtsrf(jcalflx4000(iogrp),FLX_CAL4000(iogrp), - . rnacc*1e3/dtbgc,0.,cmpflg,'calflx4000', - . 'CaCO3 flux at 4000m',' ','mol Ca m-2 s-1') - call wrtsrf(jcalflx_bot(iogrp),FLX_CAL_BOT(iogrp), - . rnacc*1e3/dtbgc,0.,cmpflg,'calflx_bot', - . 'CaCO3 flux to sediment',' ','mol Ca m-2 s-1') + if (LYR_NATPH(iogrp).ne.0) call loglyr(jnatph(iogrp),1.,0.) + if (LVL_NATPH(iogrp).ne.0) call loglvl(jlvlnatph(iogrp),rnacc,0.) +#endif + + ! --- Store 2d fields + call wrtsrf(jkwco2(iogrp),SRF_KWCO2(iogrp),rnacc,0.,cmpflg, & + & 'kwco2',' ',' ',' ') + call wrtsrf(jpco2(iogrp),SRF_PCO2(iogrp),rnacc,0.,cmpflg, & + & 'pco2','Surface PCO2',' ','uatm') + call wrtsrf(jdmsflux(iogrp),SRF_DMSFLUX(iogrp),rnacc*1e3/dtbgc,0., & + & cmpflg,'dmsflux','DMS flux',' ','mol DMS m-2 s-1') + call wrtsrf(jco2fxd(iogrp),SRF_CO2FXD(iogrp),rnacc*12./dtbgc,0., & + & cmpflg,'co2fxd','Downward CO2 flux',' ','kg C m-2 s-1') + call wrtsrf(jco2fxu(iogrp),SRF_CO2FXU(iogrp),rnacc*12./dtbgc,0., & + & cmpflg,'co2fxu','Upward CO2 flux',' ','kg C m-2 s-1') + call wrtsrf(joxflux(iogrp),SRF_OXFLUX(iogrp),rnacc*1e3/dtbgc,0., & + & cmpflg,'fgo2','Oxygen flux',' ','mol O2 m-2 s-1') + call wrtsrf(jniflux(iogrp),SRF_NIFLUX(iogrp),rnacc*1e3/dtbgc,0., & + & cmpflg,'fgn2','Nitrogen flux',' ','mol N2 m-2 s-1') + call wrtsrf(jdms(iogrp),SRF_DMS(iogrp),rnacc,0.,cmpflg, & + & 'dms','DMS',' ','kmol DMS m-3') + call wrtsrf(jdmsprod(iogrp),SRF_DMSPROD(iogrp),rnacc*1e3/dtbgc,0., & + & cmpflg,'dmsprod','DMS production from phytoplankton production', & + & ' ','mol DMS m-2 s-1') + call wrtsrf(jdms_bac(iogrp),SRF_DMS_BAC(iogrp),rnacc*1e3/dtbgc,0., & + & cmpflg,'dms_bac','DMS bacterial consumption',' ', & + & 'mol DMS m-2 s-1') + call wrtsrf(jdms_uv(iogrp),SRF_DMS_UV(iogrp),rnacc*1e3/dtbgc,0., & + & cmpflg,'dms_uv','DMS photolysis reduction',' ','mol DMS m-2 s-1') + call wrtsrf(jexport(iogrp),SRF_EXPORT(iogrp),rnacc*1e3/dtbgc,0., & + & cmpflg,'epc100','Export production',' ','mol C m-2 s-1') + call wrtsrf(jexposi(iogrp),SRF_EXPOSI(iogrp),rnacc*1e3/dtbgc,0., & + & cmpflg,'epsi100','Si export production',' ','mol Si m-2 s-1') + call wrtsrf(jexpoca(iogrp),SRF_EXPOCA(iogrp),rnacc*1e3/dtbgc,0., & + & cmpflg,'epcalc100','Ca export production',' ','mol Ca m-2 s-1') + call wrtsrf(jsrfdic(iogrp),SRF_DIC(iogrp), & + & rnacc*1e3,0.,cmpflg,'srfdissic', & + & 'Surface dissolved inorganic carbon',' ','mol C m-3') + call wrtsrf(jsrfalkali(iogrp),SRF_ALKALI(iogrp), & + & rnacc*1e3,0.,cmpflg,'srftalk', & + & 'Surface alkalinity',' ','eq m-3') + call wrtsrf(jsrfphosph(iogrp),SRF_PHOSPH(iogrp), & + & rnacc*1e3,0.,cmpflg,'srfpo4', & + & 'Surface phosphorus',' ','mol P m-3') + call wrtsrf(jsrfoxygen(iogrp),SRF_OXYGEN(iogrp), & + & rnacc*1e3,0.,cmpflg,'srfo2', & + & 'Surface oxygen',' ','mol O2 m-3') + call wrtsrf(jsrfano3(iogrp),SRF_ANO3(iogrp), & + & rnacc*1e3,0.,cmpflg,'srfno3', & + & 'Surface nitrate',' ','mol N m-3') + call wrtsrf(jsrfsilica(iogrp),SRF_SILICA(iogrp), & + & rnacc*1e3,0.,cmpflg,'srfsi', & + & 'Surface silicate',' ','mol Si m-3') + call wrtsrf(jsrfiron(iogrp),SRF_IRON(iogrp), & + & rnacc*1e3,0.,cmpflg,'srfdfe', & + & 'Surface dissolved iron',' ','mol Fe m-3') + call wrtsrf(jsrfphyto(iogrp),SRF_PHYTO(iogrp), & + & rnacc*1e3,0.,cmpflg,'srfphyc', & + & 'Surface phytoplankton',' ','mol P m-3') + call wrtsrf(jintphosy(iogrp),INT_PHOSY(iogrp), & + & rnacc*1e3/dtbgc,0.,cmpflg,'ppint', & + & 'Integrated primary production',' ','mol C m-2 s-1') + call wrtsrf(jintnfix(iogrp),INT_NFIX(iogrp), & + & rnacc*1e3/dtbgc,0.,cmpflg,'nfixint', & + & 'Integrated nitrogen fixation',' ','mol N m-2 s-1') + call wrtsrf(jintdnit(iogrp),INT_DNIT(iogrp), & + & rnacc*1e3/dtbgc,0.,cmpflg,'dnitint', & + & 'Integrated denitrification',' ','mol N m-2 s-1') + call wrtsrf(jcarflx0100(iogrp),FLX_CAR0100(iogrp), & + & rnacc*1e3/dtbgc,0.,cmpflg,'carflx0100', & + & 'C flux at 100m',' ','mol C m-2 s-1') + call wrtsrf(jcarflx0500(iogrp),FLX_CAR0500(iogrp), & + & rnacc*1e3/dtbgc,0.,cmpflg,'carflx0500', & + & 'C flux at 500m',' ','mol C m-2 s-1') + call wrtsrf(jcarflx1000(iogrp),FLX_CAR1000(iogrp), & + & rnacc*1e3/dtbgc,0.,cmpflg,'carflx1000', & + & 'C flux at 1000m',' ','mol C m-2 s-1') + call wrtsrf(jcarflx2000(iogrp),FLX_CAR2000(iogrp), & + & rnacc*1e3/dtbgc,0.,cmpflg,'carflx2000', & + & 'C flux at 2000m',' ','mol C m-2 s-1') + call wrtsrf(jcarflx4000(iogrp),FLX_CAR4000(iogrp), & + & rnacc*1e3/dtbgc,0.,cmpflg,'carflx4000', & + & 'C flux at 4000m',' ','mol C m-2 s-1') + call wrtsrf(jcarflx_bot(iogrp),FLX_CAR_BOT(iogrp), & + & rnacc*1e3/dtbgc,0.,cmpflg,'carflx_bot', & + & 'C flux to sediment',' ','mol C m-2 s-1') + call wrtsrf(jbsiflx0100(iogrp),FLX_BSI0100(iogrp), & + & rnacc*1e3/dtbgc,0.,cmpflg,'bsiflx0100', & + & 'Opal flux at 100m',' ','mol Si m-2 s-1') + call wrtsrf(jbsiflx0500(iogrp),FLX_BSI0500(iogrp), & + & rnacc*1e3/dtbgc,0.,cmpflg,'bsiflx0500', & + & 'Opal flux at 500m',' ','mol Si m-2 s-1') + call wrtsrf(jbsiflx1000(iogrp),FLX_BSI1000(iogrp), & + & rnacc*1e3/dtbgc,0.,cmpflg,'bsiflx1000', & + & 'Opal flux at 1000m',' ','mol Si m-2 s-1') + call wrtsrf(jbsiflx2000(iogrp),FLX_BSI2000(iogrp), & + & rnacc*1e3/dtbgc,0.,cmpflg,'bsiflx2000', & + & 'Opal flux at 2000m',' ','mol Si m-2 s-1') + call wrtsrf(jbsiflx4000(iogrp),FLX_BSI4000(iogrp), & + & rnacc*1e3/dtbgc,0.,cmpflg,'bsiflx4000', & + & 'Opal flux at 4000m',' ','mol Si m-2 s-1') + call wrtsrf(jbsiflx_bot(iogrp),FLX_BSI_BOT(iogrp), & + & rnacc*1e3/dtbgc,0.,cmpflg,'bsiflx_bot', & + & 'Opal flux to sediment',' ','mol Si m-2 s-1') + call wrtsrf(jcalflx0100(iogrp),FLX_CAL0100(iogrp), & + & rnacc*1e3/dtbgc,0.,cmpflg,'calflx0100', & + & 'CaCO3 flux at 100m',' ','mol Ca m-2 s-1') + call wrtsrf(jcalflx0500(iogrp),FLX_CAL0500(iogrp), & + & rnacc*1e3/dtbgc,0.,cmpflg,'calflx0500', & + & 'CaCO3 flux at 500m',' ','mol Ca m-2 s-1') + call wrtsrf(jcalflx1000(iogrp),FLX_CAL1000(iogrp), & + & rnacc*1e3/dtbgc,0.,cmpflg,'calflx1000', & + & 'CaCO3 flux at 1000m',' ','mol Ca m-2 s-1') + call wrtsrf(jcalflx2000(iogrp),FLX_CAL2000(iogrp), & + & rnacc*1e3/dtbgc,0.,cmpflg,'calflx2000', & + & 'CaCO3 flux at 2000m',' ','mol Ca m-2 s-1') + call wrtsrf(jcalflx4000(iogrp),FLX_CAL4000(iogrp), & + & rnacc*1e3/dtbgc,0.,cmpflg,'calflx4000', & + & 'CaCO3 flux at 4000m',' ','mol Ca m-2 s-1') + call wrtsrf(jcalflx_bot(iogrp),FLX_CAL_BOT(iogrp), & + & rnacc*1e3/dtbgc,0.,cmpflg,'calflx_bot', & + & 'CaCO3 flux to sediment',' ','mol Ca m-2 s-1') #ifndef sedbypass - call wrtsrf(jsediffic(iogrp),FLX_SEDIFFIC(iogrp), - . rnacc*1e3/dtbgc,0.,cmpflg,'sedfdic',' ',' ',' ') - call wrtsrf(jsediffal(iogrp),FLX_SEDIFFAL(iogrp), - . rnacc*1e3/dtbgc,0.,cmpflg,'sedfalk',' ',' ',' ') - call wrtsrf(jsediffph(iogrp),FLX_SEDIFFPH(iogrp), - . rnacc*1e3/dtbgc,0.,cmpflg,'sedfpho',' ',' ',' ') - call wrtsrf(jsediffox(iogrp),FLX_SEDIFFOX(iogrp), - . rnacc*1e3/dtbgc,0.,cmpflg,'sedfox',' ',' ',' ') - call wrtsrf(jsediffn2(iogrp),FLX_SEDIFFN2(iogrp), - . rnacc*1e3/dtbgc,0.,cmpflg,'sedfn2',' ',' ',' ') - call wrtsrf(jsediffno3(iogrp),FLX_SEDIFFNO3(iogrp), - . rnacc*1e3/dtbgc,0.,cmpflg,'sedfno3',' ',' ',' ') - call wrtsrf(jsediffsi(iogrp),FLX_SEDIFFSI(iogrp), - . rnacc*1e3/dtbgc,0.,cmpflg,'sedfsi',' ',' ',' ') -#endif - call wrtsrf(jn2ofx(iogrp),SRF_N2OFX(iogrp),rnacc*1e3/dtbgc,0., - . cmpflg,'n2oflux','N2O flux',' ','mol N2O m-2 s-1') + call wrtsrf(jsediffic(iogrp),FLX_SEDIFFIC(iogrp), & + & rnacc*1e3/dtbgc,0.,cmpflg,'sedfdic',' ',' ',' ') + call wrtsrf(jsediffal(iogrp),FLX_SEDIFFAL(iogrp), & + & rnacc*1e3/dtbgc,0.,cmpflg,'sedfalk',' ',' ',' ') + call wrtsrf(jsediffph(iogrp),FLX_SEDIFFPH(iogrp), & + & rnacc*1e3/dtbgc,0.,cmpflg,'sedfpho',' ',' ',' ') + call wrtsrf(jsediffox(iogrp),FLX_SEDIFFOX(iogrp), & + & rnacc*1e3/dtbgc,0.,cmpflg,'sedfox',' ',' ',' ') + call wrtsrf(jsediffn2(iogrp),FLX_SEDIFFN2(iogrp), & + & rnacc*1e3/dtbgc,0.,cmpflg,'sedfn2',' ',' ',' ') + call wrtsrf(jsediffno3(iogrp),FLX_SEDIFFNO3(iogrp), & + & rnacc*1e3/dtbgc,0.,cmpflg,'sedfno3',' ',' ',' ') + call wrtsrf(jsediffsi(iogrp),FLX_SEDIFFSI(iogrp), & + & rnacc*1e3/dtbgc,0.,cmpflg,'sedfsi',' ',' ',' ') +#endif + call wrtsrf(jn2ofx(iogrp),SRF_N2OFX(iogrp),rnacc*1e3/dtbgc,0., & + & cmpflg,'n2oflux','N2O flux',' ','mol N2O m-2 s-1') #ifdef cisonew - call wrtsrf(jco213fxd(iogrp),SRF_CO213FXD(iogrp), - . rnacc*12./dtbgc,0.,cmpflg,'co213fxd', - . 'Downward 13CO2 flux',' ','kg C m-2 s-1') - call wrtsrf(jco213fxu(iogrp),SRF_CO213FXU(iogrp), - . rnacc*12./dtbgc,0.,cmpflg,'co213fxu', - . 'Upward 13CO2 flux',' ','kg C m-2 s-1') - call wrtsrf(jco214fxd(iogrp),SRF_CO214FXD(iogrp), - . rnacc*12.*c14fac/dtbgc,0.,cmpflg,'co214fxd', - . 'Downward 14CO2 flux',' ','kg C m-2 s-1') - call wrtsrf(jco214fxu(iogrp),SRF_CO214FXU(iogrp), - . rnacc*12.*c14fac/dtbgc,0.,cmpflg,'co214fxu', - . 'Upward 14CO2 flux',' ','kg C m-2 s-1') + call wrtsrf(jco213fxd(iogrp),SRF_CO213FXD(iogrp), & + & rnacc*12./dtbgc,0.,cmpflg,'co213fxd', & + & 'Downward 13CO2 flux',' ','kg C m-2 s-1') + call wrtsrf(jco213fxu(iogrp),SRF_CO213FXU(iogrp), & + & rnacc*12./dtbgc,0.,cmpflg,'co213fxu', & + & 'Upward 13CO2 flux',' ','kg C m-2 s-1') + call wrtsrf(jco214fxd(iogrp),SRF_CO214FXD(iogrp), & + & rnacc*12.*c14fac/dtbgc,0.,cmpflg,'co214fxd', & + & 'Downward 14CO2 flux',' ','kg C m-2 s-1') + call wrtsrf(jco214fxu(iogrp),SRF_CO214FXU(iogrp), & + & rnacc*12.*c14fac/dtbgc,0.,cmpflg,'co214fxu', & + & 'Upward 14CO2 flux',' ','kg C m-2 s-1') #endif #ifdef CFC - call wrtsrf(jcfc11fx(iogrp),SRF_CFC11(iogrp),rnacc*1e3/dtbgc,0., - . cmpflg,'cfc11flux','CFC-11 flux',' ','mol CFC12 m-2 s-1') - call wrtsrf(jcfc12fx(iogrp),SRF_CFC12(iogrp),rnacc*1e3/dtbgc,0., - . cmpflg,'cfc12flux','CFC-12 flux',' ','mol CFC12 m-2 s-1') - call wrtsrf(jsf6fx(iogrp),SRF_SF6(iogrp),rnacc*1e3/dtbgc,0., - . cmpflg,'sf6flux','SF-6 flux',' ','mol SF6 m-2 s-1') + call wrtsrf(jcfc11fx(iogrp),SRF_CFC11(iogrp),rnacc*1e3/dtbgc,0., & + & cmpflg,'cfc11flux','CFC-11 flux',' ','mol CFC12 m-2 s-1') + call wrtsrf(jcfc12fx(iogrp),SRF_CFC12(iogrp),rnacc*1e3/dtbgc,0., & + & cmpflg,'cfc12flux','CFC-12 flux',' ','mol CFC12 m-2 s-1') + call wrtsrf(jsf6fx(iogrp),SRF_SF6(iogrp),rnacc*1e3/dtbgc,0., & + & cmpflg,'sf6flux','SF-6 flux',' ','mol SF6 m-2 s-1') #endif #ifdef natDIC - call wrtsrf(jsrfnatdic(iogrp),SRF_NATDIC(iogrp), - . rnacc*1e3,0.,cmpflg,'srfnatdissic', - . 'Surface natural dissolved inorganic carbon',' ','mol C m-3') - call wrtsrf(jsrfnatalk(iogrp),SRF_NATALKALI(iogrp), - . rnacc*1e3,0.,cmpflg,'srfnattalk', - . 'Surface natural alkalinity',' ','eq m-3') - call wrtsrf(jnatpco2(iogrp),SRF_NATPCO2(iogrp),rnacc,0.,cmpflg, - . 'natpco2','Surface natural PCO2',' ','uatm') - call wrtsrf(jnatco2fx(iogrp),SRF_NATCO2FX(iogrp), - . rnacc*12./dtbgc,0.,cmpflg,'natco2fx', - . 'Natural CO2 flux',' ','kg C m-2 s-1') + call wrtsrf(jsrfnatdic(iogrp),SRF_NATDIC(iogrp), & + & rnacc*1e3,0.,cmpflg,'srfnatdissic', & + & 'Surface natural dissolved inorganic carbon',' ','mol C m-3') + call wrtsrf(jsrfnatalk(iogrp),SRF_NATALKALI(iogrp), & + & rnacc*1e3,0.,cmpflg,'srfnattalk', & + & 'Surface natural alkalinity',' ','eq m-3') + call wrtsrf(jnatpco2(iogrp),SRF_NATPCO2(iogrp),rnacc,0.,cmpflg, & + & 'natpco2','Surface natural PCO2',' ','uatm') + call wrtsrf(jnatco2fx(iogrp),SRF_NATCO2FX(iogrp), & + & rnacc*12./dtbgc,0.,cmpflg,'natco2fx', & + & 'Natural CO2 flux',' ','kg C m-2 s-1') #endif #ifdef BROMO - call wrtsrf(jbromofx(iogrp),SRF_BROMOFX(iogrp),rnacc*1e3/dtbgc, - . 0.,cmpflg,'bromofx','Bromoform flux',' ','mol CHBr3 m-2 s-1') - call wrtsrf(jsrfbromo(iogrp),SRF_BROMO(iogrp),rnacc*1e3,0., - . cmpflg,'srfbromo','Surface bromoform',' ','mol CHBr3 m-3') - call wrtsrf(jbromo_prod(iogrp),INT_BROMOPRO(iogrp), - . rnacc*1e3/dtbgc,0.,cmpflg,'intbromoprod', - . 'Integrated bromoform production',' ','mol CHBr3 m-2 s-1') - call wrtsrf(jbromo_uv(iogrp),INT_BROMOUV(iogrp), - . rnacc*1e3/dtbgc,0.,cmpflg,'intbromouv', - . 'Integrated bromoform loss to photolysis',' ', - . 'mol CHBr3 m-2 s-1') - call wrtsrf(jatmbromo(iogrp),SRF_ATMBROMO(iogrp),rnacc,0., - . cmpflg,'atmbromo','Atmospheric bromoform',' ','ppt') + call wrtsrf(jbromofx(iogrp),SRF_BROMOFX(iogrp),rnacc*1e3/dtbgc, & + & 0.,cmpflg,'bromofx','Bromoform flux',' ','mol CHBr3 m-2 s-1') + call wrtsrf(jsrfbromo(iogrp),SRF_BROMO(iogrp),rnacc*1e3,0., & + & cmpflg,'srfbromo','Surface bromoform',' ','mol CHBr3 m-3') + call wrtsrf(jbromo_prod(iogrp),INT_BROMOPRO(iogrp), & + & rnacc*1e3/dtbgc,0.,cmpflg,'intbromoprod', & + & 'Integrated bromoform production',' ','mol CHBr3 m-2 s-1') + call wrtsrf(jbromo_uv(iogrp),INT_BROMOUV(iogrp), & + & rnacc*1e3/dtbgc,0.,cmpflg,'intbromouv', & + & 'Integrated bromoform loss to photolysis',' ', & + & 'mol CHBr3 m-2 s-1') + call wrtsrf(jatmbromo(iogrp),SRF_ATMBROMO(iogrp),rnacc,0., & + & cmpflg,'atmbromo','Atmospheric bromoform',' ','ppt') #endif - call wrtsrf(jatmco2(iogrp),SRF_ATMCO2(iogrp),rnacc,0.,cmpflg, - . 'atmco2','Atmospheric CO2',' ','ppm') + call wrtsrf(jatmco2(iogrp),SRF_ATMCO2(iogrp),rnacc,0.,cmpflg, & + & 'atmco2','Atmospheric CO2',' ','ppm') #if defined(BOXATM) - call wrtsrf(jatmo2(iogrp),SRF_ATMO2(iogrp),rnacc,0.,cmpflg, - . 'atmo2','Atmospheric O2',' ','ppm') - call wrtsrf(jatmn2(iogrp),SRF_ATMN2(iogrp),rnacc,0.,cmpflg, - . 'atmn2','Atmospheric N2',' ','ppm') + call wrtsrf(jatmo2(iogrp),SRF_ATMO2(iogrp),rnacc,0.,cmpflg, & + & 'atmo2','Atmospheric O2',' ','ppm') + call wrtsrf(jatmn2(iogrp),SRF_ATMN2(iogrp),rnacc,0.,cmpflg, & + & 'atmn2','Atmospheric N2',' ','ppm') #endif #ifdef cisonew - call wrtsrf(jatmc13(iogrp),SRF_ATMC13(iogrp),rnacc,0.,cmpflg, - . 'atmc13','Atmospheric 13CO2',' ','ppm') - call wrtsrf(jatmc14(iogrp),SRF_ATMC14(iogrp),rnacc,0.,cmpflg, - . 'atmc14','Atmospheric 14CO2',' ','ppm') -#endif -c -c --- Store 3d layer fields - call wrtlyr(jdp(iogrp),LYR_DP(iogrp),rnacc,0.,cmpflg, - . 'pddpo','Layer thickness',' ','m') - call wrtlyr(jdic(iogrp),LYR_DIC(iogrp),1e3,0.,cmpflg, - . 'dissic','Dissolved inorganic carbon',' ','mol C m-3') - call wrtlyr(jalkali(iogrp),LYR_ALKALI(iogrp),1e3,0.,cmpflg, - . 'talk','Alkalinity',' ','eq m-3') - call wrtlyr(jphosph(iogrp),LYR_PHOSPH(iogrp),1e3,0.,cmpflg, - . 'po4','Phosphorus',' ','mol P m-3') - call wrtlyr(joxygen(iogrp),LYR_OXYGEN(iogrp),1e3,0.,cmpflg, - . 'o2','Oxygen',' ','mol O2 m-3') - call wrtlyr(jano3(iogrp),LYR_ANO3(iogrp),1e3,0.,cmpflg, - . 'no3','Nitrate',' ','mol N m-3') - call wrtlyr(jsilica(iogrp),LYR_SILICA(iogrp),1e3,0.,cmpflg, - . 'si','Silicate',' ','mol Si m-3') - call wrtlyr(jdoc(iogrp),LYR_DOC(iogrp),1e3,0.,cmpflg, - . 'dissoc','Dissolved organic carbon',' ','mol P m-3') - call wrtlyr(jphyto(iogrp),LYR_PHYTO(iogrp),1e3,0.,cmpflg, - . 'phyc','Phytoplankton',' ','mol P m-3') - call wrtlyr(jgrazer(iogrp),LYR_GRAZER(iogrp),1e3,0.,cmpflg, - . 'zooc','Zooplankton',' ','mol P m-3') - call wrtlyr(jpoc(iogrp),LYR_POC(iogrp),1e3,0.,cmpflg, - . 'detoc','Detritus',' ','mol P m-3') - call wrtlyr(jcalc(iogrp),LYR_CALC(iogrp),1e3,0.,cmpflg, - . 'calc','CaCO3 shells',' ','mol C m-3') - call wrtlyr(jopal(iogrp),LYR_OPAL(iogrp),1e3,0.,cmpflg, - . 'opal','Opal shells',' ','mol Si m-3') - call wrtlyr(jiron(iogrp),LYR_IRON(iogrp),1e3,0.,cmpflg, - . 'dfe','Dissolved iron',' ','mol Fe m-3') - call wrtlyr(jphosy(iogrp),LYR_PHOSY(iogrp),1e3/dtbgc,0.,cmpflg, - . 'pp','Primary production',' ','mol C m-3 s-1') - call wrtlyr(jco3(iogrp),LYR_CO3(iogrp),1e3,0.,cmpflg, - . 'co3','Carbonate ions',' ','mol C m-3') - call wrtlyr(jph(iogrp),LYR_PH(iogrp),-1.,0.,cmpflg, - . 'ph','pH',' ','-log10([h+])') - call wrtlyr(jomegaa(iogrp),LYR_OMEGAA(iogrp),1.,0.,cmpflg, - . 'omegaa','OmegaA',' ','-') - call wrtlyr(jomegac(iogrp),LYR_OMEGAC(iogrp),1.,0.,cmpflg, - . 'omegac','OmegaC',' ','-') - call wrtlyr(jn2o(iogrp),LYR_N2O(iogrp),1e3,0.,cmpflg, - . 'n2o','N2O',' ','mol N2O m-3') - call wrtlyr(jprefo2(iogrp),LYR_PREFO2(iogrp),1e3,0.,cmpflg, - . 'p_o2','Preformed oxygen',' ','mol O2 m-3') - call wrtlyr(jo2sat(iogrp),LYR_O2SAT(iogrp),1e3,0.,cmpflg, - . 'satoxy','Saturated oxygen',' ','mol O2 m-3') - call wrtlyr(jprefpo4(iogrp),LYR_PREFPO4(iogrp),1e3,0.,cmpflg, - . 'p_po4','Preformed phosphorus',' ','mol P m-3') - call wrtlyr(jprefalk(iogrp),LYR_PREFALK(iogrp),1e3,0.,cmpflg, - . 'p_talk','Preformed alkalinity',' ','eq m-3') - call wrtlyr(jprefdic(iogrp),LYR_PREFDIC(iogrp),1e3,0.,cmpflg, - . 'p_dic','Preformed DIC',' ','mol C m-3') - call wrtlyr(jdicsat(iogrp),LYR_DICSAT(iogrp),1e3,0.,cmpflg, - . 'sat_dic','Saturated DIC',' ','mol C m-3') + call wrtsrf(jatmc13(iogrp),SRF_ATMC13(iogrp),rnacc,0.,cmpflg, & + & 'atmc13','Atmospheric 13CO2',' ','ppm') + call wrtsrf(jatmc14(iogrp),SRF_ATMC14(iogrp),rnacc,0.,cmpflg, & + & 'atmc14','Atmospheric 14CO2',' ','ppm') +#endif + + ! --- Store 3d layer fields + call wrtlyr(jdp(iogrp),LYR_DP(iogrp),rnacc,0.,cmpflg, & + & 'pddpo','Layer thickness',' ','m') + call wrtlyr(jdic(iogrp),LYR_DIC(iogrp),1e3,0.,cmpflg, & + & 'dissic','Dissolved inorganic carbon',' ','mol C m-3') + call wrtlyr(jalkali(iogrp),LYR_ALKALI(iogrp),1e3,0.,cmpflg, & + & 'talk','Alkalinity',' ','eq m-3') + call wrtlyr(jphosph(iogrp),LYR_PHOSPH(iogrp),1e3,0.,cmpflg, & + & 'po4','Phosphorus',' ','mol P m-3') + call wrtlyr(joxygen(iogrp),LYR_OXYGEN(iogrp),1e3,0.,cmpflg, & + & 'o2','Oxygen',' ','mol O2 m-3') + call wrtlyr(jano3(iogrp),LYR_ANO3(iogrp),1e3,0.,cmpflg, & + & 'no3','Nitrate',' ','mol N m-3') + call wrtlyr(jsilica(iogrp),LYR_SILICA(iogrp),1e3,0.,cmpflg, & + & 'si','Silicate',' ','mol Si m-3') + call wrtlyr(jdoc(iogrp),LYR_DOC(iogrp),1e3,0.,cmpflg, & + & 'dissoc','Dissolved organic carbon',' ','mol P m-3') + call wrtlyr(jphyto(iogrp),LYR_PHYTO(iogrp),1e3,0.,cmpflg, & + & 'phyc','Phytoplankton',' ','mol P m-3') + call wrtlyr(jgrazer(iogrp),LYR_GRAZER(iogrp),1e3,0.,cmpflg, & + & 'zooc','Zooplankton',' ','mol P m-3') + call wrtlyr(jpoc(iogrp),LYR_POC(iogrp),1e3,0.,cmpflg, & + & 'detoc','Detritus',' ','mol P m-3') + call wrtlyr(jcalc(iogrp),LYR_CALC(iogrp),1e3,0.,cmpflg, & + & 'calc','CaCO3 shells',' ','mol C m-3') + call wrtlyr(jopal(iogrp),LYR_OPAL(iogrp),1e3,0.,cmpflg, & + & 'opal','Opal shells',' ','mol Si m-3') + call wrtlyr(jiron(iogrp),LYR_IRON(iogrp),1e3,0.,cmpflg, & + & 'dfe','Dissolved iron',' ','mol Fe m-3') + call wrtlyr(jphosy(iogrp),LYR_PHOSY(iogrp),1e3/dtbgc,0.,cmpflg, & + & 'pp','Primary production',' ','mol C m-3 s-1') + call wrtlyr(jco3(iogrp),LYR_CO3(iogrp),1e3,0.,cmpflg, & + & 'co3','Carbonate ions',' ','mol C m-3') + call wrtlyr(jph(iogrp),LYR_PH(iogrp),-1.,0.,cmpflg, & + & 'ph','pH',' ','-log10([h+])') + call wrtlyr(jomegaa(iogrp),LYR_OMEGAA(iogrp),1.,0.,cmpflg, & + & 'omegaa','OmegaA',' ','-') + call wrtlyr(jomegac(iogrp),LYR_OMEGAC(iogrp),1.,0.,cmpflg, & + & 'omegac','OmegaC',' ','-') + call wrtlyr(jn2o(iogrp),LYR_N2O(iogrp),1e3,0.,cmpflg, & + & 'n2o','N2O',' ','mol N2O m-3') + call wrtlyr(jprefo2(iogrp),LYR_PREFO2(iogrp),1e3,0.,cmpflg, & + & 'p_o2','Preformed oxygen',' ','mol O2 m-3') + call wrtlyr(jo2sat(iogrp),LYR_O2SAT(iogrp),1e3,0.,cmpflg, & + & 'satoxy','Saturated oxygen',' ','mol O2 m-3') + call wrtlyr(jprefpo4(iogrp),LYR_PREFPO4(iogrp),1e3,0.,cmpflg, & + & 'p_po4','Preformed phosphorus',' ','mol P m-3') + call wrtlyr(jprefalk(iogrp),LYR_PREFALK(iogrp),1e3,0.,cmpflg, & + & 'p_talk','Preformed alkalinity',' ','eq m-3') + call wrtlyr(jprefdic(iogrp),LYR_PREFDIC(iogrp),1e3,0.,cmpflg, & + & 'p_dic','Preformed DIC',' ','mol C m-3') + call wrtlyr(jdicsat(iogrp),LYR_DICSAT(iogrp),1e3,0.,cmpflg, & + & 'sat_dic','Saturated DIC',' ','mol C m-3') #ifdef cisonew - call wrtlyr(jdic13(iogrp),LYR_DIC13(iogrp),1.e3,0.,cmpflg, - . 'dissic13','Dissolved C13',' ','mol 13C m-3') - call wrtlyr(jdic14(iogrp),LYR_DIC14(iogrp),1.e3*c14fac,0.,cmpflg, - . 'dissic14','Dissolved C14',' ','mol 14C m-3') - call wrtlyr(jd13c(iogrp),LYR_D13C(iogrp),1.,0.,cmpflg, - . 'delta13c','delta13C of DIC',' ','permil') - call wrtlyr(jd14c(iogrp),LYR_D14C(iogrp),1.,0.,cmpflg, - . 'delta14c','delta14C of DIC',' ','permil') - call wrtlyr(jbigd14c(iogrp),LYR_BIGD14C(iogrp),1.,0.,cmpflg, - . 'bigdelta14c','big delta14C of DIC',' ','permil') - call wrtlyr(jpoc13(iogrp),LYR_POC13(iogrp),1e3,0.,cmpflg, - . 'detoc13','Detritus13',' ','mol P m-3') - call wrtlyr(jdoc13(iogrp),LYR_DOC13(iogrp),1e3,0.,cmpflg, - . 'dissoc13','Dissolved organic carbon13',' ','mol P m-3') - call wrtlyr(jcalc13(iogrp),LYR_CALC13(iogrp),1e3,0.,cmpflg, - . 'calc13','Ca13CO3 shells',' ','mol 13C m-3') - call wrtlyr(jphyto13(iogrp),LYR_PHYTO13(iogrp),1e3,0.,cmpflg, - . 'phyc13','Phytoplankton13',' ','mol P m-3') - call wrtlyr(jgrazer13(iogrp),LYR_GRAZER13(iogrp),1e3,0.,cmpflg, - . 'zooc13','Zooplankton13',' ','mol P m-3') + call wrtlyr(jdic13(iogrp),LYR_DIC13(iogrp),1.e3,0.,cmpflg, & + & 'dissic13','Dissolved C13',' ','mol 13C m-3') + call wrtlyr(jdic14(iogrp),LYR_DIC14(iogrp),1.e3*c14fac,0.,cmpflg, & + & 'dissic14','Dissolved C14',' ','mol 14C m-3') + call wrtlyr(jd13c(iogrp),LYR_D13C(iogrp),1.,0.,cmpflg, & + & 'delta13c','delta13C of DIC',' ','permil') + call wrtlyr(jd14c(iogrp),LYR_D14C(iogrp),1.,0.,cmpflg, & + & 'delta14c','delta14C of DIC',' ','permil') + call wrtlyr(jbigd14c(iogrp),LYR_BIGD14C(iogrp),1.,0.,cmpflg, & + & 'bigdelta14c','big delta14C of DIC',' ','permil') + call wrtlyr(jpoc13(iogrp),LYR_POC13(iogrp),1e3,0.,cmpflg, & + & 'detoc13','Detritus13',' ','mol P m-3') + call wrtlyr(jdoc13(iogrp),LYR_DOC13(iogrp),1e3,0.,cmpflg, & + & 'dissoc13','Dissolved organic carbon13',' ','mol P m-3') + call wrtlyr(jcalc13(iogrp),LYR_CALC13(iogrp),1e3,0.,cmpflg, & + & 'calc13','Ca13CO3 shells',' ','mol 13C m-3') + call wrtlyr(jphyto13(iogrp),LYR_PHYTO13(iogrp),1e3,0.,cmpflg, & + & 'phyc13','Phytoplankton13',' ','mol P m-3') + call wrtlyr(jgrazer13(iogrp),LYR_GRAZER13(iogrp),1e3,0.,cmpflg, & + & 'zooc13','Zooplankton13',' ','mol P m-3') #endif #ifdef AGG - call wrtlyr(jnos(iogrp),LYR_NOS(iogrp),1.,0.,cmpflg, - . 'nos','Marine snow aggregates per cm^3 sea water',' ','1/cm^3') - call wrtlyr(jwphy(iogrp),LYR_WPHY(iogrp),1.,0.,cmpflg, - . 'wphy','Av. mass sinking speed of marine snow',' ','m/day') - call wrtlyr(jwnos(iogrp),LYR_WNOS(iogrp),1.,0.,cmpflg, - . 'wnos','Av. number sinking speed of marine snow',' ','m/day') - call wrtlyr(jeps(iogrp),LYR_EPS(iogrp),1.,0.,cmpflg, - . 'eps','Av. size distribution exponent',' ','-') - call wrtlyr(jasize(iogrp),LYR_ASIZE(iogrp),1.,0.,cmpflg, - . 'asize','Av. size of marine snow aggregates',' ','nb. of cells') + call wrtlyr(jnos(iogrp),LYR_NOS(iogrp),1.,0.,cmpflg, & + & 'nos','Marine snow aggregates per cm^3 sea water',' ','1/cm^3') + call wrtlyr(jwphy(iogrp),LYR_WPHY(iogrp),1.,0.,cmpflg, & + & 'wphy','Av. mass sinking speed of marine snow',' ','m/day') + call wrtlyr(jwnos(iogrp),LYR_WNOS(iogrp),1.,0.,cmpflg, & + & 'wnos','Av. number sinking speed of marine snow',' ','m/day') + call wrtlyr(jeps(iogrp),LYR_EPS(iogrp),1.,0.,cmpflg, & + & 'eps','Av. size distribution exponent',' ','-') + call wrtlyr(jasize(iogrp),LYR_ASIZE(iogrp),1.,0.,cmpflg, & + & 'asize','Av. size of marine snow aggregates',' ','nb. of cells') #endif #ifdef CFC - call wrtlyr(jcfc11(iogrp),LYR_CFC11(iogrp),1e3,0.,cmpflg, - . 'cfc11','CFC-11',' ','mol cfc11 m-3') - call wrtlyr(jcfc12(iogrp),LYR_CFC12(iogrp),1e3,0.,cmpflg, - . 'cfc12','CFC-12',' ','mol cfc12 m-3') - call wrtlyr(jsf6(iogrp),LYR_SF6(iogrp),1e3,0.,cmpflg, - . 'sf6','SF-6',' ','mol sf6 m-3') + call wrtlyr(jcfc11(iogrp),LYR_CFC11(iogrp),1e3,0.,cmpflg, & + & 'cfc11','CFC-11',' ','mol cfc11 m-3') + call wrtlyr(jcfc12(iogrp),LYR_CFC12(iogrp),1e3,0.,cmpflg, & + & 'cfc12','CFC-12',' ','mol cfc12 m-3') + call wrtlyr(jsf6(iogrp),LYR_SF6(iogrp),1e3,0.,cmpflg, & + & 'sf6','SF-6',' ','mol sf6 m-3') #endif #ifdef natDIC - call wrtlyr(jnatco3(iogrp),LYR_NATCO3(iogrp),1e3,0.,cmpflg, - . 'natco3','Natural Carbonate ions',' ','mol C m-3') - call wrtlyr(jnatalkali(iogrp),LYR_NATALKALI(iogrp),1e3,0.,cmpflg, - . 'nattalk','Natural alkalinity',' ','eq m-3') - call wrtlyr(jnatdic(iogrp),LYR_NATDIC(iogrp),1e3,0.,cmpflg, - . 'natdissic','Natural dissolved inorganic carbon',' ', - . 'mol C m-3') - call wrtlyr(jnatcalc(iogrp),LYR_NATCALC(iogrp),1e3,0.,cmpflg, - . 'natcalc','Natural CaCO3 shells',' ','mol C m-3') - call wrtlyr(jnatph(iogrp),LYR_NATPH(iogrp),-1.,0.,cmpflg, - . 'natph','Natural pH',' ','-log10([h+])') - call wrtlyr(jnatomegaa(iogrp),LYR_NATOMEGAA(iogrp),1.,0.,cmpflg, - . 'natomegaa','Natural OmegaA',' ','-') - call wrtlyr(jnatomegac(iogrp),LYR_NATOMEGAC(iogrp),1.,0.,cmpflg, - . 'natomegac','Natural OmegaC',' ','-') + call wrtlyr(jnatco3(iogrp),LYR_NATCO3(iogrp),1e3,0.,cmpflg, & + & 'natco3','Natural Carbonate ions',' ','mol C m-3') + call wrtlyr(jnatalkali(iogrp),LYR_NATALKALI(iogrp),1e3,0.,cmpflg, & + & 'nattalk','Natural alkalinity',' ','eq m-3') + call wrtlyr(jnatdic(iogrp),LYR_NATDIC(iogrp),1e3,0.,cmpflg, & + & 'natdissic','Natural dissolved inorganic carbon',' ', & + & 'mol C m-3') + call wrtlyr(jnatcalc(iogrp),LYR_NATCALC(iogrp),1e3,0.,cmpflg, & + & 'natcalc','Natural CaCO3 shells',' ','mol C m-3') + call wrtlyr(jnatph(iogrp),LYR_NATPH(iogrp),-1.,0.,cmpflg, & + & 'natph','Natural pH',' ','-log10([h+])') + call wrtlyr(jnatomegaa(iogrp),LYR_NATOMEGAA(iogrp),1.,0.,cmpflg, & + & 'natomegaa','Natural OmegaA',' ','-') + call wrtlyr(jnatomegac(iogrp),LYR_NATOMEGAC(iogrp),1.,0.,cmpflg, & + & 'natomegac','Natural OmegaC',' ','-') #endif #ifdef BROMO - call wrtlyr(jbromo(iogrp),LYR_BROMO(iogrp),1e3,0.,cmpflg, - . 'bromo','Bromoform',' ','mol CHBr3 m-3') + call wrtlyr(jbromo(iogrp),LYR_BROMO(iogrp),1e3,0.,cmpflg, & + & 'bromo','Bromoform',' ','mol CHBr3 m-3') #endif -c -c --- Store 3d level fields - call wrtlvl(jlvldic(iogrp),LVL_DIC(iogrp),rnacc*1e3,0.,cmpflg, - . 'dissiclvl','Dissolved inorganic carbon',' ','mol C m-3') - call wrtlvl(jlvlalkali(iogrp),LVL_ALKALI(iogrp),rnacc*1e3,0., - . cmpflg, 'talklvl','Alkalinity',' ','eq m-3') - call wrtlvl(jlvlphosph(iogrp),LVL_PHOSPH(iogrp),rnacc*1e3,0., - . cmpflg,'po4lvl','Phosphorus',' ','mol P m-3') - call wrtlvl(jlvloxygen(iogrp),LVL_OXYGEN(iogrp),rnacc*1e3,0., - . cmpflg,'o2lvl','Oxygen',' ','mol O2 m-3') - call wrtlvl(jlvlano3(iogrp),LVL_ANO3(iogrp),rnacc*1e3,0.,cmpflg, - . 'no3lvl','Nitrate',' ','mol N m-3') - call wrtlvl(jlvlsilica(iogrp),LVL_SILICA(iogrp),rnacc*1e3,0., - . cmpflg, 'silvl','Silicate',' ','mol Si m-3') - call wrtlvl(jlvldoc(iogrp),LVL_DOC(iogrp),rnacc*1e3,0.,cmpflg, - . 'dissoclvl','Dissolved organic carbon',' ','mol P m-3') - call wrtlvl(jlvlphyto(iogrp),LVL_PHYTO(iogrp),rnacc*1e3,0.,cmpflg, - . 'phyclvl','Phytoplankton',' ','mol P m-3') - call wrtlvl(jlvlgrazer(iogrp),LVL_GRAZER(iogrp),rnacc*1e3,0., - . cmpflg,'zooclvl','Zooplankton',' ','mol P m-3') - call wrtlvl(jlvlpoc(iogrp),LVL_POC(iogrp),rnacc*1e3,0.,cmpflg, - . 'detoclvl','Detritus',' ','mol P m-3') - call wrtlvl(jlvlcalc(iogrp),LVL_CALC(iogrp),rnacc*1e3,0.,cmpflg, - . 'calclvl','CaCO3 shells',' ','mol C m-3') - call wrtlvl(jlvlopal(iogrp),LVL_OPAL(iogrp),rnacc*1e3,0.,cmpflg, - . 'opallvl','Opal shells',' ','mol Si m-3') - call wrtlvl(jlvliron(iogrp),LVL_IRON(iogrp),rnacc*1e3,0.,cmpflg, - . 'dfelvl','Dissolved iron',' ','mol Fe m-3') - call wrtlvl(jlvlphosy(iogrp),LVL_PHOSY(iogrp),rnacc*1e3/dtbgc,0., - . cmpflg,'pplvl','Primary production',' ','mol C m-3 s-1') - call wrtlvl(jlvlco3(iogrp),LVL_CO3(iogrp),rnacc*1e3,0.,cmpflg, - . 'co3lvl','Carbonate ions',' ','mol C m-3') - call wrtlvl(jlvlph(iogrp),LVL_PH(iogrp),-1.,0.,cmpflg, - . 'phlvl','pH',' ','-log10([h+])') - call wrtlvl(jlvlomegaa(iogrp),LVL_OMEGAA(iogrp),rnacc,0.,cmpflg, - . 'omegaalvl','OmegaA',' ','-') - call wrtlvl(jlvlomegac(iogrp),LVL_OMEGAC(iogrp),rnacc,0.,cmpflg, - . 'omegaclvl','OmegaC',' ','-') - call wrtlvl(jlvln2o(iogrp),LVL_N2O(iogrp),rnacc*1e3,0.,cmpflg, - . 'n2olvl','N2O',' ','mol N2O m-3') - call wrtlvl(jlvlprefo2(iogrp),LVL_PREFO2(iogrp),rnacc*1e3,0., - . cmpflg,'p_o2lvl','Preformed oxygen',' ','mol O2 m-3') - call wrtlvl(jlvlo2sat(iogrp),LVL_O2SAT(iogrp),rnacc*1e3,0., - . cmpflg,'satoxylvl','Saturated oxygen',' ','mol O2 m-3') - call wrtlvl(jlvlprefpo4(iogrp),LVL_PREFPO4(iogrp),rnacc*1e3,0., - . cmpflg,'p_po4lvl','Preformed phosphorus',' ','mol P m-3') - call wrtlvl(jlvlprefalk(iogrp),LVL_PREFALK(iogrp),rnacc*1e3,0., - . cmpflg, 'p_talklvl','Preformed alkalinity',' ','eq m-3') - call wrtlvl(jlvlprefdic(iogrp),LVL_PREFDIC(iogrp),rnacc*1e3,0., - . cmpflg, 'p_diclvl','Preformed DIC',' ','mol C m-3') - call wrtlvl(jlvldicsat(iogrp),LVL_DICSAT(iogrp),rnacc*1e3,0., - . cmpflg, 'sat_diclvl','Saturated DIC',' ','mol C m-3') + ! --- Store 3d level fields + call wrtlvl(jlvldic(iogrp),LVL_DIC(iogrp),rnacc*1e3,0.,cmpflg, & + & 'dissiclvl','Dissolved inorganic carbon',' ','mol C m-3') + call wrtlvl(jlvlalkali(iogrp),LVL_ALKALI(iogrp),rnacc*1e3,0., & + & cmpflg, 'talklvl','Alkalinity',' ','eq m-3') + call wrtlvl(jlvlphosph(iogrp),LVL_PHOSPH(iogrp),rnacc*1e3,0., & + & cmpflg,'po4lvl','Phosphorus',' ','mol P m-3') + call wrtlvl(jlvloxygen(iogrp),LVL_OXYGEN(iogrp),rnacc*1e3,0., & + & cmpflg,'o2lvl','Oxygen',' ','mol O2 m-3') + call wrtlvl(jlvlano3(iogrp),LVL_ANO3(iogrp),rnacc*1e3,0.,cmpflg, & + & 'no3lvl','Nitrate',' ','mol N m-3') + call wrtlvl(jlvlsilica(iogrp),LVL_SILICA(iogrp),rnacc*1e3,0., & + & cmpflg, 'silvl','Silicate',' ','mol Si m-3') + call wrtlvl(jlvldoc(iogrp),LVL_DOC(iogrp),rnacc*1e3,0.,cmpflg, & + & 'dissoclvl','Dissolved organic carbon',' ','mol P m-3') + call wrtlvl(jlvlphyto(iogrp),LVL_PHYTO(iogrp),rnacc*1e3,0.,cmpflg, & + & 'phyclvl','Phytoplankton',' ','mol P m-3') + call wrtlvl(jlvlgrazer(iogrp),LVL_GRAZER(iogrp),rnacc*1e3,0., & + & cmpflg,'zooclvl','Zooplankton',' ','mol P m-3') + call wrtlvl(jlvlpoc(iogrp),LVL_POC(iogrp),rnacc*1e3,0.,cmpflg, & + & 'detoclvl','Detritus',' ','mol P m-3') + call wrtlvl(jlvlcalc(iogrp),LVL_CALC(iogrp),rnacc*1e3,0.,cmpflg, & + & 'calclvl','CaCO3 shells',' ','mol C m-3') + call wrtlvl(jlvlopal(iogrp),LVL_OPAL(iogrp),rnacc*1e3,0.,cmpflg, & + & 'opallvl','Opal shells',' ','mol Si m-3') + call wrtlvl(jlvliron(iogrp),LVL_IRON(iogrp),rnacc*1e3,0.,cmpflg, & + & 'dfelvl','Dissolved iron',' ','mol Fe m-3') + call wrtlvl(jlvlphosy(iogrp),LVL_PHOSY(iogrp),rnacc*1e3/dtbgc,0., & + & cmpflg,'pplvl','Primary production',' ','mol C m-3 s-1') + call wrtlvl(jlvlco3(iogrp),LVL_CO3(iogrp),rnacc*1e3,0.,cmpflg, & + & 'co3lvl','Carbonate ions',' ','mol C m-3') + call wrtlvl(jlvlph(iogrp),LVL_PH(iogrp),-1.,0.,cmpflg, & + & 'phlvl','pH',' ','-log10([h+])') + call wrtlvl(jlvlomegaa(iogrp),LVL_OMEGAA(iogrp),rnacc,0.,cmpflg, & + & 'omegaalvl','OmegaA',' ','-') + call wrtlvl(jlvlomegac(iogrp),LVL_OMEGAC(iogrp),rnacc,0.,cmpflg, & + & 'omegaclvl','OmegaC',' ','-') + call wrtlvl(jlvln2o(iogrp),LVL_N2O(iogrp),rnacc*1e3,0.,cmpflg, & + & 'n2olvl','N2O',' ','mol N2O m-3') + call wrtlvl(jlvlprefo2(iogrp),LVL_PREFO2(iogrp),rnacc*1e3,0., & + & cmpflg,'p_o2lvl','Preformed oxygen',' ','mol O2 m-3') + call wrtlvl(jlvlo2sat(iogrp),LVL_O2SAT(iogrp),rnacc*1e3,0., & + & cmpflg,'satoxylvl','Saturated oxygen',' ','mol O2 m-3') + call wrtlvl(jlvlprefpo4(iogrp),LVL_PREFPO4(iogrp),rnacc*1e3,0., & + & cmpflg,'p_po4lvl','Preformed phosphorus',' ','mol P m-3') + call wrtlvl(jlvlprefalk(iogrp),LVL_PREFALK(iogrp),rnacc*1e3,0., & + & cmpflg, 'p_talklvl','Preformed alkalinity',' ','eq m-3') + call wrtlvl(jlvlprefdic(iogrp),LVL_PREFDIC(iogrp),rnacc*1e3,0., & + & cmpflg, 'p_diclvl','Preformed DIC',' ','mol C m-3') + call wrtlvl(jlvldicsat(iogrp),LVL_DICSAT(iogrp),rnacc*1e3,0., & + & cmpflg, 'sat_diclvl','Saturated DIC',' ','mol C m-3') #ifdef cisonew - call wrtlvl(jlvldic13(iogrp),LVL_DIC13(iogrp),rnacc*1.e3, - . 0.,cmpflg,'dissic13lvl','Dissolved C13',' ','mol 13C m-3') - call wrtlvl(jlvldic14(iogrp),LVL_DIC14(iogrp),rnacc*1.e3*c14fac, - . 0.,cmpflg,'dissic14lvl','Dissolved C14',' ','mol 14C m-3') - call wrtlvl(jlvld13c(iogrp),LVL_D13C(iogrp),rnacc, - . 0.,cmpflg,'delta13clvl','delta13C of DIC',' ','permil') - call wrtlvl(jlvld14c(iogrp),LVL_D14C(iogrp),rnacc, - . 0.,cmpflg,'delta14clvl','delta14C of DIC',' ','permil') - call wrtlvl(jlvlbigd14c(iogrp),LVL_BIGD14C(iogrp),rnacc, - . 0.,cmpflg,'bigdelta14clvl','big delta14C of DIC',' ','permil') - call wrtlvl(jlvlpoc13(iogrp),LVL_POC13(iogrp),rnacc*1e3, - . 0.,cmpflg,'detoc13lvl','Detritus13',' ','mol P m-3') - call wrtlvl(jlvldoc13(iogrp),LVL_DOC13(iogrp),rnacc*1e3, - . 0.,cmpflg,'dissoc13lvl','Dissolved organic carbon13',' ', - . 'mol P m-3') - call wrtlvl(jlvlcalc13(iogrp),LVL_CALC13(iogrp),rnacc*1e3, - . 0.,cmpflg,'calc13lvl','Ca13CO3 shells',' ','mol 13C m-3') - call wrtlvl(jlvlphyto13(iogrp),LVL_PHYTO13(iogrp),rnacc*1e3, - . 0.,cmpflg,'phyc13lvl','Phytoplankton13',' ','mol P m-3') - call wrtlvl(jlvlgrazer13(iogrp),LVL_GRAZER13(iogrp),rnacc*1e3, - . 0.,cmpflg,'zooc13lvl','Zooplankton13',' ','mol P m-3') + call wrtlvl(jlvldic13(iogrp),LVL_DIC13(iogrp),rnacc*1.e3, & + & 0.,cmpflg,'dissic13lvl','Dissolved C13',' ','mol 13C m-3') + call wrtlvl(jlvldic14(iogrp),LVL_DIC14(iogrp),rnacc*1.e3*c14fac, & + & 0.,cmpflg,'dissic14lvl','Dissolved C14',' ','mol 14C m-3') + call wrtlvl(jlvld13c(iogrp),LVL_D13C(iogrp),rnacc, & + & 0.,cmpflg,'delta13clvl','delta13C of DIC',' ','permil') + call wrtlvl(jlvld14c(iogrp),LVL_D14C(iogrp),rnacc, & + & 0.,cmpflg,'delta14clvl','delta14C of DIC',' ','permil') + call wrtlvl(jlvlbigd14c(iogrp),LVL_BIGD14C(iogrp),rnacc, & + & 0.,cmpflg,'bigdelta14clvl','big delta14C of DIC',' ','permil') + call wrtlvl(jlvlpoc13(iogrp),LVL_POC13(iogrp),rnacc*1e3, & + & 0.,cmpflg,'detoc13lvl','Detritus13',' ','mol P m-3') + call wrtlvl(jlvldoc13(iogrp),LVL_DOC13(iogrp),rnacc*1e3, & + & 0.,cmpflg,'dissoc13lvl','Dissolved organic carbon13',' ', & + & 'mol P m-3') + call wrtlvl(jlvlcalc13(iogrp),LVL_CALC13(iogrp),rnacc*1e3, & + & 0.,cmpflg,'calc13lvl','Ca13CO3 shells',' ','mol 13C m-3') + call wrtlvl(jlvlphyto13(iogrp),LVL_PHYTO13(iogrp),rnacc*1e3, & + & 0.,cmpflg,'phyc13lvl','Phytoplankton13',' ','mol P m-3') + call wrtlvl(jlvlgrazer13(iogrp),LVL_GRAZER13(iogrp),rnacc*1e3, & + & 0.,cmpflg,'zooc13lvl','Zooplankton13',' ','mol P m-3') #endif #ifdef AGG - call wrtlvl(jlvlnos(iogrp),LVL_NOS(iogrp), - . rnacc,0.,cmpflg,'noslvl', - . 'Marine snow aggregates per cm^3 sea water',' ','1/cm^3') - call wrtlvl(jlvlwphy(iogrp),LVL_WPHY(iogrp), - . rnacc,0.,cmpflg,'wphylvl', - . 'Av. mass sinking speed of marine snow',' ','m/day') - call wrtlvl(jlvlwnos(iogrp),LVL_WNOS(iogrp), - . rnacc,0.,cmpflg,'wnoslvl', - . 'Av. number sinking speed of marine snow',' ','m/day') - call wrtlvl(jlvleps(iogrp),LVL_EPS(iogrp), - . rnacc,0.,cmpflg,'epslvl', - . 'Av. size distribution exponent',' ','-') - call wrtlvl(jlvlasize(iogrp),LVL_ASIZE(iogrp), - . rnacc,0.,cmpflg,'asizelvl', - . 'Av. size of marine snow aggregates',' ','nb. of cells') + call wrtlvl(jlvlnos(iogrp),LVL_NOS(iogrp), & + & rnacc,0.,cmpflg,'noslvl', & + & 'Marine snow aggregates per cm^3 sea water',' ','1/cm^3') + call wrtlvl(jlvlwphy(iogrp),LVL_WPHY(iogrp), & + & rnacc,0.,cmpflg,'wphylvl', & + & 'Av. mass sinking speed of marine snow',' ','m/day') + call wrtlvl(jlvlwnos(iogrp),LVL_WNOS(iogrp), & + & rnacc,0.,cmpflg,'wnoslvl', & + & 'Av. number sinking speed of marine snow',' ','m/day') + call wrtlvl(jlvleps(iogrp),LVL_EPS(iogrp), & + & rnacc,0.,cmpflg,'epslvl', & + & 'Av. size distribution exponent',' ','-') + call wrtlvl(jlvlasize(iogrp),LVL_ASIZE(iogrp), & + & rnacc,0.,cmpflg,'asizelvl', & + & 'Av. size of marine snow aggregates',' ','nb. of cells') #endif #ifdef CFC - call wrtlvl(jlvlcfc11(iogrp),LVL_CFC11(iogrp),rnacc*1e3,0.,cmpflg, - . 'cfc11lvl','CFC-11',' ','mol cfc11 m-3') - call wrtlvl(jlvlcfc12(iogrp),LVL_CFC12(iogrp),rnacc*1e3,0.,cmpflg, - . 'cfc12lvl','CFC-12',' ','mol cfc12 m-3') - call wrtlvl(jlvlsf6(iogrp),LVL_SF6(iogrp),rnacc*1e3,0.,cmpflg, - . 'sf6lvl','SF-6',' ','mol sf6 m-3') + call wrtlvl(jlvlcfc11(iogrp),LVL_CFC11(iogrp),rnacc*1e3,0.,cmpflg, & + & 'cfc11lvl','CFC-11',' ','mol cfc11 m-3') + call wrtlvl(jlvlcfc12(iogrp),LVL_CFC12(iogrp),rnacc*1e3,0.,cmpflg, & + & 'cfc12lvl','CFC-12',' ','mol cfc12 m-3') + call wrtlvl(jlvlsf6(iogrp),LVL_SF6(iogrp),rnacc*1e3,0.,cmpflg, & + & 'sf6lvl','SF-6',' ','mol sf6 m-3') #endif #ifdef natDIC - call wrtlvl(jlvlnatco3(iogrp),LVL_NATCO3(iogrp), - . rnacc*1e3,0.,cmpflg,'natco3lvl', - . 'Natural carbonate ions',' ','mol C m-3') - call wrtlvl(jlvlnatalkali(iogrp),LVL_NATALKALI(iogrp), - . rnacc*1e3,0.,cmpflg,'nattalklvl', - . 'Natural alkalinity',' ','eq m-3') - call wrtlvl(jlvlnatdic(iogrp),LVL_NATDIC(iogrp), - . rnacc*1e3,0.,cmpflg,'natdissiclvl', - . 'Natural dissolved inorganic carbon',' ','mol C m-3') - call wrtlvl(jlvlnatcalc(iogrp),LVL_NATCALC(iogrp), - . rnacc*1e3,0.,cmpflg,'natcalclvl', - . 'Natural CaCO3 shells',' ','mol C m-3') - call wrtlvl(jlvlnatph(iogrp),LVL_NATPH(iogrp),-1.,0.,cmpflg, - . 'natphlvl','Natural pH',' ','-log10([h+])') - call wrtlvl(jlvlnatomegaa(iogrp),LVL_NATOMEGAA(iogrp), - . rnacc,0.,cmpflg,'natomegaalvl', - . 'Natural OmegaA',' ','-') - call wrtlvl(jlvlnatomegac(iogrp),LVL_NATOMEGAC(iogrp), - . rnacc,0.,cmpflg,'natomegaclvl', - . 'Natural OmegaC',' ','-') + call wrtlvl(jlvlnatco3(iogrp),LVL_NATCO3(iogrp), & + & rnacc*1e3,0.,cmpflg,'natco3lvl', & + & 'Natural carbonate ions',' ','mol C m-3') + call wrtlvl(jlvlnatalkali(iogrp),LVL_NATALKALI(iogrp), & + & rnacc*1e3,0.,cmpflg,'nattalklvl', & + & 'Natural alkalinity',' ','eq m-3') + call wrtlvl(jlvlnatdic(iogrp),LVL_NATDIC(iogrp), & + & rnacc*1e3,0.,cmpflg,'natdissiclvl', & + & 'Natural dissolved inorganic carbon',' ','mol C m-3') + call wrtlvl(jlvlnatcalc(iogrp),LVL_NATCALC(iogrp), & + & rnacc*1e3,0.,cmpflg,'natcalclvl', & + & 'Natural CaCO3 shells',' ','mol C m-3') + call wrtlvl(jlvlnatph(iogrp),LVL_NATPH(iogrp),-1.,0.,cmpflg, & + & 'natphlvl','Natural pH',' ','-log10([h+])') + call wrtlvl(jlvlnatomegaa(iogrp),LVL_NATOMEGAA(iogrp), & + & rnacc,0.,cmpflg,'natomegaalvl', & + & 'Natural OmegaA',' ','-') + call wrtlvl(jlvlnatomegac(iogrp),LVL_NATOMEGAC(iogrp), & + & rnacc,0.,cmpflg,'natomegaclvl', & + & 'Natural OmegaC',' ','-') #endif #ifdef BROMO - call wrtlvl(jlvlbromo(iogrp),LVL_BROMO(iogrp),rnacc*1e3,0., - . cmpflg,'bromolvl','Bromoform',' ','mol CHBr3 m-3') + call wrtlvl(jlvlbromo(iogrp),LVL_BROMO(iogrp),rnacc*1e3,0., & + & cmpflg,'bromolvl','Bromoform',' ','mol CHBr3 m-3') #endif -c -c --- Store sediment fields + ! --- Store sediment fields #ifndef sedbypass - call wrtsdm(jpowaic(iogrp),SDM_POWAIC(iogrp),rnacc*1e3,0.,cmpflg, - . 'powdic','PoWa DIC',' ','mol C m-3') - call wrtsdm(jpowaal(iogrp),SDM_POWAAL(iogrp),rnacc*1e3,0.,cmpflg, - . 'powalk','PoWa alkalinity',' ','eq m-3') - call wrtsdm(jpowaph(iogrp),SDM_POWAPH(iogrp),rnacc*1e3,0.,cmpflg, - . 'powpho','PoWa phosphorus',' ','mol P m-3') - call wrtsdm(jpowaox(iogrp),SDM_POWAOX(iogrp),rnacc*1e3,0.,cmpflg, - . 'powox','PoWa oxygen',' ','mol O2 m-3') - call wrtsdm(jpown2(iogrp),SDM_POWN2(iogrp), rnacc*1e3,0.,cmpflg, - . 'pown2','PoWa N2',' ','mol N2 m-3') - call wrtsdm(jpowno3(iogrp),SDM_POWNO3(iogrp),rnacc*1e3,0.,cmpflg, - . 'powno3','PoWa nitrate',' ','mol N m-3') - call wrtsdm(jpowasi(iogrp),SDM_POWASI(iogrp),rnacc*1e3,0.,cmpflg, - . 'powsi','PoWa silicate',' ','mol Si m-3') - call wrtsdm(jssso12(iogrp),SDM_SSSO12(iogrp),rnacc*1e3,0.,cmpflg, - . 'ssso12','Sediment detritus',' ','mol P m-3') - call wrtsdm(jssssil(iogrp),SDM_SSSSIL(iogrp),rnacc*1e3,0.,cmpflg, - . 'ssssil','Sediment silicate',' ','mol Si m-3') - call wrtsdm(jsssc12(iogrp),SDM_SSSC12(iogrp),rnacc*1e3,0.,cmpflg, - . 'sssc12','Sediment CaCO3',' ','mol C m-3') - call wrtsdm(jssster(iogrp),SDM_SSSTER(iogrp),rnacc*1e3,0.,cmpflg, - . 'ssster','Sediment clay',' ','mol m-3') -c -c --- Store sediment burial fields - call wrtbur(jburssso12(iogrp),BUR_SSSO12(iogrp),rnacc*1e3,0., - . cmpflg,'buro12','Burial org carbon',' ','mol P m-2') - call wrtbur(jbursssc12(iogrp),BUR_SSSC12(iogrp),rnacc*1e3,0., - . cmpflg,'burc12','Burial calcium ',' ','mol C m-2') - call wrtbur(jburssssil(iogrp),BUR_SSSSIL(iogrp),rnacc*1e3,0., - . cmpflg,'bursil','Burial silicate',' ','mol Si m-2') - call wrtbur(jburssster(iogrp),BUR_SSSTER(iogrp),rnacc*1e3,0., - . cmpflg,'burter','Burial clay',' ','mol m-2') -#endif -c -c --- close netcdf file - call ncfcls -c -c --- Initialise fields - call inisrf(jkwco2(iogrp),0.) - call inisrf(jpco2(iogrp),0.) - call inisrf(jdmsflux(iogrp),0.) - call inisrf(jco2fxd(iogrp),0.) - call inisrf(jco2fxu(iogrp),0.) - call inisrf(joxflux(iogrp),0.) - call inisrf(jniflux(iogrp),0.) - call inisrf(jn2ofx(iogrp),0.) - call inisrf(jdms(iogrp),0.) - call inisrf(jdmsprod(iogrp),0.) - call inisrf(jdms_bac(iogrp),0.) - call inisrf(jdms_uv(iogrp),0.) - call inisrf(jexport(iogrp),0.) - call inisrf(jexposi(iogrp),0.) - call inisrf(jexpoca(iogrp),0.) - call inisrf(jsrfdic(iogrp),0.) - call inisrf(jsrfalkali(iogrp),0.) - call inisrf(jsrfphosph(iogrp),0.) - call inisrf(jsrfoxygen(iogrp),0.) - call inisrf(jsrfano3(iogrp),0.) - call inisrf(jsrfsilica(iogrp),0.) - call inisrf(jsrfiron(iogrp),0.) - call inisrf(jsrfphyto(iogrp),0.) - call inisrf(jintphosy(iogrp),0.) - call inisrf(jintnfix(iogrp),0.) - call inisrf(jintdnit(iogrp),0.) - call inisrf(jcarflx0100(iogrp),0.) - call inisrf(jcarflx0500(iogrp),0.) - call inisrf(jcarflx1000(iogrp),0.) - call inisrf(jcarflx2000(iogrp),0.) - call inisrf(jcarflx4000(iogrp),0.) - call inisrf(jcarflx_bot(iogrp),0.) - call inisrf(jbsiflx0100(iogrp),0.) - call inisrf(jbsiflx0500(iogrp),0.) - call inisrf(jbsiflx1000(iogrp),0.) - call inisrf(jbsiflx2000(iogrp),0.) - call inisrf(jbsiflx4000(iogrp),0.) - call inisrf(jbsiflx_bot(iogrp),0.) - call inisrf(jcalflx0100(iogrp),0.) - call inisrf(jcalflx0500(iogrp),0.) - call inisrf(jcalflx1000(iogrp),0.) - call inisrf(jcalflx2000(iogrp),0.) - call inisrf(jcalflx4000(iogrp),0.) - call inisrf(jcalflx_bot(iogrp),0.) + call wrtsdm(jpowaic(iogrp),SDM_POWAIC(iogrp),rnacc*1e3,0.,cmpflg, & + & 'powdic','PoWa DIC',' ','mol C m-3') + call wrtsdm(jpowaal(iogrp),SDM_POWAAL(iogrp),rnacc*1e3,0.,cmpflg, & + & 'powalk','PoWa alkalinity',' ','eq m-3') + call wrtsdm(jpowaph(iogrp),SDM_POWAPH(iogrp),rnacc*1e3,0.,cmpflg, & + & 'powpho','PoWa phosphorus',' ','mol P m-3') + call wrtsdm(jpowaox(iogrp),SDM_POWAOX(iogrp),rnacc*1e3,0.,cmpflg, & + & 'powox','PoWa oxygen',' ','mol O2 m-3') + call wrtsdm(jpown2(iogrp),SDM_POWN2(iogrp), rnacc*1e3,0.,cmpflg, & + & 'pown2','PoWa N2',' ','mol N2 m-3') + call wrtsdm(jpowno3(iogrp),SDM_POWNO3(iogrp),rnacc*1e3,0.,cmpflg, & + & 'powno3','PoWa nitrate',' ','mol N m-3') + call wrtsdm(jpowasi(iogrp),SDM_POWASI(iogrp),rnacc*1e3,0.,cmpflg, & + & 'powsi','PoWa silicate',' ','mol Si m-3') + call wrtsdm(jssso12(iogrp),SDM_SSSO12(iogrp),rnacc*1e3,0.,cmpflg, & + & 'ssso12','Sediment detritus',' ','mol P m-3') + call wrtsdm(jssssil(iogrp),SDM_SSSSIL(iogrp),rnacc*1e3,0.,cmpflg, & + & 'ssssil','Sediment silicate',' ','mol Si m-3') + call wrtsdm(jsssc12(iogrp),SDM_SSSC12(iogrp),rnacc*1e3,0.,cmpflg, & + & 'sssc12','Sediment CaCO3',' ','mol C m-3') + call wrtsdm(jssster(iogrp),SDM_SSSTER(iogrp),rnacc*1e3,0.,cmpflg, & + & 'ssster','Sediment clay',' ','mol m-3') + + ! --- Store sediment burial fields + call wrtbur(jburssso12(iogrp),BUR_SSSO12(iogrp),rnacc*1e3,0., & + & cmpflg,'buro12','Burial org carbon',' ','mol P m-2') + call wrtbur(jbursssc12(iogrp),BUR_SSSC12(iogrp),rnacc*1e3,0., & + & cmpflg,'burc12','Burial calcium ',' ','mol C m-2') + call wrtbur(jburssssil(iogrp),BUR_SSSSIL(iogrp),rnacc*1e3,0., & + & cmpflg,'bursil','Burial silicate',' ','mol Si m-2') + call wrtbur(jburssster(iogrp),BUR_SSSTER(iogrp),rnacc*1e3,0., & + & cmpflg,'burter','Burial clay',' ','mol m-2') +#endif + + ! --- close netcdf file + call ncfcls + + ! --- Initialise fields + call inisrf(jkwco2(iogrp),0.) + call inisrf(jpco2(iogrp),0.) + call inisrf(jdmsflux(iogrp),0.) + call inisrf(jco2fxd(iogrp),0.) + call inisrf(jco2fxu(iogrp),0.) + call inisrf(joxflux(iogrp),0.) + call inisrf(jniflux(iogrp),0.) + call inisrf(jn2ofx(iogrp),0.) + call inisrf(jdms(iogrp),0.) + call inisrf(jdmsprod(iogrp),0.) + call inisrf(jdms_bac(iogrp),0.) + call inisrf(jdms_uv(iogrp),0.) + call inisrf(jexport(iogrp),0.) + call inisrf(jexposi(iogrp),0.) + call inisrf(jexpoca(iogrp),0.) + call inisrf(jsrfdic(iogrp),0.) + call inisrf(jsrfalkali(iogrp),0.) + call inisrf(jsrfphosph(iogrp),0.) + call inisrf(jsrfoxygen(iogrp),0.) + call inisrf(jsrfano3(iogrp),0.) + call inisrf(jsrfsilica(iogrp),0.) + call inisrf(jsrfiron(iogrp),0.) + call inisrf(jsrfphyto(iogrp),0.) + call inisrf(jintphosy(iogrp),0.) + call inisrf(jintnfix(iogrp),0.) + call inisrf(jintdnit(iogrp),0.) + call inisrf(jcarflx0100(iogrp),0.) + call inisrf(jcarflx0500(iogrp),0.) + call inisrf(jcarflx1000(iogrp),0.) + call inisrf(jcarflx2000(iogrp),0.) + call inisrf(jcarflx4000(iogrp),0.) + call inisrf(jcarflx_bot(iogrp),0.) + call inisrf(jbsiflx0100(iogrp),0.) + call inisrf(jbsiflx0500(iogrp),0.) + call inisrf(jbsiflx1000(iogrp),0.) + call inisrf(jbsiflx2000(iogrp),0.) + call inisrf(jbsiflx4000(iogrp),0.) + call inisrf(jbsiflx_bot(iogrp),0.) + call inisrf(jcalflx0100(iogrp),0.) + call inisrf(jcalflx0500(iogrp),0.) + call inisrf(jcalflx1000(iogrp),0.) + call inisrf(jcalflx2000(iogrp),0.) + call inisrf(jcalflx4000(iogrp),0.) + call inisrf(jcalflx_bot(iogrp),0.) #ifndef sedbypass - call inisrf(jsediffic(iogrp),0.) - call inisrf(jsediffal(iogrp),0.) - call inisrf(jsediffph(iogrp),0.) - call inisrf(jsediffox(iogrp),0.) - call inisrf(jsediffn2(iogrp),0.) - call inisrf(jsediffno3(iogrp),0.) - call inisrf(jsediffsi(iogrp),0.) + call inisrf(jsediffic(iogrp),0.) + call inisrf(jsediffal(iogrp),0.) + call inisrf(jsediffph(iogrp),0.) + call inisrf(jsediffox(iogrp),0.) + call inisrf(jsediffn2(iogrp),0.) + call inisrf(jsediffno3(iogrp),0.) + call inisrf(jsediffsi(iogrp),0.) #endif #ifdef cisonew - call inisrf(jco213fxd(iogrp),0.) - call inisrf(jco213fxu(iogrp),0.) - call inisrf(jco214fxd(iogrp),0.) - call inisrf(jco214fxu(iogrp),0.) -#endif + call inisrf(jco213fxd(iogrp),0.) + call inisrf(jco213fxu(iogrp),0.) + call inisrf(jco214fxd(iogrp),0.) + call inisrf(jco214fxu(iogrp),0.) +#endif #ifdef CFC - call inisrf(jcfc11fx(iogrp),0.) - call inisrf(jcfc12fx(iogrp),0.) - call inisrf(jsf6fx(iogrp),0.) + call inisrf(jcfc11fx(iogrp),0.) + call inisrf(jcfc12fx(iogrp),0.) + call inisrf(jsf6fx(iogrp),0.) #endif #ifdef natDIC - call inisrf(jsrfnatdic(iogrp),0.) - call inisrf(jsrfnatalk(iogrp),0.) - call inisrf(jnatpco2(iogrp),0.) - call inisrf(jnatco2fx(iogrp),0.) + call inisrf(jsrfnatdic(iogrp),0.) + call inisrf(jsrfnatalk(iogrp),0.) + call inisrf(jnatpco2(iogrp),0.) + call inisrf(jnatco2fx(iogrp),0.) #endif #ifdef BROMO - call inisrf(jsrfbromo(iogrp),0.) - call inisrf(jbromofx(iogrp),0.) - call inisrf(jbromo_prod(iogrp),0.) - call inisrf(jbromo_uv(iogrp),0.) - call inisrf(jatmbromo(iogrp),0.) + call inisrf(jsrfbromo(iogrp),0.) + call inisrf(jbromofx(iogrp),0.) + call inisrf(jbromo_prod(iogrp),0.) + call inisrf(jbromo_uv(iogrp),0.) + call inisrf(jatmbromo(iogrp),0.) #endif - call inisrf(jatmco2(iogrp),0.) + call inisrf(jatmco2(iogrp),0.) #if defined(BOXATM) - call inisrf(jatmo2(iogrp),0.) - call inisrf(jatmn2(iogrp),0.) -#endif + call inisrf(jatmo2(iogrp),0.) + call inisrf(jatmn2(iogrp),0.) +#endif #ifdef cisonew - call inisrf(jatmc13(iogrp),0.) - call inisrf(jatmc14(iogrp),0.) -#endif -c - call inilyr(jdp(iogrp),0.) - call inilyr(jdic(iogrp),0.) - call inilyr(jalkali(iogrp),0.) - call inilyr(jphosy(iogrp),0.) - call inilyr(jphosph(iogrp),0.) - call inilyr(joxygen(iogrp),0.) - call inilyr(jano3(iogrp),0.) - call inilyr(jsilica(iogrp),0.) - call inilyr(jdoc(iogrp),0.) - call inilyr(jphyto(iogrp),0.) - call inilyr(jgrazer(iogrp),0.) - call inilyr(jpoc(iogrp),0.) - call inilyr(jcalc(iogrp),0.) - call inilyr(jopal(iogrp),0.) - call inilyr(jiron(iogrp),0.) - call inilyr(jco3(iogrp),0.) - call inilyr(jph(iogrp),0.) - call inilyr(jomegaa(iogrp),0.) - call inilyr(jomegac(iogrp),0.) - call inilyr(jn2o(iogrp),0.) - call inilyr(jprefo2(iogrp),0.) - call inilyr(jo2sat(iogrp),0.) - call inilyr(jprefpo4(iogrp),0.) - call inilyr(jprefalk(iogrp),0.) - call inilyr(jprefdic(iogrp),0.) - call inilyr(jdicsat(iogrp),0.) + call inisrf(jatmc13(iogrp),0.) + call inisrf(jatmc14(iogrp),0.) +#endif + + call inilyr(jdp(iogrp),0.) + call inilyr(jdic(iogrp),0.) + call inilyr(jalkali(iogrp),0.) + call inilyr(jphosy(iogrp),0.) + call inilyr(jphosph(iogrp),0.) + call inilyr(joxygen(iogrp),0.) + call inilyr(jano3(iogrp),0.) + call inilyr(jsilica(iogrp),0.) + call inilyr(jdoc(iogrp),0.) + call inilyr(jphyto(iogrp),0.) + call inilyr(jgrazer(iogrp),0.) + call inilyr(jpoc(iogrp),0.) + call inilyr(jcalc(iogrp),0.) + call inilyr(jopal(iogrp),0.) + call inilyr(jiron(iogrp),0.) + call inilyr(jco3(iogrp),0.) + call inilyr(jph(iogrp),0.) + call inilyr(jomegaa(iogrp),0.) + call inilyr(jomegac(iogrp),0.) + call inilyr(jn2o(iogrp),0.) + call inilyr(jprefo2(iogrp),0.) + call inilyr(jo2sat(iogrp),0.) + call inilyr(jprefpo4(iogrp),0.) + call inilyr(jprefalk(iogrp),0.) + call inilyr(jprefdic(iogrp),0.) + call inilyr(jdicsat(iogrp),0.) #ifdef cisonew - call inilyr(jdic13(iogrp),0.) - call inilyr(jdic14(iogrp),0.) - call inilyr(jd13c(iogrp),0.) - call inilyr(jd14c(iogrp),0.) - call inilyr(jbigd14c(iogrp),0.) - call inilyr(jpoc13(iogrp),0.) - call inilyr(jdoc13(iogrp),0.) - call inilyr(jcalc13(iogrp),0.) - call inilyr(jphyto13(iogrp),0.) - call inilyr(jgrazer13(iogrp),0.) -#endif + call inilyr(jdic13(iogrp),0.) + call inilyr(jdic14(iogrp),0.) + call inilyr(jd13c(iogrp),0.) + call inilyr(jd14c(iogrp),0.) + call inilyr(jbigd14c(iogrp),0.) + call inilyr(jpoc13(iogrp),0.) + call inilyr(jdoc13(iogrp),0.) + call inilyr(jcalc13(iogrp),0.) + call inilyr(jphyto13(iogrp),0.) + call inilyr(jgrazer13(iogrp),0.) +#endif #ifdef AGG - call inilyr(jnos(iogrp),0.) - call inilyr(jwphy(iogrp),0.) - call inilyr(jwnos(iogrp),0.) - call inilyr(jeps(iogrp),0.) - call inilyr(jasize(iogrp),0.) -#endif + call inilyr(jnos(iogrp),0.) + call inilyr(jwphy(iogrp),0.) + call inilyr(jwnos(iogrp),0.) + call inilyr(jeps(iogrp),0.) + call inilyr(jasize(iogrp),0.) +#endif #ifdef CFC - call inilyr(jcfc11(iogrp),0.) - call inilyr(jcfc12(iogrp),0.) - call inilyr(jsf6(iogrp),0.) + call inilyr(jcfc11(iogrp),0.) + call inilyr(jcfc12(iogrp),0.) + call inilyr(jsf6(iogrp),0.) #endif #ifdef natDIC - call inilyr(jnatco3(iogrp),0.) - call inilyr(jnatalkali(iogrp),0.) - call inilyr(jnatdic(iogrp),0.) - call inilyr(jnatcalc(iogrp),0.) - call inilyr(jnatph(iogrp),0.) - call inilyr(jnatomegaa(iogrp),0.) - call inilyr(jnatomegac(iogrp),0.) + call inilyr(jnatco3(iogrp),0.) + call inilyr(jnatalkali(iogrp),0.) + call inilyr(jnatdic(iogrp),0.) + call inilyr(jnatcalc(iogrp),0.) + call inilyr(jnatph(iogrp),0.) + call inilyr(jnatomegaa(iogrp),0.) + call inilyr(jnatomegac(iogrp),0.) #endif #ifdef BROMO - call inilyr(jbromo(iogrp),0.) + call inilyr(jbromo(iogrp),0.) #endif -c - call inilvl(jlvldic(iogrp),0.) - call inilvl(jlvlalkali(iogrp),0.) - call inilvl(jlvlphosy(iogrp),0.) - call inilvl(jlvlphosph(iogrp),0.) - call inilvl(jlvloxygen(iogrp),0.) - call inilvl(jlvlano3(iogrp),0.) - call inilvl(jlvlsilica(iogrp),0.) - call inilvl(jlvldoc(iogrp),0.) - call inilvl(jlvlphyto(iogrp),0.) - call inilvl(jlvlgrazer(iogrp),0.) - call inilvl(jlvlpoc(iogrp),0.) - call inilvl(jlvlcalc(iogrp),0.) - call inilvl(jlvlopal(iogrp),0.) - call inilvl(jlvliron(iogrp),0.) - call inilvl(jlvlco3(iogrp),0.) - call inilvl(jlvlph(iogrp),0.) - call inilvl(jlvlomegaa(iogrp),0.) - call inilvl(jlvlomegac(iogrp),0.) - call inilvl(jlvln2o(iogrp),0.) - call inilvl(jlvlprefo2(iogrp),0.) - call inilvl(jlvlo2sat(iogrp),0.) - call inilvl(jlvlprefpo4(iogrp),0.) - call inilvl(jlvlprefalk(iogrp),0.) - call inilvl(jlvlprefdic(iogrp),0.) - call inilvl(jlvldicsat(iogrp),0.) + call inilvl(jlvldic(iogrp),0.) + call inilvl(jlvlalkali(iogrp),0.) + call inilvl(jlvlphosy(iogrp),0.) + call inilvl(jlvlphosph(iogrp),0.) + call inilvl(jlvloxygen(iogrp),0.) + call inilvl(jlvlano3(iogrp),0.) + call inilvl(jlvlsilica(iogrp),0.) + call inilvl(jlvldoc(iogrp),0.) + call inilvl(jlvlphyto(iogrp),0.) + call inilvl(jlvlgrazer(iogrp),0.) + call inilvl(jlvlpoc(iogrp),0.) + call inilvl(jlvlcalc(iogrp),0.) + call inilvl(jlvlopal(iogrp),0.) + call inilvl(jlvliron(iogrp),0.) + call inilvl(jlvlco3(iogrp),0.) + call inilvl(jlvlph(iogrp),0.) + call inilvl(jlvlomegaa(iogrp),0.) + call inilvl(jlvlomegac(iogrp),0.) + call inilvl(jlvln2o(iogrp),0.) + call inilvl(jlvlprefo2(iogrp),0.) + call inilvl(jlvlo2sat(iogrp),0.) + call inilvl(jlvlprefpo4(iogrp),0.) + call inilvl(jlvlprefalk(iogrp),0.) + call inilvl(jlvlprefdic(iogrp),0.) + call inilvl(jlvldicsat(iogrp),0.) #ifdef cisonew - call inilvl(jlvldic13(iogrp),0.) - call inilvl(jlvldic14(iogrp),0.) - call inilvl(jlvld13c(iogrp),0.) - call inilvl(jlvld14c(iogrp),0.) - call inilvl(jlvlbigd14c(iogrp),0.) - call inilvl(jlvlpoc13(iogrp),0.) - call inilvl(jlvldoc13(iogrp),0.) - call inilvl(jlvlcalc13(iogrp),0.) - call inilvl(jlvlphyto13(iogrp),0.) - call inilvl(jlvlgrazer13(iogrp),0.) -#endif + call inilvl(jlvldic13(iogrp),0.) + call inilvl(jlvldic14(iogrp),0.) + call inilvl(jlvld13c(iogrp),0.) + call inilvl(jlvld14c(iogrp),0.) + call inilvl(jlvlbigd14c(iogrp),0.) + call inilvl(jlvlpoc13(iogrp),0.) + call inilvl(jlvldoc13(iogrp),0.) + call inilvl(jlvlcalc13(iogrp),0.) + call inilvl(jlvlphyto13(iogrp),0.) + call inilvl(jlvlgrazer13(iogrp),0.) +#endif #ifdef AGG - call inilvl(jlvlnos(iogrp),0.) - call inilvl(jlvlwphy(iogrp),0.) - call inilvl(jlvlwnos(iogrp),0.) - call inilvl(jlvleps(iogrp),0.) - call inilvl(jlvlasize(iogrp),0.) -#endif + call inilvl(jlvlnos(iogrp),0.) + call inilvl(jlvlwphy(iogrp),0.) + call inilvl(jlvlwnos(iogrp),0.) + call inilvl(jlvleps(iogrp),0.) + call inilvl(jlvlasize(iogrp),0.) +#endif #ifdef CFC - call inilvl(jlvlcfc11(iogrp),0.) - call inilvl(jlvlcfc12(iogrp),0.) - call inilvl(jlvlsf6(iogrp),0.) + call inilvl(jlvlcfc11(iogrp),0.) + call inilvl(jlvlcfc12(iogrp),0.) + call inilvl(jlvlsf6(iogrp),0.) #endif #ifdef natDIC - call inilvl(jlvlnatco3(iogrp),0.) - call inilvl(jlvlnatalkali(iogrp),0.) - call inilvl(jlvlnatdic(iogrp),0.) - call inilvl(jlvlnatcalc(iogrp),0.) - call inilvl(jlvlnatph(iogrp),0.) - call inilvl(jlvlnatomegaa(iogrp),0.) - call inilvl(jlvlnatomegac(iogrp),0.) + call inilvl(jlvlnatco3(iogrp),0.) + call inilvl(jlvlnatalkali(iogrp),0.) + call inilvl(jlvlnatdic(iogrp),0.) + call inilvl(jlvlnatcalc(iogrp),0.) + call inilvl(jlvlnatph(iogrp),0.) + call inilvl(jlvlnatomegaa(iogrp),0.) + call inilvl(jlvlnatomegac(iogrp),0.) #endif #ifdef BROMO - call inilvl(jlvlbromo(iogrp),0.) + call inilvl(jlvlbromo(iogrp),0.) #endif -c #ifndef sedbypass - call inisdm(jpowaic(iogrp),0.) - call inisdm(jpowaal(iogrp),0.) - call inisdm(jpowaph(iogrp),0.) - call inisdm(jpowaox(iogrp),0.) - call inisdm(jpown2(iogrp),0.) - call inisdm(jpowno3(iogrp),0.) - call inisdm(jpowasi(iogrp),0.) - call inisdm(jssso12(iogrp),0.) - call inisdm(jssssil(iogrp),0.) - call inisdm(jsssc12(iogrp),0.) - call inisdm(jssster(iogrp),0.) + call inisdm(jpowaic(iogrp),0.) + call inisdm(jpowaal(iogrp),0.) + call inisdm(jpowaph(iogrp),0.) + call inisdm(jpowaox(iogrp),0.) + call inisdm(jpown2(iogrp),0.) + call inisdm(jpowno3(iogrp),0.) + call inisdm(jpowasi(iogrp),0.) + call inisdm(jssso12(iogrp),0.) + call inisdm(jssssil(iogrp),0.) + call inisdm(jsssc12(iogrp),0.) + call inisdm(jssster(iogrp),0.) - call inibur(jburssso12(iogrp),0.) - call inibur(jbursssc12(iogrp),0.) - call inibur(jburssssil(iogrp),0.) - call inibur(jburssster(iogrp),0.) -#endif -c - nacc_bgc(iogrp)=0 -c - end + call inibur(jburssso12(iogrp),0.) + call inibur(jbursssc12(iogrp),0.) + call inibur(jburssssil(iogrp),0.) + call inibur(jburssster(iogrp),0.) +#endif + + nacc_bgc(iogrp)=0 + +end subroutine ncwrt_bgc - subroutine hamoccvardef(iogrp,timeunits,calendar,cmpflg) - use mod_nctools, only:ncdefvar,ncattr,ncfopn,ncdimc,ncdims, - . nctime,ncfcls,ncedef,ncdefvar3d,ndouble +subroutine hamoccvardef(iogrp,timeunits,calendar,cmpflg) + use mod_nctools, only:ncdefvar,ncattr,ncfopn,ncdimc,ncdims, & + & nctime,ncfcls,ncedef,ncdefvar3d,ndouble - use mo_bgcmean, only: srf_kwco2,srf_pco2,srf_dmsflux,srf_co2fxd, - . srf_co2fxu,srf_oxflux,srf_niflux,srf_dms,srf_dmsprod, - . srf_dms_bac,srf_dms_uv,srf_export,srf_exposi,srf_expoca, - . srf_dic,srf_alkali,srf_phosph,srf_oxygen,srf_ano3,srf_silica, - . srf_iron,srf_phyto,int_phosy,int_nfix,int_dnit,flx_car0100, - . flx_car0500,flx_car1000,flx_car2000,flx_car4000,flx_car_bot, - . flx_bsi0100,flx_bsi0500,flx_bsi1000,flx_bsi2000,flx_bsi4000, - . flx_bsi_bot,flx_cal0100,flx_cal0500,flx_cal1000,flx_cal2000, - . flx_cal4000,flx_cal_bot,flx_sediffic,flx_sediffal, - . flx_sediffph,flx_sediffox,flx_sediffn2,flx_sediffno3, - . flx_sediffsi,srf_n2ofx,srf_atmco2,lyr_dp,lyr_dic, - . lyr_alkali,lyr_phosph,lyr_oxygen,lyr_ano3,lyr_silica,lyr_doc, - . lyr_phyto,lyr_grazer,lyr_poc,lyr_calc,lyr_opal,lyr_iron, - . lyr_phosy,lyr_co3,lyr_ph,lyr_omegaa,lyr_omegac,lyr_n2o, - . lyr_prefo2,lyr_o2sat,lyr_prefpo4,lyr_prefalk,lyr_prefdic, - . lyr_dicsat,lvl_dic,lvl_alkali,lvl_phosph,lvl_oxygen,lvl_ano3, - . lvl_silica,lvl_doc,lvl_phyto,lvl_grazer,lvl_poc,lvl_calc, - . lvl_opal,lvl_iron,lvl_phosy,lvl_co3,lvl_ph,lvl_omegaa, - . lvl_omegac,lvl_n2o,lvl_prefo2,lvl_o2sat,lvl_prefpo4, - . lvl_prefalk,lvl_prefdic,lvl_dicsat + use mo_bgcmean, only: srf_kwco2,srf_pco2,srf_dmsflux,srf_co2fxd, & + & srf_co2fxu,srf_oxflux,srf_niflux,srf_dms,srf_dmsprod, & + & srf_dms_bac,srf_dms_uv,srf_export,srf_exposi,srf_expoca, & + & srf_dic,srf_alkali,srf_phosph,srf_oxygen,srf_ano3,srf_silica, & + & srf_iron,srf_phyto,int_phosy,int_nfix,int_dnit,flx_car0100, & + & flx_car0500,flx_car1000,flx_car2000,flx_car4000,flx_car_bot, & + & flx_bsi0100,flx_bsi0500,flx_bsi1000,flx_bsi2000,flx_bsi4000, & + & flx_bsi_bot,flx_cal0100,flx_cal0500,flx_cal1000,flx_cal2000, & + & flx_cal4000,flx_cal_bot,flx_sediffic,flx_sediffal, & + & flx_sediffph,flx_sediffox,flx_sediffn2,flx_sediffno3, & + & flx_sediffsi,srf_n2ofx,srf_atmco2,lyr_dp,lyr_dic, & + & lyr_alkali,lyr_phosph,lyr_oxygen,lyr_ano3,lyr_silica,lyr_doc, & + & lyr_phyto,lyr_grazer,lyr_poc,lyr_calc,lyr_opal,lyr_iron, & + & lyr_phosy,lyr_co3,lyr_ph,lyr_omegaa,lyr_omegac,lyr_n2o, & + & lyr_prefo2,lyr_o2sat,lyr_prefpo4,lyr_prefalk,lyr_prefdic, & + & lyr_dicsat,lvl_dic,lvl_alkali,lvl_phosph,lvl_oxygen,lvl_ano3, & + & lvl_silica,lvl_doc,lvl_phyto,lvl_grazer,lvl_poc,lvl_calc, & + & lvl_opal,lvl_iron,lvl_phosy,lvl_co3,lvl_ph,lvl_omegaa, & + & lvl_omegac,lvl_n2o,lvl_prefo2,lvl_o2sat,lvl_prefpo4, & + & lvl_prefalk,lvl_prefdic,lvl_dicsat #ifdef AGG - use mo_bgcmean, only: lyr_nos,lyr_wphy,lyr_wnos,lyr_eps, - . lyr_asize,lvl_nos,lvl_wphy,lvl_wnos,lvl_eps,lvl_asize -#endif + use mo_bgcmean, only: lyr_nos,lyr_wphy,lyr_wnos,lyr_eps, & + & lyr_asize,lvl_nos,lvl_wphy,lvl_wnos,lvl_eps,lvl_asize +#endif #if defined(BOXATM) - use mo_bgcmean, only: srf_atmo2,srf_atmn2 -#endif - + use mo_bgcmean, only: srf_atmo2,srf_atmn2 +#endif + #ifdef BROMO - use mo_bgcmean, only:srf_bromo,srf_bromofx,int_bromopro, - . int_bromouv,srf_atmbromo,lyr_bromo,lvl_bromo + use mo_bgcmean, only:srf_bromo,srf_bromofx,int_bromopro, & + & int_bromouv,srf_atmbromo,lyr_bromo,lvl_bromo #endif #ifdef CFC - use mo_bgcmean, only: srf_cfc11,srf_cfc12,srf_sf6,lyr_cfc11, - . lyr_cfc12,lyr_sf6,lvl_cfc11,lvl_cfc12,lvl_sf6 + use mo_bgcmean, only: srf_cfc11,srf_cfc12,srf_sf6,lyr_cfc11, & + & lyr_cfc12,lyr_sf6,lvl_cfc11,lvl_cfc12,lvl_sf6 #endif #ifdef cisonew - use mo_bgcmean, only: srf_co213fxd,srf_co213fxu,srf_co214fxd, - . srf_co214fxu,srf_atmc13,srf_atmc14,lyr_dic13,lyr_dic14, - . lyr_d13c,lyr_d14c,lyr_bigd14c,lyr_poc13,lyr_doc13, - . lyr_calc13,lyr_phyto13,lyr_grazer13,lvl_dic13,lvl_dic14, - . lvl_d13c,lvl_d14c,lvl_bigd14c,lvl_poc13,lvl_doc13, - . lvl_calc13,lvl_phyto13,lvl_grazer13 + use mo_bgcmean, only: srf_co213fxd,srf_co213fxu,srf_co214fxd, & + & srf_co214fxu,srf_atmc13,srf_atmc14,lyr_dic13,lyr_dic14, & + & lyr_d13c,lyr_d14c,lyr_bigd14c,lyr_poc13,lyr_doc13, & + & lyr_calc13,lyr_phyto13,lyr_grazer13,lvl_dic13,lvl_dic14, & + & lvl_d13c,lvl_d14c,lvl_bigd14c,lvl_poc13,lvl_doc13, & + & lvl_calc13,lvl_phyto13,lvl_grazer13 #endif #ifdef natDIC - use mo_bgcmean, only: srf_natdic,srf_natalkali,srf_natpco2, - . srf_natco2fx,lyr_natco3,lyr_natalkali,lyr_natdic, - . lyr_natcalc,lyr_natph,lyr_natomegaa,lyr_natomegac, - . lvl_natalkali,lvl_natdic,lvl_natcalc,lvl_natph, - . lvl_natomegaa,lvl_natomegac,lvl_natco3 + use mo_bgcmean, only: srf_natdic,srf_natalkali,srf_natpco2, & + & srf_natco2fx,lyr_natco3,lyr_natalkali,lyr_natdic, & + & lyr_natcalc,lyr_natph,lyr_natomegaa,lyr_natomegac, & + & lvl_natalkali,lvl_natdic,lvl_natcalc,lvl_natph, & + & lvl_natomegaa,lvl_natomegac,lvl_natco3 #endif #ifndef sedbypass - use mo_bgcmean, only: sdm_powaic,sdm_powaal,sdm_powaph,sdm_powaox, - . sdm_pown2,sdm_powno3,sdm_powasi,sdm_ssso12,sdm_ssssil, - . sdm_sssc12,sdm_ssster,bur_ssso12,bur_sssc12,bur_ssssil, - . bur_ssster + use mo_bgcmean, only: sdm_powaic,sdm_powaal,sdm_powaph,sdm_powaox, & + & sdm_pown2,sdm_powno3,sdm_powasi,sdm_ssso12,sdm_ssssil, & + & sdm_sssc12,sdm_ssster,bur_ssso12,bur_sssc12,bur_ssssil, & + & bur_ssster #endif - implicit none + implicit none - integer iogrp,cmpflg - character timeunits*30,calendar*19 - call ncdefvar('time','time',ndouble,0) - call ncattr('long_name','time') - call ncattr('units',timeunits) - call ncattr('calendar',calendar) - call ncdefvar('sigma','sigma',ndouble,8) - call ncattr('long_name','Potential density') - call ncattr('standard_name','sea_water_sigma_theta') - call ncattr('units','kg m-3') - call ncattr('positive','down') - call ncdefvar('depth','depth',ndouble,8) - call ncattr('long_name','z level') - call ncattr('units','m') - call ncattr('positive','down') - call ncattr('bounds','depth_bnds') - call ncdefvar('depth_bnds','bounds depth',ndouble,8) - call ncdefvar3d(SRF_KWCO2(iogrp),cmpflg,'p', - . 'kwco2',' ',' ',' ',0) - call ncdefvar3d(SRF_PCO2(iogrp),cmpflg,'p', - . 'pco2','Surface PCO2',' ','uatm',0) - call ncdefvar3d(SRF_DMSFLUX(iogrp), - . cmpflg,'p','dmsflux','DMS flux',' ','mol DMS m-2 s-1',0) - call ncdefvar3d(SRF_CO2FXD(iogrp), - . cmpflg,'p','co2fxd','Downward CO2 flux',' ','kg C m-2 s-1',0) - call ncdefvar3d(SRF_CO2FXU(iogrp), - . cmpflg,'p','co2fxu','Upward CO2 flux',' ','kg C m-2 s-1',0) - call ncdefvar3d(SRF_OXFLUX(iogrp), - . cmpflg,'p','fgo2','Oxygen flux',' ','mol O2 m-2 s-1',0) - call ncdefvar3d(SRF_NIFLUX(iogrp), - . cmpflg,'p','fgn2','Nitrogen flux',' ','mol N2 m-2 s-1',0) - call ncdefvar3d(SRF_DMS(iogrp),cmpflg,'p', - . 'dms','DMS',' ','kmol DMS m-3',0) - call ncdefvar3d(SRF_DMSPROD(iogrp),cmpflg,'p', - . 'dmsprod','DMS production from phytoplankton production',' ', - . 'mol DMS m-2 s-1',0) - call ncdefvar3d(SRF_DMS_BAC(iogrp),cmpflg,'p', - . 'dms_bac','DMS bacterial consumption',' ','mol DMS m-2 s-1',0) - call ncdefvar3d(SRF_DMS_UV(iogrp),cmpflg,'p', - . 'dms_uv','DMS photolysis reduction',' ','mol DMS m-2 s-1',0) - call ncdefvar3d(SRF_EXPORT(iogrp), - . cmpflg,'p','epc100','Export production',' ','mol C m-2 s-1',0) - call ncdefvar3d(SRF_EXPOSI(iogrp),cmpflg,'p', - . 'epsi100','Si export production',' ','mol Si m-2 s-1',0) - call ncdefvar3d(SRF_EXPOCA(iogrp),cmpflg,'p', - . 'epcalc100','Ca export production',' ','mol Ca m-2 s-1',0) - call ncdefvar3d(SRF_DIC(iogrp),cmpflg,'p','srfdissic', - . 'Surface dissolved inorganic carbon',' ','mol C m-3',0) - call ncdefvar3d(SRF_ALKALI(iogrp),cmpflg,'p','srftalk', - . 'Surface alkalinity',' ','eq m-3',0) - call ncdefvar3d(SRF_PHOSPH(iogrp),cmpflg,'p','srfpo4', - . 'Surface phosphorus',' ','mol P m-3',0) - call ncdefvar3d(SRF_OXYGEN(iogrp),cmpflg,'p','srfo2', - . 'Surface oxygen',' ','mol O2 m-3',0) - call ncdefvar3d(SRF_ANO3(iogrp),cmpflg,'p','srfno3', - . 'Surface nitrate',' ','mol N m-3',0) - call ncdefvar3d(SRF_SILICA(iogrp),cmpflg,'p','srfsi', - . 'Surface silicate',' ','mol Si m-3',0) - call ncdefvar3d(SRF_IRON(iogrp),cmpflg,'p','srfdfe', - . 'Surface dissolved iron',' ','mol Fe m-3',0) - call ncdefvar3d(SRF_PHYTO(iogrp),cmpflg,'p','srfphyc', - . 'Surface phytoplankton',' ','mol P m-3',0) - call ncdefvar3d(INT_PHOSY(iogrp),cmpflg,'p','ppint', - . 'Integrated primary production',' ','mol C m-2 s-1',0) - call ncdefvar3d(INT_NFIX(iogrp),cmpflg,'p','nfixint', - . 'Integrated nitrogen fixation',' ','mol N m-2 s-1',0) - call ncdefvar3d(INT_DNIT(iogrp),cmpflg,'p','dnitint', - . 'Integrated denitrification',' ','mol N m-2 s-1',0) - call ncdefvar3d(FLX_CAR0100(iogrp),cmpflg,'p','carflx0100', - . 'C flux at 100m',' ','mol C m-2 s-1',0) - call ncdefvar3d(FLX_CAR0500(iogrp),cmpflg,'p','carflx0500', - . 'C flux at 500m',' ','mol C m-2 s-1',0) - call ncdefvar3d(FLX_CAR1000(iogrp),cmpflg,'p','carflx1000', - . 'C flux at 1000m',' ','mol C m-2 s-1',0) - call ncdefvar3d(FLX_CAR2000(iogrp),cmpflg,'p','carflx2000', - . 'C flux at 2000m',' ','mol C m-2 s-1',0) - call ncdefvar3d(FLX_CAR4000(iogrp),cmpflg,'p','carflx4000', - . 'C flux at 4000m',' ','mol C m-2 s-1',0) - call ncdefvar3d(FLX_CAR_BOT(iogrp),cmpflg,'p','carflx_bot', - . 'C flux to sediment',' ','mol C m-2 s-1',0) - call ncdefvar3d(FLX_BSI0100(iogrp),cmpflg,'p','bsiflx0100', - . 'Opal flux at 100m',' ','mol Si m-2 s-1',0) - call ncdefvar3d(FLX_BSI0500(iogrp),cmpflg,'p','bsiflx0500', - . 'Opal flux at 500m',' ','mol Si m-2 s-1',0) - call ncdefvar3d(FLX_BSI1000(iogrp),cmpflg,'p','bsiflx1000', - . 'Opal flux at 1000m',' ','mol Si m-2 s-1',0) - call ncdefvar3d(FLX_BSI2000(iogrp),cmpflg,'p','bsiflx2000', - . 'Opal flux at 2000m',' ','mol Si m-2 s-1',0) - call ncdefvar3d(FLX_BSI4000(iogrp),cmpflg,'p','bsiflx4000', - . 'Opal flux at 4000m',' ','mol Si m-2 s-1',0) - call ncdefvar3d(FLX_BSI_BOT(iogrp),cmpflg,'p','bsiflx_bot', - . 'Opal flux to sediment',' ','mol Si m-2 s-1',0) - call ncdefvar3d(FLX_CAL0100(iogrp),cmpflg,'p','calflx0100', - . 'CaCO3 flux at 100m',' ','mol Ca m-2 s-1',0) - call ncdefvar3d(FLX_CAL0500(iogrp),cmpflg,'p','calflx0500', - . 'CaCO3 flux at 500m',' ','mol Ca m-2 s-1',0) - call ncdefvar3d(FLX_CAL1000(iogrp),cmpflg,'p','calflx1000', - . 'CaCO3 flux at 1000m',' ','mol Ca m-2 s-1',0) - call ncdefvar3d(FLX_CAL2000(iogrp),cmpflg,'p','calflx2000', - . 'CaCO3 flux at 2000m',' ','mol Ca m-2 s-1',0) - call ncdefvar3d(FLX_CAL4000(iogrp),cmpflg,'p','calflx4000', - . 'CaCO3 flux at 4000m',' ','mol Ca m-2 s-1',0) - call ncdefvar3d(FLX_CAL_BOT(iogrp),cmpflg,'p','calflx_bot', - . 'CaCO3 flux to sediment',' ','mol Ca m-2 s-1',0) - call ncdefvar3d(SRF_N2OFX(iogrp),cmpflg,'p','n2oflux', - . 'N2O flux',' ','mol N2O m-2 s-1',0) + integer iogrp,cmpflg + character timeunits*30,calendar*19 + call ncdefvar('time','time',ndouble,0) + call ncattr('long_name','time') + call ncattr('units',timeunits) + call ncattr('calendar',calendar) + call ncdefvar('sigma','sigma',ndouble,8) + call ncattr('long_name','Potential density') + call ncattr('standard_name','sea_water_sigma_theta') + call ncattr('units','kg m-3') + call ncattr('positive','down') + call ncdefvar('depth','depth',ndouble,8) + call ncattr('long_name','z level') + call ncattr('units','m') + call ncattr('positive','down') + call ncattr('bounds','depth_bnds') + call ncdefvar('depth_bnds','bounds depth',ndouble,8) + call ncdefvar3d(SRF_KWCO2(iogrp),cmpflg,'p', & + & 'kwco2',' ',' ',' ',0) + call ncdefvar3d(SRF_PCO2(iogrp),cmpflg,'p', & + & 'pco2','Surface PCO2',' ','uatm',0) + call ncdefvar3d(SRF_DMSFLUX(iogrp), & + & cmpflg,'p','dmsflux','DMS flux',' ','mol DMS m-2 s-1',0) + call ncdefvar3d(SRF_CO2FXD(iogrp), & + & cmpflg,'p','co2fxd','Downward CO2 flux',' ','kg C m-2 s-1',0) + call ncdefvar3d(SRF_CO2FXU(iogrp), & + & cmpflg,'p','co2fxu','Upward CO2 flux',' ','kg C m-2 s-1',0) + call ncdefvar3d(SRF_OXFLUX(iogrp), & + & cmpflg,'p','fgo2','Oxygen flux',' ','mol O2 m-2 s-1',0) + call ncdefvar3d(SRF_NIFLUX(iogrp), & + & cmpflg,'p','fgn2','Nitrogen flux',' ','mol N2 m-2 s-1',0) + call ncdefvar3d(SRF_DMS(iogrp),cmpflg,'p', & + & 'dms','DMS',' ','kmol DMS m-3',0) + call ncdefvar3d(SRF_DMSPROD(iogrp),cmpflg,'p', & + & 'dmsprod','DMS production from phytoplankton production',' ', & + & 'mol DMS m-2 s-1',0) + call ncdefvar3d(SRF_DMS_BAC(iogrp),cmpflg,'p', & + & 'dms_bac','DMS bacterial consumption',' ','mol DMS m-2 s-1',0) + call ncdefvar3d(SRF_DMS_UV(iogrp),cmpflg,'p', & + & 'dms_uv','DMS photolysis reduction',' ','mol DMS m-2 s-1',0) + call ncdefvar3d(SRF_EXPORT(iogrp), & + & cmpflg,'p','epc100','Export production',' ','mol C m-2 s-1',0) + call ncdefvar3d(SRF_EXPOSI(iogrp),cmpflg,'p', & + & 'epsi100','Si export production',' ','mol Si m-2 s-1',0) + call ncdefvar3d(SRF_EXPOCA(iogrp),cmpflg,'p', & + & 'epcalc100','Ca export production',' ','mol Ca m-2 s-1',0) + call ncdefvar3d(SRF_DIC(iogrp),cmpflg,'p','srfdissic', & + & 'Surface dissolved inorganic carbon',' ','mol C m-3',0) + call ncdefvar3d(SRF_ALKALI(iogrp),cmpflg,'p','srftalk', & + & 'Surface alkalinity',' ','eq m-3',0) + call ncdefvar3d(SRF_PHOSPH(iogrp),cmpflg,'p','srfpo4', & + & 'Surface phosphorus',' ','mol P m-3',0) + call ncdefvar3d(SRF_OXYGEN(iogrp),cmpflg,'p','srfo2', & + & 'Surface oxygen',' ','mol O2 m-3',0) + call ncdefvar3d(SRF_ANO3(iogrp),cmpflg,'p','srfno3', & + & 'Surface nitrate',' ','mol N m-3',0) + call ncdefvar3d(SRF_SILICA(iogrp),cmpflg,'p','srfsi', & + & 'Surface silicate',' ','mol Si m-3',0) + call ncdefvar3d(SRF_IRON(iogrp),cmpflg,'p','srfdfe', & + & 'Surface dissolved iron',' ','mol Fe m-3',0) + call ncdefvar3d(SRF_PHYTO(iogrp),cmpflg,'p','srfphyc', & + & 'Surface phytoplankton',' ','mol P m-3',0) + call ncdefvar3d(INT_PHOSY(iogrp),cmpflg,'p','ppint', & + & 'Integrated primary production',' ','mol C m-2 s-1',0) + call ncdefvar3d(INT_NFIX(iogrp),cmpflg,'p','nfixint', & + & 'Integrated nitrogen fixation',' ','mol N m-2 s-1',0) + call ncdefvar3d(INT_DNIT(iogrp),cmpflg,'p','dnitint', & + & 'Integrated denitrification',' ','mol N m-2 s-1',0) + call ncdefvar3d(FLX_CAR0100(iogrp),cmpflg,'p','carflx0100', & + & 'C flux at 100m',' ','mol C m-2 s-1',0) + call ncdefvar3d(FLX_CAR0500(iogrp),cmpflg,'p','carflx0500', & + & 'C flux at 500m',' ','mol C m-2 s-1',0) + call ncdefvar3d(FLX_CAR1000(iogrp),cmpflg,'p','carflx1000', & + & 'C flux at 1000m',' ','mol C m-2 s-1',0) + call ncdefvar3d(FLX_CAR2000(iogrp),cmpflg,'p','carflx2000', & + & 'C flux at 2000m',' ','mol C m-2 s-1',0) + call ncdefvar3d(FLX_CAR4000(iogrp),cmpflg,'p','carflx4000', & + & 'C flux at 4000m',' ','mol C m-2 s-1',0) + call ncdefvar3d(FLX_CAR_BOT(iogrp),cmpflg,'p','carflx_bot', & + & 'C flux to sediment',' ','mol C m-2 s-1',0) + call ncdefvar3d(FLX_BSI0100(iogrp),cmpflg,'p','bsiflx0100', & + & 'Opal flux at 100m',' ','mol Si m-2 s-1',0) + call ncdefvar3d(FLX_BSI0500(iogrp),cmpflg,'p','bsiflx0500', & + & 'Opal flux at 500m',' ','mol Si m-2 s-1',0) + call ncdefvar3d(FLX_BSI1000(iogrp),cmpflg,'p','bsiflx1000', & + & 'Opal flux at 1000m',' ','mol Si m-2 s-1',0) + call ncdefvar3d(FLX_BSI2000(iogrp),cmpflg,'p','bsiflx2000', & + & 'Opal flux at 2000m',' ','mol Si m-2 s-1',0) + call ncdefvar3d(FLX_BSI4000(iogrp),cmpflg,'p','bsiflx4000', & + & 'Opal flux at 4000m',' ','mol Si m-2 s-1',0) + call ncdefvar3d(FLX_BSI_BOT(iogrp),cmpflg,'p','bsiflx_bot', & + & 'Opal flux to sediment',' ','mol Si m-2 s-1',0) + call ncdefvar3d(FLX_CAL0100(iogrp),cmpflg,'p','calflx0100', & + & 'CaCO3 flux at 100m',' ','mol Ca m-2 s-1',0) + call ncdefvar3d(FLX_CAL0500(iogrp),cmpflg,'p','calflx0500', & + & 'CaCO3 flux at 500m',' ','mol Ca m-2 s-1',0) + call ncdefvar3d(FLX_CAL1000(iogrp),cmpflg,'p','calflx1000', & + & 'CaCO3 flux at 1000m',' ','mol Ca m-2 s-1',0) + call ncdefvar3d(FLX_CAL2000(iogrp),cmpflg,'p','calflx2000', & + & 'CaCO3 flux at 2000m',' ','mol Ca m-2 s-1',0) + call ncdefvar3d(FLX_CAL4000(iogrp),cmpflg,'p','calflx4000', & + & 'CaCO3 flux at 4000m',' ','mol Ca m-2 s-1',0) + call ncdefvar3d(FLX_CAL_BOT(iogrp),cmpflg,'p','calflx_bot', & + & 'CaCO3 flux to sediment',' ','mol Ca m-2 s-1',0) + call ncdefvar3d(SRF_N2OFX(iogrp),cmpflg,'p','n2oflux', & + & 'N2O flux',' ','mol N2O m-2 s-1',0) #ifndef sedbypass - call ncdefvar3d(FLX_SEDIFFIC(iogrp),cmpflg,'p','sedfdic', - . 'diffusive DIC flux to sediment (positive downwards)', - . ' ','mol C m-2 s-1',0) - call ncdefvar3d(FLX_SEDIFFAL(iogrp),cmpflg,'p','sedfalk', - . 'diffusive alkalinity flux to sediment (positive downwards)', - . ' ','mol m-2 s-1',0) - call ncdefvar3d(FLX_SEDIFFPH(iogrp),cmpflg,'p','sedfpho', - . 'diffusive phosphate flux to sediment (positive downwards)', - . ' ','mol m-2 s-1',0) - call ncdefvar3d(FLX_SEDIFFOX(iogrp),cmpflg,'p','sedfox', - . 'diffusive oxygen flux to sediment (positive downwards)', - . ' ','mol O2 m-2 s-1',0) - call ncdefvar3d(FLX_SEDIFFN2(iogrp),cmpflg,'p','sedfn2', - . 'diffusive N2 flux to sediment (positive downwards)', - . ' ','mol N2 m-2 s-1',0) - call ncdefvar3d(FLX_SEDIFFNO3(iogrp),cmpflg,'p','sedfno3', - . 'diffusive nitrate flux to sediment (positive downwards)', - . ' ','mol NO3 m-2 s-1',0) - call ncdefvar3d(FLX_SEDIFFSI(iogrp),cmpflg,'p','sedfsi', - . 'diffusive silica flux to sediment (positive downwards)', - . ' ','mol Si m-2 s-1',0) + call ncdefvar3d(FLX_SEDIFFIC(iogrp),cmpflg,'p','sedfdic', & + & 'diffusive DIC flux to sediment (positive downwards)', & + & ' ','mol C m-2 s-1',0) + call ncdefvar3d(FLX_SEDIFFAL(iogrp),cmpflg,'p','sedfalk', & + & 'diffusive alkalinity flux to sediment (positive downwards)', & + & ' ','mol m-2 s-1',0) + call ncdefvar3d(FLX_SEDIFFPH(iogrp),cmpflg,'p','sedfpho', & + & 'diffusive phosphate flux to sediment (positive downwards)', & + & ' ','mol m-2 s-1',0) + call ncdefvar3d(FLX_SEDIFFOX(iogrp),cmpflg,'p','sedfox', & + & 'diffusive oxygen flux to sediment (positive downwards)', & + & ' ','mol O2 m-2 s-1',0) + call ncdefvar3d(FLX_SEDIFFN2(iogrp),cmpflg,'p','sedfn2', & + & 'diffusive N2 flux to sediment (positive downwards)', & + & ' ','mol N2 m-2 s-1',0) + call ncdefvar3d(FLX_SEDIFFNO3(iogrp),cmpflg,'p','sedfno3', & + & 'diffusive nitrate flux to sediment (positive downwards)', & + & ' ','mol NO3 m-2 s-1',0) + call ncdefvar3d(FLX_SEDIFFSI(iogrp),cmpflg,'p','sedfsi', & + & 'diffusive silica flux to sediment (positive downwards)', & + & ' ','mol Si m-2 s-1',0) #endif #ifdef cisonew - call ncdefvar3d(SRF_CO213FXD(iogrp),cmpflg,'p','co213fxd', - . 'Downward 13CO2 flux',' ','kg C m-2 s-1',0) - call ncdefvar3d(SRF_CO213FXU(iogrp),cmpflg,'p','co213fxu', - . 'Upward 13CO2 flux',' ','kg C m-2 s-1',0) - call ncdefvar3d(SRF_CO214FXD(iogrp),cmpflg,'p','co214fxd', - . 'Downward 14CO2 flux',' ','kg C m-2 s-1',0) - call ncdefvar3d(SRF_CO214FXU(iogrp),cmpflg,'p','co214fxu', - . 'Upward 14CO2 flux',' ','kg C m-2 s-1',0) + call ncdefvar3d(SRF_CO213FXD(iogrp),cmpflg,'p','co213fxd', & + & 'Downward 13CO2 flux',' ','kg C m-2 s-1',0) + call ncdefvar3d(SRF_CO213FXU(iogrp),cmpflg,'p','co213fxu', & + & 'Upward 13CO2 flux',' ','kg C m-2 s-1',0) + call ncdefvar3d(SRF_CO214FXD(iogrp),cmpflg,'p','co214fxd', & + & 'Downward 14CO2 flux',' ','kg C m-2 s-1',0) + call ncdefvar3d(SRF_CO214FXU(iogrp),cmpflg,'p','co214fxu', & + & 'Upward 14CO2 flux',' ','kg C m-2 s-1',0) #endif #ifdef CFC - call ncdefvar3d(SRF_CFC11(iogrp),cmpflg,'p','cfc11flux', - . 'CFC-11 flux',' ','mol CFC12 m-2 s-1',0) - call ncdefvar3d(SRF_CFC12(iogrp), - . cmpflg,'p','cfc12flux','CFC-12 flux',' ','mol CFC12 m-2 s-1',0) - call ncdefvar3d(SRF_SF6(iogrp), - . cmpflg,'p','sf6flux','SF-6 flux',' ','mol SF6 m-2 s-1',0) + call ncdefvar3d(SRF_CFC11(iogrp),cmpflg,'p','cfc11flux', & + & 'CFC-11 flux',' ','mol CFC12 m-2 s-1',0) + call ncdefvar3d(SRF_CFC12(iogrp), & + & cmpflg,'p','cfc12flux','CFC-12 flux',' ','mol CFC12 m-2 s-1',0) + call ncdefvar3d(SRF_SF6(iogrp), & + & cmpflg,'p','sf6flux','SF-6 flux',' ','mol SF6 m-2 s-1',0) #endif #ifdef natDIC - call ncdefvar3d(SRF_NATDIC(iogrp),cmpflg,'p','srfnatdissic', - . 'Surface natural dissolved inorganic carbon',' ','mol C m-3',0) - call ncdefvar3d(SRF_NATALKALI(iogrp),cmpflg,'p','srfnattalk', - . 'Surface natural alkalinity',' ','eq m-3',0) - call ncdefvar3d(SRF_NATPCO2(iogrp),cmpflg,'p', - . 'natpco2','Surface natural PCO2',' ','uatm',0) - call ncdefvar3d(SRF_NATCO2FX(iogrp), - . cmpflg,'p','natco2fx','Natural CO2 flux',' ','kg C m-2 s-1',0) + call ncdefvar3d(SRF_NATDIC(iogrp),cmpflg,'p','srfnatdissic', & + & 'Surface natural dissolved inorganic carbon',' ','mol C m-3',0) + call ncdefvar3d(SRF_NATALKALI(iogrp),cmpflg,'p','srfnattalk', & + & 'Surface natural alkalinity',' ','eq m-3',0) + call ncdefvar3d(SRF_NATPCO2(iogrp),cmpflg,'p', & + & 'natpco2','Surface natural PCO2',' ','uatm',0) + call ncdefvar3d(SRF_NATCO2FX(iogrp), & + & cmpflg,'p','natco2fx','Natural CO2 flux',' ','kg C m-2 s-1',0) #endif #ifdef BROMO - call ncdefvar3d(SRF_BROMO(iogrp),cmpflg,'p','srfbromo', - . 'Surface bromoform',' ','mol CHBr3 m-3',0) - call ncdefvar3d(SRF_BROMOfx(iogrp),cmpflg,'p','bromofx', - . 'Surface bromoform flux',' ','mol CHBr3 m-2 s-1',0) - call ncdefvar3d(INT_BROMOPRO(iogrp),cmpflg,'p','intbromoprod', - . 'Integrated bromoform production',' ','mol CHBr3 m-2 s-1',0) - call ncdefvar3d(INT_BROMOUV(iogrp),cmpflg,'p','intbromouv', - . 'Integrated bromoform loss to photolysis',' ', - . 'mol CHBr3 m-2 s-1',0) - call ncdefvar3d(SRF_ATMBROMO(iogrp),cmpflg,'p', - . 'atmbromo','Atmospheric bromoform',' ','ppt',0) + call ncdefvar3d(SRF_BROMO(iogrp),cmpflg,'p','srfbromo', & + & 'Surface bromoform',' ','mol CHBr3 m-3',0) + call ncdefvar3d(SRF_BROMOfx(iogrp),cmpflg,'p','bromofx', & + & 'Surface bromoform flux',' ','mol CHBr3 m-2 s-1',0) + call ncdefvar3d(INT_BROMOPRO(iogrp),cmpflg,'p','intbromoprod', & + & 'Integrated bromoform production',' ','mol CHBr3 m-2 s-1',0) + call ncdefvar3d(INT_BROMOUV(iogrp),cmpflg,'p','intbromouv', & + & 'Integrated bromoform loss to photolysis',' ', & + & 'mol CHBr3 m-2 s-1',0) + call ncdefvar3d(SRF_ATMBROMO(iogrp),cmpflg,'p', & + & 'atmbromo','Atmospheric bromoform',' ','ppt',0) #endif - call ncdefvar3d(SRF_ATMCO2(iogrp),cmpflg,'p', - . 'atmco2','Atmospheric CO2',' ','ppm',0) + call ncdefvar3d(SRF_ATMCO2(iogrp),cmpflg,'p', & + & 'atmco2','Atmospheric CO2',' ','ppm',0) #if defined(BOXATM) - call ncdefvar3d(SRF_ATMO2(iogrp),cmpflg,'p', - . 'atmo2','Atmospheric O2',' ','ppm',0) - call ncdefvar3d(SRF_ATMN2(iogrp),cmpflg,'p', - . 'atmn2','Atmospheric N2',' ','ppm',0) -#endif + call ncdefvar3d(SRF_ATMO2(iogrp),cmpflg,'p', & + & 'atmo2','Atmospheric O2',' ','ppm',0) + call ncdefvar3d(SRF_ATMN2(iogrp),cmpflg,'p', & + & 'atmn2','Atmospheric N2',' ','ppm',0) +#endif #ifdef cisonew - call ncdefvar3d(SRF_ATMC13(iogrp),cmpflg,'p', - . 'atmc13','Atmospheric 13CO2',' ','ppm',0) - call ncdefvar3d(SRF_ATMC14(iogrp),cmpflg,'p', - . 'atmc14','Atmospheric 14CO2',' ','ppm',0) -#endif -c -c --- define 3d layer fields - call ncdefvar3d(LYR_DP(iogrp),cmpflg,'p', - . 'pddpo','Layer thickness',' ','m',1) - call ncdefvar3d(LYR_DIC(iogrp),cmpflg,'p', - . 'dissic','Dissolved inorganic carbon',' ','mol C m-3',1) - call ncdefvar3d(LYR_ALKALI(iogrp),cmpflg,'p', - . 'talk','Alkalinity',' ','eq m-3',1) - call ncdefvar3d(LYR_PHOSPH(iogrp),cmpflg,'p', - . 'po4','Phosphorus',' ','mol P m-3',1) - call ncdefvar3d(LYR_OXYGEN(iogrp),cmpflg,'p', - . 'o2','Oxygen',' ','mol O2 m-3',1) - call ncdefvar3d(LYR_ANO3(iogrp),cmpflg,'p', - . 'no3','Nitrate',' ','mol N m-3',1) - call ncdefvar3d(LYR_SILICA(iogrp),cmpflg,'p', - . 'si','Silicate',' ','mol Si m-3',1) - call ncdefvar3d(LYR_DOC(iogrp),cmpflg,'p', - . 'dissoc','Dissolved organic carbon',' ','mol P m-3',1) - call ncdefvar3d(LYR_PHYTO(iogrp),cmpflg,'p', - . 'phyc','Phytoplankton',' ','mol P m-3',1) - call ncdefvar3d(LYR_GRAZER(iogrp),cmpflg,'p', - . 'zooc','Zooplankton',' ','mol P m-3',1) - call ncdefvar3d(LYR_POC(iogrp),cmpflg,'p', - . 'detoc','Detritus',' ','mol P m-3',1) - call ncdefvar3d(LYR_CALC(iogrp),cmpflg,'p', - . 'calc','CaCO3 shells',' ','mol C m-3',1) - call ncdefvar3d(LYR_OPAL(iogrp),cmpflg,'p', - . 'opal','Opal shells',' ','mol Si m-3',1) - call ncdefvar3d(LYR_IRON(iogrp),cmpflg,'p', - . 'dfe','Dissolved iron',' ','mol Fe m-3',1) - call ncdefvar3d(LYR_PHOSY(iogrp),cmpflg,'p', - . 'pp','Primary production',' ','mol C m-3 s-1',1) - call ncdefvar3d(LYR_CO3(iogrp),cmpflg,'p', - . 'co3','Carbonate ions',' ','mol C m-3',1) - call ncdefvar3d(LYR_PH(iogrp),cmpflg,'p', - . 'ph','pH',' ','-log10([h+])',1) - call ncdefvar3d(LYR_OMEGAA(iogrp),cmpflg,'p', - . 'omegaa','OmegaA',' ','1',1) - call ncdefvar3d(LYR_OMEGAC(iogrp),cmpflg,'p', - . 'omegac','OmegaC',' ','1',1) - call ncdefvar3d(LYR_N2O(iogrp),cmpflg,'p', - . 'n2o','N2O',' ','mol N2O m-3',1) - call ncdefvar3d(LYR_PREFO2(iogrp),cmpflg,'p', - . 'p_o2','Preformed oxygen',' ','mol O2 m-3',1) - call ncdefvar3d(LYR_O2SAT(iogrp),cmpflg,'p', - . 'satoxy','Saturated oxygen',' ','mol O2 m-3',1) - call ncdefvar3d(LYR_PREFPO4(iogrp),cmpflg,'p', - . 'p_po4','Preformed phosphorus',' ','mol P m-3',1) - call ncdefvar3d(LYR_PREFALK(iogrp),cmpflg,'p', - . 'p_talk','Preformed alkalinity',' ','eq m-3',1) - call ncdefvar3d(LYR_PREFDIC(iogrp),cmpflg,'p', - . 'p_dic','Preformed DIC',' ','mol C m-3',1) - call ncdefvar3d(LYR_DICSAT(iogrp),cmpflg,'p', - . 'sat_dic','Saturated DIC',' ','mol C m-3',1) + call ncdefvar3d(SRF_ATMC13(iogrp),cmpflg,'p', & + & 'atmc13','Atmospheric 13CO2',' ','ppm',0) + call ncdefvar3d(SRF_ATMC14(iogrp),cmpflg,'p', & + & 'atmc14','Atmospheric 14CO2',' ','ppm',0) +#endif + + ! --- define 3d layer fields + call ncdefvar3d(LYR_DP(iogrp),cmpflg,'p', & + & 'pddpo','Layer thickness',' ','m',1) + call ncdefvar3d(LYR_DIC(iogrp),cmpflg,'p', & + & 'dissic','Dissolved inorganic carbon',' ','mol C m-3',1) + call ncdefvar3d(LYR_ALKALI(iogrp),cmpflg,'p', & + & 'talk','Alkalinity',' ','eq m-3',1) + call ncdefvar3d(LYR_PHOSPH(iogrp),cmpflg,'p', & + & 'po4','Phosphorus',' ','mol P m-3',1) + call ncdefvar3d(LYR_OXYGEN(iogrp),cmpflg,'p', & + & 'o2','Oxygen',' ','mol O2 m-3',1) + call ncdefvar3d(LYR_ANO3(iogrp),cmpflg,'p', & + & 'no3','Nitrate',' ','mol N m-3',1) + call ncdefvar3d(LYR_SILICA(iogrp),cmpflg,'p', & + & 'si','Silicate',' ','mol Si m-3',1) + call ncdefvar3d(LYR_DOC(iogrp),cmpflg,'p', & + & 'dissoc','Dissolved organic carbon',' ','mol P m-3',1) + call ncdefvar3d(LYR_PHYTO(iogrp),cmpflg,'p', & + & 'phyc','Phytoplankton',' ','mol P m-3',1) + call ncdefvar3d(LYR_GRAZER(iogrp),cmpflg,'p', & + & 'zooc','Zooplankton',' ','mol P m-3',1) + call ncdefvar3d(LYR_POC(iogrp),cmpflg,'p', & + & 'detoc','Detritus',' ','mol P m-3',1) + call ncdefvar3d(LYR_CALC(iogrp),cmpflg,'p', & + & 'calc','CaCO3 shells',' ','mol C m-3',1) + call ncdefvar3d(LYR_OPAL(iogrp),cmpflg,'p', & + & 'opal','Opal shells',' ','mol Si m-3',1) + call ncdefvar3d(LYR_IRON(iogrp),cmpflg,'p', & + & 'dfe','Dissolved iron',' ','mol Fe m-3',1) + call ncdefvar3d(LYR_PHOSY(iogrp),cmpflg,'p', & + & 'pp','Primary production',' ','mol C m-3 s-1',1) + call ncdefvar3d(LYR_CO3(iogrp),cmpflg,'p', & + & 'co3','Carbonate ions',' ','mol C m-3',1) + call ncdefvar3d(LYR_PH(iogrp),cmpflg,'p', & + & 'ph','pH',' ','-log10([h+])',1) + call ncdefvar3d(LYR_OMEGAA(iogrp),cmpflg,'p', & + & 'omegaa','OmegaA',' ','1',1) + call ncdefvar3d(LYR_OMEGAC(iogrp),cmpflg,'p', & + & 'omegac','OmegaC',' ','1',1) + call ncdefvar3d(LYR_N2O(iogrp),cmpflg,'p', & + & 'n2o','N2O',' ','mol N2O m-3',1) + call ncdefvar3d(LYR_PREFO2(iogrp),cmpflg,'p', & + & 'p_o2','Preformed oxygen',' ','mol O2 m-3',1) + call ncdefvar3d(LYR_O2SAT(iogrp),cmpflg,'p', & + & 'satoxy','Saturated oxygen',' ','mol O2 m-3',1) + call ncdefvar3d(LYR_PREFPO4(iogrp),cmpflg,'p', & + & 'p_po4','Preformed phosphorus',' ','mol P m-3',1) + call ncdefvar3d(LYR_PREFALK(iogrp),cmpflg,'p', & + & 'p_talk','Preformed alkalinity',' ','eq m-3',1) + call ncdefvar3d(LYR_PREFDIC(iogrp),cmpflg,'p', & + & 'p_dic','Preformed DIC',' ','mol C m-3',1) + call ncdefvar3d(LYR_DICSAT(iogrp),cmpflg,'p', & + & 'sat_dic','Saturated DIC',' ','mol C m-3',1) #ifdef cisonew - call ncdefvar3d(LYR_DIC13(iogrp),cmpflg,'p', - . 'dissic13','Dissolved C13',' ','mol 13C m-3',1) - call ncdefvar3d(LYR_DIC14(iogrp),cmpflg,'p', - . 'dissic14','Dissolved C14',' ','mol 14C m-3',1) - call ncdefvar3d(LYR_D13C(iogrp),cmpflg,'p', - . 'delta13c','delta13C of DIC',' ','permil',1) - call ncdefvar3d(LYR_D14C(iogrp),cmpflg,'p', - . 'delta14c','delta14C of DIC',' ','permil',1) - call ncdefvar3d(LYR_BIGD14C(iogrp),cmpflg,'p', - . 'bigdelta14c','big delta14C of DIC',' ','permil',1) - call ncdefvar3d(LYR_POC13(iogrp),cmpflg,'p', - . 'detoc13','Detritus13',' ','mol P m-3',1) - call ncdefvar3d(LYR_DOC13(iogrp),cmpflg,'p', - . 'dissoc13','Dissolved organic carbon13',' ','mol P m-3',1) - call ncdefvar3d(LYR_CALC13(iogrp),cmpflg,'p', - . 'calc13','Ca13CO3 shells',' ','mol 13C m-3',1) - call ncdefvar3d(LYR_PHYTO13(iogrp),cmpflg,'p', - . 'phyc13','Phytoplankton13',' ','mol P m-3',1) - call ncdefvar3d(LYR_GRAZER13(iogrp),cmpflg,'p', - . 'zooc13','Zooplankton13',' ','mol P m-3',1) + call ncdefvar3d(LYR_DIC13(iogrp),cmpflg,'p', & + & 'dissic13','Dissolved C13',' ','mol 13C m-3',1) + call ncdefvar3d(LYR_DIC14(iogrp),cmpflg,'p', & + & 'dissic14','Dissolved C14',' ','mol 14C m-3',1) + call ncdefvar3d(LYR_D13C(iogrp),cmpflg,'p', & + & 'delta13c','delta13C of DIC',' ','permil',1) + call ncdefvar3d(LYR_D14C(iogrp),cmpflg,'p', & + & 'delta14c','delta14C of DIC',' ','permil',1) + call ncdefvar3d(LYR_BIGD14C(iogrp),cmpflg,'p', & + & 'bigdelta14c','big delta14C of DIC',' ','permil',1) + call ncdefvar3d(LYR_POC13(iogrp),cmpflg,'p', & + & 'detoc13','Detritus13',' ','mol P m-3',1) + call ncdefvar3d(LYR_DOC13(iogrp),cmpflg,'p', & + & 'dissoc13','Dissolved organic carbon13',' ','mol P m-3',1) + call ncdefvar3d(LYR_CALC13(iogrp),cmpflg,'p', & + & 'calc13','Ca13CO3 shells',' ','mol 13C m-3',1) + call ncdefvar3d(LYR_PHYTO13(iogrp),cmpflg,'p', & + & 'phyc13','Phytoplankton13',' ','mol P m-3',1) + call ncdefvar3d(LYR_GRAZER13(iogrp),cmpflg,'p', & + & 'zooc13','Zooplankton13',' ','mol P m-3',1) #endif #ifdef AGG - call ncdefvar3d(LYR_NOS(iogrp),cmpflg,'p', - . 'nos','Marine snow aggregates per cm^3 sea water',' ','1/cm^3',1) - call ncdefvar3d(LYR_WPHY(iogrp),cmpflg,'p', - . 'wphy','Av. mass sinking speed of marine snow',' ','m/day',1) - call ncdefvar3d(LYR_WNOS(iogrp),cmpflg,'p', - . 'wnos','Av. number sinking speed of marine snow',' ','m/day',1) - call ncdefvar3d(LYR_EPS(iogrp),cmpflg,'p', - . 'eps','Av. size distribution exponent',' ','-',1) - call ncdefvar3d(LYR_ASIZE(iogrp),cmpflg,'p', - .'asize','Av. size of marine snow aggregates',' ','nb. of cells',1) + call ncdefvar3d(LYR_NOS(iogrp),cmpflg,'p', & + & 'nos','Marine snow aggregates per cm^3 sea water',' ','1/cm^3',1) + call ncdefvar3d(LYR_WPHY(iogrp),cmpflg,'p', & + & 'wphy','Av. mass sinking speed of marine snow',' ','m/day',1) + call ncdefvar3d(LYR_WNOS(iogrp),cmpflg,'p', & + & 'wnos','Av. number sinking speed of marine snow',' ','m/day',1) + call ncdefvar3d(LYR_EPS(iogrp),cmpflg,'p', & + & 'eps','Av. size distribution exponent',' ','-',1) + call ncdefvar3d(LYR_ASIZE(iogrp),cmpflg,'p', & + & 'asize','Av. size of marine snow aggregates',' ','nb. of cells',1) #endif #ifdef CFC - call ncdefvar3d(LYR_CFC11(iogrp),cmpflg,'p', - . 'cfc11','CFC-11',' ','mol cfc11 m-3',1) - call ncdefvar3d(LYR_CFC12(iogrp),cmpflg,'p', - . 'cfc12','CFC-12',' ','mol cfc12 m-3',1) - call ncdefvar3d(LYR_SF6(iogrp),cmpflg,'p', - . 'sf6','SF-6',' ','mol sf6 m-3',1) + call ncdefvar3d(LYR_CFC11(iogrp),cmpflg,'p', & + & 'cfc11','CFC-11',' ','mol cfc11 m-3',1) + call ncdefvar3d(LYR_CFC12(iogrp),cmpflg,'p', & + & 'cfc12','CFC-12',' ','mol cfc12 m-3',1) + call ncdefvar3d(LYR_SF6(iogrp),cmpflg,'p', & + & 'sf6','SF-6',' ','mol sf6 m-3',1) #endif #ifdef natDIC - call ncdefvar3d(LYR_NATCO3(iogrp),cmpflg,'p', - . 'natco3','Natural Carbonate ions',' ','mol C m-3',1) - call ncdefvar3d(LYR_NATALKALI(iogrp),cmpflg,'p','nattalk', - . 'Natural alkalinity',' ','eq m-3',1) - call ncdefvar3d(LYR_NATDIC(iogrp),cmpflg,'p','natdissic', - . 'Natural dissolved inorganic carbon',' ','mol C m-3',1) - call ncdefvar3d(LYR_NATCALC(iogrp),cmpflg,'p','natcalc', - . 'Natural CaCO3',' ','mol C m-3',1) - call ncdefvar3d(LYR_NATPH(iogrp),cmpflg,'p', - . 'natph','Natural pH',' ','-log10([h+])',1) - call ncdefvar3d(LYR_NATOMEGAA(iogrp),cmpflg,'p','natomegaa', - . 'Natural OmegaA',' ','1',1) - call ncdefvar3d(LYR_NATOMEGAC(iogrp),cmpflg,'p','natomegac', - . 'Natural OmegaC',' ','1',1) + call ncdefvar3d(LYR_NATCO3(iogrp),cmpflg,'p', & + & 'natco3','Natural Carbonate ions',' ','mol C m-3',1) + call ncdefvar3d(LYR_NATALKALI(iogrp),cmpflg,'p','nattalk', & + & 'Natural alkalinity',' ','eq m-3',1) + call ncdefvar3d(LYR_NATDIC(iogrp),cmpflg,'p','natdissic', & + & 'Natural dissolved inorganic carbon',' ','mol C m-3',1) + call ncdefvar3d(LYR_NATCALC(iogrp),cmpflg,'p','natcalc', & + & 'Natural CaCO3',' ','mol C m-3',1) + call ncdefvar3d(LYR_NATPH(iogrp),cmpflg,'p', & + & 'natph','Natural pH',' ','-log10([h+])',1) + call ncdefvar3d(LYR_NATOMEGAA(iogrp),cmpflg,'p','natomegaa', & + & 'Natural OmegaA',' ','1',1) + call ncdefvar3d(LYR_NATOMEGAC(iogrp),cmpflg,'p','natomegac', & + & 'Natural OmegaC',' ','1',1) #endif #ifdef BROMO - call ncdefvar3d(LYR_BROMO(iogrp),cmpflg,'p', - . 'bromo','Bromoform',' ','mol CHBr3 m-3',1) + call ncdefvar3d(LYR_BROMO(iogrp),cmpflg,'p', & + & 'bromo','Bromoform',' ','mol CHBr3 m-3',1) #endif -c -c --- define 3d level fields - call ncdefvar3d(LVL_DIC(iogrp),cmpflg,'p', - . 'dissiclvl','Dissolved inorganic carbon',' ','mol C m-3',2) - call ncdefvar3d(LVL_ALKALI(iogrp),cmpflg,'p', - . 'talklvl','Alkalinity',' ','eq m-3',2) - call ncdefvar3d(LVL_PHOSPH(iogrp),cmpflg,'p', - . 'po4lvl','Phosphorus',' ','mol P m-3',2) - call ncdefvar3d(LVL_OXYGEN(iogrp),cmpflg,'p', - . 'o2lvl','Oxygen',' ','mol O2 m-3',2) - call ncdefvar3d(LVL_ANO3(iogrp),cmpflg,'p', - . 'no3lvl','Nitrate',' ','mol N m-3',2) - call ncdefvar3d(LVL_SILICA(iogrp),cmpflg,'p', - . 'silvl','Silicate',' ','mol Si m-3',2) - call ncdefvar3d(LVL_DOC(iogrp),cmpflg,'p', - . 'dissoclvl','Dissolved organic carbon',' ','mol P m-3',2) - call ncdefvar3d(LVL_PHYTO(iogrp),cmpflg,'p', - . 'phyclvl','Phytoplankton',' ','mol P m-3',2) - call ncdefvar3d(LVL_GRAZER(iogrp),cmpflg,'p', - . 'zooclvl','Zooplankton',' ','mol P m-3',2) - call ncdefvar3d(LVL_POC(iogrp),cmpflg,'p', - . 'detoclvl','Detritus',' ','mol P m-3',2) - call ncdefvar3d(LVL_CALC(iogrp),cmpflg,'p', - . 'calclvl','CaCO3 shells',' ','mol C m-3',2) - call ncdefvar3d(LVL_OPAL(iogrp),cmpflg,'p', - . 'opallvl','Opal shells',' ','mol Si m-3',2) - call ncdefvar3d(LVL_IRON(iogrp),cmpflg,'p', - . 'dfelvl','Dissolved iron',' ','mol Fe m-3',2) - call ncdefvar3d(LVL_PHOSY(iogrp),cmpflg,'p', - . 'pplvl','Primary production',' ','mol C m-3 s-1',2) - call ncdefvar3d(LVL_CO3(iogrp),cmpflg,'p', - . 'co3lvl','Carbonate ions',' ','mol C m-3',2) - call ncdefvar3d(LVL_PH(iogrp),cmpflg,'p', - . 'phlvl','pH',' ','-log10([h+])',2) - call ncdefvar3d(LVL_OMEGAA(iogrp),cmpflg,'p', - . 'omegaalvl','OmegaA',' ','1',2) - call ncdefvar3d(LVL_OMEGAC(iogrp),cmpflg,'p', - . 'omegaclvl','OmegaC',' ','1',2) - call ncdefvar3d(LVL_N2O(iogrp),cmpflg,'p', - . 'n2olvl','N2O',' ','mol N2O m-3',2) - call ncdefvar3d(LVL_PREFO2(iogrp),cmpflg,'p', - . 'p_o2lvl','Preformed oxygen',' ','mol O2 m-3',2) - call ncdefvar3d(LVL_O2SAT(iogrp),cmpflg,'p', - . 'satoxylvl','Saturated oxygen',' ','mol O2 m-3',2) - call ncdefvar3d(LVL_PREFPO4(iogrp),cmpflg,'p', - . 'p_po4lvl','Preformed phosphorus',' ','mol P m-3',2) - call ncdefvar3d(LVL_PREFALK(iogrp),cmpflg,'p', - . 'p_talklvl','Preformed alkalinity',' ','eq m-3',2) - call ncdefvar3d(LVL_PREFDIC(iogrp),cmpflg,'p', - . 'p_diclvl','Preformed DIC',' ','mol C m-3',2) - call ncdefvar3d(LVL_DICSAT(iogrp),cmpflg,'p', - . 'sat_diclvl','Saturated DIC',' ','mol C m-3',2) + ! --- define 3d level fields + call ncdefvar3d(LVL_DIC(iogrp),cmpflg,'p', & + & 'dissiclvl','Dissolved inorganic carbon',' ','mol C m-3',2) + call ncdefvar3d(LVL_ALKALI(iogrp),cmpflg,'p', & + & 'talklvl','Alkalinity',' ','eq m-3',2) + call ncdefvar3d(LVL_PHOSPH(iogrp),cmpflg,'p', & + & 'po4lvl','Phosphorus',' ','mol P m-3',2) + call ncdefvar3d(LVL_OXYGEN(iogrp),cmpflg,'p', & + & 'o2lvl','Oxygen',' ','mol O2 m-3',2) + call ncdefvar3d(LVL_ANO3(iogrp),cmpflg,'p', & + & 'no3lvl','Nitrate',' ','mol N m-3',2) + call ncdefvar3d(LVL_SILICA(iogrp),cmpflg,'p', & + & 'silvl','Silicate',' ','mol Si m-3',2) + call ncdefvar3d(LVL_DOC(iogrp),cmpflg,'p', & + & 'dissoclvl','Dissolved organic carbon',' ','mol P m-3',2) + call ncdefvar3d(LVL_PHYTO(iogrp),cmpflg,'p', & + & 'phyclvl','Phytoplankton',' ','mol P m-3',2) + call ncdefvar3d(LVL_GRAZER(iogrp),cmpflg,'p', & + & 'zooclvl','Zooplankton',' ','mol P m-3',2) + call ncdefvar3d(LVL_POC(iogrp),cmpflg,'p', & + & 'detoclvl','Detritus',' ','mol P m-3',2) + call ncdefvar3d(LVL_CALC(iogrp),cmpflg,'p', & + & 'calclvl','CaCO3 shells',' ','mol C m-3',2) + call ncdefvar3d(LVL_OPAL(iogrp),cmpflg,'p', & + & 'opallvl','Opal shells',' ','mol Si m-3',2) + call ncdefvar3d(LVL_IRON(iogrp),cmpflg,'p', & + & 'dfelvl','Dissolved iron',' ','mol Fe m-3',2) + call ncdefvar3d(LVL_PHOSY(iogrp),cmpflg,'p', & + & 'pplvl','Primary production',' ','mol C m-3 s-1',2) + call ncdefvar3d(LVL_CO3(iogrp),cmpflg,'p', & + & 'co3lvl','Carbonate ions',' ','mol C m-3',2) + call ncdefvar3d(LVL_PH(iogrp),cmpflg,'p', & + & 'phlvl','pH',' ','-log10([h+])',2) + call ncdefvar3d(LVL_OMEGAA(iogrp),cmpflg,'p', & + & 'omegaalvl','OmegaA',' ','1',2) + call ncdefvar3d(LVL_OMEGAC(iogrp),cmpflg,'p', & + & 'omegaclvl','OmegaC',' ','1',2) + call ncdefvar3d(LVL_N2O(iogrp),cmpflg,'p', & + & 'n2olvl','N2O',' ','mol N2O m-3',2) + call ncdefvar3d(LVL_PREFO2(iogrp),cmpflg,'p', & + & 'p_o2lvl','Preformed oxygen',' ','mol O2 m-3',2) + call ncdefvar3d(LVL_O2SAT(iogrp),cmpflg,'p', & + & 'satoxylvl','Saturated oxygen',' ','mol O2 m-3',2) + call ncdefvar3d(LVL_PREFPO4(iogrp),cmpflg,'p', & + & 'p_po4lvl','Preformed phosphorus',' ','mol P m-3',2) + call ncdefvar3d(LVL_PREFALK(iogrp),cmpflg,'p', & + & 'p_talklvl','Preformed alkalinity',' ','eq m-3',2) + call ncdefvar3d(LVL_PREFDIC(iogrp),cmpflg,'p', & + & 'p_diclvl','Preformed DIC',' ','mol C m-3',2) + call ncdefvar3d(LVL_DICSAT(iogrp),cmpflg,'p', & + & 'sat_diclvl','Saturated DIC',' ','mol C m-3',2) #ifdef cisonew - call ncdefvar3d(LVL_DIC13(iogrp),cmpflg,'p', - . 'dissic13lvl','Dissolved C13',' ','mol 13C m-3',2) - call ncdefvar3d(LVL_DIC14(iogrp),cmpflg,'p', - . 'dissic14lvl','Dissolved C14',' ','mol 14C m-3',2) - call ncdefvar3d(LVL_D13C(iogrp),cmpflg,'p', - . 'delta13clvl','delta13C of DIC',' ','permil',2) - call ncdefvar3d(LVL_D14C(iogrp),cmpflg,'p', - . 'delta14clvl','delta14C of DIC',' ','permil',2) - call ncdefvar3d(LVL_BIGD14C(iogrp),cmpflg,'p', - . 'bigdelta14clvl','big delta14C of DIC',' ','permil',2) - call ncdefvar3d(LVL_POC13(iogrp),cmpflg,'p', - . 'detoc13lvl','Detritus13',' ','mol P m-3',2) - call ncdefvar3d(LVL_DOC13(iogrp),cmpflg,'p', - . 'dissoc13lvl','Dissolved organic carbon13',' ','mol P m-3',2) - call ncdefvar3d(LVL_CALC13(iogrp),cmpflg,'p', - . 'calc13lvl','Ca13CO3 shells',' ','mol 13C m-3',2) - call ncdefvar3d(LVL_PHYTO13(iogrp),cmpflg,'p', - . 'phyc13lvl','Phytoplankton13',' ','mol P m-3',2) - call ncdefvar3d(LVL_GRAZER13(iogrp),cmpflg,'p', - . 'zooc13lvl','Zooplankton13',' ','mol P m-3',2) + call ncdefvar3d(LVL_DIC13(iogrp),cmpflg,'p', & + & 'dissic13lvl','Dissolved C13',' ','mol 13C m-3',2) + call ncdefvar3d(LVL_DIC14(iogrp),cmpflg,'p', & + & 'dissic14lvl','Dissolved C14',' ','mol 14C m-3',2) + call ncdefvar3d(LVL_D13C(iogrp),cmpflg,'p', & + & 'delta13clvl','delta13C of DIC',' ','permil',2) + call ncdefvar3d(LVL_D14C(iogrp),cmpflg,'p', & + & 'delta14clvl','delta14C of DIC',' ','permil',2) + call ncdefvar3d(LVL_BIGD14C(iogrp),cmpflg,'p', & + & 'bigdelta14clvl','big delta14C of DIC',' ','permil',2) + call ncdefvar3d(LVL_POC13(iogrp),cmpflg,'p', & + & 'detoc13lvl','Detritus13',' ','mol P m-3',2) + call ncdefvar3d(LVL_DOC13(iogrp),cmpflg,'p', & + & 'dissoc13lvl','Dissolved organic carbon13',' ','mol P m-3',2) + call ncdefvar3d(LVL_CALC13(iogrp),cmpflg,'p', & + & 'calc13lvl','Ca13CO3 shells',' ','mol 13C m-3',2) + call ncdefvar3d(LVL_PHYTO13(iogrp),cmpflg,'p', & + & 'phyc13lvl','Phytoplankton13',' ','mol P m-3',2) + call ncdefvar3d(LVL_GRAZER13(iogrp),cmpflg,'p', & + & 'zooc13lvl','Zooplankton13',' ','mol P m-3',2) #endif #ifdef AGG - call ncdefvar3d(LVL_NOS(iogrp),cmpflg,'p','noslvl', - . 'Marine snow aggregates per cm^3 sea water',' ','1/cm^3',2) - call ncdefvar3d(LVL_WPHY(iogrp),cmpflg,'p','wphylvl', - . 'Av. mass sinking speed of marine snow',' ','m/day',2) - call ncdefvar3d(LVL_WNOS(iogrp),cmpflg,'p','wnoslvl', - . 'Av. number sinking speed of marine snow',' ','m/day',2) - call ncdefvar3d(LVL_EPS(iogrp),cmpflg,'p','epslvl', - . 'Av. size distribution exponent',' ','-',2) - call ncdefvar3d(LVL_ASIZE(iogrp),cmpflg,'p','asizelvl', - . 'Av. size of marine snow aggregates',' ','nb. of cells',2) + call ncdefvar3d(LVL_NOS(iogrp),cmpflg,'p','noslvl', & + & 'Marine snow aggregates per cm^3 sea water',' ','1/cm^3',2) + call ncdefvar3d(LVL_WPHY(iogrp),cmpflg,'p','wphylvl', & + & 'Av. mass sinking speed of marine snow',' ','m/day',2) + call ncdefvar3d(LVL_WNOS(iogrp),cmpflg,'p','wnoslvl', & + & 'Av. number sinking speed of marine snow',' ','m/day',2) + call ncdefvar3d(LVL_EPS(iogrp),cmpflg,'p','epslvl', & + & 'Av. size distribution exponent',' ','-',2) + call ncdefvar3d(LVL_ASIZE(iogrp),cmpflg,'p','asizelvl', & + & 'Av. size of marine snow aggregates',' ','nb. of cells',2) #endif #ifdef CFC - call ncdefvar3d(LVL_CFC11(iogrp),cmpflg,'p', - . 'cfc11lvl','CFC-11',' ','mol cfc11 m-3',2) - call ncdefvar3d(LVL_CFC12(iogrp),cmpflg,'p', - . 'cfc12lvl','CFC-12',' ','mol cfc12 m-3',2) - call ncdefvar3d(LVL_SF6(iogrp),cmpflg,'p', - . 'sf6lvl','SF-6',' ','mol sf6 m-3',2) + call ncdefvar3d(LVL_CFC11(iogrp),cmpflg,'p', & + & 'cfc11lvl','CFC-11',' ','mol cfc11 m-3',2) + call ncdefvar3d(LVL_CFC12(iogrp),cmpflg,'p', & + & 'cfc12lvl','CFC-12',' ','mol cfc12 m-3',2) + call ncdefvar3d(LVL_SF6(iogrp),cmpflg,'p', & + & 'sf6lvl','SF-6',' ','mol sf6 m-3',2) #endif #ifdef natDIC - call ncdefvar3d(LVL_NATCO3(iogrp),cmpflg,'p', - . 'natco3lvl','Natural Carbonate ions',' ','mol C m-3',2) - call ncdefvar3d(LVL_NATALKALI(iogrp),cmpflg,'p','nattalklvl', - . 'Natural alkalinity',' ','eq m-3',2) - call ncdefvar3d(LVL_NATDIC(iogrp),cmpflg,'p','natdissiclvl', - . 'Natual dissolved inorganic carbon',' ','mol C m-3',2) - call ncdefvar3d(LVL_NATCALC(iogrp),cmpflg,'p', - . 'natcalclvl','Natural CaCO3 shells',' ','mol C m-3',2) - call ncdefvar3d(LVL_NATPH(iogrp),cmpflg,'p', - . 'natphlvl','Natural pH',' ','-log10([h+])',2) - call ncdefvar3d(LVL_NATOMEGAA(iogrp),cmpflg,'p', - . 'natomegaalvl','Natural OmegaA',' ','1',2) - call ncdefvar3d(LVL_NATOMEGAC(iogrp),cmpflg,'p', - . 'natomegaclvl','Natural OmegaC',' ','1',2) + call ncdefvar3d(LVL_NATCO3(iogrp),cmpflg,'p', & + & 'natco3lvl','Natural Carbonate ions',' ','mol C m-3',2) + call ncdefvar3d(LVL_NATALKALI(iogrp),cmpflg,'p','nattalklvl', & + & 'Natural alkalinity',' ','eq m-3',2) + call ncdefvar3d(LVL_NATDIC(iogrp),cmpflg,'p','natdissiclvl', & + & 'Natual dissolved inorganic carbon',' ','mol C m-3',2) + call ncdefvar3d(LVL_NATCALC(iogrp),cmpflg,'p', & + & 'natcalclvl','Natural CaCO3 shells',' ','mol C m-3',2) + call ncdefvar3d(LVL_NATPH(iogrp),cmpflg,'p', & + & 'natphlvl','Natural pH',' ','-log10([h+])',2) + call ncdefvar3d(LVL_NATOMEGAA(iogrp),cmpflg,'p', & + & 'natomegaalvl','Natural OmegaA',' ','1',2) + call ncdefvar3d(LVL_NATOMEGAC(iogrp),cmpflg,'p', & + & 'natomegaclvl','Natural OmegaC',' ','1',2) #endif #ifdef BROMO - call ncdefvar3d(LVL_BROMO(iogrp),cmpflg,'p', - . 'bromolvl','Bromoform',' ','mol CHBr3 m-3',2) + call ncdefvar3d(LVL_BROMO(iogrp),cmpflg,'p', & + & 'bromolvl','Bromoform',' ','mol CHBr3 m-3',2) #endif -c -c --- define sediment fields + + ! --- define sediment fields #ifndef sedbypass - call ncdefvar3d(SDM_POWAIC(iogrp),cmpflg,'p', - . 'powdic','PoWa DIC',' ','mol C m-3',3) - call ncdefvar3d(SDM_POWAAL(iogrp),cmpflg,'p', - . 'powalk','PoWa alkalinity',' ','eq m-3',3) - call ncdefvar3d(SDM_POWAPH(iogrp),cmpflg,'p', - . 'powpho','PoWa phosphorus',' ','mol P m-3',3) - call ncdefvar3d(SDM_POWAOX(iogrp),cmpflg,'p', - . 'powox','PoWa oxygen',' ','mol O2 m-3',3) - call ncdefvar3d(SDM_POWN2(iogrp), cmpflg,'p', - . 'pown2','PoWa N2',' ','mol N2 m-3',3) - call ncdefvar3d(SDM_POWNO3(iogrp),cmpflg,'p', - . 'powno3','PoWa nitrate',' ','mol N m-3',3) - call ncdefvar3d(SDM_POWASI(iogrp),cmpflg,'p', - . 'powsi','PoWa silicate',' ','mol Si m-3',3) - call ncdefvar3d(SDM_SSSO12(iogrp),cmpflg,'p', - . 'ssso12','Sediment detritus',' ','mol P m-3',3) - call ncdefvar3d(SDM_SSSSIL(iogrp),cmpflg,'p', - . 'ssssil','Sediment silicate',' ','mol Si m-3',3) - call ncdefvar3d(SDM_SSSC12(iogrp),cmpflg,'p', - . 'sssc12','Sediment CaCO3',' ','mol C m-3',3) - call ncdefvar3d(SDM_SSSTER(iogrp),cmpflg,'p', - . 'ssster','Sediment clay',' ','mol m-3',3) -c -c --- define sediment burial fields - call ncdefvar3d(BUR_SSSO12(iogrp), - . cmpflg,'p','buro12','Burial org carbon',' ','mol P m-2',4) - call ncdefvar3d(BUR_SSSC12(iogrp), - . cmpflg,'p','burc12','Burial calcium ',' ','mol C m-2',4) - call ncdefvar3d(BUR_SSSSIL(iogrp), - . cmpflg,'p','bursil','Burial silicate',' ','mol Si m-2',4) - call ncdefvar3d(BUR_SSSTER(iogrp), - . cmpflg,'p','burter','Burial clay',' ','mol m-2',4) + call ncdefvar3d(SDM_POWAIC(iogrp),cmpflg,'p', & + & 'powdic','PoWa DIC',' ','mol C m-3',3) + call ncdefvar3d(SDM_POWAAL(iogrp),cmpflg,'p', & + & 'powalk','PoWa alkalinity',' ','eq m-3',3) + call ncdefvar3d(SDM_POWAPH(iogrp),cmpflg,'p', & + & 'powpho','PoWa phosphorus',' ','mol P m-3',3) + call ncdefvar3d(SDM_POWAOX(iogrp),cmpflg,'p', & + & 'powox','PoWa oxygen',' ','mol O2 m-3',3) + call ncdefvar3d(SDM_POWN2(iogrp), cmpflg,'p', & + & 'pown2','PoWa N2',' ','mol N2 m-3',3) + call ncdefvar3d(SDM_POWNO3(iogrp),cmpflg,'p', & + & 'powno3','PoWa nitrate',' ','mol N m-3',3) + call ncdefvar3d(SDM_POWASI(iogrp),cmpflg,'p', & + & 'powsi','PoWa silicate',' ','mol Si m-3',3) + call ncdefvar3d(SDM_SSSO12(iogrp),cmpflg,'p', & + & 'ssso12','Sediment detritus',' ','mol P m-3',3) + call ncdefvar3d(SDM_SSSSIL(iogrp),cmpflg,'p', & + & 'ssssil','Sediment silicate',' ','mol Si m-3',3) + call ncdefvar3d(SDM_SSSC12(iogrp),cmpflg,'p', & + & 'sssc12','Sediment CaCO3',' ','mol C m-3',3) + call ncdefvar3d(SDM_SSSTER(iogrp),cmpflg,'p', & + & 'ssster','Sediment clay',' ','mol m-3',3) + + ! --- define sediment burial fields + call ncdefvar3d(BUR_SSSO12(iogrp), & + & cmpflg,'p','buro12','Burial org carbon',' ','mol P m-2',4) + call ncdefvar3d(BUR_SSSC12(iogrp), & + & cmpflg,'p','burc12','Burial calcium ',' ','mol C m-2',4) + call ncdefvar3d(BUR_SSSSIL(iogrp), & + & cmpflg,'p','bursil','Burial silicate',' ','mol Si m-2',4) + call ncdefvar3d(BUR_SSSTER(iogrp), & + & cmpflg,'p','burter','Burial clay',' ','mol m-2',4) #endif -c -c --- enddef netcdf file - call ncedef - end + ! --- enddef netcdf file + call ncedef +end subroutine hamoccvardef From fef0064493ca53b7a7ff615565a0f1d8ad263ea0 Mon Sep 17 00:00:00 2001 From: Tomas Torsvik Date: Fri, 19 Aug 2022 23:08:12 +0200 Subject: [PATCH 137/366] Rename hamocc/hamocc_step.F -> hamocc/hamocc_step.F90 --- hamocc/{hamocc_step.F => hamocc_step.F90} | 0 1 file changed, 0 insertions(+), 0 deletions(-) rename hamocc/{hamocc_step.F => hamocc_step.F90} (100%) diff --git a/hamocc/hamocc_step.F b/hamocc/hamocc_step.F90 similarity index 100% rename from hamocc/hamocc_step.F rename to hamocc/hamocc_step.F90 From 2f10d67bd89cfccfd4d298deff742d7eebfd0d0b Mon Sep 17 00:00:00 2001 From: Tomas Torsvik Date: Fri, 19 Aug 2022 23:18:54 +0200 Subject: [PATCH 138/366] Reformat hamocc/hamocc_step.F90 according to free form convention. --- hamocc/hamocc_step.F90 | 159 ++++++++++++++++++++--------------------- 1 file changed, 79 insertions(+), 80 deletions(-) diff --git a/hamocc/hamocc_step.F90 b/hamocc/hamocc_step.F90 index c95f6b75..14136cb9 100644 --- a/hamocc/hamocc_step.F90 +++ b/hamocc/hamocc_step.F90 @@ -1,85 +1,84 @@ -c Copyright (C) 2020 K. Assmann, J. Tjiputra, J. Schwinger, M. Bentsen -c -c This file is part of BLOM/iHAMOCC. -c -c BLOM is free software: you can redistribute it and/or modify it under the -c terms of the GNU Lesser General Public License as published by the Free -c Software Foundation, either version 3 of the License, or (at your option) -c any later version. -c -c BLOM is distributed in the hope that it will be useful, but WITHOUT ANY -c WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS -c FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for -c more details. -c -c You should have received a copy of the GNU Lesser General Public License -c along with BLOM. If not, see https://www.gnu.org/licenses/. +! Copyright (C) 2020 K. Assmann, J. Tjiputra, J. Schwinger, M. Bentsen +! +! This file is part of BLOM/iHAMOCC. +! +! 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 https://www.gnu.org/licenses/. - subroutine hamocc_step(m,n,mm,nn,k1m,k1n) -c -c --- ------------------------------------------------------------------ -c --- perform one HAMOCC step -c --- ------------------------------------------------------------------ -c - use mod_xc, only: idm,jdm,kdm,nbdy - use mod_time, only: date,nday_of_year,nstep,nstep_in_day - use mod_grid, only: plat - use mod_state, only: temp,saln - use mod_forcing, only: swa,slp,abswnd,atmco2,flxco2,flxdms, - . atmbrf,flxbrf - use mod_seaice, only: ficem - use mo_bgcmean, only: nbgc,bgcwrt, diagfq_bgc,diagmon_bgc, - . diagann_bgc - use mo_intfcblom, only: bgc_dx,bgc_dy,bgc_dp,bgc_rho,omask, - . blom2hamocc,hamocc2blom - use mo_read_rivin, only: rivflx - use mo_read_fedep, only: get_fedep - use mo_read_ndep, only: get_ndep - use mo_read_pi_ph, only: get_pi_ph,pi_ph - use mo_control_bgc, only: with_dmsph -c - implicit none -c - integer, intent(in) :: m,n,mm,nn,k1m,k1n +subroutine hamocc_step(m,n,mm,nn,k1m,k1n) +! +! --- ------------------------------------------------------------------ +! --- perform one HAMOCC step +! --- ------------------------------------------------------------------ +! + use mod_xc, only: idm,jdm,kdm,nbdy + use mod_time, only: date,nday_of_year,nstep,nstep_in_day + use mod_grid, only: plat + use mod_state, only: temp,saln + use mod_forcing, only: swa,slp,abswnd,atmco2,flxco2,flxdms, & + & atmbrf,flxbrf + use mod_seaice, only: ficem + use mo_bgcmean, only: nbgc,bgcwrt, diagfq_bgc,diagmon_bgc, & + & diagann_bgc + use mo_intfcblom, only: bgc_dx,bgc_dy,bgc_dp,bgc_rho,omask, & + & blom2hamocc,hamocc2blom + use mo_read_rivin, only: rivflx + use mo_read_fedep, only: get_fedep + use mo_read_ndep, only: get_ndep + use mo_read_pi_ph, only: get_pi_ph,pi_ph + use mo_control_bgc, only: with_dmsph - integer :: l,ldtday - real :: ndep(idm,jdm) - real :: dust(idm,jdm) -c - call trc_limitc(nn) -c - call blom2hamocc(m,n,mm,nn) -c - ldtday = mod(nstep,nstep_in_day) -c - do l=1,nbgc - bgcwrt(l)=.false. - if (((diagann_bgc(l).and.nday_of_year.eq.1.or.diagmon_bgc(l) - . .and.date%day.eq.1).and.mod(nstep,nstep_in_day).eq.0).or. - . .not.(diagann_bgc(l).or.diagmon_bgc(l)).and. - . mod(nstep+.5,diagfq_bgc(l)).lt.1.) - . bgcwrt(l)=.true. - enddo -c - call get_fedep(idm,jdm,date%month,dust) - call get_ndep(idm,jdm,date%year,date%month,omask,ndep) - if(with_dmsph) call get_pi_ph(idm,jdm,date%month) -c - call hamocc4bcm(idm,jdm,kdm,nbdy, - . date%year,date%month,date%day,ldtday, - . bgc_dx,bgc_dy,bgc_dp,bgc_rho,plat,omask, - . dust,rivflx,ndep,pi_ph, - . swa,ficem,slp,abswnd, - . temp(1-nbdy,1-nbdy,1+nn),saln(1-nbdy,1-nbdy,1+nn), - . atmco2,flxco2,flxdms,atmbrf,flxbrf) + implicit none -c -c --- accumulate fields and write output -c - call accfields(idm,jdm,kdm,bgc_dx,bgc_dy,bgc_dp,omask) + integer, intent(in) :: m,n,mm,nn,k1m,k1n - call hamocc2blom(m,n,mm,nn) -c - return - end + integer :: l,ldtday + real :: ndep(idm,jdm) + real :: dust(idm,jdm) + + call trc_limitc(nn) + + call blom2hamocc(m,n,mm,nn) + + ldtday = mod(nstep,nstep_in_day) + + do l=1,nbgc + bgcwrt(l)=.false. + if (((diagann_bgc(l).and.nday_of_year.eq.1.or.diagmon_bgc(l) & + & .and.date%day.eq.1).and.mod(nstep,nstep_in_day).eq.0).or. & + & .not.(diagann_bgc(l).or.diagmon_bgc(l)).and. & + & mod(nstep+.5,diagfq_bgc(l)).lt.1.) & + & bgcwrt(l)=.true. + enddo + + call get_fedep(idm,jdm,date%month,dust) + call get_ndep(idm,jdm,date%year,date%month,omask,ndep) + if(with_dmsph) call get_pi_ph(idm,jdm,date%month) + + call hamocc4bcm(idm,jdm,kdm,nbdy, & + & date%year,date%month,date%day,ldtday, & + & bgc_dx,bgc_dy,bgc_dp,bgc_rho,plat,omask, & + & dust,rivflx,ndep,pi_ph, & + & swa,ficem,slp,abswnd, & + & temp(1-nbdy,1-nbdy,1+nn),saln(1-nbdy,1-nbdy,1+nn), & + & atmco2,flxco2,flxdms,atmbrf,flxbrf) + + ! + ! --- accumulate fields and write output + ! + call accfields(idm,jdm,kdm,bgc_dx,bgc_dy,bgc_dp,omask) + + call hamocc2blom(m,n,mm,nn) + +end subroutine hamocc_step From c9bf3492eb7e584fd9264e45aed954e33ce0f348 Mon Sep 17 00:00:00 2001 From: Tomas Torsvik Date: Fri, 19 Aug 2022 23:20:57 +0200 Subject: [PATCH 139/366] Rename hamocc/hamocc_init.F -> hamocc/hamocc_init.F90 --- hamocc/{hamocc_init.F => hamocc_init.F90} | 0 1 file changed, 0 insertions(+), 0 deletions(-) rename hamocc/{hamocc_init.F => hamocc_init.F90} (100%) diff --git a/hamocc/hamocc_init.F b/hamocc/hamocc_init.F90 similarity index 100% rename from hamocc/hamocc_init.F rename to hamocc/hamocc_init.F90 From 7f0b5a172cf1faaa9137fd8b2bed0b1b86f2ab75 Mon Sep 17 00:00:00 2001 From: Tomas Torsvik Date: Fri, 19 Aug 2022 23:32:19 +0200 Subject: [PATCH 140/366] Reformat hamocc/hamocc_init.F90 according to free form convention. --- hamocc/hamocc_init.F90 | 441 ++++++++++++++++++++--------------------- 1 file changed, 220 insertions(+), 221 deletions(-) diff --git a/hamocc/hamocc_init.F90 b/hamocc/hamocc_init.F90 index 49e26675..13ae3e59 100644 --- a/hamocc/hamocc_init.F90 +++ b/hamocc/hamocc_init.F90 @@ -1,233 +1,232 @@ -c Copyright (C) 2020 K. Assmann, J. Tjiputra, J. Schwinger, M. Bentsen, -c P.-G. Chiu -c -c This file is part of BLOM/iHAMOCC. -c -c BLOM is free software: you can redistribute it and/or modify it under the -c terms of the GNU Lesser General Public License as published by the Free -c Software Foundation, either version 3 of the License, or (at your option) -c any later version. -c -c BLOM is distributed in the hope that it will be useful, but WITHOUT ANY -c WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS -c FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for -c more details. -c -c You should have received a copy of the GNU Lesser General Public License -c along with BLOM. If not, see https://www.gnu.org/licenses/. - - - subroutine hamocc_init(read_rest,rstfnm_hamocc) -c****************************************************************************** -c -c HAMOCC_INIT - initialize HAMOCC and its interface to BLOM. -c -c -c J.Schwinger, *NORCE Climate, Bergen* 2020-05-25 -c -c -c Purpose -c ------- -c - HAMOCC intialization when coupled to BLOM. -c -c -c Interface to ocean model (parameter list): -c ----------------------------------------- -c *INTEGER* *read_rest* - flag indicating whether to read restart files. -c *INTEGER* *rstfnm_hamocc* - restart filename. -c -c****************************************************************************** - use mod_time, only: date,baclin - use mod_xc, only: ii,jj,kk,idm,jdm,kdm,nbdy,isp,ifp,ilp, - . mnproc,lp,nfu,xchalt - use mod_grid, only: plon,plat - use mod_tracers, only: ntrbgc,ntr,itrbgc,trc - use mo_control_bgc, only: bgc_namelist,get_bgc_namelist, - . do_ndep,do_rivinpt,do_sedspinup, - . sedspin_yr_s,sedspin_yr_e,sedspin_ncyc, - . dtb,dtbgc,io_stdo_bgc,ldtbgc, - . ldtrunbgc,ndtdaybgc,with_dmsph - use mo_param1_bgc, only: ks,nsedtra,npowtra - use mo_carbch, only: alloc_mem_carbch,ocetra,atm,atm_co2 - use mo_biomod, only: alloc_mem_biomod - use mo_sedmnt, only: alloc_mem_sedmnt,sedlay,powtra,burial - use mo_vgrid, only: alloc_mem_vgrid,set_vgrid - use mo_bgcmean, only: alloc_mem_bgcmean - use mo_read_rivin, only: ini_read_rivin,rivinfile - use mo_read_fedep, only: ini_read_fedep,fedepfile - use mo_read_ndep, only: ini_read_ndep,ndepfile - use mo_read_pi_ph, only: ini_pi_ph,pi_ph_file - use mo_clim_swa, only: ini_swa_clim,swaclimfile - use mo_Gdata_read, only: inidic,inialk,inipo4,inioxy,inino3, - . inisil,inid13c,inid14c - use mo_intfcblom, only: alloc_mem_intfcblom,nphys, - . bgc_dx,bgc_dy,bgc_dp,bgc_rho, - . omask,sedlay2,powtra2,burial2, - . blom2hamocc +! Copyright (C) 2020 K. Assmann, J. Tjiputra, J. Schwinger, M. Bentsen, +! P.-G. Chiu +! +! This file is part of BLOM/iHAMOCC. +! +! 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 https://www.gnu.org/licenses/. + + +subroutine hamocc_init(read_rest,rstfnm_hamocc) +!****************************************************************************** +! +! HAMOCC_INIT - initialize HAMOCC and its interface to BLOM. +! +! +! J.Schwinger, *NORCE Climate, Bergen* 2020-05-25 +! +! +! Purpose +! ------- +! - HAMOCC intialization when coupled to BLOM. +! +! +! Interface to ocean model (parameter list): +! ----------------------------------------- +! *INTEGER* *read_rest* - flag indicating whether to read restart files. +! *INTEGER* *rstfnm_hamocc* - restart filename. +! +!****************************************************************************** + use mod_time, only: date,baclin + use mod_xc, only: ii,jj,kk,idm,jdm,kdm,nbdy,isp,ifp,ilp, & + & mnproc,lp,nfu,xchalt + use mod_grid, only: plon,plat + use mod_tracers, only: ntrbgc,ntr,itrbgc,trc + use mo_control_bgc, only: bgc_namelist,get_bgc_namelist, & + & do_ndep,do_rivinpt,do_sedspinup, & + & sedspin_yr_s,sedspin_yr_e,sedspin_ncyc, & + & dtb,dtbgc,io_stdo_bgc,ldtbgc, & + & ldtrunbgc,ndtdaybgc,with_dmsph + use mo_param1_bgc, only: ks,nsedtra,npowtra + use mo_carbch, only: alloc_mem_carbch,ocetra,atm,atm_co2 + use mo_biomod, only: alloc_mem_biomod + use mo_sedmnt, only: alloc_mem_sedmnt,sedlay,powtra,burial + use mo_vgrid, only: alloc_mem_vgrid,set_vgrid + use mo_bgcmean, only: alloc_mem_bgcmean + use mo_read_rivin, only: ini_read_rivin,rivinfile + use mo_read_fedep, only: ini_read_fedep,fedepfile + use mo_read_ndep, only: ini_read_ndep,ndepfile + use mo_read_pi_ph, only: ini_pi_ph,pi_ph_file + use mo_clim_swa, only: ini_swa_clim,swaclimfile + use mo_Gdata_read, only: inidic,inialk,inipo4,inioxy,inino3, & + & inisil,inid13c,inid14c + use mo_intfcblom, only: alloc_mem_intfcblom,nphys, & + & bgc_dx,bgc_dy,bgc_dp,bgc_rho, & + & omask,sedlay2,powtra2,burial2, & + & blom2hamocc #ifdef BOXATM - use mo_intfcblom, only: atm2 + use mo_intfcblom, only: atm2 #endif -c - implicit none -c - integer, intent(in) :: read_rest - character(len=*), intent(in) :: rstfnm_hamocc - - integer :: i,j,k,l,nt - integer :: iounit - - namelist /bgcnml/ atm_co2,do_rivinpt,do_ndep, - . ndepfile,fedepfile,rivinfile, - . do_sedspinup,sedspin_yr_s, - . sedspin_yr_e,sedspin_ncyc, - . inidic,inialk,inipo4,inioxy,inino3,inisil, - . inid13c,inid14c,swaclimfile, - . with_dmsph,pi_ph_file -c -c --- Set io units and some control parameters -c - io_stdo_bgc = lp ! standard out. - dtbgc = nphys*baclin ! time step length [sec]. - ndtdaybgc=NINT(86400./dtbgc) ! time steps per day [No]. - dtb=1./ndtdaybgc ! time step length [days]. - ldtbgc = 0 - ldtrunbgc = 0 - - if (mnproc.eq.1) then - write(io_stdo_bgc,*) - WRITE(io_stdo_bgc,*)'********************************************' - write(io_stdo_bgc,*) 'iHAMOCC: initialisation' - write(io_stdo_bgc,*) - write(io_stdo_bgc,*) 'restart',read_rest - write(io_stdo_bgc,*) 'dims',idm,jdm,kdm - write(io_stdo_bgc,*) 'date',date - write(io_stdo_bgc,*) 'time step',dtbgc - endif -c -c --- Read the HAMOCC BGCNML namelist and check the value of some variables. -c - if(.not. allocated(bgc_namelist)) call get_bgc_namelist - open (newunit=iounit, file=bgc_namelist, status='old' - . ,action='read') - read (unit=iounit, nml=BGCNML) - close (unit=iounit) - IF (mnproc.eq.1) THEN - - write(io_stdo_bgc,*) - write(io_stdo_bgc,*) 'iHAMOCC: reading namelist BGCNML' - write(io_stdo_bgc,nml=BGCNML) - - if(do_sedspinup) then - if(sedspin_yr_s<0 .or. sedspin_yr_e<0 .or. - . sedspin_yr_s>sedspin_yr_e) then - call xchalt('(invalid sediment spinup start/end year)') - stop '(invalid sediment spinup start/end year)' - endif - if(sedspin_ncyc < 2) then - call xchalt('(invalid nb. of sediment spinup subcycles)') - stop '(invalid nb. of sediment spinup subcycles)' - endif + + implicit none + + integer, intent(in) :: read_rest + character(len=*), intent(in) :: rstfnm_hamocc + + integer :: i,j,k,l,nt + integer :: iounit + + namelist /bgcnml/ atm_co2,do_rivinpt,do_ndep, & + & ndepfile,fedepfile,rivinfile, & + & do_sedspinup,sedspin_yr_s, & + & sedspin_yr_e,sedspin_ncyc, & + & inidic,inialk,inipo4,inioxy,inino3,inisil, & + & inid13c,inid14c,swaclimfile, & + & with_dmsph,pi_ph_file + ! + ! --- Set io units and some control parameters + ! + io_stdo_bgc = lp ! standard out. + dtbgc = nphys*baclin ! time step length [sec]. + ndtdaybgc=NINT(86400./dtbgc) ! time steps per day [No]. + dtb=1./ndtdaybgc ! time step length [days]. + ldtbgc = 0 + ldtrunbgc = 0 + + if (mnproc.eq.1) then + write(io_stdo_bgc,*) + WRITE(io_stdo_bgc,*)'********************************************' + write(io_stdo_bgc,*) 'iHAMOCC: initialisation' + write(io_stdo_bgc,*) + write(io_stdo_bgc,*) 'restart',read_rest + write(io_stdo_bgc,*) 'dims',idm,jdm,kdm + write(io_stdo_bgc,*) 'date',date + write(io_stdo_bgc,*) 'time step',dtbgc + endif + ! + ! --- Read the HAMOCC BGCNML namelist and check the value of some variables. + ! + if(.not. allocated(bgc_namelist)) call get_bgc_namelist + open (newunit=iounit, file=bgc_namelist, status='old' & + & ,action='read') + read (unit=iounit, nml=BGCNML) + close (unit=iounit) + IF (mnproc.eq.1) THEN + + write(io_stdo_bgc,*) + write(io_stdo_bgc,*) 'iHAMOCC: reading namelist BGCNML' + write(io_stdo_bgc,nml=BGCNML) + + if(do_sedspinup) then + if(sedspin_yr_s<0 .or. sedspin_yr_e<0 .or. & + & sedspin_yr_s>sedspin_yr_e) then + call xchalt('(invalid sediment spinup start/end year)') + stop '(invalid sediment spinup start/end year)' endif + if(sedspin_ncyc < 2) then + call xchalt('(invalid nb. of sediment spinup subcycles)') + stop '(invalid nb. of sediment spinup subcycles)' + endif + endif + + ENDIF + ! + ! --- Memory allocation + ! + CALL ALLOC_MEM_INTFCBLOM(idm,jdm,kdm) + CALL ALLOC_MEM_BGCMEAN(idm,jdm,kdm) + CALL ALLOC_MEM_VGRID(idm,jdm,kdm) + CALL ALLOC_MEM_BIOMOD(idm,jdm,kdm) + CALL ALLOC_MEM_SEDMNT(idm,jdm) + CALL ALLOC_MEM_CARBCH(idm,jdm,kdm) + ! + ! --- initialise trc array (two time levels) + ! + do nt=itrbgc,itrbgc+ntrbgc-1 + do k=1,2*kk + do j=1,jj + do i=1,ii + trc(i,j,k,nt)=0.0 + enddo + enddo + enddo + enddo + ! + ! --- initialise HAMOCC land/ocean mask + ! + do j=1,jj + do l=1,isp(j) + do i=max(1,ifp(j,l)),min(ii,ilp(j,l)) + omask(i,j)=1. + enddo + enddo + enddo + ! + ! --- BLOM to HAMOCC interface + ! + call blom2hamocc(2,1,kk,0) + ! + ! --- Calculate variables related to the vertical grid + ! + call set_vgrid(idm,jdm,kdm,bgc_dp) + ! + ! --- Initialize sediment layering + ! + CALL BODENSED(idm,jdm,kdm,bgc_dp) + ! + ! --- Initialize parameters, sediment and ocean tracer. + ! + CALL BELEG_PARM(idm,jdm) + CALL BELEG_VARS(read_rest,idm,jdm,kdm,nbdy,bgc_dp,bgc_rho,omask, & + & plon,plat) + ! + ! --- Initialise reading of input data (dust, n-deposition, river, etc.) + ! + CALL ini_read_fedep(idm,jdm,omask) - ENDIF -c -c --- Memory allocation -c - CALL ALLOC_MEM_INTFCBLOM(idm,jdm,kdm) - CALL ALLOC_MEM_BGCMEAN(idm,jdm,kdm) - CALL ALLOC_MEM_VGRID(idm,jdm,kdm) - CALL ALLOC_MEM_BIOMOD(idm,jdm,kdm) - CALL ALLOC_MEM_SEDMNT(idm,jdm) - CALL ALLOC_MEM_CARBCH(idm,jdm,kdm) -c -c --- initialise trc array (two time levels) -c - do nt=itrbgc,itrbgc+ntrbgc-1 - do k=1,2*kk - do j=1,jj - do i=1,ii - trc(i,j,k,nt)=0.0 - enddo - enddo - enddo - enddo -c -c --- initialise HAMOCC land/ocean mask -c - do j=1,jj - do l=1,isp(j) - do i=max(1,ifp(j,l)),min(ii,ilp(j,l)) - omask(i,j)=1. - enddo - enddo - enddo -c -c --- BLOM to HAMOCC interface -c - call blom2hamocc(2,1,kk,0) -c -c --- Calculate variables related to the vertical grid -c - call set_vgrid(idm,jdm,kdm,bgc_dp) -c -c --- Initialize sediment layering -c - CALL BODENSED(idm,jdm,kdm,bgc_dp) -c -c --- Initialize parameters, sediment and ocean tracer. -c - CALL BELEG_PARM(idm,jdm) - CALL BELEG_VARS(read_rest,idm,jdm,kdm,nbdy,bgc_dp,bgc_rho,omask, - . plon,plat) -c -c --- Initialise reading of input data (dust, n-deposition, river, etc.) -c - CALL ini_read_fedep(idm,jdm,omask) - - CALL ini_read_ndep(idm,jdm) - - CALL ini_read_rivin(idm,jdm,omask) + CALL ini_read_ndep(idm,jdm) + + CALL ini_read_rivin(idm,jdm,omask) #ifdef BROMO - CALL ini_swa_clim(idm,jdm,omask) + CALL ini_swa_clim(idm,jdm,omask) #endif - call ini_pi_ph(idm,jdm,omask) -c -c --- Read restart fields from restart file if requested, otherwise -c (at first start-up) copy ocetra and sediment arrays (which are -c initialised in BELEG_VARS) to both timelevels of their respective -c two-time-level counterpart -c - IF(read_rest.eq.1) THEN - CALL AUFR_BGC(idm,jdm,kdm,ntr,ntrbgc,itrbgc,trc, - . date%year,date%month,date%day,omask,rstfnm_hamocc) - ELSE - trc(1:idm,1:jdm,1:kdm, itrbgc:itrbgc+ntrbgc-1) = - . ocetra(:,:,:,:) - trc(1:idm,1:jdm,kdm+1:2*kdm,itrbgc:itrbgc+ntrbgc-1) = - . ocetra(:,:,:,:) + call ini_pi_ph(idm,jdm,omask) + ! + ! --- Read restart fields from restart file if requested, otherwise + ! (at first start-up) copy ocetra and sediment arrays (which are + ! initialised in BELEG_VARS) to both timelevels of their respective + ! two-time-level counterpart + ! + IF(read_rest.eq.1) THEN + CALL AUFR_BGC(idm,jdm,kdm,ntr,ntrbgc,itrbgc,trc, & + & date%year,date%month,date%day,omask,rstfnm_hamocc) + ELSE + trc(1:idm,1:jdm,1:kdm, itrbgc:itrbgc+ntrbgc-1) = & + & ocetra(:,:,:,:) + trc(1:idm,1:jdm,kdm+1:2*kdm,itrbgc:itrbgc+ntrbgc-1) = & + & ocetra(:,:,:,:) #ifndef sedbypass - sedlay2(:,:,1:ks,:) = sedlay(:,:,:,:) - sedlay2(:,:,ks+1:2*ks,:) = sedlay(:,:,:,:) - powtra2(:,:,1:ks,:) = powtra(:,:,:,:) - powtra2(:,:,ks+1:2*ks,:) = powtra(:,:,:,:) - burial2(:,:,1,:) = burial(:,:,:) - burial2(:,:,2,:) = burial(:,:,:) + sedlay2(:,:,1:ks,:) = sedlay(:,:,:,:) + sedlay2(:,:,ks+1:2*ks,:) = sedlay(:,:,:,:) + powtra2(:,:,1:ks,:) = powtra(:,:,:,:) + powtra2(:,:,ks+1:2*ks,:) = powtra(:,:,:,:) + burial2(:,:,1,:) = burial(:,:,:) + burial2(:,:,2,:) = burial(:,:,:) #endif #if defined(BOXATM) - atm2(:,:,1,:) = atm(:,:,:) - atm2(:,:,2,:) = atm(:,:,:) + atm2(:,:,1,:) = atm(:,:,:) + atm2(:,:,2,:) = atm(:,:,:) #endif - ENDIF -c - if (mnproc.eq.1) then - write(io_stdo_bgc,*) - WRITE(io_stdo_bgc,*)'********************************************' - write(io_stdo_bgc,*) 'iHAMOCC: finished initialisation' - write(io_stdo_bgc,*) - endif - - return -c****************************************************************************** - end subroutine hamocc_init + ENDIF + + if (mnproc.eq.1) then + write(io_stdo_bgc,*) + WRITE(io_stdo_bgc,*)'********************************************' + write(io_stdo_bgc,*) 'iHAMOCC: finished initialisation' + write(io_stdo_bgc,*) + endif + +!****************************************************************************** +end subroutine hamocc_init From 7b91afde4784509fa6cc7ebdb60c8713979e30b6 Mon Sep 17 00:00:00 2001 From: Tomas Torsvik Date: Fri, 19 Aug 2022 23:39:09 +0200 Subject: [PATCH 141/366] Update hamocc/meson.build with *.F90 file names. --- hamocc/meson.build | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/hamocc/meson.build b/hamocc/meson.build index 2b60e347..f7d79e60 100644 --- a/hamocc/meson.build +++ b/hamocc/meson.build @@ -13,8 +13,8 @@ sources += files( 'dipowa.F90', 'get_cfc.F90', 'hamocc4bcm.F90', - 'hamocc_init.F', - 'hamocc_step.F', + 'hamocc_init.F90', + 'hamocc_step.F90', 'inventory_bgc.F90', 'mo_Gdata_read.F90', 'mo_apply_fedep.F90', @@ -34,7 +34,7 @@ sources += files( 'mo_read_rivin.F90', 'mo_sedmnt.F90', 'mo_vgrid.F90', - 'ncout_hamocc.F', + 'ncout_hamocc.F90', 'netcdf_def_vardb.F90', 'ocprod.F90', 'powach.F90', @@ -42,7 +42,7 @@ sources += files( 'preftrc.F90', 'profile_gd.F90', 'read_netcdf_var.F90', - 'restart_hamoccwt.F', + 'restart_hamoccwt.F90', 'sedshi.F90', - 'trc_limitc.F', + 'trc_limitc.F90', 'write_netcdf_var.F90') From 209595d2a4cc198cf0f30a255f6552dd1d9af85b Mon Sep 17 00:00:00 2001 From: jmaerz <92309038+jmaerz@users.noreply.github.com> Date: Mon, 22 Aug 2022 16:35:09 +0200 Subject: [PATCH 142/366] Fix wdust (#185) * FIX: impose no-flux boundary condition at surface for fdust This bugfix potentially affects the sediment burrying rate --- hamocc/ocprod.F90 | 10 +++++++--- 1 file changed, 7 insertions(+), 3 deletions(-) diff --git a/hamocc/ocprod.F90 b/hamocc/ocprod.F90 index 2677b483..9d2b82d7 100644 --- a/hamocc/ocprod.F90 +++ b/hamocc/ocprod.F90 @@ -150,7 +150,7 @@ subroutine ocprod(kpie,kpje,kpke,kbnd,pdlxp,pdlyp,pddpo,omask,ptho,pi_ph) real :: absorption,absorption_uv real :: dmsprod,dms_bac,dms_uv real :: dtr,dz - real :: wpocd,wcald,wopald,dagg + real :: wpocd,wcald,wopald,wdustd,dagg #ifdef sedbypass real :: florca,flcaca,flsil #endif @@ -1049,7 +1049,7 @@ subroutine ocprod(kpie,kpje,kpke,kbnd,pdlxp,pdlyp,pddpo,omask,ptho,pi_ph) ! C(k,T+dt)=(ddpo(k)*C(k,T)+w*dt*C(k-1,T+dt))/(ddpo(k)+w*dt) ! sedimentation=w*dt*C(ks,T+dt) ! -!$OMP PARALLEL DO PRIVATE(kdonor,wpoc,wpocd,wcal,wcald,wopal,wopald & +!$OMP PARALLEL DO PRIVATE(kdonor,wpoc,wpocd,wcal,wcald,wopal,wopald,wdust,wdustd & #if defined(AGG) !$OMP ,wnos,wnosd,dagg & #endif @@ -1099,17 +1099,20 @@ subroutine ocprod(kpie,kpje,kpke,kbnd,pdlxp,pdlyp,pddpo,omask,ptho,pi_ph) wnos = wnumb(i,j,k) wnosd = wnumb(i,j,kdonor) wdust = dustsink + wdustd = dustsink dagg = dustagg(i,j,k) #elif defined(WLIN) wpoc = min(wmin+wlin*ptiestu(i,j,k), wmax) wpocd = min(wmin+wlin*ptiestu(i,j,kdonor),wmax) wcald = wcal wopald = wopal + wdustd = wdust dagg = 0.0 #else wpocd = wpoc wcald = wcal wopald = wopal + wdustd = wdust dagg = 0.0 #endif @@ -1117,6 +1120,7 @@ subroutine ocprod(kpie,kpje,kpke,kbnd,pdlxp,pdlyp,pddpo,omask,ptho,pi_ph) wpocd = 0.0 wcald = 0.0 wopald = 0.0 + wdustd = 0.0 #if defined(AGG) wnosd = 0.0 #elif defined(WLIN) @@ -1153,7 +1157,7 @@ subroutine ocprod(kpie,kpje,kpke,kbnd,pdlxp,pdlyp,pddpo,omask,ptho,pi_ph) & + ocetra(i,j,kdonor,iopal)*wopald)/ & & (pddpo(i,j,k)+wopal) ocetra(i,j,k,ifdust) = (ocetra(i,j,k ,ifdust) * pddpo(i,j,k) & - & + ocetra(i,j,kdonor,ifdust)*wdust)/ & + & + ocetra(i,j,kdonor,ifdust)*wdustd)/ & & (pddpo(i,j,k)+wdust) - dagg #ifdef AGG ocetra(i,j,k,iphy) = (ocetra(i,j,k ,iphy) * pddpo(i,j,k) & From 3a81deeb6ff2804c14e6f1e49b1e04bcb20cfabe Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Wed, 24 Aug 2022 13:44:32 +0200 Subject: [PATCH 143/366] FIX issues due to renaming in merged master --- hamocc/hamocc_init.F90 | 4 +- hamocc/ncout_hamocc.F90 | 541 +++++++++++++++++++++++++++++++++++++++- 2 files changed, 540 insertions(+), 5 deletions(-) diff --git a/hamocc/hamocc_init.F90 b/hamocc/hamocc_init.F90 index 13ae3e59..fcfbe321 100644 --- a/hamocc/hamocc_init.F90 +++ b/hamocc/hamocc_init.F90 @@ -46,7 +46,7 @@ subroutine hamocc_init(read_rest,rstfnm_hamocc) & do_ndep,do_rivinpt,do_sedspinup, & & sedspin_yr_s,sedspin_yr_e,sedspin_ncyc, & & dtb,dtbgc,io_stdo_bgc,ldtbgc, & - & ldtrunbgc,ndtdaybgc,with_dmsph + & ldtrunbgc,ndtdaybgc,with_dmsph,lm4ago use mo_param1_bgc, only: ks,nsedtra,npowtra use mo_carbch, only: alloc_mem_carbch,ocetra,atm,atm_co2 use mo_biomod, only: alloc_mem_biomod @@ -64,6 +64,7 @@ subroutine hamocc_init(read_rest,rstfnm_hamocc) & bgc_dx,bgc_dy,bgc_dp,bgc_rho, & & omask,sedlay2,powtra2,burial2, & & blom2hamocc + use mo_m4ago, only: alloc_mem_m4ago #ifdef BOXATM use mo_intfcblom, only: atm2 #endif @@ -139,6 +140,7 @@ subroutine hamocc_init(read_rest,rstfnm_hamocc) CALL ALLOC_MEM_BIOMOD(idm,jdm,kdm) CALL ALLOC_MEM_SEDMNT(idm,jdm) CALL ALLOC_MEM_CARBCH(idm,jdm,kdm) + CALL ALLOC_MEM_M4AGO(idm,jdm,kdm) ! ! --- initialise trc array (two time levels) ! diff --git a/hamocc/ncout_hamocc.F90 b/hamocc/ncout_hamocc.F90 index c4bafdff..b87f7250 100644 --- a/hamocc/ncout_hamocc.F90 +++ b/hamocc/ncout_hamocc.F90 @@ -107,7 +107,23 @@ subroutine ncwrt_bgc(iogrp) & glb_fnametag,filefq_bgc,diagfq_bgc, & & filemon_bgc,fileann_bgc,ip,wrtlyr,wrtlvl, & & loglyr,inilvl,inilyr,inisrf,loglvl, & - & msklvl,wrtsrf,msksrf,finlyr + & msklvl,wrtsrf,msksrf,finlyr, & + & lyr_agg_ws,lyr_dynvis,lyr_agg_stick, & + & lyr_agg_stickf,lyr_agg_dmax,lyr_agg_avdp, & + & lyr_agg_avrhop,lyr_agg_avdC,lyr_agg_df, & + & lyr_agg_b,lyr_agg_Vrhof,lyr_agg_Vpor, & + & lvl_agg_ws,lvl_dynvis,lvl_agg_stick, & + & lvl_agg_stickf,lvl_agg_dmax,lvl_agg_avdp, & + & lvl_agg_avrhop,lvl_agg_avdC,lvl_agg_df, & + & lvl_agg_b,lvl_agg_Vrhof,lvl_agg_Vpor, & + & jagg_ws,jdynvis,jagg_stick, & + & jagg_stickf,jagg_dmax,jagg_avdp, & + & jagg_avrhop,jagg_avdC,jagg_df, & + & jagg_b,jagg_Vrhof,jagg_Vpor, & + & jlvl_agg_ws,jlvl_dynvis,jlvl_agg_stick, & + & jlvl_agg_stickf,jlvl_agg_dmax,jlvl_agg_avdp, & + & jlvl_agg_avrhop,jlvl_agg_avdC,jlvl_agg_df, & + & jlvl_agg_b,jlvl_agg_Vrhof,jlvl_agg_Vpor #ifdef AGG use mo_bgcmean, only: lyr_nos,lyr_wphy, lyr_wnos,lyr_eps, & & lyr_asize,lvl_nos,lvl_wphy,lvl_wnos,lvl_eps, & @@ -160,7 +176,36 @@ subroutine ncwrt_bgc(iogrp) & bur_sssc12,bur_ssssil,bur_ssster,bur_ssso12, & & inisdm,inibur,wrtsdm,accbur,accsdm,wrtbur #endif - +#ifdef extNcycle + use mo_bgcmean, only: janh4,jano2,jlvlanh4,jlvlano2,jsrfanh4, & + & jsrfano2,janh3fx,srf_anh4,srf_ano2, & + & srf_anh3fx,lyr_anh4,lyr_ano2,lvl_anh4, & + & lvl_ano2, & + & LYR_nitr_NH4,LYR_nitr_NO2,LYR_nitr_N2O_prod, & + & LYR_nitr_NH4_OM,LYR_nitr_NO2_OM, & + & LYR_denit_NO3,LYR_denit_NO2,LYR_denit_N2O, & + & LYR_DNRA_NO2,LYR_anmx_N2_prod, & + & LYR_anmx_OM_prod,LYR_phosy_NH4, & + & LYR_phosy_NO3,LYR_remin_aerob,LYR_remin_sulf, & + & LVL_nitr_NH4,LVL_nitr_NO2,LVL_nitr_N2O_prod, & + & LVL_nitr_NH4_OM,LVL_nitr_NO2_OM, & + & LVL_denit_NO3,LVL_denit_NO2,LVL_denit_N2O, & + & LVL_DNRA_NO2,LVL_anmx_N2_prod, & + & LVL_anmx_OM_prod,LVL_phosy_NH4, & + & LVL_phosy_NO3,LVL_remin_aerob,LVL_remin_sulf, & + & jnitr_NH4,jnitr_NO2,jnitr_N2O_prod, & + & jnitr_NH4_OM,jnitr_NO2_OM,jdenit_NO3, & + & jdenit_NO2,jdenit_N2O,jDNRA_NO2, & + & janmx_N2_prod,janmx_OM_prod,jphosy_NH4, & + & jphosy_NO3,jremin_aerob,jremin_sulf, & + & jlvl_nitr_NH4,jlvl_nitr_NO2, & + & jlvl_nitr_N2O_prod,jlvl_nitr_NH4_OM, & + & jlvl_nitr_NO2_OM,jlvl_denit_NO3, & + & jlvl_denit_NO2,jlvl_denit_N2O,jlvl_DNRA_NO2, & + & jlvl_anmx_N2_prod,jlvl_anmx_OM_prod, & + & jlvl_phosy_NH4,jlvl_phosy_NO3, & + & jlvl_remin_aerob,jlvl_remin_sulf +#endif implicit none integer iogrp @@ -301,6 +346,38 @@ subroutine ncwrt_bgc(iogrp) #ifdef BROMO call finlyr(jbromo(iogrp),jdp(iogrp)) #endif +#ifdef extNcycle + call finlyr(janh4(iogrp),jdp(iogrp)) + call finlyr(jano2(iogrp),jdp(iogrp)) + call finlyr(jnitr_NH4(iogrp),jdp(iogrp)) + call finlyr(jnitr_NO2(iogrp),jdp(iogrp)) + call finlyr(jnitr_N2O_prod(iogrp),jdp(iogrp)) + call finlyr(jnitr_NH4_OM(iogrp),jdp(iogrp)) + call finlyr(jnitr_NO2_OM(iogrp),jdp(iogrp)) + call finlyr(jdenit_NO3(iogrp),jdp(iogrp)) + call finlyr(jdenit_NO2(iogrp),jdp(iogrp)) + call finlyr(jdenit_N2O(iogrp),jdp(iogrp)) + call finlyr(jDNRA_NO2(iogrp),jdp(iogrp)) + call finlyr(janmx_N2_prod(iogrp),jdp(iogrp)) + call finlyr(janmx_OM_prod(iogrp),jdp(iogrp)) + call finlyr(jphosy_NH4(iogrp),jdp(iogrp)) + call finlyr(jphosy_NO3(iogrp),jdp(iogrp)) + call finlyr(jremin_aerob(iogrp),jdp(iogrp)) + call finlyr(jremin_sulf(iogrp),jdp(iogrp)) +#endif + ! M4AGO + call finlyr(jagg_ws(iogrp),jdp(iogrp)) + call finlyr(jdynvis(iogrp),jdp(iogrp)) + call finlyr(jagg_stick(iogrp),jdp(iogrp)) + call finlyr(jagg_stickf(iogrp),jdp(iogrp)) + call finlyr(jagg_dmax(iogrp),jdp(iogrp)) + call finlyr(jagg_avdp(iogrp),jdp(iogrp)) + call finlyr(jagg_avrhop(iogrp),jdp(iogrp)) + call finlyr(jagg_avdC(iogrp),jdp(iogrp)) + call finlyr(jagg_df(iogrp),jdp(iogrp)) + call finlyr(jagg_b(iogrp),jdp(iogrp)) + call finlyr(jagg_Vrhof(iogrp),jdp(iogrp)) + call finlyr(jagg_Vpor(iogrp),jdp(iogrp)) ! --- Mask sea floor in mass fluxes call msksrf(jcarflx0100(iogrp),k0100) @@ -381,6 +458,38 @@ subroutine ncwrt_bgc(iogrp) #ifdef BROMO call msklvl(jlvlbromo(iogrp),depths) #endif +#ifdef extNcycle + call msklvl(jlvlanh4(iogrp),depths) + call msklvl(jlvlano2(iogrp),depths) + call msklvl(jlvl_nitr_NH4(iogrp),depths) + call msklvl(jlvl_nitr_NO2(iogrp),depths) + call msklvl(jlvl_nitr_N2O_prod(iogrp),depths) + call msklvl(jlvl_nitr_NH4_OM(iogrp),depths) + call msklvl(jlvl_nitr_NO2_OM(iogrp),depths) + call msklvl(jlvl_denit_NO3(iogrp),depths) + call msklvl(jlvl_denit_NO2(iogrp),depths) + call msklvl(jlvl_denit_N2O(iogrp),depths) + call msklvl(jlvl_DNRA_NO2(iogrp),depths) + call msklvl(jlvl_anmx_N2_prod(iogrp),depths) + call msklvl(jlvl_anmx_OM_prod(iogrp),depths) + call msklvl(jlvl_phosy_NH4(iogrp),depths) + call msklvl(jlvl_phosy_NO3(iogrp),depths) + call msklvl(jlvl_remin_aerob(iogrp),depths) + call msklvl(jlvl_remin_sulf(iogrp),depths) +#endif + ! M4AGO + call msklvl(jlvl_agg_ws(iogrp),depths) + call msklvl(jlvl_dynvis(iogrp),depths) + call msklvl(jlvl_agg_stick(iogrp),depths) + call msklvl(jlvl_agg_stickf(iogrp),depths) + call msklvl(jlvl_agg_dmax(iogrp),depths) + call msklvl(jlvl_agg_avdp(iogrp),depths) + call msklvl(jlvl_agg_avrhop(iogrp),depths) + call msklvl(jlvl_agg_avdC(iogrp),depths) + call msklvl(jlvl_agg_df(iogrp),depths) + call msklvl(jlvl_agg_b(iogrp),depths) + call msklvl(jlvl_agg_Vrhof(iogrp),depths) + call msklvl(jlvl_agg_Vpor(iogrp),depths) ! --- Compute log10 of pH if (LYR_PH(iogrp).ne.0) call loglyr(jph(iogrp),1.,0.) @@ -592,6 +701,16 @@ subroutine ncwrt_bgc(iogrp) call wrtsrf(jatmc14(iogrp),SRF_ATMC14(iogrp),rnacc,0.,cmpflg, & & 'atmc14','Atmospheric 14CO2',' ','ppm') #endif +#ifdef extNcycle + call wrtsrf(jsrfanh4(iogrp),SRF_ANH4(iogrp), & + & rnacc*1e3,0.,cmpflg,'srfnh4', & + & 'Surface ammonium',' ','mol N m-3') + call wrtsrf(jsrfano2(iogrp),SRF_ANO2(iogrp), & + & rnacc*1e3,0.,cmpflg,'srfno2', & + & 'Surface nitrite',' ','mol N m-3') + call wrtsrf(janh3fx(iogrp),SRF_ANH3FX(iogrp),rnacc*1e3/dtbgc,0., & + & cmpflg,'nh3flux','NH3 flux',' ','mol NH3 m-2 s-1') +#endif ! --- Store 3d layer fields call wrtlyr(jdp(iogrp),LYR_DP(iogrp),rnacc,0.,cmpflg, & @@ -709,6 +828,85 @@ subroutine ncwrt_bgc(iogrp) call wrtlyr(jbromo(iogrp),LYR_BROMO(iogrp),1e3,0.,cmpflg, & & 'bromo','Bromoform',' ','mol CHBr3 m-3') #endif +#ifdef extNcycle + call wrtlyr(janh4(iogrp),LYR_ANH4(iogrp),1e3,0.,cmpflg, & + & 'nh4','Ammonium',' ','mol N m-3') + call wrtlyr(jano2(iogrp),LYR_ANO2(iogrp),1e3,0.,cmpflg, & + & 'no2','Nitrite',' ','mol N m-3') + call wrtlyr(jnitr_NH4(iogrp),LYR_nitr_NH4(iogrp),1e3/dtbgc,0., & + & cmpflg, & + & 'nh4nitr','NH4 nitrification rate',' ','mol N m-3 s-1') + call wrtlyr(jnitr_NO2(iogrp),LYR_nitr_NO2(iogrp),1e3/dtbgc,0., & + & cmpflg, & + & 'no2nitr','NO2 nitrification rate',' ','mol N m-3 s-1') + call wrtlyr(jnitr_N2O_prod(iogrp),LYR_nitr_N2O_prod(iogrp), & + & 1e3/dtbgc,0.,cmpflg, & + & 'nitr_n2o','N2O prod during NH4 nitrification',' ', & + & 'mol N2O m-3 s-1') + call wrtlyr(jnitr_NH4_OM(iogrp),LYR_nitr_NH4_OM(iogrp),1e3/dtbgc, & + & 0.,cmpflg, & + & 'nh4nitr_om','OM production during NH4 nitrification',' ', & + & 'mol P m-3 s-1') + call wrtlyr(jnitr_NO2_OM(iogrp),LYR_nitr_NO2_OM(iogrp),1e3/dtbgc, & + & 0.,cmpflg, & + & 'no2nitr_om','OM production during NO2 nitrification',' ', & + & 'mol P m-3 s-1') + call wrtlyr(jdenit_NO3(iogrp),LYR_denit_NO3(iogrp),1e3/dtbgc,0., & + & cmpflg, & + & 'no3denit','NO3 denitrification rate',' ','mol N m-3 s-1') + call wrtlyr(jdenit_NO2(iogrp),LYR_denit_NO2(iogrp),1e3/dtbgc,0., & + & cmpflg, & + & 'no2denit','NO2 denitrification rate',' ','mol N m-3 s-1') + call wrtlyr(jdenit_N2O(iogrp),LYR_denit_N2O(iogrp),1e3/dtbgc,0., & + & cmpflg, & + & 'n2odenit','N2O denitrification rate',' ','mol N2O m-3 s-1') + call wrtlyr(jDNRA_NO2(iogrp),LYR_DNRA_NO2(iogrp),1e3/dtbgc,0., & + & cmpflg, & + & 'no2dnra','NO2 DNRA rate',' ','mol N m-3 s-1') + call wrtlyr(janmx_N2_prod(iogrp),LYR_anmx_N2_prod(iogrp), & + & 1e3/dtbgc,0.,cmpflg, & + & 'anmx_n2','Anammox N2 production rate',' ','mol N2 m-3 s-1') + call wrtlyr(janmx_OM_prod(iogrp),LYR_anmx_OM_prod(iogrp), & + & 1e3/dtbgc,0.,cmpflg, & + & 'anmx_om','Anammox OM production rate',' ','mol P m-3 s-1') + call wrtlyr(jphosy_NH4(iogrp),LYR_phosy_NH4(iogrp),1e3/dtbgc,0., & + & cmpflg, & + & 'phosy_nh4','PP consumption rate of NH4',' ','mol N m-3 s-1') + call wrtlyr(jphosy_NO3(iogrp),LYR_phosy_NO3(iogrp),1e3/dtbgc,0., & + & cmpflg, & + & 'phosy_no3','PP consumption rate of NO3',' ','mol N m-3 s-1') + call wrtlyr(jremin_aerob(iogrp),LYR_remin_aerob(iogrp),1e3/dtbgc, & + & 0.,cmpflg, & + & 'remina','Aerob remineralization rate',' ','mol N m-3 s-1') + call wrtlyr(jremin_sulf(iogrp),LYR_remin_sulf(iogrp),1e3/dtbgc, & + & 0.,cmpflg, & + & 'remins','Sulfate remineralization rate',' ','mol P m-3 s-1') +#endif +! M4AGO + call wrtlyr(jagg_ws(iogrp),LYR_agg_ws(iogrp),1.,0.,cmpflg, & + & 'agg_ws','aggregate mean settling velocity',' ','m d-1') + call wrtlyr(jdynvis(iogrp),LYR_dynvis(iogrp),1.,0.,cmpflg, & + & 'dynvis','dynamic viscosity of sea water',' ','kg m-1 s-1') + call wrtlyr(jagg_stick(iogrp),LYR_agg_stick(iogrp),1.,0.,cmpflg, & + & 'agg_stick','aggregate mean stickiness',' ','-') + call wrtlyr(jagg_stickf(iogrp),LYR_agg_stickf(iogrp),1.,0.,cmpflg, & + & 'agg_stickf','opal frustule stickiness',' ','-') + call wrtlyr(jagg_dmax(iogrp),LYR_agg_dmax(iogrp),1.,0.,cmpflg, & + & 'agg_dmax','aggregate maximum diameter',' ','m') + call wrtlyr(jagg_avdp(iogrp),LYR_agg_avdp(iogrp),1.,0.,cmpflg, & + & 'agg_avdp','mean primary particle diameter',' ','m') + call wrtlyr(jagg_avrhop(iogrp),LYR_agg_avrhop(iogrp),1.,0.,cmpflg, & + & 'agg_avrhop','mean primary particle density',' ','kg m-3') + call wrtlyr(jagg_avdC(iogrp),LYR_agg_avdC(iogrp),1.,0.,cmpflg, & + & 'agg_avdC','Conc.-weighted mean aggregate diameter',' ','m') + call wrtlyr(jagg_df(iogrp),LYR_agg_df(iogrp),1.,0.,cmpflg, & + & 'agg_df','aggregate fractal dimension',' ','-') + call wrtlyr(jagg_b(iogrp),LYR_agg_b(iogrp),1.,0.,cmpflg, & + & 'agg_b','aggregate number distribution slope',' ','-') + call wrtlyr(jagg_Vrhof(iogrp),LYR_agg_Vrhof(iogrp),1.,0.,cmpflg, & + & 'agg_Vrhof','V-weighted aggregate mean density',' ','kg m-3') + call wrtlyr(jagg_Vpor(iogrp),LYR_agg_Vpor(iogrp),1.,0.,cmpflg, & + & 'agg_Vpor','V-weighted aggregate mean porosity',' ','-') ! --- Store 3d level fields call wrtlvl(jlvldic(iogrp),LVL_DIC(iogrp),rnacc*1e3,0.,cmpflg, & @@ -835,6 +1033,95 @@ subroutine ncwrt_bgc(iogrp) call wrtlvl(jlvlbromo(iogrp),LVL_BROMO(iogrp),rnacc*1e3,0., & & cmpflg,'bromolvl','Bromoform',' ','mol CHBr3 m-3') #endif +#ifdef extNcycle + call wrtlvl(jlvlanh4(iogrp),LVL_ANH4(iogrp),rnacc*1e3,0.,cmpflg, & + & 'nh4lvl','Ammonium',' ','mol N m-3') + call wrtlvl(jlvlano2(iogrp),LVL_ANO2(iogrp),rnacc*1e3,0.,cmpflg, & + & 'no2lvl','Nitrite',' ','mol N m-3') + call wrtlvl(jlvl_nitr_NH4(iogrp),LVL_nitr_NH4(iogrp), & + & rnacc*1e3/dtbgc,0.,cmpflg, & + & 'nh4nitrlvl','NH4 nitrification rate',' ','mol N m-3 s-1') + call wrtlvl(jlvl_nitr_NO2(iogrp),LVL_nitr_NO2(iogrp), & + & rnacc*1e3/dtbgc,0.,cmpflg, & + & 'no2nitrlvl','NO2 nitrification rate',' ','mol N m-3 s-1') + call wrtlvl(jlvl_nitr_N2O_prod(iogrp),LVL_nitr_N2O_prod(iogrp), & + & rnacc*1e3/dtbgc,0.,cmpflg, & + & 'nitr_n2olvl','N2O prod during NH4 nitrification',' ', & + & 'mol N2O m-3 s-1') + call wrtlvl(jlvl_nitr_NH4_OM(iogrp),LVL_nitr_NH4_OM(iogrp), & + & rnacc*1e3/dtbgc,0.,cmpflg, & + & 'nh4nitr_omlvl','OM production during NH4 nitrification',' ', & + & 'mol P m-3 s-1') + call wrtlvl(jlvl_nitr_NO2_OM(iogrp),LVL_nitr_NO2_OM(iogrp), & + & rnacc*1e3/dtbgc,0.,cmpflg, & + & 'no2nitr_omlvl','OM production during NO2 nitrification',' ', & + & 'mol P m-3 s-1') + call wrtlvl(jlvl_denit_NO3(iogrp),LVL_denit_NO3(iogrp), & + & rnacc*1e3/dtbgc,0.,cmpflg, & + & 'no3denitlvl','NO3 denitrification rate',' ','mol N m-3 s-1') + call wrtlvl(jlvl_denit_NO2(iogrp),LVL_denit_NO2(iogrp), & + & rnacc*1e3/dtbgc,0.,cmpflg, & + & 'no2denitlvl','NO2 denitrification rate',' ','mol N m-3 s-1') + call wrtlvl(jlvl_denit_N2O(iogrp),LVL_denit_N2O(iogrp), & + & rnacc*1e3/dtbgc,0.,cmpflg, & + & 'n2odenitlvl','N2O denitrification rate',' ','mol N2O m-3 s-1') + call wrtlvl(jlvl_DNRA_NO2(iogrp),LVL_DNRA_NO2(iogrp), & + & rnacc*1e3/dtbgc,0.,cmpflg, & + & 'no2dnralvl','NO2 DNRA rate',' ','mol N m-3 s-1') + call wrtlvl(jlvl_anmx_N2_prod(iogrp),LVL_anmx_N2_prod(iogrp), & + & rnacc*1e3/dtbgc,0.,cmpflg, & + & 'anmx_n2lvl','Anammox N2 production rate',' ','mol N2 m-3 s-1') + call wrtlvl(jlvl_anmx_OM_prod(iogrp),LVL_anmx_OM_prod(iogrp), & + & rnacc*1e3/dtbgc,0.,cmpflg, & + & 'anmx_omlvl','Anammox OM production rate',' ','mol P m-3 s-1') + call wrtlvl(jlvl_phosy_NH4(iogrp),LVL_phosy_NH4(iogrp), & + & rnacc*1e3/dtbgc,0.,cmpflg, & + & 'phosy_nh4lvl','PP consumption rate of NH4',' ', & + & 'mol N m-3 s-1') + call wrtlvl(jlvl_phosy_NO3(iogrp),LVL_phosy_NO3(iogrp), & + & rnacc*1e3/dtbgc,0.,cmpflg, & + & 'phosy_no3lvl','PP consumption rate of NO3',' ', & + & 'mol N m-3 s-1') + call wrtlvl(jlvl_remin_aerob(iogrp),LVL_remin_aerob(iogrp), & + & rnacc*1e3/dtbgc,0.,cmpflg, & + & 'reminalvl','Aerob remineralization rate',' ','mol N m-3 s-1') + call wrtlvl(jlvl_remin_sulf(iogrp),LVL_remin_sulf(iogrp), & + & rnacc*1e3/dtbgc,0.,cmpflg, & + & 'reminslvl','Sulfate remineralization rate',' ','mol P m-3 s-1') +#endif +! M4AGO + call wrtlvl(jlvl_agg_ws(iogrp),LVL_agg_ws(iogrp),rnacc,0.,cmpflg, & + & 'agg_wslvl','aggregate mean settling velocity',' ','m d-1') + call wrtlvl(jlvl_dynvis(iogrp),LVL_dynvis(iogrp),rnacc,0.,cmpflg, & + & 'dynvislvl','dynamic viscosity of sea water',' ','kg m-1 s-1') + call wrtlvl(jlvl_agg_stick(iogrp),LVL_agg_stick(iogrp),rnacc,0., & + & cmpflg, & + & 'agg_sticklvl','aggregate mean stickiness',' ','-') + call wrtlvl(jlvl_agg_stickf(iogrp),LVL_agg_stickf(iogrp),rnacc,0., & + & cmpflg, & + & 'agg_stickflvl','opal frustule stickiness',' ','-') + call wrtlvl(jlvl_agg_dmax(iogrp),LVL_agg_dmax(iogrp),rnacc,0., & + & cmpflg, & + & 'agg_dmaxlvl','aggregate maximum diameter',' ','m') + call wrtlvl(jlvl_agg_avdp(iogrp),LVL_agg_avdp(iogrp),rnacc,0., & + & cmpflg, & + & 'agg_avdplvl','mean primary particle diameter',' ','m') + call wrtlvl(jlvl_agg_avrhop(iogrp),LVL_agg_avrhop(iogrp),rnacc,0., & + & cmpflg, & + & 'agg_avrhoplvl','mean primary particle density',' ','kg m-3') + call wrtlvl(jlvl_agg_avdC(iogrp),LVL_agg_avdC(iogrp),rnacc,0., & + & cmpflg, & + & 'agg_avdClvl','Conc.-weighted mean aggregate diameter',' ','m') + call wrtlvl(jlvl_agg_df(iogrp),LVL_agg_df(iogrp),rnacc,0.,cmpflg, & + & 'agg_dflvl','aggregate fractal dimension',' ','-') + call wrtlvl(jlvl_agg_b(iogrp),LVL_agg_b(iogrp),rnacc,0.,cmpflg, & + & 'agg_blvl','aggregate number distribution slope',' ','-') + call wrtlvl(jlvl_agg_Vrhof(iogrp),LVL_agg_Vrhof(iogrp),rnacc,0., & + & cmpflg, & + & 'agg_Vrhoflvl','V-weighted aggregate mean density',' ','kg m-3') + call wrtlvl(jlvl_agg_Vpor(iogrp),LVL_agg_Vpor(iogrp),rnacc,0., & + & cmpflg, & + & 'agg_Vporlvl','V-weighted aggregate mean porosity',' ','-') ! --- Store sediment fields #ifndef sedbypass @@ -1027,6 +1314,38 @@ subroutine ncwrt_bgc(iogrp) #ifdef BROMO call inilyr(jbromo(iogrp),0.) #endif +#ifdef extNcycle + call inilyr(janh4(iogrp),0.) + call inilyr(jano2(iogrp),0.) + call inilyr(jnitr_NH4(iogrp),0.) + call inilyr(jnitr_NO2(iogrp),0.) + call inilyr(jnitr_N2O_prod(iogrp),0.) + call inilyr(jnitr_NH4_OM(iogrp),0.) + call inilyr(jnitr_NO2_OM(iogrp),0.) + call inilyr(jdenit_NO3(iogrp),0.) + call inilyr(jdenit_NO2(iogrp),0.) + call inilyr(jdenit_N2O(iogrp),0.) + call inilyr(jDNRA_NO2(iogrp),0.) + call inilyr(janmx_N2_prod(iogrp),0.) + call inilyr(janmx_OM_prod(iogrp),0.) + call inilyr(jphosy_NH4(iogrp),0.) + call inilyr(jphosy_NO3(iogrp),0.) + call inilyr(jremin_aerob(iogrp),0.) + call inilyr(jremin_sulf(iogrp),0.) +#endif + ! M4AGO + call inilyr(jagg_ws(iogrp),0.) + call inilyr(jdynvis(iogrp),0.) + call inilyr(jagg_stick(iogrp),0.) + call inilyr(jagg_stickf(iogrp),0.) + call inilyr(jagg_dmax(iogrp),0.) + call inilyr(jagg_avdp(iogrp),0.) + call inilyr(jagg_avrhop(iogrp),0.) + call inilyr(jagg_avdC(iogrp),0.) + call inilyr(jagg_df(iogrp),0.) + call inilyr(jagg_b(iogrp),0.) + call inilyr(jagg_Vrhof(iogrp),0.) + call inilyr(jagg_Vpor(iogrp),0.) call inilvl(jlvldic(iogrp),0.) call inilvl(jlvlalkali(iogrp),0.) @@ -1089,6 +1408,38 @@ subroutine ncwrt_bgc(iogrp) #ifdef BROMO call inilvl(jlvlbromo(iogrp),0.) #endif +#ifdef extNcycle + call inilvl(jlvlanh4(iogrp),0.) + call inilvl(jlvlano2(iogrp),0.) + call inilvl(jlvl_nitr_NH4(iogrp),0.) + call inilvl(jlvl_nitr_NO2(iogrp),0.) + call inilvl(jlvl_nitr_N2O_prod(iogrp),0.) + call inilvl(jlvl_nitr_NH4_OM(iogrp),0.) + call inilvl(jlvl_nitr_NO2_OM(iogrp),0.) + call inilvl(jlvl_denit_NO3(iogrp),0.) + call inilvl(jlvl_denit_NO2(iogrp),0.) + call inilvl(jlvl_denit_N2O(iogrp),0.) + call inilvl(jlvl_DNRA_NO2(iogrp),0.) + call inilvl(jlvl_anmx_N2_prod(iogrp),0.) + call inilvl(jlvl_anmx_OM_prod(iogrp),0.) + call inilvl(jlvl_phosy_NH4(iogrp),0.) + call inilvl(jlvl_phosy_NO3(iogrp),0.) + call inilvl(jlvl_remin_aerob(iogrp),0.) + call inilvl(jlvl_remin_sulf(iogrp),0.) +#endif + ! M4AGO + call inilvl(jlvl_agg_ws(iogrp),0.) + call inilvl(jlvl_dynvis(iogrp),0.) + call inilvl(jlvl_agg_stick(iogrp),0.) + call inilvl(jlvl_agg_stickf(iogrp),0.) + call inilvl(jlvl_agg_dmax(iogrp),0.) + call inilvl(jlvl_agg_avdp(iogrp),0.) + call inilvl(jlvl_agg_avrhop(iogrp),0.) + call inilvl(jlvl_agg_avdC(iogrp),0.) + call inilvl(jlvl_agg_df(iogrp),0.) + call inilvl(jlvl_agg_b(iogrp),0.) + call inilvl(jlvl_agg_Vrhof(iogrp),0.) + call inilvl(jlvl_agg_Vpor(iogrp),0.) #ifndef sedbypass call inisdm(jpowaic(iogrp),0.) @@ -1137,7 +1488,15 @@ subroutine hamoccvardef(iogrp,timeunits,calendar,cmpflg) & lvl_silica,lvl_doc,lvl_phyto,lvl_grazer,lvl_poc,lvl_calc, & & lvl_opal,lvl_iron,lvl_phosy,lvl_co3,lvl_ph,lvl_omegaa, & & lvl_omegac,lvl_n2o,lvl_prefo2,lvl_o2sat,lvl_prefpo4, & - & lvl_prefalk,lvl_prefdic,lvl_dicsat + & lvl_prefalk,lvl_prefdic,lvl_dicsat, & + & lyr_agg_ws,lyr_dynvis,lyr_agg_stick, & + & lyr_agg_stickf,lyr_agg_dmax,lyr_agg_avdp, & + & lyr_agg_avrhop,lyr_agg_avdC,lyr_agg_df, & + & lyr_agg_b,lyr_agg_Vrhof,lyr_agg_Vpor, & + & lvl_agg_ws,lvl_dynvis,lvl_agg_stick, & + & lvl_agg_stickf,lvl_agg_dmax,lvl_agg_avdp, & + & lvl_agg_avrhop,lvl_agg_avdC,lvl_agg_df, & + & lvl_agg_b,lvl_agg_Vrhof,lvl_agg_Vpor #ifdef AGG use mo_bgcmean, only: lyr_nos,lyr_wphy,lyr_wnos,lyr_eps, & & lyr_asize,lvl_nos,lvl_wphy,lvl_wnos,lvl_eps,lvl_asize @@ -1174,6 +1533,36 @@ subroutine hamoccvardef(iogrp,timeunits,calendar,cmpflg) & sdm_pown2,sdm_powno3,sdm_powasi,sdm_ssso12,sdm_ssssil, & & sdm_sssc12,sdm_ssster,bur_ssso12,bur_sssc12,bur_ssssil, & & bur_ssster +#endif +#ifdef extNcycle + use mo_bgcmean, only: janh4,jano2,jlvlanh4,jlvlano2,jsrfanh4, & + & jsrfano2,janh3fx,srf_anh4,srf_ano2, & + & srf_anh3fx,lyr_anh4,lyr_ano2,lvl_anh4, & + & lvl_ano2, & + & LYR_nitr_NH4,LYR_nitr_NO2,LYR_nitr_N2O_prod, & + & LYR_nitr_NH4_OM,LYR_nitr_NO2_OM, & + & LYR_denit_NO3,LYR_denit_NO2,LYR_denit_N2O, & + & LYR_DNRA_NO2,LYR_anmx_N2_prod, & + & LYR_anmx_OM_prod,LYR_phosy_NH4, & + & LYR_phosy_NO3,LYR_remin_aerob,LYR_remin_sulf, & + & LVL_nitr_NH4,LVL_nitr_NO2,LVL_nitr_N2O_prod, & + & LVL_nitr_NH4_OM,LVL_nitr_NO2_OM, & + & LVL_denit_NO3,LVL_denit_NO2,LVL_denit_N2O, & + & LVL_DNRA_NO2,LVL_anmx_N2_prod, & + & LVL_anmx_OM_prod,LVL_phosy_NH4, & + & LVL_phosy_NO3,LVL_remin_aerob,LVL_remin_sulf, & + & jnitr_NH4,jnitr_NO2,jnitr_N2O_prod, & + & jnitr_NH4_OM,jnitr_NO2_OM,jdenit_NO3, & + & jdenit_NO2,jdenit_N2O,jDNRA_NO2, & + & janmx_N2_prod,janmx_OM_prod,jphosy_NH4, & + & jphosy_NO3,jremin_aerob,jremin_sulf, & + & jlvl_nitr_NH4,jlvl_nitr_NO2, & + & jlvl_nitr_N2O_prod,jlvl_nitr_NH4_OM, & + & jlvl_nitr_NO2_OM,jlvl_denit_NO3, & + & jlvl_denit_NO2,jlvl_denit_N2O,jlvl_DNRA_NO2, & + & jlvl_anmx_N2_prod,jlvl_anmx_OM_prod, & + & jlvl_phosy_NH4,jlvl_phosy_NO3, & + & jlvl_remin_aerob,jlvl_remin_sulf #endif implicit none @@ -1362,7 +1751,14 @@ subroutine hamoccvardef(iogrp,timeunits,calendar,cmpflg) call ncdefvar3d(SRF_ATMC14(iogrp),cmpflg,'p', & & 'atmc14','Atmospheric 14CO2',' ','ppm',0) #endif - +#ifdef extNcycle + call ncdefvar3d(SRF_ANH4(iogrp),cmpflg,'p','srfnh4', & + & 'Surface ammonium',' ','mol N m-3',0) + call ncdefvar3d(SRF_ANO2(iogrp),cmpflg,'p','srfno2', & + & 'Surface nitrite',' ','mol N m-3',0) + call ncdefvar3d(SRF_ANH3FX(iogrp),cmpflg,'p','nh3flux', & + & 'NH3 flux',' ','mol NH3 m-2 s-1',0) +#endif ! --- define 3d layer fields call ncdefvar3d(LYR_DP(iogrp),cmpflg,'p', & & 'pddpo','Layer thickness',' ','m',1) @@ -1478,6 +1874,70 @@ subroutine hamoccvardef(iogrp,timeunits,calendar,cmpflg) call ncdefvar3d(LYR_BROMO(iogrp),cmpflg,'p', & & 'bromo','Bromoform',' ','mol CHBr3 m-3',1) #endif +#ifdef extNcycle + call ncdefvar3d(LYR_ANH4(iogrp),cmpflg,'p', & + & 'nh4','Ammonium',' ','mol N m-3',1) + call ncdefvar3d(LYR_ANO2(iogrp),cmpflg,'p', & + & 'no2','Nitrite',' ','mol N m-3',1) + call ncdefvar3d(LYR_nitr_NH4(iogrp),cmpflg,'p', & + & 'nh4nitr','NH4 nitrification rate',' ','mol N m-3 s-1',1) + call ncdefvar3d(LYR_nitr_NO2(iogrp),cmpflg,'p', & + & 'no2nitr','NO2 nitrification rate',' ','mol N m-3 s-1',1) + call ncdefvar3d(LYR_nitr_N2O_prod(iogrp),cmpflg,'p', & + & 'nitr_n2o','N2O prod during NH4 nitrification',' ', & + & 'mol N2O m-3 s-1',1) + call ncdefvar3d(LYR_nitr_NH4_OM(iogrp),cmpflg,'p', & + & 'nh4nitr_om','OM production during NH4 nitrification',' ', & + & 'mol P m-3 s-1',1) + call ncdefvar3d(LYR_nitr_NO2_OM(iogrp),cmpflg,'p', & + & 'no2nitr_om','OM production during NO2 nitrification',' ', & + & 'mol P m-3 s-1',1) + call ncdefvar3d(LYR_denit_NO3(iogrp),cmpflg,'p', & + & 'no3denit','NO3 denitrification rate',' ','mol N m-3 s-1',1) + call ncdefvar3d(LYR_denit_NO2(iogrp),cmpflg,'p', & + & 'no2denit','NO2 denitrification rate',' ','mol N m-3 s-1',1) + call ncdefvar3d(LYR_denit_N2O(iogrp),cmpflg,'p', & + & 'n2odenit','N2O denitrification rate',' ','mol N2O m-3 s-1',1) + call ncdefvar3d(LYR_DNRA_NO2(iogrp),cmpflg,'p', & + & 'no2dnra','NO2 DNRA rate',' ','mol N m-3 s-1',1) + call ncdefvar3d(LYR_anmx_N2_prod(iogrp),cmpflg,'p', & + & 'anmx_n2','Anammox N2 production rate',' ','mol N2 m-3 s-1',1) + call ncdefvar3d(LYR_anmx_OM_prod(iogrp),cmpflg,'p', & + & 'anmx_om','Anammox OM production rate',' ','mol P m-3 s-1',1) + call ncdefvar3d(LYR_phosy_NH4(iogrp),cmpflg,'p', & + & 'phosy_nh4','PP consumption rate of NH4',' ','mol N m-3 s-1',1) + call ncdefvar3d(LYR_phosy_NO3(iogrp),cmpflg,'p', & + & 'phosy_no3','PP consumption rate of NO3',' ','mol N m-3 s-1',1) + call ncdefvar3d(LYR_remin_aerob(iogrp),cmpflg,'p', & + & 'remina','Aerob remineralization rate',' ','mol N m-3 s-1',1) + call ncdefvar3d(LYR_remin_sulf(iogrp),cmpflg,'p', & + & 'remins','Sulfate remineralization rate',' ','mol P m-3 s-1',1) +#endif + ! M4AGO + call ncdefvar3d(LYR_agg_ws(iogrp),cmpflg,'p', & + & 'agg_ws','aggregate mean settling velocity',' ','m d-1',1) + call ncdefvar3d(LYR_dynvis(iogrp),cmpflg,'p', & + & 'dynvis','dynamic viscosity of sea water',' ','kg m-1 s-1',1) + call ncdefvar3d(LYR_agg_stick(iogrp),cmpflg,'p', & + & 'agg_stick','aggregate mean stickiness',' ','-',1) + call ncdefvar3d(LYR_agg_stickf(iogrp),cmpflg,'p', & + & 'agg_stickf','opal frustule stickiness',' ','-',1) + call ncdefvar3d(LYR_agg_dmax(iogrp),cmpflg,'p', & + & 'agg_dmax','aggregate maximum diameter',' ','m',1) + call ncdefvar3d(LYR_agg_avdp(iogrp),cmpflg,'p', & + & 'agg_avdp','mean primary particle diameter',' ','m',1) + call ncdefvar3d(LYR_agg_avrhop(iogrp),cmpflg,'p', & + & 'agg_avrhop','mean primary particle density',' ','kg m-3',1) + call ncdefvar3d(LYR_agg_avdC(iogrp),cmpflg,'p', & + & 'agg_avdC','Conc.-weighted mean aggregate diameter',' ','m',1) + call ncdefvar3d(LYR_agg_df(iogrp),cmpflg,'p', & + & 'agg_df','aggregate fractal dimension',' ','-',1) + call ncdefvar3d(LYR_agg_b(iogrp),cmpflg,'p', & + & 'agg_b','aggregate number distribution slope',' ','-',1) + call ncdefvar3d(LYR_agg_Vrhof(iogrp),cmpflg,'p', & + & 'agg_Vrhof','V-weighted aggregate mean density',' ','kg m-3',1) + call ncdefvar3d(LYR_agg_Vpor(iogrp),cmpflg,'p', & + & 'agg_Vpor','V-weighted aggregate mean porosity',' ','-',1) ! --- define 3d level fields call ncdefvar3d(LVL_DIC(iogrp),cmpflg,'p', & @@ -1592,6 +2052,79 @@ subroutine hamoccvardef(iogrp,timeunits,calendar,cmpflg) call ncdefvar3d(LVL_BROMO(iogrp),cmpflg,'p', & & 'bromolvl','Bromoform',' ','mol CHBr3 m-3',2) #endif +#ifdef extNcycle + call ncdefvar3d(LVL_ANH4(iogrp),cmpflg,'p', & + & 'nh4lvl','Ammonium',' ','mol N m-3',2) + call ncdefvar3d(LVL_ANO2(iogrp),cmpflg,'p', & + & 'no2lvl','Nitrite',' ','mol N m-3',2) + call ncdefvar3d(LVL_nitr_NH4(iogrp),cmpflg,'p', & + & 'nh4nitrlvl','NH4 nitrification rate',' ','mol N m-3 s-1',2) + call ncdefvar3d(LVL_nitr_NO2(iogrp),cmpflg,'p', & + & 'no2nitrlvl','NO2 nitrification rate',' ','mol N m-3 s-1',2) + call ncdefvar3d(LVL_nitr_N2O_prod(iogrp),cmpflg,'p', & + & 'nitr_n2olvl','N2O prod during NH4 nitrification',' ', & + & 'mol N2O m-3 s-1',2) + call ncdefvar3d(LVL_nitr_NH4_OM(iogrp),cmpflg,'p', & + & 'nh4nitr_omlvl','OM production during NH4 nitrification',' ', & + & 'mol P m-3 s-1',2) + call ncdefvar3d(LVL_nitr_NO2_OM(iogrp),cmpflg,'p', & + & 'no2nitr_omlvl','OM production during NO2 nitrification',' ', & + & 'mol P m-3 s-1',2) + call ncdefvar3d(LVL_denit_NO3(iogrp),cmpflg,'p', & + & 'no3denitlvl','NO3 denitrification rate',' ','mol N m-3 s-1',2) + call ncdefvar3d(LVL_denit_NO2(iogrp),cmpflg,'p', & + & 'no2denitlvl','NO2 denitrification rate',' ','mol N m-3 s-1',2) + call ncdefvar3d(LVL_denit_N2O(iogrp),cmpflg,'p', & + & 'n2odenitlvl','N2O denitrification rate',' ', & + & 'mol N2O m-3 s-1',2) + call ncdefvar3d(LVL_DNRA_NO2(iogrp),cmpflg,'p', & + & 'no2dnralvl','NO2 DNRA rate',' ','mol N m-3 s-1',2) + call ncdefvar3d(LVL_anmx_N2_prod(iogrp),cmpflg,'p', & + & 'anmx_n2lvl','Anammox N2 production rate',' ', & + & 'mol N2 m-3 s-1',2) + call ncdefvar3d(LVL_anmx_OM_prod(iogrp),cmpflg,'p', & + & 'anmx_omlvl','Anammox OM production rate',' ','mol P m-3 s-1',2) + call ncdefvar3d(LVL_phosy_NH4(iogrp),cmpflg,'p', & + & 'phosy_nh4lvl','PP consumption rate of NH4',' ', & + & 'mol N m-3 s-1',2) + call ncdefvar3d(LVL_phosy_NO3(iogrp),cmpflg,'p', & + & 'phosy_no3lvl','PP consumption rate of NO3',' ', & + & 'mol N m-3 s-1',2) + call ncdefvar3d(LVL_remin_aerob(iogrp),cmpflg,'p', & + & 'reminalvl','Aerob remineralization rate',' ', & + & 'mol N m-3 s-1',2) + call ncdefvar3d(LVL_remin_sulf(iogrp),cmpflg,'p', & + & 'reminslvl','Sulfate remineralization rate',' ', & + & 'mol P m-3 s-1',2) +#endif + ! M4AGO + call ncdefvar3d(LVL_agg_ws(iogrp),cmpflg,'p', & + & 'agg_wslvl','aggregate mean settling velocity',' ','m d-1',2) + call ncdefvar3d(LVL_dynvis(iogrp),cmpflg,'p', & + & 'dynvislvl','dynamic viscosity of sea water',' ','kg m-1 s-1', & + & 2) + call ncdefvar3d(LVL_agg_stick(iogrp),cmpflg,'p', & + & 'agg_sticklvl','aggregate mean stickiness',' ','-',2) + call ncdefvar3d(LVL_agg_stickf(iogrp),cmpflg,'p', & + & 'agg_stickflvl','opal frustule stickiness',' ','-',2) + call ncdefvar3d(LVL_agg_dmax(iogrp),cmpflg,'p', & + & 'agg_dmaxlvl','aggregate maximum diameter',' ','m',2) + call ncdefvar3d(LVL_agg_avdp(iogrp),cmpflg,'p', & + & 'agg_avdplvl','mean primary particle diameter',' ','m',2) + call ncdefvar3d(LVL_agg_avrhop(iogrp),cmpflg,'p', & + & 'agg_avrhoplvl','mean primary particle density',' ','kg m-3',2) + call ncdefvar3d(LVL_agg_avdC(iogrp),cmpflg,'p', & + & 'agg_avdClvl','Conc.-weighted mean aggregate diameter',' ', & + & 'm',2) + call ncdefvar3d(LVL_agg_df(iogrp),cmpflg,'p', & + & 'agg_dflvl','aggregate fractal dimension',' ','-',2) + call ncdefvar3d(LVL_agg_b(iogrp),cmpflg,'p', & + & 'agg_blvl','aggregate number distribution slope',' ','-',2) + call ncdefvar3d(LVL_agg_Vrhof(iogrp),cmpflg,'p', & + & 'agg_Vrhoflvl','V-weighted aggregate mean density',' ', & + & 'kg m-3',2) + call ncdefvar3d(LVL_agg_Vpor(iogrp),cmpflg,'p', & + & 'agg_Vporlvl','V-weighted aggregate mean porosity',' ','-',2) ! --- define sediment fields #ifndef sedbypass From 3943f5e0d494d2cb72dde66db21a2a058b1993c6 Mon Sep 17 00:00:00 2001 From: JorgSchwinger Date: Thu, 25 Aug 2022 10:38:15 +0200 Subject: [PATCH 144/366] Update description in some module headers that were outdated --- hamocc/mo_apply_ndep.F90 | 2 +- hamocc/mo_read_fedep.F90 | 10 +++++++--- hamocc/mo_read_ndep.F90 | 28 ++++++++++++++-------------- 3 files changed, 22 insertions(+), 18 deletions(-) diff --git a/hamocc/mo_apply_ndep.F90 b/hamocc/mo_apply_ndep.F90 index cd16ac47..36d7159b 100644 --- a/hamocc/mo_apply_ndep.F90 +++ b/hamocc/mo_apply_ndep.F90 @@ -45,7 +45,7 @@ module mo_apply_ndep ! N deposition is activated through a logical switch 'do_ndep' read from ! HAMOCC's bgcnml namelist. ! -! -subroutine n_deposition +! -subroutine apply_ndep ! Apply n-deposition to the top-most model layer. ! ! diff --git a/hamocc/mo_read_fedep.F90 b/hamocc/mo_read_fedep.F90 index 1e41cb14..61210a87 100644 --- a/hamocc/mo_read_fedep.F90 +++ b/hamocc/mo_read_fedep.F90 @@ -22,10 +22,14 @@ module mo_read_fedep ! MODULE mo_read_fedep - routines for reading iron deposition data ! ! -! J.Schwinger, *NORCE Climate, Bergen* 2020-05-27 +! J.Schwinger, *NORCE Climate, Bergen* 2020-05-27 ! ! Modified ! -------- +! J. Schwinger, *NORCE climate, Bergen* 2022-06-02 +! -revise structure of this module, split into a module for reading the +! data (mo_read_fedep) and a module that applies the fluxes in core +! hamocc (mo_apply_fedep) ! ! Purpose ! ------- @@ -36,8 +40,8 @@ module mo_read_fedep ! ------------ ! Public routines and variable of this module: ! -! -subroutine ini_fedep -! Initialise the iron deposition module. +! -subroutine ini_read_fedep +! Initialise the module for reading iron deposition data ! ! -subroutine get_fedep ! Get the iron (dust) deposition for a given month diff --git a/hamocc/mo_read_ndep.F90 b/hamocc/mo_read_ndep.F90 index a501de35..191dac74 100644 --- a/hamocc/mo_read_ndep.F90 +++ b/hamocc/mo_read_ndep.F90 @@ -34,36 +34,36 @@ module mo_read_ndep ! -put reading of a time-slice of n-deposition data into own subroutine ! -removed default file name ! +! J. Schwinger, *NORCE climate, Bergen* 2022-06-02 +! -revise structure of this module, split into a module for reading the +! data (mo_read_ndep) and a module that applies the fluxes in core +! hamocc (mo_apply_ndep) +! ! ! Purpose ! ------- -! -Routines for reading and applying nitrogen deposition fluxes +! -Routines for reading nitrogen deposition fluxes from netcdf files ! ! ! Description: ! ------------ ! -! The routine n_deposition reads nitrogen deposition from file and applies it -! to the top-most model layer. +! The routine get_ndep reads nitrogen deposition from file. The n-deposition +! field is then passed to hamocc4bcm where it is applied to the top-most model +! layer by a call to apply_ndep (mo_apply_ndep). ! ! N deposition is activated through a logical switch 'do_ndep' read from ! HAMOCC's bgcnml namelist. If N deposition is acitvated, a valid filename -! needs to be provided via HAMOCC's bgcnml namelist (variable ndepfile). If -! the input file is not found, an error will be issued. -! -! The input data must be already pre-interpolated to the ocean grid and stored -! in the same folder with BLOM's grid information. +! (including the full path) needs to be provided via HAMOCC's bgcnml namelist +! (variable ndepfile). If the input file is not found, an error will be issued. +! The input data must be already pre-interpolated to the ocean grid. ! -! -subroutine ini_ndep -! Initialise the n-deposition module +! -subroutine ini_read_ndep +! Initialise the module ! ! -subroutine get_ndep ! Read and return n-deposition data for a given month. ! -! -subroutine n_deposition -! Apply n-deposition to the top-most model layer. -! -! !****************************************************************************** implicit none From 390a44ae68eb10c25e54058ae16607b8aae5c731 Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Thu, 25 Aug 2022 17:32:19 +0200 Subject: [PATCH 145/366] FIX to enable run without extended nitrogen cycle --- hamocc/accfields.F90 | 9 +++++---- hamocc/mo_biomod.F90 | 3 --- 2 files changed, 5 insertions(+), 7 deletions(-) diff --git a/hamocc/accfields.F90 b/hamocc/accfields.F90 index aaf91fa0..ab0fc5d2 100644 --- a/hamocc/accfields.F90 +++ b/hamocc/accfields.F90 @@ -67,6 +67,10 @@ SUBROUTINE ACCFIELDS(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask) & jpoc,jprefalk,jprefdic,jprefo2,jprefpo4,jsilica,jsrfalkali,jsrfano3,jsrfdic,jsrfiron,jsrfoxygen, & & jsrfphosph,jsrfphyto,jsrfsilica,jwnos,jwphy,nbgc,nacc_bgc,bgcwrt,glb_inventory,bgct2d,acclvl, & & acclyr,accsrf,bgczlv,jlvlanh4,jlvlano2, & + & jlvl_nitr_NH4, & + & jlvl_nitr_NO2,jlvl_nitr_N2O_prod,jlvl_nitr_NH4_OM,jlvl_nitr_NO2_OM,jlvl_denit_NO3,jlvl_denit_NO2, & + & jlvl_denit_N2O,jlvl_DNRA_NO2,jlvl_anmx_N2_prod,jlvl_anmx_OM_prod,jlvl_phosy_NH4,jlvl_phosy_NO3, & + & jlvl_remin_aerob,jlvl_remin_sulf, & & jagg_ws,jdynvis,jagg_stick,jagg_stickf,jagg_dmax,jagg_avdp,jagg_avrhop,jagg_avdC,jagg_df,jagg_b, & & jagg_Vrhof,jagg_Vpor,jlvl_agg_ws,jlvl_dynvis,jlvl_agg_stick,jlvl_agg_stickf,jlvl_agg_dmax, & & jlvl_agg_avdp,jlvl_agg_avrhop,jlvl_agg_avdC,jlvl_agg_df,jlvl_agg_b,jlvl_agg_Vrhof,jlvl_agg_Vpor @@ -114,10 +118,7 @@ SUBROUTINE ACCFIELDS(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask) use mo_param1_bgc, only: iatmnh3,ianh4,iano2 use mo_bgcmean, only: jnh3flux,janh3fx,janh4,jano2,jsrfanh4,jsrfano2, & & jnitr_NH4,jnitr_NO2,jnitr_N2O_prod,jnitr_NH4_OM,jnitr_NO2_OM,jdenit_NO3,jdenit_NO2,jdenit_N2O, & - & jDNRA_NO2,janmx_N2_prod,janmx_OM_prod,jphosy_NH4,jphosy_NO3,jremin_aerob,jremin_sulf,jlvl_nitr_NH4, & - & jlvl_nitr_NO2,jlvl_nitr_N2O_prod,jlvl_nitr_NH4_OM,jlvl_nitr_NO2_OM,jlvl_denit_NO3,jlvl_denit_NO2, & - & jlvl_denit_N2O,jlvl_DNRA_NO2,jlvl_anmx_N2_prod,jlvl_anmx_OM_prod,jlvl_phosy_NH4,jlvl_phosy_NO3, & - & jlvl_remin_aerob,jlvl_remin_sulf + & jDNRA_NO2,janmx_N2_prod,janmx_OM_prod,jphosy_NH4,jphosy_NO3,jremin_aerob,jremin_sulf use mo_biomod, only: nitr_NH4,nitr_NO2,nitr_N2O_prod,nitr_NH4_OM,nitr_NO2_OM,denit_NO3,denit_NO2,denit_N2O,DNRA_NO2, & & anmx_N2_prod,anmx_OM_prod,phosy_NH4,phosy_NO3,remin_aerob,remin_sulf #endif diff --git a/hamocc/mo_biomod.F90 b/hamocc/mo_biomod.F90 index f69edade..8cadee2d 100644 --- a/hamocc/mo_biomod.F90 +++ b/hamocc/mo_biomod.F90 @@ -92,12 +92,9 @@ MODULE mo_biomod REAL, DIMENSION (:,:), ALLOCATABLE :: int_chbr3_prod REAL, DIMENSION (:,:), ALLOCATABLE :: int_chbr3_uv #endif -#ifdef extNcycle REAL, DIMENSION (:,:,:), ALLOCATABLE :: nitr_NH4,nitr_NO2,nitr_N2O_prod,nitr_NH4_OM,nitr_NO2_OM,denit_NO3,denit_NO2, & & denit_N2O,DNRA_NO2,anmx_N2_prod,anmx_OM_prod,phosy_NH4,phosy_NO3,remin_aerob, & & remin_sulf -#endif - REAL :: phytomi,grami,grazra,pi_alpha REAL :: remido,dyphy,zinges,epsher,spemor,gammap,gammaz,ecan REAL :: ro2ut,rcar,rnit,rnoi,rdnit0,rdnit1,rdnit2,rdn2o1,rdn2o2,rcalc,ropal From ec00ef719735dcca39eb79f4bd1b7de478687e75 Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Fri, 26 Aug 2022 17:27:11 +0200 Subject: [PATCH 146/366] removed whitespace --- hamocc/hamocc_init.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/hamocc/hamocc_init.F90 b/hamocc/hamocc_init.F90 index fcfbe321..b99db062 100644 --- a/hamocc/hamocc_init.F90 +++ b/hamocc/hamocc_init.F90 @@ -64,7 +64,7 @@ subroutine hamocc_init(read_rest,rstfnm_hamocc) & bgc_dx,bgc_dy,bgc_dp,bgc_rho, & & omask,sedlay2,powtra2,burial2, & & blom2hamocc - use mo_m4ago, only: alloc_mem_m4ago + use mo_m4ago, only: alloc_mem_m4ago #ifdef BOXATM use mo_intfcblom, only: atm2 #endif From 335e14893f0eb040812ccf76eeebb62725a2b4b5 Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Mon, 29 Aug 2022 12:55:07 +0200 Subject: [PATCH 147/366] adjust indentation of loops to original iHAMOCC style --- hamocc/mo_extNbioproc.F90 | 208 +++++++++--------- hamocc/mo_m4ago.F90 | 442 +++++++++++++++++++------------------- 2 files changed, 325 insertions(+), 325 deletions(-) diff --git a/hamocc/mo_extNbioproc.F90 b/hamocc/mo_extNbioproc.F90 index e67b2f8f..004c3ef8 100644 --- a/hamocc/mo_extNbioproc.F90 +++ b/hamocc/mo_extNbioproc.F90 @@ -213,24 +213,24 @@ subroutine nitrification(kpie,kpje,kpke,kbnd,pddpo,omask,ptho) !$OMP nitrfrac,totd,amox,nitr,temp,no2fn2o,no2fno2,no2fdetamox) do j = 1,kpje - do i = 1,kpie - do k = 1,kpke - if(pddpo(i,j,k) > dp_min .and. omask(i,j) > 0.5) then - potdnh4amox = 0. - fn2o = 0. - fno2 = 0. - fdetamox = 0. - potdno2nitr = 0. - fdetnitr = 0. - - if(ocetra(i,j,k,ioxygen)>minlim_oxnh4 .and. ocetra(i,j,k,ianh4)>minlim_nh4)then - temp = merge(ptho(i,j,k),10.,ptho(i,j,k)<40.) - ! Ammonium oxidation step of nitrification - Tdepanh4 = q10anh4nitr**((temp-Trefanh4nitr)/10.) - O2limanh4 = ocetra(i,j,k,ioxygen)/(ocetra(i,j,k,ioxygen) + bkoxamox) - nut1lim = ocetra(i,j,k,ianh4)/(ocetra(i,j,k,ianh4) + bkanh4nitr) - anh4new = ocetra(i,j,k,ianh4)/(1. + ranh4nitr*Tdepanh4*O2limanh4*nut1lim) - potdnh4amox = max(0.,ocetra(i,j,k,ianh4) - anh4new) + do i = 1,kpie + do k = 1,kpke + if(pddpo(i,j,k) > dp_min .and. omask(i,j) > 0.5) then + potdnh4amox = 0. + fn2o = 0. + fno2 = 0. + fdetamox = 0. + potdno2nitr = 0. + fdetnitr = 0. + + if(ocetra(i,j,k,ioxygen)>minlim_oxnh4 .and. ocetra(i,j,k,ianh4)>minlim_nh4)then + temp = merge(ptho(i,j,k),10.,ptho(i,j,k)<40.) + ! Ammonium oxidation step of nitrification + Tdepanh4 = q10anh4nitr**((temp-Trefanh4nitr)/10.) + O2limanh4 = ocetra(i,j,k,ioxygen)/(ocetra(i,j,k,ioxygen) + bkoxamox) + nut1lim = ocetra(i,j,k,ianh4)/(ocetra(i,j,k,ianh4) + bkanh4nitr) + anh4new = ocetra(i,j,k,ianh4)/(1. + ranh4nitr*Tdepanh4*O2limanh4*nut1lim) + potdnh4amox = max(0.,ocetra(i,j,k,ianh4) - anh4new) ! pathway splitting functions according to Goreau 1980 !===== @@ -241,81 +241,81 @@ subroutine nitrification(kpie,kpje,kpke,kbnd,pddpo,omask,ptho) !fn2o = 1. - (1.-0.00157)*ocetra(i,j,k,ioxygen)/(ocetra(i,j,k,ioxygen) + bkamoxn2o) ! 0.11/(50*1e6)=2.2e-9 - ~Santoro et al. 2011 with simple MM - fn2o = 2.2e-9/bkoxamox * (0.3 + 0.7*bkoxamox/(ocetra(i,j,k,ioxygen)+bkoxamox)) & + fn2o = 2.2e-9/bkoxamox * (0.3 + 0.7*bkoxamox/(ocetra(i,j,k,ioxygen)+bkoxamox)) & * ocetra(i,j,k,ianh4)/(ocetra(i,j,k,ianh4)+bkamoxn2o) - ! continue using the 'old' fno2 - neglecting NH4 term here - which doesn'y make a huge difference, - ! assuming that it's never really limited + ! continue using the 'old' fno2 - neglecting NH4 term here - which doesn'y make a huge difference, + ! assuming that it's never really limited !===== - fno2 = ocetra(i,j,k,ioxygen)/(ocetra(i,j,k,ioxygen) + bkamoxno2) - fdetamox = n2omaxy*2.*(1. + n2oybeta)*ocetra(i,j,k,ioxygen)*bkyamox & + fno2 = ocetra(i,j,k,ioxygen)/(ocetra(i,j,k,ioxygen) + bkamoxno2) + fdetamox = n2omaxy*2.*(1. + n2oybeta)*ocetra(i,j,k,ioxygen)*bkyamox & & /(ocetra(i,j,k,ioxygen)**2 + 2.*ocetra(i,j,k,ioxygen)*bkyamox + bkyamox**2) - ! normalization of pathway splitting functions to sum=1 - ftotnh4 = fn2o + fno2 + fdetamox + eps - fn2o = fn2o/ftotnh4 - fno2 = fno2/ftotnh4 - fdetamox = 1. - (fn2o + fno2) - endif - - if(ocetra(i,j,k,ioxygen)>minlim_oxno2 .and. ocetra(i,j,k,iano2)>minlim_no2)then - temp = merge(ptho(i,j,k),10.,ptho(i,j,k)<40.) - ! NO2 oxidizing step of nitrification - Tdepano2 = q10ano2nitr**((temp-Trefano2nitr)/10.) - O2limano2 = ocetra(i,j,k,ioxygen)/(ocetra(i,j,k,ioxygen) + bkoxnitr) - nut2lim = ocetra(i,j,k,iano2)/(ocetra(i,j,k,iano2) + bkano2nitr) - ano2new = ocetra(i,j,k,iano2)/(1. + rano2nitr*Tdepano2*O2limano2*nut2lim) - potdno2nitr = max(0.,ocetra(i,j,k,iano2) - ano2new) - - ! pathway splitting functions for NO2 nitrification - assuming to be the same as for NH4 - ! but with reduced OM gain per used NO2 as energy source (in amox: NH4) - no2fn2o = 1. - ocetra(i,j,k,ioxygen)/(ocetra(i,j,k,ioxygen) + bkamoxn2o) - no2fno2 = ocetra(i,j,k,ioxygen)/(ocetra(i,j,k,ioxygen) + bkamoxno2) - no2fdetamox = NOB2AOAy*n2omaxy*2.*(1. + n2oybeta)*ocetra(i,j,k,ioxygen)*bkyamox & + ! normalization of pathway splitting functions to sum=1 + ftotnh4 = fn2o + fno2 + fdetamox + eps + fn2o = fn2o/ftotnh4 + fno2 = fno2/ftotnh4 + fdetamox = 1. - (fn2o + fno2) + endif + + if(ocetra(i,j,k,ioxygen)>minlim_oxno2 .and. ocetra(i,j,k,iano2)>minlim_no2)then + temp = merge(ptho(i,j,k),10.,ptho(i,j,k)<40.) + ! NO2 oxidizing step of nitrification + Tdepano2 = q10ano2nitr**((temp-Trefano2nitr)/10.) + O2limano2 = ocetra(i,j,k,ioxygen)/(ocetra(i,j,k,ioxygen) + bkoxnitr) + nut2lim = ocetra(i,j,k,iano2)/(ocetra(i,j,k,iano2) + bkano2nitr) + ano2new = ocetra(i,j,k,iano2)/(1. + rano2nitr*Tdepano2*O2limano2*nut2lim) + potdno2nitr = max(0.,ocetra(i,j,k,iano2) - ano2new) + + ! pathway splitting functions for NO2 nitrification - assuming to be the same as for NH4 + ! but with reduced OM gain per used NO2 as energy source (in amox: NH4) + no2fn2o = 1. - ocetra(i,j,k,ioxygen)/(ocetra(i,j,k,ioxygen) + bkamoxn2o) + no2fno2 = ocetra(i,j,k,ioxygen)/(ocetra(i,j,k,ioxygen) + bkamoxno2) + no2fdetamox = NOB2AOAy*n2omaxy*2.*(1. + n2oybeta)*ocetra(i,j,k,ioxygen)*bkyamox & & /(ocetra(i,j,k,ioxygen)**2 + 2.*ocetra(i,j,k,ioxygen)*bkyamox + bkyamox**2) - fdetnitr = no2fdetamox/(no2fno2 + no2fn2o) ! yield to energy usage ratio for NO2 -> ratio equals 16:x - endif + fdetnitr = no2fdetamox/(no2fno2 + no2fn2o) ! yield to energy usage ratio for NO2 -> ratio equals 16:x + endif - ! limitation of the two processes through available nutrients, etc. - totd = potdnh4amox + potdno2nitr - amoxfrac = potdnh4amox/(totd + eps) - nitrfrac = 1. - amoxfrac + ! limitation of the two processes through available nutrients, etc. + totd = potdnh4amox + potdno2nitr + amoxfrac = potdnh4amox/(totd + eps) + nitrfrac = 1. - amoxfrac - totd = max(0., & - & min(totd, & - & ocetra(i,j,k,ianh4)/(amoxfrac + fdetnitr*nitrfrac + eps), & ! ammonium - & ocetra(i,j,k,isco212)/(rc2n*(fdetamox*amoxfrac + fdetnitr*nitrfrac) + eps), & ! CO2 - & ocetra(i,j,k,iphosph)/(rnoi*(fdetamox*amoxfrac + fdetnitr*nitrfrac) + eps), & ! PO4 - & ocetra(i,j,k,iiron)/(riron*rnoi*(fdetamox*amoxfrac + fdetnitr*nitrfrac) + eps), & ! Fe - & ocetra(i,j,k,ioxygen) & - & /((1.5*fno2 + fn2o - ro2nnit*fdetamox)*amoxfrac + (0.5 - ro2nnit*fdetnitr)*nitrfrac + eps), & ! O2 - & ocetra(i,j,k,ialkali) & - & /((2.*fno2 + fn2o + rnm1*rnoi*fdetamox)*amoxfrac + (rnm1*rnoi*fdetnitr)*nitrfrac + eps))) ! alkalinity - amox = amoxfrac*totd - nitr = nitrfrac*totd - - ocetra(i,j,k,ianh4) = ocetra(i,j,k,ianh4) - amox - fdetnitr*nitr - ocetra(i,j,k,ian2o) = ocetra(i,j,k,ian2o) + 0.5*fn2o*amox - ocetra(i,j,k,iano2) = ocetra(i,j,k,iano2) + fno2*amox - nitr - ocetra(i,j,k,iano3) = ocetra(i,j,k,iano3) + nitr - ocetra(i,j,k,idet) = ocetra(i,j,k,idet) + rnoi*(fdetamox*amox + fdetnitr*nitr) - ocetra(i,j,k,isco212) = ocetra(i,j,k,isco212) - rc2n*(fdetamox*amox + fdetnitr*nitr) - ocetra(i,j,k,iphosph) = ocetra(i,j,k,iphosph) - rnoi*(fdetamox*amox + fdetnitr*nitr) - ocetra(i,j,k,iiron) = ocetra(i,j,k,iiron) - riron*rnoi*(fdetamox*amox + fdetnitr*nitr) - ocetra(i,j,k,ioxygen) = ocetra(i,j,k,ioxygen) - (1.5*fno2 + fn2o - ro2nnit*fdetamox)*amox & - & - (0.5 - ro2nnit*fdetnitr)*nitr - ocetra(i,j,k,ialkali) = ocetra(i,j,k,ialkali) - (2.*fno2 + fn2o + rnm1*rnoi*fdetamox)*amox - rnm1*rnoi*fdetnitr*nitr - - ! Output - nitr_NH4(i,j,k) = amox ! kmol N/m3/dtb - NH4 consumption for nitrification on NH4-incl. usage for biomass - nitr_NO2(i,j,k) = nitr ! kmol N/m3/dtb - NO2 consumption for nitrification on NO2 - nitr_N2O_prod(i,j,k) = 0.5*fn2o*amox ! kmol N2O/m3/dtb - N2O production during aerob ammonium oxidation - nitr_NH4_OM(i,j,k) = rnoi*fdetamox*amox ! kmol P/m3/dtb - organic matter production during aerob NH4 oxidation - nitr_NO2_OM(i,j,k) = rnoi*fdetnitr*nitr ! kmol P/m3/dtb - organic matter production during aerob NO2 oxidation + totd = max(0., & + & min(totd, & + & ocetra(i,j,k,ianh4)/(amoxfrac + fdetnitr*nitrfrac + eps), & ! ammonium + & ocetra(i,j,k,isco212)/(rc2n*(fdetamox*amoxfrac + fdetnitr*nitrfrac) + eps), & ! CO2 + & ocetra(i,j,k,iphosph)/(rnoi*(fdetamox*amoxfrac + fdetnitr*nitrfrac) + eps), & ! PO4 + & ocetra(i,j,k,iiron)/(riron*rnoi*(fdetamox*amoxfrac + fdetnitr*nitrfrac) + eps), & ! Fe + & ocetra(i,j,k,ioxygen) & + & /((1.5*fno2 + fn2o - ro2nnit*fdetamox)*amoxfrac + (0.5 - ro2nnit*fdetnitr)*nitrfrac + eps), & ! O2 + & ocetra(i,j,k,ialkali) & + & /((2.*fno2 + fn2o + rnm1*rnoi*fdetamox)*amoxfrac + (rnm1*rnoi*fdetnitr)*nitrfrac + eps))) ! alkalinity + amox = amoxfrac*totd + nitr = nitrfrac*totd + + ocetra(i,j,k,ianh4) = ocetra(i,j,k,ianh4) - amox - fdetnitr*nitr + ocetra(i,j,k,ian2o) = ocetra(i,j,k,ian2o) + 0.5*fn2o*amox + ocetra(i,j,k,iano2) = ocetra(i,j,k,iano2) + fno2*amox - nitr + ocetra(i,j,k,iano3) = ocetra(i,j,k,iano3) + nitr + ocetra(i,j,k,idet) = ocetra(i,j,k,idet) + rnoi*(fdetamox*amox + fdetnitr*nitr) + ocetra(i,j,k,isco212) = ocetra(i,j,k,isco212) - rc2n*(fdetamox*amox + fdetnitr*nitr) + ocetra(i,j,k,iphosph) = ocetra(i,j,k,iphosph) - rnoi*(fdetamox*amox + fdetnitr*nitr) + ocetra(i,j,k,iiron) = ocetra(i,j,k,iiron) - riron*rnoi*(fdetamox*amox + fdetnitr*nitr) + ocetra(i,j,k,ioxygen) = ocetra(i,j,k,ioxygen) - (1.5*fno2 + fn2o - ro2nnit*fdetamox)*amox & + & - (0.5 - ro2nnit*fdetnitr)*nitr + ocetra(i,j,k,ialkali) = ocetra(i,j,k,ialkali) - (2.*fno2 + fn2o + rnm1*rnoi*fdetamox)*amox - rnm1*rnoi*fdetnitr*nitr + + ! Output + nitr_NH4(i,j,k) = amox ! kmol N/m3/dtb - NH4 consumption for nitrification on NH4-incl. usage for biomass + nitr_NO2(i,j,k) = nitr ! kmol N/m3/dtb - NO2 consumption for nitrification on NO2 + nitr_N2O_prod(i,j,k) = 0.5*fn2o*amox ! kmol N2O/m3/dtb - N2O production during aerob ammonium oxidation + nitr_NH4_OM(i,j,k) = rnoi*fdetamox*amox ! kmol P/m3/dtb - organic matter production during aerob NH4 oxidation + nitr_NO2_OM(i,j,k) = rnoi*fdetnitr*nitr ! kmol P/m3/dtb - organic matter production during aerob NO2 oxidation - endif - enddo - enddo + endif + enddo + enddo enddo !$OMP END PARALLEL DO @@ -344,10 +344,10 @@ subroutine denit_NO3_to_NO2(kpie,kpje,kpke,kbnd,pddpo,omask,ptho) !$OMP PARALLEL DO PRIVATE(i,k,Tdep,O2inhib,nutlim,ano3new,ano3denit,temp) do j = 1,kpje - do i = 1,kpie - do k = 1,kpke - if(pddpo(i,j,k) > dp_min .and. omask(i,j) > 0.5) then - if(ocetra(i,j,k,ioxygen) < minlim_ox .and. ocetra(i,j,k,iano3)>minlim_no3)then + do i = 1,kpie + do k = 1,kpke + if(pddpo(i,j,k) > dp_min .and. omask(i,j) > 0.5) then + if(ocetra(i,j,k,ioxygen) < minlim_ox .and. ocetra(i,j,k,iano3)>minlim_no3)then temp = merge(ptho(i,j,k),10.,ptho(i,j,k)<40.) Tdep = q10ano3denit**((temp-Trefano3denit)/10.) O2inhib = 1. - tanh(sc_ano3denit*ocetra(i,j,k,ioxygen)) @@ -368,10 +368,10 @@ subroutine denit_NO3_to_NO2(kpie,kpje,kpke,kbnd,pddpo,omask,ptho) ! Output denit_NO3(i,j,k) = ano3denit ! kmol NO3/m3/dtb - NO3 usage for denit on NO3 - endif - endif - enddo - enddo + endif + endif + enddo + enddo enddo !$OMP END PARALLEL DO @@ -402,9 +402,9 @@ subroutine anammox(kpie,kpje,kpke,kbnd,pddpo,omask,ptho) !$OMP PARALLEL DO PRIVATE(i,k,Tdep,O2inhib,nut1lim,nut2lim,ano2new,ano2anmx,temp) do j = 1,kpje - do i = 1,kpie - do k = 1,kpke - if(pddpo(i,j,k) > dp_min .and. omask(i,j) > 0.5) then + do i = 1,kpie + do k = 1,kpke + if(pddpo(i,j,k) > dp_min .and. omask(i,j) > 0.5) then if(ocetra(i,j,k,iano2)>minlim_no2 .and. ocetra(i,j,k,ianh4)>minlim_nh4 .and. ocetra(i,j,k,ioxygen) dp_min .and. omask(i,j) > 0.5) then + do i = 1,kpie + do k = 1,kpke + if(pddpo(i,j,k) > dp_min .and. omask(i,j) > 0.5) then potddet = 0. an2odenit = 0. ano2denit = 0. @@ -554,9 +554,9 @@ subroutine denit_dnra(kpie,kpje,kpke,kbnd,pddpo,omask,ptho) denit_N2O(i,j,k) = an2odenit ! kmol N2O/m3/dtb - denitrification on N2O DNRA_NO2(i,j,k) = ano2dnra ! kmol NO2/m3/dtb - DNRA on NO2 endif - endif - enddo - enddo + endif + enddo + enddo enddo !$OMP END PARALLEL DO end subroutine denit_dnra diff --git a/hamocc/mo_m4ago.F90 b/hamocc/mo_m4ago.F90 index 11b360f0..0c9e0f85 100644 --- a/hamocc/mo_m4ago.F90 +++ b/hamocc/mo_m4ago.F90 @@ -338,16 +338,16 @@ SUBROUTINE calc_pressure(kpie, kpje, kpke,kbnd, pddpo,omask, ppao, prho) !$OMP PARALLEL DO PRIVATE(i,j,k) do j = 1,kpje - do i = 1,kpie - if(omask(i,j) > 0.5) then + do i = 1,kpie + if(omask(i,j) > 0.5) then m4ago_ppo(i,j,1) = ppao(i,j) + prho(i,j,1)*grav_acc_const*pddpo(i,j,1) do k = 2,kpke if(pddpo(i,j,k) > dp_min) then m4ago_ppo(i,j,k) = m4ago_ppo(i,j,k-1) + prho(i,j,k)*grav_acc_const*pddpo(i,j,k) endif enddo - endif - enddo + endif + enddo enddo !$OMP END PARALLEL DO END SUBROUTINE calc_pressure @@ -384,54 +384,54 @@ SUBROUTINE mean_aggregate_sinking_speed(kpie, kpje, kpke, kbnd, pddpo, omask, pt !$OMP PARALLEL DO PRIVATE(i,j,k) DO j = 1,kpje - DO i = 1,kpie - DO k = 1,kpke - IF(pddpo(i,j,k) > dp_min .and. omask(i,j) > 0.5) THEN - ! Limit settling velocity wrt CFL: - ws_agg(i,j,k) = MIN(ws_agg(i,j,k), 0.99*pddpo(i,j,k)) - - ! ============================== Write general diagnostics ============ - ! ----- settling velocity-related ----- - aggregate_diagnostics(i,j,k,kws_agg) = ws_agg(i,j,k)/dtb ! applied ws conversion m/time_step to m/d for output - - ! ----- settling environment ----- - aggregate_diagnostics(i,j,k,kdynvis) = dyn_vis(i,j,k) ! dynamic viscosity - - ! ----- aggregate properties ----- - av_d_C(i,j,k) = (1. + df_agg(i,j,k) - b_agg(i,j,k)) & - & /(2. + df_agg(i,j,k) - b_agg(i,j,k)) & - & *(Lmax_agg(i,j,k)**(2. + df_agg(i,j,k) - b_agg(i,j,k)) & - & - av_dp(i,j,k)**(2. + df_agg(i,j,k) - b_agg(i,j,k))) & - & / (Lmax_agg(i,j,k)**(1.+df_agg(i,j,k)-b_agg(i,j,k)) & - & - av_dp(i,j,k)**(1. + df_agg(i,j,k)-b_agg(i,j,k))) - - aggregate_diagnostics(i,j,k,kstickiness_agg) = stickiness_agg(i,j,k) ! aggre. stickiness - aggregate_diagnostics(i,j,k,kstickiness_frustule) = stickiness_frustule(i,j,k) ! frustule stickiness - - aggregate_diagnostics(i,j,k,kLmax_agg) = Lmax_agg(i,j,k) ! applied max. diameter - aggregate_diagnostics(i,j,k,kav_dp) = av_dp(i,j,k) ! mean primary particle diameter - aggregate_diagnostics(i,j,k,kav_rho_p) = av_rho_p(i,j,k) ! mean primary particle density - aggregate_diagnostics(i,j,k,kav_d_C) = av_d_C(i,j,k) ! conc-weighted mean agg. diameter - aggregate_diagnostics(i,j,k,kdf_agg) = df_agg(i,j,k) ! aggregate fractal dim - aggregate_diagnostics(i,j,k,kb_agg) = b_agg(i,j,k) ! aggre number distr. slope - - ! volume-weighted aggregate density - aggregate_diagnostics(i,j,k,kav_rhof_V) = (av_rho_p(i,j,k)-rho_aq)*av_dp(i,j,k)**(3.-df_agg(i,j,k)) & - & *(4.-b_agg(i,j,k))*(Lmax_agg(i,j,k)**(1.+df_agg(i,j,k)-b_agg(i,j,k)) & - & - av_dp(i,j,k)**(1.+df_agg(i,j,k)-b_agg(i,j,k))) & - & / ((1.+df_agg(i,j,k)-b_agg(i,j,k)) & - & *(Lmax_agg(i,j,k)**(4.-b_agg(i,j,k)) - av_dp(i,j,k)**(4.-b_agg(i,j,k)))) + rho_aq - - ! volume-weighted aggregate porosity - aggregate_diagnostics(i,j,k,kav_por_V) = 1. - ((4.-b_agg(i,j,k)) & - & *av_dp(i,j,k)**(3.-df_agg(i,j,k)) & - & *(Lmax_agg(i,j,k)**(1.+df_agg(i,j,k)-b_agg(i,j,k)) & - & - av_dp(i,j,k)**(1.+df_agg(i,j,k)-b_agg(i,j,k)))) & - & / ((1.+df_agg(i,j,k)-b_agg(i,j,k)) & - & *(Lmax_agg(i,j,k)**(4.-b_agg(i,j,k)) - av_dp(i,j,k)**(4.-b_agg(i,j,k)))) - END IF - END DO - END DO + DO i = 1,kpie + DO k = 1,kpke + IF(pddpo(i,j,k) > dp_min .and. omask(i,j) > 0.5) THEN + ! Limit settling velocity wrt CFL: + ws_agg(i,j,k) = MIN(ws_agg(i,j,k), 0.99*pddpo(i,j,k)) + + ! ============================== Write general diagnostics ============ + ! ----- settling velocity-related ----- + aggregate_diagnostics(i,j,k,kws_agg) = ws_agg(i,j,k)/dtb ! applied ws conversion m/time_step to m/d for output + + ! ----- settling environment ----- + aggregate_diagnostics(i,j,k,kdynvis) = dyn_vis(i,j,k) ! dynamic viscosity + + ! ----- aggregate properties ----- + av_d_C(i,j,k) = (1. + df_agg(i,j,k) - b_agg(i,j,k)) & + & /(2. + df_agg(i,j,k) - b_agg(i,j,k)) & + & *(Lmax_agg(i,j,k)**(2. + df_agg(i,j,k) - b_agg(i,j,k)) & + & - av_dp(i,j,k)**(2. + df_agg(i,j,k) - b_agg(i,j,k))) & + & / (Lmax_agg(i,j,k)**(1.+df_agg(i,j,k)-b_agg(i,j,k)) & + & - av_dp(i,j,k)**(1. + df_agg(i,j,k)-b_agg(i,j,k))) + + aggregate_diagnostics(i,j,k,kstickiness_agg) = stickiness_agg(i,j,k) ! aggre. stickiness + aggregate_diagnostics(i,j,k,kstickiness_frustule) = stickiness_frustule(i,j,k) ! frustule stickiness + + aggregate_diagnostics(i,j,k,kLmax_agg) = Lmax_agg(i,j,k) ! applied max. diameter + aggregate_diagnostics(i,j,k,kav_dp) = av_dp(i,j,k) ! mean primary particle diameter + aggregate_diagnostics(i,j,k,kav_rho_p) = av_rho_p(i,j,k) ! mean primary particle density + aggregate_diagnostics(i,j,k,kav_d_C) = av_d_C(i,j,k) ! conc-weighted mean agg. diameter + aggregate_diagnostics(i,j,k,kdf_agg) = df_agg(i,j,k) ! aggregate fractal dim + aggregate_diagnostics(i,j,k,kb_agg) = b_agg(i,j,k) ! aggre number distr. slope + + ! volume-weighted aggregate density + aggregate_diagnostics(i,j,k,kav_rhof_V) = (av_rho_p(i,j,k)-rho_aq)*av_dp(i,j,k)**(3.-df_agg(i,j,k)) & + & *(4.-b_agg(i,j,k))*(Lmax_agg(i,j,k)**(1.+df_agg(i,j,k)-b_agg(i,j,k)) & + & - av_dp(i,j,k)**(1.+df_agg(i,j,k)-b_agg(i,j,k))) & + & / ((1.+df_agg(i,j,k)-b_agg(i,j,k)) & + & *(Lmax_agg(i,j,k)**(4.-b_agg(i,j,k)) - av_dp(i,j,k)**(4.-b_agg(i,j,k)))) + rho_aq + + ! volume-weighted aggregate porosity + aggregate_diagnostics(i,j,k,kav_por_V) = 1. - ((4.-b_agg(i,j,k)) & + & *av_dp(i,j,k)**(3.-df_agg(i,j,k)) & + & *(Lmax_agg(i,j,k)**(1.+df_agg(i,j,k)-b_agg(i,j,k)) & + & - av_dp(i,j,k)**(1.+df_agg(i,j,k)-b_agg(i,j,k)))) & + & / ((1.+df_agg(i,j,k)-b_agg(i,j,k)) & + & *(Lmax_agg(i,j,k)**(4.-b_agg(i,j,k)) - av_dp(i,j,k)**(4.-b_agg(i,j,k)))) + END IF + END DO + END DO END DO END SUBROUTINE mean_aggregate_sinking_speed @@ -464,148 +464,148 @@ SUBROUTINE aggregate_properties(kpie, kpje, kpke, kbnd, pddpo, omask, ptho) !$OMP free_detritus,rho_diatom,cell_det_mass,cell_pot_det_mass,V_POM_cell,V_aq,rho_frustule,A_det,A_opal, & !$OMP A_calc,A_dust,A_total,stickiness_mapped) DO j = 1,kpje - DO i = 1,kpie - DO k = 1,kpke - IF(pddpo(i,j,k) > dp_min .and. omask(i,j) > 0.5) THEN - C_det = 0. - C_opal = 0. - C_calc = 0. - C_dust = 0. + DO i = 1,kpie + DO k = 1,kpke + IF(pddpo(i,j,k) > dp_min .and. omask(i,j) > 0.5) THEN + C_det = 0. + C_opal = 0. + C_calc = 0. + C_dust = 0. - C_det = ABS(ocetra(i,j,k,idet)) - C_opal = ABS(ocetra(i,j,k,iopal)) - C_calc = ABS(ocetra(i,j,k,icalc)) - C_dust = ABS(ocetra(i,j,k,ifdust)) - - n_det = 0. ! number of primary particles - n_opal = 0. - n_dust = 0. - n_calc = 0. - mf = 0. + C_det = ABS(ocetra(i,j,k,idet)) + C_opal = ABS(ocetra(i,j,k,iopal)) + C_calc = ABS(ocetra(i,j,k,icalc)) + C_dust = ABS(ocetra(i,j,k,ifdust)) + + n_det = 0. ! number of primary particles + n_opal = 0. + n_dust = 0. + n_calc = 0. + mf = 0. - V_det = 0. ! total volume of primary particles in a unit volume - V_opal = 0. - V_calc = 0. - V_dust = 0. - V_solid = 0. - - free_detritus = 0. - rho_diatom = 0. - ! n_det are detritus primary particle that are - ! NOT linked to any diatom frustule - ! n_opal are number of frustule-like primary particles possessing - ! a density i) different from pure opal ii) due to a mixture of - ! opal frustule, detritus inside the frustule and potentially water - ! inside the frustule + V_det = 0. ! total volume of primary particles in a unit volume + V_opal = 0. + V_calc = 0. + V_dust = 0. + V_solid = 0. + + free_detritus = 0. + rho_diatom = 0. + ! n_det are detritus primary particle that are + ! NOT linked to any diatom frustule + ! n_opal are number of frustule-like primary particles possessing + ! a density i) different from pure opal ii) due to a mixture of + ! opal frustule, detritus inside the frustule and potentially water + ! inside the frustule - ! describing diatom frustule as hollow sphere - ! that is completely or partially filled with detritus - ! and water - cell_det_mass = 0. - cell_pot_det_mass = 0. - V_POM_cell = 0. - V_aq = 0. - rho_frustule = 0. - - ! number of opal frustules (/NUM_FAC) - n_opal = C_opal*opalwei/rho_V_frustule_opal - ! maximum mass of detritus inside a frustule - cell_pot_det_mass = n_opal*V_frustule_inner*agg_org_dens + ! describing diatom frustule as hollow sphere + ! that is completely or partially filled with detritus + ! and water + cell_det_mass = 0. + cell_pot_det_mass = 0. + V_POM_cell = 0. + V_aq = 0. + rho_frustule = 0. + + ! number of opal frustules (/NUM_FAC) + n_opal = C_opal*opalwei/rho_V_frustule_opal + ! maximum mass of detritus inside a frustule + cell_pot_det_mass = n_opal*V_frustule_inner*agg_org_dens - ! detritus mass inside frustules - cell_det_mass = MIN(cell_pot_det_mass, C_det*det_mol2mass - EPS_ONE) + ! detritus mass inside frustules + cell_det_mass = MIN(cell_pot_det_mass, C_det*det_mol2mass - EPS_ONE) - ! volume of detritus component in cell - V_POM_cell = (cell_det_mass/n_opal)/agg_org_dens + ! volume of detritus component in cell + V_POM_cell = (cell_det_mass/n_opal)/agg_org_dens - ! if not detritus is available, water is added - V_aq = V_frustule_inner - V_POM_cell + ! if not detritus is available, water is added + V_aq = V_frustule_inner - V_POM_cell - ! density of the diatom frsutules incl. opal, detritus and water - rho_frustule = (rho_V_frustule_opal + cell_det_mass/n_opal + V_aq*rho_aq)/V_dp_opal + ! density of the diatom frsutules incl. opal, detritus and water + rho_frustule = (rho_V_frustule_opal + cell_det_mass/n_opal + V_aq*rho_aq)/V_dp_opal - ! mass of extra cellular detritus particles - free_detritus = C_det*det_mol2mass - cell_det_mass - rho_diatom = (rho_frustule + cell_det_mass/cell_pot_det_mass*rho_TEP) & - /(1. + cell_det_mass/cell_pot_det_mass) - - ! number of primary particles - n_det = free_detritus/rho_V_dp_det ! includes NUM_FAC - n_calc = C_calc*calcwei/rho_V_dp_calc - n_dust = C_dust/rho_V_dp_dust ! dust is in kg/m3 - - ! primary particles surface weighted stickiness is mapped - ! on range between 0 and 1 - ! fractal dimension of aggregates is based on that mapped df - ! number distribution slope b is based on df + ! mass of extra cellular detritus particles + free_detritus = C_det*det_mol2mass - cell_det_mass + rho_diatom = (rho_frustule + cell_det_mass/cell_pot_det_mass*rho_TEP) & + /(1. + cell_det_mass/cell_pot_det_mass) + + ! number of primary particles + n_det = free_detritus/rho_V_dp_det ! includes NUM_FAC + n_calc = C_calc*calcwei/rho_V_dp_calc + n_dust = C_dust/rho_V_dp_dust ! dust is in kg/m3 + + ! primary particles surface weighted stickiness is mapped + ! on range between 0 and 1 + ! fractal dimension of aggregates is based on that mapped df + ! number distribution slope b is based on df - ! calc total areas - A_det = n_det*A_dp_det - A_opal = n_opal*A_dp_opal - A_calc = n_calc*A_dp_calc - A_dust = n_dust*A_dp_dust - A_total = A_det + A_opal + A_calc + A_dust - - ! calc frustule stickiness - stickiness_frustule(i,j,k) = cell_det_mass/(cell_pot_det_mass + EPS_ONE)*stickiness_TEP & - & + (1. - cell_det_mass/(cell_pot_det_mass + EPS_ONE))*stickiness_opal - - ! calc mean stickiness - stickiness_agg(i,j,k) = stickiness_frustule(i,j,k)*A_opal & - & + stickiness_det*A_det & - & + stickiness_calc*A_calc & - & + stickiness_dust*A_dust - - stickiness_agg(i,j,k) = stickiness_agg(i,j,k)/(A_total+EPS_ONE) - - stickiness_mapped = (stickiness_agg(i,j,k) - stickiness_min) & + ! calc total areas + A_det = n_det*A_dp_det + A_opal = n_opal*A_dp_opal + A_calc = n_calc*A_dp_calc + A_dust = n_dust*A_dp_dust + A_total = A_det + A_opal + A_calc + A_dust + + ! calc frustule stickiness + stickiness_frustule(i,j,k) = cell_det_mass/(cell_pot_det_mass + EPS_ONE)*stickiness_TEP & + & + (1. - cell_det_mass/(cell_pot_det_mass + EPS_ONE))*stickiness_opal + + ! calc mean stickiness + stickiness_agg(i,j,k) = stickiness_frustule(i,j,k)*A_opal & + & + stickiness_det*A_det & + & + stickiness_calc*A_calc & + & + stickiness_dust*A_dust + + stickiness_agg(i,j,k) = stickiness_agg(i,j,k)/(A_total+EPS_ONE) + + stickiness_mapped = (stickiness_agg(i,j,k) - stickiness_min) & & /(stickiness_max - stickiness_min) - df_agg(i,j,k) = agg_df_max*EXP(df_slope*stickiness_mapped) - - ! Slope is here positive defined (as n(d)~d^-b), so *-1 of - ! Jiang & Logan 1991: Fractal dimensions of aggregates - ! determined from steady-state size distributions. - ! Environ. Sci. Technol. 25, 2031-2038. - ! - ! See also: - ! Hunt 1980: Prediction of oceanic particle size distributions - ! from coagulation and sedimentation mechanisms. - ! - ! Additional assumptions made here: - ! b in Jiang & Logan (used for Re < 0.1: b=1 - ! for 0.1 < Re < 10 : b=0.871 - ! for 10 < Re < 100 : b=0.547) - ! is set to 0.871 as an 'average for our range of 0 Formulation in Jiang & Logan 1991: - ! slope = -0.5*(3+df+(2+df-D2)/(2-b)) reduces to: + df_agg(i,j,k) = agg_df_max*EXP(df_slope*stickiness_mapped) + + ! Slope is here positive defined (as n(d)~d^-b), so *-1 of + ! Jiang & Logan 1991: Fractal dimensions of aggregates + ! determined from steady-state size distributions. + ! Environ. Sci. Technol. 25, 2031-2038. + ! + ! See also: + ! Hunt 1980: Prediction of oceanic particle size distributions + ! from coagulation and sedimentation mechanisms. + ! + ! Additional assumptions made here: + ! b in Jiang & Logan (used for Re < 0.1: b=1 + ! for 0.1 < Re < 10 : b=0.871 + ! for 10 < Re < 100 : b=0.547) + ! is set to 0.871 as an 'average for our range of 0 Formulation in Jiang & Logan 1991: + ! slope = -0.5*(3+df+(2+df-D2)/(2-b)) reduces to: - b_agg(i,j,k) = 0.5*(3. + df_agg(i,j,k) & - & + (2. + df_agg(i,j,k) - MIN(2., df_agg(i,j,k)))/(2. - BJ2)) + b_agg(i,j,k) = 0.5*(3. + df_agg(i,j,k) & + & + (2. + df_agg(i,j,k) - MIN(2., df_agg(i,j,k)))/(2. - BJ2)) - ! careful: for df=1.5904: b_agg=2*df where w_s is undefined. - - ! total volume of primary particles - V_det = n_det*V_dp_det*NUM_FAC - V_opal = n_opal*V_dp_opal*NUM_FAC - V_calc = n_calc*V_dp_calc*NUM_FAC - V_dust = n_dust*V_dp_dust*NUM_FAC - V_solid = V_det + V_opal + V_calc + V_dust + ! careful: for df=1.5904: b_agg=2*df where w_s is undefined. + + ! total volume of primary particles + V_det = n_det*V_dp_det*NUM_FAC + V_opal = n_opal*V_dp_opal*NUM_FAC + V_calc = n_calc*V_dp_calc*NUM_FAC + V_dust = n_dust*V_dp_dust*NUM_FAC + V_solid = V_det + V_opal + V_calc + V_dust - ! primary particle mean diameter according to Bushell & Amal 1998, 2000 - ! sum(n_i) not changing - can be pulled out and thus cancels out - av_dp(i,j,k) = (n_calc*dp_calc**3. + n_dust*dp_dust**3. + n_opal*dp_opal**3. + n_det*dp_det**3.) - av_dp(i,j,k) = av_dp(i,j,k)/(n_calc*dp_calc**df_agg(i,j,k) + n_dust*dp_dust**df_agg(i,j,k) & - & + n_opal*dp_opal**df_agg(i,j,k) + n_det*dp_det**df_agg(i,j,k)) - av_dp(i,j,k) = av_dp(i,j,k)**(1./(3. - df_agg(i,j,k))) - - ! density of mean primary particles - av_rho_p(i,j,k) = (V_det*agg_org_dens + V_opal*rho_diatom + V_calc*calcdens + V_dust*claydens)/V_solid - END IF - END DO - END DO + ! primary particle mean diameter according to Bushell & Amal 1998, 2000 + ! sum(n_i) not changing - can be pulled out and thus cancels out + av_dp(i,j,k) = (n_calc*dp_calc**3. + n_dust*dp_dust**3. + n_opal*dp_opal**3. + n_det*dp_det**3.) + av_dp(i,j,k) = av_dp(i,j,k)/(n_calc*dp_calc**df_agg(i,j,k) + n_dust*dp_dust**df_agg(i,j,k) & + & + n_opal*dp_opal**df_agg(i,j,k) + n_det*dp_det**df_agg(i,j,k)) + av_dp(i,j,k) = av_dp(i,j,k)**(1./(3. - df_agg(i,j,k))) + + ! density of mean primary particles + av_rho_p(i,j,k) = (V_det*agg_org_dens + V_opal*rho_diatom + V_calc*calcdens + V_dust*claydens)/V_solid + END IF + END DO + END DO END DO !$OMP END PARALLEL DO @@ -652,13 +652,13 @@ SUBROUTINE ws_Re_approx(kpie, kpje, kpke, pddpo, omask) !$OMP PARALLEL DO PRIVATE(i,j,k) DO j = 1,kpje - DO i = 1,kpie - DO k = 1,kpke - IF(pddpo(i,j,k) > dp_min .and. omask(i,j) > 0.5) THEN - ws_agg(i,j,k) = ws_Re(i,j,k,Lmax_agg(i,j,k)) - END IF - END DO - END DO + DO i = 1,kpie + DO k = 1,kpke + IF(pddpo(i,j,k) > dp_min .and. omask(i,j) > 0.5) THEN + ws_agg(i,j,k) = ws_Re(i,j,k,Lmax_agg(i,j,k)) + END IF + END DO + END DO END DO !$OMP END PARALLEL DO @@ -794,13 +794,13 @@ SUBROUTINE max_agg_diam(kpie, kpje, kpke, pddpo, omask) !$OMP PARALLEL DO PRIVATE(i,j,k) ! base on analytical Jiang approximation DO j = 1,kpje - DO i = 1,kpie - DO k = 1,kpke - IF(pddpo(i,j,k) > dp_min .and. omask(i,j) > 0.5) THEN - Lmax_agg(i,j,k) = max_agg_diam_white(i,j,k) - END IF - END DO - END DO + DO i = 1,kpie + DO k = 1,kpke + IF(pddpo(i,j,k) > dp_min .and. omask(i,j) > 0.5) THEN + Lmax_agg(i,j,k) = max_agg_diam_white(i,j,k) + END IF + END DO + END DO END DO !$OMP END PARALLEL DO END SUBROUTINE max_agg_diam @@ -896,35 +896,35 @@ SUBROUTINE dynvis(kpie, kpje, kpke, kbnd, pddpo, omask, ptho, psao, ppo) kch = 0 !$OMP PARALLEL DO PRIVATE(i,j,k,press_val,ptho_val,psao_val,kch) DO j = 1,kpje - DO i = 1,kpie - DO k = 1,kpke - IF(pddpo(i,j,k) > dp_min .and. omask(i,j) > 0.5) THEN - kch = MERGE(k+1,k,k 0.5) THEN - press_val = 0.5*(ppo(i,j,k) + ppo(i,j,kch))*1.e-5 ! Pascal -> dbar - ptho_val = 0.5*(ptho(i,j,k) + ptho(i,j,kch)) - psao_val = 0.5*(psao(i,j,k) + ptho(i,j,kch)) - ELSE - press_val = ppo(i,j,k)*1.e-5 ! Pascal -> dbar - ptho_val = ptho(i,j,k) - psao_val = psao(i,j,k) - END IF + DO i = 1,kpie + DO k = 1,kpke + IF(pddpo(i,j,k) > dp_min .and. omask(i,j) > 0.5) THEN + kch = MERGE(k+1,k,k 0.5) THEN + press_val = 0.5*(ppo(i,j,k) + ppo(i,j,kch))*1.e-5 ! Pascal -> dbar + ptho_val = 0.5*(ptho(i,j,k) + ptho(i,j,kch)) + psao_val = 0.5*(psao(i,j,k) + ptho(i,j,kch)) + ELSE + press_val = ppo(i,j,k)*1.e-5 ! Pascal -> dbar + ptho_val = ptho(i,j,k) + psao_val = psao(i,j,k) + END IF - ! molecular dynamic viscosity - dyn_vis(i,j,k) = 0.1 & ! Unit: g / (cm*s) -> kg / (m*s) - & *(1.79e-2 & - & - 6.1299e-4*ptho_val + 1.4467e-5*ptho_val**2. & - & - 1.6826e-7*ptho_val**3. & - & - 1.8266e-7*press_val + 9.8972e-12*press_val**2. & - & + 2.4727e-5*psao_val & - & + psao_val*(4.8429e-7*ptho_val - 4.7172e-8*ptho_val**2. & - & + 7.5986e-10*ptho_val**3.) & - & + press_val*(1.3817e-8*ptho_val - 2.6363e-10*ptho_val**2.) & - & - press_val**2.*(6.3255e-13*ptho_val - 1.2116e-14*ptho_val**2.)) - END IF - END DO - END DO + ! molecular dynamic viscosity + dyn_vis(i,j,k) = 0.1 & ! Unit: g / (cm*s) -> kg / (m*s) + & *(1.79e-2 & + & - 6.1299e-4*ptho_val + 1.4467e-5*ptho_val**2. & + & - 1.6826e-7*ptho_val**3. & + & - 1.8266e-7*press_val + 9.8972e-12*press_val**2. & + & + 2.4727e-5*psao_val & + & + psao_val*(4.8429e-7*ptho_val - 4.7172e-8*ptho_val**2. & + & + 7.5986e-10*ptho_val**3.) & + & + press_val*(1.3817e-8*ptho_val - 2.6363e-10*ptho_val**2.) & + & - press_val**2.*(6.3255e-13*ptho_val - 1.2116e-14*ptho_val**2.)) + END IF + END DO + END DO END DO !$OMP END PARALLEL DO END SUBROUTINE dynvis From 5e3c40b9d15ac87efb4f9018cba2e60318c33a02 Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Mon, 29 Aug 2022 15:02:28 +0200 Subject: [PATCH 148/366] Introduced O2 lim in ammonification in N-cycle --- hamocc/beleg_parm.F90 | 3 ++- hamocc/mo_biomod.F90 | 2 +- hamocc/ocprod.F90 | 8 +++++--- 3 files changed, 8 insertions(+), 5 deletions(-) diff --git a/hamocc/beleg_parm.F90 b/hamocc/beleg_parm.F90 index 6c693c7a..e20da925 100644 --- a/hamocc/beleg_parm.F90 +++ b/hamocc/beleg_parm.F90 @@ -45,7 +45,7 @@ SUBROUTINE BELEG_PARM(kpie,kpje) use mo_biomod, only: atten_c,atten_f,atten_uv,atten_w,bkopal,bkphy,bkopal,bkzoo,bluefix,ctochl,dremn2o,dremopal, & & drempoc,dremsul,dyphy,ecan,epsher,fesoly,fetune,gammap,gammaz,grami,grazra,perc_diron,phytomi, & & pi_alpha,rcalc,rcar, rdn2o1,rdn2o2,rdnit0,rdnit1,rdnit2,relaxfe,remido,riron,rnit,rnoi,ro2ut, & - & ropal,spemor,tf0,tf1,tf2,tff,wcal,wdust,wopal,wpoc,zinges,drempoc_anaerob + & ropal,spemor,tf0,tf1,tf2,tff,wcal,wdust,wopal,wpoc,zinges,drempoc_anaerob,bkox_drempoc use mo_sedmnt, only: claydens,o2ut,rno3 use mo_control_bgc, only: dtb,io_stdo_bgc,lm4ago use mo_param1_bgc, only: iatmco2,iatmnco2,iatmo2,iatmn2,iatmc13,iatmc14,iatmbromo @@ -217,6 +217,7 @@ SUBROUTINE BELEG_PARM(kpie,kpje) dremn2o = 0.01*dtb !1/d dremsul = 0.005*dtb ! remineralization rate for sulphate reduction drempoc_anaerob = 0.05*drempoc ! remin in sub-/anoxic environm. - not be overwritten by lm4ago + bkox_drempoc = 1e-7 ! half-saturation constant for oxygen for ammonification (aerobic remin via drempoc) ! nirogen fixation by blue green algae bluefix=0.005*dtb !1/d diff --git a/hamocc/mo_biomod.F90 b/hamocc/mo_biomod.F90 index 8cadee2d..71afdfd4 100644 --- a/hamocc/mo_biomod.F90 +++ b/hamocc/mo_biomod.F90 @@ -101,7 +101,7 @@ MODULE mo_biomod REAL :: bluefix,tf2,tf1,tf0,tff REAL :: bkphy,bkzoo,bkopal REAL :: wpoc,wcal,wopal - REAL :: drempoc,dremopal,dremn2o,dremsul,drempoc_anaerob + REAL :: drempoc,dremopal,dremn2o,dremsul,drempoc_anaerob,bkox_drempoc REAL :: perc_diron, riron, fesoly, relaxfe, fetune, wdust REAL :: ctochl, atten_w, atten_c, atten_uv, atten_f #ifdef cisonew diff --git a/hamocc/ocprod.F90 b/hamocc/ocprod.F90 index 23bb6b34..e237ecb3 100644 --- a/hamocc/ocprod.F90 +++ b/hamocc/ocprod.F90 @@ -91,7 +91,7 @@ subroutine ocprod(kpie,kpje,kpke,kbnd,pdlxp,pdlyp,pddpo,omask,ptho,pi_ph, psao, & carflx1000,carflx2000,carflx4000,carflx_bot,dremn2o,dremopal,drempoc,dremsul,dyphy,ecan,epsher,fesoly, & & gammap,gammaz,grami,grazra,expoor,exposi,expoca,intdnit,intdms_bac,intdmsprod,intdms_uv,intphosy, & & phosy3d,pi_alpha,phytomi,rcalc,rcar,rdn2o1,rdn2o2,rdnit0,rdnit1,rdnit2,relaxfe,remido, & - & riron,rnit,strahl,rnoi,ro2ut,ropal,spemor,wcal,wdust,wopal,wpoc,zinges,drempoc_anaerob + & riron,rnit,strahl,rnoi,ro2ut,ropal,spemor,wcal,wdust,wopal,wpoc,zinges,drempoc_anaerob,bkox_drempoc use mo_param1_bgc, only: ialkali,ian2o,iano3,icalc,idet,idms,idoc,ifdust,igasnit,iiron,iopal,ioxygen,iphosph,iphy,isco212, & & isilica,izoo use mo_control_bgc, only: dtb,io_stdo_bgc,with_dmsph,lm4ago @@ -210,7 +210,8 @@ subroutine ocprod(kpie,kpje,kpke,kbnd,pdlxp,pdlyp,pddpo,omask,ptho,pi_ph, psao, #endif #ifdef extNcycle character(len=:), allocatable :: inv_message - real :: ano3up_inh,nutlim,anh4lim,nlim,grlim,nh4uptfrac + real :: ano3up_inh,nutlim,anh4lim,nlim,grlim,nh4uptfrac + real :: o2lim #endif @@ -693,7 +694,8 @@ subroutine ocprod(kpie,kpje,kpke,kbnd,pdlxp,pdlyp,pddpo,omask,ptho,pi_ph, psao, docrem = MIN( remido*ocetra(i,j,k,idoc),0.33*ocetra(i,j,k,ioxygen)/ro2ut) phyrem = MIN(0.5*dyphy*phythresh, 0.33*ocetra(i,j,k,ioxygen)/ro2ut) #else - pocrem = MIN(pocrem,0.33*ocetra(i,j,k,ioxygen)/ro2utammo) + o2lim = ocetra(i,j,k,ioxygen)/(ocetra(i,j,k,ioxygen) + bkox_drempoc) + pocrem = MIN(o2lim*pocrem,0.33*ocetra(i,j,k,ioxygen)/ro2utammo) docrem = MIN( remido*ocetra(i,j,k,idoc),0.33*ocetra(i,j,k,ioxygen)/ro2utammo) phyrem = MIN(0.5*dyphy*phythresh, 0.33*ocetra(i,j,k,ioxygen)/ro2utammo) #endif From 1aaec102986b6aa2aba54816f680766a63d1ee39 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?J=C3=B6rg=20Schwinger?= Date: Tue, 30 Aug 2022 14:02:50 +0200 Subject: [PATCH 149/366] Add framwork for applying ocean alkalinization scenarios (#187) --- cime_config/buildnml | 19 ++- hamocc/hamocc4bcm.F90 | 20 ++- hamocc/hamocc_init.F90 | 10 +- hamocc/hamocc_step.F90 | 5 +- hamocc/mo_apply_oafx.F90 | 102 ++++++++++++++ hamocc/mo_control_bgc.F90 | 1 + hamocc/mo_read_oafx.F90 | 290 ++++++++++++++++++++++++++++++++++++++ 7 files changed, 436 insertions(+), 11 deletions(-) create mode 100644 hamocc/mo_apply_oafx.F90 create mode 100644 hamocc/mo_read_oafx.F90 diff --git a/cime_config/buildnml b/cime_config/buildnml index 0154e8a1..6f3c1e30 100755 --- a/cime_config/buildnml +++ b/cime_config/buildnml @@ -207,11 +207,11 @@ if ($BLOM_N_DEPOSITION == TRUE) then set NDEPFNAME = ndep_201501-210012-${BLOM_NDEP_SCENARIO}_tnx1v4_20191112.nc else if( $BLOM_NDEP_SCENARIO == UNSET ) then set DO_NDEP = .false. - set NDEPFNAME = "" + set NDEPFNAME = "''" endif else set DO_NDEP = .false. - set NDEPFNAME = "" + set NDEPFNAME = "''" endif if ($HAMOCC_SEDSPINUP == TRUE) then set DO_SEDSPINUP = .true. @@ -230,8 +230,13 @@ if ($HAMOCC_VSLS == TRUE && $OCN_GRID != tnx1v4) then echo "$0 ERROR: HAMOCC_VSLS == TRUE not possible with this grid resolution (no swa-climatology available) " exit -1 endif +# For the following options, there are currently no switches in Case-XML files. +# These options can be activated by expert users via user namelist. +set DO_OALK = .false. +set OALKSCEN = "''" +set OALKFILE = "''" set WITH_DMSPH = .false. -set PI_PH_FILE = "" +set PI_PH_FILE = "''" # set DIAPHY defaults set GLB_FNAMETAG = "'hd','hm','hy'" @@ -1448,6 +1453,9 @@ cat >>! $RUNDIR/ocn_in$inststr << EOF RIVINFILE = $RIVINFILE DO_NDEP = $DO_NDEP NDEPFILE = $NDEPFILE + DO_OALK = $DO_OALK + OALKSCEN = $OALKSCEN + OALKFILE = $OALKFILE DO_SEDSPINUP = $DO_SEDSPINUP SEDSPIN_YR_S = $SEDSPIN_YR_S SEDSPIN_YR_E = $SEDSPIN_YR_E @@ -1853,6 +1861,11 @@ EOF if ($BLOM_N_DEPOSITION == TRUE) then cat >> $CASEBUILD/blom.input_data_list << EOF n_deposition_file = `echo $NDEPFILE | tr -d '"' | tr -d "'"` +EOF + endif + if ($OALKFILE != "''") then +cat >> $CASEBUILD/blom.input_data_list << EOF +oafx_file = `echo $OALKFILE | tr -d '"' | tr -d "'"` EOF endif if ($HAMOCC_VSLS == TRUE) then diff --git a/hamocc/hamocc4bcm.F90 b/hamocc/hamocc4bcm.F90 index 0dd3e6a3..f503b524 100644 --- a/hamocc/hamocc4bcm.F90 +++ b/hamocc/hamocc4bcm.F90 @@ -19,7 +19,7 @@ SUBROUTINE HAMOCC4BCM(kpie,kpje,kpke,kbnd,kplyear,kplmon,kplday,kldtday,& pdlxp,pdlyp,pddpo,prho,pglat,omask, & - dust,rivin,ndep,pi_ph, & + dust,rivin,ndep,oafx,pi_ph, & pfswr,psicomo,ppao,pfu10,ptho,psao, & patmco2,pflxco2,pflxdms,patmbromo,pflxbromo) !****************************************************************************** @@ -64,8 +64,9 @@ SUBROUTINE HAMOCC4BCM(kpie,kpje,kpke,kbnd,kplyear,kplmon,kplday,kldtday,& ! *REAL* *pglat* - latitude of grid cells [deg north]. ! *REAL* *omask* - land/ocean mask. ! *REAL* *dust* - dust deposition flux [kg/m2/month]. -! *REAL* *rivin* - riverine input [kmol m-2 yr-2]. -! *REAL* *ndep* - nitrogen deposition [kmol m-2 yr-2]. +! *REAL* *rivin* - riverine input [kmol m-2 yr-1]. +! *REAL* *ndep* - nitrogen deposition [kmol m-2 yr-1]. +! *REAL* *oaflx* - alkalinity flux from alkalinization [kmol m-2 yr-1] ! *REAL* *pfswr* - solar radiation [W/m**2]. ! *REAL* *psicomo* - sea ice concentration ! *REAL* *ppao* - sea level pressure [Pascal]. @@ -91,6 +92,7 @@ SUBROUTINE HAMOCC4BCM(kpie,kpje,kpke,kbnd,kplyear,kplmon,kplday,kldtday,& use mo_apply_fedep, only: apply_fedep use mo_apply_rivin, only: apply_rivin use mo_apply_ndep, only: apply_ndep + use mo_apply_oafx, only: apply_oafx #if defined(BOXATM) use mo_boxatm, only: update_boxatm #endif @@ -113,6 +115,7 @@ SUBROUTINE HAMOCC4BCM(kpie,kpje,kpke,kbnd,kplyear,kplmon,kplday,kldtday,& REAL, intent(in) :: dust (kpie,kpje) REAL, intent(in) :: rivin (kpie,kpje,nriv) REAL, intent(in) :: ndep (kpie,kpje) + REAL, intent(in) :: oafx (kpie,kpje) REAL, intent(in) :: pi_ph (kpie,kpje) REAL, intent(in) :: pfswr (1-kbnd:kpie+kbnd,1-kbnd:kpje+kbnd) REAL, intent(in) :: psicomo(1-kbnd:kpie+kbnd,1-kbnd:kpje+kbnd) @@ -298,6 +301,17 @@ SUBROUTINE HAMOCC4BCM(kpie,kpje,kpke,kbnd,kplyear,kplmon,kplday,kldtday,& CALL INVENTORY_BGC(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask,0) #endif + ! Apply alkalinity flux due to ocean alkalinization + call apply_oafx(kpie,kpje,kpke,pddpo,omask,oafx) + +#ifdef PBGC_CK_TIMESTEP + IF (mnproc.eq.1) THEN + WRITE(io_stdo_bgc,*)' ' + WRITE(io_stdo_bgc,*)'after ocean alkalinization: call INVENTORY' + ENDIF + CALL INVENTORY_BGC(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask,0) +#endif + ! Update atmospheric pCO2 [ppm] #if defined(BOXATM) CALL update_boxatm(kpie,kpje,pdlxp,pdlyp) diff --git a/hamocc/hamocc_init.F90 b/hamocc/hamocc_init.F90 index 13ae3e59..c8af2b31 100644 --- a/hamocc/hamocc_init.F90 +++ b/hamocc/hamocc_init.F90 @@ -43,7 +43,7 @@ subroutine hamocc_init(read_rest,rstfnm_hamocc) use mod_grid, only: plon,plat use mod_tracers, only: ntrbgc,ntr,itrbgc,trc use mo_control_bgc, only: bgc_namelist,get_bgc_namelist, & - & do_ndep,do_rivinpt,do_sedspinup, & + & do_ndep,do_rivinpt,do_oalk,do_sedspinup, & & sedspin_yr_s,sedspin_yr_e,sedspin_ncyc, & & dtb,dtbgc,io_stdo_bgc,ldtbgc, & & ldtrunbgc,ndtdaybgc,with_dmsph @@ -56,6 +56,7 @@ subroutine hamocc_init(read_rest,rstfnm_hamocc) use mo_read_rivin, only: ini_read_rivin,rivinfile use mo_read_fedep, only: ini_read_fedep,fedepfile use mo_read_ndep, only: ini_read_ndep,ndepfile + use mo_read_oafx, only: ini_read_oafx,oalkfile,oalkscen use mo_read_pi_ph, only: ini_pi_ph,pi_ph_file use mo_clim_swa, only: ini_swa_clim,swaclimfile use mo_Gdata_read, only: inidic,inialk,inipo4,inioxy,inino3, & @@ -76,9 +77,8 @@ subroutine hamocc_init(read_rest,rstfnm_hamocc) integer :: i,j,k,l,nt integer :: iounit - namelist /bgcnml/ atm_co2,do_rivinpt,do_ndep, & - & ndepfile,fedepfile,rivinfile, & - & do_sedspinup,sedspin_yr_s, & + namelist /bgcnml/ atm_co2,fedepfile,do_rivinpt,rivinfile,do_ndep,ndepfile, & + & do_oalk,oalkscen,oalkfile,do_sedspinup,sedspin_yr_s, & & sedspin_yr_e,sedspin_ncyc, & & inidic,inialk,inipo4,inioxy,inino3,inisil, & & inid13c,inid14c,swaclimfile, & @@ -188,6 +188,8 @@ subroutine hamocc_init(read_rest,rstfnm_hamocc) CALL ini_read_rivin(idm,jdm,omask) + CALL ini_read_oafx(idm,jdm,bgc_dx,bgc_dy,plat,omask) + #ifdef BROMO CALL ini_swa_clim(idm,jdm,omask) #endif diff --git a/hamocc/hamocc_step.F90 b/hamocc/hamocc_step.F90 index 14136cb9..74e12c8b 100644 --- a/hamocc/hamocc_step.F90 +++ b/hamocc/hamocc_step.F90 @@ -36,6 +36,7 @@ subroutine hamocc_step(m,n,mm,nn,k1m,k1n) use mo_read_rivin, only: rivflx use mo_read_fedep, only: get_fedep use mo_read_ndep, only: get_ndep + use mo_read_oafx, only: get_oafx use mo_read_pi_ph, only: get_pi_ph,pi_ph use mo_control_bgc, only: with_dmsph @@ -46,6 +47,7 @@ subroutine hamocc_step(m,n,mm,nn,k1m,k1n) integer :: l,ldtday real :: ndep(idm,jdm) real :: dust(idm,jdm) + real :: oafx(idm,jdm) call trc_limitc(nn) @@ -64,12 +66,13 @@ subroutine hamocc_step(m,n,mm,nn,k1m,k1n) call get_fedep(idm,jdm,date%month,dust) call get_ndep(idm,jdm,date%year,date%month,omask,ndep) + call get_oafx(idm,jdm,date%year,date%month,omask,oafx) if(with_dmsph) call get_pi_ph(idm,jdm,date%month) call hamocc4bcm(idm,jdm,kdm,nbdy, & & date%year,date%month,date%day,ldtday, & & bgc_dx,bgc_dy,bgc_dp,bgc_rho,plat,omask, & - & dust,rivflx,ndep,pi_ph, & + & dust,rivflx,ndep,oafx,pi_ph, & & swa,ficem,slp,abswnd, & & temp(1-nbdy,1-nbdy,1+nn),saln(1-nbdy,1-nbdy,1+nn), & & atmco2,flxco2,flxdms,atmbrf,flxbrf) diff --git a/hamocc/mo_apply_oafx.F90 b/hamocc/mo_apply_oafx.F90 new file mode 100644 index 00000000..16d89b6f --- /dev/null +++ b/hamocc/mo_apply_oafx.F90 @@ -0,0 +1,102 @@ +! Copyright (C) 2021 J. Schwinger +! +! This file is part of BLOM/iHAMOCC. +! +! 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 https://www.gnu.org/licenses/. + + +module mo_apply_oafx +!****************************************************************************** +! +! J.Schwinger *NORCE Climate, Bergen* 2021-11-15 +! +! Modified +! -------- +! +! Purpose +! ------- +! -Routines for applying ocean alkalinization +! +! +! Description: +! ------------ +! +! -subroutine alkalinization +! Apply alkalinization to the top-most model layer. +! +! +!****************************************************************************** + implicit none + + private + public :: apply_oafx + +!****************************************************************************** +contains + + + +subroutine apply_oafx(kpie,kpje,kpke,pddpo,omask,oafx) +!****************************************************************************** +! +! J. Schwinger *NORCE Climate, Bergen* 2021-11-15 +! +! Purpose +! ------- +! -apply alkalinization to the top-most model layer. +! +! Changes: +! -------- +! +! +! Parameter list: +! --------------- +! *INTEGER* *kpie* - 1st dimension of model grid. +! *INTEGER* *kpje* - 2nd dimension of model grid. +! *REAL* *pddpo* - size of grid cell (depth) [m]. +! *REAL* *omask* - land/ocean mask (1=ocean) +! *REAL* *oafx* - alkalinization field to apply [kmol m-2 yr-1] +! +!****************************************************************************** + use mo_control_bgc, only: dtb,do_oalk + use mo_carbch, only: ocetra + use mo_param1_bgc, only: ialkali + + implicit none + + integer, intent(in) :: kpie,kpje,kpke + real, intent(in) :: pddpo(kpie,kpje,kpke) + real, intent(in) :: omask(kpie,kpje) + real, intent(in) :: oafx(kpie,kpje) + + ! local variables + integer :: i,j + + if (.not. do_oalk) return + + ! alkalinization in topmost layer + do j=1,kpje + do i=1,kpie + if (omask(i,j).gt.0.5) then + ocetra(i,j,1,ialkali)=ocetra(i,j,1,ialkali)+oafx(i,j)*dtb/365./pddpo(i,j,1) + endif + enddo + enddo + +!****************************************************************************** +end subroutine apply_oafx + + +!****************************************************************************** +end module mo_apply_oafx diff --git a/hamocc/mo_control_bgc.F90 b/hamocc/mo_control_bgc.F90 index 4c36ce1e..b59c19ee 100644 --- a/hamocc/mo_control_bgc.F90 +++ b/hamocc/mo_control_bgc.F90 @@ -62,6 +62,7 @@ MODULE mo_control_bgc LOGICAL, save :: do_ndep =.true. ! apply n-deposition LOGICAL, save :: do_rivinpt =.true. ! apply riverine input LOGICAL, save :: do_sedspinup=.false. ! apply sediment spin-up + LOGICAL, save :: do_oalk =.false. ! apply ocean alkalinization logical, save :: with_dmsph =.false. ! apply DMS with pH dependence contains diff --git a/hamocc/mo_read_oafx.F90 b/hamocc/mo_read_oafx.F90 new file mode 100644 index 00000000..e3a0f934 --- /dev/null +++ b/hamocc/mo_read_oafx.F90 @@ -0,0 +1,290 @@ +! Copyright (C) 2021-2022 J. Schwinger +! +! This file is part of BLOM/iHAMOCC. +! +! 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 https://www.gnu.org/licenses/. + + +module mo_read_oafx +!****************************************************************************** +! +! J.Schwinger *NORCE Climate, Bergen* 2022-08-24 +! +! Modified +! -------- +! +! Purpose +! ------- +! -Routines for reading ocean alkalinization fluxes from netcdf files +! +! +! Description: +! ------------ +! The routine get_oafx reads a fluxs of alkalinity from file (or, for simple +! cases, constructs an alkalinity flux field from scratch). The alkalinity +! flux is then passed to hamocc4bcm where it is applied to the top-most model +! layer by a call to apply_oafx (mo_apply_oafx). +! +! Ocean alkalinization is activated through a logical switch 'do_oalk' read from +! HAMOCC's bgcnml namelist. If ocean alkalinization is acitvated, a valid +! name of an alkalinisation scenario (defined in this module, see below) and +! the file name (including the full path) of the corresponding OA-scenario +! input file needs to be provided via HAMOCC's bgcnml namelist (variables +! oascenario and oafxfile). If the input file is not found, an error will be +! issued. The input data must be already pre-interpolated to the ocean grid. +! +! Currently available ocean alkalinisation scenarios: +! -'const_0p14': constant alkalinity flux of 0.14 Pmol yr-1 applied to the +! surface ocean between 60S and 70N (no input file needed) +! -'const_0p56': constant alkalinity flux of 0.56 Pmol yr-1 applied to the +! surface ocean between 60S and 70N (no input file needed) +! +! +! -subroutine ini_read_oafx +! Initialise the module +! +! -subroutine get_oafx +! Gets the alkalinity flux to apply at a given time. +! +! +!****************************************************************************** + implicit none + + private + public :: ini_read_oafx,get_oafx,oalkscen,oalkfile + + real,allocatable, save :: oalkflx(:,:) + + character(len=128), save :: oalkscen='' + character(len=512), save :: oalkfile='' + real, parameter :: Pmol2kmol = 1.0e12 + + ! Parameter used in the definition of alkalinization scenarios. The following + ! scenarios are defined in this module: + ! + ! const_0p14 Homogeneous addition of 0.14 Pmol ALK/yr-1 over the ice-free + ! surface ocean (assumed to be between 60S and 70N) + ! const_0p56 Homogeneous addition of 0.56 Pmol ALK/yr-1 over the ice-free + ! surface ocean (assumed to be between 60S and 70N) + ! + real, parameter :: addalk_0p14 = 0.14 ! Pmol alkalinity/yr added in the + real, parameter :: addalk_0p56 = 0.56 ! 'const_0p14' and 'const_0p56' + ! scenarios + real, parameter :: cdrmip_latmax = 70.0 ! Min and max latitude where + real, parameter :: cdrmip_latmin = -60.0 ! alkalinity is added according + ! to the CDRMIP protocol + + logical, save :: lini = .false. + +!****************************************************************************** +contains + + + +subroutine ini_read_oafx(kpie,kpje,pdlxp,pdlyp,pglat,omask) +!****************************************************************************** +! +! J.Schwinger *NORCE Climate, Bergen* 2021-11-15 +! +! Purpose +! ------- +! -Initialise the alkalinization module. +! +! Changes: +! -------- +! +! Parameter list: +! --------------- +! *INTEGER* *kpie* - 1st dimension of model grid. +! *INTEGER* *kpje* - 2nd dimension of model grid. +! *REAL* *pdlxp* - size of grid cell (longitudinal) [m]. +! *REAL* *pdlyp* - size of grid cell (latitudinal) [m]. +! *REAL* *pglat* - latitude grid cell centres [degree N]. +! *REAL* *omask* - land/ocean mask. +! +!****************************************************************************** + use mod_xc, only: xcsum,xchalt,mnproc,nbdy,ips + use mo_control_bgc, only: io_stdo_bgc,do_oalk + + implicit none + + integer, intent(in) :: kpie,kpje + real, intent(in) :: pdlxp(kpie,kpje), pdlyp(kpie,kpje) + real, intent(in) :: pglat(1-nbdy:kpie+nbdy,1-nbdy:kpje+nbdy) + real, intent(in) :: omask(kpie,kpje) + + integer :: i,j,errstat + real :: avflx,ztotarea,addalk_tot + real :: ztmp1(1-nbdy:kpie+nbdy,1-nbdy:kpje+nbdy) + + ! Return if alkalinization is turned off + if (.not. do_oalk) then + if (mnproc.eq.1) then + write(io_stdo_bgc,*) '' + write(io_stdo_bgc,*) 'ini_read_oafx: ocean alkalinization is not activated.' + endif + return + end if + + ! Initialise the module + if(.not. lini) then + + if(mnproc.eq.1) then + write(io_stdo_bgc,*)' ' + write(io_stdo_bgc,*)'***************************************************' + write(io_stdo_bgc,*)'iHAMOCC: Initialization of module mo_read_oafx:' + write(io_stdo_bgc,*)' ' + endif + + !-------------------------------- + ! Scenarios of constant fluxes + !-------------------------------- + if( trim(oalkscen)=='const_0p14' .or. trim(oalkscen)=='const_0p56' ) then + + if(mnproc.eq.1) then + write(io_stdo_bgc,*)'Using alkalinization scenario ', trim(oalkscen) + write(io_stdo_bgc,*)' ' + endif + + ! Allocate field to hold constant alkalinization fluxes + if(mnproc.eq.1) then + write(io_stdo_bgc,*)'Memory allocation for variable oalkflx ...' + write(io_stdo_bgc,*)'First dimension : ',kpie + write(io_stdo_bgc,*)'Second dimension : ',kpje + endif + + allocate(oalkflx(kpie,kpje),stat=errstat) + if(errstat.ne.0) stop 'not enough memory oalkflx' + oalkflx(:,:) = 0.0 + + ! Calculate total ocean area + ztmp1(:,:)=0.0 + do j=1,kpje + do i=1,kpie + if( omask(i,j).gt.0.5 .and. pglat(i,j)cdrmip_latmin ) then + ztmp1(i,j)=ztmp1(i,j)+pdlxp(i,j)*pdlyp(i,j) + endif + enddo + enddo + + call xcsum(ztotarea,ztmp1,ips) + + if( trim(oalkscen)=='const_0p14') then + addalk_tot = addalk_0p14 + else + addalk_tot = addalk_0p56 + endif + + ! Calculate alkalinity flux (kmol m^2 yr-1) to be applied + avflx = addalk_tot/ztotarea*Pmol2kmol + if(mnproc.eq.1) then + write(io_stdo_bgc,*)' ' + write(io_stdo_bgc,*)' applying alkalinity flux of ', avflx, ' kmol m-2 yr-1' + write(io_stdo_bgc,*)' over an area of ', ztotarea , ' m2' + endif + + do j=1,kpje + do i=1,kpie + if( omask(i,j).gt.0.5 .and. pglat(i,j)cdrmip_latmin ) then + oalkflx(i,j) = avflx + endif + enddo + enddo + + lini=.true. + + !-------------------------------- + ! No valid scenario specified + !-------------------------------- + else + + write(io_stdo_bgc,*) '' + write(io_stdo_bgc,*) 'ini_read_oafx: invalid alkalinization scenario... ' + call xchalt('(ini_read_oafx)') + stop '(ini_read_oafx)' + + endif + + endif ! not lini + + +!****************************************************************************** +end subroutine ini_read_oafx + + +subroutine get_oafx(kpie,kpje,kplyear,kplmon,omask,oafx) +!****************************************************************************** +! +! J. Schwinger *NORCE Climate, Bergen* 2021-11-15 +! +! Purpose +! ------- +! -return ocean alkalinization flux. +! +! Changes: +! -------- +! +! +! Parameter list: +! --------------- +! *INTEGER* *kpie* - 1st dimension of model grid. +! *INTEGER* *kpje* - 2nd dimension of model grid. +! *INTEGER* *kplyear* - current year. +! *INTEGER* *kplmon* - current month. +! *REAL* *omask* - land/ocean mask (1=ocean) +! *REAL* *oaflx* - alkalinization flux [kmol m-2 yr-1] +! +!****************************************************************************** + use mod_xc, only: xchalt + use mo_control_bgc, only: io_stdo_bgc,do_oalk + + implicit none + + integer, intent(in) :: kpie,kpje,kplyear,kplmon + real, intent(in) :: omask(kpie,kpje) + real, intent(out) :: oafx(kpie,kpje) + + ! local variables + integer :: i,j + + if (.not. do_oalk) then + oafx(:,:) = 0.0 + return + endif + + !-------------------------------- + ! Scenarios of constant fluxes + !-------------------------------- + if( trim(oalkscen)=='const_0p14' .or. trim(oalkscen)=='const_0p56' ) then + + oafx(:,:) = oalkflx(:,:) + + else + + write(io_stdo_bgc,*) '' + write(io_stdo_bgc,*) 'get_oafx: invalid alkalinization scenario... ' + call xchalt('(get_oafx)') + stop '(get_oafx)' + + endif + +!****************************************************************************** +end subroutine get_oafx + + + +!****************************************************************************** +end module mo_read_oafx From a13ce32a2455b72928da0d7b8f16bf4a50805699 Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Tue, 30 Aug 2022 15:31:59 +0200 Subject: [PATCH 150/366] re-shape init of sediment-related tracer indices --- hamocc/mo_param1_bgc.F90 | 68 +++++++++++++++++++--------------------- 1 file changed, 33 insertions(+), 35 deletions(-) diff --git a/hamocc/mo_param1_bgc.F90 b/hamocc/mo_param1_bgc.F90 index 5793f449..c49f63fc 100644 --- a/hamocc/mo_param1_bgc.F90 +++ b/hamocc/mo_param1_bgc.F90 @@ -219,53 +219,51 @@ MODULE mo_param1_bgc & irdoc =6, & ! dissolved organic carbon & irdet =7 ! particulate carbon - -! sediment -#ifdef cisonew - INTEGER, PARAMETER :: nsedtra=8 + +! --- sediment + ! sediment solid components + INTEGER, PARAMETER :: i_sed_base = 4 INTEGER, PARAMETER :: issso12=1, & & isssc12=2, & & issssil=3, & - & issster=4, & - & issso13=5, & - & issso14=6, & - & isssc13=7, & - & isssc14=8 - -! pore water tracers, index should be the same as for ocetra - INTEGER, PARAMETER :: npowtra=9 - INTEGER, PARAMETER :: ipowaic=1, & - & ipowaal=2, & - & ipowaph=3, & - & ipowaox=4, & - & ipown2 =5, & - & ipowno3=6, & - & ipowasi=7, & - & ipowc13=8, & ! C-isotope idices do NOT correspond to ocetra! - & ipowc14=9 ! C-isotope idices do NOT correspond to ocetra! + & issster=4 +#ifdef cisonew + INTEGER, PARAMETER :: i_sed_cisonew = 4 + INTEGER, PARAMETER :: issso13 = i_sed_base+1, & + & issso14 = i_sed_base+2, & + & isssc13 = i_sed_base+3, & + & isssc14 = i_sed_base+4 #else - INTEGER, PARAMETER :: nsedtra=4 - INTEGER, PARAMETER :: issso12=1, & - & isssc12=2, & - & issssil=3, & - & issster=4, & - & issso13=-1, & - & issso14=-1, & - & isssc13=-1, & - & isssc14=-1 + INTEGER, PARAMETER :: i_sed_cisonew = 0 + INTEGER, PARAMETER :: issso13 = -1, & + & issso14 = -1, & + & isssc13 = -1, & + & isssc14 = -1 +#endif + INTEGER, PARAMETER :: nsedtra = i_sed_base + i_sed_cisonew -! pore water tracers, index should be the same as for ocetra - INTEGER, PARAMETER :: npowtra=7 + + ! sediment pore water components + ! pore water tracers, index should be the same as for ocetra + INTEGER, PARAMETER :: i_pow_base=7 INTEGER, PARAMETER :: ipowaic=1, & & ipowaal=2, & & ipowaph=3, & & ipowaox=4, & & ipown2 =5, & & ipowno3=6, & - & ipowasi=7, & - & ipowc13=-1, & - & ipowc14=-1 + & ipowasi=7 +#ifdef cisonew + INTEGER, PARAMETER :: i_pow_cisonew = 2 + INTEGER, PARAMETER :: ipowc13=i_pow_base + 1, & ! C-isotope indices do NOT correspond to ocetra! + & ipowc14=i_pow_base + 2 ! C-isotope indices do NOT correspond to ocetra! +#else + INTEGER, PARAMETER :: i_pow_cisonew = 0 + INTEGER, PARAMETER :: ipowc13 = -1, & + & ipowc14 = -1 #endif + INTEGER, PARAMETER :: npowtra = i_pow_base + i_pow_cisonew + !****************************************************************************** END MODULE mo_param1_bgc From 24f9e143bcb2cfa7530a3d4a22cdd8b78f3f9cd8 Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Tue, 30 Aug 2022 15:39:52 +0200 Subject: [PATCH 151/366] ADD oafx to meson --- hamocc/meson.build | 2 ++ 1 file changed, 2 insertions(+) diff --git a/hamocc/meson.build b/hamocc/meson.build index f7d79e60..ed3461de 100644 --- a/hamocc/meson.build +++ b/hamocc/meson.build @@ -20,6 +20,7 @@ sources += files( 'mo_apply_fedep.F90', 'mo_apply_ndep.F90', 'mo_apply_rivin.F90', + 'mo_apply_oafx.F90', 'mo_bgcmean.F90', 'mo_biomod.F90', 'mo_carbch.F90', @@ -32,6 +33,7 @@ sources += files( 'mo_read_ndep.F90', 'mo_read_pi_ph.F90', 'mo_read_rivin.F90', + 'mo_read_oafx.F90', 'mo_sedmnt.F90', 'mo_vgrid.F90', 'ncout_hamocc.F90', From cf5f06ad5829224e7f0a11b2f9ba6dfc905bcf87 Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Tue, 30 Aug 2022 15:51:35 +0200 Subject: [PATCH 152/366] Introducing pore water tracers for extended nitrogen cycle --- hamocc/mo_param1_bgc.F90 | 13 ++++++++++++- 1 file changed, 12 insertions(+), 1 deletion(-) diff --git a/hamocc/mo_param1_bgc.F90 b/hamocc/mo_param1_bgc.F90 index c49f63fc..c4c95fc0 100644 --- a/hamocc/mo_param1_bgc.F90 +++ b/hamocc/mo_param1_bgc.F90 @@ -262,7 +262,18 @@ MODULE mo_param1_bgc INTEGER, PARAMETER :: ipowc13 = -1, & & ipowc14 = -1 #endif - INTEGER, PARAMETER :: npowtra = i_pow_base + i_pow_cisonew +#ifdef extNcycle + INTEGER, PARAMETER :: i_pow_extNcycle = 3 !indices not corresponding to ocetra + INTEGER, PARAMETER :: ipownh4=i_pow_base + i_pow_cisonew+1, & + & ipown2o=i_pow_base + i_pow_cisonew+2, & + & ipowno2=i_pow_base + i_pow_cisonew+3 +#else + INTEGER, PARAMETER :: i_pow_extNcycle = 0 + INTEGER, PARAMETER :: ipownh4 = -1, & + & ipown2o = -1, & + & ipowno2 = -1 +#endif + INTEGER, PARAMETER :: npowtra = i_pow_base + i_pow_cisonew + i_pow_extNcycle !****************************************************************************** From cf544070973bc4bb7831b851de91ec7f39b8fd56 Mon Sep 17 00:00:00 2001 From: jmaerz <92309038+jmaerz@users.noreply.github.com> Date: Wed, 31 Aug 2022 10:42:10 +0200 Subject: [PATCH 153/366] ADD oafx to meson (#188) --- hamocc/meson.build | 2 ++ 1 file changed, 2 insertions(+) diff --git a/hamocc/meson.build b/hamocc/meson.build index f7d79e60..ed3461de 100644 --- a/hamocc/meson.build +++ b/hamocc/meson.build @@ -20,6 +20,7 @@ sources += files( 'mo_apply_fedep.F90', 'mo_apply_ndep.F90', 'mo_apply_rivin.F90', + 'mo_apply_oafx.F90', 'mo_bgcmean.F90', 'mo_biomod.F90', 'mo_carbch.F90', @@ -32,6 +33,7 @@ sources += files( 'mo_read_ndep.F90', 'mo_read_pi_ph.F90', 'mo_read_rivin.F90', + 'mo_read_oafx.F90', 'mo_sedmnt.F90', 'mo_vgrid.F90', 'ncout_hamocc.F90', From 4f6a0df6be2460cb7b7f06ee43797a4199562dd5 Mon Sep 17 00:00:00 2001 From: jmaerz <92309038+jmaerz@users.noreply.github.com> Date: Thu, 8 Sep 2022 21:53:30 +0200 Subject: [PATCH 154/366] Dynamic mapping of pore water tracers to ocean tracers (#192) * Initial restructuring of sediment-related tracer declaration and initialization * Introducing mapping function * Remove unncessary comments * Fixed diagnostics bug and updated index naming --- hamocc/dipowa.F90 | 29 ++++--------- hamocc/hamocc_init.F90 | 5 ++- hamocc/mo_param1_bgc.F90 | 89 ++++++++++++++++++++++++---------------- 3 files changed, 66 insertions(+), 57 deletions(-) diff --git a/hamocc/dipowa.F90 b/hamocc/dipowa.F90 index 18cf5dae..be53c421 100644 --- a/hamocc/dipowa.F90 +++ b/hamocc/dipowa.F90 @@ -57,7 +57,7 @@ subroutine dipowa(kpie,kpje,kpke,omask,lspin) use mo_carbch, only: ocetra, sedfluxo use mo_sedmnt, only: powtra,porwat,porwah,sedict,seddw,seddzi - use mo_param1_bgc, only: ks,npowtra + use mo_param1_bgc, only: ks,npowtra,map_por2octra use mo_vgrid, only: kbo,bolay #ifdef cisonew use mo_param1_bgc, only: ipowc13,ipowc14,isco213,isco214 @@ -112,11 +112,7 @@ subroutine dipowa(kpie,kpje,kpke,omask,lspin) k = 0 do iv = 1,npowtra ! loop over pore water tracers - iv_oc = iv -#ifdef cisonew - if (iv == ipowc13) iv_oc = isco213 - if (iv == ipowc14) iv_oc = isco214 -#endif + iv_oc = map_por2octra(iv) do i = 1,kpie sedb1(i,k,iv) = 0. if (omask(i,j) > 0.5) then @@ -190,16 +186,8 @@ subroutine dipowa(kpie,kpje,kpke,omask,lspin) if(.not. lspin) THEN ! sediment ocean interface -! -! CAUTION - the following assumes same indecees for ocetra and powtra -! test npowa_base 071106 -! check mo_param1_bgc.f90 for consistency do iv = 1, npowtra - iv_oc = iv -#ifdef cisonew - if (iv == ipowc13) iv_oc=isco213 - if (iv == ipowc14) iv_oc=isco214 -#endif + iv_oc = map_por2octra(iv) do i = 1,kpie l = 0 if (omask(i,j) > 0.5) then @@ -210,14 +198,15 @@ subroutine dipowa(kpie,kpje,kpke,omask,lspin) ! diffusive fluxes (positive downward) sedfluxo(i,j,iv) = sedfluxo(i,j,iv) & - & -(ocetra(i,j,kbo(i,j),iv) - aprior)* bolay(i,j) + & -(ocetra(i,j,kbo(i,j),iv_oc) - aprior)* bolay(i,j) #ifdef natDIC - if (iv==isco212) ocetra(i,j,kbo(i,j),inatsco212) = & + ! workaround as long as natDIC is not implemented throughout the sediment module + if (iv_oc==isco212) ocetra(i,j,kbo(i,j),inatsco212) = & & ocetra(i,j,kbo(i,j),inatsco212) + & - & ocetra(i,j,kbo(i,j),iv) - aprior - if (iv==ialkali) ocetra(i,j,kbo(i,j),inatalkali) = & + & ocetra(i,j,kbo(i,j),isco212) - aprior + if (iv_oc==ialkali) ocetra(i,j,kbo(i,j),inatalkali) = & & ocetra(i,j,kbo(i,j),inatalkali) + & - & ocetra(i,j,kbo(i,j),iv) - aprior + & ocetra(i,j,kbo(i,j),ialkali) - aprior #endif endif enddo diff --git a/hamocc/hamocc_init.F90 b/hamocc/hamocc_init.F90 index c8af2b31..0f753f30 100644 --- a/hamocc/hamocc_init.F90 +++ b/hamocc/hamocc_init.F90 @@ -47,7 +47,7 @@ subroutine hamocc_init(read_rest,rstfnm_hamocc) & sedspin_yr_s,sedspin_yr_e,sedspin_ncyc, & & dtb,dtbgc,io_stdo_bgc,ldtbgc, & & ldtrunbgc,ndtdaybgc,with_dmsph - use mo_param1_bgc, only: ks,nsedtra,npowtra + use mo_param1_bgc, only: ks,nsedtra,npowtra,init_por2octra_mapping use mo_carbch, only: alloc_mem_carbch,ocetra,atm,atm_co2 use mo_biomod, only: alloc_mem_biomod use mo_sedmnt, only: alloc_mem_sedmnt,sedlay,powtra,burial @@ -130,6 +130,9 @@ subroutine hamocc_init(read_rest,rstfnm_hamocc) endif ENDIF + ! init the index-mapping between pore water and ocean tracers + CALL init_por2octra_mapping() + ! ! --- Memory allocation ! diff --git a/hamocc/mo_param1_bgc.F90 b/hamocc/mo_param1_bgc.F90 index ade3a94e..7bc0c5c7 100644 --- a/hamocc/mo_param1_bgc.F90 +++ b/hamocc/mo_param1_bgc.F90 @@ -201,53 +201,70 @@ MODULE mo_param1_bgc & irdoc =6, & ! dissolved organic carbon & irdet =7 ! particulate carbon - -! sediment -#ifdef cisonew - INTEGER, PARAMETER :: nsedtra=8 + +! --- sediment + ! sediment solid components + INTEGER, PARAMETER :: i_sed_base = 4 INTEGER, PARAMETER :: issso12=1, & & isssc12=2, & & issssil=3, & - & issster=4, & - & issso13=5, & - & issso14=6, & - & isssc13=7, & - & isssc14=8 - -! pore water tracers, index should be the same as for ocetra - INTEGER, PARAMETER :: npowtra=9 - INTEGER, PARAMETER :: ipowaic=1, & - & ipowaal=2, & - & ipowaph=3, & - & ipowaox=4, & - & ipown2 =5, & - & ipowno3=6, & - & ipowasi=7, & - & ipowc13=8, & ! C-isotope idices do NOT correspond to ocetra! - & ipowc14=9 ! C-isotope idices do NOT correspond to ocetra! + & issster=4 +#ifdef cisonew + INTEGER, PARAMETER :: i_sed_cisonew = 4 + INTEGER, PARAMETER :: issso13 = i_sed_base+1, & + & issso14 = i_sed_base+2, & + & isssc13 = i_sed_base+3, & + & isssc14 = i_sed_base+4 #else - INTEGER, PARAMETER :: nsedtra=4 - INTEGER, PARAMETER :: issso12=1, & - & isssc12=2, & - & issssil=3, & - & issster=4, & - & issso13=-1, & - & issso14=-1, & - & isssc13=-1, & - & isssc14=-1 - -! pore water tracers, index should be the same as for ocetra - INTEGER, PARAMETER :: npowtra=7 + INTEGER, PARAMETER :: i_sed_cisonew = 0 + INTEGER, PARAMETER :: issso13 = -1, & + & issso14 = -1, & + & isssc13 = -1, & + & isssc14 = -1 +#endif + INTEGER, PARAMETER :: nsedtra = i_sed_base + i_sed_cisonew + + + ! sediment pore water components + INTEGER, PARAMETER :: i_pow_base=7 INTEGER, PARAMETER :: ipowaic=1, & & ipowaal=2, & & ipowaph=3, & & ipowaox=4, & & ipown2 =5, & & ipowno3=6, & - & ipowasi=7, & - & ipowc13=-1, & - & ipowc14=-1 + & ipowasi=7 +#ifdef cisonew + INTEGER, PARAMETER :: i_pow_cisonew = 2 + INTEGER, PARAMETER :: ipowc13=i_pow_base + 1, & + & ipowc14=i_pow_base + 2 +#else + INTEGER, PARAMETER :: i_pow_cisonew = 0 + INTEGER, PARAMETER :: ipowc13 = -1, & + & ipowc14 = -1 #endif + INTEGER, PARAMETER :: npowtra = i_pow_base + i_pow_cisonew + + ! Mapping between pore water and ocean tracers needed for pore water diffusion + INTEGER, SAVE :: map_por2octra(npowtra) + + contains + + subroutine init_por2octra_mapping() + + map_por2octra(ipowaic) = isco212 + map_por2octra(ipowaal) = ialkali + map_por2octra(ipowaph) = iphosph + map_por2octra(ipowaox) = ioxygen + map_por2octra(ipown2) = igasnit + map_por2octra(ipowno3) = iano3 + map_por2octra(ipowasi) = isilica + + ! if statements for non-base tracers + if(ipowc13 > 0) map_por2octra(ipowc13) = isco213 + if(ipowc14 > 0) map_por2octra(ipowc14) = isco214 + + end subroutine init_por2octra_mapping !****************************************************************************** END MODULE mo_param1_bgc From d0d907d568d420ab6304d91856154d2b937d9b5d Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Fri, 9 Sep 2022 17:56:11 +0200 Subject: [PATCH 155/366] add new pore water tracers to mapping between pore water and ocean tracers --- hamocc/mo_param1_bgc.F90 | 3 +++ 1 file changed, 3 insertions(+) diff --git a/hamocc/mo_param1_bgc.F90 b/hamocc/mo_param1_bgc.F90 index 3a9a43b1..975293dc 100644 --- a/hamocc/mo_param1_bgc.F90 +++ b/hamocc/mo_param1_bgc.F90 @@ -292,6 +292,9 @@ subroutine init_por2octra_mapping() ! if statements for non-base tracers if(ipowc13 > 0) map_por2octra(ipowc13) = isco213 if(ipowc14 > 0) map_por2octra(ipowc14) = isco214 + if(ipownh4 > 0) map_por2octra(ipownh4) = ianh4 + if(ipown2o > 0) map_por2octra(ipown2o) = ian2o + if(ipowno2 > 0) map_por2octra(ipowno2) = iano2 end subroutine init_por2octra_mapping From 081ed30ad2abeb80dc3871ade55f1bebf0cf3665 Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Fri, 9 Sep 2022 18:10:43 +0200 Subject: [PATCH 156/366] Add lM4AGO to bgc namelist --- cime_config/buildnml | 3 +++ hamocc/hamocc_init.F90 | 2 +- 2 files changed, 4 insertions(+), 1 deletion(-) diff --git a/cime_config/buildnml b/cime_config/buildnml index f65bae01..cd06a64c 100755 --- a/cime_config/buildnml +++ b/cime_config/buildnml @@ -233,6 +233,7 @@ endif # For the following options, there are currently no switches in Case-XML files. # These options can be activated by expert users via user namelist. set DO_OALK = .false. +set LM4AGO = .false. set OALKSCEN = "''" set OALKFILE = "''" set WITH_DMSPH = .false. @@ -1502,6 +1503,7 @@ cat >>! $RUNDIR/ocn_in$inststr << EOF ! SEDSPIN_YR_S: Start year for sediment spinup ! SEDSPIN_YR_E: End year for sediment spinup ! SEDSPIN_NCYC: Number of subcyles per time-step for sediment spinup +! LM4AGO : Switch for M4AGO settling scheme ! INIXXX : Initial condition file for iHAMOCC, where XXX=DIC, ALK, PO4, ! OXY, NO3, SIL, D13C, and D14C ! WITH_DMSPH : Logical switch to activate DMS calculation as function of pH @@ -1521,6 +1523,7 @@ cat >>! $RUNDIR/ocn_in$inststr << EOF SEDSPIN_YR_S = $SEDSPIN_YR_S SEDSPIN_YR_E = $SEDSPIN_YR_E SEDSPIN_NCYC = $SEDSPIN_NCYC + LM4AGO = $LM4AGO INIDIC = $INIDIC INIALK = $INIALK INIPO4 = $INIPO4 diff --git a/hamocc/hamocc_init.F90 b/hamocc/hamocc_init.F90 index 69448f79..0fc72e5d 100644 --- a/hamocc/hamocc_init.F90 +++ b/hamocc/hamocc_init.F90 @@ -83,7 +83,7 @@ subroutine hamocc_init(read_rest,rstfnm_hamocc) & sedspin_yr_e,sedspin_ncyc, & & inidic,inialk,inipo4,inioxy,inino3,inisil, & & inid13c,inid14c,swaclimfile, & - & with_dmsph,pi_ph_file + & with_dmsph,pi_ph_file,lm4ago ! ! --- Set io units and some control parameters ! From 2d5e07627d5c5c957fe478e6ad2a93a4fd84c791 Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Tue, 13 Sep 2022 15:28:22 +0200 Subject: [PATCH 157/366] Introduced MODULE mo_extNsediment.F90 --- hamocc/meson.build | 1 + hamocc/mo_extNbioproc.F90 | 4 +- hamocc/mo_extNsediment.F90 | 83 ++++++++++++++++++++++++++++++++++++++ 3 files changed, 87 insertions(+), 1 deletion(-) create mode 100644 hamocc/mo_extNsediment.F90 diff --git a/hamocc/meson.build b/hamocc/meson.build index 4c10573b..4ee30065 100644 --- a/hamocc/meson.build +++ b/hamocc/meson.build @@ -49,4 +49,5 @@ sources += files( 'trc_limitc.F90', 'write_netcdf_var.F90', 'mo_extNbioproc.F90', + 'mo_extNsediment.F90', 'mo_m4ago.F90') diff --git a/hamocc/mo_extNbioproc.F90 b/hamocc/mo_extNbioproc.F90 index 004c3ef8..a0c86993 100644 --- a/hamocc/mo_extNbioproc.F90 +++ b/hamocc/mo_extNbioproc.F90 @@ -44,7 +44,9 @@ MODULE mo_extNbioproc ! ! Explicit cyanobacteria? ! - ! Sediment processes? + ! The respective sediment processes are handled in: + ! - powach.F90 and + ! - mo_extNsediment.F90 ! !**************************************************************** use mo_vgrid, only: dp_min diff --git a/hamocc/mo_extNsediment.F90 b/hamocc/mo_extNsediment.F90 new file mode 100644 index 00000000..0f73e091 --- /dev/null +++ b/hamocc/mo_extNsediment.F90 @@ -0,0 +1,83 @@ +! Copyright (C) 2022 j. maerz +! +! This file is part of BLOM/iHAMOCC. +! +! 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 https://www.gnu.org/licenses/. + +MODULE mo_extNsediment +!********************************************************************** +! +! MODULE mo_extNsediment - extended nitrogen cycle processes +! in the sediment +! +! j.maerz 13.09.2022 +! +! Pupose: +! ------- +! - initialization of sediment related parameters of the +! extended nitrogen cycle +! - representation of microbial processes +! +! Description: +! ------------ +! The module holds the sequentially operated processes of: +! - nitrification +! - denitrification/dissimilatory nitrate reduction from NO3 to NO2 +! - anammox +! - denitrification processes from NO2 -> N2O -> N2 and DNRA +! (dissimilatory nitrite reduction to ammonium) +! +! The process of ammonification in the sediment for the extended +! nitrogen cycle is handled inside powach.F90. +! +!********************************************************************** + implicit none + private + + ! public functions + public :: extNsediment_param_init,sed_nitrification,sed_denit_NO3_to_NO2,sed_anammox,sed_denit_DNRA + + ! public parameters + !public :: + + ! extended nitrogen cycle sediment parameters + real :: sn + + contains + ! ================================================================================================================================ + subroutine extNsediment_param_init() + + end subroutine extNsediment_param_init + + ! ================================================================================================================================ + subroutine sed_nitrification() + + end subroutine sed_nitrification + + ! ================================================================================================================================ + subroutine sed_denit_NO3_to_NO2() + + end subroutine sed_denit_NO3_to_NO2 + + ! ================================================================================================================================ + subroutine sed_anammox() + + end subroutine sed_anammox + + ! ================================================================================================================================ + subroutine sed_denit_DNRA() + + end subroutine sed_denit_DNRA + +END MODULE mo_extNsediment From 10378a53d66cced608c19d7cb54e60328aa633cc Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Tue, 13 Sep 2022 17:07:54 +0200 Subject: [PATCH 158/366] Setup of general structure for the sediment part of the extended nitrogen cycle potentially, DIC and alkalinity changes need to be treated diffrently than before (aka potentially requires to add new fields) --- hamocc/beleg_parm.F90 | 2 + hamocc/hamocc4bcm.F90 | 2 +- hamocc/mo_extNsediment.F90 | 100 +++++++++++++++++++++++++------------ hamocc/powach.F90 | 17 ++++++- 4 files changed, 86 insertions(+), 35 deletions(-) diff --git a/hamocc/beleg_parm.F90 b/hamocc/beleg_parm.F90 index e20da925..81c0abfd 100644 --- a/hamocc/beleg_parm.F90 +++ b/hamocc/beleg_parm.F90 @@ -73,6 +73,7 @@ SUBROUTINE BELEG_PARM(kpie,kpje) use mo_carbch, only: atm_nh3,atm_n2o use mo_chemcon, only: atn2o !fixed mixing ratio of N2O at 1980, 300ppb = 3e-7 use mo_extNbioproc, only: extNbioparam_init + use mo_extNsediment,only: extNsediment_param_init #endif implicit none @@ -257,6 +258,7 @@ SUBROUTINE BELEG_PARM(kpie,kpje) #ifdef extNcycle ! initialize the extended nitrogen cycle parameters call extNbioparam_init() + call extNsediment_param_init() #endif #ifdef BROMO diff --git a/hamocc/hamocc4bcm.F90 b/hamocc/hamocc4bcm.F90 index 51aeaef8..48391522 100644 --- a/hamocc/hamocc4bcm.F90 +++ b/hamocc/hamocc4bcm.F90 @@ -356,7 +356,7 @@ SUBROUTINE HAMOCC4BCM(kpie,kpje,kpke,kbnd,kplyear,kplmon,kplday,kldtday,& lspin=.false. endif - call POWACH(kpie,kpje,kpke,kbnd,prho,omask,psao,lspin) + call POWACH(kpie,kpje,kpke,kbnd,prho,omask,psao,ptho,lspin) enddo diff --git a/hamocc/mo_extNsediment.F90 b/hamocc/mo_extNsediment.F90 index 0f73e091..23c63490 100644 --- a/hamocc/mo_extNsediment.F90 +++ b/hamocc/mo_extNsediment.F90 @@ -16,33 +16,37 @@ ! along with BLOM. If not, see https://www.gnu.org/licenses/. MODULE mo_extNsediment -!********************************************************************** -! -! MODULE mo_extNsediment - extended nitrogen cycle processes -! in the sediment -! -! j.maerz 13.09.2022 -! -! Pupose: -! ------- -! - initialization of sediment related parameters of the -! extended nitrogen cycle -! - representation of microbial processes -! -! Description: -! ------------ -! The module holds the sequentially operated processes of: -! - nitrification -! - denitrification/dissimilatory nitrate reduction from NO3 to NO2 -! - anammox -! - denitrification processes from NO2 -> N2O -> N2 and DNRA -! (dissimilatory nitrite reduction to ammonium) -! -! The process of ammonification in the sediment for the extended -! nitrogen cycle is handled inside powach.F90. -! -!********************************************************************** + !********************************************************************** + ! + ! MODULE mo_extNsediment - extended nitrogen cycle processes + ! in the sediment + ! + ! j.maerz 13.09.2022 + ! + ! Pupose: + ! ------- + ! - initialization of sediment related parameters of the + ! extended nitrogen cycle + ! - representation of microbial processes + ! + ! Description: + ! ------------ + ! The module holds the sequentially operated processes of: + ! - nitrification + ! - denitrification/dissimilatory nitrate reduction from NO3 to NO2 + ! - anammox + ! - denitrification processes from NO2 -> N2O -> N2 and DNRA + ! (dissimilatory nitrite reduction to ammonium) + ! + ! The process of ammonification in the sediment for the extended + ! nitrogen cycle is handled inside powach.F90. + ! + !********************************************************************** + use mo_param1_bgc, only: issso12,ipowaic,ipowaal,ipowaph,ipowaox,ipown2,ipowno3,ipownh4,ipown2o,ipowno2,ks + use mo_vgrid, only: kbo + implicit none + private ! public functions @@ -52,7 +56,7 @@ MODULE mo_extNsediment !public :: ! extended nitrogen cycle sediment parameters - real :: sn + !real :: sn contains ! ================================================================================================================================ @@ -61,22 +65,54 @@ subroutine extNsediment_param_init() end subroutine extNsediment_param_init ! ================================================================================================================================ - subroutine sed_nitrification() - + subroutine sed_nitrification(j,kpie,kpje,kpke,kbnd,ptho,omask,aerob) + integer, intent(in) :: j,kpie,kpje,kpke,kbnd + real, intent(in) :: omask(kpie,kpje) + real, intent(in) :: ptho(1-kbnd:kpie+kbnd,1-kbnd:kpje+kbnd,kpke) + ! for calculation of pore water DIC and alkalinity changes [P-units]! + real, intent(inout) :: aerob(kpie,ks) + + ! local variables + integer :: i,k + end subroutine sed_nitrification ! ================================================================================================================================ - subroutine sed_denit_NO3_to_NO2() + subroutine sed_denit_NO3_to_NO2(j,kpie,kpje,kpke,kbnd,ptho,omask,anaerob) + integer, intent(in) :: j,kpie,kpje,kpke,kbnd + real, intent(in) :: omask(kpie,kpje) + real, intent(in) :: ptho(1-kbnd:kpie+kbnd,1-kbnd:kpje+kbnd,kpke) + ! for calculation of pore water DIC and alkalinity changes [P-units]! + real, intent(inout) :: anaerob(kpie,ks) + + ! local variables + integer :: i,k end subroutine sed_denit_NO3_to_NO2 ! ================================================================================================================================ - subroutine sed_anammox() + subroutine sed_anammox(j,kpie,kpje,kpke,kbnd,ptho,omask,anaerob) + integer, intent(in) :: j,kpie,kpje,kpke,kbnd + real, intent(in) :: omask(kpie,kpje) + real, intent(in) :: ptho(1-kbnd:kpie+kbnd,1-kbnd:kpje+kbnd,kpke) + ! for calculation of pore water DIC and alkalinity changes [P-units]! + real, intent(inout) :: anaerob(kpie,ks) + + ! local variables + integer :: i,k end subroutine sed_anammox ! ================================================================================================================================ - subroutine sed_denit_DNRA() + subroutine sed_denit_DNRA(j,kpie,kpje,kpke,kbnd,ptho,omask,anaerob) + integer, intent(in) :: j,kpie,kpje,kpke,kbnd + real, intent(in) :: omask(kpie,kpje) + real, intent(in) :: ptho(1-kbnd:kpie+kbnd,1-kbnd:kpje+kbnd,kpke) + ! for calculation of pore water DIC and alkalinity changes [P-units]! + real, intent(inout) :: anaerob(kpie,ks) + + ! local variables + integer :: i,k end subroutine sed_denit_DNRA diff --git a/hamocc/powach.F90 b/hamocc/powach.F90 index 5c7f6fbc..68ed113a 100644 --- a/hamocc/powach.F90 +++ b/hamocc/powach.F90 @@ -17,7 +17,7 @@ ! along with BLOM. If not, see https://www.gnu.org/licenses/. -subroutine powach(kpie,kpje,kpke,kbnd,prho,omask,psao,lspin) +subroutine powach(kpie,kpje,kpke,kbnd,prho,omask,psao,ptho,lspin) !****************************************************************************** ! !**** *POWACH* - . @@ -53,6 +53,7 @@ subroutine powach(kpie,kpje,kpke,kbnd,prho,omask,psao,lspin) ! *REAL* *prho* - seawater density [g/cm^3]. ! *REAL* *psao* - salinity [psu]. ! *REAL* *omask* - land/ocean mask +! *REAL* *ptho* - potential temperature [deg C] ! ! Externals ! --------- @@ -72,6 +73,10 @@ subroutine powach(kpie,kpje,kpke,kbnd,prho,omask,psao,lspin) use mo_param1_bgc, only: ipowc13,ipowc14,isssc13,isssc14,issso13,issso14,safediv use mo_sedmnt, only: pror13,pror14,prca13,prca14 #endif +#ifdef extNcycle + use mo_param1_bgc, only: ipownh4 + use mo_extNsediment, only: extNsediment_param_init,sed_nitrification,sed_denit_NO3_to_NO2,sed_anammox,sed_denit_DNRA +#endif implicit none @@ -80,6 +85,7 @@ subroutine powach(kpie,kpje,kpke,kbnd,prho,omask,psao,lspin) real, intent(in) :: prho(kpie,kpje,kpke) real, intent(in) :: omask(kpie,kpje) real, intent(in) :: psao(1-kbnd:kpie+kbnd,1-kbnd:kpje+kbnd,kpke) + real, intent(in) :: ptho(1-kbnd:kpie+kbnd,1-kbnd:kpje+kbnd,kpke) logical, intent(in) :: lspin ! Local variables @@ -344,7 +350,7 @@ subroutine powach(kpie,kpje,kpke,kbnd,prho,omask,psao,lspin) ! Calculate nitrate reduction under anaerobic conditions explicitely !******************************************************************* - +#ifndef extNcycle ! Denitrification rate constant of POP (disso) [1/sec] ! Store flux in array anaerob, for later computation of DIC and alkalinity. @@ -381,6 +387,13 @@ subroutine powach(kpie,kpje,kpke,kbnd,prho,omask,psao,lspin) endif enddo enddo +#else + !======>>>> extended nitrogen cycle processes (aerobic and anaerobic) that follow ammonification + CALL sed_nitrification(j,kpie,kpje,kpke,kbnd,ptho,omask,aerob) + CALL sed_denit_NO3_to_NO2(j,kpie,kpje,kpke,kbnd,ptho,omask,anaerob) + CALL sed_anammox(j,kpie,kpje,kpke,kbnd,ptho,omask,anaerob) + CALL sed_denit_dnra(j,kpie,kpje,kpke,kbnd,ptho,omask,anaerob) +#endif ! sulphate reduction in sediments From 26de84474ff59dc86cacf3432d7854e97f1ebb5c Mon Sep 17 00:00:00 2001 From: Mats Bentsen Date: Thu, 15 Sep 2022 00:26:21 +0200 Subject: [PATCH 159/366] Added initial support for NUOPC driver. --- cime_config/buildlib_2.2 | 5 +- cime_config/config_archive.xml | 13 + drivers/nuopc/external_abort.F90 | 35 + drivers/nuopc/mod_nuopc_methods.F90 | 1034 +++++++++++++++++++++++ drivers/nuopc/mod_swtfrz.F90 | 81 ++ drivers/nuopc/ocn_comp_nuopc.F90 | 1189 +++++++++++++++++++++++++++ drivers/nuopc/setlogunit.F90 | 25 + 7 files changed, 2381 insertions(+), 1 deletion(-) create mode 100644 cime_config/config_archive.xml create mode 100644 drivers/nuopc/external_abort.F90 create mode 100644 drivers/nuopc/mod_nuopc_methods.F90 create mode 100644 drivers/nuopc/mod_swtfrz.F90 create mode 100644 drivers/nuopc/ocn_comp_nuopc.F90 create mode 100644 drivers/nuopc/setlogunit.F90 diff --git a/cime_config/buildlib_2.2 b/cime_config/buildlib_2.2 index 956c3116..3b800c15 100755 --- a/cime_config/buildlib_2.2 +++ b/cime_config/buildlib_2.2 @@ -80,10 +80,13 @@ def _main_func(): else: expect(False, "tracer module {} is not recognized".format(module)) - expect(driver != "nuopc", "NUOPC driver not supported") if driver == "mct": paths.append(os.path.join(comp_root_dir_ocn, "drivers", "cpl_share")) paths.append(os.path.join(comp_root_dir_ocn, "drivers", "cpl_mct")) + elif driver == "nuopc": + paths.append(os.path.join(comp_root_dir_ocn, "drivers", "nuopc")) + else: + expect(False, "Driver {} is not supported".format(driver)) with open(filepath_file, "w") as filepath: filepath.write("\n".join(paths)) diff --git a/cime_config/config_archive.xml b/cime_config/config_archive.xml new file mode 100644 index 00000000..0939f52d --- /dev/null +++ b/cime_config/config_archive.xml @@ -0,0 +1,13 @@ + + + r + rbgc + h[dmy]\d*.*\.nc$ + hbgc[dmy]\d*.*\.nc$ + unset + + rpointer.ocn$NINST_STRING + ./$CASE.blom$NINST_STRING.r.$DATENAME.nc + + + diff --git a/drivers/nuopc/external_abort.F90 b/drivers/nuopc/external_abort.F90 new file mode 100644 index 00000000..4e1932a1 --- /dev/null +++ b/drivers/nuopc/external_abort.F90 @@ -0,0 +1,35 @@ +! ------------------------------------------------------------------------------ +! Copyright (C) 2015 Mats Bentsen +! +! 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 . +! ------------------------------------------------------------------------------ + +subroutine external_abort(msg) +! ------------------------------------------------------------------------------ +! Call CESM shared abort routine. +! ------------------------------------------------------------------------------ + + use shr_sys_mod, only: shr_sys_abort + + implicit none + + ! Input/output arguments. + + character(len=*), intent(in) :: msg + + call shr_sys_abort(msg) + +end subroutine external_abort diff --git a/drivers/nuopc/mod_nuopc_methods.F90 b/drivers/nuopc/mod_nuopc_methods.F90 new file mode 100644 index 00000000..0d24e367 --- /dev/null +++ b/drivers/nuopc/mod_nuopc_methods.F90 @@ -0,0 +1,1034 @@ +! ------------------------------------------------------------------------------ +! Copyright (C) 2022 Mats Bentsen +! +! 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_nuopc_methods +! ------------------------------------------------------------------------------ +! This module contains routines operating on BLOM data structures needed by the +! NUOPC cap. +! ------------------------------------------------------------------------------ + + use mod_types, only: r8 + use mod_constants, only: rearth, onem + use mod_time, only: nstep, baclin, delt1, dlt + use mod_xc + use mod_grid, only: scuy, scvx, scp2, scuxi, scvyi, plon, plat, & + cosang, sinang + use mod_state, only: u, v, dp, temp, saln, pbu, pbv, ubflxs, vbflxs, sealv + use mod_forcing, only: sprfac, prfac, flxco2, flxdms, flxbrf + use mod_difest, only: obldepth + use mod_vcoord, only: vcoord_type_tag, isopyc_bulkml, cntiso_hybrid + 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, & + ustarw_da, slp_da, abswnd_da, atmco2_da, atmbrf_da, & + ficem_da, l1ci, l2ci + use mod_utility, only: util1, util2 + use mod_checksum, only: csdiag, chksummsk + use shr_const_mod, only: SHR_CONST_RHOSW, SHR_CONST_LATICE, SHR_CONST_TKFRZ + + implicit none + + private + + ! Parameters. + character(len=*), parameter :: modname = '(mod_nuopc_methods)' + + type :: fldlist_type + character(len=128) :: stdname + integer :: ungridded_lbound = 0 + integer :: ungridded_ubound = 0 + real(r8), dimension(:), pointer :: dataptr + end type fldlist_type + + real(r8), dimension(:), allocatable :: mod2med_areacor, med2mod_areacor + real(r8), dimension(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy) :: & + acc_u, acc_v, acc_dhdx, acc_dhdy, acc_t, acc_s, acc_frzpot, acc_bld, & + acc_fco2, acc_fdms, acc_fbrf + real(r8) :: tlast_coupled + integer :: jjcpl + logical :: fco2_requested, fdms_requested, fbrf_requested + + public :: fldlist_type, tlast_coupled, & + fco2_requested, fdms_requested, fbrf_requested, & + blom_logwrite, blom_getgindex, blom_checkmesh, blom_setareacor, & + blom_getglobdim, blom_getprecipfact, blom_accflds, & + blom_importflds, blom_exportflds + +contains + + ! --------------------------------------------------------------------------- + ! Private procedures. + ! --------------------------------------------------------------------------- + + subroutine getfldindex(fldlist_num, fldlist, stdname, fldindex) + ! --------------------------------------------------------------------------- + ! Get index of field with given standard name. If no field has a matching + ! name or a field with matching name has an unassociated data pointer, set + ! index to zero. + ! --------------------------------------------------------------------------- + + ! Input/output arguments. + integer, intent(in) :: fldlist_num + type(fldlist_type), dimension(:), intent(in) :: fldlist + character(len=*), intent(in) :: stdname + integer, intent(inout) :: fldindex + + ! Local variables. + integer :: n + + if (fldindex >= 0) return + + fldindex = 0 + + do n = 1, fldlist_num + if (fldlist(n)%stdname == stdname) then + if (associated(fldlist(n)%dataptr)) fldindex = n + return + endif + enddo + + end subroutine getfldindex + + ! --------------------------------------------------------------------------- + ! Public procedures. + ! --------------------------------------------------------------------------- + + subroutine blom_logwrite(msg) + ! --------------------------------------------------------------------------- + ! Write message string to standard out from master PE. + ! --------------------------------------------------------------------------- + + ! Input/output arguments. + character(len=*), intent(in) :: msg + + if (mnproc == 1) write(lp,'(a)') trim(msg) + + end subroutine blom_logwrite + + subroutine blom_getgindex(gindex) + ! --------------------------------------------------------------------------- + ! Get global index space for the computational domain. + ! --------------------------------------------------------------------------- + + ! Input/output arguments. + integer, allocatable, dimension(:), intent(out) :: gindex + + ! Local variables. + integer :: mproc_next, i, j, n + + ! Set the j-extent of the local ocean domain to be exchanged. Needed + ! because of duplication of the last global domain row when using a + ! tripolar grid. + if (nreg == 2 .and. nproc == jpr) then + jjcpl = jj - 1 + else + jjcpl = jj + endif + + ! Create the global index space for the computational domain. Also append + ! indices of eliminated grid cells adjacent to the domain and with larger + ! global i-index. + mproc_next = mod(mproc, ipr) + 1 + do while (ii_pe(mproc_next,nproc) == 0) + mproc_next = mod(mproc_next, ipr) + 1 + enddo + allocate(gindex(mod(i0_pe(mproc_next,nproc) - i0 + itdm, itdm)*jjcpl)) + n = 0 + do j = 1, jjcpl + do i = 1, ii + n = n + 1 + gindex(n) = (j0 + j - 1)*itdm + i0 + i + enddo + enddo + do j = 1, jjcpl + do i = ii + 1, mod(i0_pe(mproc_next,nproc) - i0 + itdm, itdm) + n = n + 1 + gindex(n) = (j0 + j - 1)*itdm + mod(i0 + i - 1, itdm) + 1 + enddo + enddo + + end subroutine blom_getgindex + + subroutine blom_checkmesh(lonmesh, latmesh, maskmesh) + ! --------------------------------------------------------------------------- + ! Check for consistency of lat, lon and mask between mediator mesh and model + ! grid. + ! --------------------------------------------------------------------------- + + ! Input/output arguments. + real(r8), dimension(:), pointer, intent(in) :: lonmesh, latmesh + integer, dimension(:), pointer, intent(in) :: maskmesh + + ! Local parameters. + character(len=*), parameter :: & + subname = modname//':(blom_checkmesh)' + + ! Local variables. + real(r8) :: diff_lon, diff_lat + integer :: mproc_next, i, j, n + + do j = 1, jjcpl + do i = 1, ii + n = (j - 1)*ii + i + diff_lon = abs(mod(lonmesh(n) - plon(i,j),360._r8)) + if (diff_lon > 1.e-3_r8) then + write(lp,'(a,3i6,2(f21.13,3x),d21.5)') subname// & + ': BLOM ERROR: n, i, j, lonmesh(n), plon(i,j), diff_lon = ', & + n, i, j, lonmesh(n), plon(i,j), diff_lon + call xchalt(subname) + stop subname + endif + diff_lat = abs(latmesh(n) - plat(i,j)) + if (diff_lat > 1.e-3_r8) then + write(lp,'(a,3i6,2(f21.13,3x),d21.5)') subname// & + ': BLOM ERROR: n, i, j, latmesh(n), plat(i,j), diff_lat = ', & + n, i, j, latmesh(n), plat(i,j), diff_lat + call xchalt(subname) + stop subname + endif + if (maskmesh(n) /= ip(i,j)) then + write(lp,'(a,3i6,2(f21.13,3x),d21.5)') subname// & + ': BLOM ERROR: n, i, j, maskmesh(n), ip(i,j) = ', & + n, i, j, maskmesh(n), ip(i,j) + call xchalt(subname) + stop subname + endif + enddo + enddo + + end subroutine blom_checkmesh + + subroutine blom_getprecipfact(precip_fact_provided, precip_fact) + ! --------------------------------------------------------------------------- + ! Get precipitation factor. + ! --------------------------------------------------------------------------- + + ! Input/output arguments. + logical, intent(out) :: precip_fact_provided + real(r8), intent(out) :: precip_fact + + precip_fact_provided = sprfac + precip_fact = prfac + + end subroutine blom_getprecipfact + + subroutine blom_getglobdim(nx_global, ny_global) + ! --------------------------------------------------------------------------- + ! Get global dimensions of export/import domain. + ! --------------------------------------------------------------------------- + + ! Input/output arguments. + integer, intent(out) :: nx_global, ny_global + + nx_global = itdm + if (nreg == 2) then + ny_global = jtdm - 1 + else + ny_global = jtdm + endif + + end subroutine blom_getglobdim + + subroutine blom_setareacor(areamesh, maskmesh) + ! --------------------------------------------------------------------------- + ! Set flux area correction factors. + ! --------------------------------------------------------------------------- + + ! Input/output arguments. + real(r8), dimension(:), pointer, intent(in) :: areamesh + integer, dimension(:), pointer, intent(in) :: maskmesh + + ! Local parameters. + character(len=*), parameter :: & + subname = modname//':(blom_setareacor)' + + ! Local variables. + real(r8) :: areamodel, & + max_mod2med_areacor, max_med2mod_areacor, & + min_mod2med_areacor, min_med2mod_areacor + integer :: i, j, n + + allocate(mod2med_areacor(size(areamesh)), & + med2mod_areacor(size(areamesh))) + mod2med_areacor(:) = 1._r8 + med2mod_areacor(:) = 1._r8 + + !$omp parallel do private(i, n) + do j = 1, jjcpl + do i = 1, ii + n = (j - 1)*ii + i + if (maskmesh(n) /= 0) then + areamodel = scp2(i,j)/(rearth*rearth) + mod2med_areacor(n) = areamodel/areamesh(n) + med2mod_areacor(n) = areamesh(n)/areamodel + endif + enddo + enddo + !$omp end parallel do + + min_mod2med_areacor = minval(mod2med_areacor) + max_mod2med_areacor = maxval(mod2med_areacor) + min_med2mod_areacor = minval(med2mod_areacor) + max_med2mod_areacor = maxval(med2mod_areacor) + call xcmax(max_mod2med_areacor) + call xcmin(min_mod2med_areacor) + call xcmax(max_med2mod_areacor) + call xcmin(min_med2mod_areacor) + if (mnproc == 1) then + write(lp,'(a,2g23.15)') & + subname//': min_mod2med_areacor, max_mod2med_areacor ', & + min_mod2med_areacor, max_mod2med_areacor + write(lp,'(a,2g23.15)') & + subname//': min_med2mod_areacor, max_med2mod_areacor ', & + min_med2mod_areacor, max_med2mod_areacor + endif + + end subroutine blom_setareacor + + subroutine blom_accflds + ! --------------------------------------------------------------------------- + ! Accumulate export fields to be averaged before sent to the mediator. + ! --------------------------------------------------------------------------- + + ! Local parameters. + character(len=*), parameter :: & + subname = modname//':(blom_accflds)' + + ! Local variables. + real(r8) :: q + integer m, n, mm, nn, k1m, k1n, i, j, l + + ! ------------------------------------------------------------------------ + ! Set accumulation arrays to zero if this is the first call after a + ! coupling interval. + ! ------------------------------------------------------------------------ + + if (tlast_coupled == 0._r8) then + acc_u (:,:) = 0._r8 + acc_v (:,:) = 0._r8 + acc_dhdx (:,:) = 0._r8 + acc_dhdy (:,:) = 0._r8 + acc_t (:,:) = 0._r8 + acc_s (:,:) = 0._r8 + acc_frzpot(:,:) = 0._r8 + acc_bld (:,:) = 0._r8 + acc_fco2 (:,:) = 0._r8 + acc_fdms (:,:) = 0._r8 + acc_fbrf (:,:) = 0._r8 + endif + + ! ------------------------------------------------------------------------ + ! Accumulate fields in send buffer + ! ------------------------------------------------------------------------ + + m = mod(nstep + 1, 2) + 1 + n = mod(nstep , 2) + 1 + mm = (m - 1)*kk + nn = (n - 1)*kk + k1m = 1 + mm + k1n = 1 + nn + + call xctilr(sealv, 1,1, 1,1, halo_ps) + + !$omp parallel do private(l, i) + do j = 1, jj + do l = 1, isu(j) + do i = max(1, ifu(j,l)), min(ii, ilu(j,l)) + acc_u(i,j) = acc_u(i,j) & + + ( u(i,j,k1n) & + + (ubflxs(i,j,m) + ubflxs(i,j,n))*dlt & + /(pbu(i,j,n)*scuy(i,j)*delt1))*baclin + acc_dhdx(i,j) = acc_dhdx(i,j) & + + (sealv(i,j) - sealv(i-1,j))*scuxi(i,j)*baclin + enddo + enddo + do l = 1, isv(j) + do i = max(1, ifv(j,l)), min(ii, ilv(j,l)) + acc_v(i,j) = acc_v(i,j) & + + ( v(i,j,k1n) & + + (vbflxs(i,j,m) + vbflxs(i,j,n))*dlt & + /(pbv(i,j,n)*scvx(i,j)*delt1))*baclin + acc_dhdy(i,j) = acc_dhdy(i,j) & + + (sealv(i,j) - sealv(i,j-1))*scvyi(i,j)*baclin + enddo + enddo + do l = 1, isp(j) + do i = max(1, ifp(j,l)), min(ii, ilp(j,l)) + acc_t(i,j) = acc_t(i,j) + temp(i,j,k1n)*baclin + acc_s(i,j) = acc_s(i,j) + saln(i,j,k1n)*baclin + acc_frzpot(i,j) = acc_frzpot(i,j) + frzpot(i,j) + enddo + enddo + enddo + !$omp end parallel do + + select case (vcoord_type_tag) + case (isopyc_bulkml) + q = baclin/onem + !$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)) + acc_bld(i,j) = (dp(i,j,1+nn) + dp(i,j,2+nn))*q + enddo + enddo + enddo + !$omp end parallel do + case (cntiso_hybrid) + !$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)) + acc_bld(i,j) = OBLdepth(i,j)*baclin + enddo + enddo + enddo + !$omp end parallel do + case default + if (mnproc == 1) & + write(lp,*) subname//': unsupported vertical coordinate!' + call xcstop(subname) + stop subname + end select + + if (fco2_requested) then + !$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)) + acc_fco2(i,j) = acc_fco2(i,j) + flxco2(i,j)*baclin + enddo + enddo + enddo + !$omp end parallel do + endif + + if (fdms_requested) then + !$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)) + acc_fdms(i,j) = acc_fdms(i,j) + flxdms(i,j)*baclin + enddo + enddo + enddo + !$omp end parallel do + endif + + if (fbrf_requested) then + !$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)) + acc_fbrf(i,j) = acc_fbrf(i,j) + flxbrf(i,j)*baclin + enddo + enddo + enddo + !$omp end parallel do + endif + + ! ------------------------------------------------------------------------ + ! Increment time since last coupling. + ! ------------------------------------------------------------------------ + + tlast_coupled = tlast_coupled + baclin + + end subroutine blom_accflds + + subroutine blom_importflds(fldlist_num, fldlist) + ! --------------------------------------------------------------------------- + ! Import fields from mediator to BLOM arrays. + ! --------------------------------------------------------------------------- + + ! Input/output arguments. + integer, intent(in) :: fldlist_num + type(fldlist_type), dimension(:), intent(in) :: fldlist + + ! Local parameters. + character(len=*), parameter :: & + subname = modname//':(blom_importflds)' + real(r8), parameter :: & + mval = - 1.e12_r8, & + fval = - 1.e13_r8 + + ! Local variables. + real(r8) :: afac, utmp, vtmp + integer :: n, i, j, l + integer, save :: & + index_Si_ifrac = - 1, & + index_Fioi_melth = - 1, & + index_Fioi_meltw = - 1, & + index_Fioi_salt = - 1, & + index_Fioi_bcpho = - 1, & + index_Fioi_bcphi = - 1, & + index_Fioi_flxdst = - 1, & + index_Foxx_rofl = - 1, & + index_Foxx_rofi = - 1, & + index_So_duu10n = - 1, & + index_Foxx_tauy = - 1, & + index_Foxx_taux = - 1, & + index_Foxx_lat = - 1, & + index_Foxx_sen = - 1, & + index_Foxx_lwup = - 1, & + index_Foxx_evap = - 1, & + index_Foxx_swnet = - 1, & + index_Sw_lamult = - 1, & + index_Sw_ustokes = - 1, & + index_Sw_vstokes = - 1, & + index_Sw_hstokes = - 1, & + index_Sa_pslv = - 1, & + index_Faxa_lwdn = - 1, & + index_Faxa_snow = - 1, & + index_Faxa_rain = - 1, & + index_Sa_co2diag = - 1, & + index_Sa_co2prog = - 1, & + index_Sa_brfprog = - 1 + + ! Update time level indices. + if (l1ci == 1 .and. l2ci == 1) then + l1ci = 2 + l2ci = 2 + else + l1ci = l2ci + l2ci = 3 - l2ci + endif + + call getfldindex(fldlist_num, fldlist, 'Foxx_taux', index_Foxx_taux) + call getfldindex(fldlist_num, fldlist, 'Foxx_tauy', index_Foxx_tauy) + + !$omp parallel do private(i, n) + do j = 1, jjcpl + do i = 1, ii + if (ip(i,j) == 0) then + util1(i,j) = mval + util2(i,j) = mval + ustarw_da(i,j,l2ci) = mval + elseif (cplmsk(i,j) == 0) then + util1(i,j) = fval + util2(i,j) = fval + ustarw_da(i,j,l2ci) = fval + else + n = (j - 1)*ii + i + afac = med2mod_areacor(n) + utmp = fldlist(index_Foxx_taux)%dataptr(n)*afac + vtmp = fldlist(index_Foxx_tauy)%dataptr(n)*afac + util1(i,j) = utmp*cosang(i,j) + vtmp*sinang(i,j) + util2(i,j) = - utmp*sinang(i,j) + vtmp*cosang(i,j) + + ! Friction velocity [m s-1]. + ustarw_da(i,j,l2ci) = sqrt(sqrt(utmp*utmp + vtmp*vtmp) & + /SHR_CONST_RHOSW) + endif + enddo + enddo + !$omp end parallel do + + call fill_global(mval, fval, halo_pv, util1) + call fill_global(mval, fval, halo_pv, util2) + call fill_global(mval, fval, halo_ps, ustarw_da(1-nbdy,1-nbdy,l2ci)) + + call xctilr(util1, 1,1, 1,1, halo_pv) + call xctilr(util2, 1,1, 1,1, halo_pv) + + !$omp parallel do private(l, i) + do j = 1, jj + do l = 1, isu(j) + do i = max(1,ifu(j,l)), min(ii,ilu(j,l)) + ! x-component of momentum flux [kg m-1 s-2]. + ztx_da(i,j,l2ci) = .5_r8*(util1(i-1,j) + util1(i,j)) + enddo + enddo + do l = 1,isv(j) + do i = max(1,ifv(j,l)), min(ii,ilv(j,l)) + ! y-component of momentum flux [kg m-1 s-2]. + mty_da(i,j,l2ci) = .5_r8*(util2(i,j-1) + util2(i,j)) + enddo + enddo + enddo + !$omp end parallel do + + call getfldindex(fldlist_num, fldlist, 'Faxa_rain', index_Faxa_rain) + call getfldindex(fldlist_num, fldlist, 'Faxa_snow', index_Faxa_snow) + call getfldindex(fldlist_num, fldlist, 'Foxx_evap', index_Foxx_evap) + call getfldindex(fldlist_num, fldlist, 'Foxx_rofl', index_Foxx_rofl) + call getfldindex(fldlist_num, fldlist, 'Foxx_rofi', index_Foxx_rofi) + call getfldindex(fldlist_num, fldlist, 'Fioi_meltw', index_Fioi_meltw) + call getfldindex(fldlist_num, fldlist, 'Fioi_salt', index_Fioi_salt) + call getfldindex(fldlist_num, fldlist, 'Foxx_swnet', index_Foxx_swnet) + call getfldindex(fldlist_num, fldlist, 'Foxx_lat', index_Foxx_lat) + call getfldindex(fldlist_num, fldlist, 'Foxx_sen', index_Foxx_sen) + call getfldindex(fldlist_num, fldlist, 'Foxx_lwup', index_Foxx_lwup) + call getfldindex(fldlist_num, fldlist, 'Faxa_lwdn', index_Faxa_lwdn) + call getfldindex(fldlist_num, fldlist, 'Fioi_melth', index_Fioi_melth) + call getfldindex(fldlist_num, fldlist, 'Sa_pslv', index_Sa_pslv) + call getfldindex(fldlist_num, fldlist, 'Si_ifrac', index_Si_ifrac) + call getfldindex(fldlist_num, fldlist, 'So_duu10n', index_So_duu10n) + + !$omp parallel do private(i, n) + do j = 1, jjcpl + do i = 1, ii + + if (ip(i,j) == 0) then + lip_da(i,j,l2ci) = mval + sop_da(i,j,l2ci) = mval + eva_da(i,j,l2ci) = mval + rnf_da(i,j,l2ci) = mval + rfi_da(i,j,l2ci) = mval + fmltfz_da(i,j,l2ci) = mval + sfl_da(i,j,l2ci) = mval + swa_da(i,j,l2ci) = mval + nsf_da(i,j,l2ci) = mval + hmlt_da(i,j,l2ci) = mval + slp_da(i,j,l2ci) = mval + ficem_da(i,j,l2ci) = mval + abswnd_da(i,j,l2ci) = mval + elseif (cplmsk(i,j) == 0) then + lip_da(i,j,l2ci) = 0._r8 + sop_da(i,j,l2ci) = 0._r8 + eva_da(i,j,l2ci) = 0._r8 + rnf_da(i,j,l2ci) = 0._r8 + rfi_da(i,j,l2ci) = 0._r8 + fmltfz_da(i,j,l2ci) = 0._r8 + sfl_da(i,j,l2ci) = 0._r8 + swa_da(i,j,l2ci) = 0._r8 + nsf_da(i,j,l2ci) = 0._r8 + hmlt_da(i,j,l2ci) = 0._r8 + slp_da(i,j,l2ci) = fval + ficem_da(i,j,l2ci) = fval + abswnd_da(i,j,l2ci) = fval + else + n = (j - 1)*ii + i + afac = med2mod_areacor(n) + + ! Liquid water flux, positive downwards [kg m-2 s-1]. + lip_da(i,j,l2ci) = fldlist(index_Faxa_rain)%dataptr(n)*afac + + ! Solid precipitation, positive downwards [kg m-2 s-1]. + sop_da(i,j,l2ci) = fldlist(index_Faxa_snow)%dataptr(n)*afac + + ! Evaporation, positive downwards [kg m-2 s-1]. + eva_da(i,j,l2ci) = fldlist(index_Foxx_evap)%dataptr(n)*afac + + ! Liquid runoff, positive downwards [kg m-2 s-1]. + rnf_da(i,j,l2ci) = fldlist(index_Foxx_rofl)%dataptr(n)*afac + + ! Frozen runoff, positive downwards [kg m-2 s-1]. + rfi_da(i,j,l2ci) = fldlist(index_Foxx_rofi)%dataptr(n)*afac + + ! Fresh water due to melting/freezing, positive downwards + ! [kg m-2 s-1]. + fmltfz_da(i,j,l2ci) = fldlist(index_Fioi_meltw)%dataptr(n)*afac + + ! Salt flux, positive downwards [kg m-2 s-1]. + sfl_da(i,j,l2ci) = fldlist(index_Fioi_salt)%dataptr(n)*afac + + ! Shortwave heat flux, positive downwards [W m-2]. + swa_da(i,j,l2ci) = fldlist(index_Foxx_swnet)%dataptr(n)*afac + + ! Non-solar heat flux, positive downwards [W m-2]. + nsf_da(i,j,l2ci) = ( fldlist(index_Foxx_lat)%dataptr(n) & + + fldlist(index_Foxx_sen)%dataptr(n) & + + fldlist(index_Foxx_lwup)%dataptr(n) & + + fldlist(index_Faxa_lwdn)%dataptr(n) & + - ( fldlist(index_Faxa_snow)%dataptr(n) & + + fldlist(index_Foxx_rofi)%dataptr(n)) & + *SHR_CONST_LATICE)*afac + + ! Heat flux due to melting, positive downwards [W m-2]. + hmlt_da(i,j,l2ci) = fldlist(index_Fioi_melth)%dataptr(n)*afac + + ! Sea level pressure [kg m-1 s-2]. + slp_da(i,j,l2ci) = fldlist(index_Sa_pslv)%dataptr(n) + + ! Ice fraction []. + ficem_da(i,j,l2ci) = fldlist(index_Si_ifrac)%dataptr(n) + + ! 10m wind speed [m s-1]. + abswnd_da(i,j,l2ci) = sqrt(fldlist(index_So_duu10n)%dataptr(n)) + + endif + + enddo + enddo + !$omp end parallel do + + if (nreg == 2) then + call xctilr(lip_da(1-nbdy,1-nbdy,l2ci), 1,1, 0,0, halo_ps) + call xctilr(sop_da(1-nbdy,1-nbdy,l2ci), 1,1, 0,0, halo_ps) + call xctilr(eva_da(1-nbdy,1-nbdy,l2ci), 1,1, 0,0, halo_ps) + call xctilr(rnf_da(1-nbdy,1-nbdy,l2ci), 1,1, 0,0, halo_ps) + call xctilr(rfi_da(1-nbdy,1-nbdy,l2ci), 1,1, 0,0, halo_ps) + call xctilr(fmltfz_da(1-nbdy,1-nbdy,l2ci), 1,1, 0,0, halo_ps) + call xctilr(sfl_da(1-nbdy,1-nbdy,l2ci), 1,1, 0,0, halo_ps) + call xctilr(swa_da(1-nbdy,1-nbdy,l2ci), 1,1, 0,0, halo_ps) + call xctilr(nsf_da(1-nbdy,1-nbdy,l2ci), 1,1, 0,0, halo_ps) + call xctilr(hmlt_da(1-nbdy,1-nbdy,l2ci), 1,1, 0,0, halo_ps) + endif + + call fill_global(mval, fval, halo_ps, slp_da(1-nbdy,1-nbdy,l2ci)) + call fill_global(mval, fval, halo_ps, ficem_da(1-nbdy,1-nbdy,l2ci)) + call fill_global(mval, fval, halo_ps, abswnd_da(1-nbdy,1-nbdy,l2ci)) + +#ifdef PROGCO2 + call getfldindex(fldlist_num, fldlist, 'Sa_co2prog', index_Sa_co2prog) + + if (index_Sa_co2prog > 0) then + !$omp parallel do private(i, n) + do j = 1, jjcpl + do i = 1, ii + if (ip(i,j) == 0) then + atmco2_da(i,j,l2ci) = mval + elseif (cplmsk(i,j) == 0) then + atmco2_da(i,j,l2ci) = fval + else + n = (j - 1)*ii + i + ! Atmospheric co2 concentration [ppmv?] + atmco2_da(i,j,l2ci) = fldlist(index_Sa_co2prog)%dataptr(n) + endif + enddo + enddo + !$omp end parallel do + call fill_global(mval, fval, halo_ps, atmco2_da(1-nbdy,1-nbdy,l2ci)) + if (mnproc == 1) & + write(lp,*) subname//': prog. atmospheric co2 read' + else + !$omp parallel do private(i) + do j = 1, jj + do i = 1, ii + if (ip(i,j) == 0) then + atmco2_da(i,j,l2ci) = mval + else + atmco2_da(i,j,l2ci) = -1 + endif + enddo + enddo + !$omp end parallel do + if (mnproc == 1) & + write(lp,*) subname//': prog. atmospheric co2 not read' + endif + +#elif defined(DIAGCO2) + call getfldindex(fldlist_num, fldlist, 'Sa_co2diag', index_Sa_co2diag) + + if (index_Sa_co2diag > 0) then + !$omp parallel do private(i, n) + do j = 1, jjcpl + do i = 1, ii + if (ip(i,j) == 0) then + atmco2_da(i,j,l2ci) = mval + elseif (cplmsk(i,j) == 0) then + atmco2_da(i,j,l2ci) = fval + else + n = (j - 1)*ii + i + ! Atmospheric co2 concentration [ppmv?] + atmco2_da(i,j,l2ci) = fldlist(index_Sa_co2diag)%dataptr(n) + endif + enddo + enddo + !$omp end parallel do + call fill_global(mval, fval, halo_ps, atmco2_da(1-nbdy,1-nbdy,l2ci)) + if (mnproc == 1) & + write(lp,*) subname//': diag. atmospheric co2 read' + else + !$omp parallel do private(i) + do j = 1, jj + do i = 1, ii + if (ip(i,j) == 0) then + atmco2_da(i,j,l2ci) = mval + else + atmco2_da(i,j,l2ci) = -1 + endif + enddo + enddo + !$omp end parallel do + if (mnproc == 1) & + write(lp,*) subname//': diag. atmospheric co2 not read' + endif +#else + !$omp parallel do private(i) + do j = 1, jj + do i = 1, ii + if (ip(i,j) == 0) then + atmco2_da(i,j,l2ci) = mval + else + atmco2_da(i,j,l2ci) = -1 + endif + enddo + enddo + !$omp end parallel do + if (mnproc == 1) & + write(lp,*) subname//': atmospheric co2 not read' +#endif + + call getfldindex(fldlist_num, fldlist, 'Sa_brfprog', index_Sa_brfprog) + + if (index_Sa_brfprog > 0) then + !$omp parallel do private(i, n) + do j = 1, jjcpl + do i = 1, ii + if (ip(i,j) == 0) then + atmbrf_da(i,j,l2ci) = mval + elseif (cplmsk(i,j) == 0) then + atmbrf_da(i,j,l2ci) = fval + else + n = (j - 1)*ii + i + ! Atmospheric bromoform concentration [ppt] + atmbrf_da(i,j,l2ci) = fldlist(index_Sa_brfprog)%dataptr(n) + endif + enddo + enddo + !$omp end parallel do + call fill_global(mval, fval, halo_ps, atmbrf_da(1-nbdy,1-nbdy,l2ci)) + if (mnproc == 1) & + write(lp,*) subname//': prog. atmospheric bromoform read' + else + !$omp parallel do private(i) + do j = 1, jj + do i = 1, ii + if (ip(i,j) == 0) then + atmbrf_da(i,j,l2ci) = mval + else + atmbrf_da(i,j,l2ci) = -1 + endif + enddo + enddo + !$omp end parallel do + if (mnproc == 1) & + write(lp,*) subname//': prog. atmospheric bromoform not read' + endif + + if (csdiag) then + if (mnproc == 1) then + write(lp,*) subname//':' + endif + call chksummsk(ustarw_da(1-nbdy,1-nbdy,l2ci),ip,1,'ustarw') + call chksummsk(ztx_da(1-nbdy,1-nbdy,l2ci),iu,1,'ztx') + call chksummsk(mty_da(1-nbdy,1-nbdy,l2ci),iv,1,'mty') + call chksummsk(lip_da(1-nbdy,1-nbdy,l2ci),ip,1,'lip') + call chksummsk(sop_da(1-nbdy,1-nbdy,l2ci),ip,1,'sop') + call chksummsk(eva_da(1-nbdy,1-nbdy,l2ci),ip,1,'eva') + call chksummsk(rnf_da(1-nbdy,1-nbdy,l2ci),ip,1,'rnf') + call chksummsk(rfi_da(1-nbdy,1-nbdy,l2ci),ip,1,'rfi') + call chksummsk(fmltfz_da(1-nbdy,1-nbdy,l2ci),ip,1,'fmltfz') + call chksummsk(sfl_da(1-nbdy,1-nbdy,l2ci),ip,1,'sfl') + call chksummsk(swa_da(1-nbdy,1-nbdy,l2ci),ip,1,'swa') + call chksummsk(nsf_da(1-nbdy,1-nbdy,l2ci),ip,1,'nsf') + call chksummsk(hmlt_da(1-nbdy,1-nbdy,l2ci),ip,1,'hmlt') + call chksummsk(slp_da(1-nbdy,1-nbdy,l2ci),ip,1,'slp') + call chksummsk(ficem_da(1-nbdy,1-nbdy,l2ci),ip,1,'ficem') + call chksummsk(abswnd_da(1-nbdy,1-nbdy,l2ci),ip,1,'abswnd') + call chksummsk(atmco2_da(1-nbdy,1-nbdy,l2ci),ip,1,'atmco2') + call chksummsk(atmbrf_da(1-nbdy,1-nbdy,l2ci),ip,1,'atmbrf') + endif + + end subroutine blom_importflds + + subroutine blom_exportflds(fldlist_num, fldlist) + ! --------------------------------------------------------------------------- + ! Export from BLOM arrays to mediator fields. + ! --------------------------------------------------------------------------- + + ! Input/output arguments. + integer, intent(in) :: fldlist_num + type(fldlist_type), dimension(:), intent(in) :: fldlist + + ! Local parameters. + character(len=*), parameter :: & + subname = modname//':(blom_exportflds)' + + ! Local variables. + real(r8) :: tfac, utmp, vtmp + integer :: n, l, i, j + integer, save :: & + index_So_omask = - 1, & + index_So_u = - 1, & + index_So_v = - 1, & + index_So_dhdx = - 1, & + index_So_dhdy = - 1, & + index_So_t = - 1, & + index_So_s = - 1, & + index_So_bldepth = - 1, & + index_Fioo_q = - 1, & + index_Faoo_fdms_ocn = - 1, & + index_Faoo_fco2_ocn = - 1, & + index_Faoo_fbrf_ocn = - 1 + + tfac = 1._r8/tlast_coupled + + ! ------------------------------------------------------------------------ + ! Provide standard export fields. + ! ------------------------------------------------------------------------ + + call xctilr(acc_u, 1,1, 1,1, halo_uv) + call xctilr(acc_v, 1,1, 1,1, halo_vv) + call xctilr(acc_dhdx, 1,1, 1,1, halo_uv) + call xctilr(acc_dhdy, 1,1, 1,1, halo_vv) + + call getfldindex(fldlist_num, fldlist, 'So_omask', index_So_omask) + call getfldindex(fldlist_num, fldlist, 'So_u', index_So_u) + call getfldindex(fldlist_num, fldlist, 'So_v', index_So_v) + call getfldindex(fldlist_num, fldlist, 'So_dhdx', index_So_dhdx) + call getfldindex(fldlist_num, fldlist, 'So_dhdy', index_So_dhdy) + call getfldindex(fldlist_num, fldlist, 'So_t', index_So_t) + call getfldindex(fldlist_num, fldlist, 'So_s', index_So_s) + call getfldindex(fldlist_num, fldlist, 'So_bldepth', index_So_bldepth) + call getfldindex(fldlist_num, fldlist, 'Fioo_q', index_Fioo_q) + + fldlist(index_So_omask)%dataptr(:) = 0._r8 + fldlist(index_So_u)%dataptr(:) = 0._r8 + fldlist(index_So_v)%dataptr(:) = 0._r8 + fldlist(index_So_dhdx)%dataptr(:) = 0._r8 + fldlist(index_So_dhdy)%dataptr(:) = 0._r8 + fldlist(index_So_t)%dataptr(:) = 0._r8 + fldlist(index_So_s)%dataptr(:) = 0._r8 + fldlist(index_So_bldepth)%dataptr(:) = 0._r8 + fldlist(index_Fioo_q)%dataptr(:) = 0._r8 + + !$omp parallel do private(l, i, n, utmp, vtmp) + do j = 1, jjcpl + do l = 1, isp(j) + do i = max(1, ifp(j,l)), min(ii, ilp(j,l)) + n = (j - 1)*ii + i + + ! Ocean mask []. + fldlist(index_So_omask)%dataptr(n) = 1._r8 + + ! Surface velocity, interpolated onto scalar points and rotated + ! [m s-1]. + utmp = .5_r8*(acc_u(i,j) + acc_u(i+1,j))*tfac*1.e-2_r8 + vtmp = .5_r8*(acc_v(i,j) + acc_v(i,j+1))*tfac*1.e-2_r8 + fldlist(index_So_u)%dataptr(n) = utmp*cosang(i,j) & + - vtmp*sinang(i,j) + fldlist(index_So_v)%dataptr(n) = utmp*sinang(i,j) & + + vtmp*cosang(i,j) + + ! Surface gradient, interpolated onto scalar points and rotated []. + utmp = (acc_dhdx(i,j)*iu(i,j) + acc_dhdx(i+1,j)*iu(i+1,j))*tfac & + /max(1, iu(i,j) + iu(i+1,j)) + vtmp = (acc_dhdy(i,j)*iv(i,j) + acc_dhdy(i,j+1)*iv(i,j+1))*tfac & + /max(1, iv(i,j) + iv(i,j+1)) + fldlist(index_So_dhdx)%dataptr(n) = utmp*cosang(i,j) & + - vtmp*sinang(i,j) + fldlist(index_So_dhdy)%dataptr(n) = utmp*sinang(i,j) & + + vtmp*cosang(i,j) + + ! Surface temperature [K]. + fldlist(index_So_t)%dataptr(n) = acc_t(i,j)*tfac & + + SHR_CONST_TKFRZ + + ! Surface salinity [g kg-1]. + fldlist(index_So_s)%dataptr(n) = acc_s(i,j)*tfac + + ! Boundary layer depth [m]. + fldlist(index_So_bldepth)%dataptr(n) = acc_bld(i,j)*tfac + + ! Freezing/melting potential [W m-2]. + if (acc_frzpot(i,j) > 0._r8) then + fldlist(index_Fioo_q)%dataptr(n) = & + acc_frzpot(i,j)*tfac*mod2med_areacor(n) + else + fldlist(index_Fioo_q)%dataptr(n) = & + mltpot(i,j)*tfac*mod2med_areacor(n) + endif + + enddo + enddo + enddo + !$omp end parallel do + + ! ------------------------------------------------------------------------ + ! Provide DMS flux [kmol DMS m-2 s-1], if requested. + ! ------------------------------------------------------------------------ + + call getfldindex(fldlist_num, fldlist, 'Faoo_fdms_ocn', & + index_Faoo_fdms_ocn) + + if (fbrf_requested .and. index_Faoo_fdms_ocn > 0) then + fldlist(index_Faoo_fdms_ocn)%dataptr(:) = 0._r8 + !$omp parallel do private(l, i, n) + do j = 1, jjcpl + do l = 1, isp(j) + do i = max(1, ifp(j,l)), min(ii, ilp(j,l)) + n = (j - 1)*ii + i + fldlist(index_Faoo_fdms_ocn)%dataptr(n) = & + acc_fbrf(i,j)*tfac*mod2med_areacor(n) + enddo + enddo + enddo + !$omp end parallel do + else + if (mnproc == 1) & + write(lp,*) subname//': dms flux not sent to coupler' + endif + + ! ------------------------------------------------------------------------ + ! Provide CO2 flux [kg CO2 m-2 s-1], if requested. + ! ------------------------------------------------------------------------ + + call getfldindex(fldlist_num, fldlist, 'Faoo_fco2_ocn', & + index_Faoo_fco2_ocn) + + if (fco2_requested .and. index_Faoo_fco2_ocn > 0) then + fldlist(index_Faoo_fco2_ocn)%dataptr(:) = 0._r8 + !$omp parallel do private(l, i, n) + do j = 1, jjcpl + do l = 1, isp(j) + do i = max(1, ifp(j,l)), min(ii, ilp(j,l)) + n = (j - 1)*ii + i + fldlist(index_Faoo_fco2_ocn)%dataptr(n) = & + acc_fco2(i,j)*tfac*mod2med_areacor(n) + enddo + enddo + enddo + !$omp end parallel do + else + if (mnproc == 1) & + write(lp,*) subname//': co2 flux not sent to coupler' + endif + + ! ------------------------------------------------------------------------ + ! Provide bromoform flux [kg CHBr3 m-2 s-1], if requested. + ! ------------------------------------------------------------------------ + + call getfldindex(fldlist_num, fldlist, 'Faoo_fbrf_ocn', & + index_Faoo_fbrf_ocn) + + if (fbrf_requested .and. index_Faoo_fbrf_ocn > 0) then + fldlist(index_Faoo_fbrf_ocn)%dataptr(:) = 0._r8 + !$omp parallel do private(l, i, n) + do j = 1, jjcpl + do l = 1, isp(j) + do i = max(1, ifp(j,l)), min(ii, ilp(j,l)) + n = (j - 1)*ii + i + fldlist(index_Faoo_fbrf_ocn)%dataptr(n) = & + acc_fbrf(i,j)*tfac*mod2med_areacor(n) + enddo + enddo + enddo + !$omp end parallel do + else + if (mnproc == 1) & + write(lp,*) subname//': bromoform flux not sent to coupler' + endif + + tlast_coupled = 0._r8 + + end subroutine blom_exportflds + +end module mod_nuopc_methods diff --git a/drivers/nuopc/mod_swtfrz.F90 b/drivers/nuopc/mod_swtfrz.F90 new file mode 100644 index 00000000..d5209eeb --- /dev/null +++ b/drivers/nuopc/mod_swtfrz.F90 @@ -0,0 +1,81 @@ +! ------------------------------------------------------------------------------ +! Copyright (C) 2018-2022 Mats Bentsen +! +! 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_swtfrz +! ------------------------------------------------------------------------------ +! This module contains routines for computing the freezing point of sea water. +! ------------------------------------------------------------------------------ + + use mod_types, only: r8 + use shr_frz_mod, only: shr_frz_freezetemp + + implicit none + + private + + public :: swtfrz + + interface swtfrz + module procedure swtfrz_0d + module procedure swtfrz_1d + module procedure swtfrz_2d + end interface swtfrz + +contains + + function swtfrz_0d(p,s) result(swtfrz) + ! --------------------------------------------------------------------------- + ! Retrieve freezing temperature from shared CESM function. + ! --------------------------------------------------------------------------- + + real(r8), intent(in) :: p ! Pressure [g cm-1 s-2] + real(r8), intent(in) :: s ! Salinity [g kg-1] + real(r8) :: swtfrz + + swtfrz = shr_frz_freezetemp(s) + + end function swtfrz_0d + + function swtfrz_1d(p,s) result(swtfrz) + ! --------------------------------------------------------------------------- + ! Retrieve freezing temperature from shared CESM function. + ! --------------------------------------------------------------------------- + + real(r8), intent(in) :: p(:) ! Pressure [g cm-1 s-2] + real(r8), intent(in) :: s(:) ! Salinity [g kg-1] + real(r8) :: swtfrz(size(s)) + + swtfrz(:) = shr_frz_freezetemp(s(:)) + + end function swtfrz_1d + + function swtfrz_2d(p,s) result(swtfrz) + ! --------------------------------------------------------------------------- + ! Retrieve freezing temperature from shared CESM function. + ! --------------------------------------------------------------------------- + + real(r8), intent(in) :: p(:,:) ! Pressure [g cm-1 s-2] + real(r8), intent(in) :: s(:,:) ! Salinity [g kg-1] + real(r8) :: swtfrz(size(s,1),size(s,2)) + + swtfrz(:,:) = shr_frz_freezetemp(s(:,:)) + + end function swtfrz_2d + +end module mod_swtfrz diff --git a/drivers/nuopc/ocn_comp_nuopc.F90 b/drivers/nuopc/ocn_comp_nuopc.F90 new file mode 100644 index 00000000..086501e5 --- /dev/null +++ b/drivers/nuopc/ocn_comp_nuopc.F90 @@ -0,0 +1,1189 @@ +! ------------------------------------------------------------------------------ +! Copyright (C) 2022 Mats Bentsen +! +! 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 ocn_comp_nuopc +! ------------------------------------------------------------------------------ +! This module contains the NUOPC cap for BLOM. +! ------------------------------------------------------------------------------ + + use ESMF ! TODO MOM6 uses "only" statements, while POP and CICE omits this. + use NUOPC, only: NUOPC_CompDerive, NUOPC_CompSetEntryPoint, & + NUOPC_CompSpecialize, NUOPC_CompFilterPhaseMap, & + NUOPC_IsUpdated, NUOPC_IsAtTime, NUOPC_CompAttributeGet, & + NUOPC_Advertise, NUOPC_SetAttribute, & + NUOPC_CompAttributeGet, NUOPC_CompAttributeSet, & + NUOPC_IsConnected, NUOPC_Realize + use NUOPC_Model, only: NUOPC_ModelGet, SetVM, & + model_routine_SS => SetServices, & + model_label_Advance => label_Advance, & + model_label_DataInitialize => label_DataInitialize, & + model_label_SetRunClock => label_SetRunClock, & + model_label_Finalize => label_Finalize + use nuopc_shr_methods, only : ChkErr, set_component_logging, & + get_component_instance, state_setscalar, & + alarmInit + use shr_file_mod, only: shr_file_getUnit, shr_file_getLogUnit, & + shr_file_setLogUnit + use shr_cal_mod, only : shr_cal_ymd2date + use mod_nuopc_methods, only: fldlist_type, tlast_coupled, fco2_requested, & + fdms_requested, fbrf_requested, & + blom_logwrite, blom_getgindex, blom_checkmesh, & + blom_setareacor, blom_getglobdim, & + blom_getprecipfact, blom_accflds, & + blom_importflds, blom_exportflds + use mod_xc, only: mpicom_external, lp, nfu + use mod_cesm, only: runid_cesm, runtyp_cesm, ocn_cpl_dt_cesm + use mod_config, only: inst_index, inst_name, inst_suffix + use mod_time, only: blom_time + + implicit none + + private + + integer, parameter :: cslen = 80 ! Short character string length. + integer, parameter :: cllen = 265 ! Long character string length. + character(len=*), parameter :: modname = '(ocn_comp_nuopc)' + character(len=*), parameter :: u_FILE_u = & + __FILE__ + + integer, parameter :: fldsMax = 100 + integer :: fldsToOcn_num = 0 + integer :: fldsFrOcn_num = 0 + type(fldlist_type) :: fldsToOcn(fldsMax) + type(fldlist_type) :: fldsFrOcn(fldsMax) + + character(len=cllen) :: flds_scalar_name = '' + integer :: flds_scalar_num = 0 + integer :: flds_scalar_index_nx = 0 + integer :: flds_scalar_index_ny = 0 + integer :: flds_scalar_index_precip_factor = 0 + + logical :: ldriver_has_atm_co2_diag, ldriver_has_atm_co2_prog, & + ocn2glc_coupling + + integer :: dbug = 0 + logical :: profile_memory = .false. + + public :: SetServices, SetVM + +contains + + ! --------------------------------------------------------------------------- + ! Private procedures. + ! --------------------------------------------------------------------------- + + subroutine fldlist_add(num, fldlist, stdname, & + ungridded_lbound, ungridded_ubound) + ! --------------------------------------------------------------------------- + ! Add to list of field information. + ! --------------------------------------------------------------------------- + + ! Input/output arguments. + integer , intent(inout) :: num + type(fldlist_type), intent(inout) :: fldlist(:) + character(len=*) , intent(in) :: stdname + integer, optional , intent(in) :: ungridded_lbound, ungridded_ubound + + ! Local parameters. + character(len=*), parameter :: & + subname = modname//':(fldlist_add)' + + ! Local variables. + integer :: rc + + num = num + 1 + if (num > fldsMax) then + call ESMF_LogSetError(ESMF_RC_VAL_OUTOFRANGE, & + msg=subname//": ERROR number of field exceeded fldsMax: "// & + trim(stdname), & + line=__LINE__, file=__FILE__, rcToReturn=rc) + return + endif + fldlist(num)%stdname = trim(stdname) + + if (present(ungridded_lbound) .and. present(ungridded_ubound)) then + fldlist(num)%ungridded_lbound = ungridded_lbound + fldlist(num)%ungridded_ubound = ungridded_ubound + endif + + end subroutine fldlist_add + + subroutine fldlist_realize(state, fldlist_num, fldlist, tag, mesh, rc) + ! --------------------------------------------------------------------------- + ! Realize list of import or export fields. + ! --------------------------------------------------------------------------- + + ! Input/output arguments. + type(ESMF_State) , intent(inout) :: state + integer , intent(in) :: fldlist_num + type(fldlist_type), intent(in) :: fldlist(:) + character(len=*) , intent(in) :: tag + type(ESMF_Mesh) , intent(in) :: mesh + integer , intent(inout) :: rc + + ! Local parameters. + character(len=*), parameter :: & + subname = modname//':(fldlist_realize)' + + ! Local variables. + integer :: n + type(ESMF_DistGrid) :: DistGrid + type(ESMF_Grid) :: grid + type(ESMF_Field) :: field + character(len=128) :: stdname + character(ESMF_MAXSTR) :: msg + + rc = ESMF_SUCCESS + + do n = 1, fldlist_num + + stdname = fldlist(n)%stdname + + if (NUOPC_IsConnected(state, fieldName=stdname)) then + + if (stdname == trim(flds_scalar_name)) then + + ! Create the scalar field. + call ESMF_LogWrite(subname//trim(tag)//" Field = "// & + trim(stdname)//" is connected on root pe", & + ESMF_LOGMSG_INFO) + DistGrid = ESMF_DistGridCreate(minIndex=(/1/), maxIndex=(/1/), rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + grid = ESMF_GridCreate(DistGrid, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + field = ESMF_FieldCreate(name=trim(flds_scalar_name), & + grid=grid, & + typekind=ESMF_TYPEKIND_R8, & + ungriddedLBound=(/1/), & + ungriddedUBound=(/flds_scalar_num/), & + gridToFieldMap=(/2/), rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + + else + + ! Create the field + if (fldlist(n)%ungridded_lbound > 0 .and. & + fldlist(n)%ungridded_ubound > 0) then + field = ESMF_FieldCreate(mesh, ESMF_TYPEKIND_R8, & + name=stdname, meshloc=ESMF_MESHLOC_ELEMENT, & + ungriddedLbound=(/fldlist(n)%ungridded_lbound/), & + ungriddedUbound=(/fldlist(n)%ungridded_ubound/), & + gridToFieldMap=(/2/), rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + write(msg,'(a,i4,2x,i4)') & + subname//trim(tag)//" Field = "//trim(stdname)// & + " is connected using mesh with lbound, ubound = ", & + fldlist(n)%ungridded_lbound, fldlist(n)%ungridded_ubound + call ESMF_LogWrite(msg, ESMF_LOGMSG_INFO) + else + field = ESMF_FieldCreate(mesh, ESMF_TYPEKIND_R8, & + name=stdname, & + meshloc=ESMF_MESHLOC_ELEMENT, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + write(msg,'(a)') & + subname//trim(tag)//" Field = "//trim(stdname)// & + " is connected using mesh without ungridded dimension" + call ESMF_LogWrite(msg, ESMF_LOGMSG_INFO) + endif + + endif + + ! Realize connected field. + call NUOPC_Realize(state, field=field, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + + else + + if (stdname /= trim(flds_scalar_name)) then + + call ESMF_LogWrite(subname//trim(tag)//" Field = "// & + trim(stdname)// " is not connected", & + ESMF_LOGMSG_INFO) + + ! Remove a not connected field from state. + call ESMF_StateRemove(state, (/stdname/), rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + + endif + + endif + + enddo + + end subroutine fldlist_realize + + subroutine ocn_import(importState, rc) + ! --------------------------------------------------------------------------- + ! Import data from the mediator to ocean. + ! --------------------------------------------------------------------------- + + ! Input/output arguments. + type(ESMF_State) :: importState + integer, intent(out) :: rc + + ! Local parameters. + character(len=*), parameter :: & + subname = modname//':(import)' + + ! Local variables. + type(ESMF_StateItem_Flag) :: itemType + type(ESMF_Field) :: field + integer :: n + + rc = ESMF_SUCCESS + + ! Get data pointers for the fields to be imported. + do n = 1, fldsToOcn_num + if (fldsToOcn(n)%stdname == trim(flds_scalar_name)) cycle + call ESMF_StateGet(importState, trim(fldsToOcn(n)%stdname), & + itemType, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + if (itemType == ESMF_STATEITEM_NOTFOUND) then + fldsToOcn(n)%dataptr => null() + else + call ESMF_StateGet(importState, trim(fldsToOcn(n)%stdname), & + field=field, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + call ESMF_FieldGet(field, farrayPtr=fldsToOcn(n)%dataptr, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + endif + enddo + + ! Import fields from mediator to BLOM arrays. + call blom_importflds(fldsToOcn_num, fldsToOcn) + + end subroutine ocn_import + + subroutine ocn_export(exportState, rc) + ! --------------------------------------------------------------------------- + ! Export data from ocean to the mediator. + ! --------------------------------------------------------------------------- + + ! Input/output arguments. + type(ESMF_State) :: exportState + integer, intent(out) :: rc + + ! Local parameters. + character(len=*), parameter :: & + subname = modname//':(export)' + + ! Local variables. + type(ESMF_StateItem_Flag) :: itemType + type(ESMF_Field) :: field + real(ESMF_KIND_R8) :: precip_fact + integer :: n + logical :: precip_fact_provided + + rc = ESMF_SUCCESS + + ! Get data pointers for the fields to be exported. + do n = 1, fldsFrOcn_num + if (fldsFrOcn(n)%stdname == trim(flds_scalar_name)) cycle + call ESMF_StateGet(exportState, trim(fldsFrOcn(n)%stdname), & + itemType, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + if (itemType == ESMF_STATEITEM_NOTFOUND) then + fldsFrOcn(n)%dataptr => null() + else + call ESMF_StateGet(exportState, trim(fldsFrOcn(n)%stdname), & + field=field, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + call ESMF_FieldGet(field, farrayPtr=fldsFrOcn(n)%dataptr, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + endif + enddo + + ! Export from BLOM arrays to mediator fields. + call blom_exportflds(fldsFrOcn_num, fldsFrOcn) + + ! Provide precipitation factor. + call blom_getprecipfact(precip_fact_provided, precip_fact) + if (precip_fact_provided) then + call state_setscalar(precip_fact, & + flds_scalar_index_precip_factor, exportState, & + flds_scalar_name, flds_scalar_num, rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + else + call state_setscalar(1._ESMF_KIND_R8, & + flds_scalar_index_precip_factor, exportState, & + flds_scalar_name, flds_scalar_num, rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + endif + + end subroutine ocn_export + + subroutine InitializeP0(gcomp, importState, exportState, clock, rc) + ! --------------------------------------------------------------------------- + ! Set which version of the Initialize Phase Definition (IPD) to use. + ! --------------------------------------------------------------------------- + + ! Input/output arguments. + type(ESMF_GridComp) :: gcomp + type(ESMF_State) :: importState, exportState + type(ESMF_Clock) :: clock + integer, intent(out) :: rc + + ! Local parameters. + character(len=*), parameter :: & + subname = modname//':(InitializeP0)' + + ! Local variables. + logical :: isPresent, isSet + character(len=cslen) :: cvalue + + ! Switch to IPDv01 by filtering all other PhaseMap entries + call NUOPC_CompFilterPhaseMap(gcomp, ESMF_METHOD_INITIALIZE, & + acceptStringList=(/"IPDv01p"/), rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + + profile_memory = .false. + call NUOPC_CompAttributeGet(gcomp, name="ProfileMemory", value=cvalue, & + isPresent=isPresent, isSet=isSet, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + if (isPresent .and. isSet) profile_memory = (trim(cvalue) == "true") + write(cvalue,*) profile_memory + call ESMF_LogWrite(subname//': ProfileMemory = '//trim(cvalue), & + ESMF_LOGMSG_INFO) + + end subroutine InitializeP0 + + subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) + ! --------------------------------------------------------------------------- + ! Called by NUOPC to advertise import and export fields. "Advertise" simply + ! means that the standard names of all import and export fields are supplied. + ! The NUOPC layer uses these to match fields between components in the + ! coupled system. + ! --------------------------------------------------------------------------- + + ! Input/output arguments. + type(ESMF_GridComp) :: gcomp + type(ESMF_State) :: importState, exportState + type(ESMF_Clock) :: clock + integer, intent(out) :: rc + + ! Local parameters. + character(len=*), parameter :: & + subname = modname//':(InitializeAdvertise)' + + ! local variables + type(ESMF_VM) :: vm + type(ESMF_TimeInterval) :: timeStep + integer :: localPet, nthrds, shrlogunit, n + character(len=cslen) :: starttype, stdname, cvalue, cname + character(len=cllen) :: msg + logical :: isPresent, isSet, flds_co2a, flds_co2b, flds_co2c + + ! Get debug flag. + call NUOPC_CompAttributeGet(gcomp, name='dbug_flag', value=cvalue, & + isPresent=isPresent, isSet=isSet, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + if (isPresent .and. isSet) read(cvalue,*) dbug + write(cvalue,*) dbug + call ESMF_LogWrite(subname//': dbug = '//trim(cvalue), ESMF_LOGMSG_INFO) + + ! Get local MPI communicator and Persistent Execution Thread (PET). + call ESMF_GridCompGet(gcomp, vm=vm, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + call ESMF_VMGet(vm, mpiCommunicator=mpicom_external, localPet=localPet, & + rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + + ! OpenMP threads + call ESMF_VMGet(vm, pet=localPet, peCount=nthrds, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + if (nthrds == 1) then + call NUOPC_CompAttributeGet(gcomp, "nthreads", value=cvalue, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + read(cvalue,*) nthrds + endif +!$ call omp_set_num_threads(nthrds) + + ! Reset shr logging to components log file. + call set_component_logging(gcomp, localPet==0, lp, shrlogunit, rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + + ! Get generic file unit for master task. + if (localPet == 0) then + nfu = shr_file_getUnit() + else + nfu = -1 + endif + + ! Get case name. + call NUOPC_CompAttributeGet(gcomp, name='case_name', value=cvalue, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + read(cvalue,*) runid_cesm + + ! Get start type. + call NUOPC_CompAttributeGet(gcomp, name='start_type', value=cvalue, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + read(cvalue,*) starttype + if (trim(starttype) == trim('startup')) then + runtyp_cesm = "initial" + else if (trim(starttype) == trim('continue') ) then + runtyp_cesm = "continue" + else if (trim(starttype) == trim('branch')) then + runtyp_cesm = "continue" + else + call ESMF_LogSetError(ESMF_RC_ARG_BAD, & + msg=subname//": unknown starttype - "//trim(starttype), & + line=__LINE__, file=u_FILE_u, rcToReturn=rc) + return + endif + + ! Get multiple instance data. + call get_component_instance(gcomp, inst_suffix, inst_index, rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + inst_name = "OCN" + + ! Get coupling time interval. + call ESMF_ClockGet(clock, timeStep=timeStep, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + call ESMF_TimeIntervalGet(timeStep, s=ocn_cpl_dt_cesm, rc=rc ) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + + ! ------------------------------------------------------------------------ + ! Initialize BLOM. + ! ------------------------------------------------------------------------ + + call blom_init + + ! ------------------------------------------------------------------------ + ! Get ScalarField attributes. + ! ------------------------------------------------------------------------ + + call NUOPC_CompAttributeGet(gcomp, name="ScalarFieldName", value=cvalue, & + isPresent=isPresent, isSet=isSet, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + if (isPresent .and. isSet) then + flds_scalar_name = trim(cvalue) + call ESMF_LogWrite(subname//': flds_scalar_name = '//trim(cvalue), & + ESMF_LOGMSG_INFO) + else + call ESMF_LogSetError(ESMF_RC_NOT_SET, & + msg=subname//": ScalarFieldName is not set", & + line=__LINE__, file=__FILE__, rcToReturn=rc) + return + endif + + call NUOPC_CompAttributeGet(gcomp, name="ScalarFieldCount", & + value=cvalue, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + read(cvalue,*) flds_scalar_num + write(cvalue,*) flds_scalar_num + call ESMF_LogWrite(subname//': flds_scalar_num = '//trim(cvalue), & + ESMF_LOGMSG_INFO) + + call NUOPC_CompAttributeGet(gcomp, name="ScalarFieldIdxGridNX", & + value=cvalue, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + read(cvalue,*) flds_scalar_index_nx + write(cvalue,*) flds_scalar_index_nx + call ESMF_LogWrite(subname//': flds_scalar_index_nx = '//trim(cvalue), & + ESMF_LOGMSG_INFO) + + call NUOPC_CompAttributeGet(gcomp, name="ScalarFieldIdxGridNY", & + value=cvalue, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + read(cvalue,*) flds_scalar_index_ny + write(cvalue,*) flds_scalar_index_ny + call ESMF_LogWrite(subname//': flds_scalar_index_ny = '//trim(cvalue), & + ESMF_LOGMSG_INFO) + + call NUOPC_CompAttributeGet(gcomp, name="ScalarFieldIdxPrecipFactor", & + value=cvalue, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + read(cvalue,*) flds_scalar_index_precip_factor + if ( .not. flds_scalar_index_precip_factor > 0 ) then + call ESMF_LogSetError(ESMF_RC_VAL_OUTOFRANGE, & + msg=subname//": flds_scalar_index_precip_factor must be > 0", & + line=__LINE__, file=u_FILE_u, rcToReturn=rc) + return + else + write(cvalue,*) flds_scalar_index_precip_factor + call ESMF_LogWrite(subname//': flds_scalar_index_precip_factor = '// & + trim(cvalue), ESMF_LOGMSG_INFO) + endif + + ! ------------------------------------------------------------------------ + ! Advertise import fields. + ! ------------------------------------------------------------------------ + + call fldlist_add(fldsToOcn_num, fldsToOcn, trim(flds_scalar_name)) + + ! From ice: + call fldlist_add(fldsToOcn_num, fldsToOcn, 'Si_ifrac') + call fldlist_add(fldsToOcn_num, fldsToOcn, 'Fioi_melth') + call fldlist_add(fldsToOcn_num, fldsToOcn, 'Fioi_meltw') + call fldlist_add(fldsToOcn_num, fldsToOcn, 'Fioi_salt') + call fldlist_add(fldsToOcn_num, fldsToOcn, 'Fioi_bcpho') + call fldlist_add(fldsToOcn_num, fldsToOcn, 'Fioi_bcphi') + call fldlist_add(fldsToOcn_num, fldsToOcn, 'Fioi_flxdst') + + ! From river: + call fldlist_add(fldsToOcn_num, fldsToOcn, 'Foxx_rofl') + call fldlist_add(fldsToOcn_num, fldsToOcn, 'Foxx_rofi') + + ! From mediator: + call fldlist_add(fldsToOcn_num, fldsToOcn, 'So_duu10n') + call fldlist_add(fldsToOcn_num, fldsToOcn, 'Foxx_tauy') + call fldlist_add(fldsToOcn_num, fldsToOcn, 'Foxx_taux') + call fldlist_add(fldsToOcn_num, fldsToOcn, 'Foxx_lat') + call fldlist_add(fldsToOcn_num, fldsToOcn, 'Foxx_sen') + call fldlist_add(fldsToOcn_num, fldsToOcn, 'Foxx_lwup') + call fldlist_add(fldsToOcn_num, fldsToOcn, 'Foxx_evap') + call fldlist_add(fldsToOcn_num, fldsToOcn, 'Foxx_swnet') + + ! From wave: + call fldlist_add(fldsToOcn_num, fldsToOcn, 'Sw_lamult') + call fldlist_add(fldsToOcn_num, fldsToOcn, 'Sw_ustokes') + call fldlist_add(fldsToOcn_num, fldsToOcn, 'Sw_vstokes') + call fldlist_add(fldsToOcn_num, fldsToOcn, 'Sw_hstokes') + + ! From atmosphere: + call fldlist_add(fldsToOcn_num, fldsToOcn, 'Sa_pslv') + call fldlist_add(fldsToOcn_num, fldsToOcn, 'Faxa_lwdn') + call fldlist_add(fldsToOcn_num, fldsToOcn, 'Faxa_snow') + call fldlist_add(fldsToOcn_num, fldsToOcn, 'Faxa_rain') + + ! From atm co2 fields: + + call NUOPC_CompAttributeGet(gcomp, name='flds_co2a', value=cvalue, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + read(cvalue,*) flds_co2a + call blom_logwrite(subname//': flds_co2a = '//trim(cvalue)) + + call NUOPC_CompAttributeGet(gcomp, name='flds_co2b', value=cvalue, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + read(cvalue,*) flds_co2b + call blom_logwrite(subname//': flds_co2b = '//trim(cvalue)) + + call NUOPC_CompAttributeGet(gcomp, name='flds_co2c', value=cvalue, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + read(cvalue,*) flds_co2c + call blom_logwrite(subname//': flds_co2c = '//trim(cvalue)) + + if (flds_co2a .or. flds_co2c) then + call fldlist_add(fldsToOcn_num, fldsToOcn, 'Sa_co2diag') + call fldlist_add(fldsToOcn_num, fldsToOcn, 'Sa_co2prog') + ldriver_has_atm_co2_prog = .true. + ldriver_has_atm_co2_diag = .true. + else + ldriver_has_atm_co2_prog = .false. + ldriver_has_atm_co2_diag = .false. + endif + + !TODO Determine if will get nitrogen deposition from atm + + do n = 1,fldsToOcn_num + call NUOPC_Advertise(importState, standardName=fldsToOcn(n)%stdname, & + TransferOfferGeomObject='will provide', rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + enddo + + ! ------------------------------------------------------------------------ + ! Advertise export fields. + ! ------------------------------------------------------------------------ + + ! Determine if ocn is sending temperature and salinity data to glc + call NUOPC_CompAttributeGet(gcomp, name="ocn2glc_coupling", value=cvalue, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + read(cvalue,*) ocn2glc_coupling + write(msg,'(a,l1)') subname//': ocn2glc coupling is ', ocn2glc_coupling + call blom_logwrite(msg) + + ! Determine number of ocean levels and ocean level indices + if (ocn2glc_coupling) then + call ESMF_LogSetError(ESMF_RC_NOT_IMPL, & + msg=subname//": ocn2glc coupling not implemented", & + line=__LINE__, file=u_FILE_u, rcToReturn=rc) + return + endif + + call fldlist_add(fldsFrOcn_num, fldsFrOcn, trim(flds_scalar_name)) + call fldlist_add(fldsFrOcn_num, fldsFrOcn, 'So_omask') + call fldlist_add(fldsFrOcn_num, fldsFrOcn, 'So_t') + call fldlist_add(fldsFrOcn_num, fldsFrOcn, 'So_u') + call fldlist_add(fldsFrOcn_num, fldsFrOcn, 'So_v') + call fldlist_add(fldsFrOcn_num, fldsFrOcn, 'So_s') + call fldlist_add(fldsFrOcn_num, fldsFrOcn, 'So_dhdx') + call fldlist_add(fldsFrOcn_num, fldsFrOcn, 'So_dhdy') + call fldlist_add(fldsFrOcn_num, fldsFrOcn, 'So_bldepth') + call fldlist_add(fldsFrOcn_num, fldsFrOcn, 'Fioo_q') + call fldlist_add(fldsFrOcn_num, fldsFrOcn, 'Faoo_fco2_ocn') + + do n = 1,fldsFrOcn_num + call NUOPC_Advertise(exportState, standardName=fldsFrOcn(n)%stdname, & + TransferOfferGeomObject='will provide', rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + enddo + + if (dbug > 5) call ESMF_LogWrite(subname//': done', ESMF_LOGMSG_INFO) + + end subroutine InitializeAdvertise + + subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) + ! --------------------------------------------------------------------------- + ! Called by NUOPC to realize import and export fields. "Realizing" a field + ! means that its grid has been defined and an ESMF_Field object has been + ! created and put into the import or export State. + ! --------------------------------------------------------------------------- + + ! Input/output arguments. + type(ESMF_GridComp) :: gcomp + type(ESMF_State) :: importState, exportState + type(ESMF_Clock) :: clock + integer, intent(out) :: rc + + ! Local parameters. + character(len=*), parameter :: & + subname = modname//':(InitializeRealize)' + + ! Local variables. + type(ESMF_DistGrid) :: DistGrid + type(ESMF_Mesh) :: EMesh + type(ESMF_Array) :: elemMaskArray + type(ESMF_Field) :: field + real(ESMF_KIND_R8), dimension(:), pointer :: & + ownedElemCoords, lonMesh, latMesh, areaMesh + integer(ESMF_KIND_I4), dimension(:), pointer :: maskMesh(:) + integer, allocatable, dimension(:) :: gindex + integer :: n, spatialDim, numOwnedElements, nx_global, ny_global + character(len=cslen) :: cvalue + + if (dbug > 5) call ESMF_LogWrite(subname//': called', ESMF_LOGMSG_INFO) + + ! Get the BLOM global index space for the computational domain. + call blom_getgindex(gindex) + + ! Create DistGrid from global index array. + DistGrid = ESMF_DistGridCreate(arbSeqIndexList=gindex, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + + ! Create the mesh. + call NUOPC_CompAttributeGet(gcomp, name='mesh_ocn', value=cvalue, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + EMesh = ESMF_MeshCreate(filename=trim(cvalue), & + fileformat=ESMF_FILEFORMAT_ESMFMESH, & + elementDistgrid=DistGrid, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + call blom_logwrite(subname//': mesh file for blom domain is '// & + trim(cvalue)) + + ! ------------------------------------------------------------------------ + ! Check for consistency of lat, lon and mask between mesh and model grid. + ! ------------------------------------------------------------------------ + + call ESMF_MeshGet(Emesh, spatialDim=spatialDim, & + numOwnedElements=numOwnedElements, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + + allocate(ownedElemCoords(spatialDim*numOwnedElements), & + lonMesh(numOwnedElements), latMesh(numOwnedElements), & + maskMesh(numOwnedElements)) + + call ESMF_MeshGet(Emesh, ownedElemCoords=ownedElemCoords, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + do n = 1, numOwnedElements + lonMesh(n) = ownedElemCoords(2*n-1) + latMesh(n) = ownedElemCoords(2*n) + enddo + + elemMaskArray = ESMF_ArrayCreate(Distgrid, maskMesh, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + call ESMF_MeshGet(Emesh, elemMaskArray=elemMaskArray, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + + call blom_checkmesh(lonMesh, latMesh, maskMesh) + + ! ------------------------------------------------------------------------ + ! Determine flux area correction factors. + ! ------------------------------------------------------------------------ + + field = ESMF_FieldCreate(Emesh, ESMF_TYPEKIND_R8, & + meshloc=ESMF_MESHLOC_ELEMENT, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + call ESMF_FieldRegridGetArea(field, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + call ESMF_FieldGet(field, farrayPtr=areaMesh, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + + call blom_setareacor(areaMesh, maskMesh) + + ! ------------------------------------------------------------------------ + ! Realize the actively coupled fields. + ! ------------------------------------------------------------------------ + + call fldlist_realize(state=importState, & + fldlist_num=fldsToOcn_num, fldlist=fldsToOcn, & + tag=subname//':BLOM_Import', mesh=EMesh, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + + call fldlist_realize(state=exportState, & + fldlist_num=fldsFrOcn_num, fldlist=fldsFrOcn, & + tag=subname//':BLOM_Export', mesh=EMesh, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + + ! ------------------------------------------------------------------------ + ! Set scalar data in export state. + ! ------------------------------------------------------------------------ + + call blom_getglobdim(nx_global, ny_global) + + call state_setscalar(real(nx_global, ESMF_KIND_R8), & + flds_scalar_index_nx, exportState, & + flds_scalar_name, flds_scalar_num, rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + + call state_setscalar(real(ny_global, ESMF_KIND_R8), & + flds_scalar_index_ny, exportState, & + flds_scalar_name, flds_scalar_num, rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + + if (dbug > 5) call ESMF_LogWrite(subname//': done', ESMF_LOGMSG_INFO) + + end subroutine InitializeRealize + + subroutine DataInitialize(gcomp, rc) + ! --------------------------------------------------------------------------- + ! Called by NUOPC to do the initial data export from ocean to mediator. + ! --------------------------------------------------------------------------- + + ! Input/output arguments. + type(ESMF_GridComp) :: gcomp + integer, intent(out) :: rc + + ! Local parameters. + character(len=*), parameter :: & + subname = modname//':(DataInitialize)' + + ! Local variables. + type(ESMF_State) :: exportState + type(ESMF_StateItem_flag) :: itemType + + if (dbug > 5) call ESMF_LogWrite(subname//': called', ESMF_LOGMSG_INFO) + + ! ------------------------------------------------------------------------ + ! Query the Component for its exportState. + ! ------------------------------------------------------------------------ + + call ESMF_GridCompGet(gcomp, exportState=exportState, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + + ! ------------------------------------------------------------------------ + ! Check whether non-standard export fields are present. + ! ------------------------------------------------------------------------ + + call ESMF_StateGet(exportState, 'Faoo_fco2_ocn', itemType) + fco2_requested = (itemType /= ESMF_STATEITEM_NOTFOUND) + + call ESMF_StateGet(exportState, 'Faoo_fdms_ocn', itemType) + fdms_requested = (itemType /= ESMF_STATEITEM_NOTFOUND) + + call ESMF_StateGet(exportState, 'Faoo_fbrf_ocn', itemType) + fbrf_requested = (itemType /= ESMF_STATEITEM_NOTFOUND) + + ! ------------------------------------------------------------------------ + ! TODO + ! ------------------------------------------------------------------------ + + tlast_coupled = 0._ESMF_KIND_R8 + call blom_accflds + call ocn_export(exportState, rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + + ! ------------------------------------------------------------------------ + ! Check whether all Fields in the exportState are "Updated" TODO + ! ------------------------------------------------------------------------ + + if (NUOPC_IsUpdated(exportState)) then + call NUOPC_CompAttributeSet(gcomp, name="InitializeDataComplete", & + value="true", rc=rc) + call ESMF_LogWrite("BLOM - Initialize-Data-Dependency SATISFIED!!!", & + ESMF_LOGMSG_INFO) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + else + call ESMF_LogWrite("BLOM - Initialize-Data-Dependency NOT SATISFIED!!!", & + ESMF_LOGMSG_INFO) + endif + + if (dbug > 5) call ESMF_LogWrite(subname//': done', ESMF_LOGMSG_INFO) + + end subroutine DataInitialize + + subroutine ModelAdvance(gcomp, rc) + ! --------------------------------------------------------------------------- + ! Called by NUOPC to advance the model a single timestep. + ! --------------------------------------------------------------------------- + + ! Input/output arguments. + type(ESMF_GridComp) :: gcomp + integer, intent(out) :: rc + + ! Local parameters. + character(len=*), parameter :: & + subname = modname//':(ModelAdvance)' + + ! Local variables. + type(ESMF_State) :: importState, exportState + type(ESMF_Clock) :: clock + type(ESMF_Time) :: currTime + type(ESMF_Alarm) :: restart_alarm + integer :: shrlogunit, yr_sync, mon_sync, day_sync, tod_sync, ymd_sync, & + ymd, tod + logical :: first_call = .true., restart_alarm_on + character(len=cllen) :: msg + + if (dbug > 5) call ESMF_LogWrite(subname//': called', ESMF_LOGMSG_INFO) + + rc = ESMF_SUCCESS + + ! ------------------------------------------------------------------------ + ! Reset shr logging to components log file. + ! ------------------------------------------------------------------------ + + call shr_file_getLogUnit(shrlogunit) + call shr_file_setLogUnit(lp) + + ! ------------------------------------------------------------------------ + ! Skip first coupling interval for an initial run. + ! ------------------------------------------------------------------------ + + if (first_call) then + first_call = .false. + if (runtyp_cesm == 'initial') then + call blom_logwrite('Returning at first coupling interval') + return + endif + endif + + ! ------------------------------------------------------------------------ + ! Query the Component for its clock, importState and exportState. + ! ------------------------------------------------------------------------ + + call NUOPC_ModelGet(gcomp, modelClock=clock, importState=importState, & + exportState=exportState, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + + ! ------------------------------------------------------------------------ + ! Check that internal clock is in sync with master clock. + ! ------------------------------------------------------------------------ + + if (ChkErr(rc, __LINE__, u_FILE_u)) return + call ESMF_ClockGet( clock, currTime=currTime, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + call ESMF_TimeGet(currTime, yy=yr_sync, mm=mon_sync, dd=day_sync, & + s=tod_sync, rc=rc ) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + call shr_cal_ymd2date(yr_sync, mon_sync, day_sync, ymd_sync) + + call blom_time(ymd, tod) + if (ymd /= ymd_sync .or. tod /= tod_sync) then + write(msg,*) ' blom ymd=',ymd ,' blom tod= ',tod + call blom_logwrite(msg) + write(msg,*) ' sync ymd=',ymd_sync,' sync tod= ',tod_sync + call blom_logwrite(msg) + call ESMF_LogSetError(ESMF_FAILURE, & + msg=subname//": Internal blom clock not in sync with Sync Clock", & + line=__LINE__, file=u_FILE_u, rcToReturn=rc) + return + endif + + ! ------------------------------------------------------------------------ + ! Advance the model in time over a coupling interval. + ! ------------------------------------------------------------------------ + + blom_loop: do + + if (nint(tlast_coupled) == 0) then + ! Obtain import state from driver + call ocn_import(importState, rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + endif + + ! Advance the model a time step. + call blom_step + + ! Accumulate BLOM export fields. + call blom_accflds + + if (nint(ocn_cpl_dt_cesm-tlast_coupled) == 0) then + ! Return export state to driver and exit integration loop + call ocn_export(exportState, rc) + exit blom_loop + endif + +! if (mnproc == 1) then +! call shr_sys_flush(lp) +! endif + + enddo blom_loop + + ! ------------------------------------------------------------------------ + ! If restart alarm is ringing - write restart file. TODO do we need to + ! consider stop alarm? + ! ------------------------------------------------------------------------ + + call ESMF_ClockGetAlarm(clock, alarmname='restart_alarm', & + alarm=restart_alarm, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + restart_alarm_on = ESMF_AlarmIsRinging(restart_alarm, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + + if (restart_alarm_on) then + + ! Turn off the alarm + call ESMF_AlarmRingerOff(restart_alarm, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + + ! Write BLOM restart files. + call restart_wt + + endif + + ! ------------------------------------------------------------------------ + ! Reset shr logging to original values. + ! ------------------------------------------------------------------------ + + call shr_file_setLogUnit(shrlogunit) + + if (dbug > 5) call ESMF_LogWrite(subname//': done', ESMF_LOGMSG_INFO) + + end subroutine ModelAdvance + + subroutine ModelSetRunClock(gcomp, rc) + ! --------------------------------------------------------------------------- + ! Synchronize driver and model clock and set restart and stop alarms. + ! --------------------------------------------------------------------------- + + ! Input/output arguments. + type(ESMF_GridComp) :: gcomp + integer, intent(out) :: rc + + ! Local parameters. + character(len=*), parameter :: & + subname = modname//':(ModelSetRunClock)' + + ! Local variables. + type(ESMF_Clock) :: mclock, dclock + type(ESMF_Time) :: mcurrtime, dcurrtime, mstoptime + type(ESMF_TimeInterval) :: mtimestep, dtimestep + type(ESMF_ALARM) :: restart_alarm, stop_alarm + integer :: restart_n, restart_ymd, stop_n, stop_ymd, alarmcount + character(len=256) :: cvalue, restart_option, stop_option + character(len=128) :: name + + if (dbug > 5) call ESMF_LogWrite(subname//': called', ESMF_LOGMSG_INFO) + + ! Query the component for its clocks. + + call NUOPC_ModelGet(gcomp, driverClock=dclock, modelClock=mclock, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + + call ESMF_ClockGet(dclock, currTime=dcurrtime, timeStep=dtimestep, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + + call ESMF_ClockGet(mclock, currTime=mcurrtime, timeStep=mtimestep, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + + ! ------------------------------------------------------------------------ + ! Force model clock currtime and timestep to match driver and set + ! stoptime. + ! ------------------------------------------------------------------------ + + mstoptime = mcurrtime + dtimestep + call ESMF_ClockSet(mclock, currTime=dcurrtime, timeStep=dtimestep, & + stopTime=mstoptime, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + + ! ------------------------------------------------------------------------ + ! Set restart and stop alarms. + ! ------------------------------------------------------------------------ + + call ESMF_ClockGetAlarmList(mclock, alarmlistflag=ESMF_ALARMLIST_ALL, & + alarmCount=alarmCount, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + + if (alarmCount == 0) then + + call ESMF_GridCompGet(gcomp, name=name, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + call ESMF_LogWrite(subname//': setting alarms for '//trim(name), & + ESMF_LOGMSG_INFO) + + + ! Restart alarm. + + call NUOPC_CompAttributeGet(gcomp, name="restart_option", & + value=restart_option, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + + call NUOPC_CompAttributeGet(gcomp, name="restart_n", & + value=cvalue, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + read(cvalue,*) restart_n + + call NUOPC_CompAttributeGet(gcomp, name="restart_ymd", & + value=cvalue, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + read(cvalue,*) restart_ymd + + call alarmInit(mclock, restart_alarm, restart_option, & + opt_n=restart_n, opt_ymd=restart_ymd, & + RefTime=mcurrTime, alarmname='restart_alarm', rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + + call ESMF_AlarmSet(restart_alarm, clock=mclock, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + + ! Stop alarm. + + call NUOPC_CompAttributeGet(gcomp, name="stop_option", & + value=stop_option, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + + call NUOPC_CompAttributeGet(gcomp, name="stop_n", & + value=cvalue, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + read(cvalue,*) stop_n + + call NUOPC_CompAttributeGet(gcomp, name="stop_ymd", & + value=cvalue, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + read(cvalue,*) stop_ymd + + call alarmInit(mclock, stop_alarm, stop_option, & + opt_n=stop_n, opt_ymd=stop_ymd, RefTime=mcurrTime, & + alarmname='stop_alarm', rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + + call ESMF_AlarmSet(stop_alarm, clock=mclock, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + + endif + + ! ------------------------------------------------------------------------ + ! Advance model clock to trigger alarms then reset model clock back to + ! currtime. + ! ------------------------------------------------------------------------ + + call ESMF_ClockAdvance(mclock, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + + call ESMF_ClockSet(mclock, currTime=dcurrtime, timeStep=dtimestep, & + stopTime=mstoptime, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + + if (dbug > 5) call ESMF_LogWrite(subname//': done', ESMF_LOGMSG_INFO) + + end subroutine ModelSetRunClock + + subroutine ModelFinalize(gcomp, rc) + ! --------------------------------------------------------------------------- + ! Called by NUOPC to finalize the model. + ! --------------------------------------------------------------------------- + + ! Input/output arguments. + type(ESMF_GridComp) :: gcomp + integer, intent(out) :: rc + + ! Local parameters. + character(len=*), parameter :: & + subname = modname//':(ModelFinalize)' + + if (dbug > 5) call ESMF_LogWrite(subname//': called', ESMF_LOGMSG_INFO) + + rc = ESMF_SUCCESS + + if (dbug > 5) call ESMF_LogWrite(subname//': done', ESMF_LOGMSG_INFO) + + end subroutine ModelFinalize + + ! --------------------------------------------------------------------------- + ! Public procedures. + ! --------------------------------------------------------------------------- + + subroutine SetServices(gcomp, rc) + ! --------------------------------------------------------------------------- + ! NUOPC SetService method is the only public entry point. SetServices + ! registers all of the user-provided subroutines in the module with the NUOPC + ! layer. + ! --------------------------------------------------------------------------- + + ! Input/output arguments. + type(ESMF_GridComp) :: gcomp ! ESMF_GridComp object. + integer, intent(out) :: rc ! Return code. + + ! Local parameters. + character(len=*), parameter :: & + subname = modname//':(SetServices)' + + if (dbug > 5) call ESMF_LogWrite(subname//': called', ESMF_LOGMSG_INFO) + + ! The NUOPC gcomp component will register the generic methods. + call NUOPC_CompDerive(gcomp, model_routine_SS, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + + ! Switching to IPD versions. + call ESMF_GridCompSetEntryPoint(gcomp, ESMF_METHOD_INITIALIZE, & + userRoutine=InitializeP0, phase=0, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + + ! Set entry point for methods that require specific implementation. + call NUOPC_CompSetEntryPoint(gcomp, ESMF_METHOD_INITIALIZE, & + phaseLabelList=(/"IPDv01p1"/), & + userRoutine=InitializeAdvertise, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + + call NUOPC_CompSetEntryPoint(gcomp, ESMF_METHOD_INITIALIZE, & + phaseLabelList=(/"IPDv01p3"/), & + userRoutine=InitializeRealize, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + + ! Attach specializing method(s). + call NUOPC_CompSpecialize(gcomp, specLabel=model_label_DataInitialize, & + specRoutine=DataInitialize, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + + call NUOPC_CompSpecialize(gcomp, specLabel=model_label_Advance, & + specRoutine=ModelAdvance, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + + call ESMF_MethodRemove(gcomp, label=model_label_SetRunClock, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + call NUOPC_CompSpecialize(gcomp, specLabel=model_label_SetRunClock, & + specRoutine=ModelSetRunClock, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + +! TODO Method used by POP, not by MOM6 and CICE. +! call ESMF_MethodRemove(gcomp, label=model_label_CheckImport, rc=rc) +! if (ChkErr(rc, __LINE__, u_FILE_u)) return +! call NUOPC_CompSpecialize(gcomp, specLabel=model_label_CheckImport, & +! specRoutine=ModelCheckImport, rc=rc) +! if (ChkErr(rc, __LINE__, u_FILE_u)) return + + call NUOPC_CompSpecialize(gcomp, specLabel=model_label_Finalize, & + specRoutine=ModelFinalize, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + + if (dbug > 5) call ESMF_LogWrite(subname//': done', ESMF_LOGMSG_INFO) + + end subroutine SetServices + +end module ocn_comp_nuopc diff --git a/drivers/nuopc/setlogunit.F90 b/drivers/nuopc/setlogunit.F90 new file mode 100644 index 00000000..fa73bd12 --- /dev/null +++ b/drivers/nuopc/setlogunit.F90 @@ -0,0 +1,25 @@ +! ------------------------------------------------------------------------------ +! Copyright (C) 2022 Mats Bentsen +! +! 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 . +! ------------------------------------------------------------------------------ + +subroutine setlogunit +! ------------------------------------------------------------------------------ +! Empty routine since log unit is set in routine InitializeAdvertise of the +! module ocn_comp_nuopc. +! ------------------------------------------------------------------------------ +end subroutine setlogunit From f60e840d1275dc23031dd9a1d672a0c4b661e302 Mon Sep 17 00:00:00 2001 From: jmaerz <92309038+jmaerz@users.noreply.github.com> Date: Thu, 15 Sep 2022 16:28:54 +0200 Subject: [PATCH 160/366] Lon-lat variable sediment porosity (#189) Introducing a static 3D sediment porosity field that can be optionally read in with effects on molecular pore water diffusion and shifting. --- cime_config/buildnml | 16 ++++++ hamocc/bodensed.F90 | 96 +++++++++++++++++++++++++-------- hamocc/dipowa.F90 | 23 +++----- hamocc/hamocc_init.F90 | 11 ++-- hamocc/inventory_bgc.F90 | 8 +-- hamocc/meson.build | 1 + hamocc/mo_control_bgc.F90 | 3 +- hamocc/mo_read_sedpor.F90 | 108 ++++++++++++++++++++++++++++++++++++++ hamocc/mo_sedmnt.F90 | 77 +++++++++++++++++++++++++-- hamocc/powach.F90 | 88 +++++++++++++------------------ hamocc/powadi.F90 | 12 ++--- hamocc/sedshi.F90 | 12 ++--- 12 files changed, 342 insertions(+), 113 deletions(-) create mode 100644 hamocc/mo_read_sedpor.F90 diff --git a/cime_config/buildnml b/cime_config/buildnml index 6f3c1e30..bd3d33a3 100755 --- a/cime_config/buildnml +++ b/cime_config/buildnml @@ -237,6 +237,9 @@ set OALKSCEN = "''" set OALKFILE = "''" set WITH_DMSPH = .false. set PI_PH_FILE = "''" +set L_3DVARSEDPOR = .false. +set SEDPORFILE = "''" + # set DIAPHY defaults set GLB_FNAMETAG = "'hd','hm','hy'" @@ -706,6 +709,7 @@ if ($OCN_GRID == tnx2v1) then set SCFILE = "'$DIN_LOC_ROOT/ocn/blom/bndcon/sss_clim_core_tnx2v1_20130927.nc'" set FEDEPFILE = "'$DIN_LOC_ROOT/ocn/blom/bndcon/dustdep_mhw2006_tnx2v1_20130506.nc'" set SWACLIMFILE = "''" + set SEDPORFILE = "''" if ($BLOM_RIVER_NUTRIENTS == TRUE) then set RIVINFILE = "'$DIN_LOC_ROOT/ocn/blom/bndcon/river_nutrients_GNEWS2000_tnx2v1_20170915.nc'" else @@ -726,6 +730,7 @@ else if ($OCN_GRID == tnx1v4) then set CCFILE = "'$DIN_LOC_ROOT/ocn/blom/bndcon/chlorophyll_concentration_tnx1v4_20170608.nc'" set SCFILE = "'$DIN_LOC_ROOT/ocn/blom/bndcon/sss_clim_core_tnx1v4_20170604.nc'" set FEDEPFILE = "'$DIN_LOC_ROOT/ocn/blom/bndcon/dustdep_mhw2006_tnx1v4_20171107.nc'" + set SEDPORFILE = "''" if ($HAMOCC_VSLS == TRUE) then set SWACLIMFILE = "'$DIN_LOC_ROOT/ocn/blom/bndcon/Annual_clim_swa_tnx1v4_20210415.nc'" else @@ -752,6 +757,7 @@ else if ($OCN_GRID == tnx0.25v4) then set SCFILE = "'$DIN_LOC_ROOT/ocn/blom/bndcon/sss_clim_core_tnx0.25v4_20170623.nc'" set FEDEPFILE = "'$DIN_LOC_ROOT/ocn/blom/bndcon/dustdep_mhw2006_tnx0.25v4_20181004.nc'" set SWACLIMFILE = "''" + set SEDPORFILE = "''" if ($BLOM_RIVER_NUTRIENTS == TRUE) then set RIVINFILE = "'$DIN_LOC_ROOT/ocn/blom/bndcon/river_nutrients_GNEWS2000_tnx0.25v4_20170821.nc'" else @@ -773,6 +779,7 @@ else if ($OCN_GRID == tnx0.125v4) then set SCFILE = "'$DIN_LOC_ROOT/ocn/blom/bndcon/sss_clim_core_tnx0.125v4_20200722.nc'" set FEDEPFILE = "'$DIN_LOC_ROOT/ocn/blom/bndcon/dustdep_mhw2006_tnx0.125v4_20200722.nc'" set SWACLIMFILE = "''" + set SEDPORFILE = "''" if ($BLOM_RIVER_NUTRIENTS == TRUE) then set RIVINFILE = "'$DIN_LOC_ROOT/ocn/blom/bndcon/river_nutrients_GNEWS2000_tnx0.125v4_20170821.nc'" else @@ -1445,6 +1452,8 @@ cat >>! $RUNDIR/ocn_in$inststr << EOF ! OXY, NO3, SIL, D13C, and D14C ! WITH_DMSPH : Logical switch to activate DMS calculation as function of pH ! PI_PH_FILE : File name (incl. full path) for surface PI pH input data. +! L_3DVARSEDPOR : Logical switch to enable lon-lat-depth variable sediment porosity (as opposed to default: only depth) +! SEDPORFILE : File name (incl. full path) for sediment porosity &BGCNML ATM_CO2 = $CCSM_CO2_PPMV FEDEPFILE = $FEDEPFILE @@ -1470,6 +1479,8 @@ cat >>! $RUNDIR/ocn_in$inststr << EOF INID14C = $INID14C WITH_DMSPH = $WITH_DMSPH PI_PH_FILE = $PI_PH_FILE + L_3DVARSEDPOR = $L_3DVARSEDPOR + SEDPORFILE = $SEDPORFILE / ! IO-NAMELIST FOR DIAGNOSTIC iHAMOCC OUTPUT @@ -1871,6 +1882,11 @@ EOF if ($HAMOCC_VSLS == TRUE) then cat >> $CASEBUILD/blom.input_data_list << EOF swa_clim_file = `echo $SWACLIMFILE | tr -d '"' | tr -d "'"` +EOF + endif + if ($L_3DVARSEDPOR == TRUE) then +cat >> $CASEBUILD/blom.input_data_list << EOF +sed_porosity_file = `echo $SEDPORFILE | tr -d '"' | tr -d "'"` EOF endif endif diff --git a/hamocc/bodensed.F90 b/hamocc/bodensed.F90 index 99bc782a..74cb9335 100644 --- a/hamocc/bodensed.F90 +++ b/hamocc/bodensed.F90 @@ -17,7 +17,7 @@ ! along with BLOM. If not, see https://www.gnu.org/licenses/. -subroutine bodensed(kpie,kpje,kpke,pddpo) +subroutine bodensed(kpie,kpje,kpke,pddpo,omask,sed_por) !********************************************************************** ! !**** *BODENSED* - . @@ -44,8 +44,8 @@ subroutine bodensed(kpie,kpje,kpke,pddpo) !********************************************************************** use mo_sedmnt, only: calcwei,calfa,clafa,claydens,calcdens,opaldens,opalwei,oplfa,orgdens,orgfa,seddzi,porwat,porwah, & - & porsol,dzs,seddw,sedict,solfu,orgwei - use mo_control_bgc, only: dtbgc,io_stdo_bgc + & porsol,dzs,seddw,sedict,solfu,orgwei,zcoefsu,zcoeflo,disso_sil,silsat,disso_poc,sed_denit,disso_caco3 + use mo_control_bgc, only: dtbgc,io_stdo_bgc,l_3Dvarsedpor use mo_param1_bgc, only: ks use mod_xc, only: mnproc @@ -53,6 +53,8 @@ subroutine bodensed(kpie,kpje,kpke,pddpo) integer, intent(in) :: kpie,kpje,kpke real, intent(in) :: pddpo(kpie,kpje,kpke) + real, intent(in) :: omask(kpie,kpje) + real, intent(in) :: sed_por(kpie,kpje,ks) ! Local variables integer :: i,j,k @@ -79,33 +81,68 @@ subroutine bodensed(kpie,kpje,kpke,pddpo) write(io_stdo_bgc,*) ' ' endif - porwat(1) = 0.85 - porwat(2) = 0.83 - porwat(3) = 0.8 - porwat(4) = 0.79 - porwat(5) = 0.77 - porwat(6) = 0.75 - porwat(7) = 0.73 - porwat(8) = 0.7 - porwat(9) = 0.68 - porwat(10) = 0.66 - porwat(11) = 0.64 - porwat(12) = 0.62 + ! this initialization can be done later via reading a porosity map + if (l_3Dvarsedpor)then + ! lon-lat variable sediment porosity from input file + do k=1,ks + do j=1,kpje + do i=1,kpie + if(omask(i,j).gt. 0.5)then + porwat(i,j,k) = sed_por(i,j,k) + endif + enddo + enddo + enddo + else + porwat(:,:,1) = 0.85 + porwat(:,:,2) = 0.83 + porwat(:,:,3) = 0.8 + porwat(:,:,4) = 0.79 + porwat(:,:,5) = 0.77 + porwat(:,:,6) = 0.75 + porwat(:,:,7) = 0.73 + porwat(:,:,8) = 0.7 + porwat(:,:,9) = 0.68 + porwat(:,:,10) = 0.66 + porwat(:,:,11) = 0.64 + porwat(:,:,12) = 0.62 + endif if (mnproc == 1) then - write(io_stdo_bgc,*) 'Pore water in sediment: ',porwat + write(io_stdo_bgc,*) 'Pore water in sediment initialized' endif seddzi(1) = 500. do k = 1, ks - porsol(k) = 1. - porwat(k) - if(k >= 2) porwah(k) = 0.5 * (porwat(k) + porwat(k-1)) - if(k == 1) porwah(k) = 0.5 * (1. + porwat(1)) seddzi(k+1) = 1. / dzs(k+1) seddw(k) = 0.5 * (dzs(k) + dzs(k+1)) + do j = 1, kpje + do i = 1, kpie + porsol(i,j,k) = 1. - porwat(i,j,k) + if(k >= 2) porwah(i,j,k) = 0.5 * (porwat(i,j,k) + porwat(i,j,k-1)) + if(k == 1) porwah(i,j,k) = 0.5 * (1. + porwat(i,j,1)) + enddo + enddo enddo + + sedict = 1.e-9 * dtbgc ! Molecular diffusion coefficient + ! Dissolution rate constant of opal (disso) [1/(kmol Si(OH)4/m3)*1/sec] + ! THIS NEEDS TO BE CHANGED TO disso=3.e-8! THIS IS ONLY KEPT FOR THE MOMENT + ! FOR BACKWARDS COMPATIBILITY + !disso_sil = 3.e-8*dtbgc ! (2011-01-04) EMR + !disso_sil = 1.e-6*dtbgc ! test vom 03.03.04 half live sil ca. 20.000 yr + disso_sil = 1.e-6*dtbgc + ! Silicate saturation concentration is 1 mol/m3 + silsat = 0.001 + + ! Degradation rate constant of POP (disso) [1/(kmol O2/m3)*1/sec] + disso_poc = 0.01 / 86400. * dtbgc ! disso=3.e-5 was quite high - sedict = 1.e-9 * dtbgc + ! Denitrification rate constant of POP (disso) [1/sec] + sed_denit = 0.01/86400. * dtbgc + + ! Dissolution rate constant of CaCO3 (disso) [1/(kmol CO3--/m3)*1/sec] + disso_caco3 = 1.e-7 * dtbgc ! ****************************************************************** ! densities etc. for SEDIMENT SHIFTING @@ -131,9 +168,26 @@ subroutine bodensed(kpie,kpje,kpke,pddpo) ! determine total solid sediment volume solfu = 0. + do i = 1, kpie + do j = 1, kpje do k = 1, ks - solfu = solfu + seddw(k) * porsol(k) + solfu(i,j) = solfu(i,j) + seddw(k) * porsol(i,j,k) + enddo + enddo enddo +! Initialize porosity-dependent diffusion coefficients of sediment + zcoefsu(:,:,0) = 0.0 + do k = 1,ks + do j = 1, kpje + do i = 1, kpie + ! sediment diffusion coefficient * 1/dz * fraction of pore water at half depths + zcoefsu(i,j,k ) = -sedict * seddzi(k) * porwah(i,j,k) + zcoeflo(i,j,k-1) = -sedict * seddzi(k) * porwah(i,j,k) ! why the same ? + enddo + enddo + enddo + zcoeflo(:,:,ks) = 0.0 ! diffusion coefficient for bottom sediment layer + end subroutine bodensed diff --git a/hamocc/dipowa.F90 b/hamocc/dipowa.F90 index be53c421..e6fb22a2 100644 --- a/hamocc/dipowa.F90 +++ b/hamocc/dipowa.F90 @@ -56,7 +56,7 @@ subroutine dipowa(kpie,kpje,kpke,omask,lspin) !********************************************************************** use mo_carbch, only: ocetra, sedfluxo - use mo_sedmnt, only: powtra,porwat,porwah,sedict,seddw,seddzi + use mo_sedmnt, only: powtra,porwat,porwah,sedict,seddw,seddzi,zcoefsu,zcoeflo use mo_param1_bgc, only: ks,npowtra,map_por2octra use mo_vgrid, only: kbo,bolay #ifdef cisonew @@ -77,7 +77,6 @@ subroutine dipowa(kpie,kpje,kpke,omask,lspin) integer :: iv_oc ! index of ocetra in powtra loop real :: sedb1(kpie,0:ks,npowtra) ! ???? - real :: zcoefsu(0:ks),zcoeflo(0:ks) ! diffusion coefficients (upper/lower) real :: tredsy(kpie,0:kpke,3) ! redsy for 'reduced system'? real :: aprior ! start value of oceanic tracer in bottom layer @@ -85,14 +84,6 @@ subroutine dipowa(kpie,kpje,kpke,omask,lspin) !ik needed for boundary layer ventilation in fast sediment routine real :: bolven(kpie) ! bottom layer ventilation rate - zcoefsu(0) = 0.0 - do k = 1,ks - ! sediment diffusion coefficient * 1/dz * fraction of pore water at half depths - zcoefsu(k ) = -sedict * seddzi(k) * porwah(k) - zcoeflo(k-1) = -sedict * seddzi(k) * porwah(k) ! why the same ? - enddo - zcoeflo(ks) = 0.0 ! diffusion coefficient for bottom sediment layer - !$OMP PARALLEL DO & !$OMP&PRIVATE(i,k,iv,l,bolven,tredsy,sedb1,aprior,iv_oc) j_loop: do j=1,kpje @@ -104,8 +95,8 @@ subroutine dipowa(kpie,kpje,kpke,omask,lspin) k = 0 do i = 1,kpie - tredsy(i,k,1) = zcoefsu(k) - tredsy(i,k,3) = zcoeflo(k) + tredsy(i,k,1) = zcoefsu(i,j,k) + tredsy(i,k,3) = zcoeflo(i,j,k) tredsy(i,k,2) = bolven(i)*bolay(i,j) - tredsy(i,k,1) - tredsy(i,k,3) ! dz(kbo) - diff upper - diff lower enddo @@ -124,9 +115,9 @@ subroutine dipowa(kpie,kpje,kpke,omask,lspin) do k = 1,ks do i = 1,kpie - tredsy(i,k,1) = zcoefsu(k) - tredsy(i,k,3) = zcoeflo(k) - tredsy(i,k,2) = seddw(k)*porwat(k) -tredsy(i,k,1) -tredsy(i,k,3) + tredsy(i,k,1) = zcoefsu(i,j,k) + tredsy(i,k,3) = zcoeflo(i,j,k) + tredsy(i,k,2) = seddw(k)*porwat(i,j,k) -tredsy(i,k,1) -tredsy(i,k,3) enddo enddo @@ -134,7 +125,7 @@ subroutine dipowa(kpie,kpje,kpke,omask,lspin) do k = 1,ks do i = 1,kpie ! tracer_concentration(k[1:ks]) * porewater fraction(k) * dz(k) - sedb1(i,k,iv) = powtra(i,j,k,iv) * porwat(k) * seddw(k) + sedb1(i,k,iv) = powtra(i,j,k,iv) * porwat(i,j,k) * seddw(k) enddo enddo enddo diff --git a/hamocc/hamocc_init.F90 b/hamocc/hamocc_init.F90 index 0f753f30..f7f2dcf3 100644 --- a/hamocc/hamocc_init.F90 +++ b/hamocc/hamocc_init.F90 @@ -46,7 +46,7 @@ subroutine hamocc_init(read_rest,rstfnm_hamocc) & do_ndep,do_rivinpt,do_oalk,do_sedspinup, & & sedspin_yr_s,sedspin_yr_e,sedspin_ncyc, & & dtb,dtbgc,io_stdo_bgc,ldtbgc, & - & ldtrunbgc,ndtdaybgc,with_dmsph + & ldtrunbgc,ndtdaybgc,with_dmsph,l_3Dvarsedpor use mo_param1_bgc, only: ks,nsedtra,npowtra,init_por2octra_mapping use mo_carbch, only: alloc_mem_carbch,ocetra,atm,atm_co2 use mo_biomod, only: alloc_mem_biomod @@ -58,6 +58,7 @@ subroutine hamocc_init(read_rest,rstfnm_hamocc) use mo_read_ndep, only: ini_read_ndep,ndepfile use mo_read_oafx, only: ini_read_oafx,oalkfile,oalkscen use mo_read_pi_ph, only: ini_pi_ph,pi_ph_file + use mo_read_sedpor, only: read_sedpor,sedporfile use mo_clim_swa, only: ini_swa_clim,swaclimfile use mo_Gdata_read, only: inidic,inialk,inipo4,inioxy,inino3, & & inisil,inid13c,inid14c @@ -76,13 +77,14 @@ subroutine hamocc_init(read_rest,rstfnm_hamocc) integer :: i,j,k,l,nt integer :: iounit + real :: sed_por(idm,jdm,ks) = 0. namelist /bgcnml/ atm_co2,fedepfile,do_rivinpt,rivinfile,do_ndep,ndepfile, & & do_oalk,oalkscen,oalkfile,do_sedspinup,sedspin_yr_s, & & sedspin_yr_e,sedspin_ncyc, & & inidic,inialk,inipo4,inioxy,inino3,inisil, & & inid13c,inid14c,swaclimfile, & - & with_dmsph,pi_ph_file + & with_dmsph,pi_ph_file,l_3Dvarsedpor,sedporfile ! ! --- Set io units and some control parameters ! @@ -174,8 +176,9 @@ subroutine hamocc_init(read_rest,rstfnm_hamocc) call set_vgrid(idm,jdm,kdm,bgc_dp) ! ! --- Initialize sediment layering - ! - CALL BODENSED(idm,jdm,kdm,bgc_dp) + ! First raed the porosity, then apply it in bodensed + CALL read_sedpor(idm,jdm,ks,omask,sed_por) + CALL BODENSED(idm,jdm,kdm,bgc_dp,omask,sed_por) ! ! --- Initialize parameters, sediment and ocean tracer. ! diff --git a/hamocc/inventory_bgc.F90 b/hamocc/inventory_bgc.F90 index 8ca17e61..c9f104f5 100644 --- a/hamocc/inventory_bgc.F90 +++ b/hamocc/inventory_bgc.F90 @@ -143,7 +143,7 @@ SUBROUTINE INVENTORY_BGC(kpie,kpje,kpke,dlxp,dlyp,ddpo,omask,iogrp) DO j=1,kpje DO i=1,kpie ztmp1(i,j) = ztmp1(i,j) + omask(i,j)*seddw(k) & - & *dlxp(i,j)*dlyp(i,j)*porwat(k) + & *dlxp(i,j)*dlyp(i,j)*porwat(i,j,k) ENDDO ENDDO ENDDO @@ -155,7 +155,7 @@ SUBROUTINE INVENTORY_BGC(kpie,kpje,kpke,dlxp,dlyp,ddpo,omask,iogrp) DO k=1,ks DO j=1,kpje DO i=1,kpie - vol = seddw(k)*dlxp(i,j)*dlyp(i,j)*porwat(k) + vol = seddw(k)*dlxp(i,j)*dlyp(i,j)*porwat(i,j,k) ztmp1(i,j)= ztmp1(i,j) + omask(i,j)*powtra(i,j,k,l)*vol ENDDO ENDDO @@ -174,7 +174,7 @@ SUBROUTINE INVENTORY_BGC(kpie,kpje,kpke,dlxp,dlyp,ddpo,omask,iogrp) DO k=1,ks DO j=1,kpje DO i=1,kpie - vol = porsol(k)*seddw(k)*dlxp(i,j)*dlyp(i,j) + vol = porsol(i,j,k)*seddw(k)*dlxp(i,j)*dlyp(i,j) ztmp1(i,j) = ztmp1(i,j) + omask(i,j)*sedlay(i,j,k,l)*vol ENDDO ENDDO @@ -187,7 +187,7 @@ SUBROUTINE INVENTORY_BGC(kpie,kpje,kpke,dlxp,dlyp,ddpo,omask,iogrp) DO k=1,ks DO j=1,kpje DO i=1,kpie - vol = porsol(k)*seddw(k)*dlxp(i,j)*dlyp(i,j) + vol = porsol(i,j,k)*seddw(k)*dlxp(i,j)*dlyp(i,j) ztmp1(i,j) = ztmp1(i,j) + omask(i,j)*sedhpl(i,j,k)*vol ENDDO ENDDO diff --git a/hamocc/meson.build b/hamocc/meson.build index ed3461de..acc6319d 100644 --- a/hamocc/meson.build +++ b/hamocc/meson.build @@ -34,6 +34,7 @@ sources += files( 'mo_read_pi_ph.F90', 'mo_read_rivin.F90', 'mo_read_oafx.F90', + 'mo_read_sedpor.F90', 'mo_sedmnt.F90', 'mo_vgrid.F90', 'ncout_hamocc.F90', diff --git a/hamocc/mo_control_bgc.F90 b/hamocc/mo_control_bgc.F90 index b59c19ee..c7058aa5 100644 --- a/hamocc/mo_control_bgc.F90 +++ b/hamocc/mo_control_bgc.F90 @@ -57,8 +57,9 @@ MODULE mo_control_bgc REAL, save :: rmasks = 0.0 ! value at wet cells in sediment. REAL, save :: rmasko = 99999.00 ! value at wet cells in ocean. - + ! Logical switches set via namelist + LOGICAL, save :: l_3Dvarsedpor = .false. ! apply lon-lat-depth variable sediment porosity via input file LOGICAL, save :: do_ndep =.true. ! apply n-deposition LOGICAL, save :: do_rivinpt =.true. ! apply riverine input LOGICAL, save :: do_sedspinup=.false. ! apply sediment spin-up diff --git a/hamocc/mo_read_sedpor.F90 b/hamocc/mo_read_sedpor.F90 new file mode 100644 index 00000000..6ea984c6 --- /dev/null +++ b/hamocc/mo_read_sedpor.F90 @@ -0,0 +1,108 @@ +! Copyright (C) 2020 S. Gao, I. Bethke, J. Tjiputra, J. Schwinger +! +! This file is part of BLOM/iHAMOCC. +! +! 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 https://www.gnu.org/licenses/. + +module mo_read_sedpor +!***************************************************************************** +! Purpose +! ------- +! - Routine for reading sediment porosity from netcdf file +! +! Description +! ----------- +! Public routines and variable of this module: +! +! - subroutine ini_read_sedpor +! read sediment porosity file +! +! L_SED_POR must be set to true in nml to activate +! lon-lat variable sediment porosity. +! +! The model attempts to read lon-lat-sediment depth variable porosity +! from the input file 'SEDPORFILE' (incl. full path) +! +! sed_por holds then the porosity that can be applied later +! via mo_apply_sedpor +! +!***************************************************************************** + +implicit none + +private + +public :: read_sedpor,sedporfile + +character(len=512),save :: sedporfile = '' + +contains + +subroutine read_sedpor(kpie,kpje,ks,omask,sed_por) + use mod_xc, only: mnproc,xchalt + use mod_dia, only: iotype + use mo_control_bgc, only: io_stdo_bgc,l_3Dvarsedpor + use mod_nctools, only: ncfopn,ncread,ncfcls + + implicit none + + integer, intent(in) :: kpie,kpje,ks + real, intent(in) :: omask(kpie,kpje) + real, intent(inout) :: sed_por(kpie,kpje,ks) + + !local variables + integer :: i,j,k,errstat,dummymask(2) + real :: sed_por_in(kpie,kpje,ks) + logical :: file_exists = .false. + + ! Return if l_3Dvarsedpor is turned off + if (.not. l_3Dvarsedpor) then + if (mnproc.eq.1) then + write(io_stdo_bgc,*) '' + write(io_stdo_bgc,*) 'read_sedpor: spatially variable sediment porosity is not activated.' + endif + return + endif + + ! Check if sediment porosity file exists. If not, abort. + inquire(file=sedporfile,exist=file_exists) + if (.not. file_exists .and. mnproc.eq.1) then + write(io_stdo_bgc,*) '' + write(io_stdo_bgc,*) 'read_sedpor: Cannot find sediment porosity file... ' + call xchalt('(read_sedpor)') + stop '(read_sedpor)' + endif + + ! read sediment porosity from file + if (mnproc.eq.1) then + write(io_stdo_bgc,*) '' + write(io_stdo_bgc,*) 'read_sedpor: read sediment porosity from ', & + trim(sedporfile) + endif + call ncfopn(trim(sedporfile),'r',' ',1,iotype) + call ncread('sedpor',sed_por_in,dummymask,0,0.) + call ncfcls + + do k=1,ks + do j=1,kpje + do i=1,kpie + if(omask(i,j).gt. 0.5)then + sed_por(i,j,k)=sed_por_in(i,j,k) + endif + enddo + enddo + enddo + +end subroutine read_sedpor +end module mo_read_sedpor diff --git a/hamocc/mo_sedmnt.F90 b/hamocc/mo_sedmnt.F90 index 1eb66ade..a1286f22 100644 --- a/hamocc/mo_sedmnt.F90 +++ b/hamocc/mo_sedmnt.F90 @@ -70,13 +70,16 @@ MODULE mo_sedmnt REAL, save :: dzs(ksp) = 0.0 REAL, save :: seddzi(ksp) = 0.0 REAL, save :: seddw(ks) = 0.0 - REAL, save :: porsol(ks) = 0.0 - REAL, save :: porwah(ks) = 0.0 - REAL, save :: porwat(ks) = 0.0 REAL, DIMENSION (:,:,:,:), ALLOCATABLE :: sedlay REAL, DIMENSION (:,:,:,:), ALLOCATABLE :: powtra REAL, DIMENSION (:,:,:), ALLOCATABLE :: sedhpl + REAL, DIMENSION (:,:,:), ALLOCATABLE :: porsol + REAL, DIMENSION (:,:,:), ALLOCATABLE :: porwah + REAL, DIMENSION (:,:,:), ALLOCATABLE :: porwat + REAL, DIMENSION (:,:), ALLOCATABLE :: solfu + REAL, DIMENSION (:,:,:), ALLOCATABLE :: zcoefsu + REAL, DIMENSION (:,:,:), ALLOCATABLE :: zcoeflo REAL, DIMENSION (:,:), ALLOCATABLE :: silpro REAL, DIMENSION (:,:), ALLOCATABLE :: prorca @@ -91,7 +94,8 @@ MODULE mo_sedmnt REAL :: sedict,rno3,o2ut,ansed REAL :: calcwei, opalwei, orgwei REAL :: calcdens, opaldens, orgdens, claydens - REAL :: calfa, oplfa, orgfa, clafa, solfu + REAL :: calfa, oplfa, orgfa, clafa + REAL :: disso_sil,silsat,disso_poc,sed_denit,disso_caco3 CONTAINS @@ -195,6 +199,71 @@ SUBROUTINE ALLOC_MEM_SEDMNT(kpie,kpje) if(errstat.ne.0) stop 'not enough memory sedhpl' sedhpl(:,:,:) = 0.0 + IF (mnproc.eq.1) THEN + WRITE(io_stdo_bgc,*)'Memory allocation for variable porsol ...' + WRITE(io_stdo_bgc,*)'First dimension : ',kpie + WRITE(io_stdo_bgc,*)'Second dimension : ',kpje + WRITE(io_stdo_bgc,*)'Third dimension : ',ks + ENDIF + + ALLOCATE (porsol(kpie,kpje,ks),stat=errstat) + if(errstat.ne.0) stop 'not enough memory porsol' + porsol(:,:,:) = 0.0 + + IF (mnproc.eq.1) THEN + WRITE(io_stdo_bgc,*)'Memory allocation for variable porwah ...' + WRITE(io_stdo_bgc,*)'First dimension : ',kpie + WRITE(io_stdo_bgc,*)'Second dimension : ',kpje + WRITE(io_stdo_bgc,*)'Third dimension : ',ks + ENDIF + + ALLOCATE (porwah(kpie,kpje,ks),stat=errstat) + if(errstat.ne.0) stop 'not enough memory porwah' + porwah(:,:,:) = 0.0 + + IF (mnproc.eq.1) THEN + WRITE(io_stdo_bgc,*)'Memory allocation for variable porwat ...' + WRITE(io_stdo_bgc,*)'First dimension : ',kpie + WRITE(io_stdo_bgc,*)'Second dimension : ',kpje + WRITE(io_stdo_bgc,*)'Third dimension : ',ks + ENDIF + + ALLOCATE (porwat(kpie,kpje,ks),stat=errstat) + if(errstat.ne.0) stop 'not enough memory porwat' + porwat(:,:,:) = 0.0 + + IF (mnproc.eq.1) THEN + WRITE(io_stdo_bgc,*)'Memory allocation for variable solfu ...' + WRITE(io_stdo_bgc,*)'First dimension : ',kpie + WRITE(io_stdo_bgc,*)'Second dimension : ',kpje + ENDIF + + ALLOCATE (solfu(kpie,kpje),stat=errstat) + if(errstat.ne.0) stop 'not enough memory solfu' + solfu(:,:) = 0.0 + + IF (mnproc.eq.1) THEN + WRITE(io_stdo_bgc,*)'Memory allocation for variable zcoefsu ...' + WRITE(io_stdo_bgc,*)'First dimension : ',kpie + WRITE(io_stdo_bgc,*)'Second dimension : ',kpje + WRITE(io_stdo_bgc,*)'Third dimension : ',ks + ENDIF + + ALLOCATE (zcoefsu(kpie,kpje,0:ks),stat=errstat) + if(errstat.ne.0) stop 'not enough memory zcoefsu' + zcoefsu(:,:,:) = 0.0 + + IF (mnproc.eq.1) THEN + WRITE(io_stdo_bgc,*)'Memory allocation for variable zcoeflo ...' + WRITE(io_stdo_bgc,*)'First dimension : ',kpie + WRITE(io_stdo_bgc,*)'Second dimension : ',kpje + WRITE(io_stdo_bgc,*)'Third dimension : ',ks + ENDIF + + ALLOCATE (zcoeflo(kpie,kpje,0:ks),stat=errstat) + if(errstat.ne.0) stop 'not enough memory zcoeflo' + zcoeflo(:,:,:) = 0.0 + IF (mnproc.eq.1) THEN WRITE(io_stdo_bgc,*)'Memory allocation for variable burial ...' WRITE(io_stdo_bgc,*)'First dimension : ',kpie diff --git a/hamocc/powach.F90 b/hamocc/powach.F90 index 5c7f6fbc..540d4c94 100644 --- a/hamocc/powach.F90 +++ b/hamocc/powach.F90 @@ -61,7 +61,8 @@ subroutine powach(kpie,kpje,kpke,kbnd,prho,omask,psao,lspin) !****************************************************************************** use mo_carbch, only: co3,keqb,ocetra,sedfluxo use mo_chemcon, only: calcon - use mo_sedmnt, only: porwat,porsol,powtra,produs,prcaca,prorca,rno3,seddw,sedhpl,sedlay,silpro + use mo_sedmnt, only: porwat,porsol,powtra,produs,prcaca,prorca,rno3,seddw,sedhpl,sedlay,silpro,disso_sil,silsat,disso_poc, & + & sed_denit,disso_caco3 use mo_biomod, only: rnit,ro2ut use mo_control_bgc, only: dtbgc use mo_param1_bgc, only: ioxygen,ipowaal,ipowaic,ipowaox,ipowaph,ipowasi,ipown2,ipowno3,isilica,isssc12,issso12,issssil, & @@ -92,7 +93,7 @@ subroutine powach(kpie,kpje,kpke,kbnd,prho,omask,psao,lspin) real :: aerob13(kpie,ks),anaerob13(kpie,ks) real :: aerob14(kpie,ks),anaerob14(kpie,ks) #endif - real :: disso, dissot, undsa, silsat, posol + real :: dissot, undsa, posol real :: umfa, denit, saln, rrho, alk, c, sit, pt real :: K1, K2, Kb, Kw, Ks1, Kf, Ksi, K1p, K2p, K3p real :: ah1, ac, cu, cb, cc, satlev @@ -117,7 +118,7 @@ subroutine powach(kpie,kpje,kpke,kbnd,prho,omask,psao,lspin) !$OMP PARALLEL DO & !$OMP&PRIVATE(sedb1,sediso,solrat,powcar,aerob,anaerob, & -!$OMP& disso,dissot,undsa,silsat,posol, & +!$OMP& dissot,undsa,posol, & !$OMP& umfa,denit,saln,rrho,alk,c,sit,pt, & !$OMP& K1,K2,Kb,Kw,Ks1,Kf,Ksi,K1p,K2p,K3p, & !$OMP& ah1,ac,cu,cb,cc,satlev,bolven, & @@ -158,17 +159,8 @@ subroutine powach(kpie,kpje,kpke,kbnd,prho,omask,psao,lspin) ! Calculate silicate-opal cycle and simultaneous silicate diffusion !****************************************************************** -! Dissolution rate constant of opal (disso) [1/(kmol Si(OH)4/m3)*1/sec] - -! THIS NEEDS TO BE CHANGED TO disso=3.e-8! THIS IS ONLY KEPT FOR THE MOMENT -! FOR BACKWARDS COMPATIBILITY - !disso=3.e-8 ! (2011-01-04) EMR - disso=1.e-6 ! test vom 03.03.04 half live sil ca. 20.000 yr - dissot=disso*dtbgc - -! Silicate saturation concentration is 1 mol/m3 - - silsat = 0.001 +! Dissolution rate constant of opal (disso) [1/(kmol Si(OH)4/m3)*1/sec]*dtbgc + dissot=disso_sil ! Evaluate boundary conditions for sediment-water column exchange. ! Current undersaturation of bottom water: sedb(i,0) and @@ -180,8 +172,8 @@ subroutine powach(kpie,kpje,kpke,kbnd,prho,omask,psao,lspin) sedb1(i,0) = bolay(i,j) * (silsat - ocetra(i,j,kbo(i,j),isilica)) & & * bolven(i) solrat(i,1) = ( sedlay(i,j,1,issssil) & - & + silpro(i,j) / (porsol(1) * seddw(1)) ) & - & * dissot / (1. + dissot * undsa) * porsol(1) / porwat(1) + & + silpro(i,j) / (porsol(i,j,1) * seddw(1)) ) & + & * dissot / (1. + dissot * undsa) * porsol(i,j,1) / porwat(i,j,1) endif enddo @@ -194,9 +186,9 @@ subroutine powach(kpie,kpje,kpke,kbnd,prho,omask,psao,lspin) do i = 1, kpie if(omask(i,j) > 0.5) then undsa = silsat - powtra(i,j,k,ipowasi) - sedb1(i,k) = seddw(k) * porwat(k) * (silsat - powtra(i,j,k,ipowasi)) + sedb1(i,k) = seddw(k) * porwat(i,j,k) * (silsat - powtra(i,j,k,ipowasi)) if ( k > 1 ) solrat(i,k) = sedlay(i,j,k,issssil) & - & * dissot / (1. + dissot * undsa) * porsol(k) / porwat(k) + & * dissot / (1. + dissot * undsa) * porsol(i,j,k) / porwat(i,j,k) endif enddo enddo @@ -218,7 +210,7 @@ subroutine powach(kpie,kpje,kpke,kbnd,prho,omask,psao,lspin) ocetra(i,j,kbo(i,j),isilica) = silsat - sediso(i,0) endif sedlay(i,j,1,issssil) = & - & sedlay(i,j,1,issssil) + silpro(i,j) / (porsol(1) * seddw(1)) + & sedlay(i,j,1,issssil) + silpro(i,j) / (porsol(i,j,1) * seddw(1)) endif enddo @@ -230,7 +222,7 @@ subroutine powach(kpie,kpje,kpke,kbnd,prho,omask,psao,lspin) do k = 1, ks do i = 1, kpie if(omask(i,j) > 0.5) then - umfa = porsol(k)/porwat(k) + umfa = porsol(i,j,k)/porwat(i,j,k) solrat(i,k) = sedlay(i,j,k,issssil) * dissot & & / (1. + dissot * sediso(i,k)) posol = sediso(i,k) * solrat(i,k) @@ -243,10 +235,8 @@ subroutine powach(kpie,kpje,kpke,kbnd,prho,omask,psao,lspin) ! Calculate oxygen-POC cycle and simultaneous oxygen diffusion !************************************************************* -! Degradation rate constant of POP (disso) [1/(kmol O2/m3)*1/sec] - - disso = 0.01 / 86400. ! disso=3.e-5 was quite high - dissot = disso * dtbgc +! Degradation rate constant of POP (disso) [1/(kmol O2/m3)*1/sec]*dtbgc + dissot = disso_poc ! This scheme is not based on undersaturation, but on O2 itself @@ -259,9 +249,9 @@ subroutine powach(kpie,kpje,kpke,kbnd,prho,omask,psao,lspin) undsa = powtra(i,j,1,ipowaox) sedb1(i,0) = bolay(i,j) * ocetra(i,j,kbo(i,j),ioxygen) * bolven(i) solrat(i,1) = ( sedlay(i,j,1,issso12) + prorca(i,j) & - & / (porsol(1) * seddw(1)) ) & + & / (porsol(i,j,1) * seddw(1)) ) & & * ro2ut * dissot / (1. + dissot * undsa) & - & * porsol(1) / porwat(1) + & * porsol(i,j,1) / porwat(i,j,1) endif enddo @@ -273,9 +263,9 @@ subroutine powach(kpie,kpje,kpke,kbnd,prho,omask,psao,lspin) do i = 1, kpie if(omask(i,j) > 0.5) then undsa = powtra(i,j,k,ipowaox) - sedb1(i,k) = seddw(k) * porwat(k) * powtra(i,j,k,ipowaox) + sedb1(i,k) = seddw(k) * porwat(i,j,k) * powtra(i,j,k,ipowaox) if (k > 1) solrat(i,k) = sedlay(i,j,k,issso12) * ro2ut * dissot & - & / (1. + dissot*undsa) * porsol(k) / porwat(k) + & / (1. + dissot*undsa) * porsol(i,j,k) / porwat(i,j,k) endif enddo enddo @@ -297,12 +287,12 @@ subroutine powach(kpie,kpje,kpke,kbnd,prho,omask,psao,lspin) ocetra(i,j,kbo(i,j),ioxygen) = sediso(i,0) endif sedlay(i,j,1,issso12) = & - & sedlay(i,j,1,issso12) + prorca(i,j) / (porsol(1)*seddw(1)) + & sedlay(i,j,1,issso12) + prorca(i,j) / (porsol(i,j,1)*seddw(1)) #ifdef cisonew sedlay(i,j,1,issso13) = & - & sedlay(i,j,1,issso13) + pror13(i,j) / (porsol(1)*seddw(1)) + & sedlay(i,j,1,issso13) + pror13(i,j) / (porsol(i,j,1)*seddw(1)) sedlay(i,j,1,issso14) = & - & sedlay(i,j,1,issso14) + pror14(i,j) / (porsol(1)*seddw(1)) + & sedlay(i,j,1,issso14) + pror14(i,j) / (porsol(i,j,1)*seddw(1)) #endif endif enddo @@ -315,7 +305,7 @@ subroutine powach(kpie,kpje,kpke,kbnd,prho,omask,psao,lspin) do k = 1, ks do i = 1, kpie if(omask(i,j) > 0.5) then - umfa = porsol(k) / porwat(k) + umfa = porsol(i,j,k) / porwat(i,j,k) solrat(i,k) = sedlay(i,j,k,issso12) * dissot/(1. + dissot*sediso(i,k)) posol = sediso(i,k)*solrat(i,k) aerob(i,k) = posol*umfa !this has P units: kmol P/m3 of pore water @@ -345,18 +335,15 @@ subroutine powach(kpie,kpje,kpke,kbnd,prho,omask,psao,lspin) ! Calculate nitrate reduction under anaerobic conditions explicitely !******************************************************************* -! Denitrification rate constant of POP (disso) [1/sec] -! Store flux in array anaerob, for later computation of DIC and alkalinity. - -!ik denit = 1.e-6*dtbgc - denit = 0.01/86400. *dtbgc + ! Denitrification rate constant of POP (disso) [1/sec]*dtbgc + denit = sed_denit do k = 1, ks do i = 1, kpie if(omask(i,j) > 0.5) then if(powtra(i,j,k,ipowaox) < 1.e-6) then posol = denit * MIN(0.5*powtra(i,j,k,ipowno3)/114., & & sedlay(i,j,k,issso12)) - umfa = porsol(k)/porwat(k) + umfa = porsol(i,j,k)/porwat(i,j,k) anaerob(i,k) = posol*umfa !this has P units: kmol P/m3 of pore water #ifdef cisonew rato13 = sedlay(i,j,k,issso13) / (sedlay(i,j,k,issso12) + safediv) @@ -389,7 +376,7 @@ subroutine powach(kpie,kpje,kpke,kbnd,prho,omask,psao,lspin) if(omask(i,j) > 0.5) then if(powtra(i,j,k,ipowaox) < 3.e-6 .and. powtra(i,j,k,ipowno3) < 3.e-6) then posol = denit * sedlay(i,j,k,issso12) ! remineralization of poc - umfa = porsol(k) / porwat(k) + umfa = porsol(i,j,k) / porwat(i,j,k) !this overwrites anaerob from denitrification. added =anaerob+..., works anaerob(i,k) = anaerob(i,k) + posol*umfa !this has P units: kmol P/m3 of pore water #ifdef cisonew @@ -456,9 +443,8 @@ subroutine powach(kpie,kpje,kpke,kbnd,prho,omask,psao,lspin) enddo -! Dissolution rate constant of CaCO3 (disso) [1/(kmol CO3--/m3)*1/sec] - disso = 1.e-7 - dissot = disso * dtbgc +! Dissolution rate constant of CaCO3 (disso) [1/(kmol CO3--/m3)*1/sec]*dtbgc + dissot = disso_caco3 ! Evaluate boundary conditions for sediment-water column exchange. ! Current undersaturation of bottom water: sedb(i,0) and @@ -473,8 +459,8 @@ subroutine powach(kpie,kpje,kpke,kbnd,prho,omask,psao,lspin) undsa = MAX( satlev-powcar(i,1), 0. ) sedb1(i,0) = bolay(i,j) * (satlev-co3(i,j,kbo(i,j))) * bolven(i) solrat(i,1) = (sedlay(i,j,1,isssc12) & - & + prcaca(i,j) / (porsol(1)*seddw(1))) & - & * dissot / (1.+dissot*undsa) * porsol(1) / porwat(1) + & + prcaca(i,j) / (porsol(i,j,1)*seddw(1))) & + & * dissot / (1.+dissot*undsa) * porsol(i,j,1) / porwat(i,j,1) endif enddo @@ -486,9 +472,9 @@ subroutine powach(kpie,kpje,kpke,kbnd,prho,omask,psao,lspin) do i = 1, kpie if(omask(i,j) > 0.5) then undsa = MAX( keqb(11,i,j) / calcon - powcar(i,k), 0. ) - sedb1(i,k) = seddw(k) * porwat(k) * undsa + sedb1(i,k) = seddw(k) * porwat(i,j,k) * undsa if (k > 1) solrat(i,k) = sedlay(i,j,k,isssc12) & - & * dissot/(1.+dissot*undsa) * porsol(k)/porwat(k) + & * dissot/(1.+dissot*undsa) * porsol(i,j,k)/porwat(i,j,k) if (undsa <= 0.) solrat(i,k) = 0. endif enddo @@ -504,12 +490,12 @@ subroutine powach(kpie,kpje,kpke,kbnd,prho,omask,psao,lspin) do i = 1, kpie if(omask(i,j) > 0.5) then sedlay(i,j,1,isssc12) = & - & sedlay(i,j,1,isssc12) + prcaca(i,j) / (porsol(1)*seddw(1)) + & sedlay(i,j,1,isssc12) + prcaca(i,j) / (porsol(i,j,1)*seddw(1)) #ifdef cisonew sedlay(i,j,1,isssc13) = & - & sedlay(i,j,1,isssc13) + prca13(i,j) / (porsol(1)*seddw(1)) + & sedlay(i,j,1,isssc13) + prca13(i,j) / (porsol(i,j,1)*seddw(1)) sedlay(i,j,1,isssc14) = & - & sedlay(i,j,1,isssc14) + prca14(i,j) / (porsol(1)*seddw(1)) + & sedlay(i,j,1,isssc14) + prca14(i,j) / (porsol(i,j,1)*seddw(1)) #endif endif enddo @@ -523,7 +509,7 @@ subroutine powach(kpie,kpje,kpke,kbnd,prho,omask,psao,lspin) do k = 1, ks do i = 1, kpie if(omask(i,j) > 0.5) then - umfa = porsol(k) / porwat(k) + umfa = porsol(i,j,k) / porwat(i,j,k) solrat(i,k) = sedlay(i,j,k,isssc12) & & * dissot / (1. + dissot * sediso(i,k)) posol = sediso(i,k) * solrat(i,k) @@ -565,7 +551,7 @@ subroutine powach(kpie,kpje,kpke,kbnd,prho,omask,psao,lspin) do j = 1, kpje do i = 1, kpie sedlay(i,j,1,issster) = sedlay(i,j,1,issster) & - & + produs(i,j) / (porsol(1) * seddw(1)) + & + produs(i,j) / (porsol(i,j,1) * seddw(1)) enddo enddo !$OMP END PARALLEL DO diff --git a/hamocc/powadi.F90 b/hamocc/powadi.F90 index a5828d91..413c3046 100644 --- a/hamocc/powadi.F90 +++ b/hamocc/powadi.F90 @@ -76,21 +76,21 @@ subroutine powadi(j,kpie,kpje,solrat,sedb1,sediso,bolven,omask) !********************************************************************** do k = 1, ks - asu = sedict * seddzi(k) * porwah(k) - alo = 0. - if(k < ks) alo = sedict * seddzi(k+1) * porwah(k+1) do i = 1, kpie + asu = sedict * seddzi(k) * porwah(i,j,k) + alo = 0. + if(k < ks) alo = sedict * seddzi(k+1) * porwah(i,j,k+1) tredsy(i,k,1) = -asu tredsy(i,k,3) = -alo - tredsy(i,k,2) = seddw(k) * porwat(k) - tredsy(i,k,1) & - & - tredsy(i,k,3) + solrat(i,k) * porwat(k) * seddw(k) + tredsy(i,k,2) = seddw(k) * porwat(i,j,k) - tredsy(i,k,1) & + & - tredsy(i,k,3) + solrat(i,k) * porwat(i,j,k) * seddw(k) enddo enddo k = 0 asu = 0. - alo = sedict * seddzi(1) * porwah(1) do i = 1, kpie + alo = sedict * seddzi(1) * porwah(i,j,1) if(omask(i,j) > 0.5) then tredsy(i,k,1) = -asu tredsy(i,k,3) = -alo diff --git a/hamocc/sedshi.F90 b/hamocc/sedshi.F90 index 51eea483..44058447 100644 --- a/hamocc/sedshi.F90 +++ b/hamocc/sedshi.F90 @@ -100,7 +100,7 @@ SUBROUTINE SEDSHI(kpie,kpje,omask) uebers=wsed(i,j)*sedlay(i,j,k,iv) sedlay(i,j,k ,iv)=sedlay(i,j,k ,iv)-uebers sedlay(i,j,k+1,iv)=sedlay(i,j,k+1,iv)+uebers & - & *(seddw(k)*porsol(k))/(seddw(k+1)*porsol(k+1)) + & *(seddw(k)*porsol(i,j,k))/(seddw(k+1)*porsol(i,j,k+1)) endif enddo !end i-loop enddo !end j-loop @@ -140,7 +140,7 @@ SUBROUTINE SEDSHI(kpie,kpje,omask) !ka if(bolay(i,j).gt.0.) then uebers=wsed(i,j)*sedlay(i,j,k,iv) sedlay(i,j,ks ,iv)=sedlay(i,j,ks ,iv)-uebers - burial(i,j,iv)=burial(i,j,iv)+uebers*seddw(k)*porsol(k) + burial(i,j,iv)=burial(i,j,iv)+uebers*seddw(k)*porsol(i,j,k) endif enddo !end i-loop enddo !end j-loop @@ -178,7 +178,7 @@ SUBROUTINE SEDSHI(kpie,kpje,omask) & +calfa*sedlay(i,j,k,isssc12) & & +oplfa*sedlay(i,j,k,issssil) & & +clafa*sedlay(i,j,k,issster) - fulsed(i,j)=fulsed(i,j)+porsol(k)*seddw(k)*sedlo + fulsed(i,j)=fulsed(i,j)+porsol(i,j,k)*seddw(k)*sedlo endif enddo !end i-loop enddo !end j-loop @@ -197,7 +197,7 @@ SUBROUTINE SEDSHI(kpie,kpje,omask) ! deficiency to fully loaded sediment packed in sedlay(i,j,ks) ! this is the volume required from the buried layer - seddef=solfu-fulsed(i,j) + seddef=solfu(i,j)-fulsed(i,j) ! total volume of solid constituents in buried layer spresent=orgfa*rcar*burial(i,j,issso12) & @@ -219,7 +219,7 @@ SUBROUTINE SEDSHI(kpie,kpje,omask) ! fill the last active layer refill=seddef/(buried+1.e-10) - frac = porsol(ks)*seddw(ks) !changed k to ks, ik + frac = porsol(i,j,ks)*seddw(ks) sedlay(i,j,ks,issso12)=sedlay(i,j,ks,issso12) & & +refill*burial(i,j,issso12)/frac @@ -269,7 +269,7 @@ SUBROUTINE SEDSHI(kpie,kpje,omask) if(omask(i,j).gt.0.5) then !ka if(bolay(i,j).gt.0.) then uebers=sedlay(i,j,k,iv)*wsed(i,j) - frac=porsol(k)*seddw(k)/(porsol(k-1)*seddw(k-1)) + frac=porsol(i,j,k)*seddw(k)/(porsol(i,j,k-1)*seddw(k-1)) sedlay(i,j,k,iv)=sedlay(i,j,k,iv)-uebers sedlay(i,j,k-1,iv)=sedlay(i,j,k-1,iv)+uebers*frac #ifdef cisonew From ed8206848e73e0cae26cf6250b4328d4b037d86d Mon Sep 17 00:00:00 2001 From: Mats Bentsen Date: Thu, 15 Sep 2022 19:08:13 +0200 Subject: [PATCH 161/366] Added wave forcing fields. --- cesm/mod_cesm.F90 | 76 ++++++++++++++++-------- drivers/nuopc/mod_nuopc_methods.F90 | 90 ++++++++++++++++++++++++----- phy/mod_difest.F | 11 ++++ phy/mod_forcing.F90 | 11 +++- 4 files changed, 149 insertions(+), 39 deletions(-) diff --git a/cesm/mod_cesm.F90 b/cesm/mod_cesm.F90 index c02e0cdb..cc371c18 100644 --- a/cesm/mod_cesm.F90 +++ b/cesm/mod_cesm.F90 @@ -28,8 +28,8 @@ module mod_cesm use mod_time, only: nstep use mod_xc use mod_forcing, only: trxday, srxday, swa, nsf, lip, sop, eva, rnf, rfi, & - fmltfz, sfl, ztx, mty, ustarw, slp, abswnd, atmco2,& - atmbrf + fmltfz, sfl, ztx, mty, ustarw, slp, abswnd, & + lamult, lasl, ustokes, vstokes, atmco2, atmbrf use mod_ben02, only: initai, rdcsic, rdctsf, fnlzai use mod_seaice, only: ficem use mod_checksum, only: csdiag, chksummsk @@ -70,9 +70,13 @@ module mod_cesm ustarw_da, & ! Friction velocity for open water [m s-1]. slp_da, & ! Sea-level pressure [kg m-1 s-2]. abswnd_da, & ! Wind speed at measurement height (zu) [m s-1]. + ficem_da, & ! Ice concentration []. + lamult_da, & ! Langmuir enhancement factor []. + lasl_da, & ! Surface layer averaged Langmuir number []. + ustokes_da, & ! u-component of surface Stokes drift [m s-1]. + vstokes_da, & ! v-component of surface Stokes drift [m s-1]. atmco2_da, & ! Atmospheric CO2 concentration [ppm]. - atmbrf_da, & ! Atmospheric bromoform concentration [ppt]. - ficem_da ! Ice concentration []. + atmbrf_da ! Atmospheric bromoform concentration [ppt]. logical :: & smtfrc ! If true, time smooth CESM forcing fields. @@ -83,7 +87,8 @@ module mod_cesm public :: runid_cesm, runtyp_cesm, ocn_cpl_dt_cesm, nstep_in_cpl, hmlt, & 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, ustarw_da, & - slp_da, abswnd_da, atmco2_da, atmbrf_da, ficem_da, smtfrc, l1ci, l2ci, & + slp_da, abswnd_da, ficem_da, lamult_da, lasl_da, & + ustokes_da, vstokes_da, atmco2_da, atmbrf_da, smtfrc, l1ci, l2ci, & inicon_cesm, inifrc_cesm, getfrc_cesm contains @@ -146,6 +151,7 @@ subroutine getfrc_cesm #undef DIAG #ifdef DIAG use mod_nctools + use mod_dia, only : iotype #endif integer :: i, j, l @@ -163,22 +169,26 @@ subroutine getfrc_cesm do j = 1, jj do l = 1, isp(j) do i = max(1, ifp(j, l)), min(ii, ilp(j, l)) - ustarw(i, j) = w1*ustarw_da(i, j, l1ci) + w2*ustarw_da(i, j, l2ci) - lip(i, j) = w1*lip_da(i, j, l1ci) + w2*lip_da(i, j, l2ci) - sop(i, j) = w1*sop_da(i, j, l1ci) + w2*sop_da(i, j, l2ci) - eva(i, j) = w1*eva_da(i, j, l1ci) + w2*eva_da(i, j, l2ci) - rnf(i, j) = w1*rnf_da(i, j, l1ci) + w2*rnf_da(i, j, l2ci) - rfi(i, j) = w1*rfi_da(i, j, l1ci) + w2*rfi_da(i, j, l2ci) - fmltfz(i, j) = w1*fmltfz_da(i, j, l1ci) + w2*fmltfz_da(i, j, l2ci) - sfl(i, j) = w1*sfl_da(i, j, l1ci) + w2*sfl_da(i, j, l2ci) - swa(i, j) = w1*swa_da(i, j, l1ci) + w2*swa_da(i, j, l2ci) - nsf(i, j) = w1*nsf_da(i, j, l1ci) + w2*nsf_da(i, j, l2ci) - hmlt(i, j) = w1*hmlt_da(i, j, l1ci) + w2*hmlt_da(i, j, l2ci) - slp(i, j) = w1*slp_da(i, j, l1ci) + w2*slp_da(i, j, l2ci) - ficem(i, j) = w1*ficem_da(i, j, l1ci) + w2*ficem_da(i, j, l2ci) - abswnd(i, j) = w1*abswnd_da(i, j, l1ci) + w2*abswnd_da(i, j, l2ci) - atmco2(i, j) = w1*atmco2_da(i, j, l1ci) + w2*atmco2_da(i, j, l2ci) - atmbrf(i, j) = w1*atmbrf_da(i, j, l1ci) + w2*atmbrf_da(i, j, l2ci) + ustarw(i, j) = w1*ustarw_da(i, j, l1ci) + w2*ustarw_da(i, j, l2ci) + lip(i, j) = w1*lip_da(i, j, l1ci) + w2*lip_da(i, j, l2ci) + sop(i, j) = w1*sop_da(i, j, l1ci) + w2*sop_da(i, j, l2ci) + eva(i, j) = w1*eva_da(i, j, l1ci) + w2*eva_da(i, j, l2ci) + rnf(i, j) = w1*rnf_da(i, j, l1ci) + w2*rnf_da(i, j, l2ci) + rfi(i, j) = w1*rfi_da(i, j, l1ci) + w2*rfi_da(i, j, l2ci) + fmltfz(i, j) = w1*fmltfz_da(i, j, l1ci) + w2*fmltfz_da(i, j, l2ci) + sfl(i, j) = w1*sfl_da(i, j, l1ci) + w2*sfl_da(i, j, l2ci) + swa(i, j) = w1*swa_da(i, j, l1ci) + w2*swa_da(i, j, l2ci) + nsf(i, j) = w1*nsf_da(i, j, l1ci) + w2*nsf_da(i, j, l2ci) + hmlt(i, j) = w1*hmlt_da(i, j, l1ci) + w2*hmlt_da(i, j, l2ci) + slp(i, j) = w1*slp_da(i, j, l1ci) + w2*slp_da(i, j, l2ci) + abswnd(i, j) = w1*abswnd_da(i, j, l1ci) + w2*abswnd_da(i, j, l2ci) + ficem(i, j) = w1*ficem_da(i, j, l1ci) + w2*ficem_da(i, j, l2ci) + lamult(i, j) = w1*lamult_da(i, j, l1ci) + w2*lamult_da(i, j, l2ci) + lasl(i, j) = w1*lasl_da(i, j, l1ci) + w2*lasl_da(i, j, l2ci) + ustokes(i, j) = w1*ustokes_da(i, j, l1ci) + w2*ustokes_da(i, j, l2ci) + vstokes(i, j) = w1*vstokes_da(i, j, l1ci) + w2*vstokes_da(i, j, l2ci) + atmco2(i, j) = w1*atmco2_da(i, j, l1ci) + w2*atmco2_da(i, j, l2ci) + atmbrf(i, j) = w1*atmbrf_da(i, j, l1ci) + w2*atmbrf_da(i, j, l2ci) enddo enddo do l = 1, isu(j) @@ -210,8 +220,12 @@ subroutine getfrc_cesm call ncdefvar('nsf_da', 'x y', ndouble, 8) call ncdefvar('hmlt_da', 'x y', ndouble, 8) call ncdefvar('slp_da', 'x y', ndouble, 8) - call ncdefvar('ficem_da', 'x y', ndouble, 8) call ncdefvar('abswnd_da', 'x y', ndouble, 8) + call ncdefvar('ficem_da', 'x y', ndouble, 8) + call ncdefvar('lamult_da', 'x y', ndouble, 8) + call ncdefvar('lasl_da', 'x y', ndouble, 8) + call ncdefvar('ustokes_da', 'x y', ndouble, 8) + call ncdefvar('vstokes_da', 'x y', ndouble, 8) call ncdefvar('atmco2_da', 'x y', ndouble, 8) call ncdefvar('atmbrf_da', 'x y', ndouble, 8) call ncdefvar('ztx_da', 'x y', ndouble, 8) @@ -242,14 +256,22 @@ subroutine getfrc_cesm ip, 1, 1._r8, 0._r8, 8) call ncwrtr('slp_da', 'x y', slp_da(1 - nbdy, 1 - nbdy, l2ci), & ip, 1, 1._r8, 0._r8, 8) + call ncwrtr('abswnd_da', 'x y', abswnd_da(1 - nbdy, 1 - nbdy, l2ci), & + ip, 1, 1._r8, 0._r8, 8) call ncwrtr('ficem_da', 'x y', ficem_da(1 - nbdy, 1 - nbdy, l2ci), & ip, 1, 1._r8, 0._r8, 8) - call ncwrtr('abswnd_da', 'x y', abswnd_da(1 - nbdy, 1 - nbdy, l2ci), & + call ncwrtr('lamult_da', 'x y', lamult_da(1 - nbdy, 1 - nbdy, l2ci), & + ip, 1, 1._r8, 0._r8, 8) + call ncwrtr('lasl_da', 'x y', lasl_da(1 - nbdy, 1 - nbdy, l2ci), & + ip, 1, 1._r8, 0._r8, 8) + call ncwrtr('ustokes_da', 'x y', ustokes_da(1 - nbdy, 1 - nbdy, l2ci), & + ip, 1, 1._r8, 0._r8, 8) + call ncwrtr('vstokes_da', 'x y', vstokes_da(1 - nbdy, 1 - nbdy, l2ci), & ip, 1, 1._r8, 0._r8, 8) call ncwrtr('atmco2_da', 'x y', atmco2_da(1 - nbdy, 1 - nbdy, l2ci), & ip, 1, 1._r8, 0._r8, 8) call ncwrtr('atmbrf_da', 'x y', atmbrf_da(1 - nbdy, 1 - nbdy, l2ci), & - . ip, 1, 1._r8, 0._r8, 8) + ip, 1, 1._r8, 0._r8, 8) call ncwrtr('ztx_da', 'x y', ztx_da(1 - nbdy, 1 - nbdy, l2ci), & iu, 1, 1._r8, 0._r8, 8) call ncwrtr('mty_da', 'x y', mty_da(1 - nbdy, 1 - nbdy, l2ci), & @@ -277,8 +299,12 @@ subroutine getfrc_cesm call chksummsk(nsf, ip, 1, 'nsf') call chksummsk(hmlt, ip, 1, 'hmlt') call chksummsk(slp, ip, 1, 'slp') - call chksummsk(ficem, ip, 1, 'ficem') call chksummsk(abswnd, ip, 1, 'abswnd') + call chksummsk(ficem, ip, 1, 'ficem') + call chksummsk(lamult, ip, 1, 'lamult') + call chksummsk(lasl, ip, 1, 'lasl') + call chksummsk(ustokes, ip, 1, 'ustokes') + call chksummsk(vstokes, ip, 1, 'vstokes') call chksummsk(atmco2, ip, 1, 'atmco2') call chksummsk(atmbrf, ip, 1, 'atmbrf') endif diff --git a/drivers/nuopc/mod_nuopc_methods.F90 b/drivers/nuopc/mod_nuopc_methods.F90 index 0d24e367..6cdd659a 100644 --- a/drivers/nuopc/mod_nuopc_methods.F90 +++ b/drivers/nuopc/mod_nuopc_methods.F90 @@ -36,8 +36,9 @@ module mod_nuopc_methods 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, & - ustarw_da, slp_da, abswnd_da, atmco2_da, atmbrf_da, & - ficem_da, l1ci, l2ci + ustarw_da, slp_da, abswnd_da, ficem_da, lamult_da, & + lasl_da, ustokes_da, vstokes_da, atmco2_da, atmbrf_da, & + l1ci, l2ci use mod_utility, only: util1, util2 use mod_checksum, only: csdiag, chksummsk use shr_const_mod, only: SHR_CONST_RHOSW, SHR_CONST_LATICE, SHR_CONST_TKFRZ @@ -492,10 +493,10 @@ subroutine blom_importflds(fldlist_num, fldlist) index_Sw_ustokes = - 1, & index_Sw_vstokes = - 1, & index_Sw_hstokes = - 1, & - index_Sa_pslv = - 1, & index_Faxa_lwdn = - 1, & index_Faxa_snow = - 1, & index_Faxa_rain = - 1, & + index_Sa_pslv = - 1, & index_Sa_co2diag = - 1, & index_Sa_co2prog = - 1, & index_Sa_brfprog = - 1 @@ -512,7 +513,7 @@ subroutine blom_importflds(fldlist_num, fldlist) call getfldindex(fldlist_num, fldlist, 'Foxx_taux', index_Foxx_taux) call getfldindex(fldlist_num, fldlist, 'Foxx_tauy', index_Foxx_tauy) - !$omp parallel do private(i, n) + !$omp parallel do private(i, n, afac, utmp, vtmp) do j = 1, jjcpl do i = 1, ii if (ip(i,j) == 0) then @@ -526,6 +527,7 @@ subroutine blom_importflds(fldlist_num, fldlist) else n = (j - 1)*ii + i afac = med2mod_areacor(n) + utmp = fldlist(index_Foxx_taux)%dataptr(n)*afac vtmp = fldlist(index_Foxx_tauy)%dataptr(n)*afac util1(i,j) = utmp*cosang(i,j) + vtmp*sinang(i,j) @@ -577,10 +579,10 @@ subroutine blom_importflds(fldlist_num, fldlist) call getfldindex(fldlist_num, fldlist, 'Faxa_lwdn', index_Faxa_lwdn) call getfldindex(fldlist_num, fldlist, 'Fioi_melth', index_Fioi_melth) call getfldindex(fldlist_num, fldlist, 'Sa_pslv', index_Sa_pslv) - call getfldindex(fldlist_num, fldlist, 'Si_ifrac', index_Si_ifrac) call getfldindex(fldlist_num, fldlist, 'So_duu10n', index_So_duu10n) + call getfldindex(fldlist_num, fldlist, 'Si_ifrac', index_Si_ifrac) - !$omp parallel do private(i, n) + !$omp parallel do private(i, n, afac) do j = 1, jjcpl do i = 1, ii @@ -596,8 +598,8 @@ subroutine blom_importflds(fldlist_num, fldlist) nsf_da(i,j,l2ci) = mval hmlt_da(i,j,l2ci) = mval slp_da(i,j,l2ci) = mval - ficem_da(i,j,l2ci) = mval abswnd_da(i,j,l2ci) = mval + ficem_da(i,j,l2ci) = mval elseif (cplmsk(i,j) == 0) then lip_da(i,j,l2ci) = 0._r8 sop_da(i,j,l2ci) = 0._r8 @@ -610,8 +612,8 @@ subroutine blom_importflds(fldlist_num, fldlist) nsf_da(i,j,l2ci) = 0._r8 hmlt_da(i,j,l2ci) = 0._r8 slp_da(i,j,l2ci) = fval - ficem_da(i,j,l2ci) = fval abswnd_da(i,j,l2ci) = fval + ficem_da(i,j,l2ci) = fval else n = (j - 1)*ii + i afac = med2mod_areacor(n) @@ -656,12 +658,12 @@ subroutine blom_importflds(fldlist_num, fldlist) ! Sea level pressure [kg m-1 s-2]. slp_da(i,j,l2ci) = fldlist(index_Sa_pslv)%dataptr(n) - ! Ice fraction []. - ficem_da(i,j,l2ci) = fldlist(index_Si_ifrac)%dataptr(n) - ! 10m wind speed [m s-1]. abswnd_da(i,j,l2ci) = sqrt(fldlist(index_So_duu10n)%dataptr(n)) + ! Ice fraction []. + ficem_da(i,j,l2ci) = fldlist(index_Si_ifrac)%dataptr(n) + endif enddo @@ -682,8 +684,70 @@ subroutine blom_importflds(fldlist_num, fldlist) endif call fill_global(mval, fval, halo_ps, slp_da(1-nbdy,1-nbdy,l2ci)) - call fill_global(mval, fval, halo_ps, ficem_da(1-nbdy,1-nbdy,l2ci)) call fill_global(mval, fval, halo_ps, abswnd_da(1-nbdy,1-nbdy,l2ci)) + call fill_global(mval, fval, halo_ps, ficem_da(1-nbdy,1-nbdy,l2ci)) + + call getfldindex(fldlist_num, fldlist, 'Sw_lamult', index_Sw_lamult) + call getfldindex(fldlist_num, fldlist, 'Sw_ustokes', index_Sw_ustokes) + call getfldindex(fldlist_num, fldlist, 'Sw_vstokes', index_Sw_vstokes) + call getfldindex(fldlist_num, fldlist, 'Sw_hstokes', index_Sw_hstokes) + + !$omp parallel do private(i, n, utmp, vtmp) + do j = 1, jjcpl + do i = 1, ii + if (ip(i,j) == 0) then + util1(i,j) = mval + util2(i,j) = mval + lamult_da(i,j,l2ci) = mval + lasl_da(i,j,l2ci) = mval + elseif (cplmsk(i,j) == 0) then + util1(i,j) = fval + util2(i,j) = fval + lamult_da(i,j,l2ci) = fval + lasl_da(i,j,l2ci) = fval + else + n = (j - 1)*ii + i + + utmp = fldlist(index_Sw_ustokes)%dataptr(n) + vtmp = fldlist(index_Sw_vstokes)%dataptr(n) + util1(i,j) = utmp*cosang(i,j) + vtmp*sinang(i,j) + util2(i,j) = - utmp*sinang(i,j) + vtmp*cosang(i,j) + + ! Langmuir enhancement factor []. + lamult_da(i,j,l2ci) = fldlist(index_Sw_lamult)%dataptr(n) + + ! Surface layer averaged Langmuir number []. + lasl_da(i,j,l2ci) = fldlist(index_Sw_hstokes)%dataptr(n) + + endif + enddo + enddo + !$omp end parallel do + + call fill_global(mval, fval, halo_pv, util1) + call fill_global(mval, fval, halo_pv, util2) + call fill_global(mval, fval, halo_ps, lamult_da(1-nbdy,1-nbdy,l2ci)) + call fill_global(mval, fval, halo_ps, lasl_da(1-nbdy,1-nbdy,l2ci)) + + call xctilr(util1, 1,1, 1,1, halo_pv) + call xctilr(util2, 1,1, 1,1, halo_pv) + + !$omp parallel do private(l, i) + do j = 1, jj + do l = 1, isu(j) + do i = max(1,ifu(j,l)), min(ii,ilu(j,l)) + ! x-component of surface Stokes drift [m s-1]. + ustokes_da(i,j,l2ci) = .5_r8*(util1(i-1,j) + util1(i,j)) + enddo + enddo + do l = 1,isv(j) + do i = max(1,ifv(j,l)), min(ii,ilv(j,l)) + ! y-component of surface Stokes drift [m s-1]. + vstokes_da(i,j,l2ci) = .5_r8*(util2(i,j-1) + util2(i,j)) + enddo + enddo + enddo + !$omp end parallel do #ifdef PROGCO2 call getfldindex(fldlist_num, fldlist, 'Sa_co2prog', index_Sa_co2prog) @@ -831,8 +895,8 @@ subroutine blom_importflds(fldlist_num, fldlist) call chksummsk(nsf_da(1-nbdy,1-nbdy,l2ci),ip,1,'nsf') call chksummsk(hmlt_da(1-nbdy,1-nbdy,l2ci),ip,1,'hmlt') call chksummsk(slp_da(1-nbdy,1-nbdy,l2ci),ip,1,'slp') - call chksummsk(ficem_da(1-nbdy,1-nbdy,l2ci),ip,1,'ficem') call chksummsk(abswnd_da(1-nbdy,1-nbdy,l2ci),ip,1,'abswnd') + call chksummsk(ficem_da(1-nbdy,1-nbdy,l2ci),ip,1,'ficem') call chksummsk(atmco2_da(1-nbdy,1-nbdy,l2ci),ip,1,'atmco2') call chksummsk(atmbrf_da(1-nbdy,1-nbdy,l2ci),ip,1,'atmbrf') endif diff --git a/phy/mod_difest.F b/phy/mod_difest.F index e661e8ba..d7aed04b 100644 --- a/phy/mod_difest.F +++ b/phy/mod_difest.F @@ -214,6 +214,8 @@ subroutine init_difest c --- ------------------------------------------------------------------ c --- Initialize CVmix variables. c --- ------------------------------------------------------------------ +c + integer :: i,j,l c c -- ------- Background diapycnal mixing. c The Bryan-Lewis parameterization is based on the following: @@ -283,6 +285,15 @@ subroutine init_difest c . lnoDGat1=.true. , c . CVMix_kpp_params_user=KPP_params ) c +c$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)) + OBLdepth(i,j)=10. + enddo + enddo + enddo +c$OMP END PARALLEL DO c end subroutine init_difest c diff --git a/phy/mod_forcing.F90 b/phy/mod_forcing.F90 index c000d28c..64b546b3 100644 --- a/phy/mod_forcing.F90 +++ b/phy/mod_forcing.F90 @@ -106,6 +106,10 @@ module mod_forcing ustarw, & ! Friction velocity for open water [m s-1]. slp, & ! Sea-level pressure [kg m-1 s-2]. abswnd, & ! Wind speed at measurement height (zu) [m s-1]. + lamult, & ! Langmuir enhancement factor []. + lasl, & ! Surface layer averaged Langmuir number []. + ustokes, & ! u-component of surface Stokes drift [m s-1]. + vstokes, & ! v-component of surface Stokes drift [m s-1]. atmco2, & ! Atmospheric CO2 concentration [ppm]. flxco2, & ! Air-sea CO2 flux [kg m-2 s-1]. flxdms, & ! Sea-air DMS flux [kg m-2 s-1]. @@ -138,7 +142,8 @@ module mod_forcing sref, tflxap, sflxap, tflxdi, sflxdi, nflxdi, & sstclm, ricclm, sssclm, prfac, eiacc, pracc, & swa, nsf, hmltfz, lip, sop, eva, rnf, rfi, fmltfz, sfl, ztx, mty, & - ustarw, slp, abswnd, atmco2, flxco2, flxdms, flxbrf, atmbrf, & + ustarw, slp, abswnd, lamult, lasl, ustokes, vstokes, & + atmco2, flxco2, flxdms, flxbrf, atmbrf, & surflx, surrlx, sswflx, salflx, brnflx, salrlx, taux, tauy, & ustar, ustarb, ustar3, buoyfl, t_sw_nonloc, & inivar_forcing, fwbbal @@ -172,6 +177,10 @@ subroutine inivar_forcing ustarw(i, j) = spval slp(i, j) = spval abswnd(i, j) = spval + lamult(i, j) = spval + lasl(i, j) = spval + ustokes(i, j) = spval + vstokes(i, j) = spval atmco2(i, j) = spval flxco2(i, j) = spval flxdms(i, j) = spval From 0e16e61e06f48798801ccbd2173743b62b570a6e Mon Sep 17 00:00:00 2001 From: Mats Bentsen Date: Thu, 15 Sep 2022 19:32:06 +0200 Subject: [PATCH 162/366] Renamed folder for MCT driver. --- cime_config/buildlib_2.1 | 2 +- cime_config/buildlib_2.2 | 2 +- drivers/{cpl_mct => mct}/domain_mct.F | 0 drivers/{cpl_mct => mct}/export_mct.F | 0 drivers/{cpl_mct => mct}/external_abort.F | 0 drivers/{cpl_mct => mct}/getprecipfact_mct.F | 0 drivers/{cpl_mct => mct}/import_mct.F | 0 drivers/{cpl_mct => mct}/mod_swtfrz.F | 0 drivers/{cpl_mct => mct}/ocn_comp_mct.F90 | 0 drivers/{cpl_mct => mct}/setlogunit.F | 0 drivers/{cpl_mct => mct}/sumsbuff_mct.F | 0 11 files changed, 2 insertions(+), 2 deletions(-) rename drivers/{cpl_mct => mct}/domain_mct.F (100%) rename drivers/{cpl_mct => mct}/export_mct.F (100%) rename drivers/{cpl_mct => mct}/external_abort.F (100%) rename drivers/{cpl_mct => mct}/getprecipfact_mct.F (100%) rename drivers/{cpl_mct => mct}/import_mct.F (100%) rename drivers/{cpl_mct => mct}/mod_swtfrz.F (100%) rename drivers/{cpl_mct => mct}/ocn_comp_mct.F90 (100%) rename drivers/{cpl_mct => mct}/setlogunit.F (100%) rename drivers/{cpl_mct => mct}/sumsbuff_mct.F (100%) diff --git a/cime_config/buildlib_2.1 b/cime_config/buildlib_2.1 index 99f5315d..758cb28b 100755 --- a/cime_config/buildlib_2.1 +++ b/cime_config/buildlib_2.1 @@ -82,7 +82,7 @@ def _main_func(): expect(driver != "nuopc", "NUOPC driver not supported") if driver == "mct": paths.append(os.path.join(comp_root_dir_ocn, "drivers", "cpl_share")) - paths.append(os.path.join(comp_root_dir_ocn, "drivers", "cpl_mct")) + paths.append(os.path.join(comp_root_dir_ocn, "drivers", "mct")) with open(filepath_file, "w") as filepath: filepath.write("\n".join(paths)) diff --git a/cime_config/buildlib_2.2 b/cime_config/buildlib_2.2 index 3b800c15..2facb5a3 100755 --- a/cime_config/buildlib_2.2 +++ b/cime_config/buildlib_2.2 @@ -82,7 +82,7 @@ def _main_func(): if driver == "mct": paths.append(os.path.join(comp_root_dir_ocn, "drivers", "cpl_share")) - paths.append(os.path.join(comp_root_dir_ocn, "drivers", "cpl_mct")) + paths.append(os.path.join(comp_root_dir_ocn, "drivers", "mct")) elif driver == "nuopc": paths.append(os.path.join(comp_root_dir_ocn, "drivers", "nuopc")) else: diff --git a/drivers/cpl_mct/domain_mct.F b/drivers/mct/domain_mct.F similarity index 100% rename from drivers/cpl_mct/domain_mct.F rename to drivers/mct/domain_mct.F diff --git a/drivers/cpl_mct/export_mct.F b/drivers/mct/export_mct.F similarity index 100% rename from drivers/cpl_mct/export_mct.F rename to drivers/mct/export_mct.F diff --git a/drivers/cpl_mct/external_abort.F b/drivers/mct/external_abort.F similarity index 100% rename from drivers/cpl_mct/external_abort.F rename to drivers/mct/external_abort.F diff --git a/drivers/cpl_mct/getprecipfact_mct.F b/drivers/mct/getprecipfact_mct.F similarity index 100% rename from drivers/cpl_mct/getprecipfact_mct.F rename to drivers/mct/getprecipfact_mct.F diff --git a/drivers/cpl_mct/import_mct.F b/drivers/mct/import_mct.F similarity index 100% rename from drivers/cpl_mct/import_mct.F rename to drivers/mct/import_mct.F diff --git a/drivers/cpl_mct/mod_swtfrz.F b/drivers/mct/mod_swtfrz.F similarity index 100% rename from drivers/cpl_mct/mod_swtfrz.F rename to drivers/mct/mod_swtfrz.F diff --git a/drivers/cpl_mct/ocn_comp_mct.F90 b/drivers/mct/ocn_comp_mct.F90 similarity index 100% rename from drivers/cpl_mct/ocn_comp_mct.F90 rename to drivers/mct/ocn_comp_mct.F90 diff --git a/drivers/cpl_mct/setlogunit.F b/drivers/mct/setlogunit.F similarity index 100% rename from drivers/cpl_mct/setlogunit.F rename to drivers/mct/setlogunit.F diff --git a/drivers/cpl_mct/sumsbuff_mct.F b/drivers/mct/sumsbuff_mct.F similarity index 100% rename from drivers/cpl_mct/sumsbuff_mct.F rename to drivers/mct/sumsbuff_mct.F From 8a7223a4b268f8031ae5e5d04064fb59d3f3913a Mon Sep 17 00:00:00 2001 From: Mats Bentsen Date: Thu, 15 Sep 2022 19:44:32 +0200 Subject: [PATCH 163/366] Moved MCT specific file from drivers/cpl_share/ to drivers/mct/. --- cime_config/buildlib_2.1 | 1 - cime_config/buildlib_2.2 | 1 - drivers/{cpl_share => mct}/blom_cpl_indices.F90 | 0 3 files changed, 2 deletions(-) rename drivers/{cpl_share => mct}/blom_cpl_indices.F90 (100%) diff --git a/cime_config/buildlib_2.1 b/cime_config/buildlib_2.1 index 758cb28b..a46abbdd 100755 --- a/cime_config/buildlib_2.1 +++ b/cime_config/buildlib_2.1 @@ -81,7 +81,6 @@ def _main_func(): expect(driver != "nuopc", "NUOPC driver not supported") if driver == "mct": - paths.append(os.path.join(comp_root_dir_ocn, "drivers", "cpl_share")) paths.append(os.path.join(comp_root_dir_ocn, "drivers", "mct")) with open(filepath_file, "w") as filepath: diff --git a/cime_config/buildlib_2.2 b/cime_config/buildlib_2.2 index 2facb5a3..d069e2eb 100755 --- a/cime_config/buildlib_2.2 +++ b/cime_config/buildlib_2.2 @@ -81,7 +81,6 @@ def _main_func(): expect(False, "tracer module {} is not recognized".format(module)) if driver == "mct": - paths.append(os.path.join(comp_root_dir_ocn, "drivers", "cpl_share")) paths.append(os.path.join(comp_root_dir_ocn, "drivers", "mct")) elif driver == "nuopc": paths.append(os.path.join(comp_root_dir_ocn, "drivers", "nuopc")) diff --git a/drivers/cpl_share/blom_cpl_indices.F90 b/drivers/mct/blom_cpl_indices.F90 similarity index 100% rename from drivers/cpl_share/blom_cpl_indices.F90 rename to drivers/mct/blom_cpl_indices.F90 From 52863556e236f0c0e912b5cdb57708e34e6a9ede Mon Sep 17 00:00:00 2001 From: Mats Bentsen Date: Thu, 15 Sep 2022 20:40:59 +0200 Subject: [PATCH 164/366] Rename drivers/mct/mod_swtfrz.F to drivers/mct/mod_swtfrz.F90. --- drivers/mct/{mod_swtfrz.F => mod_swtfrz.F90} | 0 1 file changed, 0 insertions(+), 0 deletions(-) rename drivers/mct/{mod_swtfrz.F => mod_swtfrz.F90} (100%) diff --git a/drivers/mct/mod_swtfrz.F b/drivers/mct/mod_swtfrz.F90 similarity index 100% rename from drivers/mct/mod_swtfrz.F rename to drivers/mct/mod_swtfrz.F90 From 0003695046f3972c3866f528384eb91a40bbf1e1 Mon Sep 17 00:00:00 2001 From: Mats Bentsen Date: Thu, 15 Sep 2022 20:42:13 +0200 Subject: [PATCH 165/366] Rewrite to drivers/mct/mod_swtfrz.F90 to free format Fortran. --- drivers/mct/mod_swtfrz.F90 | 121 +++++++++++++++++-------------------- 1 file changed, 54 insertions(+), 67 deletions(-) diff --git a/drivers/mct/mod_swtfrz.F90 b/drivers/mct/mod_swtfrz.F90 index fd623993..d5209eeb 100644 --- a/drivers/mct/mod_swtfrz.F90 +++ b/drivers/mct/mod_swtfrz.F90 @@ -1,5 +1,5 @@ ! ------------------------------------------------------------------------------ -! Copyright (C) 2018-2020 Mats Bentsen +! Copyright (C) 2018-2022 Mats Bentsen ! ! This file is part of BLOM. ! @@ -17,78 +17,65 @@ ! along with BLOM. If not, see . ! ------------------------------------------------------------------------------ - module mod_swtfrz -c -c --- ------------------------------------------------------------------ -c --- This module contains routines for computing the freezing point of -c --- sea water. -c --- ------------------------------------------------------------------ -c - use mod_types, only: r8 - use shr_frz_mod, only: shr_frz_freezetemp -c - implicit none -c - private -c - public :: swtfrz -c - interface swtfrz - module procedure swtfrz_0d - module procedure swtfrz_1d - module procedure swtfrz_2d - end interface swtfrz -c - contains -c -c --- ------------------------------------------------------------------ -c - function swtfrz_0d(p,s) result(swtfrz) -c -c --- ------------------------------------------------------------------ -c --- Retrieve freezing temperature from shared CESM function. -c --- ------------------------------------------------------------------ -c +module mod_swtfrz +! ------------------------------------------------------------------------------ +! This module contains routines for computing the freezing point of sea water. +! ------------------------------------------------------------------------------ + + use mod_types, only: r8 + use shr_frz_mod, only: shr_frz_freezetemp + + implicit none + + private + + public :: swtfrz + + interface swtfrz + module procedure swtfrz_0d + module procedure swtfrz_1d + module procedure swtfrz_2d + end interface swtfrz + +contains + + function swtfrz_0d(p,s) result(swtfrz) + ! --------------------------------------------------------------------------- + ! Retrieve freezing temperature from shared CESM function. + ! --------------------------------------------------------------------------- + real(r8), intent(in) :: p ! Pressure [g cm-1 s-2] real(r8), intent(in) :: s ! Salinity [g kg-1] real(r8) :: swtfrz -c - swtfrz=shr_frz_freezetemp(s) -c - end function swtfrz_0d -c -c --- ------------------------------------------------------------------ -c - function swtfrz_1d(p,s) result(swtfrz) -c -c --- ------------------------------------------------------------------ -c --- Retrieve freezing temperature from shared CESM function. -c --- ------------------------------------------------------------------ -c + + swtfrz = shr_frz_freezetemp(s) + + end function swtfrz_0d + + function swtfrz_1d(p,s) result(swtfrz) + ! --------------------------------------------------------------------------- + ! Retrieve freezing temperature from shared CESM function. + ! --------------------------------------------------------------------------- + real(r8), intent(in) :: p(:) ! Pressure [g cm-1 s-2] real(r8), intent(in) :: s(:) ! Salinity [g kg-1] real(r8) :: swtfrz(size(s)) -c - swtfrz(:)=shr_frz_freezetemp(s(:)) -c - end function swtfrz_1d -c -c --- ------------------------------------------------------------------ -c - function swtfrz_2d(p,s) result(swtfrz) -c -c --- ------------------------------------------------------------------ -c --- Retrieve freezing temperature from shared CESM function. -c --- ------------------------------------------------------------------ -c + + swtfrz(:) = shr_frz_freezetemp(s(:)) + + end function swtfrz_1d + + function swtfrz_2d(p,s) result(swtfrz) + ! --------------------------------------------------------------------------- + ! Retrieve freezing temperature from shared CESM function. + ! --------------------------------------------------------------------------- + real(r8), intent(in) :: p(:,:) ! Pressure [g cm-1 s-2] real(r8), intent(in) :: s(:,:) ! Salinity [g kg-1] real(r8) :: swtfrz(size(s,1),size(s,2)) -c - swtfrz(:,:)=shr_frz_freezetemp(s(:,:)) -c - end function swtfrz_2d -c -c --- ------------------------------------------------------------------ -c - end module mod_swtfrz + + swtfrz(:,:) = shr_frz_freezetemp(s(:,:)) + + end function swtfrz_2d + +end module mod_swtfrz From 1d4974654f871cc00c9a4063cb41f6813e4010d2 Mon Sep 17 00:00:00 2001 From: jmaerz <92309038+jmaerz@users.noreply.github.com> Date: Tue, 20 Sep 2022 10:37:34 +0200 Subject: [PATCH 166/366] Merging master into beyond-CMIP6 (#196) --- cime_config/buildnml | 16 ++++++ hamocc/bodensed.F90 | 96 +++++++++++++++++++++++++-------- hamocc/dipowa.F90 | 52 ++++++------------ hamocc/hamocc_init.F90 | 16 ++++-- hamocc/inventory_bgc.F90 | 8 +-- hamocc/meson.build | 1 + hamocc/mo_control_bgc.F90 | 3 +- hamocc/mo_param1_bgc.F90 | 89 ++++++++++++++++++------------- hamocc/mo_read_sedpor.F90 | 108 ++++++++++++++++++++++++++++++++++++++ hamocc/mo_sedmnt.F90 | 77 +++++++++++++++++++++++++-- hamocc/powach.F90 | 88 +++++++++++++------------------ hamocc/powadi.F90 | 12 ++--- hamocc/sedshi.F90 | 12 ++--- 13 files changed, 408 insertions(+), 170 deletions(-) create mode 100644 hamocc/mo_read_sedpor.F90 diff --git a/cime_config/buildnml b/cime_config/buildnml index 6f3c1e30..bd3d33a3 100755 --- a/cime_config/buildnml +++ b/cime_config/buildnml @@ -237,6 +237,9 @@ set OALKSCEN = "''" set OALKFILE = "''" set WITH_DMSPH = .false. set PI_PH_FILE = "''" +set L_3DVARSEDPOR = .false. +set SEDPORFILE = "''" + # set DIAPHY defaults set GLB_FNAMETAG = "'hd','hm','hy'" @@ -706,6 +709,7 @@ if ($OCN_GRID == tnx2v1) then set SCFILE = "'$DIN_LOC_ROOT/ocn/blom/bndcon/sss_clim_core_tnx2v1_20130927.nc'" set FEDEPFILE = "'$DIN_LOC_ROOT/ocn/blom/bndcon/dustdep_mhw2006_tnx2v1_20130506.nc'" set SWACLIMFILE = "''" + set SEDPORFILE = "''" if ($BLOM_RIVER_NUTRIENTS == TRUE) then set RIVINFILE = "'$DIN_LOC_ROOT/ocn/blom/bndcon/river_nutrients_GNEWS2000_tnx2v1_20170915.nc'" else @@ -726,6 +730,7 @@ else if ($OCN_GRID == tnx1v4) then set CCFILE = "'$DIN_LOC_ROOT/ocn/blom/bndcon/chlorophyll_concentration_tnx1v4_20170608.nc'" set SCFILE = "'$DIN_LOC_ROOT/ocn/blom/bndcon/sss_clim_core_tnx1v4_20170604.nc'" set FEDEPFILE = "'$DIN_LOC_ROOT/ocn/blom/bndcon/dustdep_mhw2006_tnx1v4_20171107.nc'" + set SEDPORFILE = "''" if ($HAMOCC_VSLS == TRUE) then set SWACLIMFILE = "'$DIN_LOC_ROOT/ocn/blom/bndcon/Annual_clim_swa_tnx1v4_20210415.nc'" else @@ -752,6 +757,7 @@ else if ($OCN_GRID == tnx0.25v4) then set SCFILE = "'$DIN_LOC_ROOT/ocn/blom/bndcon/sss_clim_core_tnx0.25v4_20170623.nc'" set FEDEPFILE = "'$DIN_LOC_ROOT/ocn/blom/bndcon/dustdep_mhw2006_tnx0.25v4_20181004.nc'" set SWACLIMFILE = "''" + set SEDPORFILE = "''" if ($BLOM_RIVER_NUTRIENTS == TRUE) then set RIVINFILE = "'$DIN_LOC_ROOT/ocn/blom/bndcon/river_nutrients_GNEWS2000_tnx0.25v4_20170821.nc'" else @@ -773,6 +779,7 @@ else if ($OCN_GRID == tnx0.125v4) then set SCFILE = "'$DIN_LOC_ROOT/ocn/blom/bndcon/sss_clim_core_tnx0.125v4_20200722.nc'" set FEDEPFILE = "'$DIN_LOC_ROOT/ocn/blom/bndcon/dustdep_mhw2006_tnx0.125v4_20200722.nc'" set SWACLIMFILE = "''" + set SEDPORFILE = "''" if ($BLOM_RIVER_NUTRIENTS == TRUE) then set RIVINFILE = "'$DIN_LOC_ROOT/ocn/blom/bndcon/river_nutrients_GNEWS2000_tnx0.125v4_20170821.nc'" else @@ -1445,6 +1452,8 @@ cat >>! $RUNDIR/ocn_in$inststr << EOF ! OXY, NO3, SIL, D13C, and D14C ! WITH_DMSPH : Logical switch to activate DMS calculation as function of pH ! PI_PH_FILE : File name (incl. full path) for surface PI pH input data. +! L_3DVARSEDPOR : Logical switch to enable lon-lat-depth variable sediment porosity (as opposed to default: only depth) +! SEDPORFILE : File name (incl. full path) for sediment porosity &BGCNML ATM_CO2 = $CCSM_CO2_PPMV FEDEPFILE = $FEDEPFILE @@ -1470,6 +1479,8 @@ cat >>! $RUNDIR/ocn_in$inststr << EOF INID14C = $INID14C WITH_DMSPH = $WITH_DMSPH PI_PH_FILE = $PI_PH_FILE + L_3DVARSEDPOR = $L_3DVARSEDPOR + SEDPORFILE = $SEDPORFILE / ! IO-NAMELIST FOR DIAGNOSTIC iHAMOCC OUTPUT @@ -1871,6 +1882,11 @@ EOF if ($HAMOCC_VSLS == TRUE) then cat >> $CASEBUILD/blom.input_data_list << EOF swa_clim_file = `echo $SWACLIMFILE | tr -d '"' | tr -d "'"` +EOF + endif + if ($L_3DVARSEDPOR == TRUE) then +cat >> $CASEBUILD/blom.input_data_list << EOF +sed_porosity_file = `echo $SEDPORFILE | tr -d '"' | tr -d "'"` EOF endif endif diff --git a/hamocc/bodensed.F90 b/hamocc/bodensed.F90 index 99bc782a..74cb9335 100644 --- a/hamocc/bodensed.F90 +++ b/hamocc/bodensed.F90 @@ -17,7 +17,7 @@ ! along with BLOM. If not, see https://www.gnu.org/licenses/. -subroutine bodensed(kpie,kpje,kpke,pddpo) +subroutine bodensed(kpie,kpje,kpke,pddpo,omask,sed_por) !********************************************************************** ! !**** *BODENSED* - . @@ -44,8 +44,8 @@ subroutine bodensed(kpie,kpje,kpke,pddpo) !********************************************************************** use mo_sedmnt, only: calcwei,calfa,clafa,claydens,calcdens,opaldens,opalwei,oplfa,orgdens,orgfa,seddzi,porwat,porwah, & - & porsol,dzs,seddw,sedict,solfu,orgwei - use mo_control_bgc, only: dtbgc,io_stdo_bgc + & porsol,dzs,seddw,sedict,solfu,orgwei,zcoefsu,zcoeflo,disso_sil,silsat,disso_poc,sed_denit,disso_caco3 + use mo_control_bgc, only: dtbgc,io_stdo_bgc,l_3Dvarsedpor use mo_param1_bgc, only: ks use mod_xc, only: mnproc @@ -53,6 +53,8 @@ subroutine bodensed(kpie,kpje,kpke,pddpo) integer, intent(in) :: kpie,kpje,kpke real, intent(in) :: pddpo(kpie,kpje,kpke) + real, intent(in) :: omask(kpie,kpje) + real, intent(in) :: sed_por(kpie,kpje,ks) ! Local variables integer :: i,j,k @@ -79,33 +81,68 @@ subroutine bodensed(kpie,kpje,kpke,pddpo) write(io_stdo_bgc,*) ' ' endif - porwat(1) = 0.85 - porwat(2) = 0.83 - porwat(3) = 0.8 - porwat(4) = 0.79 - porwat(5) = 0.77 - porwat(6) = 0.75 - porwat(7) = 0.73 - porwat(8) = 0.7 - porwat(9) = 0.68 - porwat(10) = 0.66 - porwat(11) = 0.64 - porwat(12) = 0.62 + ! this initialization can be done later via reading a porosity map + if (l_3Dvarsedpor)then + ! lon-lat variable sediment porosity from input file + do k=1,ks + do j=1,kpje + do i=1,kpie + if(omask(i,j).gt. 0.5)then + porwat(i,j,k) = sed_por(i,j,k) + endif + enddo + enddo + enddo + else + porwat(:,:,1) = 0.85 + porwat(:,:,2) = 0.83 + porwat(:,:,3) = 0.8 + porwat(:,:,4) = 0.79 + porwat(:,:,5) = 0.77 + porwat(:,:,6) = 0.75 + porwat(:,:,7) = 0.73 + porwat(:,:,8) = 0.7 + porwat(:,:,9) = 0.68 + porwat(:,:,10) = 0.66 + porwat(:,:,11) = 0.64 + porwat(:,:,12) = 0.62 + endif if (mnproc == 1) then - write(io_stdo_bgc,*) 'Pore water in sediment: ',porwat + write(io_stdo_bgc,*) 'Pore water in sediment initialized' endif seddzi(1) = 500. do k = 1, ks - porsol(k) = 1. - porwat(k) - if(k >= 2) porwah(k) = 0.5 * (porwat(k) + porwat(k-1)) - if(k == 1) porwah(k) = 0.5 * (1. + porwat(1)) seddzi(k+1) = 1. / dzs(k+1) seddw(k) = 0.5 * (dzs(k) + dzs(k+1)) + do j = 1, kpje + do i = 1, kpie + porsol(i,j,k) = 1. - porwat(i,j,k) + if(k >= 2) porwah(i,j,k) = 0.5 * (porwat(i,j,k) + porwat(i,j,k-1)) + if(k == 1) porwah(i,j,k) = 0.5 * (1. + porwat(i,j,1)) + enddo + enddo enddo + + sedict = 1.e-9 * dtbgc ! Molecular diffusion coefficient + ! Dissolution rate constant of opal (disso) [1/(kmol Si(OH)4/m3)*1/sec] + ! THIS NEEDS TO BE CHANGED TO disso=3.e-8! THIS IS ONLY KEPT FOR THE MOMENT + ! FOR BACKWARDS COMPATIBILITY + !disso_sil = 3.e-8*dtbgc ! (2011-01-04) EMR + !disso_sil = 1.e-6*dtbgc ! test vom 03.03.04 half live sil ca. 20.000 yr + disso_sil = 1.e-6*dtbgc + ! Silicate saturation concentration is 1 mol/m3 + silsat = 0.001 + + ! Degradation rate constant of POP (disso) [1/(kmol O2/m3)*1/sec] + disso_poc = 0.01 / 86400. * dtbgc ! disso=3.e-5 was quite high - sedict = 1.e-9 * dtbgc + ! Denitrification rate constant of POP (disso) [1/sec] + sed_denit = 0.01/86400. * dtbgc + + ! Dissolution rate constant of CaCO3 (disso) [1/(kmol CO3--/m3)*1/sec] + disso_caco3 = 1.e-7 * dtbgc ! ****************************************************************** ! densities etc. for SEDIMENT SHIFTING @@ -131,9 +168,26 @@ subroutine bodensed(kpie,kpje,kpke,pddpo) ! determine total solid sediment volume solfu = 0. + do i = 1, kpie + do j = 1, kpje do k = 1, ks - solfu = solfu + seddw(k) * porsol(k) + solfu(i,j) = solfu(i,j) + seddw(k) * porsol(i,j,k) + enddo + enddo enddo +! Initialize porosity-dependent diffusion coefficients of sediment + zcoefsu(:,:,0) = 0.0 + do k = 1,ks + do j = 1, kpje + do i = 1, kpie + ! sediment diffusion coefficient * 1/dz * fraction of pore water at half depths + zcoefsu(i,j,k ) = -sedict * seddzi(k) * porwah(i,j,k) + zcoeflo(i,j,k-1) = -sedict * seddzi(k) * porwah(i,j,k) ! why the same ? + enddo + enddo + enddo + zcoeflo(:,:,ks) = 0.0 ! diffusion coefficient for bottom sediment layer + end subroutine bodensed diff --git a/hamocc/dipowa.F90 b/hamocc/dipowa.F90 index 18cf5dae..e6fb22a2 100644 --- a/hamocc/dipowa.F90 +++ b/hamocc/dipowa.F90 @@ -56,8 +56,8 @@ subroutine dipowa(kpie,kpje,kpke,omask,lspin) !********************************************************************** use mo_carbch, only: ocetra, sedfluxo - use mo_sedmnt, only: powtra,porwat,porwah,sedict,seddw,seddzi - use mo_param1_bgc, only: ks,npowtra + use mo_sedmnt, only: powtra,porwat,porwah,sedict,seddw,seddzi,zcoefsu,zcoeflo + use mo_param1_bgc, only: ks,npowtra,map_por2octra use mo_vgrid, only: kbo,bolay #ifdef cisonew use mo_param1_bgc, only: ipowc13,ipowc14,isco213,isco214 @@ -77,7 +77,6 @@ subroutine dipowa(kpie,kpje,kpke,omask,lspin) integer :: iv_oc ! index of ocetra in powtra loop real :: sedb1(kpie,0:ks,npowtra) ! ???? - real :: zcoefsu(0:ks),zcoeflo(0:ks) ! diffusion coefficients (upper/lower) real :: tredsy(kpie,0:kpke,3) ! redsy for 'reduced system'? real :: aprior ! start value of oceanic tracer in bottom layer @@ -85,14 +84,6 @@ subroutine dipowa(kpie,kpje,kpke,omask,lspin) !ik needed for boundary layer ventilation in fast sediment routine real :: bolven(kpie) ! bottom layer ventilation rate - zcoefsu(0) = 0.0 - do k = 1,ks - ! sediment diffusion coefficient * 1/dz * fraction of pore water at half depths - zcoefsu(k ) = -sedict * seddzi(k) * porwah(k) - zcoeflo(k-1) = -sedict * seddzi(k) * porwah(k) ! why the same ? - enddo - zcoeflo(ks) = 0.0 ! diffusion coefficient for bottom sediment layer - !$OMP PARALLEL DO & !$OMP&PRIVATE(i,k,iv,l,bolven,tredsy,sedb1,aprior,iv_oc) j_loop: do j=1,kpje @@ -104,19 +95,15 @@ subroutine dipowa(kpie,kpje,kpke,omask,lspin) k = 0 do i = 1,kpie - tredsy(i,k,1) = zcoefsu(k) - tredsy(i,k,3) = zcoeflo(k) + tredsy(i,k,1) = zcoefsu(i,j,k) + tredsy(i,k,3) = zcoeflo(i,j,k) tredsy(i,k,2) = bolven(i)*bolay(i,j) - tredsy(i,k,1) - tredsy(i,k,3) ! dz(kbo) - diff upper - diff lower enddo k = 0 do iv = 1,npowtra ! loop over pore water tracers - iv_oc = iv -#ifdef cisonew - if (iv == ipowc13) iv_oc = isco213 - if (iv == ipowc14) iv_oc = isco214 -#endif + iv_oc = map_por2octra(iv) do i = 1,kpie sedb1(i,k,iv) = 0. if (omask(i,j) > 0.5) then @@ -128,9 +115,9 @@ subroutine dipowa(kpie,kpje,kpke,omask,lspin) do k = 1,ks do i = 1,kpie - tredsy(i,k,1) = zcoefsu(k) - tredsy(i,k,3) = zcoeflo(k) - tredsy(i,k,2) = seddw(k)*porwat(k) -tredsy(i,k,1) -tredsy(i,k,3) + tredsy(i,k,1) = zcoefsu(i,j,k) + tredsy(i,k,3) = zcoeflo(i,j,k) + tredsy(i,k,2) = seddw(k)*porwat(i,j,k) -tredsy(i,k,1) -tredsy(i,k,3) enddo enddo @@ -138,7 +125,7 @@ subroutine dipowa(kpie,kpje,kpke,omask,lspin) do k = 1,ks do i = 1,kpie ! tracer_concentration(k[1:ks]) * porewater fraction(k) * dz(k) - sedb1(i,k,iv) = powtra(i,j,k,iv) * porwat(k) * seddw(k) + sedb1(i,k,iv) = powtra(i,j,k,iv) * porwat(i,j,k) * seddw(k) enddo enddo enddo @@ -190,16 +177,8 @@ subroutine dipowa(kpie,kpje,kpke,omask,lspin) if(.not. lspin) THEN ! sediment ocean interface -! -! CAUTION - the following assumes same indecees for ocetra and powtra -! test npowa_base 071106 -! check mo_param1_bgc.f90 for consistency do iv = 1, npowtra - iv_oc = iv -#ifdef cisonew - if (iv == ipowc13) iv_oc=isco213 - if (iv == ipowc14) iv_oc=isco214 -#endif + iv_oc = map_por2octra(iv) do i = 1,kpie l = 0 if (omask(i,j) > 0.5) then @@ -210,14 +189,15 @@ subroutine dipowa(kpie,kpje,kpke,omask,lspin) ! diffusive fluxes (positive downward) sedfluxo(i,j,iv) = sedfluxo(i,j,iv) & - & -(ocetra(i,j,kbo(i,j),iv) - aprior)* bolay(i,j) + & -(ocetra(i,j,kbo(i,j),iv_oc) - aprior)* bolay(i,j) #ifdef natDIC - if (iv==isco212) ocetra(i,j,kbo(i,j),inatsco212) = & + ! workaround as long as natDIC is not implemented throughout the sediment module + if (iv_oc==isco212) ocetra(i,j,kbo(i,j),inatsco212) = & & ocetra(i,j,kbo(i,j),inatsco212) + & - & ocetra(i,j,kbo(i,j),iv) - aprior - if (iv==ialkali) ocetra(i,j,kbo(i,j),inatalkali) = & + & ocetra(i,j,kbo(i,j),isco212) - aprior + if (iv_oc==ialkali) ocetra(i,j,kbo(i,j),inatalkali) = & & ocetra(i,j,kbo(i,j),inatalkali) + & - & ocetra(i,j,kbo(i,j),iv) - aprior + & ocetra(i,j,kbo(i,j),ialkali) - aprior #endif endif enddo diff --git a/hamocc/hamocc_init.F90 b/hamocc/hamocc_init.F90 index c8af2b31..f7f2dcf3 100644 --- a/hamocc/hamocc_init.F90 +++ b/hamocc/hamocc_init.F90 @@ -46,8 +46,8 @@ subroutine hamocc_init(read_rest,rstfnm_hamocc) & do_ndep,do_rivinpt,do_oalk,do_sedspinup, & & sedspin_yr_s,sedspin_yr_e,sedspin_ncyc, & & dtb,dtbgc,io_stdo_bgc,ldtbgc, & - & ldtrunbgc,ndtdaybgc,with_dmsph - use mo_param1_bgc, only: ks,nsedtra,npowtra + & ldtrunbgc,ndtdaybgc,with_dmsph,l_3Dvarsedpor + use mo_param1_bgc, only: ks,nsedtra,npowtra,init_por2octra_mapping use mo_carbch, only: alloc_mem_carbch,ocetra,atm,atm_co2 use mo_biomod, only: alloc_mem_biomod use mo_sedmnt, only: alloc_mem_sedmnt,sedlay,powtra,burial @@ -58,6 +58,7 @@ subroutine hamocc_init(read_rest,rstfnm_hamocc) use mo_read_ndep, only: ini_read_ndep,ndepfile use mo_read_oafx, only: ini_read_oafx,oalkfile,oalkscen use mo_read_pi_ph, only: ini_pi_ph,pi_ph_file + use mo_read_sedpor, only: read_sedpor,sedporfile use mo_clim_swa, only: ini_swa_clim,swaclimfile use mo_Gdata_read, only: inidic,inialk,inipo4,inioxy,inino3, & & inisil,inid13c,inid14c @@ -76,13 +77,14 @@ subroutine hamocc_init(read_rest,rstfnm_hamocc) integer :: i,j,k,l,nt integer :: iounit + real :: sed_por(idm,jdm,ks) = 0. namelist /bgcnml/ atm_co2,fedepfile,do_rivinpt,rivinfile,do_ndep,ndepfile, & & do_oalk,oalkscen,oalkfile,do_sedspinup,sedspin_yr_s, & & sedspin_yr_e,sedspin_ncyc, & & inidic,inialk,inipo4,inioxy,inino3,inisil, & & inid13c,inid14c,swaclimfile, & - & with_dmsph,pi_ph_file + & with_dmsph,pi_ph_file,l_3Dvarsedpor,sedporfile ! ! --- Set io units and some control parameters ! @@ -130,6 +132,9 @@ subroutine hamocc_init(read_rest,rstfnm_hamocc) endif ENDIF + ! init the index-mapping between pore water and ocean tracers + CALL init_por2octra_mapping() + ! ! --- Memory allocation ! @@ -171,8 +176,9 @@ subroutine hamocc_init(read_rest,rstfnm_hamocc) call set_vgrid(idm,jdm,kdm,bgc_dp) ! ! --- Initialize sediment layering - ! - CALL BODENSED(idm,jdm,kdm,bgc_dp) + ! First raed the porosity, then apply it in bodensed + CALL read_sedpor(idm,jdm,ks,omask,sed_por) + CALL BODENSED(idm,jdm,kdm,bgc_dp,omask,sed_por) ! ! --- Initialize parameters, sediment and ocean tracer. ! diff --git a/hamocc/inventory_bgc.F90 b/hamocc/inventory_bgc.F90 index 8ca17e61..c9f104f5 100644 --- a/hamocc/inventory_bgc.F90 +++ b/hamocc/inventory_bgc.F90 @@ -143,7 +143,7 @@ SUBROUTINE INVENTORY_BGC(kpie,kpje,kpke,dlxp,dlyp,ddpo,omask,iogrp) DO j=1,kpje DO i=1,kpie ztmp1(i,j) = ztmp1(i,j) + omask(i,j)*seddw(k) & - & *dlxp(i,j)*dlyp(i,j)*porwat(k) + & *dlxp(i,j)*dlyp(i,j)*porwat(i,j,k) ENDDO ENDDO ENDDO @@ -155,7 +155,7 @@ SUBROUTINE INVENTORY_BGC(kpie,kpje,kpke,dlxp,dlyp,ddpo,omask,iogrp) DO k=1,ks DO j=1,kpje DO i=1,kpie - vol = seddw(k)*dlxp(i,j)*dlyp(i,j)*porwat(k) + vol = seddw(k)*dlxp(i,j)*dlyp(i,j)*porwat(i,j,k) ztmp1(i,j)= ztmp1(i,j) + omask(i,j)*powtra(i,j,k,l)*vol ENDDO ENDDO @@ -174,7 +174,7 @@ SUBROUTINE INVENTORY_BGC(kpie,kpje,kpke,dlxp,dlyp,ddpo,omask,iogrp) DO k=1,ks DO j=1,kpje DO i=1,kpie - vol = porsol(k)*seddw(k)*dlxp(i,j)*dlyp(i,j) + vol = porsol(i,j,k)*seddw(k)*dlxp(i,j)*dlyp(i,j) ztmp1(i,j) = ztmp1(i,j) + omask(i,j)*sedlay(i,j,k,l)*vol ENDDO ENDDO @@ -187,7 +187,7 @@ SUBROUTINE INVENTORY_BGC(kpie,kpje,kpke,dlxp,dlyp,ddpo,omask,iogrp) DO k=1,ks DO j=1,kpje DO i=1,kpie - vol = porsol(k)*seddw(k)*dlxp(i,j)*dlyp(i,j) + vol = porsol(i,j,k)*seddw(k)*dlxp(i,j)*dlyp(i,j) ztmp1(i,j) = ztmp1(i,j) + omask(i,j)*sedhpl(i,j,k)*vol ENDDO ENDDO diff --git a/hamocc/meson.build b/hamocc/meson.build index ed3461de..acc6319d 100644 --- a/hamocc/meson.build +++ b/hamocc/meson.build @@ -34,6 +34,7 @@ sources += files( 'mo_read_pi_ph.F90', 'mo_read_rivin.F90', 'mo_read_oafx.F90', + 'mo_read_sedpor.F90', 'mo_sedmnt.F90', 'mo_vgrid.F90', 'ncout_hamocc.F90', diff --git a/hamocc/mo_control_bgc.F90 b/hamocc/mo_control_bgc.F90 index b59c19ee..c7058aa5 100644 --- a/hamocc/mo_control_bgc.F90 +++ b/hamocc/mo_control_bgc.F90 @@ -57,8 +57,9 @@ MODULE mo_control_bgc REAL, save :: rmasks = 0.0 ! value at wet cells in sediment. REAL, save :: rmasko = 99999.00 ! value at wet cells in ocean. - + ! Logical switches set via namelist + LOGICAL, save :: l_3Dvarsedpor = .false. ! apply lon-lat-depth variable sediment porosity via input file LOGICAL, save :: do_ndep =.true. ! apply n-deposition LOGICAL, save :: do_rivinpt =.true. ! apply riverine input LOGICAL, save :: do_sedspinup=.false. ! apply sediment spin-up diff --git a/hamocc/mo_param1_bgc.F90 b/hamocc/mo_param1_bgc.F90 index ade3a94e..7bc0c5c7 100644 --- a/hamocc/mo_param1_bgc.F90 +++ b/hamocc/mo_param1_bgc.F90 @@ -201,53 +201,70 @@ MODULE mo_param1_bgc & irdoc =6, & ! dissolved organic carbon & irdet =7 ! particulate carbon - -! sediment -#ifdef cisonew - INTEGER, PARAMETER :: nsedtra=8 + +! --- sediment + ! sediment solid components + INTEGER, PARAMETER :: i_sed_base = 4 INTEGER, PARAMETER :: issso12=1, & & isssc12=2, & & issssil=3, & - & issster=4, & - & issso13=5, & - & issso14=6, & - & isssc13=7, & - & isssc14=8 - -! pore water tracers, index should be the same as for ocetra - INTEGER, PARAMETER :: npowtra=9 - INTEGER, PARAMETER :: ipowaic=1, & - & ipowaal=2, & - & ipowaph=3, & - & ipowaox=4, & - & ipown2 =5, & - & ipowno3=6, & - & ipowasi=7, & - & ipowc13=8, & ! C-isotope idices do NOT correspond to ocetra! - & ipowc14=9 ! C-isotope idices do NOT correspond to ocetra! + & issster=4 +#ifdef cisonew + INTEGER, PARAMETER :: i_sed_cisonew = 4 + INTEGER, PARAMETER :: issso13 = i_sed_base+1, & + & issso14 = i_sed_base+2, & + & isssc13 = i_sed_base+3, & + & isssc14 = i_sed_base+4 #else - INTEGER, PARAMETER :: nsedtra=4 - INTEGER, PARAMETER :: issso12=1, & - & isssc12=2, & - & issssil=3, & - & issster=4, & - & issso13=-1, & - & issso14=-1, & - & isssc13=-1, & - & isssc14=-1 - -! pore water tracers, index should be the same as for ocetra - INTEGER, PARAMETER :: npowtra=7 + INTEGER, PARAMETER :: i_sed_cisonew = 0 + INTEGER, PARAMETER :: issso13 = -1, & + & issso14 = -1, & + & isssc13 = -1, & + & isssc14 = -1 +#endif + INTEGER, PARAMETER :: nsedtra = i_sed_base + i_sed_cisonew + + + ! sediment pore water components + INTEGER, PARAMETER :: i_pow_base=7 INTEGER, PARAMETER :: ipowaic=1, & & ipowaal=2, & & ipowaph=3, & & ipowaox=4, & & ipown2 =5, & & ipowno3=6, & - & ipowasi=7, & - & ipowc13=-1, & - & ipowc14=-1 + & ipowasi=7 +#ifdef cisonew + INTEGER, PARAMETER :: i_pow_cisonew = 2 + INTEGER, PARAMETER :: ipowc13=i_pow_base + 1, & + & ipowc14=i_pow_base + 2 +#else + INTEGER, PARAMETER :: i_pow_cisonew = 0 + INTEGER, PARAMETER :: ipowc13 = -1, & + & ipowc14 = -1 #endif + INTEGER, PARAMETER :: npowtra = i_pow_base + i_pow_cisonew + + ! Mapping between pore water and ocean tracers needed for pore water diffusion + INTEGER, SAVE :: map_por2octra(npowtra) + + contains + + subroutine init_por2octra_mapping() + + map_por2octra(ipowaic) = isco212 + map_por2octra(ipowaal) = ialkali + map_por2octra(ipowaph) = iphosph + map_por2octra(ipowaox) = ioxygen + map_por2octra(ipown2) = igasnit + map_por2octra(ipowno3) = iano3 + map_por2octra(ipowasi) = isilica + + ! if statements for non-base tracers + if(ipowc13 > 0) map_por2octra(ipowc13) = isco213 + if(ipowc14 > 0) map_por2octra(ipowc14) = isco214 + + end subroutine init_por2octra_mapping !****************************************************************************** END MODULE mo_param1_bgc diff --git a/hamocc/mo_read_sedpor.F90 b/hamocc/mo_read_sedpor.F90 new file mode 100644 index 00000000..6ea984c6 --- /dev/null +++ b/hamocc/mo_read_sedpor.F90 @@ -0,0 +1,108 @@ +! Copyright (C) 2020 S. Gao, I. Bethke, J. Tjiputra, J. Schwinger +! +! This file is part of BLOM/iHAMOCC. +! +! 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 https://www.gnu.org/licenses/. + +module mo_read_sedpor +!***************************************************************************** +! Purpose +! ------- +! - Routine for reading sediment porosity from netcdf file +! +! Description +! ----------- +! Public routines and variable of this module: +! +! - subroutine ini_read_sedpor +! read sediment porosity file +! +! L_SED_POR must be set to true in nml to activate +! lon-lat variable sediment porosity. +! +! The model attempts to read lon-lat-sediment depth variable porosity +! from the input file 'SEDPORFILE' (incl. full path) +! +! sed_por holds then the porosity that can be applied later +! via mo_apply_sedpor +! +!***************************************************************************** + +implicit none + +private + +public :: read_sedpor,sedporfile + +character(len=512),save :: sedporfile = '' + +contains + +subroutine read_sedpor(kpie,kpje,ks,omask,sed_por) + use mod_xc, only: mnproc,xchalt + use mod_dia, only: iotype + use mo_control_bgc, only: io_stdo_bgc,l_3Dvarsedpor + use mod_nctools, only: ncfopn,ncread,ncfcls + + implicit none + + integer, intent(in) :: kpie,kpje,ks + real, intent(in) :: omask(kpie,kpje) + real, intent(inout) :: sed_por(kpie,kpje,ks) + + !local variables + integer :: i,j,k,errstat,dummymask(2) + real :: sed_por_in(kpie,kpje,ks) + logical :: file_exists = .false. + + ! Return if l_3Dvarsedpor is turned off + if (.not. l_3Dvarsedpor) then + if (mnproc.eq.1) then + write(io_stdo_bgc,*) '' + write(io_stdo_bgc,*) 'read_sedpor: spatially variable sediment porosity is not activated.' + endif + return + endif + + ! Check if sediment porosity file exists. If not, abort. + inquire(file=sedporfile,exist=file_exists) + if (.not. file_exists .and. mnproc.eq.1) then + write(io_stdo_bgc,*) '' + write(io_stdo_bgc,*) 'read_sedpor: Cannot find sediment porosity file... ' + call xchalt('(read_sedpor)') + stop '(read_sedpor)' + endif + + ! read sediment porosity from file + if (mnproc.eq.1) then + write(io_stdo_bgc,*) '' + write(io_stdo_bgc,*) 'read_sedpor: read sediment porosity from ', & + trim(sedporfile) + endif + call ncfopn(trim(sedporfile),'r',' ',1,iotype) + call ncread('sedpor',sed_por_in,dummymask,0,0.) + call ncfcls + + do k=1,ks + do j=1,kpje + do i=1,kpie + if(omask(i,j).gt. 0.5)then + sed_por(i,j,k)=sed_por_in(i,j,k) + endif + enddo + enddo + enddo + +end subroutine read_sedpor +end module mo_read_sedpor diff --git a/hamocc/mo_sedmnt.F90 b/hamocc/mo_sedmnt.F90 index 1eb66ade..a1286f22 100644 --- a/hamocc/mo_sedmnt.F90 +++ b/hamocc/mo_sedmnt.F90 @@ -70,13 +70,16 @@ MODULE mo_sedmnt REAL, save :: dzs(ksp) = 0.0 REAL, save :: seddzi(ksp) = 0.0 REAL, save :: seddw(ks) = 0.0 - REAL, save :: porsol(ks) = 0.0 - REAL, save :: porwah(ks) = 0.0 - REAL, save :: porwat(ks) = 0.0 REAL, DIMENSION (:,:,:,:), ALLOCATABLE :: sedlay REAL, DIMENSION (:,:,:,:), ALLOCATABLE :: powtra REAL, DIMENSION (:,:,:), ALLOCATABLE :: sedhpl + REAL, DIMENSION (:,:,:), ALLOCATABLE :: porsol + REAL, DIMENSION (:,:,:), ALLOCATABLE :: porwah + REAL, DIMENSION (:,:,:), ALLOCATABLE :: porwat + REAL, DIMENSION (:,:), ALLOCATABLE :: solfu + REAL, DIMENSION (:,:,:), ALLOCATABLE :: zcoefsu + REAL, DIMENSION (:,:,:), ALLOCATABLE :: zcoeflo REAL, DIMENSION (:,:), ALLOCATABLE :: silpro REAL, DIMENSION (:,:), ALLOCATABLE :: prorca @@ -91,7 +94,8 @@ MODULE mo_sedmnt REAL :: sedict,rno3,o2ut,ansed REAL :: calcwei, opalwei, orgwei REAL :: calcdens, opaldens, orgdens, claydens - REAL :: calfa, oplfa, orgfa, clafa, solfu + REAL :: calfa, oplfa, orgfa, clafa + REAL :: disso_sil,silsat,disso_poc,sed_denit,disso_caco3 CONTAINS @@ -195,6 +199,71 @@ SUBROUTINE ALLOC_MEM_SEDMNT(kpie,kpje) if(errstat.ne.0) stop 'not enough memory sedhpl' sedhpl(:,:,:) = 0.0 + IF (mnproc.eq.1) THEN + WRITE(io_stdo_bgc,*)'Memory allocation for variable porsol ...' + WRITE(io_stdo_bgc,*)'First dimension : ',kpie + WRITE(io_stdo_bgc,*)'Second dimension : ',kpje + WRITE(io_stdo_bgc,*)'Third dimension : ',ks + ENDIF + + ALLOCATE (porsol(kpie,kpje,ks),stat=errstat) + if(errstat.ne.0) stop 'not enough memory porsol' + porsol(:,:,:) = 0.0 + + IF (mnproc.eq.1) THEN + WRITE(io_stdo_bgc,*)'Memory allocation for variable porwah ...' + WRITE(io_stdo_bgc,*)'First dimension : ',kpie + WRITE(io_stdo_bgc,*)'Second dimension : ',kpje + WRITE(io_stdo_bgc,*)'Third dimension : ',ks + ENDIF + + ALLOCATE (porwah(kpie,kpje,ks),stat=errstat) + if(errstat.ne.0) stop 'not enough memory porwah' + porwah(:,:,:) = 0.0 + + IF (mnproc.eq.1) THEN + WRITE(io_stdo_bgc,*)'Memory allocation for variable porwat ...' + WRITE(io_stdo_bgc,*)'First dimension : ',kpie + WRITE(io_stdo_bgc,*)'Second dimension : ',kpje + WRITE(io_stdo_bgc,*)'Third dimension : ',ks + ENDIF + + ALLOCATE (porwat(kpie,kpje,ks),stat=errstat) + if(errstat.ne.0) stop 'not enough memory porwat' + porwat(:,:,:) = 0.0 + + IF (mnproc.eq.1) THEN + WRITE(io_stdo_bgc,*)'Memory allocation for variable solfu ...' + WRITE(io_stdo_bgc,*)'First dimension : ',kpie + WRITE(io_stdo_bgc,*)'Second dimension : ',kpje + ENDIF + + ALLOCATE (solfu(kpie,kpje),stat=errstat) + if(errstat.ne.0) stop 'not enough memory solfu' + solfu(:,:) = 0.0 + + IF (mnproc.eq.1) THEN + WRITE(io_stdo_bgc,*)'Memory allocation for variable zcoefsu ...' + WRITE(io_stdo_bgc,*)'First dimension : ',kpie + WRITE(io_stdo_bgc,*)'Second dimension : ',kpje + WRITE(io_stdo_bgc,*)'Third dimension : ',ks + ENDIF + + ALLOCATE (zcoefsu(kpie,kpje,0:ks),stat=errstat) + if(errstat.ne.0) stop 'not enough memory zcoefsu' + zcoefsu(:,:,:) = 0.0 + + IF (mnproc.eq.1) THEN + WRITE(io_stdo_bgc,*)'Memory allocation for variable zcoeflo ...' + WRITE(io_stdo_bgc,*)'First dimension : ',kpie + WRITE(io_stdo_bgc,*)'Second dimension : ',kpje + WRITE(io_stdo_bgc,*)'Third dimension : ',ks + ENDIF + + ALLOCATE (zcoeflo(kpie,kpje,0:ks),stat=errstat) + if(errstat.ne.0) stop 'not enough memory zcoeflo' + zcoeflo(:,:,:) = 0.0 + IF (mnproc.eq.1) THEN WRITE(io_stdo_bgc,*)'Memory allocation for variable burial ...' WRITE(io_stdo_bgc,*)'First dimension : ',kpie diff --git a/hamocc/powach.F90 b/hamocc/powach.F90 index 5c7f6fbc..540d4c94 100644 --- a/hamocc/powach.F90 +++ b/hamocc/powach.F90 @@ -61,7 +61,8 @@ subroutine powach(kpie,kpje,kpke,kbnd,prho,omask,psao,lspin) !****************************************************************************** use mo_carbch, only: co3,keqb,ocetra,sedfluxo use mo_chemcon, only: calcon - use mo_sedmnt, only: porwat,porsol,powtra,produs,prcaca,prorca,rno3,seddw,sedhpl,sedlay,silpro + use mo_sedmnt, only: porwat,porsol,powtra,produs,prcaca,prorca,rno3,seddw,sedhpl,sedlay,silpro,disso_sil,silsat,disso_poc, & + & sed_denit,disso_caco3 use mo_biomod, only: rnit,ro2ut use mo_control_bgc, only: dtbgc use mo_param1_bgc, only: ioxygen,ipowaal,ipowaic,ipowaox,ipowaph,ipowasi,ipown2,ipowno3,isilica,isssc12,issso12,issssil, & @@ -92,7 +93,7 @@ subroutine powach(kpie,kpje,kpke,kbnd,prho,omask,psao,lspin) real :: aerob13(kpie,ks),anaerob13(kpie,ks) real :: aerob14(kpie,ks),anaerob14(kpie,ks) #endif - real :: disso, dissot, undsa, silsat, posol + real :: dissot, undsa, posol real :: umfa, denit, saln, rrho, alk, c, sit, pt real :: K1, K2, Kb, Kw, Ks1, Kf, Ksi, K1p, K2p, K3p real :: ah1, ac, cu, cb, cc, satlev @@ -117,7 +118,7 @@ subroutine powach(kpie,kpje,kpke,kbnd,prho,omask,psao,lspin) !$OMP PARALLEL DO & !$OMP&PRIVATE(sedb1,sediso,solrat,powcar,aerob,anaerob, & -!$OMP& disso,dissot,undsa,silsat,posol, & +!$OMP& dissot,undsa,posol, & !$OMP& umfa,denit,saln,rrho,alk,c,sit,pt, & !$OMP& K1,K2,Kb,Kw,Ks1,Kf,Ksi,K1p,K2p,K3p, & !$OMP& ah1,ac,cu,cb,cc,satlev,bolven, & @@ -158,17 +159,8 @@ subroutine powach(kpie,kpje,kpke,kbnd,prho,omask,psao,lspin) ! Calculate silicate-opal cycle and simultaneous silicate diffusion !****************************************************************** -! Dissolution rate constant of opal (disso) [1/(kmol Si(OH)4/m3)*1/sec] - -! THIS NEEDS TO BE CHANGED TO disso=3.e-8! THIS IS ONLY KEPT FOR THE MOMENT -! FOR BACKWARDS COMPATIBILITY - !disso=3.e-8 ! (2011-01-04) EMR - disso=1.e-6 ! test vom 03.03.04 half live sil ca. 20.000 yr - dissot=disso*dtbgc - -! Silicate saturation concentration is 1 mol/m3 - - silsat = 0.001 +! Dissolution rate constant of opal (disso) [1/(kmol Si(OH)4/m3)*1/sec]*dtbgc + dissot=disso_sil ! Evaluate boundary conditions for sediment-water column exchange. ! Current undersaturation of bottom water: sedb(i,0) and @@ -180,8 +172,8 @@ subroutine powach(kpie,kpje,kpke,kbnd,prho,omask,psao,lspin) sedb1(i,0) = bolay(i,j) * (silsat - ocetra(i,j,kbo(i,j),isilica)) & & * bolven(i) solrat(i,1) = ( sedlay(i,j,1,issssil) & - & + silpro(i,j) / (porsol(1) * seddw(1)) ) & - & * dissot / (1. + dissot * undsa) * porsol(1) / porwat(1) + & + silpro(i,j) / (porsol(i,j,1) * seddw(1)) ) & + & * dissot / (1. + dissot * undsa) * porsol(i,j,1) / porwat(i,j,1) endif enddo @@ -194,9 +186,9 @@ subroutine powach(kpie,kpje,kpke,kbnd,prho,omask,psao,lspin) do i = 1, kpie if(omask(i,j) > 0.5) then undsa = silsat - powtra(i,j,k,ipowasi) - sedb1(i,k) = seddw(k) * porwat(k) * (silsat - powtra(i,j,k,ipowasi)) + sedb1(i,k) = seddw(k) * porwat(i,j,k) * (silsat - powtra(i,j,k,ipowasi)) if ( k > 1 ) solrat(i,k) = sedlay(i,j,k,issssil) & - & * dissot / (1. + dissot * undsa) * porsol(k) / porwat(k) + & * dissot / (1. + dissot * undsa) * porsol(i,j,k) / porwat(i,j,k) endif enddo enddo @@ -218,7 +210,7 @@ subroutine powach(kpie,kpje,kpke,kbnd,prho,omask,psao,lspin) ocetra(i,j,kbo(i,j),isilica) = silsat - sediso(i,0) endif sedlay(i,j,1,issssil) = & - & sedlay(i,j,1,issssil) + silpro(i,j) / (porsol(1) * seddw(1)) + & sedlay(i,j,1,issssil) + silpro(i,j) / (porsol(i,j,1) * seddw(1)) endif enddo @@ -230,7 +222,7 @@ subroutine powach(kpie,kpje,kpke,kbnd,prho,omask,psao,lspin) do k = 1, ks do i = 1, kpie if(omask(i,j) > 0.5) then - umfa = porsol(k)/porwat(k) + umfa = porsol(i,j,k)/porwat(i,j,k) solrat(i,k) = sedlay(i,j,k,issssil) * dissot & & / (1. + dissot * sediso(i,k)) posol = sediso(i,k) * solrat(i,k) @@ -243,10 +235,8 @@ subroutine powach(kpie,kpje,kpke,kbnd,prho,omask,psao,lspin) ! Calculate oxygen-POC cycle and simultaneous oxygen diffusion !************************************************************* -! Degradation rate constant of POP (disso) [1/(kmol O2/m3)*1/sec] - - disso = 0.01 / 86400. ! disso=3.e-5 was quite high - dissot = disso * dtbgc +! Degradation rate constant of POP (disso) [1/(kmol O2/m3)*1/sec]*dtbgc + dissot = disso_poc ! This scheme is not based on undersaturation, but on O2 itself @@ -259,9 +249,9 @@ subroutine powach(kpie,kpje,kpke,kbnd,prho,omask,psao,lspin) undsa = powtra(i,j,1,ipowaox) sedb1(i,0) = bolay(i,j) * ocetra(i,j,kbo(i,j),ioxygen) * bolven(i) solrat(i,1) = ( sedlay(i,j,1,issso12) + prorca(i,j) & - & / (porsol(1) * seddw(1)) ) & + & / (porsol(i,j,1) * seddw(1)) ) & & * ro2ut * dissot / (1. + dissot * undsa) & - & * porsol(1) / porwat(1) + & * porsol(i,j,1) / porwat(i,j,1) endif enddo @@ -273,9 +263,9 @@ subroutine powach(kpie,kpje,kpke,kbnd,prho,omask,psao,lspin) do i = 1, kpie if(omask(i,j) > 0.5) then undsa = powtra(i,j,k,ipowaox) - sedb1(i,k) = seddw(k) * porwat(k) * powtra(i,j,k,ipowaox) + sedb1(i,k) = seddw(k) * porwat(i,j,k) * powtra(i,j,k,ipowaox) if (k > 1) solrat(i,k) = sedlay(i,j,k,issso12) * ro2ut * dissot & - & / (1. + dissot*undsa) * porsol(k) / porwat(k) + & / (1. + dissot*undsa) * porsol(i,j,k) / porwat(i,j,k) endif enddo enddo @@ -297,12 +287,12 @@ subroutine powach(kpie,kpje,kpke,kbnd,prho,omask,psao,lspin) ocetra(i,j,kbo(i,j),ioxygen) = sediso(i,0) endif sedlay(i,j,1,issso12) = & - & sedlay(i,j,1,issso12) + prorca(i,j) / (porsol(1)*seddw(1)) + & sedlay(i,j,1,issso12) + prorca(i,j) / (porsol(i,j,1)*seddw(1)) #ifdef cisonew sedlay(i,j,1,issso13) = & - & sedlay(i,j,1,issso13) + pror13(i,j) / (porsol(1)*seddw(1)) + & sedlay(i,j,1,issso13) + pror13(i,j) / (porsol(i,j,1)*seddw(1)) sedlay(i,j,1,issso14) = & - & sedlay(i,j,1,issso14) + pror14(i,j) / (porsol(1)*seddw(1)) + & sedlay(i,j,1,issso14) + pror14(i,j) / (porsol(i,j,1)*seddw(1)) #endif endif enddo @@ -315,7 +305,7 @@ subroutine powach(kpie,kpje,kpke,kbnd,prho,omask,psao,lspin) do k = 1, ks do i = 1, kpie if(omask(i,j) > 0.5) then - umfa = porsol(k) / porwat(k) + umfa = porsol(i,j,k) / porwat(i,j,k) solrat(i,k) = sedlay(i,j,k,issso12) * dissot/(1. + dissot*sediso(i,k)) posol = sediso(i,k)*solrat(i,k) aerob(i,k) = posol*umfa !this has P units: kmol P/m3 of pore water @@ -345,18 +335,15 @@ subroutine powach(kpie,kpje,kpke,kbnd,prho,omask,psao,lspin) ! Calculate nitrate reduction under anaerobic conditions explicitely !******************************************************************* -! Denitrification rate constant of POP (disso) [1/sec] -! Store flux in array anaerob, for later computation of DIC and alkalinity. - -!ik denit = 1.e-6*dtbgc - denit = 0.01/86400. *dtbgc + ! Denitrification rate constant of POP (disso) [1/sec]*dtbgc + denit = sed_denit do k = 1, ks do i = 1, kpie if(omask(i,j) > 0.5) then if(powtra(i,j,k,ipowaox) < 1.e-6) then posol = denit * MIN(0.5*powtra(i,j,k,ipowno3)/114., & & sedlay(i,j,k,issso12)) - umfa = porsol(k)/porwat(k) + umfa = porsol(i,j,k)/porwat(i,j,k) anaerob(i,k) = posol*umfa !this has P units: kmol P/m3 of pore water #ifdef cisonew rato13 = sedlay(i,j,k,issso13) / (sedlay(i,j,k,issso12) + safediv) @@ -389,7 +376,7 @@ subroutine powach(kpie,kpje,kpke,kbnd,prho,omask,psao,lspin) if(omask(i,j) > 0.5) then if(powtra(i,j,k,ipowaox) < 3.e-6 .and. powtra(i,j,k,ipowno3) < 3.e-6) then posol = denit * sedlay(i,j,k,issso12) ! remineralization of poc - umfa = porsol(k) / porwat(k) + umfa = porsol(i,j,k) / porwat(i,j,k) !this overwrites anaerob from denitrification. added =anaerob+..., works anaerob(i,k) = anaerob(i,k) + posol*umfa !this has P units: kmol P/m3 of pore water #ifdef cisonew @@ -456,9 +443,8 @@ subroutine powach(kpie,kpje,kpke,kbnd,prho,omask,psao,lspin) enddo -! Dissolution rate constant of CaCO3 (disso) [1/(kmol CO3--/m3)*1/sec] - disso = 1.e-7 - dissot = disso * dtbgc +! Dissolution rate constant of CaCO3 (disso) [1/(kmol CO3--/m3)*1/sec]*dtbgc + dissot = disso_caco3 ! Evaluate boundary conditions for sediment-water column exchange. ! Current undersaturation of bottom water: sedb(i,0) and @@ -473,8 +459,8 @@ subroutine powach(kpie,kpje,kpke,kbnd,prho,omask,psao,lspin) undsa = MAX( satlev-powcar(i,1), 0. ) sedb1(i,0) = bolay(i,j) * (satlev-co3(i,j,kbo(i,j))) * bolven(i) solrat(i,1) = (sedlay(i,j,1,isssc12) & - & + prcaca(i,j) / (porsol(1)*seddw(1))) & - & * dissot / (1.+dissot*undsa) * porsol(1) / porwat(1) + & + prcaca(i,j) / (porsol(i,j,1)*seddw(1))) & + & * dissot / (1.+dissot*undsa) * porsol(i,j,1) / porwat(i,j,1) endif enddo @@ -486,9 +472,9 @@ subroutine powach(kpie,kpje,kpke,kbnd,prho,omask,psao,lspin) do i = 1, kpie if(omask(i,j) > 0.5) then undsa = MAX( keqb(11,i,j) / calcon - powcar(i,k), 0. ) - sedb1(i,k) = seddw(k) * porwat(k) * undsa + sedb1(i,k) = seddw(k) * porwat(i,j,k) * undsa if (k > 1) solrat(i,k) = sedlay(i,j,k,isssc12) & - & * dissot/(1.+dissot*undsa) * porsol(k)/porwat(k) + & * dissot/(1.+dissot*undsa) * porsol(i,j,k)/porwat(i,j,k) if (undsa <= 0.) solrat(i,k) = 0. endif enddo @@ -504,12 +490,12 @@ subroutine powach(kpie,kpje,kpke,kbnd,prho,omask,psao,lspin) do i = 1, kpie if(omask(i,j) > 0.5) then sedlay(i,j,1,isssc12) = & - & sedlay(i,j,1,isssc12) + prcaca(i,j) / (porsol(1)*seddw(1)) + & sedlay(i,j,1,isssc12) + prcaca(i,j) / (porsol(i,j,1)*seddw(1)) #ifdef cisonew sedlay(i,j,1,isssc13) = & - & sedlay(i,j,1,isssc13) + prca13(i,j) / (porsol(1)*seddw(1)) + & sedlay(i,j,1,isssc13) + prca13(i,j) / (porsol(i,j,1)*seddw(1)) sedlay(i,j,1,isssc14) = & - & sedlay(i,j,1,isssc14) + prca14(i,j) / (porsol(1)*seddw(1)) + & sedlay(i,j,1,isssc14) + prca14(i,j) / (porsol(i,j,1)*seddw(1)) #endif endif enddo @@ -523,7 +509,7 @@ subroutine powach(kpie,kpje,kpke,kbnd,prho,omask,psao,lspin) do k = 1, ks do i = 1, kpie if(omask(i,j) > 0.5) then - umfa = porsol(k) / porwat(k) + umfa = porsol(i,j,k) / porwat(i,j,k) solrat(i,k) = sedlay(i,j,k,isssc12) & & * dissot / (1. + dissot * sediso(i,k)) posol = sediso(i,k) * solrat(i,k) @@ -565,7 +551,7 @@ subroutine powach(kpie,kpje,kpke,kbnd,prho,omask,psao,lspin) do j = 1, kpje do i = 1, kpie sedlay(i,j,1,issster) = sedlay(i,j,1,issster) & - & + produs(i,j) / (porsol(1) * seddw(1)) + & + produs(i,j) / (porsol(i,j,1) * seddw(1)) enddo enddo !$OMP END PARALLEL DO diff --git a/hamocc/powadi.F90 b/hamocc/powadi.F90 index a5828d91..413c3046 100644 --- a/hamocc/powadi.F90 +++ b/hamocc/powadi.F90 @@ -76,21 +76,21 @@ subroutine powadi(j,kpie,kpje,solrat,sedb1,sediso,bolven,omask) !********************************************************************** do k = 1, ks - asu = sedict * seddzi(k) * porwah(k) - alo = 0. - if(k < ks) alo = sedict * seddzi(k+1) * porwah(k+1) do i = 1, kpie + asu = sedict * seddzi(k) * porwah(i,j,k) + alo = 0. + if(k < ks) alo = sedict * seddzi(k+1) * porwah(i,j,k+1) tredsy(i,k,1) = -asu tredsy(i,k,3) = -alo - tredsy(i,k,2) = seddw(k) * porwat(k) - tredsy(i,k,1) & - & - tredsy(i,k,3) + solrat(i,k) * porwat(k) * seddw(k) + tredsy(i,k,2) = seddw(k) * porwat(i,j,k) - tredsy(i,k,1) & + & - tredsy(i,k,3) + solrat(i,k) * porwat(i,j,k) * seddw(k) enddo enddo k = 0 asu = 0. - alo = sedict * seddzi(1) * porwah(1) do i = 1, kpie + alo = sedict * seddzi(1) * porwah(i,j,1) if(omask(i,j) > 0.5) then tredsy(i,k,1) = -asu tredsy(i,k,3) = -alo diff --git a/hamocc/sedshi.F90 b/hamocc/sedshi.F90 index 51eea483..44058447 100644 --- a/hamocc/sedshi.F90 +++ b/hamocc/sedshi.F90 @@ -100,7 +100,7 @@ SUBROUTINE SEDSHI(kpie,kpje,omask) uebers=wsed(i,j)*sedlay(i,j,k,iv) sedlay(i,j,k ,iv)=sedlay(i,j,k ,iv)-uebers sedlay(i,j,k+1,iv)=sedlay(i,j,k+1,iv)+uebers & - & *(seddw(k)*porsol(k))/(seddw(k+1)*porsol(k+1)) + & *(seddw(k)*porsol(i,j,k))/(seddw(k+1)*porsol(i,j,k+1)) endif enddo !end i-loop enddo !end j-loop @@ -140,7 +140,7 @@ SUBROUTINE SEDSHI(kpie,kpje,omask) !ka if(bolay(i,j).gt.0.) then uebers=wsed(i,j)*sedlay(i,j,k,iv) sedlay(i,j,ks ,iv)=sedlay(i,j,ks ,iv)-uebers - burial(i,j,iv)=burial(i,j,iv)+uebers*seddw(k)*porsol(k) + burial(i,j,iv)=burial(i,j,iv)+uebers*seddw(k)*porsol(i,j,k) endif enddo !end i-loop enddo !end j-loop @@ -178,7 +178,7 @@ SUBROUTINE SEDSHI(kpie,kpje,omask) & +calfa*sedlay(i,j,k,isssc12) & & +oplfa*sedlay(i,j,k,issssil) & & +clafa*sedlay(i,j,k,issster) - fulsed(i,j)=fulsed(i,j)+porsol(k)*seddw(k)*sedlo + fulsed(i,j)=fulsed(i,j)+porsol(i,j,k)*seddw(k)*sedlo endif enddo !end i-loop enddo !end j-loop @@ -197,7 +197,7 @@ SUBROUTINE SEDSHI(kpie,kpje,omask) ! deficiency to fully loaded sediment packed in sedlay(i,j,ks) ! this is the volume required from the buried layer - seddef=solfu-fulsed(i,j) + seddef=solfu(i,j)-fulsed(i,j) ! total volume of solid constituents in buried layer spresent=orgfa*rcar*burial(i,j,issso12) & @@ -219,7 +219,7 @@ SUBROUTINE SEDSHI(kpie,kpje,omask) ! fill the last active layer refill=seddef/(buried+1.e-10) - frac = porsol(ks)*seddw(ks) !changed k to ks, ik + frac = porsol(i,j,ks)*seddw(ks) sedlay(i,j,ks,issso12)=sedlay(i,j,ks,issso12) & & +refill*burial(i,j,issso12)/frac @@ -269,7 +269,7 @@ SUBROUTINE SEDSHI(kpie,kpje,omask) if(omask(i,j).gt.0.5) then !ka if(bolay(i,j).gt.0.) then uebers=sedlay(i,j,k,iv)*wsed(i,j) - frac=porsol(k)*seddw(k)/(porsol(k-1)*seddw(k-1)) + frac=porsol(i,j,k)*seddw(k)/(porsol(i,j,k-1)*seddw(k-1)) sedlay(i,j,k,iv)=sedlay(i,j,k,iv)-uebers sedlay(i,j,k-1,iv)=sedlay(i,j,k-1,iv)+uebers*frac #ifdef cisonew From 1a7384913da859ed07f3c1ea4b7b40516a90be89 Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Tue, 20 Sep 2022 16:32:40 +0200 Subject: [PATCH 167/366] Updated fn2o pathway split function for nitrification to mechanistic version --- hamocc/mo_extNbioproc.F90 | 28 +++++++++++++++------------- 1 file changed, 15 insertions(+), 13 deletions(-) diff --git a/hamocc/mo_extNbioproc.F90 b/hamocc/mo_extNbioproc.F90 index 004c3ef8..b2b34918 100644 --- a/hamocc/mo_extNbioproc.F90 +++ b/hamocc/mo_extNbioproc.F90 @@ -74,7 +74,7 @@ MODULE mo_extNbioproc & rdnra,q10dnra,Trefdnra,bkoxdnra,bkdnra,ranh4nitr,q10anh4nitr, & & Trefanh4nitr,bkoxamox,bkanh4nitr,bkamoxn2o,bkamoxno2,bkyamox, & & rano2nitr,q10ano2nitr,Trefano2nitr,bkoxnitr,bkano2nitr,n2omaxy, & - & n2oybeta,bkphyanh4,bkphyano3,bkphosph,bkiron,NOB2AOAy + & n2oybeta,bkphyanh4,bkphyano3,bkphosph,bkiron,NOB2AOAy,bn2o,mufn2o real :: rc2n,ro2utammo,ro2nnit,rnoxp,rnoxpi,rno2anmx,rno2anmxi,rnh4anmx, & & rnh4anmxi,rno2dnra,rno2dnrai,rnh4dnra,rnh4dnrai,rnm1 @@ -88,7 +88,7 @@ subroutine extNbioparam_init() !=========================================================================== ! Initialization of model parameters for the extended nitrogen cycle rc2n = rcar/rnit ! iHAMOCC C:N ratio - ro2utammo = 140. ! Oxygen utilization per mol detitus during ammonification + ro2utammo = 140. ! Oxygen utilization per mol detritus during ammonification ro2nnit = ro2utammo/rnit ! rnoxp = 280. ! consumption of NOx per mol detritus during denitrification rnoxpi = 1./rnoxp ! inverse @@ -155,9 +155,11 @@ subroutine extNbioparam_init() bkanh4nitr = 0.133e-6 ! Half-saturation constant for nitrification on NH4 (kmol/m3) !====== ! OLD VERSION OF pathway splitting function - !bkamoxn2o = 0.453e-6 ! Half saturation constant for pathway splitting function N2O for nitrification on NH4 (kmol/m3) + !bkamoxn2o = 0.453e-6 ! Half saturation constant for O2 in pathway splitting function N2O for nitrification on NH4 (kmol/m3) ! NEW version similar to Santoros 2021, Ji 2018: - bkamoxn2o = 0.5e-6 ! Half saturation constant for pathway splitting function N2O for nitrification on NH4 (kmol/m3) + bkamoxn2o = 0.5e-6 ! Half saturation constant for NH4 in pathway splitting function N2O for nitrification on NH4 (kmol/m3) + mufn2o = 0.11/(50.*1e6*bkoxamox) !=6.61e-3 0.11/(50*1e6)=2.2e-9 - ~Santoro et al. 2011 with simple MM, + bn2o = 0.077/(50.*mufn2o) !=0.2331 - before set to 0.3 - base fraction entering N2O !====== !bkamoxno2 = 0.479e-6 ! Half saturation constant for pathway splitting function N2O for nitrification on NH4 (kmol/m3) bkamoxno2 = 0.1e-6 ! Half saturation constant for pathway splitting function N2O for nitrification on NH4 (kmol/m3) @@ -237,14 +239,8 @@ subroutine nitrification(kpie,kpje,kpke,kbnd,pddpo,omask,ptho) ! OLD version according to Goreau !fn2o = 1. - ocetra(i,j,k,ioxygen)/(ocetra(i,j,k,ioxygen) + bkamoxn2o) ! NEW version similar to Santoros et al. 2021, Ji et al. 2018 - ! was set: bkamoxn2o = 0.002e-6 - !fn2o = 1. - (1.-0.00157)*ocetra(i,j,k,ioxygen)/(ocetra(i,j,k,ioxygen) + bkamoxn2o) - - ! 0.11/(50*1e6)=2.2e-9 - ~Santoro et al. 2011 with simple MM - fn2o = 2.2e-9/bkoxamox * (0.3 + 0.7*bkoxamox/(ocetra(i,j,k,ioxygen)+bkoxamox)) & - * ocetra(i,j,k,ianh4)/(ocetra(i,j,k,ianh4)+bkamoxn2o) - ! continue using the 'old' fno2 - neglecting NH4 term here - which doesn'y make a huge difference, - ! assuming that it's never really limited + fn2o = mufn2o * (bn2o + (1.-bn2o)*bkoxamox/(ocetra(i,j,k,ioxygen)+bkoxamox)) & + & * ocetra(i,j,k,ianh4)/(ocetra(i,j,k,ianh4)+bkamoxn2o) !===== fno2 = ocetra(i,j,k,ioxygen)/(ocetra(i,j,k,ioxygen) + bkamoxno2) fdetamox = n2omaxy*2.*(1. + n2oybeta)*ocetra(i,j,k,ioxygen)*bkyamox & @@ -268,7 +264,13 @@ subroutine nitrification(kpie,kpje,kpke,kbnd,pddpo,omask,ptho) ! pathway splitting functions for NO2 nitrification - assuming to be the same as for NH4 ! but with reduced OM gain per used NO2 as energy source (in amox: NH4) - no2fn2o = 1. - ocetra(i,j,k,ioxygen)/(ocetra(i,j,k,ioxygen) + bkamoxn2o) + !===== + ! OLD version according to Goreau + ! no2fn2o = 1. - ocetra(i,j,k,ioxygen)/(ocetra(i,j,k,ioxygen) + bkamoxn2o) + ! NEW version + no2fn2o = mufn2o * (bn2o + (1.-bn2o)*bkoxamox/(ocetra(i,j,k,ioxygen)+bkoxamox)) & + & * ocetra(i,j,k,ianh4)/(ocetra(i,j,k,ianh4)+bkamoxn2o) + !===== no2fno2 = ocetra(i,j,k,ioxygen)/(ocetra(i,j,k,ioxygen) + bkamoxno2) no2fdetamox = NOB2AOAy*n2omaxy*2.*(1. + n2oybeta)*ocetra(i,j,k,ioxygen)*bkyamox & & /(ocetra(i,j,k,ioxygen)**2 + 2.*ocetra(i,j,k,ioxygen)*bkyamox + bkyamox**2) From 3f4bca790e27c4c4b9197c78fd70768520b1a3e2 Mon Sep 17 00:00:00 2001 From: jmaerz <92309038+jmaerz@users.noreply.github.com> Date: Tue, 20 Sep 2022 17:29:04 +0200 Subject: [PATCH 168/366] BUG fixes: sediment alkalinity and sediment C14 (#194) Bug fixes for denitrification stoichiometry and C-isotopes in the sediment --- hamocc/powach.F90 | 42 +++++++++++++++++++----------------------- 1 file changed, 19 insertions(+), 23 deletions(-) diff --git a/hamocc/powach.F90 b/hamocc/powach.F90 index 540d4c94..ab7ca6fd 100644 --- a/hamocc/powach.F90 +++ b/hamocc/powach.F90 @@ -63,7 +63,7 @@ subroutine powach(kpie,kpje,kpke,kbnd,prho,omask,psao,lspin) use mo_chemcon, only: calcon use mo_sedmnt, only: porwat,porsol,powtra,produs,prcaca,prorca,rno3,seddw,sedhpl,sedlay,silpro,disso_sil,silsat,disso_poc, & & sed_denit,disso_caco3 - use mo_biomod, only: rnit,ro2ut + use mo_biomod, only: rnit,ro2ut,rcar,rdnit1,rdnit2 use mo_control_bgc, only: dtbgc use mo_param1_bgc, only: ioxygen,ipowaal,ipowaic,ipowaox,ipowaph,ipowasi,ipown2,ipowno3,isilica,isssc12,issso12,issssil, & & issster, ks @@ -88,10 +88,10 @@ subroutine powach(kpie,kpje,kpke,kbnd,prho,omask,psao,lspin) real :: sedb1(kpie,0:ks),sediso(kpie,0:ks) real :: solrat(kpie,ks),powcar(kpie,ks) - real :: aerob(kpie,ks),anaerob(kpie,ks) + real :: aerob(kpie,ks),anaerob(kpie,ks),sulf(kpie,ks) #ifdef cisonew - real :: aerob13(kpie,ks),anaerob13(kpie,ks) - real :: aerob14(kpie,ks),anaerob14(kpie,ks) + real :: aerob13(kpie,ks),anaerob13(kpie,ks),sulf13(kpie,ks) + real :: aerob14(kpie,ks),anaerob14(kpie,ks),sulf14(kpie,ks) #endif real :: dissot, undsa, posol real :: umfa, denit, saln, rrho, alk, c, sit, pt @@ -133,11 +133,14 @@ subroutine powach(kpie,kpje,kpke,kbnd,prho,omask,psao,lspin) powcar(i,k) = 0. anaerob(i,k)= 0. aerob(i,k) = 0. + sulf(i,k) = 0. #ifdef cisonew anaerob13(i,k)=0. aerob13(i,k) =0. + sulf13(i,k) =0. anaerob14(i,k)=0. aerob14(i,k) =0. + sulf14(i,k) =0. #endif enddo enddo @@ -324,9 +327,6 @@ subroutine powach(kpie,kpje,kpke,kbnd,prho,omask,psao,lspin) #ifdef cisonew sedlay(i,j,k,issso13) = sedlay(i,j,k,issso13) - poso13 sedlay(i,j,k,issso14) = sedlay(i,j,k,issso14) - poso14 - ! is this correct? no correspondance in the lines above - powtra(i,j,k,ipowc13) = powtra(i,j,k,ipowc13) + poso13*umfa - powtra(i,j,k,ipowc14) = powtra(i,j,k,ipowc14) + poso14*umfa #endif endif enddo @@ -341,7 +341,7 @@ subroutine powach(kpie,kpje,kpke,kbnd,prho,omask,psao,lspin) do i = 1, kpie if(omask(i,j) > 0.5) then if(powtra(i,j,k,ipowaox) < 1.e-6) then - posol = denit * MIN(0.5*powtra(i,j,k,ipowno3)/114., & + posol = denit * MIN(0.25*powtra(i,j,k,ipowno3)/rdnit2, & & sedlay(i,j,k,issso12)) umfa = porsol(i,j,k)/porwat(i,j,k) anaerob(i,k) = posol*umfa !this has P units: kmol P/m3 of pore water @@ -355,14 +355,11 @@ subroutine powach(kpie,kpje,kpke,kbnd,prho,omask,psao,lspin) #endif sedlay(i,j,k,issso12) = sedlay(i,j,k,issso12) - posol powtra(i,j,k,ipowaph) = powtra(i,j,k,ipowaph) + posol*umfa - powtra(i,j,k,ipowno3) = powtra(i,j,k,ipowno3) - 98.*posol*umfa - powtra(i,j,k,ipown2) = powtra(i,j,k,ipown2) + 57.*posol*umfa + powtra(i,j,k,ipowno3) = powtra(i,j,k,ipowno3) - rdnit1*posol*umfa + powtra(i,j,k,ipown2) = powtra(i,j,k,ipown2) + rdnit2*posol*umfa #ifdef cisonew sedlay(i,j,k,issso13) = sedlay(i,j,k,issso13) - poso13 sedlay(i,j,k,issso14) = sedlay(i,j,k,issso14) - poso14 - ! is this correct? no corresponance in the lines above - powtra(i,j,k,ipowc13) = powtra(i,j,k,ipowc13) + poso13*umfa - powtra(i,j,k,ipowc14) = powtra(i,j,k,ipowc14) + poso14*umfa #endif endif endif @@ -377,15 +374,14 @@ subroutine powach(kpie,kpje,kpke,kbnd,prho,omask,psao,lspin) if(powtra(i,j,k,ipowaox) < 3.e-6 .and. powtra(i,j,k,ipowno3) < 3.e-6) then posol = denit * sedlay(i,j,k,issso12) ! remineralization of poc umfa = porsol(i,j,k) / porwat(i,j,k) - !this overwrites anaerob from denitrification. added =anaerob+..., works - anaerob(i,k) = anaerob(i,k) + posol*umfa !this has P units: kmol P/m3 of pore water + sulf(i,k) = posol*umfa !this has P units: kmol P/m3 of pore water #ifdef cisonew rato13 = sedlay(i,j,k,issso13) / (sedlay(i,j,k,issso12)+safediv) rato14 = sedlay(i,j,k,issso14) / (sedlay(i,j,k,issso12)+safediv) poso13 = posol * rato13 poso14 = posol * rato14 - anaerob13(i,k) = anaerob13(i,k) + poso13*umfa !this has P units: kmol P/m3 of pore water - anaerob14(i,k) = anaerob13(i,k) + poso14*umfa !this has P units: kmol P/m3 of pore water + sulf13(i,k) = poso13*umfa !this has P units: kmol P/m3 of pore water + sulf14(i,k) = poso14*umfa !this has P units: kmol P/m3 of pore water #endif sedlay(i,j,k,issso12) = sedlay(i,j,k,issso12) - posol powtra(i,j,k,ipowaph) = powtra(i,j,k,ipowaph) + posol*umfa @@ -413,8 +409,8 @@ subroutine powach(kpie,kpje,kpke,kbnd,prho,omask,psao,lspin) if(omask(i,j) > 0.5) then saln= min( 40., max( 0., psao(i,j,kbo(i,j)))) rrho= prho(i,j,kbo(i,j)) - alk = (powtra(i,j,k,ipowaal) - (anaerob(i,k)+aerob(i,k))*16.) / rrho - c = (powtra(i,j,k,ipowaic) + (anaerob(i,k)+aerob(i,k))*122.) / rrho + alk = (powtra(i,j,k,ipowaal) - (sulf(i,k)+aerob(i,k))*(rnit+1.) + anaerob(i,k)*(rdnit1-1.)) / rrho + c = (powtra(i,j,k,ipowaic) + (anaerob(i,k)+aerob(i,k)+sulf(i,k))*rcar) / rrho sit = powtra(i,j,k,ipowasi) / rrho pt = powtra(i,j,k,ipowaph) / rrho ah1 = sedhpl(i,j,k) @@ -521,16 +517,16 @@ subroutine powach(kpie,kpje,kpke,kbnd,prho,omask,psao,lspin) #endif sedlay(i,j,k,isssc12) = sedlay(i,j,k,isssc12) - posol powtra(i,j,k,ipowaic) = powtra(i,j,k,ipowaic) & - & + posol * umfa + (aerob(i,k) + anaerob(i,k)) * 122. + & + posol * umfa + (aerob(i,k) + anaerob(i,k) + sulf(i,k)) * rcar powtra(i,j,k,ipowaal) = powtra(i,j,k,ipowaal) & - & + 2. * posol * umfa - 16. * (aerob(i,k) + anaerob(i,k)) + & + 2. * posol * umfa - (rnit+1.)*(aerob(i,k) + sulf(i,k)) + (rdnit1-1.)*anaerob(i,k) #ifdef cisonew sedlay(i,j,k,isssc13) = sedlay(i,j,k,isssc13) - poso13 sedlay(i,j,k,isssc14) = sedlay(i,j,k,isssc14) - poso14 powtra(i,j,k,ipowc13) = powtra(i,j,k,ipowc13) + poso13 * umfa & - & + (aerob13(i,k) + anaerob13(i,k)) * 122. + & + (aerob13(i,k) + anaerob13(i,k) + sulf13(i,k)) * rcar powtra(i,j,k,ipowc14) = powtra(i,j,k,ipowc14) + poso14 * umfa & - & + (aerob14(i,k) + anaerob14(i,k)) * 122. + & + (aerob14(i,k) + anaerob14(i,k) + sulf14(i,k)) * rcar #endif endif enddo From bbea3bf917b1fb6148476a851d98f360701c9693 Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Tue, 20 Sep 2022 18:22:33 +0200 Subject: [PATCH 169/366] oxygen limitation always with M4AGO and in extended nitrogen cycle --- hamocc/ocprod.F90 | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/hamocc/ocprod.F90 b/hamocc/ocprod.F90 index d691fe90..e6a15c49 100644 --- a/hamocc/ocprod.F90 +++ b/hamocc/ocprod.F90 @@ -685,7 +685,14 @@ subroutine ocprod(kpie,kpje,kpke,kbnd,pdlxp,pdlyp,pddpo,omask,ptho,pi_ph, psao, if(ocetra(i,j,k,ioxygen) > 5.e-8) then if(lm4ago) then +#ifndef extNcycle + ! M4AGO comes with O2-lim + o2lim = ocetra(i,j,k,ioxygen)/(ocetra(i,j,k,ioxygen) + bkox_drempoc) + pocrem = o2lim*drempoc*POM_remin_q10**((ptho(i,j,k)-POM_remin_Tref)/10.)*ocetra(i,j,k,idet) +#else + ! nitrogen always accounts for O2-lim - see below pocrem = drempoc*POM_remin_q10**((ptho(i,j,k)-POM_remin_Tref)/10.)*ocetra(i,j,k,idet) +#endif else pocrem = drempoc*ocetra(i,j,k,idet) endif From 7b1e28fa34628e57f35cd6216b5055136221fa00 Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Wed, 21 Sep 2022 14:57:24 +0200 Subject: [PATCH 170/366] Including sediment parameters --- hamocc/beleg_parm.F90 | 3 +- hamocc/mo_extNbioproc.F90 | 18 +++++++- hamocc/mo_extNsediment.F90 | 93 +++++++++++++++++++++++++++++++++++++- 3 files changed, 110 insertions(+), 4 deletions(-) diff --git a/hamocc/beleg_parm.F90 b/hamocc/beleg_parm.F90 index 81c0abfd..371f457c 100644 --- a/hamocc/beleg_parm.F90 +++ b/hamocc/beleg_parm.F90 @@ -256,7 +256,8 @@ SUBROUTINE BELEG_PARM(kpie,kpje) rdn2o2=2*ro2ut-2*rnit ! moles N2 released for remineralisation of 1 mole P #ifdef extNcycle - ! initialize the extended nitrogen cycle parameters + ! initialize the extended nitrogen cycle parameters - first water column, then sediment, + ! since sediment relies on water column parameters for the extended nitrogen cycle call extNbioparam_init() call extNsediment_param_init() #endif diff --git a/hamocc/mo_extNbioproc.F90 b/hamocc/mo_extNbioproc.F90 index dbfa2655..04034795 100644 --- a/hamocc/mo_extNbioproc.F90 +++ b/hamocc/mo_extNbioproc.F90 @@ -65,9 +65,25 @@ MODULE mo_extNbioproc public :: extNbioparam_init,nitrification,denit_NO3_to_NO2,& & anammox,denit_dnra,extN_inv_check - ! public parameters + ! public parameters for primary production public :: bkphyanh4,bkphyano3,bkphosph,bkiron,ro2utammo + ! Public parameters for extended nitrogen cycle in the sediment. + ! The basic idea is that we have the same temperature dependence + ! and same nutrient sensitivities, + ! while only the rates vary between sediment and water column + ! (Thus far, we keep the rates public in order to enable to write them to the log in beleg_parm) + public :: q10ano3denit,sc_ano3denit,Trefano3denit,rano3denit,bkano3denit, & + & rano2anmx,q10anmx,Trefanmx,alphaanmx,bkoxanmx,bkano2anmx,bkanh4anmx, & + & rano2denit,q10ano2denit,Trefano2denit,bkoxano2denit,bkano2denit, & + & ran2odenit,q10an2odenit,Trefan2odenit,bkoxan2odenit,bkan2odenit, & + & rdnra,q10dnra,Trefdnra,bkoxdnra,bkdnra,ranh4nitr,q10anh4nitr, & + & Trefanh4nitr,bkoxamox,bkanh4nitr,bkamoxn2o,bkamoxno2,bkyamox, & + & rano2nitr,q10ano2nitr,Trefano2nitr,bkoxnitr,bkano2nitr,n2omaxy, & + & n2oybeta,NOB2AOAy,bn2o,mufn2o, & + & rc2n,ro2nnit,rnoxp,rnoxpi,rno2anmx,rno2anmxi,rnh4anmx, & + & rnh4anmxi,rno2dnra,rno2dnrai,rnh4dnra,rnh4dnrai,rnm1 + real :: q10ano3denit,sc_ano3denit,Trefano3denit,rano3denit,bkano3denit, & & rano2anmx,q10anmx,Trefanmx,alphaanmx,bkoxanmx,bkano2anmx,bkanh4anmx, & diff --git a/hamocc/mo_extNsediment.F90 b/hamocc/mo_extNsediment.F90 index 23c63490..ee24ae39 100644 --- a/hamocc/mo_extNsediment.F90 +++ b/hamocc/mo_extNsediment.F90 @@ -44,6 +44,18 @@ MODULE mo_extNsediment !********************************************************************** use mo_param1_bgc, only: issso12,ipowaic,ipowaal,ipowaph,ipowaox,ipown2,ipowno3,ipownh4,ipown2o,ipowno2,ks use mo_vgrid, only: kbo + use mo_biomod, only: rnit,rcar + use mo_control_bgc,only: dtb + use mo_extNbioproc,only: q10ano3denit,sc_ano3denit,Trefano3denit,bkano3denit, & + & q10anmx,Trefanmx,alphaanmx,bkoxanmx,bkano2anmx,bkanh4anmx, & + & q10ano2denit,Trefano2denit,bkoxano2denit,bkano2denit, & + & q10an2odenit,Trefan2odenit,bkoxan2odenit,bkan2odenit, & + & q10dnra,Trefdnra,bkoxdnra,bkdnra, & + & q10anh4nitr,Trefanh4nitr,bkoxamox,bkanh4nitr,bkamoxn2o,bkamoxno2,bkyamox,n2omaxy,n2oybeta,bn2o,mufn2o, & + & q10ano2nitr,Trefano2nitr,bkoxnitr,bkano2nitr,NOB2AOAy, & + & rc2n,ro2utammo,ro2nnit,rnoxp,rnoxpi,rno2anmx,rno2anmxi,rnh4anmx, & + & rnh4anmxi,rno2dnra,rno2dnrai,rnh4dnra,rnh4dnrai,rnm1 + implicit none @@ -56,12 +68,89 @@ MODULE mo_extNsediment !public :: ! extended nitrogen cycle sediment parameters - !real :: sn + real :: q10ano3denit_sed,sc_ano3denit_sed,Trefano3denit_sed,rano3denit_sed,bkano3denit_sed, & + & rano2anmx_sed,q10anmx_sed,Trefanmx_sed,alphaanmx_sed,bkoxanmx_sed,bkano2anmx_sed,bkanh4anmx_sed, & + & rano2denit_sed,q10ano2denit_sed,Trefano2denit_sed,bkoxano2denit_sed,bkano2denit_sed, & + & ran2odenit_sed,q10an2odenit_sed,Trefan2odenit_sed,bkoxan2odenit_sed,bkan2odenit_sed, & + & rdnra_sed,q10dnra_sed,Trefdnra_sed,bkoxdnra_sed,bkdnra_sed,ranh4nitr_sed,q10anh4nitr_sed, & + & Trefanh4nitr_sed,bkoxamox_sed,bkanh4nitr_sed,bkamoxn2o_sed,bkamoxno2_sed,bkyamox_sed, & + & rano2nitr_sed,q10ano2nitr_sed,Trefano2nitr_sed,bkoxnitr_sed,bkano2nitr_sed,n2omaxy_sed, & + & n2oybeta_sed,bkphyanh4_sed,bkphyano3_sed,bkphosph_sed,bkiron_sed,NOB2AOAy_sed,bn2o_sed,mufn2o_sed + + real :: eps,minlim contains ! ================================================================================================================================ subroutine extNsediment_param_init() - + ! === Denitrification step NO3 -> NO2: + !rano3denit_sed = 0.15*dtb ! Maximum growth rate denitrification on NO3 at reference T (1/d -> 1/dt) + rano3denit_sed = 0.05*dtb ! Maximum growth rate denitrification on NO3 at reference T (1/d -> 1/dt) + q10ano3denit_sed = q10ano3denit ! Q10 factor for denitrification on NO3 (-) + Trefano3denit_sed = Trefano3denit ! Reference temperature for denitrification on NO3 (degr C) + !sc_ano3denit_sed = 0.05e6 ! Shape factor for NO3 denitrification oxygen inhibition function (m3/kmol) + sc_ano3denit_sed = sc_ano3denit ! Shape factor for NO3 denitrification oxygen inhibition function (m3/kmol) + bkano3denit_sed = bkano3denit ! Half-saturation constant for NO3 denitrification (kmol/m3) + + ! === Anammox + rano2anmx_sed = 0.05*dtb ! Maximum growth rate for anammox at reference T (1/d -> 1/dt) + q10anmx_sed = q10anmx ! Q10 factor for anammox (-) + Trefanmx_sed = Trefanmx ! Reference temperature for anammox (degr C) + alphaanmx_sed = alphaanmx ! Shape factor for anammox oxygen inhibition function (m3/kmol) + bkoxanmx_sed = bkoxanmx ! Half-saturation constant for oxygen inhibition function (kmol/m3) + bkano2anmx_sed = bkano2anmx ! Half-saturation constant for NO2 limitation (kmol/m3) + bkanh4anmx_sed = bkano2anmx_sed * rnh4anmx/rno2anmx !Half-saturation constant for NH4 limitation of anammox (kmol/m3) + + ! === Denitrification step NO2 -> N2O + rano2denit_sed = 0.12*dtb ! Maximum growth rate denitrification on NO2 at reference T (1/d -> 1/dt) + q10ano2denit_sed = q10ano2denit ! Q10 factor for denitrification on NO2 (-) + Trefano2denit_sed = Trefano2denit ! Reference temperature for denitrification on NO2 (degr C) + bkoxano2denit_sed = bkoxano2denit ! Half-saturation constant for (quadratic) oxygen inhibition function of denitrification on NO2 (kmol/m3) + bkano2denit_sed = bkano2denit ! Half-saturation constant for denitrification on NO2 (kmol/m3) + + ! === Denitrification step N2O -> N2 + ran2odenit_sed = 0.16*dtb ! Maximum growth rate denitrification on N2O at reference T (1/d -> 1/dt) + q10an2odenit_sed = q10an2odenit ! Q1- factor for denitrificationj on N2O (-) + Trefan2odenit_sed = Trefan2odenit ! Reference temperature for denitrification on N2O (degr C) + bkoxan2odenit_sed = bkoxan2odenit ! Half-saturation constant for (quadratic) oxygen inhibition function of denitrification on N2O (kmol/m3) + bkan2odenit_sed = bkan2odenit ! Half-saturation constant for denitrification on N2O (kmol/m3) + + ! === DNRA NO2 -> NH4 + rdnra_sed = 0.1*dtb ! Maximum growth rate DNRA on NO2 at reference T (1/d -> 1/dt) + q10dnra_sed = q10dnra ! Q10 factor for DNRA on NO2 (-) + Trefdnra_sed = Trefdnra ! Reference temperature for DNRA (degr C) + bkoxdnra_sed = bkoxdnra ! Half saturation constant for (quadratic) oxygen inhibition function of DNRA on NO2 (kmol/m3) + bkdnra_sed = bkdnra ! Half-saturation constant for DNRA on NO2 (kmol/m3) + + ! === Nitrification on NH4 + ranh4nitr_sed = 1.*dtb ! Maximum growth rate nitrification on NH4 at reference T (1/d -> 1/dt) + q10anh4nitr_sed = q10anh4nitr ! Q10 factor for nitrification on NH4 (-) + Trefanh4nitr_sed = Trefanh4nitr ! Reference temperature for nitrification on NH4 (degr C) + bkoxamox_sed = bkoxamox ! Half-saturation constant for oxygen limitation of nitrification on NH4 (kmol/m3) + bkanh4nitr_sed = bkanh4nitr ! Half-saturation constant for nitrification on NH4 (kmol/m3) +!====== +! OLD VERSION OF pathway splitting function + !bkamoxn2o_sed = 0.453e-6 ! Half saturation constant for O2 in pathway splitting function N2O for nitrification on NH4 (kmol/m3) +! NEW version similar to Santoros 2021, Ji 2018: + bkamoxn2o_sed = bkamoxn2o ! Half saturation constant for NH4 in pathway splitting function N2O for nitrification on NH4 (kmol/m3) + mufn2o_sed = 0.11/(50.*1e6*bkoxamox_sed) !=6.61e-3 0.11/(50*1e6)=2.2e-9 - ~Santoro et al. 2011 with simple MM, + bn2o_sed = 0.077/(50.*mufn2o_sed) !=0.2331 - before set to 0.3 - base fraction entering N2O +!====== + !bkamoxno2_sed = 0.479e-6 ! Half saturation constant for pathway splitting function N2O for nitrification on NH4 (kmol/m3) + bkamoxno2_sed = bkamoxno2 ! Half saturation constant for pathway splitting function N2O for nitrification on NH4 (kmol/m3) + n2omaxy_sed = n2omaxy ! Maximum yield of OM on NH4 nitrification (-) + n2oybeta_sed = n2oybeta ! Decay factor for inhibition function for yield during nitrification on NH4 (kmol/m3) + bkyamox_sed = bkyamox ! Half saturation constant for pathway splitting function OM-yield for nitrification on NH4 (kmol/m3) + + ! === Nitrification on NO2 + rano2nitr_sed = 1.54*dtb ! Maximum growth rate nitrification on NO2 at reference T (1/d -> 1/dt) + q10ano2nitr_sed = q10ano2nitr ! Q10 factor for nitrification on NO2 (-) + Trefano2nitr_sed = Trefano2nitr ! Reference temperature for nitrification on NO2 (degr C) + bkoxnitr_sed = bkoxnitr ! Half-saturation constant for oxygen limitation of nitrification on NO2 (kmol/m3) + bkano2nitr_sed = bkano2nitr ! Half-saturation constant for NO2 for nitrification on NO2 (kmol/m3) + NOB2AOAy_sed = NOB2AOAy ! Ratio of NOB versus AOA yield per energy source ~0.043/0.098 according to Zakem et al. 2022 + + eps = 1.e-25 ! safe division etc. + minlim = 1.e-9 ! minimum for limitation functions (e.g. nutlim or oxlim/inh can only decrease to minlim) end subroutine extNsediment_param_init ! ================================================================================================================================ From e0dd73ccaa156fb09009274812e5bf23d8d7ec80 Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Wed, 21 Sep 2022 15:06:47 +0200 Subject: [PATCH 171/366] Fix o2lim usage when NOT running extNcycle, but using M4AGO --- hamocc/ocprod.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/hamocc/ocprod.F90 b/hamocc/ocprod.F90 index e6a15c49..c1e85bb5 100644 --- a/hamocc/ocprod.F90 +++ b/hamocc/ocprod.F90 @@ -165,6 +165,7 @@ subroutine ocprod(kpie,kpje,kpke,kbnd,pdlxp,pdlyp,pddpo,omask,ptho,pi_ph, psao, real :: dmsprod,dms_bac,dms_uv real :: dtr,dz real :: wpocd,wcald,wopald,wdustd,dagg + real :: o2lim ! O2 limitation of ammonification (POC remin) #ifdef sedbypass real :: florca,flcaca,flsil #endif @@ -211,7 +212,6 @@ subroutine ocprod(kpie,kpje,kpke,kbnd,pdlxp,pdlyp,pddpo,omask,ptho,pi_ph, psao, #ifdef extNcycle character(len=:), allocatable :: inv_message real :: ano3up_inh,nutlim,anh4lim,nlim,grlim,nh4uptfrac - real :: o2lim #endif @@ -635,7 +635,7 @@ subroutine ocprod(kpie,kpje,kpke,kbnd,pdlxp,pdlyp,pddpo,omask,ptho,pi_ph, psao, #endif !$OMP PARALLEL DO PRIVATE(phythresh,zoothresh,sterph,sterzo,remin & -!$OMP ,opalrem,aou,refra,dms_bac,pocrem,docrem,phyrem,dz & +!$OMP ,opalrem,aou,refra,dms_bac,pocrem,docrem,phyrem,dz,o2lim & # ifdef AGG !$OMP ,avmass,avnos,zmornos & # endif From 2be88ab772e4f338d51091fb30fba02e300d9e47 Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Wed, 21 Sep 2022 15:08:34 +0200 Subject: [PATCH 172/366] Setup of DIC and alkalinity changes tracking for sediment extNcycle --- hamocc/mo_extNsediment.F90 | 28 +++++++++++++++++++-------- hamocc/powach.F90 | 39 ++++++++++++++++++++++++++++++++------ 2 files changed, 53 insertions(+), 14 deletions(-) diff --git a/hamocc/mo_extNsediment.F90 b/hamocc/mo_extNsediment.F90 index ee24ae39..32f15659 100644 --- a/hamocc/mo_extNsediment.F90 +++ b/hamocc/mo_extNsediment.F90 @@ -154,25 +154,35 @@ subroutine extNsediment_param_init() end subroutine extNsediment_param_init ! ================================================================================================================================ - subroutine sed_nitrification(j,kpie,kpje,kpke,kbnd,ptho,omask,aerob) + subroutine sed_nitrification(j,kpie,kpje,kpke,kbnd,ptho,omask,ex_ddic,ex_dalk) integer, intent(in) :: j,kpie,kpje,kpke,kbnd real, intent(in) :: omask(kpie,kpje) real, intent(in) :: ptho(1-kbnd:kpie+kbnd,1-kbnd:kpje+kbnd,kpke) ! for calculation of pore water DIC and alkalinity changes [P-units]! - real, intent(inout) :: aerob(kpie,ks) + real, intent(inout) :: ex_ddic(kpie,ks) + real, intent(inout) :: ex_dalk(kpie,ks) ! local variables integer :: i,k + do i = 1,kpie + do k = 1,ks + if(omask(i,j)>0.5) then + + endif + enddo + enddo + end subroutine sed_nitrification ! ================================================================================================================================ - subroutine sed_denit_NO3_to_NO2(j,kpie,kpje,kpke,kbnd,ptho,omask,anaerob) + subroutine sed_denit_NO3_to_NO2(j,kpie,kpje,kpke,kbnd,ptho,omask,ex_ddic,ex_dalk) integer, intent(in) :: j,kpie,kpje,kpke,kbnd real, intent(in) :: omask(kpie,kpje) real, intent(in) :: ptho(1-kbnd:kpie+kbnd,1-kbnd:kpje+kbnd,kpke) ! for calculation of pore water DIC and alkalinity changes [P-units]! - real, intent(inout) :: anaerob(kpie,ks) + real, intent(inout) :: ex_ddic(kpie,ks) + real, intent(inout) :: ex_dalk(kpie,ks) ! local variables integer :: i,k @@ -180,12 +190,13 @@ subroutine sed_denit_NO3_to_NO2(j,kpie,kpje,kpke,kbnd,ptho,omask,anaerob) end subroutine sed_denit_NO3_to_NO2 ! ================================================================================================================================ - subroutine sed_anammox(j,kpie,kpje,kpke,kbnd,ptho,omask,anaerob) + subroutine sed_anammox(j,kpie,kpje,kpke,kbnd,ptho,omask,ex_ddic,ex_dalk) integer, intent(in) :: j,kpie,kpje,kpke,kbnd real, intent(in) :: omask(kpie,kpje) real, intent(in) :: ptho(1-kbnd:kpie+kbnd,1-kbnd:kpje+kbnd,kpke) ! for calculation of pore water DIC and alkalinity changes [P-units]! - real, intent(inout) :: anaerob(kpie,ks) + real, intent(inout) :: ex_ddic(kpie,ks) + real, intent(inout) :: ex_dalk(kpie,ks) ! local variables integer :: i,k @@ -193,12 +204,13 @@ subroutine sed_anammox(j,kpie,kpje,kpke,kbnd,ptho,omask,anaerob) end subroutine sed_anammox ! ================================================================================================================================ - subroutine sed_denit_DNRA(j,kpie,kpje,kpke,kbnd,ptho,omask,anaerob) + subroutine sed_denit_DNRA(j,kpie,kpje,kpke,kbnd,ptho,omask,ex_ddic,ex_dalk) integer, intent(in) :: j,kpie,kpje,kpke,kbnd real, intent(in) :: omask(kpie,kpje) real, intent(in) :: ptho(1-kbnd:kpie+kbnd,1-kbnd:kpje+kbnd,kpke) ! for calculation of pore water DIC and alkalinity changes [P-units]! - real, intent(inout) :: anaerob(kpie,ks) + real, intent(inout) :: ex_ddic(kpie,ks) + real, intent(inout) :: ex_dalk(kpie,ks) ! local variables integer :: i,k diff --git a/hamocc/powach.F90 b/hamocc/powach.F90 index 588f8c20..bd7fa1fd 100644 --- a/hamocc/powach.F90 +++ b/hamocc/powach.F90 @@ -94,7 +94,12 @@ subroutine powach(kpie,kpje,kpke,kbnd,prho,omask,psao,ptho,lspin) real :: sedb1(kpie,0:ks),sediso(kpie,0:ks) real :: solrat(kpie,ks),powcar(kpie,ks) - real :: aerob(kpie,ks),anaerob(kpie,ks),sulf(kpie,ks) + real :: aerob(kpie,ks),sulf(kpie,ks) +#ifndef extNcycle + real :: anaerob(kpie,ks) +#else + real :: ex_ddic(kpie,ks),ex_dalk(kpie,ks) !sum of DIC and alk changes related to extended nitrogen cycle +#endif #ifdef cisonew real :: aerob13(kpie,ks),anaerob13(kpie,ks),sulf13(kpie,ks) real :: aerob14(kpie,ks),anaerob14(kpie,ks),sulf14(kpie,ks) @@ -123,7 +128,12 @@ subroutine powach(kpie,kpje,kpke,kbnd,prho,omask,psao,ptho,lspin) !$OMP PARALLEL DO & -!$OMP&PRIVATE(sedb1,sediso,solrat,powcar,aerob,anaerob, & +!$OMP&PRIVATE(sedb1,sediso,solrat,powcar,aerob, & +#ifndef extNcycle +!$OMP& anaerob, & +#else +!$OMP& ex_dalk,ex_ddic, & +#endif !$OMP& dissot,undsa,posol, & !$OMP& umfa,denit,saln,rrho,alk,c,sit,pt, & !$OMP& K1,K2,Kb,Kw,Ks1,Kf,Ksi,K1p,K2p,K3p, & @@ -137,7 +147,12 @@ subroutine powach(kpie,kpje,kpke,kbnd,prho,omask,psao,ptho,lspin) do i = 1, kpie solrat(i,k) = 0. powcar(i,k) = 0. +#ifndef extNcycle anaerob(i,k)= 0. +#else + ex_ddic(i,k)=0. + ex_dalk(i,j)=0. +#endif aerob(i,k) = 0. sulf(i,k) = 0. #ifdef cisonew @@ -375,10 +390,10 @@ subroutine powach(kpie,kpje,kpke,kbnd,prho,omask,psao,ptho,lspin) enddo #else !======>>>> extended nitrogen cycle processes (aerobic and anaerobic) that follow ammonification - CALL sed_nitrification(j,kpie,kpje,kpke,kbnd,ptho,omask,aerob) - CALL sed_denit_NO3_to_NO2(j,kpie,kpje,kpke,kbnd,ptho,omask,anaerob) - CALL sed_anammox(j,kpie,kpje,kpke,kbnd,ptho,omask,anaerob) - CALL sed_denit_dnra(j,kpie,kpje,kpke,kbnd,ptho,omask,anaerob) + CALL sed_nitrification(j,kpie,kpje,kpke,kbnd,ptho,omask,ex_ddic,ex_dalk) + CALL sed_denit_NO3_to_NO2(j,kpie,kpje,kpke,kbnd,ptho,omask,ex_ddic,ex_dalk) + CALL sed_anammox(j,kpie,kpje,kpke,kbnd,ptho,omask,ex_ddic,ex_dalk) + CALL sed_denit_dnra(j,kpie,kpje,kpke,kbnd,ptho,omask,ex_ddic,ex_dalk) #endif @@ -424,8 +439,13 @@ subroutine powach(kpie,kpje,kpke,kbnd,prho,omask,psao,ptho,lspin) if(omask(i,j) > 0.5) then saln= min( 40., max( 0., psao(i,j,kbo(i,j)))) rrho= prho(i,j,kbo(i,j)) +#ifdef extNcycle + alk = (powtra(i,j,k,ipowaal) - (sulf(i,k)+aerob(i,k))*(rnit+1.) + ex_dalk(i,k)) / rrho + c = (powtra(i,j,k,ipowaic) + (aerob(i,k)+sulf(i,k))*rcar + ex_ddic(i,k)) / rrho +#else alk = (powtra(i,j,k,ipowaal) - (sulf(i,k)+aerob(i,k))*(rnit+1.) + anaerob(i,k)*(rdnit1-1.)) / rrho c = (powtra(i,j,k,ipowaic) + (anaerob(i,k)+aerob(i,k)+sulf(i,k))*rcar) / rrho +#endif sit = powtra(i,j,k,ipowasi) / rrho pt = powtra(i,j,k,ipowaph) / rrho ah1 = sedhpl(i,j,k) @@ -531,10 +551,17 @@ subroutine powach(kpie,kpje,kpke,kbnd,prho,omask,psao,ptho,lspin) poso14 = posol * ratc14 #endif sedlay(i,j,k,isssc12) = sedlay(i,j,k,isssc12) - posol +#ifdef extNcycle + powtra(i,j,k,ipowaic) = powtra(i,j,k,ipowaic) & + & + posol * umfa + (aerob(i,k) + sulf(i,k)) * rcar + ex_ddic(i,k) + powtra(i,j,k,ipowaal) = powtra(i,j,k,ipowaal) & + & + 2. * posol * umfa - (rnit+1.)*(aerob(i,k) + sulf(i,k)) + ex_dalk(i,k) +#else powtra(i,j,k,ipowaic) = powtra(i,j,k,ipowaic) & & + posol * umfa + (aerob(i,k) + anaerob(i,k) + sulf(i,k)) * rcar powtra(i,j,k,ipowaal) = powtra(i,j,k,ipowaal) & & + 2. * posol * umfa - (rnit+1.)*(aerob(i,k) + sulf(i,k)) + (rdnit1-1.)*anaerob(i,k) +#endif #ifdef cisonew sedlay(i,j,k,isssc13) = sedlay(i,j,k,isssc13) - poso13 sedlay(i,j,k,isssc14) = sedlay(i,j,k,isssc14) - poso14 From 5db186399db6c2e1119fa67b1645365120859eee Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Wed, 21 Sep 2022 15:50:12 +0200 Subject: [PATCH 173/366] Incorporated pore water N species to inventory calculations --- hamocc/inventory_bgc.F90 | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/hamocc/inventory_bgc.F90 b/hamocc/inventory_bgc.F90 index a838f8b1..8733c8e2 100644 --- a/hamocc/inventory_bgc.F90 +++ b/hamocc/inventory_bgc.F90 @@ -68,7 +68,7 @@ SUBROUTINE INVENTORY_BGC(kpie,kpje,kpke,dlxp,dlyp,ddpo,omask,iogrp) use mo_sedmnt, only: porwat,seddw,sedlay,burial,sedhpl,powtra,porsol #endif #ifdef extNcycle - use mo_param1_bgc, only: ianh4,iano2,iatmnh3 + use mo_param1_bgc, only: ianh4,iano2,iatmnh3,ipownh4,ipown2o,ipowno2 use mo_bgcmean, only: jnh3flux #endif @@ -383,6 +383,7 @@ SUBROUTINE INVENTORY_BGC(kpie,kpje,kpke,dlxp,dlyp,ddpo,omask,iogrp) & +zprorca*rnit & #ifdef extNcycle & +zocetratot(ianh4)+zocetratot(iano2)+snh3flux & + & +zpowtratot(ipownh4)+zpowtratot(ipown2o)*2+zpowtratot(ipowno2) & #endif #if defined(BOXATM) & +zatmn2*ppm2con*2 @@ -416,6 +417,7 @@ SUBROUTINE INVENTORY_BGC(kpie,kpje,kpke,dlxp,dlyp,ddpo,omask,iogrp) & +zprorca*(-24.)+zprcaca & #ifdef extNcycle & +zocetratot(iano2) & + & +zpowtratot(ipown2o)*0.5+zpowtratot(ipowno2) & #endif #if defined(BOXATM) & +zatmo2*ppm2con+zatmco2*ppm2con From 999d66de4e4746c22bac3b409a3270cac792095c Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Thu, 22 Sep 2022 11:59:42 +0200 Subject: [PATCH 174/366] Introduced NO3 to NO2 denitrification in sediment --- hamocc/mo_extNsediment.F90 | 50 +++++++++++++++++++++++++++++++++++--- 1 file changed, 47 insertions(+), 3 deletions(-) diff --git a/hamocc/mo_extNsediment.F90 b/hamocc/mo_extNsediment.F90 index 32f15659..8a80abc3 100644 --- a/hamocc/mo_extNsediment.F90 +++ b/hamocc/mo_extNsediment.F90 @@ -46,6 +46,7 @@ MODULE mo_extNsediment use mo_vgrid, only: kbo use mo_biomod, only: rnit,rcar use mo_control_bgc,only: dtb + use mo_sedmnt, only: powtra,sedlay,porsol,porwat use mo_extNbioproc,only: q10ano3denit,sc_ano3denit,Trefano3denit,bkano3denit, & & q10anmx,Trefanmx,alphaanmx,bkoxanmx,bkano2anmx,bkanh4anmx, & & q10ano2denit,Trefano2denit,bkoxano2denit,bkano2denit, & @@ -170,9 +171,7 @@ subroutine sed_nitrification(j,kpie,kpje,kpke,kbnd,ptho,omask,ex_ddic,ex_dalk) endif enddo - enddo - - + enddo end subroutine sed_nitrification ! ================================================================================================================================ @@ -186,6 +185,37 @@ subroutine sed_denit_NO3_to_NO2(j,kpie,kpje,kpke,kbnd,ptho,omask,ex_ddic,ex_dalk ! local variables integer :: i,k + real :: Tdep,O2inhib,nutlim,ano3new,ano3denit,temp,s2w + + do i = 1,kpie + do k = 1,ks + if(omask(i,j)>0.5) then + s2w = porsol(i,j,k) / porwat(i,j,k) + temp = merge(ptho(i,j,kbo(i,j)),10.,ptho(i,j,kbo(i,j))<40.) + Tdep = q10ano3denit_sed**((temp-Trefano3denit_sed)/10.) + O2inhib = 1. - tanh(sc_ano3denit_sed*powtra(i,j,k,ipowaox)) + nutlim = powtra(i,j,k,ipowno3)/(powtra(i,j,k,ipowno3) + bkano3denit_sed) + + ano3new = powtra(i,j,k,ipowno3)/(1. + rano3denit_sed*Tdep*O2inhib*nutlim) + + ano3denit = max(0.,min(powtra(i,j,k,ipowno3) - ano3new, sedlay(i,j,k,issso12)*rnoxp*s2w)) + + powtra(i,j,k,ipowno3) = powtra(i,j,k,ipowno3) - ano3denit + powtra(i,j,k,ipowno2) = powtra(i,j,k,ipowno2) + ano3denit + powtra(i,j,k,issso12) = powtra(i,j,k,issso12) - ano3denit*rnoxpi/s2w + powtra(i,j,k,ipownh4) = powtra(i,j,k,ipownh4) + ano3denit*rnit*rnoxpi + !ocetra(i,j,k,isco212) = ocetra(i,j,k,isco212) + ano3denit*rcar*rnoxpi + powtra(i,j,k,ipowaph) = powtra(i,j,k,ipowaph) + ano3denit*rnoxpi + !ocetra(i,j,k,iiron) = ocetra(i,j,k,iiron) + ano3denit*riron*rnoxpi + !ocetra(i,j,k,ialkali) = ocetra(i,j,k,ialkali) + ano3denit*rnm1*rnoxpi + + ! update of DIC and alkalinity through ex_ddic and ex_dalk fields + ! at later stage, when undersaturation of CaCO3 has been calculted + ex_ddic(i,k) = ex_ddic(i,k) + ano3denit*rcar*rnoxpi + ex_dalk(i,k) = ex_dalk(i,k) + ano3denit*rnm1*rnoxpi + endif + enddo + enddo end subroutine sed_denit_NO3_to_NO2 @@ -200,6 +230,13 @@ subroutine sed_anammox(j,kpie,kpje,kpke,kbnd,ptho,omask,ex_ddic,ex_dalk) ! local variables integer :: i,k + do i = 1,kpie + do k = 1,ks + if(omask(i,j)>0.5) then + + endif + enddo + enddo end subroutine sed_anammox @@ -214,6 +251,13 @@ subroutine sed_denit_DNRA(j,kpie,kpje,kpke,kbnd,ptho,omask,ex_ddic,ex_dalk) ! local variables integer :: i,k + do i = 1,kpie + do k = 1,ks + if(omask(i,j)>0.5) then + + endif + enddo + enddo end subroutine sed_denit_DNRA From 9f89f072d47c155edd77fbc669ac1b59ba706b96 Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Thu, 22 Sep 2022 13:21:20 +0200 Subject: [PATCH 175/366] Introduced nitrification in sediment --- hamocc/mo_extNsediment.F90 | 97 +++++++++++++++++++++++++++++++++++++- 1 file changed, 96 insertions(+), 1 deletion(-) diff --git a/hamocc/mo_extNsediment.F90 b/hamocc/mo_extNsediment.F90 index 8a80abc3..ceabad87 100644 --- a/hamocc/mo_extNsediment.F90 +++ b/hamocc/mo_extNsediment.F90 @@ -44,7 +44,7 @@ MODULE mo_extNsediment !********************************************************************** use mo_param1_bgc, only: issso12,ipowaic,ipowaal,ipowaph,ipowaox,ipown2,ipowno3,ipownh4,ipown2o,ipowno2,ks use mo_vgrid, only: kbo - use mo_biomod, only: rnit,rcar + use mo_biomod, only: rnit,rcar,rnoi use mo_control_bgc,only: dtb use mo_sedmnt, only: powtra,sedlay,porsol,porwat use mo_extNbioproc,only: q10ano3denit,sc_ano3denit,Trefano3denit,bkano3denit, & @@ -165,10 +165,105 @@ subroutine sed_nitrification(j,kpie,kpje,kpke,kbnd,ptho,omask,ex_ddic,ex_dalk) ! local variables integer :: i,k + + real :: Tdepanh4,O2limanh4,nut1lim,anh4new,potdnh4amox,fdetamox,fno2,fn2o,ftotnh4 + real :: Tdepano2,O2limano2,nut2lim,ano2new,potdno2nitr,fdetnitr,ftotno2,no2fn2o,no2fno2,no2fdetamox + real :: amoxfrac,nitrfrac,totd,amox,nitr,temp,w2s + do i = 1,kpie do k = 1,ks if(omask(i,j)>0.5) then + potdnh4amox = 0. + fn2o = 0. + fno2 = 0. + fdetamox = 0. + potdno2nitr = 0. + fdetnitr = 0. + w2s = porwat(i,j,k) / porsol(i,j,k) + +! if(ocetra(i,j,k,ioxygen)>minlim_oxnh4 .and. ocetra(i,j,k,ianh4)>minlim_nh4)then + temp = merge(ptho(i,j,kbo(i,j)),10.,ptho(i,j,kbo(i,j))<40.) + ! Ammonium oxidation step of nitrification + Tdepanh4 = q10anh4nitr_sed**((temp-Trefanh4nitr_sed)/10.) + O2limanh4 = powtra(i,j,k,ipowaox)/(powtra(i,j,k,ipowaox) + bkoxamox_sed) + nut1lim = powtra(i,j,k,ipownh4)/(powtra(i,j,k,ipownh4) + bkanh4nitr_sed) + anh4new = powtra(i,j,k,ipownh4)/(1. + ranh4nitr_sed*Tdepanh4*O2limanh4*nut1lim) + potdnh4amox = max(0.,powtra(i,j,k,ipownh4) - anh4new) + + ! pathway splitting functions according to Goreau 1980 + !===== + ! OLD version according to Goreau + !fn2o = 1. - ocetra(i,j,k,ioxygen)/(ocetra(i,j,k,ioxygen) + bkamoxn2o) + ! NEW version similar to Santoros et al. 2021, Ji et al. 2018 + fn2o = mufn2o_sed * (bn2o_sed + (1.-bn2o_sed)*bkoxamox_sed/(powtra(i,j,k,ipowaox)+bkoxamox_sed)) & + & * powtra(i,j,k,ipownh4)/(powtra(i,j,k,ipownh4)+bkamoxn2o_sed) + !===== + fno2 = powtra(i,j,k,ipowaox)/(powtra(i,j,k,ipowaox) + bkamoxno2_sed) + fdetamox = n2omaxy_sed*2.*(1. + n2oybeta_sed)*powtra(i,j,k,ipowaox)*bkyamox_sed & + & /(powtra(i,j,k,ipowaox)**2 + 2.*powtra(i,j,k,ipowaox)*bkyamox_sed + bkyamox_sed**2) + + ! normalization of pathway splitting functions to sum=1 + ftotnh4 = fn2o + fno2 + fdetamox + eps + fn2o = fn2o/ftotnh4 + fno2 = fno2/ftotnh4 + fdetamox = 1. - (fn2o + fno2) +! endif + +! if(ocetra(i,j,k,ioxygen)>minlim_oxno2 .and. ocetra(i,j,k,iano2)>minlim_no2)then +! temp = merge(ptho(i,j,kbo(i,j)),10.,ptho(i,j,kbo(i,j))<40.) + ! NO2 oxidizing step of nitrification + Tdepano2 = q10ano2nitr_sed**((temp-Trefano2nitr_sed)/10.) + O2limano2 = powtra(i,j,k,ipowaox)/(powtra(i,j,k,ipowaox) + bkoxnitr_sed) + nut2lim = powtra(i,j,k,ipowno2)/(powtra(i,j,k,ipowno2) + bkano2nitr_sed) + ano2new = powtra(i,j,k,ipowno2)/(1. + rano2nitr_sed*Tdepano2*O2limano2*nut2lim) + potdno2nitr = max(0.,powtra(i,j,k,ipowno2) - ano2new) + + ! pathway splitting functions for NO2 nitrification - assuming to be the same as for NH4 + ! but with reduced OM gain per used NO2 as energy source (in amox: NH4) + + no2fn2o = mufn2o_sed * (bn2o_sed + (1.-bn2o_sed)*bkoxamox_sed/(powtra(i,j,k,ipowaox)+bkoxamox_sed)) & + & * powtra(i,j,k,ipownh4)/(powtra(i,j,k,ipownh4)+bkamoxn2o_sed) + no2fno2 = powtra(i,j,k,ipowaox)/(powtra(i,j,k,ipowaox) + bkamoxno2_sed) + no2fdetamox = NOB2AOAy_sed*n2omaxy_sed*2.*(1. + n2oybeta_sed)*powtra(i,j,k,ipowaox)*bkyamox_sed & + & /(powtra(i,j,k,ipowaox)**2 + 2.*powtra(i,j,k,ipowaox)*bkyamox_sed + bkyamox_sed**2) + + fdetnitr = no2fdetamox/(no2fno2 + no2fn2o) ! yield to energy usage ratio for NO2 -> ratio equals 16:x +! endif + + ! limitation of the two processes through available nutrients, etc. + totd = potdnh4amox + potdno2nitr + amoxfrac = potdnh4amox/(totd + eps) + nitrfrac = 1. - amoxfrac + + ! Account for potential earlier changes in DIC and alkalinity in finiding the minimum + totd = max(0., & + & min(totd, & + & powtra(i,j,k,ipownh4)/(amoxfrac + fdetnitr*nitrfrac + eps), & ! ammonium + & (powtra(i,j,k,ipowaic)+ex_ddic(i,k))/(rc2n*(fdetamox*amoxfrac + fdetnitr*nitrfrac) + eps), & ! CO2 + & powtra(i,j,k,ipowaph)/(rnoi*(fdetamox*amoxfrac + fdetnitr*nitrfrac) + eps), & ! PO4 + & powtra(i,j,k,ipowaox) & + & /((1.5*fno2 + fn2o - ro2nnit*fdetamox)*amoxfrac + (0.5 - ro2nnit*fdetnitr)*nitrfrac + eps), & ! O2 + & (powtra(i,j,k,ipowaal) + ex_dalk(i,j)) & + & /((2.*fno2 + fn2o + rnm1*rnoi*fdetamox)*amoxfrac + (rnm1*rnoi*fdetnitr)*nitrfrac + eps))) ! alkalinity + amox = amoxfrac*totd + nitr = nitrfrac*totd + + powtra(i,j,k,ipownh4) = powtra(i,j,k,ipownh4) - amox - fdetnitr*nitr + powtra(i,j,k,ipown2o) = powtra(i,j,k,ipown2o) + 0.5*fn2o*amox + powtra(i,j,k,ipowno2) = powtra(i,j,k,ipowno2) + fno2*amox - nitr + powtra(i,j,k,ipowno3) = powtra(i,j,k,ipowno3) + nitr + sedlay(i,j,k,issso12) = sedlay(i,j,k,issso12) + rnoi*(fdetamox*amox + fdetnitr*nitr) * w2s +! ocetra(i,j,k,isco212) = ocetra(i,j,k,isco212) - rc2n*(fdetamox*amox + fdetnitr*nitr) + powtra(i,j,k,ipowaph) = powtra(i,j,k,ipowaph) - rnoi*(fdetamox*amox + fdetnitr*nitr) +! ocetra(i,j,k,iiron) = ocetra(i,j,k,iiron) - riron*rnoi*(fdetamox*amox + fdetnitr*nitr) + powtra(i,j,k,ipowaox) = powtra(i,j,k,ipowaox) - (1.5*fno2 + fn2o - ro2nnit*fdetamox)*amox & + & - (0.5 - ro2nnit*fdetnitr)*nitr +! ocetra(i,j,k,ialkali) = ocetra(i,j,k,ialkali) - (2.*fno2 + fn2o + rnm1*rnoi*fdetamox)*amox - rnm1*rnoi*fdetnitr*nitr + ! update of DIC and alkalinity through ex_ddic and ex_dalk fields + ! at later stage, when undersaturation of CaCO3 has been calculted + ex_ddic(i,k) = ex_ddic(i,k) - rc2n*(fdetamox*amox + fdetnitr*nitr) + ex_dalk(i,k) = ex_dalk(i,k) - (2.*fno2 + fn2o + rnm1*rnoi*fdetamox)*amox - rnm1*rnoi*fdetnitr*nitr endif enddo enddo From 37f6617352abf7863d4bd1d20b941199c1c7262b Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Thu, 22 Sep 2022 13:37:45 +0200 Subject: [PATCH 176/366] Included anammox in sediment --- hamocc/mo_extNsediment.F90 | 36 ++++++++++++++++++++++++++++++++---- 1 file changed, 32 insertions(+), 4 deletions(-) diff --git a/hamocc/mo_extNsediment.F90 b/hamocc/mo_extNsediment.F90 index ceabad87..e832a229 100644 --- a/hamocc/mo_extNsediment.F90 +++ b/hamocc/mo_extNsediment.F90 @@ -243,7 +243,7 @@ subroutine sed_nitrification(j,kpie,kpje,kpke,kbnd,ptho,omask,ex_ddic,ex_dalk) & powtra(i,j,k,ipowaph)/(rnoi*(fdetamox*amoxfrac + fdetnitr*nitrfrac) + eps), & ! PO4 & powtra(i,j,k,ipowaox) & & /((1.5*fno2 + fn2o - ro2nnit*fdetamox)*amoxfrac + (0.5 - ro2nnit*fdetnitr)*nitrfrac + eps), & ! O2 - & (powtra(i,j,k,ipowaal) + ex_dalk(i,j)) & + & (powtra(i,j,k,ipowaal) + ex_dalk(i,k)) & & /((2.*fno2 + fn2o + rnm1*rnoi*fdetamox)*amoxfrac + (rnm1*rnoi*fdetnitr)*nitrfrac + eps))) ! alkalinity amox = amoxfrac*totd nitr = nitrfrac*totd @@ -299,9 +299,8 @@ subroutine sed_denit_NO3_to_NO2(j,kpie,kpje,kpke,kbnd,ptho,omask,ex_ddic,ex_dalk powtra(i,j,k,ipowno2) = powtra(i,j,k,ipowno2) + ano3denit powtra(i,j,k,issso12) = powtra(i,j,k,issso12) - ano3denit*rnoxpi/s2w powtra(i,j,k,ipownh4) = powtra(i,j,k,ipownh4) + ano3denit*rnit*rnoxpi - !ocetra(i,j,k,isco212) = ocetra(i,j,k,isco212) + ano3denit*rcar*rnoxpi powtra(i,j,k,ipowaph) = powtra(i,j,k,ipowaph) + ano3denit*rnoxpi - !ocetra(i,j,k,iiron) = ocetra(i,j,k,iiron) + ano3denit*riron*rnoxpi + !ocetra(i,j,k,isco212) = ocetra(i,j,k,isco212) + ano3denit*rcar*rnoxpi !ocetra(i,j,k,ialkali) = ocetra(i,j,k,ialkali) + ano3denit*rnm1*rnoxpi ! update of DIC and alkalinity through ex_ddic and ex_dalk fields @@ -325,10 +324,39 @@ subroutine sed_anammox(j,kpie,kpje,kpke,kbnd,ptho,omask,ex_ddic,ex_dalk) ! local variables integer :: i,k + real :: Tdep,O2inhib,nut1lim,nut2lim,ano2new,ano2anmx,temp,w2s + do i = 1,kpie do k = 1,ks if(omask(i,j)>0.5) then - + w2s = porwat(i,j,k) / porsol(i,j,k) + temp = merge(ptho(i,j,kbo(i,j)),10.,ptho(i,j,kbo(i,j))<40.) + Tdep = q10anmx_sed**((temp-Trefanmx_sed)/10.) + O2inhib = 1. - exp(alphaanmx_sed*(powtra(i,j,k,ipowaox)-bkoxanmx_sed)) & + & /(1.+ exp(alphaanmx_sed*(powtra(i,j,k,ipowaox)-bkoxanmx_sed))) + nut1lim = powtra(i,j,k,ipowno2)/(powtra(i,j,k,ipowno2)+bkano2anmx_sed) + nut2lim = powtra(i,j,k,ipownh4)/(powtra(i,j,k,ipownh4)+bkanh4anmx_sed) + + ano2new = powtra(i,j,k,ipowno2)/(1. + rano2anmx_sed*Tdep*O2inhib*nut1lim*nut2lim) + + ! Account for former changes in DIC and alkalinity + ano2anmx = max(0.,min(powtra(i,j,k,ipowno2) - ano2new, powtra(i,j,k,ipownh4)*rno2anmx*rnh4anmxi, & + (powtra(i,j,k,ipowaic)+ex_ddic(i,k))*rno2anmx/rcar, powtra(i,j,k,ipowaph)*rno2anmx, & + (powtra(i,j,k,ipowaal)+ex_dalk(i,k))*rno2anmx/rnm1)) + + powtra(i,j,k,ipowno2) = powtra(i,j,k,ipowno2) - ano2anmx + powtra(i,j,k,ipownh4) = powtra(i,j,k,ipownh4) - ano2anmx*rnh4anmx*rno2anmxi + powtra(i,j,k,ipown2) = powtra(i,j,k,ipown2) + ano2anmx*(rnh4anmx-rnit)*rno2anmxi + powtra(i,j,k,ipowno3) = powtra(i,j,k,ipowno3) + ano2anmx*rnoxp*rno2anmxi + sedlay(i,j,k,issso12) = sedlay(i,j,k,issso12) + ano2anmx*rno2anmxi*w2s + powtra(i,j,k,ipowaph) = powtra(i,j,k,ipowaph) - ano2anmx*rno2anmxi +! ocetra(i,j,k,isco212) = ocetra(i,j,k,isco212) - ano2anmx*rcar*rno2anmxi +! ocetra(i,j,k,ialkali) = ocetra(i,j,k,ialkali) - ano2anmx*rnm1*rno2anmxi + + ! update of DIC and alkalinity through ex_ddic and ex_dalk fields + ! at later stage, when undersaturation of CaCO3 has been calculted + ex_ddic(i,k) = ex_ddic(i,k) - ano2anmx*rcar*rno2anmxi + ex_dalk(i,k) = ex_dalk(i,k) - ano2anmx*rnm1*rno2anmxi endif enddo enddo From a92b409286628455913e5cd5dcb2ac384bae9410 Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Thu, 22 Sep 2022 13:58:48 +0200 Subject: [PATCH 177/366] Added DNRA und denitrification NO2 -> N2O -> N2 --- hamocc/mo_extNsediment.F90 | 78 ++++++++++++++++++++++++++++++++++++++ 1 file changed, 78 insertions(+) diff --git a/hamocc/mo_extNsediment.F90 b/hamocc/mo_extNsediment.F90 index e832a229..66cd6944 100644 --- a/hamocc/mo_extNsediment.F90 +++ b/hamocc/mo_extNsediment.F90 @@ -374,10 +374,88 @@ subroutine sed_denit_DNRA(j,kpie,kpje,kpke,kbnd,ptho,omask,ex_ddic,ex_dalk) ! local variables integer :: i,k + real :: Tdepano2,O2inhibano2,nutlimano2,detlimano2,rpotano2denit,ano2denit + real :: Tdepdnra,O2inhibdnra,nutlimdnra,detlimdnra,rpotano2dnra,ano2dnra + real :: fdenit,fdnra,potano2new,potdano2,potddet,fdetano2denit,fdetan2odenit,fdetdnra + real :: Tdepan2o,O2inhiban2o,nutliman2o,detliman2o,an2onew,an2odenit + real :: temp,s2w + + do i = 1,kpie do k = 1,ks if(omask(i,j)>0.5) then + potddet = 0. + an2odenit = 0. + ano2denit = 0. + ano2dnra = 0. + s2w = porsol(i,j,k) / porwat(i,j,k) +! if(0.<=ocetra(i,j,k,ioxygen) .and. ocetra(i,j,k,ioxygen)minlim_n2o)then + temp = merge(ptho(i,j,kbo(i,j)),10.,ptho(i,j,kbo(i,j))<40.) + ! === denitrification on N2O + Tdepan2o = q10an2odenit_sed**((temp-Trefan2odenit_sed)/10.) + O2inhiban2o = bkoxan2odenit_sed**2/(powtra(i,j,k,ipowaox)**2 + bkoxan2odenit_sed**2) + nutliman2o = powtra(i,j,k,ipown2o)/(powtra(i,j,k,ipown2o) + bkan2odenit_sed) + an2onew = powtra(i,j,k,ipown2o)/(1. + ran2odenit_sed*Tdepan2o*O2inhiban2o*nutliman2o) + an2odenit = max(0.,min(powtra(i,j,k,ipown2o),powtra(i,j,k,ipown2o) - an2onew)) +! endif +! if(0.<=ocetra(i,j,k,ioxygen) .and. ocetra(i,j,k,ioxygen)minlim_no2)then +! temp = merge(ptho(i,j,kbo(i,j)),10.,ptho(i,j,kbo(i,j))<40.) + ! denitrification on NO2 + Tdepano2 = q10ano2denit_sed**((temp-Trefano2denit_sed)/10.) + O2inhibano2 = bkoxano2denit_sed**2/(powtra(i,j,k,ipowaox)**2 + bkoxano2denit_sed**2) + nutlimano2 = powtra(i,j,k,ipowno2)/(powtra(i,j,k,ipowno2) + bkano2denit_sed) + rpotano2denit = max(0.,rano2denit_sed*Tdepano2*O2inhibano2*nutlimano2) ! potential rate of denit + + ! DNRA on NO2 + Tdepdnra = q10dnra_sed**((temp-Trefdnra_sed)/10.) + O2inhibdnra = bkoxdnra_sed**2/(powtra(i,j,k,ipowaox)**2 + bkoxdnra_sed**2) + nutlimdnra = powtra(i,j,k,ipowno2)/(powtra(i,j,k,ipowno2) + bkdnra_sed) + rpotano2dnra = max(0.,rdnra_sed*Tdepdnra*O2inhibdnra*nutlimdnra) ! pot. rate of dnra + + ! potential new conc of NO2 due to denitrification and DNRA + potano2new = powtra(i,j,k,ipowno2)/(1. + rpotano2denit + rpotano2dnra) + potdano2 = max(0.,min(powtra(i,j,k,ipowno2), powtra(i,j,k,ipowno2) - potano2new)) + + ! === limitation due to NO2: + ! fraction on potential change of NO2: + fdenit = rpotano2denit/(rpotano2denit + rpotano2dnra + eps) + fdnra = 1. - fdenit + + ! potential fractional change + ano2denit = fdenit * potdano2 + ano2dnra = fdnra * potdano2 + ! endif + + ! limitation of processes due to detritus (based on pore water volume) + potddet = rnoxpi*(ano2denit + an2odenit) + rno2dnrai*ano2dnra ! P units + fdetano2denit = rnoxpi*ano2denit/(potddet + eps) + fdetan2odenit = rnoxpi*an2odenit/(potddet + eps) + fdetdnra = 1. - fdetano2denit - fdetan2odenit + potddet = max(0.,min(potddet,powtra(i,j,k,issso12)*s2w)) + +! if(potddet>0.)then + ! change of NO2 and N2O in N units + ano2denit = fdetano2denit*rnoxp*potddet + an2odenit = fdetan2odenit*rnoxp*potddet + ano2dnra = fdetdnra*rno2dnra*potddet + + ! change in tracer concentrations due to denit (NO2->N2O->N2) and DNRA (NO2->NH4) + powtra(i,j,k,ipowno2) = powtra(i,j,k,ipowno2) - ano2denit - ano2dnra + powtra(i,j,k,ipown2o) = powtra(i,j,k,ipown2o) - an2odenit + 0.5*ano2denit + powtra(i,j,k,ipown2) = powtra(i,j,k,ipown2) + an2odenit + powtra(i,j,k,ipownh4) = powtra(i,j,k,ipownh4) + rnit*rnoxpi*(ano2denit+an2odenit) + rnh4dnra*rno2dnrai*ano2dnra + sedlay(i,j,k,issso12) = sedlay(i,j,k,issso12) - ((ano2denit + an2odenit)*rnoxpi + ano2dnra*rno2dnrai)/s2w + powtra(i,j,k,ipowaph) = powtra(i,j,k,ipowaph) + (ano2denit + an2odenit)*rnoxpi + ano2dnra*rno2dnrai +! ocetra(i,j,k,isco212) = ocetra(i,j,k,isco212) + rcar*rnoxpi*(ano2denit + an2odenit) + rcar*rno2dnrai*ano2dnra +! ocetra(i,j,k,iiron) = ocetra(i,j,k,iiron) + riron*rnoxpi*(ano2denit + an2odenit) + riron*rno2dnrai*ano2dnra +! ocetra(i,j,k,ialkali) = ocetra(i,j,k,ialkali) + (295.*ano2denit + rnm1*an2odenit)*rnoxpi & +! & + (rno2dnra + rnh4dnra - 1.)*rno2dnrai * ano2dnra + + ! update of DIC and alkalinity through ex_ddic and ex_dalk fields + ! at later stage, when undersaturation of CaCO3 has been calculted + ex_ddic(i,k) = ex_ddic(i,k) + rcar*rnoxpi*(ano2denit + an2odenit) + rcar*rno2dnrai*ano2dnra + ex_dalk(i,k) = ex_dalk(i,k) + (295.*ano2denit + rnm1*an2odenit)*rnoxpi + (rno2dnra + rnh4dnra - 1.)*rno2dnrai * ano2dnra endif enddo enddo From 36cb67b5a6de61d086f4bbb38a72ea4a45daa7b3 Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Thu, 22 Sep 2022 14:04:29 +0200 Subject: [PATCH 178/366] make water column tuning parameters only available to init of sediment --- hamocc/mo_extNsediment.F90 | 23 +++++++++++++---------- 1 file changed, 13 insertions(+), 10 deletions(-) diff --git a/hamocc/mo_extNsediment.F90 b/hamocc/mo_extNsediment.F90 index 66cd6944..4415bfc5 100644 --- a/hamocc/mo_extNsediment.F90 +++ b/hamocc/mo_extNsediment.F90 @@ -47,17 +47,9 @@ MODULE mo_extNsediment use mo_biomod, only: rnit,rcar,rnoi use mo_control_bgc,only: dtb use mo_sedmnt, only: powtra,sedlay,porsol,porwat - use mo_extNbioproc,only: q10ano3denit,sc_ano3denit,Trefano3denit,bkano3denit, & - & q10anmx,Trefanmx,alphaanmx,bkoxanmx,bkano2anmx,bkanh4anmx, & - & q10ano2denit,Trefano2denit,bkoxano2denit,bkano2denit, & - & q10an2odenit,Trefan2odenit,bkoxan2odenit,bkan2odenit, & - & q10dnra,Trefdnra,bkoxdnra,bkdnra, & - & q10anh4nitr,Trefanh4nitr,bkoxamox,bkanh4nitr,bkamoxn2o,bkamoxno2,bkyamox,n2omaxy,n2oybeta,bn2o,mufn2o, & - & q10ano2nitr,Trefano2nitr,bkoxnitr,bkano2nitr,NOB2AOAy, & - & rc2n,ro2utammo,ro2nnit,rnoxp,rnoxpi,rno2anmx,rno2anmxi,rnh4anmx, & + use mo_extNbioproc,only: rc2n,ro2utammo,ro2nnit,rnoxp,rnoxpi,rno2anmx,rno2anmxi,rnh4anmx, & & rnh4anmxi,rno2dnra,rno2dnrai,rnh4dnra,rnh4dnrai,rnm1 - implicit none private @@ -83,7 +75,18 @@ MODULE mo_extNsediment contains ! ================================================================================================================================ subroutine extNsediment_param_init() - ! === Denitrification step NO3 -> NO2: + use mo_extNbioproc,only: q10ano3denit,sc_ano3denit,Trefano3denit,bkano3denit, & + & q10anmx,Trefanmx,alphaanmx,bkoxanmx,bkano2anmx,bkanh4anmx, & + & q10ano2denit,Trefano2denit,bkoxano2denit,bkano2denit, & + & q10an2odenit,Trefan2odenit,bkoxan2odenit,bkan2odenit, & + & q10dnra,Trefdnra,bkoxdnra,bkdnra, & + & q10anh4nitr,Trefanh4nitr,bkoxamox,bkanh4nitr,bkamoxn2o,bkamoxno2,bkyamox,n2omaxy,n2oybeta,bn2o,mufn2o, & + & q10ano2nitr,Trefano2nitr,bkoxnitr,bkano2nitr,NOB2AOAy, & + & rc2n,ro2utammo,ro2nnit,rnoxp,rnoxpi,rno2anmx,rno2anmxi,rnh4anmx, & + & rnh4anmxi,rno2dnra,rno2dnrai,rnh4dnra,rnh4dnrai,rnm1 + implicit none + + ! === Denitrification step NO3 -> NO2: !rano3denit_sed = 0.15*dtb ! Maximum growth rate denitrification on NO3 at reference T (1/d -> 1/dt) rano3denit_sed = 0.05*dtb ! Maximum growth rate denitrification on NO3 at reference T (1/d -> 1/dt) q10ano3denit_sed = q10ano3denit ! Q10 factor for denitrification on NO3 (-) From 161db4fecfff409fca92c75110f336a03bf85a85 Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Thu, 22 Sep 2022 17:06:10 +0200 Subject: [PATCH 179/366] fix bug in NO3 denitrification --- hamocc/mo_extNsediment.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/hamocc/mo_extNsediment.F90 b/hamocc/mo_extNsediment.F90 index 4415bfc5..c3ecb628 100644 --- a/hamocc/mo_extNsediment.F90 +++ b/hamocc/mo_extNsediment.F90 @@ -300,7 +300,7 @@ subroutine sed_denit_NO3_to_NO2(j,kpie,kpje,kpke,kbnd,ptho,omask,ex_ddic,ex_dalk powtra(i,j,k,ipowno3) = powtra(i,j,k,ipowno3) - ano3denit powtra(i,j,k,ipowno2) = powtra(i,j,k,ipowno2) + ano3denit - powtra(i,j,k,issso12) = powtra(i,j,k,issso12) - ano3denit*rnoxpi/s2w + sedlay(i,j,k,issso12) = sedlay(i,j,k,issso12) - ano3denit*rnoxpi/s2w powtra(i,j,k,ipownh4) = powtra(i,j,k,ipownh4) + ano3denit*rnit*rnoxpi powtra(i,j,k,ipowaph) = powtra(i,j,k,ipowaph) + ano3denit*rnoxpi !ocetra(i,j,k,isco212) = ocetra(i,j,k,isco212) + ano3denit*rcar*rnoxpi From fee659e097f01872462410f31b6a4367dec97de5 Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Thu, 22 Sep 2022 18:48:40 +0200 Subject: [PATCH 180/366] Included ammonification to NH4 --- hamocc/powach.F90 | 23 ++++++++++++++++++++++- 1 file changed, 22 insertions(+), 1 deletion(-) diff --git a/hamocc/powach.F90 b/hamocc/powach.F90 index bd7fa1fd..ee7ce465 100644 --- a/hamocc/powach.F90 +++ b/hamocc/powach.F90 @@ -76,6 +76,7 @@ subroutine powach(kpie,kpje,kpke,kbnd,prho,omask,psao,ptho,lspin) #endif #ifdef extNcycle use mo_param1_bgc, only: ipownh4 + use mo_extNbioproc, only: ro2utammo use mo_extNsediment, only: extNsediment_param_init,sed_nitrification,sed_denit_NO3_to_NO2,sed_anammox,sed_denit_DNRA #endif @@ -272,10 +273,18 @@ subroutine powach(kpie,kpje,kpke,kbnd,prho,omask,psao,ptho,lspin) if(omask(i,j) > 0.5) then undsa = powtra(i,j,1,ipowaox) sedb1(i,0) = bolay(i,j) * ocetra(i,j,kbo(i,j),ioxygen) * bolven(i) +#ifndef extNcyce solrat(i,1) = ( sedlay(i,j,1,issso12) + prorca(i,j) & & / (porsol(i,j,1) * seddw(1)) ) & & * ro2ut * dissot / (1. + dissot * undsa) & & * porsol(i,j,1) / porwat(i,j,1) +#else + ! extended nitrogen cycle - 140mol O2/mol POP O2-consumption + solrat(i,1) = ( sedlay(i,j,1,issso12) + prorca(i,j) & + & / (porsol(i,j,1) * seddw(1)) ) & + & * ro2utammo * dissot / (1. + dissot * undsa) & + & * porsol(i,j,1) / porwat(i,j,1) +#endif endif enddo @@ -288,8 +297,14 @@ subroutine powach(kpie,kpje,kpke,kbnd,prho,omask,psao,ptho,lspin) if(omask(i,j) > 0.5) then undsa = powtra(i,j,k,ipowaox) sedb1(i,k) = seddw(k) * porwat(i,j,k) * powtra(i,j,k,ipowaox) +#ifndef extNcycle if (k > 1) solrat(i,k) = sedlay(i,j,k,issso12) * ro2ut * dissot & & / (1. + dissot*undsa) * porsol(i,j,k) / porwat(i,j,k) +#else + ! extended nitrogen cycle - 140mol O2/mol POP O2-consumption + if (k > 1) solrat(i,k) = sedlay(i,j,k,issso12) * ro2utammo * dissot & + & / (1. + dissot*undsa) * porsol(i,j,k) / porwat(i,j,k) +#endif endif enddo enddo @@ -332,7 +347,6 @@ subroutine powach(kpie,kpje,kpke,kbnd,prho,omask,psao,ptho,lspin) umfa = porsol(i,j,k) / porwat(i,j,k) solrat(i,k) = sedlay(i,j,k,issso12) * dissot/(1. + dissot*sediso(i,k)) posol = sediso(i,k)*solrat(i,k) - aerob(i,k) = posol*umfa !this has P units: kmol P/m3 of pore water #ifdef cisonew rato13 = sedlay(i,j,k,issso13) / (sedlay(i,j,k,issso12) + safediv) rato14 = sedlay(i,j,k,issso14) / (sedlay(i,j,k,issso12) + safediv) @@ -343,7 +357,14 @@ subroutine powach(kpie,kpje,kpke,kbnd,prho,omask,psao,ptho,lspin) #endif sedlay(i,j,k,issso12) = sedlay(i,j,k,issso12) - posol powtra(i,j,k,ipowaph) = powtra(i,j,k,ipowaph) + posol*umfa +#ifndef extNcycle powtra(i,j,k,ipowno3) = powtra(i,j,k,ipowno3) + posol*rnit*umfa + aerob(i,k) = posol*umfa !this has P units: kmol P/m3 of pore water +#else + powtra(i,j,k,ipownh4) = powtra(i,j,k,ipownh4) + posol*rnit*umfa + ex_ddic(i,k) = rcar*posol*umfa ! C-units kmol C/m3 of pore water + ex_dalk(i,k) = (rnit-1.)*posol*umfa ! alkalinity units +#endif powtra(i,j,k,ipowaox) = sediso(i,k) #ifdef cisonew sedlay(i,j,k,issso13) = sedlay(i,j,k,issso13) - poso13 From 9c143927098ab8c85ff5b507bf7f9d7ce8349bb4 Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Fri, 23 Sep 2022 18:24:36 +0200 Subject: [PATCH 181/366] Implemented OUTPUT for sediment --- cime_config/buildnml | 58 +++++++++++++- hamocc/accfields.F90 | 35 +++++++- hamocc/hamocc_init.F90 | 6 ++ hamocc/mo_bgcmean.F90 | 87 +++++++++++++++++++- hamocc/mo_extNsediment.F90 | 89 +++++++++++++++++---- hamocc/ncout_hamocc.F90 | 158 +++++++++++++++++++++++++++++++++++++ hamocc/powach.F90 | 7 +- 7 files changed, 418 insertions(+), 22 deletions(-) diff --git a/cime_config/buildnml b/cime_config/buildnml index 73ad97de..284ddc55 100755 --- a/cime_config/buildnml +++ b/cime_config/buildnml @@ -651,6 +651,22 @@ set SDM_POWAOX = '0, 0, 2' set SDM_POWN2 = '0, 0, 2' set SDM_POWNO3 = '0, 0, 2' set SDM_POWASI = '0, 0, 2' +set SDM_POWNH4 = '0, 0, 2' +set SDM_POWN2O = '0, 0, 2' +set SDM_POWNO2 = '0, 0, 2' +set SDM_NITR_NH4 = '0, 0, 2' +set SDM_NITR_NO2 = '0, 0, 2' +set SDM_NITR_N2O_PROD = '0, 0, 2' +set SDM_NITR_NH4_OM = '0, 0, 2' +set SDM_NITR_NO2_OM = '0, 0, 2' +set SDM_DENIT_NO3 = '0, 0, 2' +set SDM_DENIT_NO2 = '0, 0, 2' +set SDM_DENIT_N2O = '0, 0, 2' +set SDM_DNRA_NO2 = '0, 0, 2' +set SDM_ANMX_N2_PROD = '0, 0, 2' +set SDM_ANMX_OM_PROD = '0, 0, 2' +set SDM_REMIN_AEROB = '0, 0, 2' +set SDM_REMIN_SULF = '0, 0, 2' set SDM_SSSO12 = '0, 0, 2' set SDM_SSSSIL = '0, 0, 2' set SDM_SSSC12 = '0, 0, 2' @@ -1713,7 +1729,10 @@ cat >>! $RUNDIR/ocn_in$inststr << EOF ! SEDIFFN2 - sediment - water-column diffusive flux of N2 [mol N2 m-2 s-1] ! SEDIFFNO3 - sediment - water-column diffusive flux of nitrate [mol NO3 m-2 s-1] ! SEDIFFSI - sediment - water-column diffusive flux of silica [mol Si m-2 s-1] -! +! SEDIFFNH4 - sediment - water-column diffusive flux of ammonia [mol NH4 m-2 s-1] +! SEDIFFN2O - sediment - water-column diffusive flux of N2O [mol N2O m-2 s-1] +! SEDIFFNO2 - sediment - water-column diffusive flux of NO2 [mol NO2 m-2 s-1] +! ! Sediment fields (SDM) ! POWAIC - (powdic) [mol C m-3] ! POWAAL - (powalk) [eq m-3] @@ -1722,6 +1741,24 @@ cat >>! $RUNDIR/ocn_in$inststr << EOF ! POWN2 - (pown2) [mol N2 m-3] ! POWNO3 - (powno3)[mol N m-3] ! POWASI - (powsi) [mol Si m-3] +! POWNH4 - (pownh4) [mol NH4 m-3] - extended N cycle only +! POWN2O - (pown2o) [mol N2O m-3] - extended N cycle only +! POWNO2 - (powno2) [mol NO2 m-3] - extended N cycle only +! NITR_NH4 - nitrification rate on NH4 [mol NH4 m-3 s-1] - extended N cycle only +! NITR_NO2 - nitrification rate on NO2 [mol NO2 m-3 s-1] - extended N cycle only +! NITR_N2O_PROD - N2O production rate during nitrification on NH4 [mol N2O m-3 s-1] - ext. N cycle only +! NITR_NH4_OM - detritus production during nitrification on NH4 [mol P m-3 s-1] - ext. N cycle only +! NITR_NO2_OM - detritus production during nitrification on NO2 [mol P m-3 s-1] - ext. N cycle only +! DENIT_NO3 - denitrification rate on NO3 [mol NO3 m-3 s-1] - ext. N cycle only +! DENIT_NO2 - denitrification rate on NO2 [mol NO2 m-3 s-1] - ext. N cycle only +! DENIT_N2O - denitrification rate on N20 [mol N20 m-3 s-1] - ext. N cycle only +! DNRA_NO2 - DNRA on NO2 [mol NO2 m-3 s-1] - ext. N cycle only +! ANMX_N2_PROD - anammox N2 production [mol N2 m-3 s-1] - ext. N cycle only +! ANMX_OM_PROD - anammox detritus production [mol P m-3 s-1] - ext. N cycle only +! PHOSY_NH4 - PP consumption of NH4 [mol NH4 m-3 s-1] - ext. N cycle only +! PHOSY_NO3 - PP consumption of NH4 [mol NH4 m-3 s-1] - ext. N cycle only +! REMIN_AEROB - aerob remineralization rate (sev. sources) [mol NH4 m-3 s-1] - ext. N cycle only +! REMIN_SULF - sulfate-based remin rate on det [mol P m-3 s-1] - ext. N cycle only ! SSSO12 - (ssso12) [mol m-3] ! SSSSIL - (ssssil) [mol Si m-3] ! SSSC12 - (sssc12) [mol C m-3] @@ -1971,6 +2008,9 @@ cat >>! $RUNDIR/ocn_in$inststr << EOF FLX_SEDIFFN2 = $FLX_SEDIFFN2 FLX_SEDIFFNO3 = $FLX_SEDIFFNO3 FLX_SEDIFFSI = $FLX_SEDIFFSI + FLX_SEDIFFNH4 = $FLX_SEDIFFNH4 + FLX_SEDIFFN2O = $FLX_SEDIFFN2O + FLX_SEDIFFNO2 = $FLX_SEDIFFNO2 SDM_POWAIC = $SDM_POWAIC SDM_POWAAL = $SDM_POWAAL SDM_POWAPH = $SDM_POWAPH @@ -1978,6 +2018,22 @@ cat >>! $RUNDIR/ocn_in$inststr << EOF SDM_POWN2 = $SDM_POWN2 SDM_POWNO3 = $SDM_POWNO3 SDM_POWASI = $SDM_POWASI + SDM_POWNH4 = $SDM_POWNH4 + SDM_POWN2O = $SDM_POWN2O + SDM_POWNO2 = $SDM_POWNO2 + SDM_NITR_NH4 = $SDM_NITR_NH4 + SDM_NITR_NO2 = $SDM_NITR_NO2 + SDM_NITR_N2O_PROD = $SDM_NITR_N2O_PROD + SDM_NITR_NH4_OM = $SDM_NITR_NH4_OM + SDM_NITR_NO2_OM = $SDM_NITR_NO2_OM + SDM_DENIT_NO3 = $SDM_DENIT_NO3 + SDM_DENIT_NO2 = $SDM_DENIT_NO2 + SDM_DENIT_N2O = $SDM_DENIT_N2O + SDM_DNRA_NO2 = $SDM_DNRA_NO2 + SDM_ANMX_N2_PROD = $SDM_ANMX_N2_PROD + SDM_ANMX_OM_PROD = $SDM_ANMX_OM_PROD + SDM_REMIN_AEROB = $SDM_REMIN_AEROB + SDM_REMIN_SULF = $SDM_REMIN_SULF SDM_SSSO12 = $SDM_SSSO12 SDM_SSSSIL = $SDM_SSSSIL SDM_SSSC12 = $SDM_SSSC12 diff --git a/hamocc/accfields.F90 b/hamocc/accfields.F90 index ab0fc5d2..a195d01f 100644 --- a/hamocc/accfields.F90 +++ b/hamocc/accfields.F90 @@ -115,12 +115,18 @@ SUBROUTINE ACCFIELDS(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask) & jpowno3,jsssc12,jssso12,jssssil,jssster,accbur,accsdm #endif #ifdef extNcycle - use mo_param1_bgc, only: iatmnh3,ianh4,iano2 + use mo_param1_bgc, only: iatmnh3,ianh4,iano2,ipownh4,ipown2o,ipowno2 use mo_bgcmean, only: jnh3flux,janh3fx,janh4,jano2,jsrfanh4,jsrfano2, & & jnitr_NH4,jnitr_NO2,jnitr_N2O_prod,jnitr_NH4_OM,jnitr_NO2_OM,jdenit_NO3,jdenit_NO2,jdenit_N2O, & - & jDNRA_NO2,janmx_N2_prod,janmx_OM_prod,jphosy_NH4,jphosy_NO3,jremin_aerob,jremin_sulf + & jDNRA_NO2,janmx_N2_prod,janmx_OM_prod,jphosy_NH4,jphosy_NO3,jremin_aerob,jremin_sulf, & + & jpownh4,jpown2o,jpowno2,jsdm_nitr_NH4,jsdm_nitr_NO2,jsdm_nitr_N2O_prod,jsdm_nitr_NH4_OM, & + & jsdm_nitr_NO2_OM,jsdm_denit_NO3,jsdm_denit_NO2,jsdm_denit_N2O,jsdm_DNRA_NO2,jsdm_anmx_N2_prod, & + & jsdm_anmx_OM_prod,jsdm_remin_aerob,jsdm_remin_sulf,jsediffnh4,jsediffn2o,jsediffno2 use mo_biomod, only: nitr_NH4,nitr_NO2,nitr_N2O_prod,nitr_NH4_OM,nitr_NO2_OM,denit_NO3,denit_NO2,denit_N2O,DNRA_NO2, & & anmx_N2_prod,anmx_OM_prod,phosy_NH4,phosy_NO3,remin_aerob,remin_sulf + use mo_extNsediment,only: extNsed_diagnostics,ised_nitr_NH4,ised_nitr_NO2,ised_nitr_N2O_prod,ised_nitr_NH4_OM, & + & ised_nitr_NO2_OM,ised_denit_NO3,ised_denit_NO2,ised_denit_N2O,ised_DNRA_NO2,ised_anmx_N2_prod, & + & ised_anmx_OM_prod,ised_remin_aerob,ised_remin_sulf #endif implicit none @@ -314,6 +320,11 @@ SUBROUTINE ACCFIELDS(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask) call accsrf(jsediffno3,sedfluxo(1,1,ipowno3),omask,0) call accsrf(jsediffsi,sedfluxo(1,1,ipowasi),omask,0) #endif +#if defined(extNcycle) && ! defined(sedbypass) + call accsrf(jsediffnh4,sedfluxo(1,1,ipownh4),omask,0) + call accsrf(jsediffn2o,sedfluxo(1,1,ipown2o),omask,0) + call accsrf(jsediffno2,sedfluxo(1,1,ipowno2),omask,0) +#endif ! Accumulate layer diagnostics call acclyr(jdp,pddpo,pddpo,0) @@ -549,6 +560,26 @@ SUBROUTINE ACCFIELDS(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask) call accbur(jbursssc12,burial(1,1,isssc12)) call accbur(jburssster,burial(1,1,issster)) #endif +#if defined(extNcycle) && ! defined(sedbypass) + call accsdm(jpownh4,powtra(1,1,1,ipownh4)) + call accsdm(jpown2o,powtra(1,1,1,ipown2o)) + call accsdm(jpowno2,powtra(1,1,1,ipowno2)) + + call accsdm(jsdm_nitr_NH4 ,extNsed_diagnostics(1,1,1,ised_nitr_NH4)) + call accsdm(jsdm_nitr_NO2 ,extNsed_diagnostics(1,1,1,ised_nitr_NO2)) + call accsdm(jsdm_nitr_N2O_prod ,extNsed_diagnostics(1,1,1,ised_nitr_N2O_prod)) + call accsdm(jsdm_nitr_NH4_OM ,extNsed_diagnostics(1,1,1,ised_nitr_NH4_OM)) + call accsdm(jsdm_nitr_NO2_OM ,extNsed_diagnostics(1,1,1,ised_nitr_NO2_OM)) + call accsdm(jsdm_denit_NO3 ,extNsed_diagnostics(1,1,1,ised_denit_NO3)) + call accsdm(jsdm_denit_NO2 ,extNsed_diagnostics(1,1,1,ised_denit_NO2)) + call accsdm(jsdm_denit_N2O ,extNsed_diagnostics(1,1,1,ised_denit_N2O)) + call accsdm(jsdm_DNRA_NO2 ,extNsed_diagnostics(1,1,1,ised_DNRA_NO2)) + call accsdm(jsdm_anmx_N2_prod ,extNsed_diagnostics(1,1,1,ised_anmx_N2_prod)) + call accsdm(jsdm_anmx_OM_prod ,extNsed_diagnostics(1,1,1,ised_anmx_OM_prod)) + call accsdm(jsdm_remin_aerob ,extNsed_diagnostics(1,1,1,ised_remin_aerob)) + call accsdm(jsdm_remin_sulf ,extNsed_diagnostics(1,1,1,ised_remin_sulf)) + +#endif ! Write output if requested diff --git a/hamocc/hamocc_init.F90 b/hamocc/hamocc_init.F90 index 6e35c97c..8051e925 100644 --- a/hamocc/hamocc_init.F90 +++ b/hamocc/hamocc_init.F90 @@ -70,6 +70,9 @@ subroutine hamocc_init(read_rest,rstfnm_hamocc) #ifdef BOXATM use mo_intfcblom, only: atm2 #endif +#ifdef extNcycle + use mo_extNsediment,only: alloc_mem_extNsediment_diag +#endif implicit none @@ -146,6 +149,9 @@ subroutine hamocc_init(read_rest,rstfnm_hamocc) CALL ALLOC_MEM_SEDMNT(idm,jdm) CALL ALLOC_MEM_CARBCH(idm,jdm,kdm) CALL ALLOC_MEM_M4AGO(idm,jdm,kdm) +#if defined(extNcycle) && ! defined(sedbypass) + CALL ALLOC_MEM_extNsediment_diag(idm,jdm,ks) +#endif ! ! --- initialise trc array (two time levels) ! diff --git a/hamocc/mo_bgcmean.F90 b/hamocc/mo_bgcmean.F90 index b9be3f55..3b4c054c 100644 --- a/hamocc/mo_bgcmean.F90 +++ b/hamocc/mo_bgcmean.F90 @@ -101,7 +101,8 @@ MODULE mo_bgcmean & FLX_CAL2000 =0 ,FLX_CAL4000 =0 ,FLX_CAL_BOT =0 , & & FLX_SEDIFFIC =0 ,FLX_SEDIFFAL =0 ,FLX_SEDIFFPH =0 , & & FLX_SEDIFFOX =0 ,FLX_SEDIFFN2 =0 ,FLX_SEDIFFNO3 =0 , & - & FLX_SEDIFFSI =0 , & + & FLX_SEDIFFSI =0 ,FLX_SEDIFFNH4 =0 ,FLX_SEDIFFN2O =0 , & + & FLX_SEDIFFNO2 =0 , & & LYR_PHYTO =0 ,LYR_GRAZER =0 ,LYR_DOC =0 , & & LYR_PHOSY =0 ,LYR_PHOSPH =0 ,LYR_OXYGEN =0 , & & LYR_IRON =0 ,LYR_ANO3 =0 ,LYR_ALKALI =0 , & @@ -169,6 +170,13 @@ MODULE mo_bgcmean & SDM_POWAOX =0 ,SDM_POWN2 =0 ,SDM_POWNO3 =0 , & & SDM_POWASI =0 ,SDM_SSSO12 =0 ,SDM_SSSSIL =0 , & & SDM_SSSC12 =0 ,SDM_SSSTER =0 , & + !extNcycle + & SDM_POWNH4 =0 ,SDM_POWN2O =0 ,SDM_POWNO2 =0 , & + & SDM_nitr_NH4 =0 ,SDM_nitr_NO2 =0 ,SDM_nitr_N2O_prod =0, & + & SDM_nitr_NH4_OM =0 ,SDM_nitr_NO2_OM =0 ,SDM_denit_NO3 =0, & + & SDM_denit_NO2 = 0 ,SDM_denit_N2O = 0 ,SDM_DNRA_NO2 =0, & + & SDM_anmx_N2_prod=0 ,SDM_anmx_OM_prod=0 ,SDM_remin_aerob =0 , & + & SDM_remin_sulf =0 , & & BUR_SSSO12 =0 ,BUR_SSSC12 =0 ,BUR_SSSSIL =0 , & & BUR_SSSTER =0 , & & GLB_AVEPERIO =0 ,GLB_FILEFREQ =0 ,GLB_COMPFLAG =0 , & @@ -201,7 +209,8 @@ MODULE mo_bgcmean & FLX_CAL2000 ,FLX_CAL4000 ,FLX_CAL_BOT , & & FLX_SEDIFFIC ,FLX_SEDIFFAL ,FLX_SEDIFFPH , & & FLX_SEDIFFOX ,FLX_SEDIFFN2 ,FLX_SEDIFFNO3 , & - & FLX_SEDIFFSI , & + & FLX_SEDIFFSI ,FLX_SEDIFFNH4 ,FLX_SEDIFFN2O , & + & FLX_SEDIFFNO2 , & & LYR_PHYTO ,LYR_GRAZER ,LYR_DOC , & & LYR_PHOSY ,LYR_PHOSPH ,LYR_OXYGEN , & & LYR_IRON ,LYR_ANO3 ,LYR_ALKALI , & @@ -264,6 +273,12 @@ MODULE mo_bgcmean & SDM_POWAOX ,SDM_POWN2 ,SDM_POWNO3 , & & SDM_POWASI ,SDM_SSSO12 ,SDM_SSSSIL , & & SDM_SSSC12 ,SDM_SSSTER , & + & SDM_POWNH4 ,SDM_POWN2O ,SDM_POWNO2 , & + & SDM_nitr_NH4 ,SDM_nitr_NO2 ,SDM_nitr_N2O_prod , & + & SDM_nitr_NH4_OM ,SDM_nitr_NO2_OM ,SDM_denit_NO3 , & + & SDM_denit_NO2 ,SDM_denit_N2O ,SDM_DNRA_NO2 , & + & SDM_anmx_N2_prod ,SDM_anmx_OM_prod ,SDM_remin_aerob , & + & SDM_remin_sulf , & & BUR_SSSO12 ,BUR_SSSC12 ,BUR_SSSSIL , & & BUR_SSSTER , & & GLB_AVEPERIO ,GLB_FILEFREQ ,GLB_COMPFLAG , & @@ -361,7 +376,10 @@ MODULE mo_bgcmean & jsediffox = 0 , & & jsediffn2 = 0 , & & jsediffno3 = 0 , & - jsediffsi = 0 + & jsediffsi = 0 , & + & jsediffnh4 = 0 , & + & jsediffn2o = 0 , & + & jsediffno2 = 0 INTEGER, DIMENSION(nbgcmax), SAVE :: & & jsrfnatdic = 0 , & @@ -583,7 +601,23 @@ MODULE mo_bgcmean & jssso12 = 0 , & & jssssil = 0 , & & jsssc12 = 0 , & - & jssster = 0 + & jssster = 0 , & + & jpownh4 = 0 , & + & jpown2o = 0 , & + & jpowno2 = 0 , & + & jsdm_nitr_NH4 = 0 , & + & jsdm_nitr_NO2 = 0 , & + & jsdm_nitr_N2O_prod = 0 , & + & jsdm_nitr_NH4_OM = 0 , & + & jsdm_nitr_NO2_OM = 0 , & + & jsdm_denit_NO3 = 0 , & + & jsdm_denit_NO2 = 0 , & + & jsdm_denit_N2O = 0 , & + & jsdm_DNRA_NO2 = 0 , & + & jsdm_anmx_N2_prod = 0 , & + & jsdm_anmx_OM_prod = 0 , & + & jsdm_remin_aerob = 0 , & + & jsdm_remin_sulf = 0 INTEGER, SAVE :: nbgct_sed @@ -774,6 +808,14 @@ SUBROUTINE ALLOC_MEM_BGCMEAN(kpie,kpje,kpke) IF (FLX_SEDIFFSI(n).GT.0) i_bsc_m2d=i_bsc_m2d+1 jsediffsi(n)=i_bsc_m2d*min(1,FLX_SEDIFFSI(n)) #endif +#if defined (extNcycle) && ! defined(sedbypass) + IF (FLX_SEDIFFNH4(n).GT.0) i_bsc_m2d=i_bsc_m2d+1 + jsediffnh4(n)=i_bsc_m2d*min(1,FLX_SEDIFFNH4(n)) + IF (FLX_SEDIFFN2O(n).GT.0) i_bsc_m2d=i_bsc_m2d+1 + jsediffn2o(n)=i_bsc_m2d*min(1,FLX_SEDIFFN2O(n)) + IF (FLX_SEDIFFNO2(n).GT.0) i_bsc_m2d=i_bsc_m2d+1 + jsediffno2(n)=i_bsc_m2d*min(1,FLX_SEDIFFNO2(n)) +#endif #ifdef cisonew IF (SRF_CO213FXD(n).GT.0) i_bsc_m2d=i_bsc_m2d+1 jco213fxd(n)=i_bsc_m2d*min(1,SRF_CO213FXD(n)) @@ -1260,6 +1302,43 @@ SUBROUTINE ALLOC_MEM_BGCMEAN(kpie,kpje,kpke) jburssster(n)=i_bsc_bur*min(1,BUR_SSSTER(n)) ENDDO #endif +#if defined(extNcycle) && ! defined(sedbypass) + DO n=1,nbgc + IF (SDM_POWNH4(n).GT.0) i_bsc_sed=i_bsc_sed+1 + jpownh4(n)=i_bsc_sed*min(1,SDM_POWNH4(n)) + IF (SDM_POWN2O(n).GT.0) i_bsc_sed=i_bsc_sed+1 + jpown2o(n)=i_bsc_sed*min(1,SDM_POWN2O(n)) + IF (SDM_POWNO2(n).GT.0) i_bsc_sed=i_bsc_sed+1 + jpowno2(n)=i_bsc_sed*min(1,SDM_POWNO2(n)) + IF (SDM_nitr_NH4(n).GT.0) i_bsc_sed=i_bsc_sed+1 + jsdm_nitr_NH4(n)=i_bsc_sed*min(1,SDM_nitr_NH4(n)) + IF (SDM_nitr_NO2(n).GT.0) i_bsc_sed=i_bsc_sed+1 + jsdm_nitr_NO2(n)=i_bsc_sed*min(1,SDM_nitr_NO2(n)) + IF (SDM_nitr_N2O_prod(n).GT.0) i_bsc_sed=i_bsc_sed+1 + jsdm_nitr_N2O_prod(n)=i_bsc_sed*min(1,SDM_nitr_N2O_prod(n)) + IF (SDM_nitr_NH4_OM(n).GT.0) i_bsc_sed=i_bsc_sed+1 + jsdm_nitr_NH4_OM(n)=i_bsc_sed*min(1,SDM_nitr_NH4_OM(n)) + IF (SDM_nitr_NO2_OM(n).GT.0) i_bsc_sed=i_bsc_sed+1 + jsdm_nitr_NO2_OM(n)=i_bsc_sed*min(1,SDM_nitr_NO2_OM(n)) + IF (SDM_denit_NO3(n).GT.0) i_bsc_sed=i_bsc_sed+1 + jsdm_denit_NO3(n)=i_bsc_sed*min(1,SDM_denit_NO3(n)) + IF (SDM_denit_NO2(n).GT.0) i_bsc_sed=i_bsc_sed+1 + jsdm_denit_NO2(n)=i_bsc_sed*min(1,SDM_denit_NO2(n)) + IF (SDM_denit_N2O(n).GT.0) i_bsc_sed=i_bsc_sed+1 + jsdm_denit_N2O(n)=i_bsc_sed*min(1,SDM_denit_N2O(n)) + IF (SDM_DNRA_NO2(n).GT.0) i_bsc_sed=i_bsc_sed+1 + jsdm_DNRA_NO2(n)=i_bsc_sed*min(1,SDM_DNRA_NO2(n)) + IF (SDM_anmx_N2_prod(n).GT.0) i_bsc_sed=i_bsc_sed+1 + jsdm_anmx_N2_prod(n)=i_bsc_sed*min(1,SDM_anmx_N2_prod(n)) + IF (SDM_anmx_OM_prod(n).GT.0) i_bsc_sed=i_bsc_sed+1 + jsdm_anmx_OM_prod(n)=i_bsc_sed*min(1,SDM_anmx_OM_prod(n)) + IF (SDM_remin_aerob(n).GT.0) i_bsc_sed=i_bsc_sed+1 + jsdm_remin_aerob(n)=i_bsc_sed*min(1,SDM_remin_aerob(n)) + IF (SDM_remin_sulf(n).GT.0) i_bsc_sed=i_bsc_sed+1 + jsdm_remin_sulf(n)=i_bsc_sed*min(1,SDM_remin_sulf(n)) + ENDDO +#endif + nbgcm2d = i_bsc_m2d+i_atm_m2d nbgcm3d = i_bsc_m3d diff --git a/hamocc/mo_extNsediment.F90 b/hamocc/mo_extNsediment.F90 index c3ecb628..52e12ddf 100644 --- a/hamocc/mo_extNsediment.F90 +++ b/hamocc/mo_extNsediment.F90 @@ -55,10 +55,11 @@ MODULE mo_extNsediment private ! public functions - public :: extNsediment_param_init,sed_nitrification,sed_denit_NO3_to_NO2,sed_anammox,sed_denit_DNRA + public :: extNsediment_param_init,sed_nitrification,sed_denit_NO3_to_NO2,sed_anammox,sed_denit_DNRA,alloc_mem_extNsediment_diag - ! public parameters - !public :: + ! public parameters and fields + public :: ised_nitr_NH4,ised_nitr_NO2,ised_nitr_N2O_prod,ised_nitr_NH4_OM,ised_nitr_NO2_OM,ised_denit_NO3,ised_denit_NO2, & + ised_denit_N2O,ised_DNRA_NO2,ised_anmx_N2_prod,ised_anmx_OM_prod,ised_remin_aerob,ised_remin_sulf,extNsed_diagnostics ! extended nitrogen cycle sediment parameters real :: q10ano3denit_sed,sc_ano3denit_sed,Trefano3denit_sed,rano3denit_sed,bkano3denit_sed, & @@ -68,22 +69,64 @@ MODULE mo_extNsediment & rdnra_sed,q10dnra_sed,Trefdnra_sed,bkoxdnra_sed,bkdnra_sed,ranh4nitr_sed,q10anh4nitr_sed, & & Trefanh4nitr_sed,bkoxamox_sed,bkanh4nitr_sed,bkamoxn2o_sed,bkamoxno2_sed,bkyamox_sed, & & rano2nitr_sed,q10ano2nitr_sed,Trefano2nitr_sed,bkoxnitr_sed,bkano2nitr_sed,n2omaxy_sed, & - & n2oybeta_sed,bkphyanh4_sed,bkphyano3_sed,bkphosph_sed,bkiron_sed,NOB2AOAy_sed,bn2o_sed,mufn2o_sed - + & n2oybeta_sed,NOB2AOAy_sed,bn2o_sed,mufn2o_sed + + ! output + real, dimension (:,:,:,:), allocatable :: extNsed_diagnostics + integer, parameter :: & + ised_nitr_NH4 = 1, & + ised_nitr_NO2 = 2, & + ised_nitr_N2O_prod = 3, & + ised_nitr_NH4_OM = 4, & + ised_nitr_NO2_OM = 5, & + ised_denit_NO3 = 6, & + ised_denit_NO2 = 7, & + ised_denit_N2O = 8, & + ised_DNRA_NO2 = 9, & + ised_anmx_N2_prod = 10, & + ised_anmx_OM_prod = 11, & + ised_remin_aerob = 12, & + ised_remin_sulf = 13, & + n_seddiag = 13 + real :: eps,minlim contains + + ! ================================================================================================================================ + subroutine alloc_mem_extNsediment_diag(kpie,kpje,ksed) + use mod_xc, only: mnproc + use mo_control_bgc, only: io_stdo_bgc + + implicit none + + INTEGER, intent(in) :: kpie,kpje,ksed ! ksed = ks + INTEGER :: errstat + + + IF (mnproc.eq.1) THEN + WRITE(io_stdo_bgc,*)'Memory allocation for sediment output of the extended nitrogen cycle ...' + WRITE(io_stdo_bgc,*)'First dimension : ',kpie + WRITE(io_stdo_bgc,*)'Second dimension : ',kpje + WRITE(io_stdo_bgc,*)'Third dimension : ',ksed + WRITE(io_stdo_bgc,*)'Fourth dimension : ',n_seddiag + ENDIF + + ALLOCATE (extNsed_diagnostics(kpie,kpje,ksed,n_seddiag),stat=errstat) + + if(errstat.ne.0) stop 'not enough memory extended nitrogen cycle' + + end subroutine alloc_mem_extNsediment_diag + ! ================================================================================================================================ subroutine extNsediment_param_init() use mo_extNbioproc,only: q10ano3denit,sc_ano3denit,Trefano3denit,bkano3denit, & - & q10anmx,Trefanmx,alphaanmx,bkoxanmx,bkano2anmx,bkanh4anmx, & + & q10anmx,Trefanmx,alphaanmx,bkoxanmx,bkano2anmx, & & q10ano2denit,Trefano2denit,bkoxano2denit,bkano2denit, & & q10an2odenit,Trefan2odenit,bkoxan2odenit,bkan2odenit, & & q10dnra,Trefdnra,bkoxdnra,bkdnra, & - & q10anh4nitr,Trefanh4nitr,bkoxamox,bkanh4nitr,bkamoxn2o,bkamoxno2,bkyamox,n2omaxy,n2oybeta,bn2o,mufn2o, & - & q10ano2nitr,Trefano2nitr,bkoxnitr,bkano2nitr,NOB2AOAy, & - & rc2n,ro2utammo,ro2nnit,rnoxp,rnoxpi,rno2anmx,rno2anmxi,rnh4anmx, & - & rnh4anmxi,rno2dnra,rno2dnrai,rnh4dnra,rnh4dnrai,rnm1 + & q10anh4nitr,Trefanh4nitr,bkoxamox,bkanh4nitr,bkamoxn2o,bkamoxno2,bkyamox,n2omaxy,n2oybeta, & + & q10ano2nitr,Trefano2nitr,bkoxnitr,bkano2nitr,NOB2AOAy,rno2anmx,rnh4anmx implicit none ! === Denitrification step NO3 -> NO2: @@ -170,7 +213,7 @@ subroutine sed_nitrification(j,kpie,kpje,kpke,kbnd,ptho,omask,ex_ddic,ex_dalk) integer :: i,k real :: Tdepanh4,O2limanh4,nut1lim,anh4new,potdnh4amox,fdetamox,fno2,fn2o,ftotnh4 - real :: Tdepano2,O2limano2,nut2lim,ano2new,potdno2nitr,fdetnitr,ftotno2,no2fn2o,no2fno2,no2fdetamox + real :: Tdepano2,O2limano2,nut2lim,ano2new,potdno2nitr,fdetnitr,no2fn2o,no2fno2,no2fdetamox real :: amoxfrac,nitrfrac,totd,amox,nitr,temp,w2s do i = 1,kpie @@ -267,6 +310,13 @@ subroutine sed_nitrification(j,kpie,kpje,kpke,kbnd,ptho,omask,ex_ddic,ex_dalk) ! at later stage, when undersaturation of CaCO3 has been calculted ex_ddic(i,k) = ex_ddic(i,k) - rc2n*(fdetamox*amox + fdetnitr*nitr) ex_dalk(i,k) = ex_dalk(i,k) - (2.*fno2 + fn2o + rnm1*rnoi*fdetamox)*amox - rnm1*rnoi*fdetnitr*nitr + + ! output: + extNsed_diagnostics(i,j,k,ised_nitr_NH4) = amox + extNsed_diagnostics(i,j,k,ised_nitr_NO2) = nitr + extNsed_diagnostics(i,j,k,ised_nitr_N2O_prod) = 0.5*fn2o*amox + extNsed_diagnostics(i,j,k,ised_nitr_NH4_OM) = rnoi*fdetamox*amox * w2s + extNsed_diagnostics(i,j,k,ised_nitr_NO2_OM) = rnoi*fdetnitr*nitr * w2s endif enddo enddo @@ -310,6 +360,9 @@ subroutine sed_denit_NO3_to_NO2(j,kpie,kpje,kpke,kbnd,ptho,omask,ex_ddic,ex_dalk ! at later stage, when undersaturation of CaCO3 has been calculted ex_ddic(i,k) = ex_ddic(i,k) + ano3denit*rcar*rnoxpi ex_dalk(i,k) = ex_dalk(i,k) + ano3denit*rnm1*rnoxpi + + ! Output: + extNsed_diagnostics(i,j,k,ised_denit_NO3) = ano3denit endif enddo enddo @@ -360,6 +413,10 @@ subroutine sed_anammox(j,kpie,kpje,kpke,kbnd,ptho,omask,ex_ddic,ex_dalk) ! at later stage, when undersaturation of CaCO3 has been calculted ex_ddic(i,k) = ex_ddic(i,k) - ano2anmx*rcar*rno2anmxi ex_dalk(i,k) = ex_dalk(i,k) - ano2anmx*rnm1*rno2anmxi + + ! Output: + extNsed_diagnostics(i,j,k,ised_anmx_N2_prod) = ano2anmx*(rnh4anmx-rnit)*rno2anmxi ! kmol N2/m3/dtb - N2 prod through anammox + extNsed_diagnostics(i,j,k,ised_anmx_OM_prod) = ano2anmx*rno2anmxi*w2s endif enddo enddo @@ -377,10 +434,10 @@ subroutine sed_denit_DNRA(j,kpie,kpje,kpke,kbnd,ptho,omask,ex_ddic,ex_dalk) ! local variables integer :: i,k - real :: Tdepano2,O2inhibano2,nutlimano2,detlimano2,rpotano2denit,ano2denit - real :: Tdepdnra,O2inhibdnra,nutlimdnra,detlimdnra,rpotano2dnra,ano2dnra + real :: Tdepano2,O2inhibano2,nutlimano2,rpotano2denit,ano2denit + real :: Tdepdnra,O2inhibdnra,nutlimdnra,rpotano2dnra,ano2dnra real :: fdenit,fdnra,potano2new,potdano2,potddet,fdetano2denit,fdetan2odenit,fdetdnra - real :: Tdepan2o,O2inhiban2o,nutliman2o,detliman2o,an2onew,an2odenit + real :: Tdepan2o,O2inhiban2o,nutliman2o,an2onew,an2odenit real :: temp,s2w @@ -459,6 +516,10 @@ subroutine sed_denit_DNRA(j,kpie,kpje,kpke,kbnd,ptho,omask,ex_ddic,ex_dalk) ! at later stage, when undersaturation of CaCO3 has been calculted ex_ddic(i,k) = ex_ddic(i,k) + rcar*rnoxpi*(ano2denit + an2odenit) + rcar*rno2dnrai*ano2dnra ex_dalk(i,k) = ex_dalk(i,k) + (295.*ano2denit + rnm1*an2odenit)*rnoxpi + (rno2dnra + rnh4dnra - 1.)*rno2dnrai * ano2dnra + + extNsed_diagnostics(i,j,k,ised_denit_NO2) = ano2denit + extNsed_diagnostics(i,j,k,ised_denit_N2O) = an2odenit + extNsed_diagnostics(i,j,k,ised_DNRA_NO2) = ano2dnra endif enddo enddo diff --git a/hamocc/ncout_hamocc.F90 b/hamocc/ncout_hamocc.F90 index b87f7250..577da9e7 100644 --- a/hamocc/ncout_hamocc.F90 +++ b/hamocc/ncout_hamocc.F90 @@ -205,6 +205,19 @@ subroutine ncwrt_bgc(iogrp) & jlvl_anmx_N2_prod,jlvl_anmx_OM_prod, & & jlvl_phosy_NH4,jlvl_phosy_NO3, & & jlvl_remin_aerob,jlvl_remin_sulf +#endif +#if defined(extNcycle) && ! defined(sedbypass) + use mo_bgcmean, only: jpownh4,jpown2o,jpowno2,jsdm_nitr_NH4,jsdm_nitr_NO2, & + & jsdm_nitr_N2O_prod,jsdm_nitr_NH4_OM,jsdm_nitr_NO2_OM, & + & jsdm_denit_NO3,jsdm_denit_NO2,jsdm_denit_N2O, & + & jsdm_DNRA_NO2,jsdm_anmx_N2_prod,jsdm_anmx_OM_prod, & + & jsdm_remin_aerob,jsdm_remin_sulf, SDM_POWNH4,SDM_POWN2O,& + & SDM_POWNO2,SDM_nitr_NH4,SDM_nitr_NO2,SDM_nitr_N2O_prod, & + & SDM_nitr_NH4_OM,SDM_nitr_NO2_OM,SDM_denit_NO3, & + & SDM_denit_NO2,SDM_denit_N2O,SDM_DNRA_NO2, & + & SDM_anmx_N2_prod,SDM_anmx_OM_prod,SDM_remin_aerob, & + & SDM_remin_sulf,jsediffnh4,jsediffn2o,jsediffno2, & + & FLX_SEDIFFNH4,FLX_SEDIFFN2O,FLX_SEDIFFNO2 #endif implicit none @@ -632,6 +645,14 @@ subroutine ncwrt_bgc(iogrp) & rnacc*1e3/dtbgc,0.,cmpflg,'sedfno3',' ',' ',' ') call wrtsrf(jsediffsi(iogrp),FLX_SEDIFFSI(iogrp), & & rnacc*1e3/dtbgc,0.,cmpflg,'sedfsi',' ',' ',' ') +#endif +#if defined(extNcycle) && ! defined(sedbypass) + call wrtsrf(jsediffnh4(iogrp),FLX_SEDIFFNH4(iogrp), & + & rnacc*1e3/dtbgc,0.,cmpflg,'sedfnh4',' ',' ',' ') + call wrtsrf(jsediffn2o(iogrp),FLX_SEDIFFN2O(iogrp), & + & rnacc*1e3/dtbgc,0.,cmpflg,'sedfn2o',' ',' ',' ') + call wrtsrf(jsediffno2(iogrp),FLX_SEDIFFNO2(iogrp), & + & rnacc*1e3/dtbgc,0.,cmpflg,'sedfno2',' ',' ',' ') #endif call wrtsrf(jn2ofx(iogrp),SRF_N2OFX(iogrp),rnacc*1e3/dtbgc,0., & & cmpflg,'n2oflux','N2O flux',' ','mol N2O m-2 s-1') @@ -1158,6 +1179,56 @@ subroutine ncwrt_bgc(iogrp) call wrtbur(jburssster(iogrp),BUR_SSSTER(iogrp),rnacc*1e3,0., & & cmpflg,'burter','Burial clay',' ','mol m-2') #endif +#if defined(extNcycle) && ! defined(sedbypass) + call wrtsdm(jpownh4(iogrp),SDM_POWNH4(iogrp),rnacc*1e3,0.,cmpflg, & + & 'pownh4','PoWa ammonium',' ','mol N m-3') + call wrtsdm(jpown2o(iogrp),SDM_POWN2O(iogrp),rnacc*1e3,0.,cmpflg, & + & 'pown2o','PoWa nitrous oxide',' ','mol N2O m-3') + call wrtsdm(jpowno2(iogrp),SDM_POWNO2(iogrp),rnacc*1e3,0.,cmpflg, & + & 'powno2','PoWa nitrite',' ','mol N m-3') + call wrtsdm(jsdm_nitr_NH4(iogrp),sdm_nitr_NH4(iogrp), & + & rnacc*1e3/dtbgc,0.,cmpflg, & + & 'nh4nitrsdm','NH4 nitrification rate sediment',' ','mol N m-3 s-1') + call wrtsdm(jsdm_nitr_NO2(iogrp),sdm_nitr_NO2(iogrp), & + & rnacc*1e3/dtbgc,0.,cmpflg, & + & 'no2nitrsdm','NO2 nitrification rate sediment',' ','mol N m-3 s-1') + call wrtsdm(jsdm_nitr_N2O_prod(iogrp),sdm_nitr_N2O_prod(iogrp), & + & rnacc*1e3/dtbgc,0.,cmpflg, & + & 'nitr_n2osdm','N2O prod during NH4 nitrification sediment',' ', & + & 'mol N2O m-3 s-1') + call wrtsdm(jsdm_nitr_NH4_OM(iogrp),sdm_nitr_NH4_OM(iogrp), & + & rnacc*1e3/dtbgc,0.,cmpflg, & + & 'nh4nitr_omsdm','OM production during NH4 nitrification sediment',' ', & + & 'mol P m-3 s-1') + call wrtsdm(jsdm_nitr_NO2_OM(iogrp),sdm_nitr_NO2_OM(iogrp), & + & rnacc*1e3/dtbgc,0.,cmpflg, & + & 'no2nitr_omsdm','OM production during NO2 nitrification sediment',' ', & + & 'mol P m-3 s-1') + call wrtsdm(jsdm_denit_NO3(iogrp),sdm_denit_NO3(iogrp), & + & rnacc*1e3/dtbgc,0.,cmpflg, & + & 'no3denitsdm','NO3 denitrification rate sediment',' ','mol N m-3 s-1') + call wrtsdm(jsdm_denit_NO2(iogrp),sdm_denit_NO2(iogrp), & + & rnacc*1e3/dtbgc,0.,cmpflg, & + & 'no2denitsdm','NO2 denitrification rate sediment',' ','mol N m-3 s-1') + call wrtsdm(jsdm_denit_N2O(iogrp),sdm_denit_N2O(iogrp), & + & rnacc*1e3/dtbgc,0.,cmpflg, & + & 'n2odenitsdm','N2O denitrification rate sediment',' ','mol N2O m-3 s-1') + call wrtsdm(jsdm_DNRA_NO2(iogrp),sdm_DNRA_NO2(iogrp), & + & rnacc*1e3/dtbgc,0.,cmpflg, & + & 'no2dnrasdm','NO2 DNRA rate sediment',' ','mol N m-3 s-1') + call wrtsdm(jsdm_anmx_N2_prod(iogrp),sdm_anmx_N2_prod(iogrp), & + & rnacc*1e3/dtbgc,0.,cmpflg, & + & 'anmx_n2sdm','Anammox N2 production rate sediment',' ','mol N2 m-3 s-1') + call wrtsdm(jsdm_anmx_OM_prod(iogrp),sdm_anmx_OM_prod(iogrp), & + & rnacc*1e3/dtbgc,0.,cmpflg, & + & 'anmx_omsdm','Anammox OM production rate sediment',' ','mol P m-3 s-1') + call wrtsdm(jsdm_remin_aerob(iogrp),sdm_remin_aerob(iogrp), & + & rnacc*1e3/dtbgc,0.,cmpflg, & + & 'reminasdm','Aerob remineralization rate sediment',' ','mol N m-3 s-1') + call wrtsdm(jsdm_remin_sulf(iogrp),sdm_remin_sulf(iogrp), & + & rnacc*1e3/dtbgc,0.,cmpflg, & + & 'reminssdm','Sulfate remineralization rate sediment',' ','mol P m-3 s-1') +#endif ! --- close netcdf file call ncfcls @@ -1459,6 +1530,24 @@ subroutine ncwrt_bgc(iogrp) call inibur(jburssssil(iogrp),0.) call inibur(jburssster(iogrp),0.) #endif +#if defined(extNcycle) && ! defined(sedbypass) + call inisdm(jpownh4(iogrp),0.) + call inisdm(jpown2o(iogrp),0.) + call inisdm(jpowno2(iogrp),0.) + call inisdm(jsdm_nitr_NH4(iogrp),0.) + call inisdm(jsdm_nitr_NO2(iogrp),0.) + call inisdm(jsdm_nitr_N2O_prod(iogrp),0.) + call inisdm(jsdm_nitr_NH4_OM(iogrp),0.) + call inisdm(jsdm_nitr_NO2_OM(iogrp),0.) + call inisdm(jsdm_denit_NO3(iogrp),0.) + call inisdm(jsdm_denit_NO2(iogrp),0.) + call inisdm(jsdm_denit_N2O(iogrp),0.) + call inisdm(jsdm_DNRA_NO2(iogrp),0.) + call inisdm(jsdm_anmx_N2_prod(iogrp),0.) + call inisdm(jsdm_anmx_OM_prod(iogrp),0.) + call inisdm(jsdm_remin_aerob(iogrp),0.) + call inisdm(jsdm_remin_sulf(iogrp),0.) +#endif nacc_bgc(iogrp)=0 @@ -1564,6 +1653,22 @@ subroutine hamoccvardef(iogrp,timeunits,calendar,cmpflg) & jlvl_phosy_NH4,jlvl_phosy_NO3, & & jlvl_remin_aerob,jlvl_remin_sulf #endif +#if defined(extNcycle) && ! defined(sedbypass) + use mo_bgcmean, only: jpownh4,jpown2o,jpowno2,jsdm_nitr_NH4,jsdm_nitr_NO2, & + & jsdm_nitr_N2O_prod,jsdm_nitr_NH4_OM,jsdm_nitr_NO2_OM, & + & jsdm_denit_NO3,jsdm_denit_NO2,jsdm_denit_N2O, & + & jsdm_DNRA_NO2,jsdm_anmx_N2_prod,jsdm_anmx_OM_prod, & + & jsdm_remin_aerob,jsdm_remin_sulf, SDM_POWNH4,SDM_POWN2O,& + & SDM_POWNO2,SDM_nitr_NH4,SDM_nitr_NO2,SDM_nitr_N2O_prod, & + & SDM_nitr_NH4_OM,SDM_nitr_NO2_OM,SDM_denit_NO3, & + & SDM_denit_NO2,SDM_denit_N2O,SDM_DNRA_NO2, & + & SDM_anmx_N2_prod,SDM_anmx_OM_prod,SDM_remin_aerob, & + & SDM_remin_sulf,jsediffnh4,jsediffn2o,jsediffno2, & + & FLX_SEDIFFNH4,FLX_SEDIFFN2O,FLX_SEDIFFNO2 +#endif + + + implicit none integer iogrp,cmpflg @@ -1695,6 +1800,17 @@ subroutine hamoccvardef(iogrp,timeunits,calendar,cmpflg) & 'diffusive silica flux to sediment (positive downwards)', & & ' ','mol Si m-2 s-1',0) #endif +#if defined(extNcycle) && ! defined(sedbypass) + call ncdefvar3d(FLX_SEDIFFNH4(iogrp),cmpflg,'p','sedfnh4', & + & 'diffusive ammonium flux to sediment (positive downwards)', & + & ' ','mol NH4 m-2 s-1',0) + call ncdefvar3d(FLX_SEDIFFN2O(iogrp),cmpflg,'p','sedfn2o', & + & 'diffusive nitrous oxide flux to sediment (positive downwards)', & + & ' ','mol N2O m-2 s-1',0) + call ncdefvar3d(FLX_SEDIFFNO2(iogrp),cmpflg,'p','sedfno2', & + & 'diffusive nitrite flux to sediment (positive downwards)', & + & ' ','mol NO2 m-2 s-1',0) +#endif #ifdef cisonew call ncdefvar3d(SRF_CO213FXD(iogrp),cmpflg,'p','co213fxd', & & 'Downward 13CO2 flux',' ','kg C m-2 s-1',0) @@ -2161,7 +2277,49 @@ subroutine hamoccvardef(iogrp,timeunits,calendar,cmpflg) call ncdefvar3d(BUR_SSSTER(iogrp), & & cmpflg,'p','burter','Burial clay',' ','mol m-2',4) #endif +#if defined(extNcycle) && ! defined(sedbypass) + call ncdefvar3d(SDM_POWNH4(iogrp),cmpflg,'p', & + & 'pownh4','PoWa ammonium',' ','mol N m-3',3) + call ncdefvar3d(SDM_POWN2O(iogrp),cmpflg,'p', & + & 'pown2o','PoWa nitrous oxide',' ','mol N m-3',3) + call ncdefvar3d(SDM_POWNO2(iogrp),cmpflg,'p', & + & 'powno2','PoWa nitrite',' ','mol N m-3',3) + call ncdefvar3d(sdm_nitr_NH4(iogrp),cmpflg,'p', & + & 'nh4nitrsdm','NH4 nitrification rate sediment',' ','mol N m-3 s-1',3) + call ncdefvar3d(sdm_nitr_NO2(iogrp),cmpflg,'p', & + & 'no2nitrsdm','NO2 nitrification rate sediment',' ','mol N m-3 s-1',3) + call ncdefvar3d(sdm_nitr_N2O_prod(iogrp),cmpflg,'p', & + & 'nitr_n2osdm','N2O prod during NH4 nitrification sediment',' ', & + & 'mol N2O m-3 s-1',3) + call ncdefvar3d(sdm_nitr_NH4_OM(iogrp),cmpflg,'p', & + & 'nh4nitr_omsdm','OM production during NH4 nitrification sediment',' ', & + & 'mol P m-3 s-1',3) + call ncdefvar3d(sdm_nitr_NO2_OM(iogrp),cmpflg,'p', & + & 'no2nitr_omsdm','OM production during NO2 nitrification sediment',' ', & + & 'mol P m-3 s-1',3) + call ncdefvar3d(sdm_denit_NO3(iogrp),cmpflg,'p', & + & 'no3denitsdm','NO3 denitrification rate sediment',' ','mol N m-3 s-1',3) + call ncdefvar3d(sdm_denit_NO2(iogrp),cmpflg,'p', & + & 'no2denitsdm','NO2 denitrification rate sediment',' ','mol N m-3 s-1',3) + call ncdefvar3d(sdm_denit_N2O(iogrp),cmpflg,'p', & + & 'n2odenitsdm','N2O denitrification rate sediment',' ', & + & 'mol N2O m-3 s-1',3) + call ncdefvar3d(sdm_DNRA_NO2(iogrp),cmpflg,'p', & + & 'no2dnrasdm','NO2 DNRA rate sediment',' ','mol N m-3 s-1',3) + call ncdefvar3d(sdm_anmx_N2_prod(iogrp),cmpflg,'p', & + & 'anmx_n2sdm','Anammox N2 production rate sediment',' ', & + & 'mol N2 m-3 s-1',3) + call ncdefvar3d(sdm_anmx_OM_prod(iogrp),cmpflg,'p', & + & 'anmx_omsdm','Anammox OM production rate sediment',' ', & + & 'mol P m-3 s-1',3) + call ncdefvar3d(sdm_remin_aerob(iogrp),cmpflg,'p', & + & 'reminasdm','Aerob remineralization rate sediment',' ', & + & 'mol N m-3 s-1',3) + call ncdefvar3d(sdm_remin_sulf(iogrp),cmpflg,'p', & + & 'reminssdm','Sulfate remineralization rate sediment',' ', & + & 'mol P m-3 s-1',3) +#endif ! --- enddef netcdf file call ncedef end subroutine hamoccvardef diff --git a/hamocc/powach.F90 b/hamocc/powach.F90 index ee7ce465..fd258920 100644 --- a/hamocc/powach.F90 +++ b/hamocc/powach.F90 @@ -77,7 +77,8 @@ subroutine powach(kpie,kpje,kpke,kbnd,prho,omask,psao,ptho,lspin) #ifdef extNcycle use mo_param1_bgc, only: ipownh4 use mo_extNbioproc, only: ro2utammo - use mo_extNsediment, only: extNsediment_param_init,sed_nitrification,sed_denit_NO3_to_NO2,sed_anammox,sed_denit_DNRA + use mo_extNsediment, only: extNsediment_param_init,sed_nitrification,sed_denit_NO3_to_NO2,sed_anammox,sed_denit_DNRA, & + & extNsed_diagnostics,ised_remin_aerob,ised_remin_sulf #endif @@ -364,6 +365,7 @@ subroutine powach(kpie,kpje,kpke,kbnd,prho,omask,psao,ptho,lspin) powtra(i,j,k,ipownh4) = powtra(i,j,k,ipownh4) + posol*rnit*umfa ex_ddic(i,k) = rcar*posol*umfa ! C-units kmol C/m3 of pore water ex_dalk(i,k) = (rnit-1.)*posol*umfa ! alkalinity units + extNsed_diagnostics(i,j,k,ised_remin_aerob) = posol*rnit*umfa ! Output #endif powtra(i,j,k,ipowaox) = sediso(i,k) #ifdef cisonew @@ -440,6 +442,9 @@ subroutine powach(kpie,kpje,kpke,kbnd,prho,omask,psao,ptho,lspin) #ifdef cisonew sedlay(i,j,k,issso13) = sedlay(i,j,k,issso13) - poso13 sedlay(i,j,k,issso14) = sedlay(i,j,k,issso14) - poso14 +#endif +#ifdef extNcycle + extNsed_diagnostics(i,j,k,ised_remin_sulf) = posol*umfa ! Output #endif endif endif From 57a290c1f467aad79b7f60a930785174e3e8c96b Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Mon, 26 Sep 2022 15:22:10 +0200 Subject: [PATCH 182/366] T- and O2-dependent ammonification in sediment --- hamocc/beleg_parm.F90 | 15 +++++++++------ hamocc/mo_extNsediment.F90 | 15 ++++++++++++--- hamocc/powach.F90 | 27 ++++++++++++++++++++------- 3 files changed, 41 insertions(+), 16 deletions(-) diff --git a/hamocc/beleg_parm.F90 b/hamocc/beleg_parm.F90 index 371f457c..224d55ee 100644 --- a/hamocc/beleg_parm.F90 +++ b/hamocc/beleg_parm.F90 @@ -255,12 +255,6 @@ SUBROUTINE BELEG_PARM(kpie,kpje) rdn2o1=2*ro2ut-2.5*rnit ! moles N2O used for remineralisation of 1 mole P rdn2o2=2*ro2ut-2*rnit ! moles N2 released for remineralisation of 1 mole P -#ifdef extNcycle - ! initialize the extended nitrogen cycle parameters - first water column, then sediment, - ! since sediment relies on water column parameters for the extended nitrogen cycle - call extNbioparam_init() - call extNsediment_param_init() -#endif #ifdef BROMO !Bromoform to phosphate ratio (Hense and Quack, 2009) @@ -292,6 +286,15 @@ SUBROUTINE BELEG_PARM(kpie,kpje) drempoc = 0.12*dtb dremopal = 0.023*dtb endif + +#ifdef extNcycle + ! initialize the extended nitrogen cycle parameters - first water column, then sediment, + ! since sediment relies on water column parameters for the extended nitrogen cycle + ! Sediment also relies on M4AGO being initialized (POM_remin_q10 and POM_remin_Tref) + call extNbioparam_init() + call extNsediment_param_init() +#endif + ! parameters for sw-radiation attenuation ! Analog to Moore et al., Deep-Sea Research II 49 (2002), 403-462 ! 1 kmolP = (122*12/60)*10^6 mg[Chlorophyl] diff --git a/hamocc/mo_extNsediment.F90 b/hamocc/mo_extNsediment.F90 index 52e12ddf..81d4bd30 100644 --- a/hamocc/mo_extNsediment.F90 +++ b/hamocc/mo_extNsediment.F90 @@ -59,7 +59,8 @@ MODULE mo_extNsediment ! public parameters and fields public :: ised_nitr_NH4,ised_nitr_NO2,ised_nitr_N2O_prod,ised_nitr_NH4_OM,ised_nitr_NO2_OM,ised_denit_NO3,ised_denit_NO2, & - ised_denit_N2O,ised_DNRA_NO2,ised_anmx_N2_prod,ised_anmx_OM_prod,ised_remin_aerob,ised_remin_sulf,extNsed_diagnostics + ised_denit_N2O,ised_DNRA_NO2,ised_anmx_N2_prod,ised_anmx_OM_prod,ised_remin_aerob,ised_remin_sulf,extNsed_diagnostics, & + POM_remin_q10_sed, POM_remin_Tref_sed,bkox_drempoc_sed ! extended nitrogen cycle sediment parameters real :: q10ano3denit_sed,sc_ano3denit_sed,Trefano3denit_sed,rano3denit_sed,bkano3denit_sed, & @@ -69,7 +70,7 @@ MODULE mo_extNsediment & rdnra_sed,q10dnra_sed,Trefdnra_sed,bkoxdnra_sed,bkdnra_sed,ranh4nitr_sed,q10anh4nitr_sed, & & Trefanh4nitr_sed,bkoxamox_sed,bkanh4nitr_sed,bkamoxn2o_sed,bkamoxno2_sed,bkyamox_sed, & & rano2nitr_sed,q10ano2nitr_sed,Trefano2nitr_sed,bkoxnitr_sed,bkano2nitr_sed,n2omaxy_sed, & - & n2oybeta_sed,NOB2AOAy_sed,bn2o_sed,mufn2o_sed + & n2oybeta_sed,NOB2AOAy_sed,bn2o_sed,mufn2o_sed,POM_remin_q10_sed, POM_remin_Tref_sed,bkox_drempoc_sed ! output real, dimension (:,:,:,:), allocatable :: extNsed_diagnostics @@ -127,8 +128,16 @@ subroutine extNsediment_param_init() & q10dnra,Trefdnra,bkoxdnra,bkdnra, & & q10anh4nitr,Trefanh4nitr,bkoxamox,bkanh4nitr,bkamoxn2o,bkamoxno2,bkyamox,n2omaxy,n2oybeta, & & q10ano2nitr,Trefano2nitr,bkoxnitr,bkano2nitr,NOB2AOAy,rno2anmx,rnh4anmx + use mo_m4ago, only: POM_remin_q10,POM_remin_Tref + use mo_biomod, only: bkox_drempoc + implicit none - + + ! === Ammonification in the sediment + POM_remin_q10_sed = POM_remin_q10 ! ammonification Q10 in sediment + POM_remin_Tref_sed = POM_remin_Tref ! ammonification Tref in sediment + bkox_drempoc_sed = bkox_drempoc ! half saturation constant for O2 limitatio of ammonification in sediment + ! === Denitrification step NO3 -> NO2: !rano3denit_sed = 0.15*dtb ! Maximum growth rate denitrification on NO3 at reference T (1/d -> 1/dt) rano3denit_sed = 0.05*dtb ! Maximum growth rate denitrification on NO3 at reference T (1/d -> 1/dt) diff --git a/hamocc/powach.F90 b/hamocc/powach.F90 index fd258920..6251e7a4 100644 --- a/hamocc/powach.F90 +++ b/hamocc/powach.F90 @@ -78,7 +78,8 @@ subroutine powach(kpie,kpje,kpke,kbnd,prho,omask,psao,ptho,lspin) use mo_param1_bgc, only: ipownh4 use mo_extNbioproc, only: ro2utammo use mo_extNsediment, only: extNsediment_param_init,sed_nitrification,sed_denit_NO3_to_NO2,sed_anammox,sed_denit_DNRA, & - & extNsed_diagnostics,ised_remin_aerob,ised_remin_sulf + & extNsed_diagnostics,ised_remin_aerob,ised_remin_sulf,POM_remin_q10_sed,POM_remin_Tref_sed, & + & bkox_drempoc_sed #endif @@ -101,6 +102,7 @@ subroutine powach(kpie,kpje,kpke,kbnd,prho,omask,psao,ptho,lspin) real :: anaerob(kpie,ks) #else real :: ex_ddic(kpie,ks),ex_dalk(kpie,ks) !sum of DIC and alk changes related to extended nitrogen cycle + real :: ex_disso_poc #endif #ifdef cisonew real :: aerob13(kpie,ks),anaerob13(kpie,ks),sulf13(kpie,ks) @@ -134,7 +136,7 @@ subroutine powach(kpie,kpje,kpke,kbnd,prho,omask,psao,ptho,lspin) #ifndef extNcycle !$OMP& anaerob, & #else -!$OMP& ex_dalk,ex_ddic, & +!$OMP& ex_dalk,ex_ddic,ex_disso_poc, & #endif !$OMP& dissot,undsa,posol, & !$OMP& umfa,denit,saln,rrho,alk,c,sit,pt, & @@ -281,9 +283,12 @@ subroutine powach(kpie,kpje,kpke,kbnd,prho,omask,psao,ptho,lspin) & * porsol(i,j,1) / porwat(i,j,1) #else ! extended nitrogen cycle - 140mol O2/mol POP O2-consumption - solrat(i,1) = ( sedlay(i,j,1,issso12) + prorca(i,j) & - & / (porsol(i,j,1) * seddw(1)) ) & - & * ro2utammo * dissot / (1. + dissot * undsa) & + ! O2 and T-dep + ex_disso_poc = dissot * powtra(i,j,k,ipowaox)/(powtra(i,j,k,ipowaox) + bkox_drempoc_sed) & ! oxygen limitation + & * POM_remin_q10_sed**((ptho(i,j,kbo(i,j))-POM_remin_Tref_sed)/10.) ! T-dep + solrat(i,1) = ( sedlay(i,j,1,issso12) + prorca(i,j) & + & / (porsol(i,j,1) * seddw(1)) ) & + & * ro2utammo * ex_disso_poc / (1. + ex_disso_poc * undsa) & & * porsol(i,j,1) / porwat(i,j,1) #endif endif @@ -303,8 +308,10 @@ subroutine powach(kpie,kpje,kpke,kbnd,prho,omask,psao,ptho,lspin) & / (1. + dissot*undsa) * porsol(i,j,k) / porwat(i,j,k) #else ! extended nitrogen cycle - 140mol O2/mol POP O2-consumption - if (k > 1) solrat(i,k) = sedlay(i,j,k,issso12) * ro2utammo * dissot & - & / (1. + dissot*undsa) * porsol(i,j,k) / porwat(i,j,k) + ex_disso_poc = dissot * powtra(i,j,k,ipowaox)/(powtra(i,j,k,ipowaox) + bkox_drempoc_sed) & ! oxygen limitation + & * POM_remin_q10_sed**((ptho(i,j,kbo(i,j))-POM_remin_Tref_sed)/10.) ! T-dep + if (k > 1) solrat(i,k) = sedlay(i,j,k,issso12) * ro2utammo * ex_disso_poc & + & / (1. + ex_disso_poc*undsa) * porsol(i,j,k) / porwat(i,j,k) #endif endif enddo @@ -346,7 +353,13 @@ subroutine powach(kpie,kpje,kpke,kbnd,prho,omask,psao,ptho,lspin) do i = 1, kpie if(omask(i,j) > 0.5) then umfa = porsol(i,j,k) / porwat(i,j,k) +#ifndef extNcycle solrat(i,k) = sedlay(i,j,k,issso12) * dissot/(1. + dissot*sediso(i,k)) +#else + ex_disso_poc = dissot * powtra(i,j,k,ipowaox)/(powtra(i,j,k,ipowaox) + bkox_drempoc_sed) & ! oxygen limitation + & * POM_remin_q10_sed**((ptho(i,j,kbo(i,j))-POM_remin_Tref_sed)/10.) ! T-dep + solrat(i,k) = sedlay(i,j,k,issso12) * ex_disso_poc/(1. + ex_disso_poc*sediso(i,k)) +#endif posol = sediso(i,k)*solrat(i,k) #ifdef cisonew rato13 = sedlay(i,j,k,issso13) / (sedlay(i,j,k,issso12) + safediv) From 58252b52d6132f73c02373f76da1601a13c96c20 Mon Sep 17 00:00:00 2001 From: Tomas Torsvik Date: Fri, 5 Aug 2022 15:33:54 +0200 Subject: [PATCH 183/366] Remove redundant definition of kOBL. --- phy/mod_difest.F | 4 ---- 1 file changed, 4 deletions(-) diff --git a/phy/mod_difest.F b/phy/mod_difest.F index e661e8ba..823d0b12 100644 --- a/phy/mod_difest.F +++ b/phy/mod_difest.F @@ -1205,10 +1205,6 @@ subroutine difest_vertical_hyb(m,n,mm,nn,k1m,k1n) . kk, ! (in) Number of levels in array shape . CVMix_kpp_params_user=KPP_params ) ! KPP parameters - ! gets index of the level and interface above hbl - kOBL = CVMix_kpp_compute_kOBL_depth(iFaceHeight, - . cellHeight,OBLdepth(i,j)) - c ---- ccc ------- ! convert m2/s to cm2/s Kv_kpp = Kv_kpp*1e4 From 855a8f8deea642d36375eb9ff817c1873991a6b8 Mon Sep 17 00:00:00 2001 From: Tomas Torsvik Date: Tue, 27 Sep 2022 13:06:03 +0200 Subject: [PATCH 184/366] Redefine kOBL, cast as integer --- phy/mod_difest.F | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/phy/mod_difest.F b/phy/mod_difest.F index 823d0b12..2d2dde96 100644 --- a/phy/mod_difest.F +++ b/phy/mod_difest.F @@ -1161,8 +1161,8 @@ subroutine difest_vertical_hyb(m,n,mm,nn,k1m,k1n) . cellHeight,OBLdepth(i,j)) ! gets index of the level and interface above hbl - kOBL = CVMix_kpp_compute_kOBL_depth(iFaceHeight, - . cellHeight,OBLdepth(i,j)) + kOBL = int(hOBL(i,j)) ! index of interface above OBL depth + c --- ------ Diapycnal mixing when local stability is weak c --- ------ convection routine based on N2 not rho c --- ------ make sure it is in metrics if stability depends on rho From 7c6f22c075319498ae0275111e4671eb7d2d4758 Mon Sep 17 00:00:00 2001 From: jmaerz <92309038+jmaerz@users.noreply.github.com> Date: Tue, 27 Sep 2022 14:50:20 +0200 Subject: [PATCH 185/366] Fixing variable sediment porosity - field initialization in case of `sedbypass=true` (#198) * Removing bodensed - Initialization of sediment parameters and fields now in mo_sedmnt --- hamocc/bodensed.F90 | 193 -------------------------------------- hamocc/dipowa.F90 | 2 +- hamocc/hamocc_init.F90 | 8 +- hamocc/meson.build | 1 - hamocc/mo_sedmnt.F90 | 206 ++++++++++++++++++++++++++++++++++++++--- 5 files changed, 200 insertions(+), 210 deletions(-) delete mode 100644 hamocc/bodensed.F90 diff --git a/hamocc/bodensed.F90 b/hamocc/bodensed.F90 deleted file mode 100644 index 74cb9335..00000000 --- a/hamocc/bodensed.F90 +++ /dev/null @@ -1,193 +0,0 @@ -! Copyright (C) 2001 Ernst Maier-Reimer, S. Legutke -! Copyright (C) 2020 J. Schwinger -! -! This file is part of BLOM/iHAMOCC. -! -! 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 https://www.gnu.org/licenses/. - - -subroutine bodensed(kpie,kpje,kpke,pddpo,omask,sed_por) -!********************************************************************** -! -!**** *BODENSED* - . -! -! Ernst Maier-Reimer, *MPI-Met, HH* 10.04.01 -! -! Modified -! -------- -! S.Legutke, *MPI-MaD, HH* 10.04.01 -! -! Purpose -! ------- -! set up of sediment layer. -! -! -!** Interface to ocean model (parameter list): -! ----------------------------------------- -! -! *INTEGER* *kpie* - 1st dimension of model grid. -! *INTEGER* *kpje* - 2nd dimension of model grid. -! *INTEGER* *kpke* - 3rd (vertical) dimension of model grid. -! *REAL* *pddpo* - size of scalar grid cell (3rd dimension) [m]. -! -!********************************************************************** - - use mo_sedmnt, only: calcwei,calfa,clafa,claydens,calcdens,opaldens,opalwei,oplfa,orgdens,orgfa,seddzi,porwat,porwah, & - & porsol,dzs,seddw,sedict,solfu,orgwei,zcoefsu,zcoeflo,disso_sil,silsat,disso_poc,sed_denit,disso_caco3 - use mo_control_bgc, only: dtbgc,io_stdo_bgc,l_3Dvarsedpor - use mo_param1_bgc, only: ks - use mod_xc, only: mnproc - - implicit none - - integer, intent(in) :: kpie,kpje,kpke - real, intent(in) :: pddpo(kpie,kpje,kpke) - real, intent(in) :: omask(kpie,kpje) - real, intent(in) :: sed_por(kpie,kpje,ks) - - ! Local variables - integer :: i,j,k - real :: sumsed - - dzs(1) = 0.001 - dzs(2) = 0.003 - dzs(3) = 0.005 - dzs(4) = 0.007 - dzs(5) = 0.009 - dzs(6) = 0.011 - dzs(7) = 0.013 - dzs(8) = 0.015 - dzs(9) = 0.017 - dzs(10) = 0.019 - dzs(11) = 0.021 - dzs(12) = 0.023 - dzs(13) = 0.025 - - if (mnproc == 1) then - write(io_stdo_bgc,*) ' ' - write(io_stdo_bgc,*) 'Sediment layer thickness [m] : ' - write(io_stdo_bgc,'(5F9.3)') dzs - write(io_stdo_bgc,*) ' ' - endif - - ! this initialization can be done later via reading a porosity map - if (l_3Dvarsedpor)then - ! lon-lat variable sediment porosity from input file - do k=1,ks - do j=1,kpje - do i=1,kpie - if(omask(i,j).gt. 0.5)then - porwat(i,j,k) = sed_por(i,j,k) - endif - enddo - enddo - enddo - else - porwat(:,:,1) = 0.85 - porwat(:,:,2) = 0.83 - porwat(:,:,3) = 0.8 - porwat(:,:,4) = 0.79 - porwat(:,:,5) = 0.77 - porwat(:,:,6) = 0.75 - porwat(:,:,7) = 0.73 - porwat(:,:,8) = 0.7 - porwat(:,:,9) = 0.68 - porwat(:,:,10) = 0.66 - porwat(:,:,11) = 0.64 - porwat(:,:,12) = 0.62 - endif - - if (mnproc == 1) then - write(io_stdo_bgc,*) 'Pore water in sediment initialized' - endif - - seddzi(1) = 500. - do k = 1, ks - seddzi(k+1) = 1. / dzs(k+1) - seddw(k) = 0.5 * (dzs(k) + dzs(k+1)) - do j = 1, kpje - do i = 1, kpie - porsol(i,j,k) = 1. - porwat(i,j,k) - if(k >= 2) porwah(i,j,k) = 0.5 * (porwat(i,j,k) + porwat(i,j,k-1)) - if(k == 1) porwah(i,j,k) = 0.5 * (1. + porwat(i,j,1)) - enddo - enddo - enddo - - sedict = 1.e-9 * dtbgc ! Molecular diffusion coefficient - ! Dissolution rate constant of opal (disso) [1/(kmol Si(OH)4/m3)*1/sec] - ! THIS NEEDS TO BE CHANGED TO disso=3.e-8! THIS IS ONLY KEPT FOR THE MOMENT - ! FOR BACKWARDS COMPATIBILITY - !disso_sil = 3.e-8*dtbgc ! (2011-01-04) EMR - !disso_sil = 1.e-6*dtbgc ! test vom 03.03.04 half live sil ca. 20.000 yr - disso_sil = 1.e-6*dtbgc - ! Silicate saturation concentration is 1 mol/m3 - silsat = 0.001 - - ! Degradation rate constant of POP (disso) [1/(kmol O2/m3)*1/sec] - disso_poc = 0.01 / 86400. * dtbgc ! disso=3.e-5 was quite high - - ! Denitrification rate constant of POP (disso) [1/sec] - sed_denit = 0.01/86400. * dtbgc - - ! Dissolution rate constant of CaCO3 (disso) [1/(kmol CO3--/m3)*1/sec] - disso_caco3 = 1.e-7 * dtbgc - -! ****************************************************************** -! densities etc. for SEDIMENT SHIFTING - -! define weight of calcium carbonate, opal, and poc [kg/kmol] - calcwei = 100. ! 40+12+3*16 kg/kmol C - opalwei = 60. ! 28 + 2*16 kg/kmol Si - orgwei = 30. ! from 12 kg/kmol * 2.5 POC[kg]/DW[kg] - ! after Alldredge, 1998: - ! POC(g)/DW(g) = 0.4 of diatom marine snow, size 1mm3 - -! define densities of opal, caco3, poc [kg/m3] - calcdens = 2600. - opaldens = 2200. - orgdens = 1000. - claydens = 2600. !quartz - -! define volumes occupied by solid constituents [m3/kmol] - calfa = calcwei / calcdens - oplfa = opalwei / opaldens - orgfa = orgwei / orgdens - clafa = 1. / claydens !clay is calculated in kg/m3 - -! determine total solid sediment volume - solfu = 0. - do i = 1, kpie - do j = 1, kpje - do k = 1, ks - solfu(i,j) = solfu(i,j) + seddw(k) * porsol(i,j,k) - enddo - enddo - enddo - -! Initialize porosity-dependent diffusion coefficients of sediment - zcoefsu(:,:,0) = 0.0 - do k = 1,ks - do j = 1, kpje - do i = 1, kpie - ! sediment diffusion coefficient * 1/dz * fraction of pore water at half depths - zcoefsu(i,j,k ) = -sedict * seddzi(k) * porwah(i,j,k) - zcoeflo(i,j,k-1) = -sedict * seddzi(k) * porwah(i,j,k) ! why the same ? - enddo - enddo - enddo - zcoeflo(:,:,ks) = 0.0 ! diffusion coefficient for bottom sediment layer - - -end subroutine bodensed diff --git a/hamocc/dipowa.F90 b/hamocc/dipowa.F90 index e6fb22a2..f601b33b 100644 --- a/hamocc/dipowa.F90 +++ b/hamocc/dipowa.F90 @@ -40,7 +40,7 @@ subroutine dipowa(kpie,kpje,kpke,omask,lspin) ! Method ! ------- ! implicit formulation; -! constant diffusion coefficient : 1.e-9 set in BODENSED. +! constant diffusion coefficient : 1.e-9 set in ini_sedmnt in mo_sedmnt ! diffusion coefficient : zcoefsu/zcoeflo for upper/lower ! sediment layer boundary. ! diff --git a/hamocc/hamocc_init.F90 b/hamocc/hamocc_init.F90 index f7f2dcf3..72e05a36 100644 --- a/hamocc/hamocc_init.F90 +++ b/hamocc/hamocc_init.F90 @@ -47,10 +47,10 @@ subroutine hamocc_init(read_rest,rstfnm_hamocc) & sedspin_yr_s,sedspin_yr_e,sedspin_ncyc, & & dtb,dtbgc,io_stdo_bgc,ldtbgc, & & ldtrunbgc,ndtdaybgc,with_dmsph,l_3Dvarsedpor - use mo_param1_bgc, only: ks,nsedtra,npowtra,init_por2octra_mapping + use mo_param1_bgc, only: ks,init_por2octra_mapping use mo_carbch, only: alloc_mem_carbch,ocetra,atm,atm_co2 use mo_biomod, only: alloc_mem_biomod - use mo_sedmnt, only: alloc_mem_sedmnt,sedlay,powtra,burial + use mo_sedmnt, only: alloc_mem_sedmnt,sedlay,powtra,burial,ini_sedmnt use mo_vgrid, only: alloc_mem_vgrid,set_vgrid use mo_bgcmean, only: alloc_mem_bgcmean use mo_read_rivin, only: ini_read_rivin,rivinfile @@ -176,9 +176,9 @@ subroutine hamocc_init(read_rest,rstfnm_hamocc) call set_vgrid(idm,jdm,kdm,bgc_dp) ! ! --- Initialize sediment layering - ! First raed the porosity, then apply it in bodensed + ! First read the porosity, then apply it in ini_sedmnt CALL read_sedpor(idm,jdm,ks,omask,sed_por) - CALL BODENSED(idm,jdm,kdm,bgc_dp,omask,sed_por) + CALL ini_sedmnt(idm,jdm,kdm,omask,sed_por) ! ! --- Initialize parameters, sediment and ocean tracer. ! diff --git a/hamocc/meson.build b/hamocc/meson.build index acc6319d..cc6b7433 100644 --- a/hamocc/meson.build +++ b/hamocc/meson.build @@ -4,7 +4,6 @@ sources += files( 'aufw_bgc.F90', 'beleg_parm.F90', 'beleg_vars.F90', - 'bodensed.F90', 'carchm.F90', 'carchm_kequi.F90', 'carchm_solve.F90', diff --git a/hamocc/mo_sedmnt.F90 b/hamocc/mo_sedmnt.F90 index a1286f22..7fab49b4 100644 --- a/hamocc/mo_sedmnt.F90 +++ b/hamocc/mo_sedmnt.F90 @@ -17,7 +17,7 @@ ! along with BLOM. If not, see https://www.gnu.org/licenses/. - MODULE mo_sedmnt + MODULE mo_sedmnt !****************************************************************************** ! ! MODULE mo_sedmnt - Variables for sediment modules. @@ -32,6 +32,7 @@ MODULE mo_sedmnt ! Purpose ! ------- ! - declaration and memory allocation +! - initialization of sediment ! ! Description: ! ------------ @@ -62,8 +63,15 @@ MODULE mo_sedmnt ! *ansed* *REAL* - . ! *o2ut* *REAL* - . ! +! -subroutine ini_sedmnt +! Initialize sediment parameters (some are also used in water column) +! -subroutine ini_sedmnt_fields +! Initialize 2D and 3D sediment fields +! !****************************************************************************** - use mo_param1_bgc, only: ks,ksp,nsedtra,npowtra + use mo_param1_bgc, only: ks,ksp,nsedtra,npowtra + use mo_control_bgc, only: io_stdo_bgc + use mod_xc, only: mnproc implicit none @@ -97,16 +105,192 @@ MODULE mo_sedmnt REAL :: calfa, oplfa, orgfa, clafa REAL :: disso_sil,silsat,disso_poc,sed_denit,disso_caco3 - CONTAINS + CONTAINS + + !======================================================================== + SUBROUTINE ini_sedmnt(kpie,kpje,kpke,omask,sed_por) + use mo_control_bgc, only: dtbgc + implicit none - SUBROUTINE ALLOC_MEM_SEDMNT(kpie,kpje) -!****************************************************************************** -! ALLOC_MEM_SEDMNT - Allocate variables in this module -!****************************************************************************** - use mod_xc, only: mnproc - use mo_control_bgc, only: io_stdo_bgc + integer, intent(in) :: kpie,kpje,kpke + real, intent(in) :: omask(kpie,kpje) + real, intent(in) :: sed_por(kpie,kpje,ks) + + integer :: k + + sedict = 1.e-9 * dtbgc ! Molecular diffusion coefficient + ! Dissolution rate constant of opal (disso) [1/(kmol Si(OH)4/m3)*1/sec] + ! THIS NEEDS TO BE CHANGED TO disso=3.e-8! THIS IS ONLY KEPT FOR THE MOMENT + ! FOR BACKWARDS COMPATIBILITY + !disso_sil = 3.e-8*dtbgc ! (2011-01-04) EMR + !disso_sil = 1.e-6*dtbgc ! test vom 03.03.04 half live sil ca. 20.000 yr + disso_sil = 1.e-6*dtbgc + ! Silicate saturation concentration is 1 mol/m3 + silsat = 0.001 + + ! Degradation rate constant of POP (disso) [1/(kmol O2/m3)*1/sec] + disso_poc = 0.01 / 86400. * dtbgc ! disso=3.e-5 was quite high + + ! Denitrification rate constant of POP (disso) [1/sec] + sed_denit = 0.01/86400. * dtbgc + + ! Dissolution rate constant of CaCO3 (disso) [1/(kmol CO3--/m3)*1/sec] + disso_caco3 = 1.e-7 * dtbgc + + ! ****************************************************************** + ! densities etc. for SEDIMENT SHIFTING + + ! define weight of calcium carbonate, opal, and poc [kg/kmol] + calcwei = 100. ! 40+12+3*16 kg/kmol C + opalwei = 60. ! 28 + 2*16 kg/kmol Si + orgwei = 30. ! from 12 kg/kmol * 2.5 POC[kg]/DW[kg] + ! after Alldredge, 1998: + ! POC(g)/DW(g) = 0.4 of diatom marine snow, size 1mm3 + + ! define densities of opal, caco3, poc [kg/m3] + calcdens = 2600. + opaldens = 2200. + orgdens = 1000. + claydens = 2600. !quartz + + ! define volumes occupied by solid constituents [m3/kmol] + calfa = calcwei / calcdens + oplfa = opalwei / opaldens + orgfa = orgwei / orgdens + clafa = 1. / claydens !clay is calculated in kg/m3 + + ! sediment layer thickness + dzs(1) = 0.001 + dzs(2) = 0.003 + dzs(3) = 0.005 + dzs(4) = 0.007 + dzs(5) = 0.009 + dzs(6) = 0.011 + dzs(7) = 0.013 + dzs(8) = 0.015 + dzs(9) = 0.017 + dzs(10) = 0.019 + dzs(11) = 0.021 + dzs(12) = 0.023 + dzs(13) = 0.025 + + if (mnproc == 1) then + write(io_stdo_bgc,*) ' ' + write(io_stdo_bgc,*) 'Sediment layer thickness [m] : ' + write(io_stdo_bgc,'(5F9.3)') dzs + write(io_stdo_bgc,*) ' ' + endif + + seddzi(1) = 500. + do k = 1, ks + seddzi(k+1) = 1. / dzs(k+1) ! inverse of grid cell size + seddw(k) = 0.5 * (dzs(k) + dzs(k+1)) ! distance between grid cell centers (pressure points) + enddo + +#ifndef sedbypass + ! 2d and 3d fields are not allocated in case of sedbypass + ! so only initialize them if we are using the sediment + CALL ini_sedmnt_por(kpie,kpje,kpke,omask,sed_por) +#endif + END SUBROUTINE ini_sedmnt + + !======================================================================== + SUBROUTINE ini_sedmnt_por(kpie,kpje,kpke,omask,sed_por) + ! + ! Initialization of: + ! - 3D porosity field (cell center and cell boundaries) + ! - solid volume fraction at cell center + ! - vertical molecular diffusion coefficients scaled with porosity + ! + use mo_control_bgc, only: l_3Dvarsedpor + + implicit none + + integer, intent(in) :: kpie,kpje,kpke + real, intent(in) :: omask(kpie,kpje) + real, intent(in) :: sed_por(kpie,kpje,ks) + + ! local + integer :: i,j,k + + ! this initialization can be done via reading a porosity map + ! porwat is the poroisty at the (pressure point) center of the grid cell + if (l_3Dvarsedpor)then + ! lon-lat variable sediment porosity from input file + do k=1,ks + do j=1,kpje + do i=1,kpie + if(omask(i,j).gt. 0.5)then + porwat(i,j,k) = sed_por(i,j,k) + endif + enddo + enddo + enddo + else + porwat(:,:,1) = 0.85 + porwat(:,:,2) = 0.83 + porwat(:,:,3) = 0.8 + porwat(:,:,4) = 0.79 + porwat(:,:,5) = 0.77 + porwat(:,:,6) = 0.75 + porwat(:,:,7) = 0.73 + porwat(:,:,8) = 0.7 + porwat(:,:,9) = 0.68 + porwat(:,:,10) = 0.66 + porwat(:,:,11) = 0.64 + porwat(:,:,12) = 0.62 + endif + + if (mnproc == 1) then + write(io_stdo_bgc,*) 'Pore water in sediment initialized' + endif + + do k = 1, ks + do j = 1, kpje + do i = 1, kpie + porsol(i,j,k) = 1. - porwat(i,j,k) ! solid volume fraction at grid center + if(k >= 2) porwah(i,j,k) = 0.5 * (porwat(i,j,k) + porwat(i,j,k-1)) ! porosity at cell interfaces + if(k == 1) porwah(i,j,k) = 0.5 * (1. + porwat(i,j,1)) + enddo + enddo + enddo + + ! determine total solid sediment volume + solfu = 0. + do i = 1, kpie + do j = 1, kpje + do k = 1, ks + solfu(i,j) = solfu(i,j) + seddw(k) * porsol(i,j,k) + enddo + enddo + enddo + + ! Initialize porosity-dependent diffusion coefficients of sediment + zcoefsu(:,:,0) = 0.0 + do k = 1,ks + do j = 1, kpje + do i = 1, kpie + ! sediment diffusion coefficient * 1/dz * fraction of pore water at half depths + zcoefsu(i,j,k ) = -sedict * seddzi(k) * porwah(i,j,k) + zcoeflo(i,j,k-1) = -sedict * seddzi(k) * porwah(i,j,k) ! why the same ? + enddo + enddo + enddo + zcoeflo(:,:,ks) = 0.0 ! diffusion coefficient for bottom sediment layer + if (mnproc == 1) then + write(io_stdo_bgc,*) 'Pore water diffusion coefficients in sediment initialized' + endif + + END SUBROUTINE ini_sedmnt_por + + + !======================================================================== + SUBROUTINE ALLOC_MEM_SEDMNT(kpie,kpje) + !****************************************************************************** + ! ALLOC_MEM_SEDMNT - Allocate variables in this module + !****************************************************************************** INTEGER, intent(in) :: kpie,kpje INTEGER :: errstat @@ -290,6 +474,6 @@ SUBROUTINE ALLOC_MEM_SEDMNT(kpie,kpje) !****************************************************************************** - END SUBROUTINE ALLOC_MEM_SEDMNT + END SUBROUTINE ALLOC_MEM_SEDMNT - END MODULE mo_sedmnt + END MODULE mo_sedmnt From ddd05e05eaf621d0a863357547193a69d028bfa7 Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Tue, 27 Sep 2022 16:38:15 +0200 Subject: [PATCH 186/366] Outcommented minlim checks to test, if they are needed --- hamocc/mo_extNbioproc.F90 | 28 ++++++++++++++-------------- 1 file changed, 14 insertions(+), 14 deletions(-) diff --git a/hamocc/mo_extNbioproc.F90 b/hamocc/mo_extNbioproc.F90 index 04034795..6fed94b9 100644 --- a/hamocc/mo_extNbioproc.F90 +++ b/hamocc/mo_extNbioproc.F90 @@ -243,7 +243,7 @@ subroutine nitrification(kpie,kpje,kpke,kbnd,pddpo,omask,ptho) potdno2nitr = 0. fdetnitr = 0. - if(ocetra(i,j,k,ioxygen)>minlim_oxnh4 .and. ocetra(i,j,k,ianh4)>minlim_nh4)then +! if(ocetra(i,j,k,ioxygen)>minlim_oxnh4 .and. ocetra(i,j,k,ianh4)>minlim_nh4)then temp = merge(ptho(i,j,k),10.,ptho(i,j,k)<40.) ! Ammonium oxidation step of nitrification Tdepanh4 = q10anh4nitr**((temp-Trefanh4nitr)/10.) @@ -269,9 +269,9 @@ subroutine nitrification(kpie,kpje,kpke,kbnd,pddpo,omask,ptho) fn2o = fn2o/ftotnh4 fno2 = fno2/ftotnh4 fdetamox = 1. - (fn2o + fno2) - endif +! endif - if(ocetra(i,j,k,ioxygen)>minlim_oxno2 .and. ocetra(i,j,k,iano2)>minlim_no2)then +! if(ocetra(i,j,k,ioxygen)>minlim_oxno2 .and. ocetra(i,j,k,iano2)>minlim_no2)then temp = merge(ptho(i,j,k),10.,ptho(i,j,k)<40.) ! NO2 oxidizing step of nitrification Tdepano2 = q10ano2nitr**((temp-Trefano2nitr)/10.) @@ -294,7 +294,7 @@ subroutine nitrification(kpie,kpje,kpke,kbnd,pddpo,omask,ptho) & /(ocetra(i,j,k,ioxygen)**2 + 2.*ocetra(i,j,k,ioxygen)*bkyamox + bkyamox**2) fdetnitr = no2fdetamox/(no2fno2 + no2fn2o) ! yield to energy usage ratio for NO2 -> ratio equals 16:x - endif +! endif ! limitation of the two processes through available nutrients, etc. totd = potdnh4amox + potdno2nitr @@ -367,7 +367,7 @@ subroutine denit_NO3_to_NO2(kpie,kpje,kpke,kbnd,pddpo,omask,ptho) do i = 1,kpie do k = 1,kpke if(pddpo(i,j,k) > dp_min .and. omask(i,j) > 0.5) then - if(ocetra(i,j,k,ioxygen) < minlim_ox .and. ocetra(i,j,k,iano3)>minlim_no3)then +! if(ocetra(i,j,k,ioxygen) < minlim_ox .and. ocetra(i,j,k,iano3)>minlim_no3)then temp = merge(ptho(i,j,k),10.,ptho(i,j,k)<40.) Tdep = q10ano3denit**((temp-Trefano3denit)/10.) O2inhib = 1. - tanh(sc_ano3denit*ocetra(i,j,k,ioxygen)) @@ -388,7 +388,7 @@ subroutine denit_NO3_to_NO2(kpie,kpje,kpke,kbnd,pddpo,omask,ptho) ! Output denit_NO3(i,j,k) = ano3denit ! kmol NO3/m3/dtb - NO3 usage for denit on NO3 - endif +! endif endif enddo enddo @@ -425,7 +425,7 @@ subroutine anammox(kpie,kpje,kpke,kbnd,pddpo,omask,ptho) do i = 1,kpie do k = 1,kpke if(pddpo(i,j,k) > dp_min .and. omask(i,j) > 0.5) then - if(ocetra(i,j,k,iano2)>minlim_no2 .and. ocetra(i,j,k,ianh4)>minlim_nh4 .and. ocetra(i,j,k,ioxygen)minlim_no2 .and. ocetra(i,j,k,ianh4)>minlim_nh4 .and. ocetra(i,j,k,ioxygen)minlim_n2o)then +! if(0.<=ocetra(i,j,k,ioxygen) .and. ocetra(i,j,k,ioxygen)minlim_n2o)then temp = merge(ptho(i,j,k),10.,ptho(i,j,k)<40.) ! === denitrification on N2O Tdepan2o = q10an2odenit**((temp-Trefan2odenit)/10.) @@ -515,9 +515,9 @@ subroutine denit_dnra(kpie,kpje,kpke,kbnd,pddpo,omask,ptho) nutliman2o = ocetra(i,j,k,ian2o)/(ocetra(i,j,k,ian2o) + bkan2odenit) an2onew = ocetra(i,j,k,ian2o)/(1. + ran2odenit*Tdepan2o*O2inhiban2o*nutliman2o) an2odenit = max(0.,min(ocetra(i,j,k,ian2o),ocetra(i,j,k,ian2o) - an2onew)) - endif +! endif - if(0.<=ocetra(i,j,k,ioxygen) .and. ocetra(i,j,k,ioxygen)minlim_no2)then +! if(0.<=ocetra(i,j,k,ioxygen) .and. ocetra(i,j,k,ioxygen)minlim_no2)then temp = merge(ptho(i,j,k),10.,ptho(i,j,k)<40.) ! denitrification on NO2 Tdepano2 = q10ano2denit**((temp-Trefano2denit)/10.) @@ -543,7 +543,7 @@ subroutine denit_dnra(kpie,kpje,kpke,kbnd,pddpo,omask,ptho) ! potential fractional change ano2denit = fdenit * potdano2 ano2dnra = fdnra * potdano2 - endif +! endif ! limitation of processes due to detritus potddet = rnoxpi*(ano2denit + an2odenit) + rno2dnrai*ano2dnra ! P units @@ -552,7 +552,7 @@ subroutine denit_dnra(kpie,kpje,kpke,kbnd,pddpo,omask,ptho) fdetdnra = 1. - fdetano2denit - fdetan2odenit potddet = max(0.,min(potddet,ocetra(i,j,k,idet))) - if(potddet>0.)then +! if(potddet>0.)then ! change of NO2 and N2O in N units ano2denit = fdetano2denit*rnoxp*potddet an2odenit = fdetan2odenit*rnoxp*potddet @@ -573,7 +573,7 @@ subroutine denit_dnra(kpie,kpje,kpke,kbnd,pddpo,omask,ptho) denit_NO2(i,j,k) = ano2denit ! kmol NO2/m3/dtb - denitrification on NO2 denit_N2O(i,j,k) = an2odenit ! kmol N2O/m3/dtb - denitrification on N2O DNRA_NO2(i,j,k) = ano2dnra ! kmol NO2/m3/dtb - DNRA on NO2 - endif +! endif endif enddo enddo From cfbe359657524c95582cd2ea584321c0831d2e73 Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Tue, 27 Sep 2022 17:03:07 +0200 Subject: [PATCH 187/366] Introduce a section for tweaking parameters --- hamocc/mo_extNbioproc.F90 | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/hamocc/mo_extNbioproc.F90 b/hamocc/mo_extNbioproc.F90 index 6fed94b9..c238bf53 100644 --- a/hamocc/mo_extNbioproc.F90 +++ b/hamocc/mo_extNbioproc.F90 @@ -196,6 +196,14 @@ subroutine extNbioparam_init() eps = 1.e-25 ! safe division etc. minlim = 1.e-9 ! minimum for limitation functions (e.g. nutlim or oxlim/inh can only decrease to minlim) !=========================================================================== + + ! Tweaked parameters: + rano3denit = 0.0005*dtb ! Maximum growth rate denitrification on NO3 at reference T (1/d -> 1/dt) + rano2anmx = 0.001*dtb ! Maximum growth rate for anammox at reference T (1/d -> 1/dt) + rano2denit = 0.001*dtb ! Maximum growth rate denitrification on NO2 at reference T (1/d -> 1/dt) + ran2odenit = 0.0012*dtb ! Maximum growth rate denitrification on N2O at reference T (1/d -> 1/dt) + rdnra = 0.001*dtb ! Maximum growth rate DNRA on NO2 at reference T (1/d -> 1/dt) + end subroutine extNbioparam_init !================================================================================================================================== From 5a65d8c75463ffa5f5f037feb37bbf84937b5cb9 Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Tue, 27 Sep 2022 17:32:41 +0200 Subject: [PATCH 188/366] fix buildnml wrt sediment - water column pore water fluxes --- cime_config/buildnml | 3 +++ 1 file changed, 3 insertions(+) diff --git a/cime_config/buildnml b/cime_config/buildnml index 284ddc55..255beebb 100755 --- a/cime_config/buildnml +++ b/cime_config/buildnml @@ -644,6 +644,9 @@ set FLX_SEDIFFOX = '0, 0, 2' set FLX_SEDIFFN2 = '0, 0, 2' set FLX_SEDIFFNO3 = '0, 0, 2' set FLX_SEDIFFSI = '0, 0, 2' +set FLX_SEDIFFNH4 = '0, 0, 2' +set FLX_SEDIFFN2O = '0, 0, 2' +set FLX_SEDIFFNO2 = '0, 0, 2' set SDM_POWAIC = '0, 0, 2' set SDM_POWAAL = '0, 0, 2' set SDM_POWAPH = '0, 0, 2' From 9640065fb3c70342d2b784ccea5518e84121c262 Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Wed, 28 Sep 2022 14:01:00 +0200 Subject: [PATCH 189/366] FIX reading the variable porosity file --- hamocc/mo_read_sedpor.F90 | 34 +++++++++++++++++++++++++++++----- 1 file changed, 29 insertions(+), 5 deletions(-) diff --git a/hamocc/mo_read_sedpor.F90 b/hamocc/mo_read_sedpor.F90 index 6ea984c6..c7a6c269 100644 --- a/hamocc/mo_read_sedpor.F90 +++ b/hamocc/mo_read_sedpor.F90 @@ -53,7 +53,9 @@ subroutine read_sedpor(kpie,kpje,ks,omask,sed_por) use mod_xc, only: mnproc,xchalt use mod_dia, only: iotype use mo_control_bgc, only: io_stdo_bgc,l_3Dvarsedpor - use mod_nctools, only: ncfopn,ncread,ncfcls + use netcdf, only: nf90_noerr,nf90_nowrite,nf90_close,nf90_open + + implicit none @@ -62,9 +64,10 @@ subroutine read_sedpor(kpie,kpje,ks,omask,sed_por) real, intent(inout) :: sed_por(kpie,kpje,ks) !local variables - integer :: i,j,k,errstat,dummymask(2) + integer :: i,j,k,errstat real :: sed_por_in(kpie,kpje,ks) logical :: file_exists = .false. + integer :: ncid,ncstat,ncvarid ! Return if l_3Dvarsedpor is turned off if (.not. l_3Dvarsedpor) then @@ -90,15 +93,36 @@ subroutine read_sedpor(kpie,kpje,ks,omask,sed_por) write(io_stdo_bgc,*) 'read_sedpor: read sediment porosity from ', & trim(sedporfile) endif - call ncfopn(trim(sedporfile),'r',' ',1,iotype) - call ncread('sedpor',sed_por_in,dummymask,0,0.) - call ncfcls + + ! Open netCDF data file + IF(mnproc==1) THEN + ncstat = NF90_OPEN(trim(sedporfile),NF90_NOWRITE, ncid) + IF (ncstat.NE.NF90_NOERR ) THEN + CALL xchalt('(read_sedpor: Problem with netCDF1)') + stop '(read_sedpor: Problem with netCDF1)' + END IF + END IF + + ! Read data + call read_netcdf_var(ncid,'sedpor',sed_por_in(1,1,1),12,0,0) + + ! Close file + IF(mnproc==1) THEN + ncstat = NF90_CLOSE(ncid) + IF ( ncstat .NE. NF90_NOERR ) THEN + CALL xchalt('(read_sedpor: Problem with netCDF200)') + stop '(read_sedpor: Problem with netCDF200)' + END IF + END IF + do k=1,ks do j=1,kpje do i=1,kpie if(omask(i,j).gt. 0.5)then sed_por(i,j,k)=sed_por_in(i,j,k) + else + sed_por(i,j,k)=0. endif enddo enddo From 18d560b08b77ca3526d6d8fbb8ed86490c5f02a9 Mon Sep 17 00:00:00 2001 From: Mehmet Ilicak Date: Mon, 3 Oct 2022 08:43:05 +0200 Subject: [PATCH 190/366] This is the first commit of MKS units. All variables in the subroutines have been converted to MKS [meter, kg, seconds] instead of CGS [cm, gram, seconds] with necessary coefficients. The default option which is CGS reproduce old results. The new option MKS cannot reproduce because of machine precision. --- ben02/mod_ben02.F | 19 ++- ben02/sfcstr_ben02.F | 5 +- ben02/thermf_ben02.F | 56 ++++--- cesm/sfcstr_cesm.F | 5 +- cesm/thermf_cesm.F | 49 +++--- channel/thermf_channel.F | 8 +- drivers/cpl_mct/domain_mct.F | 3 +- fuk95/mod_fuk95.F90 | 4 +- meson.build | 8 + meson_options.txt | 3 + phy/convec.F | 6 +- phy/diapfl.F | 30 +++- phy/diffus.F | 12 +- phy/geoenv_file.F | 26 +-- phy/mod_advect.F | 1 + phy/mod_cmnfld.F90 | 6 +- phy/mod_cmnfld_routines.F90 | 30 ++-- phy/mod_constants.F90 | 50 +++++- phy/mod_dia.F | 251 +++++++++++++++------------- phy/mod_difest.F | 142 +++++++++------- phy/mod_diffusion.F90 | 8 +- phy/mod_eddtra.F90 | 101 +++++------ phy/mod_eos.F90 | 66 ++++++-- phy/mod_inicon.F | 26 +-- phy/mod_momtum.F | 19 ++- phy/mod_mxlayr.F | 49 +++--- phy/mod_ndiff.F90 | 11 +- phy/mod_pbcor.F | 14 +- phy/mod_pgforc.F | 6 +- phy/mod_remap.F | 13 +- phy/mod_swabs.F | 2 +- phy/mod_tidaldissip.F90 | 6 +- phy/mod_time.F90 | 4 +- phy/mod_tke.F90 | 20 ++- phy/mod_tmsmt.F | 16 +- phy/mod_vcoord.F90 | 8 +- phy/mod_vdiff.F90 | 4 +- phy/numerical_bounds.F90 | 4 +- phy/rdlim.F | 3 +- single_column/mod_single_column.F90 | 15 +- 40 files changed, 667 insertions(+), 442 deletions(-) diff --git a/ben02/mod_ben02.F b/ben02/mod_ben02.F index d6fd01a5..39a8ef6a 100644 --- a/ben02/mod_ben02.F +++ b/ben02/mod_ben02.F @@ -26,7 +26,7 @@ module mod_ben02 c use mod_types, only: i2, r4 use mod_config, only: expcnf - use mod_constants, only: t0deg, spval + use mod_constants, only: t0deg, spval, L_mks2cgs use mod_calendar, only: date_offset, calendar_noerr, . calendar_errstr use mod_time, only: date, calendar, nday_in_year, nday_of_year, @@ -183,10 +183,18 @@ module mod_ben02 . atm_cswa_era ! short-wave radiation adjustment factor ! (NCEP) c +#if defined(CGS) data atm_ice_csmt_ncep,atm_rnf_csmt_ncep /2.e14,1.e13/, . atm_crnf_ncep,atm_cswa_ncep /0.82073,0.88340/, . atm_ice_csmt_era,atm_rnf_csmt_era /0.0,1.e13/, . atm_crnf_era,atm_cswa_era /0.7234,0.9721/ +#endif +#if defined(MKS) + data atm_ice_csmt_ncep,atm_rnf_csmt_ncep /2.e10,1.e9/, + . atm_crnf_ncep,atm_cswa_ncep /0.82073,0.88340/, + . atm_ice_csmt_era,atm_rnf_csmt_era /0.0,1.e13/, + . atm_crnf_era,atm_cswa_era /0.7234,0.9721/ +#endif c real :: . zu, ! measurement height of wind [m] @@ -2095,6 +2103,9 @@ subroutine inifrc_ben02clim integer i,j,k,l,il,jl integer*2 rn2,ri2,rj2 c + real iL_mks2cgssq + iL_mks2cgssq = 1.0 / (L_mks2cgs*L_mks2cgs) +c c --- 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), @@ -2775,7 +2786,7 @@ subroutine inifrc_ben02clim do k=1,12 do l=1,isp(j) do i=max(1,ifp(j,l)),min(ii,ilp(j,l)) - garea=scp2(i,j)*1.e-4 ! [m^2] + garea=scp2(i,j)*iL_mks2cgssq ! [m^2] c c --- ----- freshwater fluxes [m/s] util1(i,j)=util1(i,j)+precip(i,j,k)*fwf_fac*garea @@ -2819,7 +2830,7 @@ subroutine inifrc_ben02clim do j=1,jj do l=1,isp(j) do i=max(1,ifp(j,l)),min(ii,ilp(j,l)) - garea=scp2(i,j)*1.e-4 ! [m^2] + garea=scp2(i,j)*iL_mks2cgssq ! [m^2] c c --- ----- heat fluxes albedo=albs_f*ricclm(i,j,k)+albw(i,j)*(1.-ricclm(i,j,k)) @@ -2838,7 +2849,7 @@ subroutine inifrc_ben02clim call xcsum(lht_sum,util3,ip) call xcsum(sht_sum,util4,ip) c - fac=1.e4/(12.*area) + fac=(L_mks2cgs*L_mks2cgs)/(12.*area) swa_ave=swa_sum*fac lwa_ave=lwa_sum*fac lht_ave=lht_sum*fac diff --git a/ben02/sfcstr_ben02.F b/ben02/sfcstr_ben02.F index efd9e014..e81c005d 100644 --- a/ben02/sfcstr_ben02.F +++ b/ben02/sfcstr_ben02.F @@ -24,6 +24,7 @@ subroutine sfcstr_ben02(m,n,mm,nn,k1m,k1n) c --- ------------------------------------------------------------------ c use mod_xc + use mod_constants, only: P_mks2cgs use mod_forcing, only: ztx, mty, taux, tauy use mod_seaice, only: ficem, hicem, tauxice, tauyice use mod_checksum, only: csdiag, chksummsk @@ -44,14 +45,14 @@ subroutine sfcstr_ben02(m,n,mm,nn,k1m,k1n) do i=max(1,ifu(j,l)),min(ii,ilu(j,l)) facice=(ficem(i,j)+ficem(i-1,j)) . *min(2.,hicem(i,j)+hicem(i-1,j))*.25 - taux(i,j)=10.*(ztx(i,j)*(1.-facice)+tauxice(i,j)*facice) + taux(i,j)=P_mks2cgs*(ztx(i,j)*(1.-facice)+tauxice(i,j)*facice) enddo enddo do l=1,isv(j) do i=max(1,ifv(j,l)),min(ii,ilv(j,l)) facice=(ficem(i,j)+ficem(i,j-1)) . *min(2.,hicem(i,j)+hicem(i,j-1))*.25 - tauy(i,j)=10.*(mty(i,j)*(1.-facice)+tauyice(i,j)*facice) + tauy(i,j)=P_mks2cgs*(mty(i,j)*(1.-facice)+tauyice(i,j)*facice) enddo enddo enddo diff --git a/ben02/thermf_ben02.F b/ben02/thermf_ben02.F index 003e9c61..11fc1f66 100644 --- a/ben02/thermf_ben02.F +++ b/ben02/thermf_ben02.F @@ -21,7 +21,8 @@ subroutine thermf_ben02(m,n,mm,nn,k1m,k1n) c c --- NERSC version of thermf. c - use mod_constants, only: spcifh, t0deg, epsil, onem + use mod_constants, only: spcifh, t0deg, epsilt, onem + use mod_constants, only: L_mks2cgs, M_mks2cgs, g2kg, alpha0 use mod_time, only: nday_in_year, nday_of_year, nstep, . nstep_in_day, baclin, . xmi, l1mi, l2mi, l3mi, l4mi, l5mi @@ -66,7 +67,7 @@ subroutine thermf_ben02(m,n,mm,nn,k1m,k1n) real, dimension(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy) :: vrtsfl c integer i,j,k,l,m1,m2,m3,m4,m5 - real dt,cpsw,rnf_fac,sag_fac,y, + real*8 dt,cpsw,rnf_fac,sag_fac,y, . dpotl,hotl,totl,sotl,dpmxl,hmxl,tmxl,smxl,tice_f,hice_min, . fice,hice,hsnw,tsrf,fice0,hice0,hsnw0,qsww,qnsw,tice,albi, . tsmlt,albi_h,qswi,dh,qsnwf,fcond,qdamp,qsmlt,qo2i,qbot,swfac, @@ -82,10 +83,13 @@ subroutine thermf_ben02(m,n,mm,nn,k1m,k1n) c real intp1d external intp1d + real iL_mks2cgssq +c + iL_mks2cgssq = 1.0 / (L_mks2cgs**2) c c --- Due to conservation, the ratio of ice and snow density must be c --- equal to the ratio of ice and snow heat of fusion - if (abs(fuss/fusi-rhosnw/rhoice).gt.epsil) then + if (abs(fuss/fusi-rhosnw/rhoice).gt.epsilt) then if (mnproc.eq.1) then write (lp,*) . 'thermf: check consistency between snow/ice densities' @@ -97,7 +101,7 @@ subroutine thermf_ben02(m,n,mm,nn,k1m,k1n) c c --- Set various constants dt=baclin ! Time step - cpsw=spcifh*1.e3 ! Specific heat of seawater + cpsw=spcifh*M_mks2cgs ! Specific heat of seawater rnf_fac=baclin/real(nrfets*86400) ! Runoff reservoar detrainment rate sag_fac=exp(-sagets*dt) ! Snow aging rate c @@ -326,7 +330,7 @@ subroutine thermf_ben02(m,n,mm,nn,k1m,k1n) c --- ----- Ice volume that has to freeze to balance the heat budget volice=-(qsww+qnsw-q)*(1.-fice)*dt/fusi c - if (volice.gt.epsil) then + if (volice.gt.epsilt) then c c --- ------- New ice in the lead is formed with a specified thickness. c --- ------- Estimate the change in ice fraction @@ -344,7 +348,7 @@ subroutine thermf_ben02(m,n,mm,nn,k1m,k1n) c --- ----- If the lead is warming, let the fraction (1 - fice) go to c --- ----- warm the lead, and the fraction fice to melt ice laterally fice=fice-(swfac*qsww+qnsw)*fice*dt - . /max(hice*fusi+hsnw*fuss,epsil) + . /max(hice*fusi+hsnw*fuss,epsilt) if (fice.lt.0.) then fice=0. hice=0. @@ -398,14 +402,14 @@ subroutine thermf_ben02(m,n,mm,nn,k1m,k1n) fwflx=eva(i,j)+lip(i,j)+sop(i,j)+rnf(i,j)+rfi(i,j)+fmltfz(i,j) c c --- --- Salt flux [kg m-2 s-1] (positive downwards) - sfl(i,j)=-sice*dvi*rhoice/dt*1.e-3 + sfl(i,j)=-sice*dvi*rhoice/dt*g2kg c c --- --- Salt flux due to brine rejection of freezing sea c --- --- ice [kg m-2 m-1] (positive downwards) - brnflx(i,j)=max(0.,-sotl*fmltfz(i,j)*1.e-3+sfl(i,j)) + brnflx(i,j)=max(0.,-sotl*fmltfz(i,j)*g2kg+sfl(i,j)) c c --- --- Virtual salt flux [kg m-2 s-1] (positive downwards) - vrtsfl(i,j)=-sotl*fwflx*1.e-3 + vrtsfl(i,j)=-sotl*fwflx*g2kg c c --- --- Store area weighted virtual salt flux and fresh water flux util1(i,j)=vrtsfl(i,j)*scp2(i,j) @@ -415,11 +419,11 @@ subroutine thermf_ben02(m,n,mm,nn,k1m,k1n) hmltfz(i,j)=(dvi*fusi+dvs*fuss)/dt c c --- --- Total heat flux in BLOM units [W cm-2] (positive upwards) - surflx(i,j)=-(swa(i,j)+nsf(i,j)+hmltfz(i,j))*1.e-4 + surflx(i,j)=-(swa(i,j)+nsf(i,j)+hmltfz(i,j))*iL_mks2cgssq c c --- --- Short-wave heat flux in BLOM units [W cm-2] (positive c --- --- upwards) - sswflx(i,j)=-qsww*(1.-fice0)*1.e-4 + sswflx(i,j)=-qsww*(1.-fice0)*iL_mks2cgssq c #ifdef TRC c --- ------------------------------------------------------------------ @@ -452,7 +456,7 @@ subroutine thermf_ben02(m,n,mm,nn,k1m,k1n) endif # endif # endif - trflx(nt,i,j)=-trc(i,j,k1n,nt)*fwflx*1.e-3 + trflx(nt,i,j)=-trc(i,j,k1n,nt)*fwflx*g2kg ttrsf(nt,i,j)=trflx(nt,i,j)*scp2(i,j) ttrav(nt,i,j)=trc(i,j,k1n,nt)*scp2(i,j) enddo @@ -465,7 +469,7 @@ subroutine thermf_ben02(m,n,mm,nn,k1m,k1n) surrlx(i,j)=0. c c --- --- If trxday>0 , apply relaxation towards observed sst - if (trxday.gt.epsil) then + if (trxday.gt.epsilt) then sstc=intp1d(sstclm(i,j,l1mi),sstclm(i,j,l2mi), . sstclm(i,j,l3mi),sstclm(i,j,l4mi), . sstclm(i,j,l5mi),xmi) @@ -473,8 +477,8 @@ 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 - trxflx=spcifh*100.*min(hmxl,trxdpt)/(trxday*86400.) - . *min(trxlim,max(-trxlim,sstc-tmxl)) + trxflx=spcifh*L_mks2cgs*min(hmxl,trxdpt)/(trxday*86400.) + . *min(trxlim,max(-trxlim,sstc-tmxl))/alpha0 surrlx(i,j)=-trxflx else trxflx=0. @@ -496,12 +500,12 @@ subroutine thermf_ben02(m,n,mm,nn,k1m,k1n) salrlx(i,j)=0. c c --- --- if srxday>0 , apply relaxation towards observed sss - if (srxday.gt.epsil) then + if (srxday.gt.epsilt) then sssc=intp1d(sssclm(i,j,l1mi),sssclm(i,j,l2mi), . sssclm(i,j,l3mi),sssclm(i,j,l4mi), . sssclm(i,j,l5mi),xmi) - srxflx=100.*min(hmxl,srxdpt)/(srxday*86400.) - . *min(srxlim,max(-srxlim,sssc-smxl)) + srxflx=L_mks2cgs*min(hmxl,srxdpt)/(srxday*86400.) + . *min(srxlim,max(-srxlim,sssc-smxl))/alpha0 salrlx(i,j)=-srxflx util3(i,j)=max(0.,salrlx(i,j))*scp2(i,j) util4(i,j)=min(0.,salrlx(i,j))*scp2(i,j) @@ -538,7 +542,7 @@ subroutine thermf_ben02(m,n,mm,nn,k1m,k1n) c --- ------------------------------------------------------------------- c ustar(i,j)=(min(ustari(i,j),.8e-2)*fice0 - . +ustarw(i,j)*(1.-fice0))*1.e2 + . +ustarw(i,j)*(1.-fice0))*L_mks2cgs c enddo enddo @@ -556,7 +560,7 @@ subroutine thermf_ben02(m,n,mm,nn,k1m,k1n) call xcsum(totwfl,util2,ips) c c --- Correction for the virtual salt flux [kg m-2 s-1] - sflxc=(-sref*totwfl*1.e-3-totsfl)/area + sflxc=(-sref*totwfl*g2kg-totsfl)/area if (mnproc.eq.1) then write (lp,*) 'thermf: totsfl/area,sflxc',totsfl/area,sflxc endif @@ -567,8 +571,10 @@ subroutine thermf_ben02(m,n,mm,nn,k1m,k1n) do j=1,jj do l=1,isp(j) do i=max(1,ifp(j,l)),min(ii,ilp(j,l)) - salflx(i,j)=-(vrtsfl(i,j)+sflxc+sfl(i,j))*1.e2 - brnflx(i,j)=-brnflx(i,j)*1.e2 + salflx(i,j)=-(vrtsfl(i,j)+sflxc+sfl(i,j)) + . *(1e3*(M_mks2cgs/L_mks2cgs**2)) + brnflx(i,j)=-brnflx(i,j) + . *(1e3*(M_mks2cgs/L_mks2cgs**2)) enddo enddo enddo @@ -577,7 +583,7 @@ subroutine thermf_ben02(m,n,mm,nn,k1m,k1n) c --- if srxday>0 and srxbal=.true. , balance the sss relaxation flux c --- so the net input of salt in grid cells connected to the world c --- ocean is zero - if (srxday.gt.epsil.and.srxbal) then + if (srxday.gt.epsilt.and.srxbal) then call xcsum(totsrp,util3,ipwocn) call xcsum(totsrn,util4,ipwocn) if (abs(totsrp).gt.abs(totsrn)) then @@ -632,14 +638,14 @@ subroutine thermf_ben02(m,n,mm,nn,k1m,k1n) c tottrav=tottrav/area cc c trflxc=(-tottrsf)/area -c trflxc=(-tottrav*totwfl*1.e-3-tottrsf)/area +c trflxc=(-tottrav*totwfl*g2kg-tottrsf)/area trflxc=0. c c$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)) - trflx(nt,i,j)=-(trflx(nt,i,j)+trflxc)*1.e2 + trflx(nt,i,j)=-(trflx(nt,i,j)+trflxc)*L_mks2cgs enddo enddo enddo diff --git a/cesm/sfcstr_cesm.F b/cesm/sfcstr_cesm.F index b352cbfd..55a8d205 100644 --- a/cesm/sfcstr_cesm.F +++ b/cesm/sfcstr_cesm.F @@ -24,6 +24,7 @@ subroutine sfcstr_cesm(m,n,mm,nn,k1m,k1n) c --- ------------------------------------------------------------------ c use mod_xc + use mod_constants, only: P_mks2cgs use mod_forcing, only: ztx, mty, taux, tauy use mod_checksum, only: csdiag, chksummsk c @@ -37,12 +38,12 @@ subroutine sfcstr_cesm(m,n,mm,nn,k1m,k1n) do j=1,jj do l=1,isu(j) do i=max(1,ifu(j,l)),min(ii,ilu(j,l)) - taux(i,j)=10.*ztx(i,j) + taux(i,j)=P_mks2cgs*ztx(i,j) enddo enddo do l=1,isv(j) do i=max(1,ifv(j,l)),min(ii,ilv(j,l)) - tauy(i,j)=10.*mty(i,j) + tauy(i,j)=P_mks2cgs*mty(i,j) enddo enddo enddo diff --git a/cesm/thermf_cesm.F b/cesm/thermf_cesm.F index 63b6a4e8..ce140d90 100644 --- a/cesm/thermf_cesm.F +++ b/cesm/thermf_cesm.F @@ -21,7 +21,8 @@ subroutine thermf_cesm(m,n,mm,nn,k1m,k1n) c c --- NERSC version of thermf. To be used when coupled to CESM c - use mod_constants, only: g, spcifh, t0deg, epsil, onem + use mod_constants, only: g, spcifh, t0deg, epsilt, onem + use mod_constants, only: L_mks2cgs, M_mks2cgs, g2kg, alpha0 use mod_time, only: nstep, nstep_in_day, nday_in_year, . nday_of_year, baclin, . xmi, l1mi, l2mi, l3mi, l4mi, l5mi @@ -69,9 +70,12 @@ subroutine thermf_cesm(m,n,mm,nn,k1m,k1n) real tottrsf,tottrav,trflxc #endif c + real iL_mks2cgssq real intp1d external intp1d c + iL_mks2cgssq = 1.0 / (L_mks2cgs*L_mks2cgs) +c c --- Set parameters for time interpolation when applying diagnosed heat c --- and salt relaxation fluxes y=(nday_of_year-1+mod(nstep,nstep_in_day)/real(nstep_in_day))*48. @@ -132,10 +136,10 @@ subroutine thermf_cesm(m,n,mm,nn,k1m,k1n) c c --- --- Salt flux due to brine rejection of freezing sea c --- --- ice [kg m-2 m-1] (positive downwards) - brnflx(i,j)=max(0.,-sotl*fmltfz(i,j)*1.e-3+sfl(i,j)) + brnflx(i,j)=max(0.,-sotl*fmltfz(i,j)*g2kg+sfl(i,j)) c c --- --- Virtual salt flux [kg m-2 s-1] (positive downwards) - vrtsfl(i,j)=-sotl*fwflx*1.e-3 + vrtsfl(i,j)=-sotl*fwflx*g2kg c c --- --- Store area weighted virtual salt flux and fresh water flux util1(i,j)=vrtsfl(i,j)*scp2(i,j) @@ -150,20 +154,21 @@ subroutine thermf_cesm(m,n,mm,nn,k1m,k1n) c --- --- be heated. Note the freezing potential is multiplied by 1/2 c --- --- due to the leap-frog time stepping. The melting potential uses c --- --- time averaged quantities since it is not accumulated. - frzpot(i,j)=max(0.,tice_f-totl)*spcifh*dpotl/(2.*g)*1.e4 + frzpot(i,j)=max(0.,tice_f-totl)*spcifh*dpotl + . /(2.*g)*L_mks2cgs*L_mks2cgs mltpot(i,j)= . min(0.,tfrzm(i,j)-.5*(temp(i,j,k1m)+temp(i,j,k1n))) - . *spcifh*.5*(dp(i,j,k1m)+dp(i,j,k1n))/g*1.e4 + . *spcifh*.5*(dp(i,j,k1m)+dp(i,j,k1n))/g*L_mks2cgs*L_mks2cgs c c --- --- Heat flux due to melting/freezing [W m-2] (positive downwards) hmltfz(i,j)=hmlt(i,j)+frzpot(i,j)/baclin c c --- --- Total heat flux in BLOM units [W cm-2] (positive upwards) - surflx(i,j)=-(swa(i,j)+nsf(i,j)+hmltfz(i,j))*1.e-4 + surflx(i,j)=-(swa(i,j)+nsf(i,j)+hmltfz(i,j))*iL_mks2cgssq c c --- --- Short-wave heat flux in BLOM units [W cm-2] (positive c --- --- upwards) - sswflx(i,j)=-swa(i,j)*1.e-4 + sswflx(i,j)=-swa(i,j)*iL_mks2cgssq c #ifdef TRC c --- ------------------------------------------------------------------ @@ -196,7 +201,7 @@ subroutine thermf_cesm(m,n,mm,nn,k1m,k1n) endif # endif # endif - trflx(nt,i,j)=-trc(i,j,k1n,nt)*fwflx*1.e-3 + trflx(nt,i,j)=-trc(i,j,k1n,nt)*fwflx*g2kg ttrsf(nt,i,j)=trflx(nt,i,j)*scp2(i,j) ttrav(nt,i,j)=trc(i,j,k1n,nt)*scp2(i,j) enddo @@ -208,7 +213,7 @@ subroutine thermf_cesm(m,n,mm,nn,k1m,k1n) surrlx(i,j)=0. c c --- --- If trxday>0 , apply relaxation towards observed sst - if (trxday.gt.epsil) then + if (trxday.gt.epsilt) then sstc=intp1d(sstclm(i,j,l1mi),sstclm(i,j,l2mi), . sstclm(i,j,l3mi),sstclm(i,j,l4mi), . sstclm(i,j,l5mi),xmi) @@ -216,8 +221,8 @@ 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 - trxflx=spcifh*100.*min(hmxl,trxdpt)/(trxday*86400.) - . *min(trxlim,max(-trxlim,sstc-tmxl)) + trxflx=spcifh*L_mks2cgs*min(hmxl,trxdpt)/(trxday*86400.) + . *min(trxlim,max(-trxlim,sstc-tmxl))/alpha0 surrlx(i,j)=-trxflx else trxflx=0. @@ -239,12 +244,12 @@ subroutine thermf_cesm(m,n,mm,nn,k1m,k1n) salrlx(i,j)=0. c c --- --- if srxday>0 , apply relaxation towards observed sss - if (srxday.gt.epsil) then + if (srxday.gt.epsilt) then sssc=intp1d(sssclm(i,j,l1mi),sssclm(i,j,l2mi), . sssclm(i,j,l3mi),sssclm(i,j,l4mi), . sssclm(i,j,l5mi),xmi) - srxflx=100.*min(hmxl,srxdpt)/(srxday*86400.) - . *min(srxlim,max(-srxlim,sssc-smxl)) + srxflx=L_mks2cgs*min(hmxl,srxdpt)/(srxday*86400.) + . *min(srxlim,max(-srxlim,sssc-smxl))/alpha0 salrlx(i,j)=-srxflx util3(i,j)=max(0.,salrlx(i,j))*scp2(i,j) util4(i,j)=min(0.,salrlx(i,j))*scp2(i,j) @@ -269,7 +274,7 @@ subroutine thermf_cesm(m,n,mm,nn,k1m,k1n) c --- --- Friction velocity (cm/s) c --- ------------------------------------------------------------------- c - ustar(i,j)=ustarw(i,j)*1.e2 + ustar(i,j)=ustarw(i,j)*L_mks2cgs c enddo enddo @@ -287,7 +292,7 @@ subroutine thermf_cesm(m,n,mm,nn,k1m,k1n) call xcsum(totwfl,util2,ips) c c --- Correction for the virtual salt flux [kg m-2 s-1] - sflxc=(-sref*totwfl*1.e-3-totsfl)/area + sflxc=(-sref*totwfl*g2kg-totsfl)/area if (mnproc.eq.1) then write (lp,*) 'thermf: totsfl/area,sflxc',totsfl/area,sflxc endif @@ -298,8 +303,10 @@ subroutine thermf_cesm(m,n,mm,nn,k1m,k1n) do j=1,jj do l=1,isp(j) do i=max(1,ifp(j,l)),min(ii,ilp(j,l)) - salflx(i,j)=-(vrtsfl(i,j)+sflxc+sfl(i,j))*1.e2 - brnflx(i,j)=-brnflx(i,j)*1.e2 + salflx(i,j)=-(vrtsfl(i,j)+sflxc+sfl(i,j)) + . *(1e3*(M_mks2cgs/L_mks2cgs**2)) + brnflx(i,j)=-brnflx(i,j) + . *(1e3*(M_mks2cgs/L_mks2cgs**2)) enddo enddo enddo @@ -308,7 +315,7 @@ subroutine thermf_cesm(m,n,mm,nn,k1m,k1n) c --- if srxday>0 and srxbal=.true. , balance the sss relaxation flux c --- so the net input of salt in grid cells connected to the world c --- ocean is zero - if (srxday.gt.epsil.and.srxbal) then + if (srxday.gt.epsilt.and.srxbal) then call xcsum(totsrp,util3,ipwocn) call xcsum(totsrn,util4,ipwocn) if (abs(totsrp-totsrn).gt.0.) then @@ -352,14 +359,14 @@ subroutine thermf_cesm(m,n,mm,nn,k1m,k1n) tottrav=tottrav/area c trflxc=(-tottrsf)/area -c trflxc=(-tottrav*totwfl*1.e-3-tottrsf)/area +c trflxc=(-tottrav*totwfl*g2kg-tottrsf)/area c trflxc=0. c c$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)) - trflx(nt,i,j)=-(trflx(nt,i,j)+trflxc)*1.e2 + trflx(nt,i,j)=-(trflx(nt,i,j)+trflxc)*L_mks2cgs enddo enddo enddo diff --git a/channel/thermf_channel.F b/channel/thermf_channel.F index bc0ee447..41a565f9 100644 --- a/channel/thermf_channel.F +++ b/channel/thermf_channel.F @@ -24,7 +24,7 @@ subroutine thermf_channel(m,n,mm,nn,k1m,k1n) use mod_xc use mod_types, only: r8 use mod_ben02, only: ntda - use mod_constants, only: spcifh, t0deg, epsil, onem + use mod_constants, only: spcifh, t0deg, epsilt, onem use mod_time, only: nday_in_year, nday_of_year, nstep, . nstep_in_day, baclin, . xmi, l1mi, l2mi, l3mi, l4mi, l5mi @@ -217,7 +217,7 @@ subroutine thermf_channel(m,n,mm,nn,k1m,k1n) surrlx(i,j)=0._r8 ! ! --- --- If trxday>0 , apply relaxation towards observed sst - if (trxday.gt.epsil) then + if (trxday.gt.epsilt) then sstc=intp1d(sstclm(i,j,l1mi),sstclm(i,j,l2mi), . sstclm(i,j,l3mi),sstclm(i,j,l4mi), . sstclm(i,j,l5mi),xmi) @@ -248,7 +248,7 @@ subroutine thermf_channel(m,n,mm,nn,k1m,k1n) salrlx(i,j)=0._r8 ! ! --- --- if srxday>0 , apply relaxation towards observed sss - if (srxday.gt.epsil) then + if (srxday.gt.epsilt) then sssc=intp1d(sssclm(i,j,l1mi),sssclm(i,j,l2mi), . sssclm(i,j,l3mi),sssclm(i,j,l4mi), . sssclm(i,j,l5mi),xmi) @@ -319,7 +319,7 @@ subroutine thermf_channel(m,n,mm,nn,k1m,k1n) ! --- if srxday>0 and srxbal=.true. , balance the sss relaxation flux ! --- so the net input of salt in grid cells connected to the world ! --- ocean is zero - if (srxday.gt.epsil.and.srxbal) then + if (srxday.gt.epsilt.and.srxbal) then call xcsum(totsrp,util3,ipwocn) call xcsum(totsrn,util4,ipwocn) if (abs(totsrp).gt.abs(totsrn)) then diff --git a/drivers/cpl_mct/domain_mct.F b/drivers/cpl_mct/domain_mct.F index 34e07813..4c088b69 100644 --- a/drivers/cpl_mct/domain_mct.F +++ b/drivers/cpl_mct/domain_mct.F @@ -27,6 +27,7 @@ subroutine domain_mct(gsMap_ocn, dom_ocn, lsize, perm, jjcpl) use mod_types, only: r8 use mod_xc use mod_grid, only: scp2, plon, plat + use mod_constants, only: L_mks2cgs implicit none @@ -105,7 +106,7 @@ subroutine domain_mct(gsMap_ocn, dom_ocn, lsize, perm, jjcpl) enddo call mct_gGrid_importRattr(dom_ocn, "lat", rdata, lsize) - radius = SHR_CONST_REARTH*1.e2_r8 ! Earth's radius in cm + radius = SHR_CONST_REARTH*L_mks2cgs ! Earth's radius in cm n = 0 do j = 1, jjcpl diff --git a/fuk95/mod_fuk95.F90 b/fuk95/mod_fuk95.F90 index 6dd0a7bc..cd35535e 100644 --- a/fuk95/mod_fuk95.F90 +++ b/fuk95/mod_fuk95.F90 @@ -25,7 +25,7 @@ module mod_fuk95 ! ------------------------------------------------------------------------------ use mod_types, only: r8 - use mod_constants, only: g, rearth, pi, radian, epsil + use mod_constants, only: g, rearth, pi, radian, epsilt use mod_xc use mod_vcoord, only: vcoord_type_tag, isopyc_bulkml, cntiso_hybrid, sigmar use mod_grid, only: qclon, qclat, pclon, pclat, uclon, uclat, vclon, vclat, & @@ -426,7 +426,7 @@ subroutine ictsz_fuk95 zl = .5_r8*(z(i, j - 1, k + 1) + z(i, j, k + 1)) v1 = u0*psi(x)*(h1 - .5*(zu + zl))/h1 v1 = 0._r8 - if (abs(zl - zu) < epsil) then + if (abs(zl - zu) < epsilt) then v(i, j, k) = v1 else v(i, j, k) = ( v1*max(0._r8, min(zl, h1) - zu) & diff --git a/meson.build b/meson.build index baf58d7d..2581a3a7 100644 --- a/meson.build +++ b/meson.build @@ -71,6 +71,14 @@ subdir('pkgs/') # Handle options and add necessary flags and subfolders with source files +cgsmks = get_option('cgsmks') +if cgsmks.contains('cgs') + add_project_arguments('-DCGS', language: 'fortran') +endif +if cgsmks.contains('mks') + add_project_arguments('-DMKS', language: 'fortran') +endif + turbclo = get_option('turbclo') if turbclo.length() > 0 and get_option('vcoord') == 'cntiso_hybrid' message('Setting turbclo = [] for vcoord == \'cntiso_hybrid\'') diff --git a/meson_options.txt b/meson_options.txt index af50852a..abc274e5 100644 --- a/meson_options.txt +++ b/meson_options.txt @@ -13,6 +13,9 @@ option('vcoord', type: 'combo', option('driver', type: 'combo', choices: ['nocoupler', 'noforc'], value: 'nocoupler') # List of BLOM options +option('cgsmks', type: 'array', + choices: ['cgs', 'mks'], + description: 'Enable CGS or MKS unit', value: ['mks']) option('turbclo', type: 'array', choices: ['oneeq', 'twoeq', 'advection', 'isodif'], description: 'Turbulent closure options', value: ['oneeq', 'advection']) diff --git a/phy/convec.F b/phy/convec.F index 83d12baa..d3c32388 100644 --- a/phy/convec.F +++ b/phy/convec.F @@ -24,7 +24,7 @@ subroutine convec(m,n,mm,nn,k1m,k1n) c --- layers c --- ------------------------------------------------------------------ c - use mod_constants, only: epsil + use mod_constants, only: epsilp use mod_xc use mod_vcoord, only: sigmar use mod_eos, only: rho, sig, sofsig @@ -84,7 +84,7 @@ subroutine convec(m,n,mm,nn,k1m,k1n) c k=3 dps=0. - do while (delp(k).lt.epsil) + do while (delp(k).lt.epsilp) dps=dps+delp(k) delp(k)=0. k=k+1 @@ -212,7 +212,7 @@ subroutine convec(m,n,mm,nn,k1m,k1n) k=kfpl do while (rho(dps,ttmp,stmp).gt. . rho(dps,ttem(k),ssal(k)).or. - . delp(k).lt.epsil) + . delp(k).lt.epsilp) tdps=tdps+ttem(k)*delp(k) sdps=sdps+ssal(k)*delp(k) dps=dps+delp(k) diff --git a/phy/diapfl.F b/phy/diapfl.F index 0ba42b2b..39505890 100644 --- a/phy/diapfl.F +++ b/phy/diapfl.F @@ -23,7 +23,8 @@ subroutine diapfl(m,n,mm,nn,k1m,k1n) c --- Diapycnal mixing c --- ------------------------------------------------------------------ c - use mod_constants, only: g, alpha0, spval, epsil, onem + use mod_constants, only: g, alpha0, spval, epsilp, onem + use mod_constants, only: L_mks2cgs use mod_time, only: delt1 use mod_xc use mod_vcoord, only: sigmar @@ -33,6 +34,7 @@ subroutine diapfl(m,n,mm,nn,k1m,k1n) use mod_state, only: u, v, dp, dpu, dpv, temp, saln, sigma, . p, pu, pv, kfpla use mod_diffusion, only: difdia + use mod_pointtest, only: itest, jtest, ptest use mod_forcing, only: ustarb use mod_utility, only: util1 use mod_checksum, only: csdiag, chksummsk @@ -64,7 +66,7 @@ subroutine diapfl(m,n,mm,nn,k1m,k1n) c --- scale bottom boundary layer mixing [cm/s] real dsgmnr,fcmxr,dsgcr0,dfeps,gbbl,kappa,ustmin parameter (dsgmnr=.1,fcmxr=.25,dsgcr0=.25,dfeps=1.e-12,gbbl=.2, - . kappa=.4,ustmin=.01) + . kappa=.4,ustmin=.0001*L_mks2cgs) c real, save, dimension(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy,kdm) :: . fpug=spval,fplg=spval @@ -80,6 +82,7 @@ subroutine diapfl(m,n,mm,nn,k1m,k1n) logical done,dwnwrd,remfmx c real, dimension(kdm) :: ttem0,ssal0,delp0,dens0,sigr0,nu0 + real, dimension(kdm) :: rnd integer niter #ifdef TRC real, dimension(ntr,kdm) :: ttrc @@ -127,13 +130,18 @@ subroutine diapfl(m,n,mm,nn,k1m,k1n) enddo #endif enddo + if (mnproc.eq.ptest.and.i.eq.itest.and.j.eq.jtest) then + print*,'mehmet',ttem,ssal + print*,'mehmetniter',niter + print*,'mehmetdifdia',nu + endif c c --- --- Locate range of physical layers. kfpl=kfpla(i,j,n) kmin=kfpl-2 kmax=1 do k=2,kk - if (delp(k).gt.epsil) kmax=k + if (delp(k).gt.epsilp) kmax=k enddo c if (kmin.lt.kmax) then @@ -197,6 +205,8 @@ subroutine diapfl(m,n,mm,nn,k1m,k1n) . *exp(-(delp(k+1)+.5*delp(k))*abs(coriop(i,j)) . *alpha0/(kappa*max(ustmin,ustarb(i,j))*g)) . /(alpha0*g*(sigr(k+1)-sigr(k))) + !Mehmet + ! nubbl = 0.001*L_mks2cgs**2 nu(k)=max(nu(k),nubbl) difdia(i,j,k)=nu(k) endif @@ -314,7 +324,7 @@ subroutine diapfl(m,n,mm,nn,k1m,k1n) . i+i0,j+j0 open (10,file='diapfl.uf',form='unformatted') write (10) kk,kfpl - write (10) g,alpha0,epsil,onem,delt1,dsgmnr,q,q + write (10) g,alpha0,epsilp,onem,delt1,dsgmnr,q,q write (10) ttem0,ssal0,delp0,dens0,sigr0,nu0 close (10) call xchalt('(diapfl)') @@ -334,7 +344,7 @@ subroutine diapfl(m,n,mm,nn,k1m,k1n) f(k)=min(fmax(k), . .5*sqrt(c*nu(k)*dsg(k) . *(dsgui(k)+dsgli(k)))*dsghm(k), - . c*nu(k)*dsg(k)/max(epsil,delp(k))) + . c*nu(k)*dsg(k)/max(epsilp,delp(k))) fold(k)=f(k) h(k)=fcu(k )*dsgui(k )-fcl(k )*dsgli(k ) . +fcl(k-1)*dsgli(k-1)-fcu(k+1)*dsgui(k+1) @@ -519,7 +529,7 @@ subroutine diapfl(m,n,mm,nn,k1m,k1n) . i+i0,j+j0,maxdf,dflim open (10,file='diapfl.uf',form='unformatted') write (10) kk,kfpl - write (10) g,alpha0,epsil,onem,delt1,dsgmnr,q,q + write (10) g,alpha0,epsilp,onem,delt1,dsgmnr,q,q write (10) ttem0,ssal0,delp0,dens0,sigr0,nu0 close (10) call xchalt('(diapfl)') @@ -646,10 +656,12 @@ subroutine diapfl(m,n,mm,nn,k1m,k1n) enddo endif c + call random_number(rnd) c --- --- Copy 1d arrays to 3d arrays do k=1,kk kn=k+nn - temp(i,j,kn)=ttem(k) + !Mehmet + temp(i,j,kn)=ttem(k)!+(2e-11*(1.0-rnd(k)) - 1e-11) saln(i,j,kn)=ssal(k) dp(i,j,kn)=delp(k) sigma(i,j,kn)=dens(k) @@ -672,6 +684,10 @@ subroutine diapfl(m,n,mm,nn,k1m,k1n) enddo #endif enddo + if (mnproc.eq.ptest.and.i.eq.itest.and.j.eq.jtest) then + print*,'mehmetend',ttem,ssal + print*,'mehmetendniter',niter + endif c c --- --- Save variables used for momentum mixing kming(i,j)=kmin diff --git a/phy/diffus.F b/phy/diffus.F index e99a4983..39e93bce 100644 --- a/phy/diffus.F +++ b/phy/diffus.F @@ -24,6 +24,7 @@ subroutine diffus(m,n,mm,nn,k1m,k1n) c --- ------------------------------------------------------------------ c use mod_time, only: delt1 + use mod_constants, only: P_mks2cgs use mod_xc use mod_grid, only: scuy, scvx, scp2, scuxi, scvyi use mod_eos, only: sig @@ -47,7 +48,7 @@ subroutine diffus(m,n,mm,nn,k1m,k1n) #endif c real dpeps - parameter (dpeps=1.e-4) + parameter (dpeps=1.e-5*P_mks2cgs) c call xctilr(dp(1-nbdy,1-nbdy,k1n), 1,kk, 3,3, halo_ps) if (ltedtp_opt.eq.ltedtp_neutral) then @@ -75,6 +76,8 @@ subroutine diffus(m,n,mm,nn,k1m,k1n) #endif call xctilr(difiso, 1,kk, 2,2, halo_ps) endif + ! Mehmet + difiso(:,:,:) = 300.0 c do k=1,kk kn=k+nn @@ -89,7 +92,7 @@ subroutine diffus(m,n,mm,nn,k1m,k1n) do l=1,isu(j) do i=max(0,ifu(j,l)),min(ii+2,ilu(j,l)) q=delt1*.5*(difiso(i-1,j,k)+difiso(i,j,k)) - . *scuy(i,j)*scuxi(i,j) +c . *scuy(i,j)*scuxi(i,j) . *max(min(dp(i-1,j,kn),dp(i,j,kn)),dpeps) usflld(i,j,km)=q*(saln(i-1,j,kn)-saln(i,j,kn)) utflld(i,j,km)=q*(temp(i-1,j,kn)-temp(i,j,kn)) @@ -116,7 +119,7 @@ subroutine diffus(m,n,mm,nn,k1m,k1n) do l=1,isv(j) do i=max(0,ifv(j,l)),min(ii+1,ilv(j,l)) q=delt1*.5*(difiso(i,j-1,k)+difiso(i,j,k)) - . *scvx(i,j)*scvyi(i,j) +c . *scvx(i,j)*scvyi(i,j) . *max(min(dp(i,j-1,kn),dp(i,j,kn)),dpeps) vsflld(i,j,km)=q*(saln(i,j-1,kn)-saln(i,j,kn)) vtflld(i,j,km)=q*(temp(i,j-1,kn)-temp(i,j,kn)) @@ -142,7 +145,8 @@ subroutine diffus(m,n,mm,nn,k1m,k1n) do j=0,jj+1 do l=1,isp(j) do i=max(0,ifp(j,l)),min(ii+1,ilp(j,l)) - q=1./(scp2(i,j)*max(dp(i,j,kn),dpeps)) + q=1./(max(dp(i,j,kn),dpeps)) +c q=1./(scp2(i,j)*max(dp(i,j,kn),dpeps)) saln(i,j,kn)=saln(i,j,kn) . -q*(usflld(i+1,j,km)-usflld(i,j,km) . +vsflld(i,j+1,km)-vsflld(i,j,km)) diff --git a/phy/geoenv_file.F b/phy/geoenv_file.F index 11ebf88c..4c26a982 100644 --- a/phy/geoenv_file.F +++ b/phy/geoenv_file.F @@ -25,7 +25,7 @@ subroutine geoenv_file c --- ------------------------------------------------------------------ c use mod_config, only: inst_suffix - use mod_constants, only: rearth, pi, radian + use mod_constants, only: rearth, pi, radian, L_mks2cgs use mod_xc use mod_grid, only: grfile, qclon, qclat, pclon, pclat, uclon, . uclat, vclon, vclat, scqx, scqy, scpx, scpy, @@ -797,18 +797,18 @@ subroutine geoenv_file do j=1,jj do i=1,ii c - scqx(i,j)=scqx(i,j)*1.e2 - scqy(i,j)=scqy(i,j)*1.e2 - scpx(i,j)=scpx(i,j)*1.e2 - scpy(i,j)=scpy(i,j)*1.e2 - scux(i,j)=scux(i,j)*1.e2 - scuy(i,j)=scuy(i,j)*1.e2 - scvx(i,j)=scvx(i,j)*1.e2 - scvy(i,j)=scvy(i,j)*1.e2 - scq2(i,j)=scq2(i,j)*1.e4 - scp2(i,j)=scp2(i,j)*1.e4 - scu2(i,j)=scu2(i,j)*1.e4 - scv2(i,j)=scv2(i,j)*1.e4 + scqx(i,j)=scqx(i,j)*L_mks2cgs + scqy(i,j)=scqy(i,j)*L_mks2cgs + scpx(i,j)=scpx(i,j)*L_mks2cgs + scpy(i,j)=scpy(i,j)*L_mks2cgs + scux(i,j)=scux(i,j)*L_mks2cgs + scuy(i,j)=scuy(i,j)*L_mks2cgs + scvx(i,j)=scvx(i,j)*L_mks2cgs + scvy(i,j)=scvy(i,j)*L_mks2cgs + scq2(i,j)=scq2(i,j)*L_mks2cgs**2 + scp2(i,j)=scp2(i,j)*L_mks2cgs**2 + scu2(i,j)=scu2(i,j)*L_mks2cgs**2 + scv2(i,j)=scv2(i,j)*L_mks2cgs**2 c cosang(i,j)=cos(angle(i,j)) sinang(i,j)=sin(angle(i,j)) diff --git a/phy/mod_advect.F b/phy/mod_advect.F index e91b894a..6d6f9280 100644 --- a/phy/mod_advect.F +++ b/phy/mod_advect.F @@ -37,6 +37,7 @@ module mod_advect use mod_remap, only: remap_eitvel, remap_eitflx use mod_utility, only: utotm, vtotm, umax, vmax use mod_checksum, only: csdiag, chksummsk + use mod_pointtest, only: itest, jtest, ptest #ifdef TRC use mod_tracers, only: ntr, itrtke, itrgls, trc, uflxtr, vflxtr #endif diff --git a/phy/mod_cmnfld.F90 b/phy/mod_cmnfld.F90 index 6fe55510..a6a0bd8f 100644 --- a/phy/mod_cmnfld.F90 +++ b/phy/mod_cmnfld.F90 @@ -24,7 +24,7 @@ module mod_cmnfld ! ------------------------------------------------------------------------------ use mod_types, only: r8 - use mod_constants, only: spval + use mod_constants, only: spval, onem, L_mks2cgs use mod_xc implicit none @@ -33,7 +33,7 @@ module mod_cmnfld ! Parameters: real(r8) :: & - sls0 = 10._r8*98060._r8, & ! Minimum smoothing length scale in the + sls0 = 10._r8*onem, & ! Minimum smoothing length scale in the ! computation of filtered BFSQ [g cm-1 s-2]. slsmfq = 2._r8, & ! Factor to be multiplied with the mixed ! layer depth to find the smoothing length @@ -45,7 +45,7 @@ module mod_cmnfld ! computation of filtered BFSQ []. bfsqmn = 1.e-7_r8, & ! Minimum value of BFSQ used in the ! computation of neutral slope [s-2]. - dbcrit = .03_r8 ! Critical buoyancy difference used in the + dbcrit = .0003_r8*L_mks2cgs! Critical buoyancy difference used in the ! mixed layer thickness estimation (Levitus, ! 1982) [cm s-2]. diff --git a/phy/mod_cmnfld_routines.F90 b/phy/mod_cmnfld_routines.F90 index 761ac198..14ff2fbf 100644 --- a/phy/mod_cmnfld_routines.F90 +++ b/phy/mod_cmnfld_routines.F90 @@ -24,7 +24,7 @@ module mod_cmnfld_routines ! ------------------------------------------------------------------------------ use mod_types, only: r8 - use mod_constants, only: g, alpha0, epsil, onem, onecm, onemm + use mod_constants, only: g, alpha0, epsilp, onem, onecm, onemm use mod_xc use mod_vcoord, only: vcoord_type_tag, isopyc_bulkml, cntiso_hybrid use mod_grid, only: scuxi, scvyi @@ -125,7 +125,7 @@ subroutine cmnfld_bfsqf_isopyc_bulkml(m, n, mm, nn, k1m, k1n) sup = saln(i, j, 2 + nn) do k = kfpl, kk kn = k + nn - if (p(i, j, kk + 1) - p(i, j, k) < epsil) then + if (p(i, j, kk + 1) - p(i, j, k) < epsilp) then delp(k) = onemm bfsqi(i, j, k) = bfsqi(i, j, k - 1) bfsq(k) = bfsqmn @@ -133,7 +133,7 @@ subroutine cmnfld_bfsqf_isopyc_bulkml(m, n, mm, nn, k1m, k1n) q = max(sls0, delp(kfpl - 1)*slsmfq*q + sls0*(1._r8 - q)) sls2(k) = q*q else - if (p(i, j, kk + 1) - p(i, j, k + 1) < epsil) then + if (p(i, j, kk + 1) - p(i, j, k + 1) < epsilp) then plo = p(i, j, kk + 1) else plo = .5_r8*(p(i, j, k) + p(i, j, k + 1)) @@ -262,13 +262,13 @@ subroutine cmnfld_bfsqf_cntiso_hybrid(m, n, mm, nn, k1m, k1n) sup = saln(i, j, 1 + nn) do k = 2, kk kn = k + nn - if (p(i, j, kk + 1) - p(i, j, k) < epsil) then + if (p(i, j, kk + 1) - p(i, j, k) < epsilp) then delp(k) = onemm bfsqi(i, j, k) = bfsqi(i, j, k - 1) bfsq(k) = bfsqmn sls2(k) = sls0*sls0 else - if (p(i, j, kk + 1) - p(i, j, k + 1) < epsil) then + if (p(i, j, kk + 1) - p(i, j, k + 1) < epsilp) then plo = p(i, j, kk + 1) else plo = .5_r8*(p(i, j, k) + p(i, j, k + 1)) @@ -376,10 +376,10 @@ subroutine cmnfld_bfsqi_cntiso_hybrid(m, n, mm, nn, k1m, k1n) sup = saln(i, j, 1 + nn) do k = 2, kk kn = k + nn - if (p(i, j, kk + 1) - p(i, j, k) < epsil) then + if (p(i, j, kk + 1) - p(i, j, k) < epsilp) then bfsqi(i, j, k) = bfsqi(i, j, k - 1) else - if (p(i, j, kk + 1) - p(i, j, k + 1) < epsil) then + if (p(i, j, kk + 1) - p(i, j, k + 1) < epsilp) then plo = p(i, j, kk + 1) else plo = .5_r8*(p(i, j, k) + p(i, j, k + 1)) @@ -433,7 +433,7 @@ subroutine cmnfld_nslope_isopyc_bulkml(m, n, mm, nn, k1m, k1n) kn = k + nn do l = 1, isp(j) do i = max(- 1, ifp(j, l)), min(ii + 2, ilp(j, l)) - if (dp(i, j, kn) < epsil) then + if (dp(i, j, kn) < epsilp) then phi(i, j, k) = phi(i, j, k + 1) else phi(i, j, k) = phi(i, j, k + 1) & @@ -475,7 +475,7 @@ subroutine cmnfld_nslope_isopyc_bulkml(m, n, mm, nn, k1m, k1n) kmax = 1 do k = 3, kk kn = k + nn - if (dp(i - 1, j, kn) > epsil .or. dp(i, j, kn) > epsil) & + if (dp(i - 1, j, kn) > epsilp .or. dp(i, j, kn) > epsilp) & kmax = k enddo @@ -564,7 +564,7 @@ subroutine cmnfld_nslope_isopyc_bulkml(m, n, mm, nn, k1m, k1n) kmax = 1 do k = 3, kk kn = k + nn - if (dp(i, j - 1, kn) > epsil .or. dp(i, j, kn) > epsil) & + if (dp(i, j - 1, kn) > epsilp .or. dp(i, j, kn) > epsilp) & kmax = k enddo @@ -666,7 +666,7 @@ subroutine cmnfld_nslope_cntiso_hybrid(m, n, mm, nn, k1m, k1n) kn = k + nn do l = 1, isp(j) do i = max(- 1, ifp(j, l)), min(ii + 2, ilp(j, l)) - if (dp(i, j, kn) < epsil) then + if (dp(i, j, kn) < epsilp) then phi(i, j, k) = phi(i, j, k + 1) else phi(i, j, k) = phi(i, j, k + 1) & @@ -705,7 +705,7 @@ subroutine cmnfld_nslope_cntiso_hybrid(m, n, mm, nn, k1m, k1n) kmax = 1 do k = 2, kk kn = k + nn - if (dp(i - 1, j, kn) > epsil .or. dp(i, j, kn) > epsil) kmax = k + if (dp(i - 1, j, kn) > epsilp .or. dp(i, j, kn) > epsilp) kmax=k enddo ! Index of last interface where slope vector times Brunt-Vaisala @@ -758,7 +758,7 @@ subroutine cmnfld_nslope_cntiso_hybrid(m, n, mm, nn, k1m, k1n) kmax = 1 do k = 2, kk kn = k + nn - if (dp(i, j - 1, kn) > epsil .or. dp(i, j, kn) > epsil) kmax = k + if (dp(i, j - 1, kn) > epsilp .or. dp(i, j, kn) > epsilp) kmax=k enddo ! Index of last interface where slope vector times Brunt-Vaisala @@ -881,7 +881,7 @@ subroutine cmnfld_z(m, n, mm, nn, k1m, k1n) km = k + mm do l = 1, isp(j) do i = max(1, ifp(j, l)), min(ii, ilp(j, l)) - if (dp(i, j, km) < epsil) then + if (dp(i, j, km) < epsilp) then z(i, j, k) = z(i, j, k + 1) else z(i, j, k) = z(i, j, k + 1) & @@ -934,7 +934,7 @@ subroutine cmnfld_mlts(m, n, mm, nn, k1m, k1n) zup = zlo dbup = dblo else - dbup = min(dbup, dbcrit - epsil) + dbup = min(dbup, dbcrit - epsilp) mlts(i, j) = ( zup*(dblo - dbcrit) & + zlo*(dbcrit - dbup))/(dblo - dbup) & - z(i, j, 1) diff --git a/phy/mod_constants.F90 b/phy/mod_constants.F90 index 48c17b47..c5e85033 100644 --- a/phy/mod_constants.F90 +++ b/phy/mod_constants.F90 @@ -28,6 +28,7 @@ module mod_constants private +#if defined(CGS) real(r8), parameter :: & g = 980.6_r8, & ! Gravitational acceleration [cm s-2]. rearth = 6.37122e8_r8, & ! Radius of the Earth [cm]. @@ -38,18 +39,59 @@ module mod_constants ! [cm3 g-1]. pi = 3.1415926536_r8, & ! pi []. radian = 57.295779513_r8, & ! 180/pi []. - epsil = 1.e-11_r8, & ! Small value []. + epsilpl = 1.e-11_r8, & ! Small value for pressure*dx []. + epsilp = 1.e-11_r8, & ! Small value for pressure []. + epsilt = 1.e-11_r8, & ! Small value for time []. + epsilk = 1.e-11_r8, & ! Small value for kappa []. spval = 1.e33_r8, & ! Large value []. tenm = 980600._r8, & ! 10 m in units of pressure [g cm-1 s-2]. onem = 98060._r8, & ! 1 m in units of pressure [g cm-1 s-2]. tencm = 9806._r8, & ! 10 cm in units of pressure [g cm-1 s-2]. onecm = 980.6_r8, & ! 1 cm in units of pressure [g cm-1 s-2]. onemm = 98.06_r8, & ! 1 mm in units of pressure [g cm-1 s-2]. - onemu = .09806_r8 ! 1 micrometer in units of pressure + onemu = .09806_r8, & ! 1 micrometer in units of pressure ! [g cm-1 s-2]. + L_mks2cgs = 1.e2_r8, & ! length coefficient converting CGS to MKS + M_mks2cgs = 1.e3_r8, & ! mass coefficient converting CGS to MKS + P_mks2cgs = 1.e1_r8, & ! pressure coefficient converting CGS to MKS + R_mks2cgs = 1.e-3_r8, & ! rho coefficient converting CGS to MKS + g2kg = 1.e-3_r8 ! convert g to kg coeff +#endif +#if defined(MKS) + ! MKS unit + real(r8), parameter :: & + g = 9.806_r8, & ! Gravitational acceleration [m s-2]. + rearth = 6.37122e6_r8, & ! Radius of the Earth [m]. + spcifh = 3990._r8, & ! Specific heat capacity of sea water + ! [J kg-1 K-1]. + t0deg = 273.15_r8, & ! Zero degrees Celsius in Kelvin [K]. + alpha0 = 1.e-3_r8, & ! Reference value of specific volume + ! [m3 kg-1]. + pi = 3.1415926536_r8, & ! pi []. + radian = 57.295779513_r8, & ! 180/pi []. + epsilpl = 1.e-14_r8, & ! Small value for pressure*dx []. + epsilp = 1.e-12_r8, & ! Small value for pressure []. + epsilt = 1.e-11_r8, & ! Small value for time []. + epsilk = 1.e-15_r8, & ! Small value for kappa []. + spval = 1.e33_r8, & ! Large value []. + tenm = 98060._r8, & ! 10 m in units of pressure [kg m-1 s-2]. + onem = 9806._r8, & ! 1 m in units of pressure [kg m-1 s-2]. + tencm = 980.6_r8, & ! 10 cm in units of pressure [kg m-1 s-2]. + onecm = 98.06_r8, & ! 1 cm in units of pressure [kg m-1 s-2]. + onemm = 9.806_r8, & ! 1 mm in units of pressure [kg m-1 s-2]. + onemu = .009806_r8, & ! 1 micrometer in units of pressure + ! [kg m-1 s-2]. + L_mks2cgs = 1._r8, & ! length coefficient converting CGS to MKS + M_mks2cgs = 1._r8, & ! mass coefficient converting CGS to MKS + P_mks2cgs = 1._r8, & ! pressure coefficient converting CGS to MKS + R_mks2cgs = 1._r8, & ! rho coefficient converting CGS to MKS + g2kg = 1.e-3_r8 ! convert g to kg coeff +#endif - public :: g, rearth, spcifh, t0deg, alpha0, pi, radian, epsil, spval, & - tenm, onem, tencm, onecm, onemm, onemu + public :: g, rearth, spcifh, t0deg, alpha0, pi, radian, & + epsilpl, epsilp, epsilt, epsilk, spval, & + tenm, onem, tencm, onecm, onemm, onemu, L_mks2cgs, M_mks2cgs, & + P_mks2cgs, R_mks2cgs, g2kg end module mod_constants diff --git a/phy/mod_dia.F b/phy/mod_dia.F index 715f811b..2099cc51 100644 --- a/phy/mod_dia.F +++ b/phy/mod_dia.F @@ -25,8 +25,9 @@ module mod_dia use mod_calendar, only: date_type, date_offset, calendar_noerr use mod_time, only: date0, date, calendar, nstep, nstep_in_day, . nday_of_year, time, time0, baclin, dlt - use mod_constants, only: g, spcifh, t0deg, alpha0, epsil, spval, + use mod_constants, only: g, spcifh, t0deg, alpha0, epsilp, spval, . onem, onecm, onemm + use mod_constants, only: L_mks2cgs, M_mks2cgs, g2kg use mod_xc use mod_nctools use netcdf, only : nf90_fill_double @@ -169,7 +170,7 @@ module mod_dia c c --- Pressure thickness [g cm-1 s-2] of region for bottom salinity and c --- temperature diagnostics - real, parameter :: dpbot=98060. + real, parameter :: dpbot=onem c c --- Namelist integer, dimension(nphymax), save :: @@ -323,7 +324,7 @@ subroutine diafnm(ctag,diagfq,diagmon,diagann,fname) c date_tmp=date c - if (diagfq+epsil.gt.1.) then + if (diagfq+epsilp.gt.1.) then errstat=date_offset(calendar,date_tmp,-1) if (errstat.ne.calendar_noerr) then if (mnproc.eq.1) then @@ -968,7 +969,7 @@ subroutine diasg1 call xcbcst(j1) do k=1,kk call xceget(sigmar1(k),sigmar(1-nbdy,1-nbdy,k),i1,j1) - sigmar1(k)=sigmar1(k)*1.e3 ! Convert units from g cm-3 to kg m-3 + sigmar1(k)=sigmar1(k)*M_mks2cgs ! Convert units from g cm-3 to kg m-3 enddo if (mnproc.eq.1) then write(lp,*) 'sigma layers=',sigmar1 @@ -1201,7 +1202,7 @@ subroutine diaacc(m,n,mm,nn,k1m,k1n) zup=z(i,j,kup)+.5*dz(i,j,kup) zlo=z(i,j,k )+.5*dz(i,j,k ) tup=temp(i,j,kup+mm) - tlo=min(temp(i,j,km),tup-epsil) + tlo=min(temp(i,j,km),tup-epsilp) t20d(i,j)=(zup*(tlo-20.)+zlo*(20.-tup))/(tlo-tup) endif enddo @@ -1748,6 +1749,12 @@ subroutine diaout(iogrp,m,n,mm,nn,k1m,k1n) real treps parameter (treps=1.e-14) #endif +c + real iM_mks2cgs, iL_mks2cgs, iL_mks2cgssq +c + iM_mks2cgs = 1.0 / (M_mks2cgs) + iL_mks2cgs = 1.0 / (L_mks2cgs) + iL_mks2cgssq = 1.0 / (L_mks2cgs**2) c c --- prepare output fields if (mnproc.eq.1) @@ -1880,7 +1887,7 @@ subroutine diaout(iogrp,m,n,mm,nn,k1m,k1n) enddo c$OMP END PARALLEL DO call xcsum(volgs(1),util1,ips) - volgs(1)=rnacc*1e-6*volgs(1)/g + volgs(1)=rnacc*(iL_mks2cgs**3)*volgs(1)/g endif if (MSC_SALNGA(iogrp).ne.0) then c$OMP PARALLEL DO PRIVATE(l,i) @@ -1949,7 +1956,7 @@ subroutine diaout(iogrp,m,n,mm,nn,k1m,k1n) tempga(1)=tempga(1)/massgs(1) endif if (MSC_MASSGS(iogrp).ne.0) then - massgs(1)=rnacc*1e-3*massgs(1)/g + massgs(1)=rnacc*iM_mks2cgs*massgs(1)/g endif if (MSC_SSSGA(iogrp).ne.0) then c$OMP PARALLEL DO PRIVATE(l,i) @@ -2004,30 +2011,30 @@ subroutine diaout(iogrp,m,n,mm,nn,k1m,k1n) c c --- compute log10 of diffusivities if (LYR_DIFDIA(iogrp).eq.2) - . call loglyr(ACC_DIFDIA(iogrp),'p',1e-4,0.) + . call loglyr(ACC_DIFDIA(iogrp),'p',iL_mks2cgssq,0.) if (LYR_DIFVMO(iogrp).eq.2) - . call loglyr(ACC_DIFVMO(iogrp),'p',1e-4,0.) + . call loglyr(ACC_DIFVMO(iogrp),'p',iL_mks2cgssq,0.) if (LYR_DIFVHO(iogrp).eq.2) - . call loglyr(ACC_DIFVHO(iogrp),'p',1e-4,0.) + . call loglyr(ACC_DIFVHO(iogrp),'p',iL_mks2cgssq,0.) if (LYR_DIFVSO(iogrp).eq.2) - . call loglyr(ACC_DIFVSO(iogrp),'p',1e-4,0.) + . call loglyr(ACC_DIFVSO(iogrp),'p',iL_mks2cgssq,0.) if (LYR_DIFINT(iogrp).eq.2) - . call loglyr(ACC_DIFINT(iogrp),'p',1e-4,0.) + . call loglyr(ACC_DIFINT(iogrp),'p',iL_mks2cgssq,0.) if (LYR_DIFISO(iogrp).eq.2) - . call loglyr(ACC_DIFISO(iogrp),'p',1e-4,0.) + . call loglyr(ACC_DIFISO(iogrp),'p',iL_mks2cgssq,0.) c if (LVL_DIFDIA(iogrp).eq.2) - . call loglvl(ACC_DIFDIALVL(iogrp),'p',1e-4*rnacc,0.) + . call loglvl(ACC_DIFDIALVL(iogrp),'p',iL_mks2cgssq*rnacc,0.) if (LVL_DIFVMO(iogrp).eq.2) - . call loglvl(ACC_DIFVMOLVL(iogrp),'p',1e-4*rnacc,0.) + . call loglvl(ACC_DIFVMOLVL(iogrp),'p',iL_mks2cgssq*rnacc,0.) if (LVL_DIFVHO(iogrp).eq.2) - . call loglvl(ACC_DIFVHOLVL(iogrp),'p',1e-4*rnacc,0.) + . call loglvl(ACC_DIFVHOLVL(iogrp),'p',iL_mks2cgssq*rnacc,0.) if (LVL_DIFVSO(iogrp).eq.2) - . call loglvl(ACC_DIFVSOLVL(iogrp),'p',1e-4*rnacc,0.) + . call loglvl(ACC_DIFVSOLVL(iogrp),'p',iL_mks2cgssq*rnacc,0.) if (LVL_DIFINT(iogrp).eq.2) - . call loglvl(ACC_DIFINTLVL(iogrp),'p',1e-4*rnacc,0.) + . call loglvl(ACC_DIFINTLVL(iogrp),'p',iL_mks2cgssq*rnacc,0.) if (LVL_DIFISO(iogrp).eq.2) - . call loglvl(ACC_DIFISOLVL(iogrp),'p',1e-4*rnacc,0.) + . call loglvl(ACC_DIFISOLVL(iogrp),'p',iL_mks2cgssq*rnacc,0.) c c --- mask sea floor of level fields call msklvl(ACC_BFSQLVL(iogrp),'p') @@ -2224,14 +2231,14 @@ subroutine diaout(iogrp,m,n,mm,nn,k1m,k1n) endif c c --- write 2d fields - call wrth2d(ACC_SIGMX(iogrp),H2D_SIGMX(iogrp),rnacc*1e3, + call wrth2d(ACC_SIGMX(iogrp),H2D_SIGMX(iogrp),rnacc*M_mks2cgs, , 0.,cmpflg,ip,'p','sigmx','Mixed layer density',' ','kg m-3') c - call wrth2d(ACC_UB(iogrp),H2D_UB(iogrp),rnacc*1e-2, + call wrth2d(ACC_UB(iogrp),H2D_UB(iogrp),rnacc*iL_mks2cgs, . 0.,cmpflg,iuu,'u','ubaro','Barotropic velocity x-component', . ' ','m s-1') c - call wrth2d(ACC_VB(iogrp),H2D_VB(iogrp),rnacc*1e-2, + call wrth2d(ACC_VB(iogrp),H2D_VB(iogrp),rnacc*iL_mks2cgs, . 0.,cmpflg,ivv,'v','vbaro','Barotropic velocity y-component', . ' ','m s-1') c @@ -2242,14 +2249,14 @@ subroutine diaout(iogrp,m,n,mm,nn,k1m,k1n) . rnacc*.1,0.,cmpflg,ip,'p','pbot','Bottom pressure',' ','Pa') c call wrth2d(ACC_SEALV(iogrp),H2D_SEALV(iogrp), - . -rnacc*1e-2,0.,cmpflg,ip,'p','sealv','Sea level',' ','m') + . -rnacc*iL_mks2cgs,0.,cmpflg,ip,'p','sealv','Sea level',' ','m') c call wrth2d(ACC_SLVSQ(iogrp),H2D_SLVSQ(iogrp), - . rnacc*1e-4,0.,cmpflg,ip,'p','slvsq','Sea level squared',' ', - . 'm2') + . rnacc*iL_mks2cgssq,0.,cmpflg,ip, + . 'p','slvsq','Sea level squared',' ','m2') c call wrth2d(ACC_UTILH2D(1),H2D_BTMSTR(iogrp), - . rnacc*0.5e-3*dlt/(g*baclin),0.,cmpflg,ip,'p','btmstr', + . rnacc*0.5*iM_mks2cgs*dlt/(g*baclin),0.,cmpflg,ip,'p','btmstr', . 'Barotropic mass streamfunction',' ','kg s-1') c call wrth2d(ACC_HICE(iogrp),H2D_HICE(iogrp),1.,0., @@ -2270,10 +2277,10 @@ subroutine diaout(iogrp,m,n,mm,nn,k1m,k1n) call wrth2d(ACC_IAGE(iogrp),H2D_IAGE(iogrp),1.,0., . cmpflg,ip,'p','iage','Ice age',' ','day') c - call wrth2d(ACC_UICE(iogrp),H2D_UICE(iogrp),1e-2,0., + call wrth2d(ACC_UICE(iogrp),H2D_UICE(iogrp),iL_mks2cgs,0., . cmpflg,iuu,'u','uice','Ice velocity x-component',' ','m s-1') c - call wrth2d(ACC_VICE(iogrp),H2D_VICE(iogrp),1e-2,0., + call wrth2d(ACC_VICE(iogrp),H2D_VICE(iogrp),iL_mks2cgs,0., . cmpflg,ivv,'v','vice','Ice velocity y-component',' ','m s-1') c call wrth2d(ACC_SWA(iogrp),H2D_SWA(iogrp),rnacc,0., @@ -2291,11 +2298,11 @@ subroutine diaout(iogrp,m,n,mm,nn,k1m,k1n) . 'W m-2 K-1') c call wrth2d(ACC_SURFLX(iogrp),H2D_SURFLX(iogrp), - . -rnacc*1e4,0.,cmpflg,ip,'p','hflx', + . -rnacc*L_mks2cgs*L_mks2cgs,0.,cmpflg,ip,'p','hflx', . 'Heat flux received by ocean',' ','W m-2') c call wrth2d(ACC_SURRLX(iogrp),H2D_SURRLX(iogrp), - . -rnacc*1e4,0.,cmpflg,ip,'p','hrflx', + . -rnacc*L_mks2cgs*L_mks2cgs,0.,cmpflg,ip,'p','hrflx', . 'Restoring heat flux received by ocean',' ','W m-2') c call wrth2d(ACC_LIP(iogrp),H2D_LIP(iogrp),rnacc,0., @@ -2318,15 +2325,15 @@ subroutine diaout(iogrp,m,n,mm,nn,k1m,k1n) . rnacc,0.,cmpflg,ip,'p','rfi','Frozen runoff',' ','kg m-2 s-1') c call wrth2d(ACC_SALFLX(iogrp),H2D_SALFLX(iogrp), - . -rnacc*1e-2,0.,cmpflg,ip,'p','sflx', + . -rnacc*iL_mks2cgs,0.,cmpflg,ip,'p','sflx', . 'Salt flux received by ocean',' ','kg m-2 s-1') c call wrth2d(ACC_SALRLX(iogrp),H2D_SALRLX(iogrp), - . -rnacc*1e-2,0.,cmpflg,ip,'p','srflx', + . -rnacc*iL_mks2cgs,0.,cmpflg,ip,'p','srflx', . 'Restoring salt flux received by ocean',' ','kg m-2 s-1') c call wrth2d(ACC_BRNFLX(iogrp),H2D_BRNFLX(iogrp), - . rnacc*(-1e-2),0.,cmpflg,ip,'p','bflx','Brine flux',' ', + . rnacc*(-iL_mks2cgs),0.,cmpflg,ip,'p','bflx','Brine flux',' ', . 'kg m-2 s-1') c call wrth2d(ACC_ZTX(iogrp),H2D_ZTX(iogrp),rnacc,0., @@ -2344,16 +2351,16 @@ subroutine diaout(iogrp,m,n,mm,nn,k1m,k1n) . 'Momentum flux received by ocean y-component',' ','N m-2') c call wrth2d(ACC_IDKEDT(iogrp),H2D_IDKEDT(iogrp), - . rnacc*1.e-3/alpha0,0.,cmpflg,ip,'p','idkedt', + . rnacc*iM_mks2cgs/alpha0,0.,cmpflg,ip,'p','idkedt', . 'Mixed layer inertial kinetic energy tendency per unit area', . ' ','kg s-3') c call wrth2d(ACC_USTAR(iogrp),H2D_USTAR(iogrp), - . rnacc*1e-2,0.,cmpflg,ip,'p','ustar','Friction velocity',' ', - . 'm s-1') + . rnacc*iL_mks2cgs,0.,cmpflg,ip, + . 'p','ustar','Friction velocity',' ','m s-1') c call wrth2d(ACC_USTAR3(iogrp),H2D_USTAR3(iogrp), - . rnacc*1.e-6,0.,cmpflg,ip,'p','ustar3', + . rnacc*(iL_mks2cgs**3),0.,cmpflg,ip,'p','ustar3', . 'Friction velocity cubed',' ','m3 s-3') c call wrth2d(ACC_ABSWND(iogrp),H2D_ABSWND(iogrp), @@ -2361,37 +2368,37 @@ subroutine diaout(iogrp,m,n,mm,nn,k1m,k1n) . 'm s-1') c call wrth2d(ACC_MTKEUS(iogrp),H2D_MTKEUS(iogrp), - . rnacc*1.e-3/alpha0,0.,cmpflg,ip,'p','mtkeus', + . rnacc*iM_mks2cgs/alpha0,0.,cmpflg,ip,'p','mtkeus', . 'Mixed layer turbulent kinetic energy tendency '// . 'per unit area related to friction velocity', . ' ','kg s-3') c call wrth2d(ACC_MTKENI(iogrp),H2D_MTKENI(iogrp), - . rnacc*1.e-3/alpha0,0.,cmpflg,ip,'p','mtkeni', + . rnacc*iM_mks2cgs/alpha0,0.,cmpflg,ip,'p','mtkeni', . 'Mixed layer turbulent kinetic energy tendency '// . 'per unit area related to near inertial motions', . ' ','kg s-3') c call wrth2d(ACC_MTKEBF(iogrp),H2D_MTKEBF(iogrp), - . rnacc*1.e-3/alpha0,0.,cmpflg,ip,'p','mtkebf', + . rnacc*iM_mks2cgs/alpha0,0.,cmpflg,ip,'p','mtkebf', . 'Mixed layer turbulent kinetic energy tendency '// . 'per unit area related to buoyancy forcing', . ' ','kg s-3') c call wrth2d(ACC_MTKERS(iogrp),H2D_MTKERS(iogrp), - . rnacc*1.e-3/alpha0,0.,cmpflg,ip,'p','mtkers', + . rnacc*iM_mks2cgs/alpha0,0.,cmpflg,ip,'p','mtkers', . 'Mixed layer turbulent kinetic energy tendency '// . 'per unit area related to eddy restratification', . ' ','kg s-3') c call wrth2d(ACC_MTKEPE(iogrp),H2D_MTKEPE(iogrp), - . rnacc*1.e-3/alpha0,0.,cmpflg,ip,'p','mtkepe', + . rnacc*iM_mks2cgs/alpha0,0.,cmpflg,ip,'p','mtkepe', . 'Mixed layer turbulent kinetic energy tendency '// . 'per unit area related to potential energy change', . ' ','kg s-3') c call wrth2d(ACC_MTKEKE(iogrp),H2D_MTKEKE(iogrp), - . rnacc*1.e-3/alpha0,0.,cmpflg,ip,'p','mtkeke', + . rnacc*iM_mks2cgs/alpha0,0.,cmpflg,ip,'p','mtkeke', . 'Mixed layer turbulent kinetic energy tendency '// . 'per unit area related to kinetic energy change', . ' ','kg s-3') @@ -2409,23 +2416,23 @@ subroutine diaout(iogrp,m,n,mm,nn,k1m,k1n) . 1./onem,0.,cmpflg,ip,'p','maxmld','Maximum mixed layer depth', . ' ','m') c - call wrth2d(ACC_MLTS(iogrp),H2D_MLTS(iogrp),rnacc*1e-2, + call wrth2d(ACC_MLTS(iogrp),H2D_MLTS(iogrp),rnacc*iL_mks2cgs, . 0.,cmpflg,ip,'p','mlts', . 'Mixed layer thickness defined by sigma t',' ','m') c - call wrth2d(ACC_MLTSMN(iogrp),H2D_MLTSMN(iogrp),1e-2, + call wrth2d(ACC_MLTSMN(iogrp),H2D_MLTSMN(iogrp),iL_mks2cgs, . 0.,cmpflg,ip,'p','mltsmn', . 'Minimum mixed layer thickness defined by sigma t',' ','m') c - call wrth2d(ACC_MLTSMX(iogrp),H2D_MLTSMX(iogrp),1e-2, + call wrth2d(ACC_MLTSMX(iogrp),H2D_MLTSMX(iogrp),iL_mks2cgs, . 0.,cmpflg,ip,'p','mltsmx', . 'Maximum mixed layer thickness defined by sigma t',' ','m') c - call wrth2d(ACC_MLTSSQ(iogrp),H2D_MLTSSQ(iogrp),rnacc*1e-4, - . 0.,cmpflg,ip,'p','mltssq', - . 'Mixed layer thickness squared defined by sigma t',' ','m') + call wrth2d(ACC_MLTSSQ(iogrp),H2D_MLTSSQ(iogrp), + . rnacc*iL_mks2cgssq,0.,cmpflg,ip,'p','mltssq', + . 'Mixed layer thickness squared defined by sigma t',' ','m2') c - call wrth2d(ACC_T20D(iogrp),H2D_T20D(iogrp),rnacc*1e-2, + call wrth2d(ACC_T20D(iogrp),H2D_T20D(iogrp),rnacc*iL_mks2cgs, . 0.,cmpflg,ip,'p','t20d','20C isoterm depth',' ','m') c call wrth2d(ACC_BRNPD(iogrp),H2D_BRNPD(iogrp),rnacc/onem, @@ -2456,7 +2463,8 @@ subroutine diaout(iogrp,m,n,mm,nn,k1m,k1n) . cmpflg,ip,'p','dp','Layer pressure thickness',' ','Pa') c call wrtlyr(ACC_DZ(iogrp),LYR_DZ(iogrp), - . rnacc*1e-2,0.,cmpflg,ip,'p','dz','Layer thickness',' ','m') + . rnacc*iL_mks2cgs,0.,cmpflg,ip, + . 'p','dz','Layer thickness',' ','m') c call wrtlyr(ACC_TEMP(iogrp),LYR_TEMP(iogrp),1.,0., . cmpflg,ip,'p','temp','Temperature','Ocean temperature', @@ -2465,18 +2473,18 @@ subroutine diaout(iogrp,m,n,mm,nn,k1m,k1n) call wrtlyr(ACC_SALN(iogrp),LYR_SALN(iogrp),1.,0., . cmpflg,ip,'p','saln','Salinity','Ocean salinity','g kg-1') c - call wrtlyr(ACC_UVEL(iogrp),LYR_UVEL(iogrp),1e-2, + call wrtlyr(ACC_UVEL(iogrp),LYR_UVEL(iogrp),iL_mks2cgs, . 0.,cmpflg,iuu,'u','uvel','Velocity x-component',' ','m s-1') c - call wrtlyr(ACC_VVEL(iogrp),LYR_VVEL(iogrp),1e-2, + call wrtlyr(ACC_VVEL(iogrp),LYR_VVEL(iogrp),iL_mks2cgs, . 0.,cmpflg,ivv,'v','vvel','Velocity y-component',' ','m s-1') c call wrtlyr(ACC_UFLX(iogrp),LYR_UFLX(iogrp), - . rnacc*0.5e-3/(g*baclin),0.,cmpflg,iuu,'u','uflx', + . rnacc*0.5*iM_mks2cgs/(g*baclin),0.,cmpflg,iuu,'u','uflx', . 'Mass flux in x-direction',' ','kg s-1') c call wrtlyr(ACC_VFLX(iogrp),LYR_VFLX(iogrp), - . rnacc*0.5e-3/(g*baclin),0.,cmpflg,ivv,'v','vflx', + . rnacc*0.5*iM_mks2cgs/(g*baclin),0.,cmpflg,ivv,'v','vflx', . 'Mass flux in y-direction',' ','kg s-1') c call wrtlyr(ACC_UTFLX(iogrp),LYR_UTFLX(iogrp), @@ -2488,20 +2496,20 @@ subroutine diaout(iogrp,m,n,mm,nn,k1m,k1n) . 'Heat flux in y-direction',' ','W') c call wrtlyr(ACC_USFLX(iogrp),LYR_USFLX(iogrp), - . rnacc*0.5e-6/(g*baclin),0.,cmpflg,iuu,'u','usflx', + . rnacc*0.5*g2kg*iM_mks2cgs/(g*baclin),0.,cmpflg,iuu,'u','usflx', . 'Salt flux in x-direction',' ','kg s-1') c call wrtlyr(ACC_VSFLX(iogrp),LYR_VSFLX(iogrp), - . rnacc*0.5e-6/(g*baclin),0.,cmpflg,ivv,'v','vsflx', + . rnacc*0.5*g2kg*iM_mks2cgs/(g*baclin),0.,cmpflg,ivv,'v','vsflx', . 'Salt flux in y-direction',' ','kg s-1') c call wrtlyr(ACC_UMFLTD(iogrp),LYR_UMFLTD(iogrp), - . rnacc*0.5e-3/(g*baclin),0.,cmpflg,iuu,'u','umfltd', + . rnacc*0.5*iM_mks2cgs/(g*baclin),0.,cmpflg,iuu,'u','umfltd', . 'Mass flux due to thickness diffusion in x-direction',' ', . 'kg s-1') c call wrtlyr(ACC_VMFLTD(iogrp),LYR_VMFLTD(iogrp), - . rnacc*0.5e-3/(g*baclin),0.,cmpflg,ivv,'v','vmfltd', + . rnacc*0.5*iM_mks2cgs/(g*baclin),0.,cmpflg,ivv,'v','vmfltd', . 'Mass flux due to thickness diffusion in y-direction',' ', . 'kg s-1') c @@ -2526,31 +2534,31 @@ subroutine diaout(iogrp,m,n,mm,nn,k1m,k1n) . 'W') c call wrtlyr(ACC_USFLTD(iogrp),LYR_USFLTD(iogrp), - . rnacc*0.5e-6/(g*baclin),0.,cmpflg,iuu,'u','usfltd', + . rnacc*0.5*g2kg*iM_mks2cgs/(g*baclin),0.,cmpflg,iuu,'u','usfltd', . 'Salt flux due to thickness diffusion in x-direction',' ', . 'kg s-1') c call wrtlyr(ACC_VSFLTD(iogrp),LYR_VSFLTD(iogrp), - . rnacc*0.5e-6/(g*baclin),0.,cmpflg,ivv,'v','vsfltd', + . rnacc*0.5*g2kg*iM_mks2cgs/(g*baclin),0.,cmpflg,ivv,'v','vsfltd', . 'Salt flux due to thickness diffusion in y-direction',' ', . 'kg s-1') c call wrtlyr(ACC_USFLLD(iogrp),LYR_USFLLD(iogrp), - . rnacc*0.5e-6/(g*baclin),0.,cmpflg,iuu,'u','usflld', + . rnacc*0.5*g2kg*iM_mks2cgs/(g*baclin),0.,cmpflg,iuu,'u','usflld', . 'Salt flux due to lateral diffusion in x-direction',' ', . 'kg s-1') c call wrtlyr(ACC_VSFLLD(iogrp),LYR_VSFLLD(iogrp), - . rnacc*0.5e-6/(g*baclin),0.,cmpflg,ivv,'v','vsflld', + . rnacc*0.5*g2kg*iM_mks2cgs/(g*baclin),0.,cmpflg,ivv,'v','vsflld', . 'Salt flux due to lateral diffusion in y-direction',' ', . 'kg s-1') c call wrtlyr(ACC_WFLX(iogrp),LYR_WFLX(iogrp), - . rnacc*0.5e-3/(g*baclin),0.,cmpflg,ip,'p','wflx', + . rnacc*0.5*iM_mks2cgs/(g*baclin),0.,cmpflg,ip,'p','wflx', . 'Vertical mass flux',' ','kg s-1') c call wrtlyr(ACC_WFLX2(iogrp),LYR_WFLX2(iogrp), - . rnacc*(0.5e-3/(g*baclin))**2,0.,cmpflg,ip,'p','wflx2', + . rnacc*(0.5*iM_mks2cgs/(g*baclin))**2,0.,cmpflg,ip,'p','wflx2', . 'Vertical mass flux squared',' ','kg2 s-2') c call wrtlyr(ACC_BFSQ(iogrp),LYR_BFSQ(iogrp),1.,0., @@ -2558,7 +2566,7 @@ subroutine diaout(iogrp,m,n,mm,nn,k1m,k1n) . 's-1') c call wrtlyr(ACC_AVDSG(iogrp),LYR_PV(iogrp), - . 1.e2*g,0.,cmpflg,ip,'p','pv','Potential vorticity',' ', + . L_mks2cgs*g,0.,cmpflg,ip,'p','pv','Potential vorticity',' ', . 'm-1 s-1') c if (LYR_DIFINT(iogrp).eq.2) then @@ -2566,7 +2574,7 @@ subroutine diaout(iogrp,m,n,mm,nn,k1m,k1n) . 0.,cmpflg,ip,'p','difint','Layer interface diffusivity', . ' ','log10(m2 s-1)') else - call wrtlyr(ACC_DIFINT(iogrp),LYR_DIFINT(iogrp),1e-4, + call wrtlyr(ACC_DIFINT(iogrp),LYR_DIFINT(iogrp),iL_mks2cgssq, . 0.,cmpflg,ip,'p','difint','Layer interface diffusivity', . ' ','m2 s-1') endif @@ -2576,7 +2584,7 @@ subroutine diaout(iogrp,m,n,mm,nn,k1m,k1n) . 0.,cmpflg,ip,'p','difiso','Isopycnal diffusivity',' ', . 'log10(m2 s-1)') else - call wrtlyr(ACC_DIFISO(iogrp),LYR_DIFISO(iogrp),1e-4, + call wrtlyr(ACC_DIFISO(iogrp),LYR_DIFISO(iogrp),iL_mks2cgssq, . 0.,cmpflg,ip,'p','difiso','Isopycnal diffusivity',' ', . 'm2 s-1') endif @@ -2586,7 +2594,7 @@ subroutine diaout(iogrp,m,n,mm,nn,k1m,k1n) . 0.,cmpflg,ip,'p','difdia','Vertical diffusivity',' ', . 'log10(m2 s-1)') else - call wrtlyr(ACC_DIFDIA(iogrp),LYR_DIFDIA(iogrp),1e-4, + call wrtlyr(ACC_DIFDIA(iogrp),LYR_DIFDIA(iogrp),iL_mks2cgssq, . 0.,cmpflg,ip,'p','difdia','Vertical diffusivity',' ', . 'm2 s-1') endif @@ -2596,7 +2604,7 @@ subroutine diaout(iogrp,m,n,mm,nn,k1m,k1n) . 0.,cmpflg,ip,'p','difvmo','Vertical momentum diffusivity',' ', . 'log10(m2 s-1)') else - call wrtlyr(ACC_DIFVMO(iogrp),LYR_DIFVMO(iogrp),1e-4, + call wrtlyr(ACC_DIFVMO(iogrp),LYR_DIFVMO(iogrp),iL_mks2cgssq, . 0.,cmpflg,ip,'p','difvmo','Vertical momentum diffusivity',' ', . 'm2 s-1') endif @@ -2606,7 +2614,7 @@ subroutine diaout(iogrp,m,n,mm,nn,k1m,k1n) . 0.,cmpflg,ip,'p','difvho','Vertical heat diffusivity',' ', . 'log10(m2 s-1)') else - call wrtlyr(ACC_DIFVHO(iogrp),LYR_DIFVHO(iogrp),1e-4, + call wrtlyr(ACC_DIFVHO(iogrp),LYR_DIFVHO(iogrp),iL_mks2cgssq, . 0.,cmpflg,ip,'p','difvho','Vertical heat diffusivity',' ', . 'm2 s-1') endif @@ -2616,24 +2624,25 @@ subroutine diaout(iogrp,m,n,mm,nn,k1m,k1n) . 0.,cmpflg,ip,'p','difvso','Vertical salt diffusivity',' ', . 'log10(m2 s-1)') else - call wrtlyr(ACC_DIFVSO(iogrp),LYR_DIFVSO(iogrp),1e-4, + call wrtlyr(ACC_DIFVSO(iogrp),LYR_DIFVSO(iogrp),iL_mks2cgssq, . 0.,cmpflg,ip,'p','difvso','Vertical salt diffusivity',' ', . 'm2 s-1') endif c #if defined(TRC) && defined(TKE) - call wrtlyr(ACC_TKE(iogrp),LYR_TKE(iogrp),1e-4,0., + call wrtlyr(ACC_TKE(iogrp),LYR_TKE(iogrp),iL_mks2cgssq,0., . cmpflg,ip,'p','tke','TKE','Turbulent kinetic energy', . 'm2 s-2') c - call wrtlyr(ACC_GLS_PSI(iogrp),LYR_GLS_PSI(iogrp),1.e-4,0., + call wrtlyr(ACC_GLS_PSI(iogrp),LYR_GLS_PSI(iogrp),iL_mks2cgssq,0., . cmpflg,ip,'p','gls_psi','GLS_PSI','Generic length scale', . 'm2 s-3') c #endif c --- Write 3d depth fields call wrtlvl(ACC_DZLVL(iogrp),LVL_DZ(iogrp), - . rnacc*1e-2,0.,cmpflg,ip,'p','dzlvl','Layer thickness',' ','m') + . rnacc*iL_mks2cgs,0.,cmpflg,ip, + . 'p','dzlvl','Layer thickness',' ','m') c call wrtlvl(ACC_TEMPLVL(iogrp),LVL_TEMP(iogrp), . rnacc,0.,cmpflg,ip,'p','templvl','Temperature', @@ -2644,19 +2653,19 @@ subroutine diaout(iogrp,m,n,mm,nn,k1m,k1n) . 'Ocean salinity','g kg-1') c call wrtlvl(ACC_UVELLVL(iogrp),LVL_UVEL(iogrp), - . rnacc*1e-2,0.,cmpflg,iuu,'u','uvellvl', + . rnacc*iL_mks2cgs,0.,cmpflg,iuu,'u','uvellvl', . 'Velocity x-component',' ','m s-1') c call wrtlvl(ACC_VVELLVL(iogrp),LVL_VVEL(iogrp), - . rnacc*1e-2,0.,cmpflg,ivv,'v','vvellvl', + . rnacc*iL_mks2cgs,0.,cmpflg,ivv,'v','vvellvl', . 'Velocity y-component',' ','m s-1') c call wrtlvl(ACC_UFLXLVL(iogrp),LVL_UFLX(iogrp), - . rnacc*0.5e-3/(g*baclin),0.,cmpflg,iuu,'u','uflxlvl', + . rnacc*0.5*iM_mks2cgs/(g*baclin),0.,cmpflg,iuu,'u','uflxlvl', . 'Mass flux in x-direction',' ','kg s-1') c call wrtlvl(ACC_VFLXLVL(iogrp),LVL_VFLX(iogrp), - . rnacc*0.5e-3/(g*baclin),0.,cmpflg,ivv,'v','vflxlvl', + . rnacc*0.5*iM_mks2cgs/(g*baclin),0.,cmpflg,ivv,'v','vflxlvl', . 'Mass flux in y-direction',' ','kg s-1') c call wrtlvl(ACC_UTFLXLVL(iogrp),LVL_UTFLX(iogrp), @@ -2668,20 +2677,20 @@ subroutine diaout(iogrp,m,n,mm,nn,k1m,k1n) . 'Heat flux in y-direction',' ','W') c call wrtlvl(ACC_USFLXLVL(iogrp),LVL_USFLX(iogrp), - . rnacc*0.5e-6/(g*baclin),0.,cmpflg,iuu,'u','usflxlvl', - . 'Salt flux in x-direction',' ','kg s-1') + . rnacc*0.5*g2kg*iM_mks2cgs/(g*baclin),0.,cmpflg,iuu, + . 'u','usflxlvl','Salt flux in x-direction',' ','kg s-1') c call wrtlvl(ACC_VSFLXLVL(iogrp),LVL_VSFLX(iogrp), - . rnacc*0.5e-6/(g*baclin),0.,cmpflg,ivv,'v','vsflxlvl', - . 'Salt flux in y-direction',' ','kg s-1') + . rnacc*0.5*g2kg*iM_mks2cgs/(g*baclin),0.,cmpflg,ivv, + . 'v','vsflxlvl','Salt flux in y-direction',' ','kg s-1') c call wrtlvl(ACC_UMFLTDLVL(iogrp),LVL_UMFLTD(iogrp), - . rnacc*0.5e-3/(g*baclin),0.,cmpflg,iuu,'u','umfltdlvl', + . rnacc*0.5*iM_mks2cgs/(g*baclin),0.,cmpflg,iuu,'u','umfltdlvl', . 'Mass flux due to thickness diffusion in x-direction',' ', . 'kg s-1') c call wrtlvl(ACC_VMFLTDLVL(iogrp),LVL_VMFLTD(iogrp), - . rnacc*0.5e-3/(g*baclin),0.,cmpflg,ivv,'v','vmfltdlvl', + . rnacc*0.5*iM_mks2cgs/(g*baclin),0.,cmpflg,ivv,'v','vmfltdlvl', . 'Mass flux due to thickness diffusion in y-direction',' ', . 'kg s-1') c @@ -2706,31 +2715,35 @@ subroutine diaout(iogrp,m,n,mm,nn,k1m,k1n) . 'W') c call wrtlvl(ACC_USFLTDLVL(iogrp),LVL_USFLTD(iogrp), - . rnacc*0.5e-6/(g*baclin),0.,cmpflg,iuu,'u','usfltdlvl', + . rnacc*0.5*g2kg*iM_mks2cgs/(g*baclin),0.,cmpflg,iuu, + . 'u','usfltdlvl', . 'Salt flux due to thickness diffusion in x-direction',' ', . 'kg s-1') c call wrtlvl(ACC_VSFLTDLVL(iogrp),LVL_VSFLTD(iogrp), - . rnacc*0.5e-6/(g*baclin),0.,cmpflg,ivv,'v','vsfltdlvl', + . rnacc*0.5*g2kg*iM_mks2cgs/(g*baclin),0.,cmpflg,ivv, + . 'v','vsfltdlvl', . 'Salt flux due to thickness diffusion in y-direction',' ', . 'kg s-1') c call wrtlvl(ACC_USFLLDLVL(iogrp),LVL_USFLLD(iogrp), - . rnacc*0.5e-6/(g*baclin),0.,cmpflg,iuu,'u','usflldlvl', + . rnacc*0.5*g2kg*iM_mks2cgs/(g*baclin),0.,cmpflg,iuu, + . 'u','usflldlvl', . 'Salt flux due to lateral diffusion in x-direction',' ', . 'kg s-1') c call wrtlvl(ACC_VSFLLDLVL(iogrp),LVL_VSFLLD(iogrp), - . rnacc*0.5e-6/(g*baclin),0.,cmpflg,ivv,'v','vsflldlvl', + . rnacc*0.5*g2kg*iM_mks2cgs/(g*baclin),0.,cmpflg,ivv, + . 'v','vsflldlvl', . 'Salt flux due to lateral diffusion in y-direction',' ', . 'kg s-1') c call wrtlvl(ACC_WFLXLVL(iogrp),LVL_WFLX(iogrp), - . rnacc*0.5e-3/(g*baclin),0.,cmpflg,ip,'p','wflxlvl', + . rnacc*0.5*iM_mks2cgs/(g*baclin),0.,cmpflg,ip,'p','wflxlvl', . 'Vertical mass flux',' ','kg s-1') c call wrtlvl(ACC_WFLX2LVL(iogrp),LVL_WFLX2(iogrp), - . rnacc*(0.5e-3/(g*baclin))**2,0.,cmpflg,ip,'p','wflx2lvl', + . rnacc*(0.5*iM_mks2cgs/(g*baclin))**2,0.,cmpflg,ip,'p','wflx2lvl', . 'Vertical mass flux squared',' ','kg2 s-2') c call wrtlvl(ACC_BFSQLVL(iogrp),LVL_BFSQ(iogrp), @@ -2738,15 +2751,16 @@ subroutine diaout(iogrp,m,n,mm,nn,k1m,k1n) . ' ','s-1') c call wrtlvl(ACC_PVLVL(iogrp),LVL_PV(iogrp), - . rnacc*1.e2*g,0.,cmpflg,ip,'p','pvlvl','Potential vorticity', - . ' ','m-1 s-1') + . rnacc*L_mks2cgs*g,0.,cmpflg,ip, + . 'p','pvlvl','Potential vorticity',' ','m-1 s-1') c if (LVL_DIFINT(iogrp).eq.2) then call wrtlvl(ACC_DIFINTLVL(iogrp),LVL_DIFINT(iogrp),1., . 0.,cmpflg,ip,'p','difintlvl','Layer interface diffusivity', . ' ','log10(m2 s-1)') else - call wrtlvl(ACC_DIFINTLVL(iogrp),LVL_DIFINT(iogrp),1e-4*rnacc, + call wrtlvl(ACC_DIFINTLVL(iogrp),LVL_DIFINT(iogrp), + . iL_mks2cgssq*rnacc, . 0.,cmpflg,ip,'p','difintlvl','Layer interface diffusivity', . ' ','m2 s-1') endif @@ -2756,7 +2770,8 @@ subroutine diaout(iogrp,m,n,mm,nn,k1m,k1n) . 0.,cmpflg,ip,'p','difisolvl','Isopycnal diffusivity',' ', . 'log10(m2 s-1)') else - call wrtlvl(ACC_DIFISOLVL(iogrp),LVL_DIFISO(iogrp),1e-4*rnacc, + call wrtlvl(ACC_DIFISOLVL(iogrp),LVL_DIFISO(iogrp), + . iL_mks2cgssq*rnacc, . 0.,cmpflg,ip,'p','difisolvl','Isopycnal diffusivity',' ', . 'm2 s-1') endif @@ -2766,7 +2781,8 @@ subroutine diaout(iogrp,m,n,mm,nn,k1m,k1n) . 0.,cmpflg,ip,'p','difdialvl','Vertical diffusivity',' ', . 'log10(m2 s-1)') else - call wrtlvl(ACC_DIFDIALVL(iogrp),LVL_DIFDIA(iogrp),1e-4*rnacc, + call wrtlvl(ACC_DIFDIALVL(iogrp),LVL_DIFDIA(iogrp), + . iL_mks2cgssq*rnacc, . 0.,cmpflg,ip,'p','difdialvl','Vertical diffusivity',' ', . 'm2 s-1') endif @@ -2776,7 +2792,8 @@ subroutine diaout(iogrp,m,n,mm,nn,k1m,k1n) . 0.,cmpflg,ip,'p','difvmolvl','Vertical momentum diffusivity', . ' ','log10(m2 s-1)') else - call wrtlvl(ACC_DIFVMOLVL(iogrp),LVL_DIFVMO(iogrp),1e-4*rnacc, + call wrtlvl(ACC_DIFVMOLVL(iogrp),LVL_DIFVMO(iogrp), + . iL_mks2cgssq*rnacc, . 0.,cmpflg,ip,'p','difvmolvl','Vertical momentum diffusivity', . ' ','m2 s-1') endif @@ -2786,7 +2803,8 @@ subroutine diaout(iogrp,m,n,mm,nn,k1m,k1n) . 0.,cmpflg,ip,'p','difvholvl','Vertical heat diffusivity', . ' ','log10(m2 s-1)') else - call wrtlvl(ACC_DIFVHOLVL(iogrp),LVL_DIFVHO(iogrp),1e-4*rnacc, + call wrtlvl(ACC_DIFVHOLVL(iogrp),LVL_DIFVHO(iogrp), + . iL_mks2cgssq*rnacc, . 0.,cmpflg,ip,'p','difvholvl','Vertical heat diffusivity', . ' ','m2 s-1') endif @@ -2796,17 +2814,19 @@ subroutine diaout(iogrp,m,n,mm,nn,k1m,k1n) . 0.,cmpflg,ip,'p','difvsolvl','Vertical salt diffusivity', . ' ','log10(m2 s-1)') else - call wrtlvl(ACC_DIFVSOLVL(iogrp),LVL_DIFVSO(iogrp),1e-4*rnacc, + call wrtlvl(ACC_DIFVSOLVL(iogrp),LVL_DIFVSO(iogrp), + . iL_mks2cgssq*rnacc, . 0.,cmpflg,ip,'p','difvsolvl','Vertical salt diffusivity', . ' ','m2 s-1') endif c #if defined(TRC) && defined(TKE) - call wrtlvl(ACC_TKELVL(iogrp),LVL_TKE(iogrp),rnacc*1.e-4, + call wrtlvl(ACC_TKELVL(iogrp),LVL_TKE(iogrp),rnacc*iL_mks2cgssq, . 0.,cmpflg,ip,'p','tkelvl','Turbulent kinetic energy',' ', . 'm2 s-2') c - call wrtlvl(ACC_GLS_PSILVL(iogrp),LVL_GLS_PSI(iogrp),rnacc*1.e-4, + call wrtlvl(ACC_GLS_PSILVL(iogrp),LVL_GLS_PSI(iogrp), + . rnacc*iL_mks2cgssq, . 0.,cmpflg,ip,'p','gls_psilvl','Generic length scale',' ', . 'm2 s-3') c @@ -3080,6 +3100,9 @@ subroutine diasec(iogrp) real, dimension(itdm,jtdm) :: uflx_cumt,vflx_cumt . ,uflx_cum350t,vflx_cum350t real*8 :: volu,volv + real iM_mks2cgs +c + iM_mks2cgs = 1.0 / (M_mks2cgs) c c --- ------------------------------------------------------------------ c --- read section information @@ -3134,14 +3157,14 @@ subroutine diasec(iogrp) do i=max(1,ifu(j,l)),min(ii,ilu(j,l)) uflx_cum(i,j)=uflx_cum(i,j)+ . phylvl(i,j,k,ACC_UFLXLVL(iogrp)) - . *0.5e-3/(g*baclin*nacc_phy(iogrp)) + . *0.5*iM_mks2cgs/(g*baclin*nacc_phy(iogrp)) enddo enddo do l=1,isv(j) do i=max(1,ifv(j,l)),min(ii,ilv(j,l)) vflx_cum(i,j)=vflx_cum(i,j)+ . phylvl(i,j,k,ACC_VFLXLVL(iogrp)) - . *0.5e-3/(g*baclin*nacc_phy(iogrp)) + . *0.5*iM_mks2cgs/(g*baclin*nacc_phy(iogrp)) enddo enddo c @@ -3231,8 +3254,12 @@ subroutine diamer(iogrp) character :: c20*20 c logical :: iniflg=.true. +c + real iM_mks2cgs c save nind,iind,jind,oflg,uflg,vflg,depthst,iniflg,ocn_nreg +c + iM_mks2cgs = 1.0 / (M_mks2cgs) c if (iniflg) then c @@ -3370,17 +3397,17 @@ subroutine diamer(iogrp) if (ACC_MSFLX(iogrp).eq.0) exit ACC_UIND=ACC_USFLX(iogrp) ACC_VIND=ACC_VSFLX(iogrp) - r=0.5e-6/(g*baclin*nacc_phy(iogrp)) + r=0.5*g2kg*iM_mks2cgs/(g*baclin*nacc_phy(iogrp)) elseif (nfld.eq.5) then if (ACC_MSFTD(iogrp).eq.0) exit ACC_UIND=ACC_USFLTD(iogrp) ACC_VIND=ACC_VSFLTD(iogrp) - r=0.5e-6/(g*baclin*nacc_phy(iogrp)) + r=0.5*g2kg*iM_mks2cgs/(g*baclin*nacc_phy(iogrp)) elseif (nfld.eq.6) then if (ACC_MSFLD(iogrp).eq.0) exit ACC_UIND=ACC_USFLLD(iogrp) ACC_VIND=ACC_VSFLLD(iogrp) - r=0.5e-6/(g*baclin*nacc_phy(iogrp)) + r=0.5*g2kg*iM_mks2cgs/(g*baclin*nacc_phy(iogrp)) else write(lp,*) 'field index out of range' call xchalt('(diamer)') @@ -3541,7 +3568,7 @@ subroutine diamer(iogrp) enddo c$OMP END PARALLEL DO c - r=0.5e-3/(g*baclin*nacc_phy(iogrp)) + r=0.5*iM_mks2cgs/(g*baclin*nacc_phy(iogrp)) c do nfld=1,2 c @@ -3643,7 +3670,7 @@ subroutine diamer(iogrp) enddo endif if (abs(mflx_mr(l,m)-mflx_last_mr(l,m)).lt. - . 1.e5*epsil) then + . 1.e5*epsilp) then mflx_last_mr(l,m)=mflx_mr(l,m) mflx_mr(l,m)=nf90_fill_double else @@ -3706,7 +3733,7 @@ subroutine diamer(iogrp) enddo endif c - r=0.5e-3/(g*baclin*nacc_phy(iogrp)) + r=0.5*iM_mks2cgs/(g*baclin*nacc_phy(iogrp)) c do nfld=1,2 c @@ -3947,9 +3974,9 @@ subroutine diazlv(gridid,k,mm,nn,ind1,ind2,weights,weightsflx) save ztop,zbot,dlevp,dlevu,dlevv,iniflg c c --- Define thresholds - dzeps=1e1*epsil - dpeps=1e5*epsil - flxeps=1e5*epsil + dzeps=1e1*epsilp + dpeps=1e5*epsilp + flxeps=1e5*epsilp c c --- Sort out stuff related to time stepping km=k+mm diff --git a/phy/mod_difest.F b/phy/mod_difest.F index e661e8ba..07e176b8 100644 --- a/phy/mod_difest.F +++ b/phy/mod_difest.F @@ -20,7 +20,8 @@ module mod_difest c use mod_types, only: r8 - use mod_constants, only: g, alpha0, pi, epsil, spval, onem, onecm + use mod_constants, only: g, alpha0, pi, epsilp, spval, onem, onecm + use mod_constants, only: L_mks2cgs, M_mks2cgs, R_mks2cgs use mod_time, only: delt1 use mod_xc use mod_vcoord, only: vcoord_type_tag, isopyc_bulkml, @@ -63,6 +64,7 @@ module mod_difest use CVMix_kpp, only : CVMix_put_kpp use CVMix_kpp, only : CVMix_init_kpp use CVMix_put_get, only : CVMix_put + use mod_pointtest, only: itest, jtest, ptest #if defined(TRC) && defined(TKE) use mod_tracers, only: itrtke, itrgls, trc use mod_tke, only: gls_cmu0, Pr_t, tke_min, gls_psi_min, gls_p, @@ -156,22 +158,33 @@ module mod_difest c --- non-isopycnic layers [g/cm/s**2]. c --- dpnbav - thickness of region near the bottom used to estimate c --- bottom Brunt-Vaisala frequency [g/cm/s**2]. +c --- cpsemin - Zonal eddy phase speed minus zonal barotropic velocity +c --- with a lower bound of -20 cm s-1. +c --- urmsemin- Eddy mixing suppresion factor of +c --- RMS eddy velocity is set to 5 cm s-1 integer iidtyp,bdmldp,tdmflg,iwdflg real dptmin,dpbmin,drhomn,thkdff,temdff,nu0,nus0,nug0,drho0,nuls0, . iwdfac,dmxeff,tdmq,tdmls0,tdmls1,tdclat,tddlat,tkepls,niwls, . cori30,bvf0,nubmin,dpgc,dpgrav,dpdiav,dpddav,dpnbav,ustmin, - . kappa,bfeps,sleps,zetas,as,cs,minOBLdepth - parameter (iidtyp=2,bdmldp=1,tdmflg=1,iwdflg=1,dptmin=98060., - . dpbmin=980.6,drhomn=6.e-6,thkdff=.5,temdff=.35,nu0=.1, - . nus0=50.,nug0=2500.,drho0=6.e-6,nuls0=500.,iwdfac=.06, - . dmxeff=.2,tdmq=1./3.,tdmls0=500.*98060., - . tdmls1=100.*98060.,tdclat=74.5,tddlat=3., - . tkepls=20.*98060.,niwls=300.*98060.,cori30=7.2722e-5, - . bvf0=5.24e-3,nubmin=.01,dpgc=300.*98060., - . dpgrav=100.*98060.,dpdiav=100.*98060., - . dpddav=10.*98060.,dpnbav=250.*98060.,ustmin=.1, - . kappa=.4,bfeps=1.e-12,sleps=.1,zetas=-1.,as=-28.86, - . cs=98.96,minOBLdepth=1.0) + . kappa,bfeps,sleps,zetas,as,cs,minOBLdepth, + . cpsemin,urmsemin + parameter (iidtyp=2,bdmldp=1,tdmflg=1,iwdflg=1,dptmin=onem, + . dpbmin=onecm,drhomn=6.e-3*R_mks2cgs, + . thkdff=5.e-3*L_mks2cgs,temdff=3.5e-3*L_mks2cgs, + . nu0=1.e-5*L_mks2cgs**2, + . nus0=5.e-3*L_mks2cgs**2, + . nug0=2.5e-1*L_mks2cgs**2, + . drho0=6.e-3*R_mks2cgs, + . nuls0=5.e-2*L_mks2cgs**2,iwdfac=.06, + . dmxeff=.2,tdmq=1./3.,tdmls0=500.*onem, + . tdmls1=100.*onem,tdclat=74.5,tddlat=3., + . tkepls=20.*onem,niwls=300.*onem,cori30=7.2722e-5, + . bvf0=5.24e-3,nubmin=1.e-6*L_mks2cgs**2, + . dpgc=300.*onem,dpgrav=100.*onem,dpdiav=100.*onem, + . dpddav=10.*onem,dpnbav=250.*onem,ustmin=.001*L_mks2cgs, + . kappa=.4,bfeps=1.e-16*L_mks2cgs**2,sleps=.1,zetas=-1., + . cpsemin=-0.2*L_mks2cgs,urmsemin=0.05*L_mks2cgs, + . as=-28.86,cs=98.96,minOBLdepth=1.0) c public :: OBLdepth, inivar_difest, init_difest, difest_isobml, . difest_lateral_hybrid, difest_vertical_hybrid @@ -210,6 +223,10 @@ subroutine inivar_difest end subroutine inivar_difest c subroutine init_difest +c + real iL_mks2cgs, iL_mks2cgssq + iL_mks2cgs = 1.0 / (L_mks2cgs) + iL_mks2cgssq = 1.0 / (L_mks2cgs*L_mks2cgs) c c --- ------------------------------------------------------------------ c --- Initialize CVmix variables. @@ -227,8 +244,8 @@ subroutine init_difest c --- ------ convection routine based on N2 not rho c --- ------ if lBruntVaisala is TRUE, otherwise based on rho c --- ------ convert nuls0 to m2/s - call CVMix_init_conv(convect_diff=20.0*nuls0*1e-4, - . convect_visc=20.0*nuls0*1e-4, + call CVMix_init_conv(convect_diff=20.0*nuls0*iL_mks2cgssq, + . convect_visc=20.0*nuls0*iL_mks2cgssq, . lBruntVaisala=.true., . BVsqr_convect=0.0) call CVMix_put(CVMix_glb_params,'max_nlev',kk) @@ -236,7 +253,7 @@ subroutine init_difest call CVMix_put(CVMix_glb_params,'FreshWaterDensity',1000.0) call CVMix_put(CVMix_glb_params,'SaltWaterDensity',1025.0) call cvmix_init_shear(mix_scheme='KPP', - . KPP_nu_zero=nus0*1e-4, + . KPP_nu_zero=nus0*iL_mks2cgssq, . KPP_Ri_zero=ri0, . KPP_exp=3.0) ! CVmix_kpp_params_in => CVmix_kpp_params_user @@ -483,7 +500,7 @@ subroutine difest_common_iso(m,n,mm,nn,k1m,k1n) elseif (k.lt.kmax(i,j)) then q=max(0.,rho(p(i,j,k+1),temp(i,j,kn+1),saln(i,j,kn+1)) . -rho(p(i,j,k+1),temp(i,j,kn ),saln(i,j,kn ))) - drhol(i,j,k)=2.*tup(i)*q/max(1.e-14,tup(i)+q) + drhol(i,j,k)=2.*tup(i)*q/max(1.e-11*R_mks2cgs,tup(i)+q) tup(i)=q else drhol(i,j,k)=tup(i) @@ -500,7 +517,7 @@ subroutine difest_common_iso(m,n,mm,nn,k1m,k1n) c --- ------- Local gradient Richardson number. rig(i,j,k)=alpha0*alpha0 . *max(drhomn,drhol(i,j,k))*dp(i,j,kn) - . /max(1.e-9,du2l(i,j,k)) + . /max(1.e-13*L_mks2cgs**2,du2l(i,j,k)) c endif enddo @@ -622,7 +639,8 @@ subroutine difest_common_hyb(m,n,mm,nn,k1m,k1n) . +(mskv(i,j,k)*dv2(i,j,k)+mskv(i,j+1,k)*dv2(i,j+1,k)) . /max(1,mskv(i,j,k)+mskv(i,j+1,k)) dz=.5*(dp(i,j,kn-1)+dp(i,j,kn))*alpha0/g - rig(i,j,k)=max(0.,bfsqi(i,j,k)*dz*dz)/max(1.e-9,q) + rig(i,j,k)=max(0.,bfsqi(i,j,k)*dz*dz)/ + . max(1.e-13*L_mks2cgs**2,q) else rig(i,j,k)=rig(i,j,k-1) endif @@ -905,7 +923,12 @@ subroutine difest_vertical_hyb(m,n,mm,nn,k1m,k1n) real :: bl1, bl2, bl3, bl4 integer ki, ksfc, ktmp, kOBL, kn1 real, dimension(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy) :: hOBL + real iL_mks2cgs, iL_mks2cgssq, iM_mks2cgs +c c + iL_mks2cgs = 1.0 / (L_mks2cgs) + iM_mks2cgs = 1.0 / (M_mks2cgs) + iL_mks2cgssq = 1.0 / (L_mks2cgs*L_mks2cgs) surf_layer_ext = 0.1 bl1 = 8e-5 bl2 = 1.05e-4 @@ -947,16 +970,16 @@ subroutine difest_vertical_hyb(m,n,mm,nn,k1m,k1n) Kt_kpp = 0.0 Ks_kpp = 0.0 do k=1,kk+1 - Kv_kpp(k) = Kvisc_m(i,j,k)*1e-4 - Kt_kpp(k) = Kdiff_t(i,j,k)*1e-4 - Ks_kpp(k) = Kdiff_s(i,j,k)*1e-4 + Kv_kpp(k) = Kvisc_m(i,j,k)*iL_mks2cgssq + Kt_kpp(k) = Kdiff_t(i,j,k)*iL_mks2cgssq + Ks_kpp(k) = Kdiff_s(i,j,k)*iL_mks2cgssq enddo depth_int(1) = p(i,j,1)/onem iFaceHeight(1) = -depth_int(1) ! convert cm/s to m/s - surfFricVel = ustar(i,j) * 1e-2 + surfFricVel = ustar(i,j) * iL_mks2cgs ! convert cm2/s3 to m2/s3 - surfBuoyFlux = - buoyfl(i,j,1) * 1e-4 + surfBuoyFlux = - buoyfl(i,j,1) * iL_mks2cgssq do k=1,kk kn = k + nn kn1 = max(nn+1,kn-1) @@ -1011,7 +1034,7 @@ subroutine difest_vertical_hyb(m,n,mm,nn,k1m,k1n) surfU = surfHu / hTot surfV = surfHv / hTot surfRho = rho(p(i,j,k),surfTemp,surfSalt) - if (p(i,j,kk+1)-p(i,j,k) < epsil) then + if (p(i,j,kk+1)-p(i,j,k) < epsilp) then deltaRho(k) = deltaRho(k-1) else deltaRho(k) = rho_1d(k) - surfRho @@ -1039,12 +1062,12 @@ subroutine difest_vertical_hyb(m,n,mm,nn,k1m,k1n) rig_i(k)=rig(i,j,k) surfBuoyFlux2(k) = ( buoyfl(i,j,k+1) - . - buoyfl(i,j,1 )) * 1e-4 + . - buoyfl(i,j,1 )) * iL_mks2cgssq c enddo ! k if(dps.gt.0.) bvfbot=bvfbot/dps ! convert cm2/s2 to m2/s2 - deltaU2 = deltaU2*1e-4 + deltaU2 = deltaU2*iL_mks2cgssq ! bottom values for the Ri, N2, and N rig_i(kk+1) = rig_i(kk) @@ -1062,8 +1085,8 @@ subroutine difest_vertical_hyb(m,n,mm,nn,k1m,k1n) elseif (bdmtyp.eq.2) then c --- --------- Type 2: Background diffusivity is a constant ! convert cm2/s2 to m2/s2 - Kv_col(:) = bdmc2*1e-4 - Kd_col(:) = bdmc2*1e-4 + Kv_col(:) = bdmc2*iL_mks2cgssq + Kd_col(:) = bdmc2*iL_mks2cgssq else Kv_col(:) = 0. Kd_col(:) = 0. @@ -1082,7 +1105,7 @@ subroutine difest_vertical_hyb(m,n,mm,nn,k1m,k1n) . efficiency=dmxeff, local_mixing_frac=tdmq) call CVMix_compute_Simmons_invariant(nlev=kk, - . energy_flux=twedon(i,j)*bvfbot*1e-3, + . energy_flux=twedon(i,j)*bvfbot*iM_mks2cgs, . rho=CVMix_glb_params%FreshWaterDensity, . SimmonsCoeff = Simmons_coeff, VertDep = vert_dep, . zw = iFaceHeight, zt = cellHeight, @@ -1129,7 +1152,7 @@ subroutine difest_vertical_hyb(m,n,mm,nn,k1m,k1n) ! Calculate Bulk Richardson number from eq (21) of LMD94 BulkRi_1d = CVmix_kpp_compute_bulk_Richardson( . zt_cntr = cellHeight, ! Depth of cell center [m] - . delta_buoy_cntr=g*alpha0*deltaRho*1e-2, ! Bulk buoyancy difference, Br-B(z) [m s-2] + . delta_buoy_cntr=g*alpha0*deltaRho*iL_mks2cgs, ! Bulk buoyancy difference, Br-B(z) [m s-2] . delta_Vsqr_cntr=deltaU2, ! Square of resolved velocity difference [m2 s-2] . Vt_sqr_cntr=VT2(:), ! Unresolved shear [m2 s-2] . ws_cntr=Ws_1d, ! Turbulent velocity scale profile [m s-1] @@ -1184,7 +1207,7 @@ subroutine difest_vertical_hyb(m,n,mm,nn,k1m,k1n) ! Buoyancy flux acting on the OBL surfBuoyFlux = ( buoyfl(i,j,kOBL+1) - . - buoyfl(i,j,1 )) * 1e-4 + . - buoyfl(i,j,1 )) * iL_mks2cgssq ! Compute KPP using CVMix call CVMix_coeffs_kpp(Kv_kpp(:), ! (inout) Total viscosity [m2 s-1] @@ -1211,9 +1234,9 @@ subroutine difest_vertical_hyb(m,n,mm,nn,k1m,k1n) c ---- ccc ------- ! convert m2/s to cm2/s - Kv_kpp = Kv_kpp*1e4 - Kt_kpp = Kt_kpp*1e4 - Ks_kpp = Ks_kpp*1e4 + Kv_kpp = Kv_kpp*L_mks2cgs**2 + Kt_kpp = Kt_kpp*L_mks2cgs**2 + Ks_kpp = Ks_kpp*L_mks2cgs**2 Kv_kpp=max(nubmin,Kv_kpp) Kt_kpp=max(nubmin,Kt_kpp) Ks_kpp=max(nubmin,Ks_kpp) @@ -1282,7 +1305,8 @@ subroutine difest_lateral_hyb(m,n,mm,nn,k1m,k1n) do i=max(1,ifp(j,l)),min(ii,ilp(j,l)) kfil(i,j)=kk+1 do k=kk,2,-1 - if (p(i,j,k).gt.mlts(i,j)*onecm) kfil(i,j)=k + ! if (p(i,j,k).gt.mlts(i,j)*onecm) kfil(i,j)=k + if (p(i,j,k).gt.mlts(i,j)*(onem/L_mks2cgs)) kfil(i,j)=k enddo enddo enddo @@ -1309,7 +1333,7 @@ subroutine difest_lateral_hyb(m,n,mm,nn,k1m,k1n) kn=k+nn do l=1,isp(j) do i=max(1,ifp(j,l)),min(ii,ilp(j,l)) - if (p(i,j,kk+1)-p(i,j,k+1).lt.epsil) then + if (p(i,j,kk+1)-p(i,j,k+1).lt.epsilp) then plo=p(i,j,kk+1) else plo=.5*(p(i,j,k)+p(i,j,k+1)) @@ -1506,7 +1530,7 @@ subroutine difest_lateral_hyb(m,n,mm,nn,k1m,k1n) . kmax(i,j)-kfil(i,j).ge.1) then c c --- --------- Rhines scale. - rhisc=egr(i,k)/max(1.e-24,betafp(i,j)) + rhisc=egr(i,k)/max(1.e-22*L_mks2cgs**-1,betafp(i,j)) c c --- --------- Eddy length scale. els=max(eglsmn,min(bcrrd(i),rhisc)) @@ -1569,13 +1593,13 @@ subroutine difest_lateral_hyb(m,n,mm,nn,k1m,k1n) c --- ------- RMS eddy velocity estimated from K = Gamma*u_rms*L, where c --- ------- a mixing efficiency of Gamma = 0.35 is used (Klocker and c --- ------- Abernathey, 2014). - rhisc=egrs(i)/max(1.e-24,betafp(i,j)) + rhisc=egrs(i)/max(1.e-22*L_mks2cgs**-1,betafp(i,j)) els=max(eglsmn,min(bcrrd(i),rhisc)) urmse(i)=2.86*egc*egrs(i)*els c c --- ------- Zonal eddy phase speed minus zonal barotropic velocity c --- ------- with a lower bound of -20 cm s-1. - cpse(i)=max(-20.,-betafp(i,j)*bcrrd(i)**2) + cpse(i)=max(cpsemin,-betafp(i,j)*bcrrd(i)**2) c endif c @@ -1593,7 +1617,8 @@ subroutine difest_lateral_hyb(m,n,mm,nn,k1m,k1n) c --- --------- zonal velocity minus eddy phase speed and absolute value c --- --------- of RMS eddy velocity is set to -20 cm s-1 and 5 cm s-1, c --- --------- respectively. - esfac=1./(1.+4.*(umnsc/max(5.,abs(urmse(i))))**2) + esfac=1./ + . (1.+4.*(umnsc/max(urmsemin,abs(urmse(i))))**2) c else esfac=1. @@ -1624,7 +1649,8 @@ subroutine difest_lateral_hyb(m,n,mm,nn,k1m,k1n) . -cpse(i) c c --- ----------- Eddy mixing suppresion factor. - esfac=1./(1.+4.*(umnsc/max(5.,abs(urmse(i))))**2) + esfac=1./ + . (1.+4.*(umnsc/max(urmsemin,abs(urmse(i))))**2) c else esfac=1. @@ -1705,7 +1731,7 @@ subroutine difest_lateral_iso(m,n,mm,nn,k1m,k1n) do l=1,isp(j) do i=max(1,ifp(j,l)),min(ii,ilp(j,l)) if (k.ge.kfpla(i,j,n)) then - if (p(i,j,kk+1)-p(i,j,k+1).lt.epsil) then + if (p(i,j,kk+1)-p(i,j,k+1).lt.epsilp) then plo=p(i,j,kk+1) else plo=.5*(p(i,j,k)+p(i,j,k+1)) @@ -1902,7 +1928,7 @@ subroutine difest_lateral_iso(m,n,mm,nn,k1m,k1n) . kmax(i,j)-kfil(i,j).ge.1) then c c --- --------- Rhines scale. - rhisc=egr(i,k)/max(1.e-24,betafp(i,j)) + rhisc=egr(i,k)/max(1.e-22*L_mks2cgs**-1,betafp(i,j)) c c --- --------- Eddy length scale. els=max(eglsmn,min(bcrrd(i),rhisc)) @@ -1938,13 +1964,13 @@ subroutine difest_lateral_iso(m,n,mm,nn,k1m,k1n) c --- ------- RMS eddy velocity estimated from K = Gamma*u_rms*L, where c --- ------- a mixing efficiency of Gamma = 0.35 is used (Klocker and c --- ------- Abernathey, 2014). - rhisc=egrs(i)/max(1.e-24,betafp(i,j)) + rhisc=egrs(i)/max(1.e-22*L_mks2cgs**-1,betafp(i,j)) els=max(eglsmn,min(bcrrd(i),rhisc)) urmse(i)=2.86*egc*egrs(i)*els c c --- ------- Zonal eddy phase speed minus zonal barotropic velocity c --- ------- with a lower bound of -20 cm s-1. - cpse(i)=max(-20.,-betafp(i,j)*bcrrd(i)**2) + cpse(i)=max(cpsemin,-betafp(i,j)*bcrrd(i)**2) c endif c @@ -1999,7 +2025,8 @@ subroutine difest_lateral_iso(m,n,mm,nn,k1m,k1n) c --- --------- zonal velocity minus eddy phase speed and absolute value c --- --------- of RMS eddy velocity is set to -20 cm s-1 and 5 cm s-1, c --- --------- respectively. - esfac=1./(1.+4.*(umnsc/max(5.,abs(urmse(i))))**2) + esfac=1./ + . (1.+4.*(umnsc/max(urmsemin,abs(urmse(i))))**2) c else esfac=1. @@ -2034,7 +2061,8 @@ subroutine difest_lateral_iso(m,n,mm,nn,k1m,k1n) . -cpse(i) c c --- ----------- Eddy mixing suppresion factor. - esfac=1./(1.+4.*(umnsc/max(5.,abs(urmse(i))))**2) + esfac=1./ + . (1.+4.*(umnsc/max(urmsemin,abs(urmse(i))))**2) c else esfac=1. @@ -2128,7 +2156,7 @@ subroutine difest_vertical_iso(m,n,mm,nn,k1m,k1n) c c --- ------- Brunt-Vaisala frequency squared bvfsq(i,k)=g*g*max(drhomn,drhol(i,j,k)) - . /max(epsil,dp(i,j,kn)) + . /max(epsilp,dp(i,j,kn)) c c --- ------- Brunt-Vaisala frequency bvf(i,k)=sqrt(bvfsq(i,k)) @@ -2139,7 +2167,7 @@ subroutine difest_vertical_iso(m,n,mm,nn,k1m,k1n) h=max(onem,dp(i,j,kn))*alpha0/g c h=max(onem*1e-8,dp(i,j,kn))*alpha0/g c h=max(onemm,dp(i,j,kn))*alpha0/g - Shear2(i,j,k)=max(1.e-9,du2l(i,j,k))/(h*h) + Shear2(i,j,k)=max(1.e-13*L_mks2cgs**2,du2l(i,j,k))/(h*h) Prod(i,j,k)=difdia(i,j,k)*Pr_t*Shear2(i,j,k) else Buoy(i,j,k)=0. @@ -2294,7 +2322,7 @@ subroutine difest_vertical_iso(m,n,mm,nn,k1m,k1n) c c --- ------- Penetration of surface TKE below mixed layer. if (tkepf.gt.0.) then - if (dp(i,j,kn).lt.epsil) then + if (dp(i,j,kn).lt.epsilp) then q=exp(-p(i,j,k)/tkepls) else q=tkepls*(exp(-p(i,j,k )/tkepls) @@ -2306,7 +2334,7 @@ subroutine difest_vertical_iso(m,n,mm,nn,k1m,k1n) c c --- ------- Set TKE and GLS to prescribed minimum values in surface c --- ------- mixed layers and thin layers - if (dp(i,j,kn).lt.epsil) then + if (dp(i,j,kn).lt.epsilp) then trc(i,j,kn,itrtke)=tke_min trc(i,j,kn,itrgls)=gls_psi_min endif @@ -2323,7 +2351,7 @@ subroutine difest_vertical_iso(m,n,mm,nn,k1m,k1n) trc(i,j,kn,itrgls)=max(gls_psi_min, . (gls_cmu0**(gls_p-2.*gls_m)) . *(ust**(2.*gls_m)) - . *(kappa*1.e2)**gls_n) + . *(kappa*L_mks2cgs)**gls_n) # endif endif c @@ -2395,7 +2423,7 @@ subroutine difest_vertical_iso(m,n,mm,nn,k1m,k1n) if (tdmflg.eq.1) then q=.5*(tanh(4.*(abs(plat(i,j))-tdclat)/tddlat-2.)+1.) q=(1.-q)*tdmls0+q*tdmls1 - if (dp(i,j,kn).lt.epsil) then + if (dp(i,j,kn).lt.epsilp) then vsf=exp(p(i,j,k)/q)/(q*(exp(p(i,j,kk+1)/q)-1.)) else vsf=(exp(p(i,j,k+1)/q)-exp(p(i,j,k)/q)) @@ -2457,7 +2485,7 @@ subroutine difest_vertical_iso(m,n,mm,nn,k1m,k1n) do i=max(1,ifp(j,l)),min(ii,ilp(j,l)) if (k.lt.kfil(i,j)) then if (k.gt.2.and.kfil(i,j).le.kk.and. - . p(i,j,min(kk,kfil(i,j)))-p(i,j,3).gt.epsil) then + . p(i,j,min(kk,kfil(i,j)))-p(i,j,3).gt.epsilp) then q=.5*(p(i,j,k+1)+p(i,j,k)) difdia(i,j,k)=((q-p(i,j,3))*dfddsl(i) . +(p(i,j,kfil(i,j))-q)*dfddsu(i)) @@ -2478,7 +2506,7 @@ subroutine difest_vertical_iso(m,n,mm,nn,k1m,k1n) do i=max(1,ifp(j,l)),min(ii,ilp(j,l)) if (k.le.kmax(i,j).and.kmax(i,j)-kfil(i,j).ge.1) then q=niwls - if (k.eq.2.or.dp(i,j,kn).lt.epsil) then + if (k.eq.2.or.dp(i,j,kn).lt.epsilp) then vsf=exp((p(i,j,3)-p(i,j,k+1))/q) . /(q*(1.-exp((p(i,j,3)-p(i,j,kk+1))/q))) else @@ -2506,7 +2534,7 @@ subroutine difest_vertical_iso(m,n,mm,nn,k1m,k1n) . -buoyfl(i,j,1))) c c --- --- Mixed layer thickness - h=(p(i,j,3)-p(i,j,1))/onecm + h=(p(i,j,3)-p(i,j,1))/(onem/L_mks2cgs) c c --- --- Dimensionless vertical coordinate in the boundary layer sg=(p(i,j,2)-p(i,j,1))/(p(i,j,3)-p(i,j,1)) diff --git a/phy/mod_diffusion.F90 b/phy/mod_diffusion.F90 index 638a5f6d..4f91834c 100644 --- a/phy/mod_diffusion.F90 +++ b/phy/mod_diffusion.F90 @@ -24,7 +24,7 @@ module mod_diffusion use mod_types, only: r8 use mod_config, only: inst_suffix - use mod_constants, only: spval, epsil + use mod_constants, only: spval, epsilk use mod_xc implicit none @@ -320,9 +320,9 @@ subroutine inivar_diffusion enddo do k = 1, kk+1 do i = 1 - nbdy, ii + nbdy - Kvisc_m(i, j, k) = epsil - Kdiff_t(i, j, k) = epsil - Kdiff_s(i, j, k) = epsil + Kvisc_m(i, j, k) = epsilk + Kdiff_t(i, j, k) = epsilk + Kdiff_s(i, j, k) = epsilk enddo enddo enddo diff --git a/phy/mod_eddtra.F90 b/phy/mod_eddtra.F90 index 87df3bda..2c97eaac 100644 --- a/phy/mod_eddtra.F90 +++ b/phy/mod_eddtra.F90 @@ -24,7 +24,7 @@ module mod_eddtra ! ------------------------------------------------------------------------------ use mod_types, only: r8 - use mod_constants, only: g, alpha0, epsil, onecm, onemm + use mod_constants, only: g, alpha0, epsilp, onem, onecm, onemm, L_mks2cgs use mod_time, only: delt1 use mod_xc use mod_vcoord, only: vcoord_type_tag, isopyc_bulkml, cntiso_hybrid @@ -36,6 +36,7 @@ module mod_eddtra usfltd, vsfltd use mod_cmnfld, only: nslpx, nslpy, mlts use mod_checksum, only: csdiag, chksummsk + use mod_pointtest, only: itest, jtest, ptest implicit none @@ -205,7 +206,7 @@ subroutine eddtra_gm_isopyc_bulkml(m, n, mm, nn, k1m, k1n) kmax = 1 do k = 3, kk kn = k + nn - if (dp(i - 1, j, kn) > epsil .or. dp(i, j, kn) > epsil) kmax = k + if (dp(i - 1, j, kn) > epsilp .or. dp(i, j, kn) > epsilp) kmax=k enddo ! ------------------------------------------------------------------ @@ -248,7 +249,7 @@ subroutine eddtra_gm_isopyc_bulkml(m, n, mm, nn, k1m, k1n) temp(i - 1, j, kn), saln(i - 1, j, kn)) < & rho(p(i , j, 3), & temp(i , j, km), saln(i , j, km)) .or. & - dp(i - 1, j, kn) < epsil) + dp(i - 1, j, kn) < epsilp) kintr = kintr + 1 if (kintr == kmax + 1) exit kn = kintr + nn @@ -290,7 +291,7 @@ subroutine eddtra_gm_isopyc_bulkml(m, n, mm, nn, k1m, k1n) temp(i , j, kn), saln(i , j, kn)) < & rho(p(i - 1, j, 3), & temp(i - 1, j, km), saln(i - 1, j, km)) .or. & - dp(i , j, kn) < epsil) + dp(i , j, kn) < epsilp) kintr = kintr + 1 if (kintr == kmax + 1) exit kn = kintr + nn @@ -412,10 +413,10 @@ subroutine eddtra_gm_isopyc_bulkml(m, n, mm, nn, k1m, k1n) mfl(kmin + 1) = min(fhi, max(flo, mfl(kmin + 1))) do k = kmin + 1, kmax - 1 if (mfl(k + 1) - mfl(k) > & - ffac*max(epsil, dlm(k))*scp2(i - 1, j)) then + ffac*max(epsilp, dlm(k))*scp2(i - 1, j)) then mfl(k + 1) = mfl(k) + fface*dlm(k)*scp2(i - 1, j) elseif (mfl(k + 1) - mfl(k) < & - - ffac*max(epsil, dlp(k))*scp2(i , j)) then + - ffac*max(epsilp, dlp(k))*scp2(i , j)) then mfl(k + 1) = mfl(k) - fface*dlp(k)*scp2(i , j) else exit @@ -462,11 +463,11 @@ subroutine eddtra_gm_isopyc_bulkml(m, n, mm, nn, k1m, k1n) ! difference between lower and upper interface is beyond the ! floating point accuracy limitation. if (abs(mfl(k + 1) - mfl(k)) > & - 1.e-14_r8*max(epsil*scu2(i, j), & + 1.e-14_r8*max(epsilp*scu2(i, j), & abs(mfl(k + 1) + mfl(k)))) then if (mfl(k + 1) - mfl(k) > & - ffac*max(epsil, dlm(k))*scp2(i - 1, j)) then + ffac*max(epsilp, dlm(k))*scp2(i - 1, j)) then ! In this case, the mass fluxes are removing too much ! mass from the grid cell at (i - 1, j, k). Limit the ! dominating interface flux. @@ -488,7 +489,7 @@ subroutine eddtra_gm_isopyc_bulkml(m, n, mm, nn, k1m, k1n) endif changed = .true. elseif (mfl(k + 1) - mfl(k) < & - - ffac*max(epsil, dlp(k))*scp2(i , j)) then + - ffac*max(epsilp, dlp(k))*scp2(i , j)) then ! In this case, the mass fluxes are removing too much ! mass from the grid cell at (i, j, k). Limit the ! dominating interface flux. @@ -522,7 +523,7 @@ subroutine eddtra_gm_isopyc_bulkml(m, n, mm, nn, k1m, k1n) k = kmin if (abs(mfl(k + 1) - mfl(k)) > & - 1.e-14_r8*max(epsil*scu2(i, j), & + 1.e-14_r8*max(epsilp*scu2(i, j), & abs(mfl(k + 1) + mfl(k)))) then umfltd(i, j, 2 + mm) = mfl(k + 1) - mfl(k) umfltd(i, j, 1 + mm) = umfltd(i, j, 2 + mm) & @@ -537,25 +538,25 @@ subroutine eddtra_gm_isopyc_bulkml(m, n, mm, nn, k1m, k1n) do k = kintr, kmax km = k + mm if (abs(mfl(k + 1) - mfl(k)) > & - 1.e-14_r8*max(epsil*scu2(i, j), & + 1.e-14_r8*max(epsilp*scu2(i, j), & abs(mfl(k + 1) + mfl(k)))) then umfltd(i, j, km) = mfl(k + 1) - mfl(k) else umfltd(i, j, km) = 0._r8 endif if (umfltd(i, j, km) > & - ffac*max(epsil, dlm(k))*scp2(i - 1, j)) then + ffac*max(epsilp, dlm(k))*scp2(i - 1, j)) then write(lp,*) 'eddtra_gm_isopyc_bulkml u >', & i + i0, j + j0, k, umfltd(i, j, km), & - ffac*max(epsil, dlm(k))*scp2(i - 1, j) + ffac*max(epsilp, dlm(k))*scp2(i - 1, j) call xchalt('(eddtra_gm_isopyc_bulkml)') stop '(eddtra_gm_isopyc_bulkml)' endif if (umfltd(i, j, km) < & - - ffac*max(epsil, dlp(k))*scp2(i , j)) then + - ffac*max(epsilp, dlp(k))*scp2(i , j)) then write(lp,*) 'eddtra_gm_isopyc_bulkml u <', & i + i0, j + j0, k, umfltd(i, j, km), & - - ffac*max(epsil, dlp(k))*scp2(i , j) + - ffac*max(epsilp, dlp(k))*scp2(i , j) call xchalt('(eddtra_gm_isopyc_bulkml)') stop '(eddtra_gm_isopyc_bulkml)' endif @@ -591,7 +592,7 @@ subroutine eddtra_gm_isopyc_bulkml(m, n, mm, nn, k1m, k1n) kmax = 1 do k = 3, kk kn = k + nn - if (dp(i, j - 1, kn) > epsil .or. dp(i, j, kn) > epsil) kmax = k + if (dp(i, j - 1, kn) > epsilp .or. dp(i, j, kn) > epsilp) kmax=k enddo ! ------------------------------------------------------------------ @@ -634,7 +635,7 @@ subroutine eddtra_gm_isopyc_bulkml(m, n, mm, nn, k1m, k1n) temp(i, j - 1, kn), saln(i, j - 1, kn)) < & rho(p(i, j , 3), & temp(i, j , km), saln(i, j , km)) .or. & - dp(i, j - 1, kn) < epsil) + dp(i, j - 1, kn) < epsilp) kintr = kintr + 1 if (kintr == kmax + 1) exit kn = kintr + nn @@ -676,7 +677,7 @@ subroutine eddtra_gm_isopyc_bulkml(m, n, mm, nn, k1m, k1n) temp(i, j , kn), saln(i, j , kn)) < & rho(p(i, j - 1, 3), & temp(i, j - 1, km), saln(i, j - 1, km)) .or. & - dp(i, j , kn) < epsil) + dp(i, j , kn) < epsilp) kintr = kintr + 1 if (kintr == kmax + 1) exit kn = kintr + nn @@ -798,10 +799,10 @@ subroutine eddtra_gm_isopyc_bulkml(m, n, mm, nn, k1m, k1n) mfl(kmin + 1) = min(fhi, max(flo, mfl(kmin + 1))) do k = kmin + 1, kmax - 1 if (mfl(k + 1) - mfl(k) > & - ffac*max(epsil, dlm(k))*scp2(i, j - 1)) then + ffac*max(epsilp, dlm(k))*scp2(i, j - 1)) then mfl(k + 1) = mfl(k) + fface*dlm(k)*scp2(i, j - 1) elseif (mfl(k + 1) - mfl(k) < & - - ffac*max(epsil, dlp(k))*scp2(i, j )) then + - ffac*max(epsilp, dlp(k))*scp2(i, j )) then mfl(k + 1) = mfl(k) - fface*dlp(k)*scp2(i, j ) else exit @@ -848,11 +849,11 @@ subroutine eddtra_gm_isopyc_bulkml(m, n, mm, nn, k1m, k1n) ! difference between lower and upper interface is beyond the ! floating point accuracy limitation. if (abs(mfl(k + 1) - mfl(k)) > & - 1.e-14_r8*max(epsil*scv2(i, j), & + 1.e-14_r8*max(epsilp*scv2(i, j), & abs(mfl(k + 1) + mfl(k)))) then if (mfl(k + 1) - mfl(k) > & - ffac*max(epsil, dlm(k))*scp2(i, j - 1)) then + ffac*max(epsilp, dlm(k))*scp2(i, j - 1)) then ! In this case, the mass fluxes are removing too much ! mass from the grid cell at (i, j - 1, k). Limit the ! dominating interface flux. @@ -874,7 +875,7 @@ subroutine eddtra_gm_isopyc_bulkml(m, n, mm, nn, k1m, k1n) endif changed = .true. elseif (mfl(k + 1) - mfl(k) < & - - ffac*max(epsil, dlp(k))*scp2(i, j )) then + - ffac*max(epsilp, dlp(k))*scp2(i, j )) then ! In this case, the mass fluxes are removing too much ! mass from the grid cell at (i, j, k). Limit the ! dominating interface flux. @@ -908,7 +909,7 @@ subroutine eddtra_gm_isopyc_bulkml(m, n, mm, nn, k1m, k1n) k = kmin if (abs(mfl(k + 1) - mfl(k)) > & - 1.e-14_r8*max(epsil*scv2(i, j), & + 1.e-14_r8*max(epsilp*scv2(i, j), & abs(mfl(k + 1) + mfl(k)))) then vmfltd(i, j, 2 + mm) = mfl(k + 1) - mfl(k) vmfltd(i, j, 1 + mm) = vmfltd(i, j, 2 + mm) & @@ -923,25 +924,25 @@ subroutine eddtra_gm_isopyc_bulkml(m, n, mm, nn, k1m, k1n) do k = kintr, kmax km = k + mm if (abs(mfl(k + 1) - mfl(k)) > & - 1.e-14_r8*max(epsil*scv2(i, j), & + 1.e-14_r8*max(epsilp*scv2(i, j), & abs(mfl(k + 1) + mfl(k)))) then vmfltd(i, j, km) = mfl(k + 1) - mfl(k) else vmfltd(i, j, km) = 0._r8 endif if (vmfltd(i, j, km) > & - ffac*max(epsil, dlm(k))*scp2(i, j - 1)) then + ffac*max(epsilp, dlm(k))*scp2(i, j - 1)) then write(lp,*) 'eddtra_gm_isopyc_bulkml v >', & i + i0, j + j0, k, vmfltd(i, j, km), & - ffac*max(epsil, dlm(k))*scp2(i, j - 1) + ffac*max(epsilp, dlm(k))*scp2(i, j - 1) call xchalt('(eddtra_gm_isopyc_bulkml)') stop '(eddtra_gm_isopyc_bulkml)' endif if (vmfltd(i, j, km) < & - - ffac*max(epsil, dlp(k))*scp2(i, j )) then + - ffac*max(epsilp, dlp(k))*scp2(i, j )) then write(lp,*) 'eddtra_gm_isopyc_bulkml v <', & i + i0, j + j0, k, vmfltd(i, j, km), & - - ffac*max(epsil, dlp(k))*scp2(i, j ) + - ffac*max(epsilp, dlp(k))*scp2(i, j ) call xchalt('(eddtra_gm_isopyc_bulkml)') stop '(eddtra_gm_isopyc_bulkml)' endif @@ -1028,12 +1029,13 @@ subroutine eddtra_gm_cntiso_hybrid(m, n, mm, nn, k1m, k1n) do k = 2, kk kn = k + nn puv(k) = puv(k - 1) + dpu(i, j, kn - 1) - if (dp(i - 1, j, kn) > epsil .or. dp(i, j, kn) > epsil) kmax = k + if (dp(i - 1, j, kn) > epsilp .or. dp(i, j, kn) > epsilp) kmax=k enddo ! Compute the eddy induced mass flux at layer interfaces below the ! mixed layer. - mlp = .5_r8*(mlts(i - 1, j) + mlts(i, j))*onecm + ! mlp = .5_r8*(mlts(i - 1, j) + mlts(i, j))*onecm + mlp = .5_r8*(mlts(i - 1, j) + mlts(i, j))*(onem/L_mks2cgs) kml = kmax + 1 mfl(kmax + 1) = 0._r8 do k = kmax, 2, -1 @@ -1106,11 +1108,11 @@ subroutine eddtra_gm_cntiso_hybrid(m, n, mm, nn, k1m, k1n) ! difference between lower and upper interface is beyond the ! floating point accuracy limitation. if (abs(mfl(k + 1) - mfl(k)) > & - 1.e-14_r8*max(epsil*scu2(i, j), & + 1.e-14_r8*max(epsilp*scu2(i, j), & abs(mfl(k + 1) + mfl(k)))) then if (mfl(k + 1) - mfl(k) > & - ffac*max(epsil, dlm(k))*scp2(i - 1, j)) then + ffac*max(epsilp, dlm(k))*scp2(i - 1, j)) then ! In this case, the mass fluxes are removing too much ! mass from the grid cell at (i - 1, j, k). Limit the ! dominating interface flux. @@ -1132,7 +1134,7 @@ subroutine eddtra_gm_cntiso_hybrid(m, n, mm, nn, k1m, k1n) endif changed = .true. elseif (mfl(k + 1) - mfl(k) < & - - ffac*max(epsil, dlp(k))*scp2(i , j)) then + - ffac*max(epsilp, dlp(k))*scp2(i , j)) then ! In this case, the mass fluxes are removing too much ! mass from the grid cell at (i, j, k). Limit the ! dominating interface flux. @@ -1167,25 +1169,25 @@ subroutine eddtra_gm_cntiso_hybrid(m, n, mm, nn, k1m, k1n) do k = 1, kmax km = k + mm if (abs(mfl(k + 1) - mfl(k)) > & - 1.e-14_r8*max(epsil*scu2(i, j), & + 1.e-14_r8*max(epsilp*scu2(i, j), & abs(mfl(k + 1) + mfl(k)))) then umfltd(i, j, km) = mfl(k + 1) - mfl(k) else umfltd(i, j, km) = 0._r8 endif if (umfltd(i, j, km) > & - ffac*max(epsil, dlm(k))*scp2(i - 1, j)) then + ffac*max(epsilp, dlm(k))*scp2(i - 1, j)) then write(lp,*) 'eddtra_gm_cntiso_hybrid u >', & i + i0, j + j0, k, umfltd(i, j, km), & - ffac*max(epsil, dlm(k))*scp2(i - 1, j) + ffac*max(epsilp, dlm(k))*scp2(i - 1, j) call xchalt('(eddtra_gm_cntiso_hybrid)') stop '(eddtra_gm_cntiso_hybrid)' endif if (umfltd(i, j, km) < & - - ffac*max(epsil, dlp(k))*scp2(i , j)) then + - ffac*max(epsilp, dlp(k))*scp2(i , j)) then write(lp,*) 'eddtra_gm_cntiso_hybrid u <', & i + i0, j + j0, k, umfltd(i, j, km), & - - ffac*max(epsil, dlp(k))*scp2(i , j) + - ffac*max(epsilp, dlp(k))*scp2(i , j) call xchalt('(eddtra_gm_cntiso_hybrid)') stop '(eddtra_gm_cntiso_hybrid)' endif @@ -1222,12 +1224,13 @@ subroutine eddtra_gm_cntiso_hybrid(m, n, mm, nn, k1m, k1n) do k = 2, kk kn = k + nn puv(k) = puv(k - 1) + dpv(i, j, kn - 1) - if (dp(i, j - 1, kn) > epsil .or. dp(i, j, kn) > epsil) kmax = k + if (dp(i, j - 1, kn) > epsilp .or. dp(i, j, kn) > epsilp) kmax=k enddo ! Compute the eddy induced mass flux at layer interfaces below the ! mixed layer. - mlp = .5_r8*(mlts(i, j - 1) + mlts(i, j))*onecm + ! mlp = .5_r8*(mlts(i, j - 1) + mlts(i, j))*onecm + mlp = .5_r8*(mlts(i, j - 1) + mlts(i, j))*(onem/L_mks2cgs) kml = kmax + 1 mfl(kmax + 1) = 0._r8 do k = kmax, 2, -1 @@ -1300,11 +1303,11 @@ subroutine eddtra_gm_cntiso_hybrid(m, n, mm, nn, k1m, k1n) ! difference between lower and upper interface is beyond the ! floating point accuracy limitation. if (abs(mfl(k + 1) - mfl(k)) > & - 1.e-14_r8*max(epsil*scv2(i, j), & + 1.e-14_r8*max(epsilp*scv2(i, j), & abs(mfl(k + 1) + mfl(k)))) then if (mfl(k + 1) - mfl(k) > & - ffac*max(epsil, dlm(k))*scp2(i, j - 1)) then + ffac*max(epsilp, dlm(k))*scp2(i, j - 1)) then ! In this case, the mass fluxes are removing too much ! mass from the grid cell at (i, j - 1, k). Limit the ! dominating interface flux. @@ -1326,7 +1329,7 @@ subroutine eddtra_gm_cntiso_hybrid(m, n, mm, nn, k1m, k1n) endif changed = .true. elseif (mfl(k + 1) - mfl(k) < & - - ffac*max(epsil, dlp(k))*scp2(i, j )) then + - ffac*max(epsilp, dlp(k))*scp2(i, j )) then ! In this case, the mass fluxes are removing too much ! mass from the grid cell at (i, j, k). Limit the ! dominating interface flux. @@ -1361,25 +1364,25 @@ subroutine eddtra_gm_cntiso_hybrid(m, n, mm, nn, k1m, k1n) do k = 1, kmax km = k + mm if (abs(mfl(k + 1) - mfl(k)) > & - 1.e-14_r8*max(epsil*scv2(i, j), & + 1.e-14_r8*max(epsilp*scv2(i, j), & abs(mfl(k + 1) + mfl(k)))) then vmfltd(i, j, km) = mfl(k + 1) - mfl(k) else vmfltd(i, j, km) = 0._r8 endif if (vmfltd(i, j, km) > & - ffac*max(epsil, dlm(k))*scp2(i, j - 1)) then + ffac*max(epsilp, dlm(k))*scp2(i, j - 1)) then write(lp,*) 'eddtra_gm_cntiso_hybrid v >', & i + i0, j + j0, k, vmfltd(i, j, km), & - ffac*max(epsil, dlm(k))*scp2(i, j - 1) + ffac*max(epsilp, dlm(k))*scp2(i, j - 1) call xchalt('(eddtra_gm_cntiso_hybrid)') stop '(eddtra_gm_cntiso_hybrid)' endif if (vmfltd(i, j, km) < & - - ffac*max(epsil, dlp(k))*scp2(i, j )) then + - ffac*max(epsilp, dlp(k))*scp2(i, j )) then write(lp,*) 'eddtra_gm_cntiso_hybrid v <', & i + i0, j + j0, k, vmfltd(i, j, km), & - - ffac*max(epsil, dlp(k))*scp2(i, j ) + - ffac*max(epsilp, dlp(k))*scp2(i, j ) call xchalt('(eddtra_gm_cntiso_hybrid)') stop '(eddtra_gm_cntiso_hybrid)' endif diff --git a/phy/mod_eos.F90 b/phy/mod_eos.F90 index 49bbef46..4a99f38c 100644 --- a/phy/mod_eos.F90 +++ b/phy/mod_eos.F90 @@ -24,6 +24,7 @@ module mod_eos ! ------------------------------------------------------------------------------ use mod_types, only: r8 + use mod_constants, only: alpha0 use mod_config, only: expcnf use mod_xc, only: mnproc, lp, xcstop @@ -32,6 +33,7 @@ module mod_eos private ! Coefficients for the functional fit of in situ density. +#if defined(CGS) real(r8), parameter :: & a11 = 9.9985372432159340e-01_r8, & a12 = 1.0380621928183473e-02_r8, & @@ -51,6 +53,46 @@ module mod_eos b21 = 1.1995545126831476e-10_r8, & b22 = 5.5234008384648383e-13_r8, & b23 = 8.4310335919950873e-14_r8 +#endif +#if defined(MKS) + real(r8), parameter :: & + a11 = 9.9985372432159340e+02_r8, & + a12 = 1.0380621928183473e+01_r8, & + a13 = 1.7073577195684715e+00_r8, & + a14 = -3.6570490496333680e-02_r8, & + a15 = -7.3677944503527477e-03_r8, & + a16 = -3.5529175999643348e-03_r8, & + b11 = 1.7083494994335439e-06_r8, & + b12 = 7.1567921402953455e-09_r8, & + b13 = 1.2821026080049485e-09_r8, & + a21 = 1.0_r8 , & + a22 = 1.0316374535350838e-02_r8, & + a23 = 8.9521792365142522e-04_r8, & + a24 = -2.8438341552142710e-05_r8, & + a25 = -1.1887778959461776e-05_r8, & + a26 = -4.0163964812921489e-06_r8, & + b21 = 1.1995545126831476e-09_r8, & + b22 = 5.5234008384648383e-12_r8, & + b23 = 8.4310335919950873e-13_r8 +!c a11 = 9.9985372432159340e+02_r8, & +!c a12 = 1.0380621928183473e+01_r8, & +!c a13 = 1.7073577195684715e+00_r8, & +!c a14 = -3.6570490496333680e-02_r8, & +!c a15 = -7.3677944503527477e-03_r8, & +!c a16 = -3.5529175999643348e-03_r8, & +!c b11 = 1.7083494994335439e-02_r8, & +!c b12 = 7.1567921402953455e-05_r8, & +!c b13 = 1.2821026080049485e-05_r8, & +!c a21 = 1.0_r8 , & +!c a22 = 1.0316374535350838e-02_r8, & +!c a23 = 8.9521792365142522e-04_r8, & +!c a24 = -2.8438341552142710e-05_r8, & +!c a25 = -1.1887778959461776e-05_r8, & +!c a26 = -4.0163964812921489e-06_r8, & +!c b21 = 1.1995545126831476e-05_r8, & +!c b22 = 5.5234008384648383e-08_r8, & +!c b23 = 8.4310335919950873e-09_r8 +#endif ! Reference pressure [g cm-1 s-2]. real(r8) :: pref @@ -106,12 +148,12 @@ subroutine inieos ap24 = a24 ap25 = a25 ap26 = a26 - ap11 = a11 + b11*pref - ap21 - ap12 = a12 + b12*pref - ap22 - ap13 = a13 + b13*pref - ap23 - ap14 = a14 - ap24 - ap15 = a15 - ap25 - ap16 = a16 - ap26 + ap11 = a11 + b11*pref - ap21/alpha0 + ap12 = a12 + b12*pref - ap22/alpha0 + ap13 = a13 + b13*pref - ap23/alpha0 + ap14 = a14 - ap24/alpha0 + ap15 = a15 - ap25/alpha0 + ap16 = a16 - ap26/alpha0 ap210 = a21 ap220 = a22 @@ -119,12 +161,12 @@ subroutine inieos ap240 = a24 ap250 = a25 ap260 = a26 - ap110 = a11 - ap210 - ap120 = a12 - ap220 - ap130 = a13 - ap230 - ap140 = a14 - ap240 - ap150 = a15 - ap250 - ap160 = a16 - ap260 + ap110 = a11 - ap210/alpha0 + ap120 = a12 - ap220/alpha0 + ap130 = a13 - ap230/alpha0 + ap140 = a14 - ap240/alpha0 + ap150 = a15 - ap250/alpha0 + ap160 = a16 - ap260/alpha0 ! Coefficients for freezing temperature. select case (trim(expcnf)) diff --git a/phy/mod_inicon.F b/phy/mod_inicon.F index fdfebd50..d5c18140 100644 --- a/phy/mod_inicon.F +++ b/phy/mod_inicon.F @@ -27,7 +27,8 @@ module mod_inicon c use mod_types, only: r8 use mod_config, only: expcnf - use mod_constants, only: g, epsil, onem + use mod_constants, only: g, epsilp, onem + use mod_constants, only: L_mks2cgs, M_mks2cgs, P_mks2cgs use mod_time, only: nstep, delt1, dlt use mod_xc use mod_vcoord, only: vcoord_type_tag, isopyc_bulkml, @@ -98,7 +99,7 @@ function getpl(th,s,phiu,phil,pup) result(plo) c --- improve the accuracy of the pressure interface by an c --- iterative procedure q=1._r8 - do while (abs(q).gt.1.e-4_r8) + do while (abs(q).gt.1.e-5_r8*P_mks2cgs) call delphi(pup,plo,th,s,dphi,alpu,alpl) q=(phil-phiu-dphi)/alpl plo=plo-q @@ -121,6 +122,9 @@ 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 +c + iM_mks2cgs = 1.0 / M_mks2cgs c if (mnproc.eq.1) then write (lp,'(2a)') ' reading initial condition from ', @@ -344,7 +348,7 @@ subroutine ictsz_file do j=1,jj do l=1,isp(j) do i=max(1,ifp(j,l)),min(ii,ilp(j,l)) -c z(i,j,1)=z(i,j,1)*1.e2 +c z(i,j,1)=z(i,j,1)*L_mks2cgs z(i,j,1)=0. enddo enddo @@ -355,7 +359,8 @@ subroutine ictsz_file do k=1,kdmic do l=1,isp(j) do i=max(1,ifp(j,l)),min(ii,ilp(j,l)) - z(i,j,k+1)=min(depths(i,j)*1.e2,z(i,j,k)+dz(i,j,k)*1.e2) + z(i,j,k+1)=min(depths(i,j)*L_mks2cgs, + . z(i,j,k)+dz(i,j,k)*L_mks2cgs) enddo enddo enddo @@ -369,20 +374,20 @@ subroutine ictsz_file do k=2,kk do l=1,isp(j) do i=max(1,ifp(j,l)),min(ii,ilp(j,l)) - if (z(i,j,kk+1)-z(i,j,k).lt.1.e-4) - . z(i,j,k)=depths(i,j)*1.e2 + if (z(i,j,kk+1)-z(i,j,k).lt.1.e-6*L_mks2cgs) + . z(i,j,k)=depths(i,j)*L_mks2cgs 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)=depths(i,j)*1.e2 + z(i,j,kk+1)=depths(i,j)*L_mks2cgs enddo enddo 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)*1.e-3 + sigmar(i,j,k)=sigmar(i,j,k)*iM_mks2cgs enddo enddo enddo @@ -876,7 +881,7 @@ subroutine inicon do i=max(1,ifp(j,l)),min(ii,ilp(j,l)) k=3 dps=0. - do while (dp(i,j,k).lt.epsil) + do while (dp(i,j,k).lt.epsilp) dps=dps+dp(i,j,k) dp(i,j,k)=0. dp(i,j,k+kk)=0. @@ -920,7 +925,8 @@ subroutine inicon j=jtest write (lp,103) nstep,i0+i,j0+j, . ' init.profile temp saln dens thkns dpth', - . (k,temp(i,j,k),saln(i,j,k),1000.*sig(temp(i,j,k),saln(i,j,k)), + . (k,temp(i,j,k),saln(i,j,k), + . M_mks2cgs*sig(temp(i,j,k),saln(i,j,k)), . dp(i,j,k)/onem,p(i,j,k+1)/onem,k=1,kk) 103 format (i9,2i5,a/(28x,i3,3f8.2,2f8.1)) endif diff --git a/phy/mod_momtum.F b/phy/mod_momtum.F index ad98f07a..dafedb2d 100644 --- a/phy/mod_momtum.F +++ b/phy/mod_momtum.F @@ -26,7 +26,8 @@ module mod_momtum c --- ------------------------------------------------------------------ c use mod_types, only: r8 - use mod_constants, only: g, alpha0, epsil, spval, onem, onemm + use mod_constants, only: g, alpha0, spval, onem, onemm + use mod_constants, only: epsilp, epsilpl use mod_time, only: delt1, dlt use mod_xc use mod_grid, only: scqx, scqy, scpx, scpy, scux, scuy, @@ -276,14 +277,14 @@ subroutine momtum(m,n,mm,nn,k1m,k1n) c do i=max(0,ifp(j,l)),min(ii,ilp(j,l)) ubot=(ubflxs_p(i ,j,n) - . /max(epsil,pbu(i ,j,n)*scuy(i ,j)) + . /max(epsilpl,pbu(i ,j,n)*scuy(i ,j)) . +ubflxs_p(i+1,j,n) - . /max(epsil,pbu(i+1,j,n)*scuy(i+1,j)))*tsfac + . /max(epsilpl,pbu(i+1,j,n)*scuy(i+1,j)))*tsfac . +util1(i,j)/thkbop vbot=(vbflxs_p(i,j ,n) - . /max(epsil,pbv(i,j ,n)*scvx(i,j )) + . /max(epsilpl,pbv(i,j ,n)*scvx(i,j )) . +vbflxs_p(i,j+1,n) - . /max(epsil,pbv(i,j+1,n)*scvx(i,j+1)))*tsfac + . /max(epsilpl,pbv(i,j+1,n)*scvx(i,j+1)))*tsfac . +util2(i,j)/thkbop ubbl=.5*sqrt(ubot*ubot+vbot*vbot) q=cb*(ubbl+cbar) @@ -445,9 +446,9 @@ subroutine momtum(m,n,mm,nn,k1m,k1n) do l=1,isu(j) do i=max(0,ifu(j,l)),min(ii+2,ilu(j,l)) wgtja(i,j)=max(0.,min(1.,(pu(i,j,k+1)-pbu(i,j-1,m)) - . /max(pu(i,j,k+1)-pu(i,j,k),epsil))) + . /max(pu(i,j,k+1)-pu(i,j,k),epsilp))) wgtjb(i,j)=max(0.,min(1.,(pu(i,j,k+1)-pbu(i,j+1,m)) - . /max(pu(i,j,k+1)-pu(i,j,k),epsil))) + . /max(pu(i,j,k+1)-pu(i,j,k),epsilp))) uja(i,j)=(1.-wgtja(i,j))*utotn(i,j-1) . +wgtja(i,j)*slip*utotn(i,j) ujb(i,j)=(1.-wgtjb(i,j))*utotn(i,j+1) @@ -464,9 +465,9 @@ subroutine momtum(m,n,mm,nn,k1m,k1n) do l=1,isv(j) do i=max(-1,ifv(j,l)),min(ii+2,ilv(j,l)) wgtia(i,j)=max(0.,min(1.,(pv(i,j,k+1)-pbv(i-1,j,m)) - . /max(pv(i,j,k+1)-pv(i,j,k),epsil))) + . /max(pv(i,j,k+1)-pv(i,j,k),epsilp))) wgtib(i,j)=max(0.,min(1.,(pv(i,j,k+1)-pbv(i+1,j,m)) - . /max(pv(i,j,k+1)-pv(i,j,k),epsil))) + . /max(pv(i,j,k+1)-pv(i,j,k),epsilp))) via(i,j)=(1.-wgtia(i,j))*vtotn(i-1,j) . +wgtia(i,j)*slip*vtotn(i,j) vib(i,j)=(1.-wgtib(i,j))*vtotn(i+1,j) diff --git a/phy/mod_mxlayr.F b/phy/mod_mxlayr.F index c81abb6a..4c3a397b 100644 --- a/phy/mod_mxlayr.F +++ b/phy/mod_mxlayr.F @@ -25,8 +25,9 @@ module mod_mxlayr c --- ------------------------------------------------------------------ c use mod_types, only: r8 - use mod_constants, only: g, spcifh, alpha0, epsil, spval, onem, + use mod_constants, only: g, spcifh, alpha0, epsilp, spval, onem, . tencm, onecm, onemm, onemu + use mod_constants, only: L_mks2cgs, R_mks2cgs use mod_time, only: delt1 use mod_xc use mod_vcoord, only: sigmar @@ -163,7 +164,8 @@ subroutine mxlayr(m,n,mm,nn,k1m,k1n) c --- of TKE balance []. real kappa,mu,ustmin,mldjmp integer maxitr - parameter (kappa=.4,mu=2.,ustmin=.1,mldjmp=1.e-6,maxitr=20) + parameter (kappa=.4,mu=2.,ustmin=.001*L_mks2cgs, + . mldjmp=1.e-3*R_mks2cgs,maxitr=20) c c --- Parameters for the parameterization of restratification by mixed c --- layer eddies by Fox-Kemper et al. (2008): @@ -175,12 +177,12 @@ subroutine mxlayr(m,n,mm,nn,k1m,k1n) c --- ci - constant that appears when integrating the shape c --- function over the mixed layer depth []. real rtau,cori20,rlf,ci,slbg0 - parameter (rtau=1./86400.,cori20=4.9745e-5,rlf=1./5.e5, - . ci=44./63.,slbg0=0.) + parameter (rtau=1./86400.,cori20=4.9745e-5, + . rlf=1./(5.e3*L_mks2cgs),ci=44./63.,slbg0=0.) c c --- Parameters for brine plume parameterization: c --- bpdrho - density contrast between surface and brine plume depth -c --- [g/cm/s**2]. +c --- [g/cm**3]. c --- bpmndp - minimum distribution thickness of salt from sea-ice c --- freezing [g/cm/s**2]. c --- bpmxdp - maximum distribution depth below the mixed layer base @@ -190,8 +192,8 @@ subroutine mxlayr(m,n,mm,nn,k1m,k1n) c --- dsgmnr - minimum ratio of linearized density jump to target c --- density jump across a layer interface []. real bpdrho,bpmndp,bpmxdp,bpdpmn,dsgmnr - parameter (bpdrho=.4e-3,bpmndp=10.*98060.,bpmxdp=500.*98060., - . bpdpmn=1.*98060.,dsgmnr=.1) + parameter (bpdrho=.4*R_mks2cgs,bpmndp=10.*onem, + . bpmxdp=500.*onem,bpdpmn=1.*onem,dsgmnr=.1) c c --- ------------------------------------------------------------------ c --- Resolve type of mixed layer restratification time scale. @@ -418,7 +420,8 @@ subroutine mxlayr(m,n,mm,nn,k1m,k1n) tkew=mtkeus(i,j)+mtkeni(i,j)+mtkebf(i,j)+mtkers(i,j) if (.not.(nitr.eq.1.and.pres(3)*lbi.gt.1.)) then dtke=(tkew-tkeo)/dpmxl - if (abs(dtke)<(abs(tkew)+1.e-16)/(pres(3)-pres(1))) then + if (abs(dtke)<(abs(tkew)+1.e-22*L_mks2cgs**3) + . /(pres(3)-pres(1))) then if (tkew.lt.0.) then dpmxl=.5*(pres(1)-pmxl) else @@ -437,9 +440,9 @@ subroutine mxlayr(m,n,mm,nn,k1m,k1n) write (lp,*) 'dpth=',pres(3)/onem,';' write (lp,*) 'pmxl=',pmxl/onem,';' write (lp,*) 'corio=',coriop(i,j),';' - write (lp,*) 'ustar=',ustar(i,j)*1.e-2,';' - write (lp,*) 'bfltot=',bfltot*1.e-4,';' - write (lp,*) 'bflpsw=',bflpsw*1.e-4,';' + write (lp,*) 'ustar=',ustar(i,j)*L_mks2cgs**-1,';' + write (lp,*) 'bfltot=',bfltot*L_mks2cgs**-2,';' + write (lp,*) 'bflpsw=',bflpsw*L_mks2cgs**-2,';' write (lp,*) 'bg2=',util1(i,j),';' write (lp,*) 'ce=',ce*sqrt(scp2(i,j))*rlf,';' write (lp,*) @@ -512,7 +515,7 @@ subroutine mxlayr(m,n,mm,nn,k1m,k1n) c kmax=1 do k=2,kk - if (delp(k).gt.epsil) kmax=k + if (delp(k).gt.epsilp) kmax=k enddo kfmax=0 c @@ -589,7 +592,7 @@ subroutine mxlayr(m,n,mm,nn,k1m,k1n) bc(k)=0. endif kfmax=k - if (bdpsum.le.epsil) then + if (bdpsum.le.epsilp) then if (dpfsl.gt.onemu) then bpmldp=min(bpmndp,dpfsl+delp(2)) q=brnflx(i,j)*delt1*g/bpmldp @@ -730,7 +733,7 @@ subroutine mxlayr(m,n,mm,nn,k1m,k1n) endif else if (delp(k).gt.onemu.and.dens(k).gt.densr(k).and. - . sigfsl.lt.densr(k)-1.e-9) then + . sigfsl.lt.densr(k)-(1.e-6*R_mks2cgs)) then dps=min(dpfsl,delp(k)*(dens(k)-densr(k)) . /(densr(k)-sigfsl)) q=1./(dps+delp(k)) @@ -857,7 +860,7 @@ subroutine mxlayr(m,n,mm,nn,k1m,k1n) do if (k.gt.kk) then exit - elseif (delp(k).lt.epsil) then + elseif (delp(k).lt.epsilp) then k=k+1 else pmxl=pres(k+1) @@ -929,7 +932,7 @@ subroutine mxlayr(m,n,mm,nn,k1m,k1n) endif if (.not.chngd) then if (abs(dtke).lt. - . (abs(tkew)+1.e-16)/delp(k)) then + . (abs(tkew)+1.e-22*L_mks2cgs**3)/delp(k)) then if (tkew.lt.0.) then dpmxl=.5*(pres(k)-pmxl) else @@ -952,9 +955,9 @@ subroutine mxlayr(m,n,mm,nn,k1m,k1n) write (lp,*) 'dpth=',pres(3)/onem,';' write (lp,*) 'pmxl=',pmxl/onem,';' write (lp,*) 'corio=',coriop(i,j),';' - write (lp,*) 'ustar=',ustar(i,j)*1.e-2,';' - write (lp,*) 'bfltot=',bfltot*1.e-4,';' - write (lp,*) 'bflpsw=',bflpsw*1.e-4,';' + write (lp,*) 'ustar=',ustar(i,j)*L_mks2cgs**-1,';' + write (lp,*) 'bfltot=',bfltot*L_mks2cgs**-2,';' + write (lp,*) 'bflpsw=',bflpsw*L_mks2cgs**-2,';' write (lp,*) 'bg2=',util1(i,j),';' write (lp,*) 'ce=',ce*sqrt(scp2(i,j))*rlf,';' write (lp,*) 'pres(3)=',pres(3)/onem,';' @@ -972,7 +975,7 @@ subroutine mxlayr(m,n,mm,nn,k1m,k1n) c call xchalt('(mxlayr)') c stop '(mxlayr)' endif - if (pmxl.lt.pres(k+1)-epsil.and.nitr.lt.maxitr) then + if (pmxl.lt.pres(k+1)-epsilp.and.nitr.lt.maxitr) then tdps=tdps+ttem(k)*(pmxl-pres(k)) sdps=sdps+ssal(k)*(pmxl-pres(k)) #ifdef TRC @@ -1072,7 +1075,7 @@ subroutine mxlayr(m,n,mm,nn,k1m,k1n) c kmax=1 do k=2,kk - if (delp(k).gt.epsil) kmax=k + if (delp(k).gt.epsilp) kmax=k enddo kfmax=0 c @@ -1142,7 +1145,7 @@ subroutine mxlayr(m,n,mm,nn,k1m,k1n) bc(k)=0. endif kfmax=k - if (bdpsum.le.epsil) then + if (bdpsum.le.epsilp) then ssal(2)=ssal(2)-brnflx(i,j)*delt1*g/delp(2) else if (bdpsum.lt.bpmndp) then @@ -1206,7 +1209,7 @@ subroutine mxlayr(m,n,mm,nn,k1m,k1n) c --- --- Define first physical layer. k=3 dps=0. - do while (delp(k).lt.epsil) + do while (delp(k).lt.epsilp) dps=dps+delp(k) delp(k)=0. k=k+1 diff --git a/phy/mod_ndiff.F90 b/phy/mod_ndiff.F90 index 5f875313..e4baa771 100644 --- a/phy/mod_ndiff.F90 +++ b/phy/mod_ndiff.F90 @@ -23,7 +23,8 @@ module mod_ndiff ! ------------------------------------------------------------------------------ use mod_types, only: r8 - use mod_constants, only: g, alpha0, epsil, onemm + use mod_constants, only: g, alpha0, epsilp, onemm + use mod_constants, only: P_mks2cgs, R_mks2cgs use mod_time, only: delt1 use mod_xc use mod_grid, only: scuy, scvx, scp2, scuxi, scvyi @@ -42,8 +43,8 @@ module mod_ndiff private real(r8), parameter :: & - rhoeps = 1.e-8_r8, & - dpeps = 1.e-4_r8 + rhoeps = 1.e-5_r8*R_mks2cgs, & + dpeps = 1.e-5_r8*P_mks2cgs integer, parameter :: & p_ord = 4, & it = 1, & @@ -846,7 +847,7 @@ subroutine ndiff_flx(p_srcdi_m, t_srcdi_m, tpc_src_m, & flxconv_rs(kd_p,is,i_p,j_rs_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(epsil, p_ni_lo - p_ni_up) + dp_ni_i = 1._r8/max(epsilp, p_ni_lo - p_ni_up) do while (kuv <= kk) kuvm = kuv + mm if (puv(i_p,j_p,kuv+1) < p_ni_lo) then @@ -918,7 +919,7 @@ subroutine ndiff_flx(p_srcdi_m, t_srcdi_m, tpc_src_m, & ks = ks + 1 enddo q = (p_nslp_src(ks) - p_nslp_dst) & - /max(p_nslp_src(ks) - p_nslp_src(ks-1), epsil) + /max(p_nslp_src(ks) - p_nslp_src(ks-1), epsilp) nslpxy(i_p,j_p,kd) = q*nslp_src(ks-1) + (1._r8 - q)*nslp_src(ks) kd = kd + 1 if (kd > kk) exit diff --git a/phy/mod_pbcor.F b/phy/mod_pbcor.F index 3a350abb..606509bd 100644 --- a/phy/mod_pbcor.F +++ b/phy/mod_pbcor.F @@ -27,7 +27,7 @@ module mod_pbcor c --- ------------------------------------------------------------------ c use mod_types, only: r8 - use mod_constants, only: epsil + use mod_constants, only: epsilp, P_mks2cgs use mod_time, only: dlt use mod_xc use mod_grid, only: scp2i @@ -54,10 +54,10 @@ module mod_pbcor c c --- Parameters: real(r8), parameter :: - . dpeps1 = 1.e-4_r8, ! Small layer pressure thickness - ! [g cm-1 s-2]. - . dpeps2 = 1.e-6_r8 ! Small layer pressure thickness - ! [g cm-1 s-2]. + . dpeps1 = 1.e-5_r8*P_mks2cgs, ! Small layer pressure thickness + ! [g cm-1 s-2]. + . dpeps2 = 1.e-7_r8*P_mks2cgs ! Small layer pressure thickness + ! [g cm-1 s-2]. c public :: bmcmth, pbcor1, pbcor2 c @@ -459,7 +459,7 @@ subroutine pbcor2(m,n,mm,nn,k1m,k1n) km=k+mm do l=1,isp(j) do i=max(0,ifp(j,l)),min(ii+1,ilp(j,l)) - dp(i,j,km)=max(0.,dp(i,j,km))+epsil + dp(i,j,km)=max(0.,dp(i,j,km))+epsilp p(i,j,k+1)=p(i,j,k)+dp(i,j,km) enddo enddo @@ -719,7 +719,7 @@ subroutine pbcor2(m,n,mm,nn,k1m,k1n) enddo #endif sigma(i,j,km)=sig(temp(i,j,km),saln(i,j,km)) - dp(i,j,km)=dp(i,j,km)-epsil + dp(i,j,km)=dp(i,j,km)-epsilp if (dp(i,j,km).lt.dpeps2) dp(i,j,km)=0. enddo enddo diff --git a/phy/mod_pgforc.F b/phy/mod_pgforc.F index 22eed8c6..80a04a37 100644 --- a/phy/mod_pgforc.F +++ b/phy/mod_pgforc.F @@ -25,7 +25,7 @@ module mod_pgforc c --- ------------------------------------------------------------------ c use mod_types, only: r8 - use mod_constants, only: g, epsil, spval + use mod_constants, only: g, epsilp, spval use mod_xc use mod_state, only: dp, dpu, dpv, temp, saln, p, pu, pv, phi, . pb_p, pbu_p, pbv_p, sealv @@ -141,7 +141,7 @@ subroutine pgforc(m,n,mm,nn,k1m,k1n) c --- compute the pressure gradient force c --- ------------------------------------------------------------------ c - use mod_constants, only: g, epsil + use mod_constants, only: g, epsilp use mod_xc c implicit none @@ -206,7 +206,7 @@ subroutine pgforc(m,n,mm,nn,k1m,k1n) kn=k+nn do l=1,isp(j) do i=max(0,ifp(j,l)),min(ii,ilp(j,l)) - if (dp(i,j,kn).lt.epsil) then + if (dp(i,j,kn).lt.epsilp) then phi (i,j,k)=phi (i,j,k+1) phip(i,j,k)=phip(i,j,k+1) else diff --git a/phy/mod_remap.F b/phy/mod_remap.F index 44180dd1..a671b80c 100644 --- a/phy/mod_remap.F +++ b/phy/mod_remap.F @@ -26,6 +26,7 @@ module mod_remap c use mod_types, only: r8 use mod_xc + use mod_constants, only: P_mks2cgs #ifdef TRC use mod_tracers, only: ntr, itrtke, itrgls #endif @@ -36,8 +37,8 @@ module mod_remap c c --- Parameters: real(r8), parameter :: - . dpeps = 1.e-11_r8 ! Small layer pressure thickness (equivalent - ! to approximately 10-16 m) [g cm-1 s-2]. + . dpeps = 1.e-12_r8*P_mks2cgs ! Small layer pressure thickness (equivalent + ! to approximately 10-16 m) [g cm-1 s-2]. #if defined(TRC) && defined(ATRC) real(r8), parameter :: . treps = 1.e-14_r8 ! Small tracer concentration. @@ -1984,7 +1985,7 @@ subroutine remap_eitflx(scuy,scvx,scp2i,scp2,pbmin,pbu,pbv,plo, ca=aa*scp2i(i-1,j) q=dlm+.5*dx(i-1,j)*(1.-ca) if (abs(2.*dx(i-1,j)*umfl(i,j)*scp2i(i-1,j)).lt. - . 1.e-8*q*q) then + . 1.e-6*P_mks2cgs**-2*q*q) then cu(i,j)=ca+umfl(i,j)*scp2i(i-1,j)/q else cdiag @@ -2004,7 +2005,7 @@ subroutine remap_eitflx(scuy,scvx,scp2i,scp2,pbmin,pbu,pbv,plo, ca=aa*scp2i(i ,j) q=dlp-.5*dx(i ,j)*(1.+ca) if (abs(2.*dx(i ,j)*umfl(i,j)*scp2i(i ,j)).lt. - . 1.e-8*q*q) then + . 1.e-6*P_mks2cgs**-2*q*q) then cu(i,j)=ca+umfl(i,j)*scp2i(i ,j)/q else cdiag @@ -2048,7 +2049,7 @@ subroutine remap_eitflx(scuy,scvx,scp2i,scp2,pbmin,pbu,pbv,plo, ca=aa*scp2i(i,j-1) q=dlm+.5*dy(i,j-1)*(1.-ca) if (abs(2.*dy(i,j-1)*vmfl(i,j)*scp2i(i,j-1)).lt. - . 1.e-8*q*q) then + . 1.e-6*P_mks2cgs**-2*q*q) then cv(i,j)=ca+vmfl(i,j)*scp2i(i,j-1)/q else cdiag @@ -2068,7 +2069,7 @@ subroutine remap_eitflx(scuy,scvx,scp2i,scp2,pbmin,pbu,pbv,plo, ca=aa*scp2i(i,j ) q=dlp-.5*dy(i,j )*(1.+ca) if (abs(2.*dy(i,j )*vmfl(i,j)*scp2i(i,j )).lt. - . 1.e-8*q*q) then + . 1.e-6*P_mks2cgs**-2*q*q) then cv(i,j)=ca+vmfl(i,j)*scp2i(i,j )/q else cdiag diff --git a/phy/mod_swabs.F b/phy/mod_swabs.F index 6b1b6b38..f8c57064 100644 --- a/phy/mod_swabs.F +++ b/phy/mod_swabs.F @@ -113,7 +113,7 @@ module mod_swabs . ma94z2=(/ 7.925,-6.644, 3.662,-1.815, -.218, .502/) c c --- Other parameters: -c---- swamxd: Maximum depth of shortwave radiation penetration. +c---- swamxd: Maximum depth of shortwave radiation penetration [m]. real, parameter :: . swamxd = 200. c diff --git a/phy/mod_tidaldissip.F90 b/phy/mod_tidaldissip.F90 index 2005289d..8cab45c6 100644 --- a/phy/mod_tidaldissip.F90 +++ b/phy/mod_tidaldissip.F90 @@ -24,7 +24,7 @@ module mod_tidaldissip ! ------------------------------------------------------------------------------ use mod_types, only: r8 - use mod_constants, only: spval + use mod_constants, only: spval, M_mks2cgs use mod_xc use mod_checksum, only: csdiag, chksummsk use netcdf @@ -78,7 +78,7 @@ subroutine read_tidaldissip real(r8), dimension(itdm,jtdm) :: tmpg integer :: i, j, l, errstat, ncid, dimid, varid - + if (mnproc == 1) then write (lp, '(2a)') ' reading tidal dissipation data from ', & trim(tdfile) @@ -157,7 +157,7 @@ subroutine read_tidaldissip do j = 1, jj do l = 1, isp(j) do i = max(1, ifp(j, l)), min(ii, ilp(j, l)) - twedon(i, j) = twedon(i, j)*1.e3_r8 + twedon(i, j) = twedon(i, j)*M_mks2cgs enddo enddo enddo diff --git a/phy/mod_time.F90 b/phy/mod_time.F90 index 5e32c7d3..bbd1632e 100644 --- a/phy/mod_time.F90 +++ b/phy/mod_time.F90 @@ -24,7 +24,7 @@ module mod_time use mod_types, only: r8 use mod_config, only: expcnf - use mod_constants, only: epsil + use mod_constants, only: epsilt use mod_calendar, only: date_type, daynum_diff, date_offset, & calendar_noerr, calendar_errstr use mod_xc, only: lp, mnproc, xcstop @@ -118,7 +118,7 @@ subroutine init_timevars ! Get number of baroclinic time steps per day and verify that an integer ! number of steps fits in a day. nstep_in_day = nint(86400._r8/baclin) - if (abs(86400._r8/baclin - nstep_in_day) > epsil) then + if (abs(86400._r8/baclin - nstep_in_day) > epsilt) then if (mnproc == 1) then write (lp, *) & 'init_timevars: '// & diff --git a/phy/mod_tke.F90 b/phy/mod_tke.F90 index fc5655ae..bd01ab90 100644 --- a/phy/mod_tke.F90 +++ b/phy/mod_tke.F90 @@ -34,10 +34,8 @@ module mod_tke real(r8), parameter :: & gls_cmu0 = .527_r8, & ! cmu0 - Pr_t = 1._r8, & ! Turbulent Prandtl number []. - tke_min = 7.6e-4_r8, & ! Minimum TKE value [?]. + Pr_t = 1._r8, & ! Turbulent Prandtl number [non-dimensional]. zos = .0002_r8, & ! - gls_psi_min = 1.e-10_r8, & ! Minimum GLS value [?]. gls_p = 3._r8, & ! gls_m = 1.5_r8, & ! gls_n = -1._r8, & ! @@ -56,8 +54,20 @@ module mod_tke gls_Gh0 = .0329_r8, & ! gls_Ghmin = -.28_r8, & ! gls_Ghcri = .03_r8, & ! - vonKar = .4_r8, & ! - Ls_unlmt_min = 1.e-6_r8 ! + vonKar = .4_r8 ! + +#if defined(CGS) + real(r8), parameter :: & + tke_min = 7.6e-4_r8, & ! Minimum TKE value [cm2/s2]. + gls_psi_min = 1.e-10_r8, & ! Minimum GLS value [cm2/s3]. + Ls_unlmt_min = 1.e-6_r8 ! [cm] +#endif +#if defined(MKS) + real(r8), parameter :: & + tke_min = 7.6e-8_r8, & ! Minimum TKE value [m2/s2]. + gls_psi_min = 1.e-14_r8, & ! Minimum GLS value [m2/s3]. + Ls_unlmt_min = 1.e-8_r8 ! [m] +#endif real(r8), dimension(1 - nbdy:idm + nbdy, 1 - nbdy:jdm + nbdy, kdm) :: & Prod, & ! Shear production [?]. diff --git a/phy/mod_tmsmt.F b/phy/mod_tmsmt.F index 5aec8d56..639af0c6 100644 --- a/phy/mod_tmsmt.F +++ b/phy/mod_tmsmt.F @@ -27,7 +27,7 @@ module mod_tmsmt c --- ------------------------------------------------------------------ c use mod_types, only: r8 - use mod_constants, only: epsil, spval + use mod_constants, only: epsilp, spval use mod_xc use mod_vcoord, only: vcoord_type_tag, isopyc_bulkml use mod_state, only: dp, dpu, dpv, temp, saln, p, pb @@ -265,7 +265,7 @@ subroutine tmsmt2(m,n,mm,nn,k1m,k1n) c c --- time smoothing of layer thickness, temperature and salinity c - use mod_constants, only: epsil + use mod_constants, only: epsilp use mod_xc c implicit none @@ -318,23 +318,23 @@ subroutine tmsmt2(m,n,mm,nn,k1m,k1n) pnew=max(0.,dp(i,j,kn)*pbfacn(i)) dp(i,j,km)=wts1*pmid+wts2*(pold+pnew) dpold(i,j,km)=dp(i,j,km) - pold=pold+epsil - pmid=pmid+epsil - pnew=pnew+epsil + pold=pold+epsilp + pmid=pmid+epsilp + pnew=pnew+epsilp temp(i,j,km)=(wts1*pmid*temp(i,j,km) . +wts2*(pold*told(i,j,k)+pnew*temp(i,j,kn))) - . /(dp(i,j,km)+epsil) + . /(dp(i,j,km)+epsilp) told(i,j,k)=temp(i,j,km) saln(i,j,km)=(wts1*pmid*saln(i,j,km) . +wts2*(pold*sold(i,j,k)+pnew*saln(i,j,kn))) - . /(dp(i,j,km)+epsil) + . /(dp(i,j,km)+epsilp) sold(i,j,k)=saln(i,j,km) #ifdef TRC do nt=1,ntr trc(i,j,km,nt)=(wts1*pmid*trc(i,j,km,nt) . +wts2*(pold*trcold(i,j,k,nt) . +pnew*trc(i,j,kn,nt))) - . /(dp(i,j,km)+epsil) + . /(dp(i,j,km)+epsilp) trcold(i,j,k,nt)=trc(i,j,km,nt) enddo #endif diff --git a/phy/mod_vcoord.F90 b/phy/mod_vcoord.F90 index 849380b9..4b974748 100644 --- a/phy/mod_vcoord.F90 +++ b/phy/mod_vcoord.F90 @@ -25,7 +25,7 @@ module mod_vcoord use mod_types, only: r8 use mod_config, only: inst_suffix - use mod_constants, only: g, epsil, spval, onem + use mod_constants, only: g, epsilp, spval, onem use mod_xc use mod_eos, only: sig, dsigdt, dsigds use mod_state, only: u, v, dp, dpu, dpv, temp, saln, sigma, p, pu, pv @@ -296,7 +296,7 @@ subroutine cntiso_regrid_direct_jslice(p_src, p_dst, i_lb, i_ub, j, j_rs, nn) kl = kk ku = kl - 1 do while (ku > 0) - thin_layers = p_src(kl+1,i) - p_src(ku,i) < epsil + 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 @@ -311,7 +311,7 @@ subroutine cntiso_regrid_direct_jslice(p_src, p_dst, i_lb, i_ub, j, j_rs, nn) 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) < epsil + 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. @@ -331,7 +331,7 @@ subroutine cntiso_regrid_direct_jslice(p_src, p_dst, i_lb, i_ub, j, j_rs, nn) 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) < epsil + 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. diff --git a/phy/mod_vdiff.F90 b/phy/mod_vdiff.F90 index 3d1798fd..4a8b0864 100644 --- a/phy/mod_vdiff.F90 +++ b/phy/mod_vdiff.F90 @@ -23,7 +23,7 @@ module mod_vdiff ! ------------------------------------------------------------------------------ use mod_types, only: r8 - use mod_constants, only: g, spcifh, alpha0 + use mod_constants, only: g, spcifh, alpha0, onem use mod_time, only: delt1 use mod_xc use mod_eos, only: sig @@ -40,7 +40,7 @@ module mod_vdiff private real(r8), parameter :: & - dpmin_vdiff = 0.1_r8*98060._r8 + dpmin_vdiff = 0.1_r8*onem public :: cntiso_hybrid_vdifft, cntiso_hybrid_vdiffm diff --git a/phy/numerical_bounds.F90 b/phy/numerical_bounds.F90 index f4579056..79097cca 100644 --- a/phy/numerical_bounds.F90 +++ b/phy/numerical_bounds.F90 @@ -23,7 +23,7 @@ subroutine numerical_bounds ! --------------------------------------------------------------------------- use mod_types, only: r8 - use mod_constants, only: g, spval + use mod_constants, only: g, spval, L_mks2cgs use mod_time, only: baclin use mod_xc use mod_grid, only: scqx, scqy, scpx, scpy, scuy, scvx, scp2, depths @@ -61,7 +61,7 @@ subroutine numerical_bounds do i = max(1, ifp(j, l)), min(ii, ilp(j, l)) btdtmx = min(btdtmx, & scpx(i, j)*scpy(i, j) & - /sqrt(g*depths(i, j)*100._r8*( scpx(i, j)*scpx(i, j) & + /sqrt(g*depths(i, j)*L_mks2cgs*( scpx(i, j)*scpx(i, j) & + scpy(i, j)*scpy(i, j)))) enddo enddo diff --git a/phy/rdlim.F b/phy/rdlim.F index e45667f0..1db45a3e 100644 --- a/phy/rdlim.F +++ b/phy/rdlim.F @@ -25,6 +25,7 @@ subroutine rdlim c --- ------------------------------------------------------------------ c use mod_config, only: expcnf, runid, inst_suffix + use mod_constants, only: epsilt use mod_calendar, only: date_type, daynum_diff, calendar_errstr, . calendar_noerr, operator(==), operator(<), . operator(/=) @@ -726,7 +727,7 @@ subroutine rdlim c c --- - verify integer number of baroclinic time steps per coupling c --- - interval - if (mod(ocn_cpl_dt_cesm+epsil,baclin).gt.2.*epsil) then + if (mod(ocn_cpl_dt_cesm+epsilt,baclin).gt.2.*epsilt) then if (mnproc.eq.1) then write (lp,*) 'rdlim: must have an integer number of '// . 'baroclinic time steps in a coupling' diff --git a/single_column/mod_single_column.F90 b/single_column/mod_single_column.F90 index 58eb6826..1071d155 100644 --- a/single_column/mod_single_column.F90 +++ b/single_column/mod_single_column.F90 @@ -24,6 +24,7 @@ module mod_single_column ! ---------------------------------------------------------------------- use mod_types, only: r8 + use mod_constants, only: L_mks2cgs use mod_xc use mod_vcoord, only: sigmar use mod_grid, only: qclon, qclat, pclon, pclat, uclon, uclat, vclon, vclat, & @@ -64,13 +65,13 @@ subroutine geoenv_single_column uclat = 0._r8 vclon = 0._r8 vclat = 0._r8 - scqx = 1100000.0_r8 - scqy = 1100000.0_r8 - scpx = 1100000.0_r8 - scpy = 1100000.0_r8 - scux = 1100000.0_r8 - scuy = 1100000.0_r8 - scvx = 1100000.0_r8 + scqx = 11000.0_r8*L_mks2cgs + scqy = 11000.0_r8*L_mks2cgs + scpx = 11000.0_r8*L_mks2cgs + scpy = 11000.0_r8*L_mks2cgs + scux = 11000.0_r8*L_mks2cgs + scuy = 11000.0_r8*L_mks2cgs + scvx = 11000.0_r8*L_mks2cgs scvy = scuy scq2 = scqx*scqy scp2 = scpx*scpy From b833500a8f9b143905e6d389c29277ff67f9bfeb Mon Sep 17 00:00:00 2001 From: Tomas Torsvik <43031053+TomasTorsvik@users.noreply.github.com> Date: Mon, 3 Oct 2022 13:41:18 +0200 Subject: [PATCH 191/366] Hamocc hybrid coord2 (#179) Make the surface mixed layer depth fractional index `hOBL` available for use in iHAMOCC, and adjust the internal iHAMOCC index `kmle` according to `hOBL`. Default value `kmle = 2` is retained for consistency with isopycnic coordinates. --- hamocc/beleg_vars.F90 | 10 ++--- hamocc/carchm.F90 | 11 +++-- hamocc/cyano.F90 | 87 ++++++++++++++++++--------------------- hamocc/mo_apply_rivin.F90 | 22 +++++----- hamocc/mo_intfcblom.F90 | 9 +++- hamocc/mo_vgrid.F90 | 19 +++++++-- hamocc/ocprod.F90 | 4 +- hamocc/preftrc.F90 | 38 ++++++++--------- phy/mod_difest.F | 10 ++++- 9 files changed, 112 insertions(+), 98 deletions(-) diff --git a/hamocc/beleg_vars.F90 b/hamocc/beleg_vars.F90 index 22cd8dc4..f7d68963 100644 --- a/hamocc/beleg_vars.F90 +++ b/hamocc/beleg_vars.F90 @@ -220,18 +220,16 @@ SUBROUTINE BELEG_VARS(kpaufr,kpie,kpje,kpke,kbnd,pddpo,prho,omask, & ! Initialise preformed tracers in the mixed layer; note that the ! whole field has been initialised to zero above - DO k=1,kmle DO j=1,kpje DO i=1,kpie IF(omask(i,j) .GT. 0.5) THEN - ocetra(i,j,k,iprefo2) =ocetra(i,j,k,ioxygen) - ocetra(i,j,k,iprefpo4)=ocetra(i,j,k,iphosph) - ocetra(i,j,k,iprefalk)=ocetra(i,j,k,ialkali) - ocetra(i,j,k,iprefdic)=ocetra(i,j,k,isco212) + ocetra(i,j,1:kmle(i,j),iprefo2) = ocetra(i,j,1:kmle(i,j),ioxygen) + ocetra(i,j,1:kmle(i,j),iprefpo4) = ocetra(i,j,1:kmle(i,j),iphosph) + ocetra(i,j,1:kmle(i,j),iprefalk) = ocetra(i,j,1:kmle(i,j),ialkali) + ocetra(i,j,1:kmle(i,j),iprefdic) = ocetra(i,j,1:kmle(i,j),isco212) ENDIF ENDDO ENDDO - ENDDO ! Initial values for sediment diff --git a/hamocc/carchm.F90 b/hamocc/carchm.F90 index d86013b8..bab04daf 100644 --- a/hamocc/carchm.F90 +++ b/hamocc/carchm.F90 @@ -96,11 +96,11 @@ SUBROUTINE CARCHM(kpie,kpje,kpke,kbnd, & !********************************************************************** use mo_carbch, only: atm,atmflx,co2fxd,co2fxu,co2star,co3,hi,keqb,kwco2sol,ocetra,omegaa,omegac,pco2d,satn2o,satoxy use mo_chemcon, only: al1,al2,al3,al4,an0,an1,an2,an3,an4,an5,an6,atn2o,bl1,bl2,bl3,calcon,ox0,ox1,ox2,ox3,ox4,ox5,ox6, & - & oxyco,tzero - use mo_control_bgc, only: dtbgc + & oxyco,tzero + use mo_control_bgc, only: dtbgc use mo_param1_bgc, only: ialkali,iatmo2,iatmco2,iatmdms,iatmn2,iatmn2o,ian2o,icalc,idicsat,idms,igasnit,ioxygen,iphosph, & - & isco212,isilica - use mo_vgrid, only: dp_min,kbo,ptiestu + & isco212,isilica + use mo_vgrid, only: dp_min,kmle,kbo,ptiestu #ifdef BROMO use mo_param1_bgc, only: iatmbromo,ibromo @@ -390,8 +390,7 @@ SUBROUTINE CARCHM(kpie,kpje,kpke,kbnd, & ta = ocetra(i,j,k,ialkali) / rrho CALL carchm_solve_DICsat(s,atco2*rpp0,ta,sit,pt,Kh,K1,K2,Kb,Kw,Ks1,Kf, & Ksi,K1p,K2p,K3p,tc_sat,niter) - ocetra(i,j,k, idicsat)=tc_sat * rrho ! convert mol/kg to kmol/m^3 - ocetra(i,j,k+1,idicsat)=tc_sat * rrho ! k+1 = the rest of the mixed layer + ocetra(i,j,1:kmle(i,j),idicsat) = tc_sat * rrho ! convert mol/kg to kmlo/m^3 #ifdef cisonew ! Ocean-Atmosphere fluxes for carbon isotopes diff --git a/hamocc/cyano.F90 b/hamocc/cyano.F90 index e39fa678..f3f696df 100644 --- a/hamocc/cyano.F90 +++ b/hamocc/cyano.F90 @@ -17,7 +17,7 @@ ! along with BLOM. If not, see https://www.gnu.org/licenses/. - SUBROUTINE CYANO(kpie,kpje,kpke,kbnd,pddpo,omask,ptho) +SUBROUTINE CYANO(kpie,kpje,kpke,kbnd,pddpo,omask,ptho) !********************************************************************** ! !**** *CYANO* - . @@ -61,74 +61,69 @@ SUBROUTINE CYANO(kpie,kpje,kpke,kbnd,pddpo,omask,ptho) ! . !********************************************************************** - use mo_carbch, only: ocetra - use mo_biomod, only: bluefix,intnfix,rnit,tf0,tf1,tf2,tff - use mo_param1_bgc, only: ialkali,iano3,igasnit,iphosph,ioxygen - use mo_vgrid, only: kmle + use mo_carbch, only: ocetra + use mo_biomod, only: bluefix,intnfix,rnit,tf0,tf1,tf2,tff + use mo_param1_bgc, only: ialkali,iano3,igasnit,iphosph,ioxygen + use mo_vgrid, only: kmle #ifdef natDIC - use mo_param1_bgc, only: inatalkali + use mo_param1_bgc, only: inatalkali #endif - implicit none + implicit none - INTEGER, intent(in) :: kpie,kpje,kpke,kbnd - REAL, intent(in) :: pddpo(kpie,kpje,kpke) - REAL, intent(in) :: omask(kpie,kpje) - REAL, intent(in) :: ptho(1-kbnd:kpie+kbnd,1-kbnd:kpje+kbnd,kpke) + INTEGER, intent(in) :: kpie,kpje,kpke,kbnd + REAL, intent(in) :: pddpo(kpie,kpje,kpke) + REAL, intent(in) :: omask(kpie,kpje) + REAL, intent(in) :: ptho(1-kbnd:kpie+kbnd,1-kbnd:kpje+kbnd,kpke) - ! Local variables - INTEGER :: i,j,k - REAL :: oldocetra,dano3 - REAL :: ttemp,nfixtfac + ! Local variables + INTEGER :: i,j,k + REAL :: oldocetra,dano3 + REAL :: ttemp,nfixtfac + + intnfix(:,:)=0.0 - intnfix(:,:)=0.0 - ! -! N-fixation by cyano bacteria (followed by remineralisation and nitrification), +! N-fixation by cyano bacteria (followed by remineralisation and nitrification), ! it is assumed here that this process is limited to the mixed layer ! - DO k=1,kmle -!$OMP PARALLEL DO PRIVATE(i,oldocetra,dano3,ttemp,nfixtfac) - DO j=1,kpje - DO i=1,kpie - IF(omask(i,j).gt.0.5) THEN - IF(ocetra(i,j,k,iano3).LT.(rnit*ocetra(i,j,k,iphosph))) THEN + DO j=1,kpje + DO i=1,kpie + IF(omask(i,j).gt.0.5) THEN + DO k=1,kmle(i,j) + IF(ocetra(i,j,k,iano3).LT.(rnit*ocetra(i,j,k,iphosph))) THEN - oldocetra = ocetra(i,j,k,iano3) - ttemp = min(40.,max(-3.,ptho(i,j,k))) + oldocetra = ocetra(i,j,k,iano3) + ttemp = min(40.,max(-3.,ptho(i,j,k))) ! Temperature dependence of nitrogen fixation, Kriest and Oschlies 2015. - nfixtfac = MAX(0.0,tf2*ttemp*ttemp + tf1*ttemp + tf0)/tff + nfixtfac = MAX(0.0,tf2*ttemp*ttemp + tf1*ttemp + tf0)/tff - ocetra(i,j,k,iano3)=ocetra(i,j,k,iano3)*(1-bluefix*nfixtfac) & - & +bluefix*nfixtfac*rnit*ocetra(i,j,k,iphosph) + ocetra(i,j,k,iano3)=ocetra(i,j,k,iano3)*(1-bluefix*nfixtfac) & + & + bluefix*nfixtfac*rnit*ocetra(i,j,k,iphosph) - dano3=ocetra(i,j,k,iano3)-oldocetra + dano3=ocetra(i,j,k,iano3)-oldocetra - ocetra(i,j,k,igasnit)=ocetra(i,j,k,igasnit)-dano3*(1./2.) + ocetra(i,j,k,igasnit)=ocetra(i,j,k,igasnit)-dano3*(1./2.) ! Note: to fix one mole N2 requires: N2+H2O+y*O2 = 2* HNO3 <-> y=2.5 mole O2. ! I.e., to release one mole HNO3 = H+ + NO3- requires 1.25 mole O2 - ocetra(i,j,k,ioxygen)=ocetra(i,j,k,ioxygen)-dano3*1.25 + ocetra(i,j,k,ioxygen)=ocetra(i,j,k,ioxygen)-dano3*1.25 ! Nitrogen fixation followed by remineralisation and nitrification decreases ! alkalinity by 1 mole per mole nitrogen fixed (Wolf-Gladrow et al. 2007) - ocetra(i,j,k,ialkali)=ocetra(i,j,k,ialkali)-dano3 + ocetra(i,j,k,ialkali)=ocetra(i,j,k,ialkali)-dano3 #ifdef natDIC - ocetra(i,j,k,inatalkali)=ocetra(i,j,k,inatalkali)-dano3 + ocetra(i,j,k,inatalkali)=ocetra(i,j,k,inatalkali)-dano3 #endif - intnfix(i,j) = intnfix(i,j) + & - & (ocetra(i,j,k,iano3)-oldocetra)*pddpo(i,j,k) - - ENDIF - ENDIF - ENDDO - ENDDO -!$OMP END PARALLEL DO - ENDDO - + intnfix(i,j) = intnfix(i,j) + & + & (ocetra(i,j,k,iano3)-oldocetra)*pddpo(i,j,k) + ENDIF + ENDDO + ENDIF + ENDDO + ENDDO - RETURN - END +END SUBROUTINE CYANO diff --git a/hamocc/mo_apply_rivin.F90 b/hamocc/mo_apply_rivin.F90 index 697990d1..0dfbc528 100644 --- a/hamocc/mo_apply_rivin.F90 +++ b/hamocc/mo_apply_rivin.F90 @@ -120,28 +120,28 @@ subroutine apply_rivin(kpie,kpje,kpke,pddpo,omask,rivin) ! Distribute riverine inputs over the model mixed layer volij = 0. - DO k=1,kmle + DO k=1,kmle(i,j) volij=volij+pddpo(i,j,k) ENDDO ! DIC is updated using the assumtions that a_t=a_c+a_n and DIC=a_c (a_t: total ! alkalinity, a_c: carbonate alkalinity, a_n: contribution of nutrients to a_t). - ocetra(i,j,1:kmle,iano3) = ocetra(i,j,1:kmle,iano3) + rivin(i,j,irdin)*fdt/volij - ocetra(i,j,1:kmle,iphosph) = ocetra(i,j,1:kmle,iphosph) + rivin(i,j,irdip)*fdt/volij - ocetra(i,j,1:kmle,isilica) = ocetra(i,j,1:kmle,isilica) + rivin(i,j,irsi) *fdt/volij - ocetra(i,j,1:kmle,isco212) = ocetra(i,j,1:kmle,isco212) + rivin(i,j,iralk)*fdt/volij & + ocetra(i,j,1:kmle(i,j),iano3) = ocetra(i,j,1:kmle(i,j),iano3) + rivin(i,j,irdin)*fdt/volij + ocetra(i,j,1:kmle(i,j),iphosph) = ocetra(i,j,1:kmle(i,j),iphosph) + rivin(i,j,irdip)*fdt/volij + ocetra(i,j,1:kmle(i,j),isilica) = ocetra(i,j,1:kmle(i,j),isilica) + rivin(i,j,irsi) *fdt/volij + ocetra(i,j,1:kmle(i,j),isco212) = ocetra(i,j,1:kmle(i,j),isco212) + rivin(i,j,iralk)*fdt/volij & + rivin(i,j,irdin)*fdt/volij & + rivin(i,j,irdip)*fdt/volij - ocetra(i,j,1:kmle,ialkali) = ocetra(i,j,1:kmle,ialkali) + rivin(i,j,iralk)*fdt/volij + ocetra(i,j,1:kmle(i,j),ialkali) = ocetra(i,j,1:kmle(i,j),ialkali) + rivin(i,j,iralk)*fdt/volij #ifdef natDIC - ocetra(i,j,1:kmle,inatsco212) = ocetra(i,j,1:kmle,inatsco212) + rivin(i,j,iralk)*fdt/volij & + ocetra(i,j,1:kmle(i,j),inatsco212) = ocetra(i,j,1:kmle(i,j),inatsco212) + rivin(i,j,iralk)*fdt/volij & + rivin(i,j,irdin)*fdt/volij & + rivin(i,j,irdip)*fdt/volij - ocetra(i,j,1:kmle,inatalkali) = ocetra(i,j,1:kmle,inatalkali) + rivin(i,j,iralk)*fdt/volij + ocetra(i,j,1:kmle(i,j),inatalkali) = ocetra(i,j,1:kmle(i,j),inatalkali) + rivin(i,j,iralk)*fdt/volij #endif - ocetra(i,j,1:kmle,iiron) = ocetra(i,j,1:kmle,iiron) + rivin(i,j,iriron)*fdt/volij*dFe_frac - ocetra(i,j,1:kmle,idoc) = ocetra(i,j,1:kmle,idoc) + rivin(i,j,irdoc)*fdt/volij - ocetra(i,j,1:kmle,idet) = ocetra(i,j,1:kmle,idet) + rivin(i,j,irdet)*fdt/volij + ocetra(i,j,1:kmle(i,j),iiron) = ocetra(i,j,1:kmle(i,j),iiron) + rivin(i,j,iriron)*fdt/volij*dFe_frac + ocetra(i,j,1:kmle(i,j),idoc) = ocetra(i,j,1:kmle(i,j),idoc) + rivin(i,j,irdoc)*fdt/volij + ocetra(i,j,1:kmle(i,j),idet) = ocetra(i,j,1:kmle(i,j),idet) + rivin(i,j,irdet)*fdt/volij rivinflx(i,j,irdin) = rivin(i,j,irdin)*fdt rivinflx(i,j,irdip) = rivin(i,j,irdip)*fdt diff --git a/hamocc/mo_intfcblom.F90 b/hamocc/mo_intfcblom.F90 index 68227f7b..e0d78b3b 100644 --- a/hamocc/mo_intfcblom.F90 +++ b/hamocc/mo_intfcblom.F90 @@ -244,14 +244,16 @@ subroutine blom2hamocc(m,n,mm,nn) !****************************************************************************** ! use mod_constants, only: onem - use mod_xc, only: ii,jdm,jj,kdm,kk,ifp,isp,ilp,idm + use mod_xc, only: ii,jdm,jj,kdm,kk,ifp,isp,ilp,idm use mod_grid, only: scpx,scpy use mod_state, only: dp,temp,saln use mod_eos, only: rho,p_alpha + use mod_difest, only: hOBL use mod_tracers, only: ntrbgc,itrbgc,trc use mo_param1_bgc, only: ks,nsedtra,npowtra,natm use mo_carbch, only: ocetra,atm use mo_sedmnt, only: sedlay,powtra,sedhpl,burial + use mo_vgrid, only: kmle, kmle_static implicit none @@ -292,6 +294,11 @@ subroutine blom2hamocc(m,n,mm,nn) ! --- - dimension of grid box in meters bgc_dx(i,j) = scpx(i,j)/1.e2 bgc_dy(i,j) = scpy(i,j)/1.e2 +! +! --- - index of level above OBL depth +! --- isopycninc coords: hOBL(i,j) = hOBL_static = 3. => kmle(i,j) = 2 +! --- hybrid coords: hOBL defined according to cvmix_kpp_compute_kOBL_depth + kmle(i,j) = nint(hOBL(i,j))-1 enddo enddo !$OMP END PARALLEL DO diff --git a/hamocc/mo_vgrid.F90 b/hamocc/mo_vgrid.F90 index 0f7cc08b..e010e92e 100644 --- a/hamocc/mo_vgrid.F90 +++ b/hamocc/mo_vgrid.F90 @@ -53,16 +53,18 @@ module mo_vgrid !****************************************************************************** implicit none - INTEGER, PARAMETER :: kmle = 2 ! k-end index for layers that - ! represent the mixed layer in BLOM + INTEGER, PARAMETER :: kmle_static = 2 ! k-end index for layers that + ! represent the mixed layer in BLOM. + ! Default value used for isopycnic coordinates. REAL, PARAMETER :: dp_ez = 100.0 ! depth of euphotic zone - REAL, PARAMETER :: dp_min = 1.0E-12 ! min layer thickness layers thinner + REAL, PARAMETER :: dp_min = 1.0E-12 ! min layer thickness layers thinner ! than this are ignored by HAMOCC REAL, PARAMETER :: dp_min_sink = 1.0 ! min layer thickness for sinking (layers thinner than ! this are ignored and set to the concentration of the ! layer above). Note that the bottom layer index kbo(i,j) ! is defined as the lowermost layer thicker than dp_min_sink. + INTEGER, DIMENSION(:,:), ALLOCATABLE :: kmle INTEGER, DIMENSION(:,:), ALLOCATABLE :: kbo INTEGER, DIMENSION(:,:), ALLOCATABLE :: kwrbioz INTEGER, DIMENSION(:,:), ALLOCATABLE :: k0100,k0500,k1000,k2000,k4000 @@ -263,6 +265,17 @@ subroutine alloc_mem_vgrid(kpie,kpje,kpke) ptiestw(:,:,:) = 0.0 + IF(mnproc.eq.1) THEN + WRITE(io_stdo_bgc,*)'Memory allocation for variable kmle ...' + WRITE(io_stdo_bgc,*)'First dimension : ',kpie + WRITE(io_stdo_bgc,*)'Second dimension : ',kpje + ENDIF + + ALLOCATE(kmle(kpie,kpje),stat=errstat) + if(errstat.ne.0) stop 'not enough memory kmle' + kmle(:,:) = kmle_static + + IF(mnproc.eq.1) THEN WRITE(io_stdo_bgc,*)'Memory allocation for variable kbo ...' WRITE(io_stdo_bgc,*)'First dimension : ',kpie diff --git a/hamocc/ocprod.F90 b/hamocc/ocprod.F90 index 2677b483..d98bc43c 100644 --- a/hamocc/ocprod.F90 +++ b/hamocc/ocprod.F90 @@ -938,7 +938,7 @@ subroutine ocprod(kpie,kpje,kpke,kbnd,pdlxp,pdlyp,pddpo,omask,ptho,pi_ph) ! Set minimum particle number to nmldmin in the mixed layer. This is to prevent ! very small values of nos (and asscociated high sinking speed if there is mass) ! in high latitudes during winter - if ( k <= kmle ) then + if ( k <= kmle(i,j) ) then ocetra(i,j,k,inos) = MAX(nmldmin,ocetra(i,j,k,inos)) endif @@ -974,7 +974,7 @@ subroutine ocprod(kpie,kpje,kpke,kbnd,pdlxp,pdlyp,pddpo,omask,ptho,pi_ph) ! As a first step, assume that shear in the mixed layer is high and ! zero below. - if ( k <= kmle ) then + if ( k <= kmle(i,j) ) then fshear = fsh else fshear = 0. diff --git a/hamocc/preftrc.F90 b/hamocc/preftrc.F90 index 34a9161c..a33280d1 100644 --- a/hamocc/preftrc.F90 +++ b/hamocc/preftrc.F90 @@ -16,7 +16,7 @@ ! along with BLOM. If not, see https://www.gnu.org/licenses/. - SUBROUTINE PREFTRC(kpie,kpje,omask) +SUBROUTINE PREFTRC(kpie,kpje,omask) !**************************************************************** ! !**** *PREFTRC* - update preformed tracers in the mixed layer. @@ -43,31 +43,27 @@ SUBROUTINE PREFTRC(kpie,kpje,omask) ! !************************************************************************** - use mo_carbch, only: ocetra - use mo_param1_bgc, only: ialkali,ioxygen,iphosph,iprefalk,iprefdic,iprefo2,iprefpo4,isco212 - use mo_vgrid, only: kmle + use mo_carbch, only: ocetra + use mo_param1_bgc, only: ialkali,ioxygen,iphosph,iprefalk,iprefdic,iprefo2,iprefpo4,isco212 + use mo_vgrid, only: kmle - implicit none + implicit none - INTEGER :: kpie,kpje - REAL :: omask(kpie,kpje) + INTEGER :: kpie,kpje + REAL :: omask(kpie,kpje) - INTEGER :: i,j,k + INTEGER :: i,j - do k=1,kmle -!$OMP PARALLEL DO PRIVATE(i) - do j=1,kpje - do i=1,kpie + do j=1,kpje + do i=1,kpie if (omask(i,j) .gt. 0.5 ) then - ocetra(i,j,k,iprefo2) =ocetra(i,j,k,ioxygen) - ocetra(i,j,k,iprefpo4)=ocetra(i,j,k,iphosph) - ocetra(i,j,k,iprefalk)=ocetra(i,j,k,ialkali) - ocetra(i,j,k,iprefdic)=ocetra(i,j,k,isco212) + ocetra(i,j,1:kmle(i,j),iprefo2) = ocetra(i,j,1:kmle(i,j),ioxygen) + ocetra(i,j,1:kmle(i,j),iprefpo4) = ocetra(i,j,1:kmle(i,j),iphosph) + ocetra(i,j,1:kmle(i,j),iprefalk) = ocetra(i,j,1:kmle(i,j),ialkali) + ocetra(i,j,1:kmle(i,j),iprefdic) = ocetra(i,j,1:kmle(i,j),isco212) endif - enddo - enddo -!$OMP END PARALLEL DO - enddo + enddo + enddo - END SUBROUTINE PREFTRC +END SUBROUTINE PREFTRC diff --git a/phy/mod_difest.F b/phy/mod_difest.F index 2d2dde96..5bd4b2b9 100644 --- a/phy/mod_difest.F +++ b/phy/mod_difest.F @@ -78,6 +78,10 @@ module mod_difest implicit none c private +c +c Initialize hOBL with hOBL_static = 3. for consistency with bulk +c mixed layer formulation in iHAMOCC: kmle = nint(hOBL) - 1 = 2 + real, PARAMETER :: hOBL_static = 3. c real, dimension(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy,kdm+1) :: . rig @@ -85,6 +89,8 @@ module mod_difest . du2l,drhol,up,vp real, dimension(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy) :: . OBLdepth + real, dimension(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy) :: + . hOBL integer, dimension(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy,kdm) :: . mskv,msku integer, dimension(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy) :: @@ -174,7 +180,7 @@ module mod_difest . cs=98.96,minOBLdepth=1.0) c public :: OBLdepth, inivar_difest, init_difest, difest_isobml, - . difest_lateral_hybrid, difest_vertical_hybrid + . difest_lateral_hybrid, difest_vertical_hybrid, hOBL c contains c @@ -203,6 +209,7 @@ subroutine inivar_difest enddo do i=1-nbdy,ii+nbdy OBLdepth(i,j)=spval + hOBL(i,j) = hOBL_static enddo enddo c$OMP END PARALLEL DO @@ -904,7 +911,6 @@ subroutine difest_vertical_hyb(m,n,mm,nn,k1m,k1n) real :: Simmons_coeff, zBottomMinusOffset real :: bl1, bl2, bl3, bl4 integer ki, ksfc, ktmp, kOBL, kn1 - real, dimension(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy) :: hOBL c surf_layer_ext = 0.1 bl1 = 8e-5 From 07e3ae3aaeedbd3d9d193a0a47965ff16258c81b Mon Sep 17 00:00:00 2001 From: Mehmet Ilicak Date: Mon, 10 Oct 2022 10:13:47 +0200 Subject: [PATCH 192/366] BLOM CIME cpp updates to run in NorESM --- cime_config/buildcpp | 10 ++++++++++ cime_config/config_component.xml | 9 +++++++++ 2 files changed, 19 insertions(+) diff --git a/cime_config/buildcpp b/cime_config/buildcpp index e237d1a4..39a6a280 100644 --- a/cime_config/buildcpp +++ b/cime_config/buildcpp @@ -87,6 +87,7 @@ def buildcpp(case): hamocc_sedbypass = case.get_value("HAMOCC_SEDBYPASS") hamocc_ciso = case.get_value("HAMOCC_CISO") hamocc_vsls = case.get_value("HAMOCC_VSLS") + cgsmks = case.get_value("BLOM_UNIT") expect(blom_vcoord != "cntiso_hybrid" or not turbclo, "BLOM_VCOORD == {} and BLOM_TURBULENT_CLOSURE == {} is not a valid combination".format(blom_vcoord, turbclo)) @@ -146,6 +147,15 @@ def buildcpp(case): else: expect(False, "tracer module {} is not recognized".format(module)) + if cgsmks: + for option in cgsmks.split(): + if option == "cgs": + blom_cppdefs = blom_cppdefs + " -DCGS" + elif option == "mks": + blom_cppdefs = blom_cppdefs + " -DMKS" + else: + expect(False, "SI_UNIT module {} is not recognized".format(option)) + blom_cppdefs = "-DMPI" + blom_cppdefs # update the xml variable BLOM_CPPDEFS with the above definition diff --git a/cime_config/config_component.xml b/cime_config/config_component.xml index a77e658c..25448c0e 100644 --- a/cime_config/config_component.xml +++ b/cime_config/config_component.xml @@ -218,6 +218,15 @@ Optional turbulent closure. Valid values one of: twoeq oneeq. Additional values: advection isodif + + char + + cgs + build_component_blom + env_build.xml + BLOM UNIT values. Valid values one of: cgs mks. + + BLOM default: BLOM/Ecosystem: From 64478860425019574dd926e14d6416754824567c Mon Sep 17 00:00:00 2001 From: Mehmet Ilicak Date: Mon, 10 Oct 2022 17:58:19 +0200 Subject: [PATCH 193/366] bug fixes for the CGS MKS conversion --- phy/diapfl.F | 16 +--------------- phy/diffus.F | 9 +++------ 2 files changed, 4 insertions(+), 21 deletions(-) diff --git a/phy/diapfl.F b/phy/diapfl.F index 39505890..b228fd35 100644 --- a/phy/diapfl.F +++ b/phy/diapfl.F @@ -82,7 +82,6 @@ subroutine diapfl(m,n,mm,nn,k1m,k1n) logical done,dwnwrd,remfmx c real, dimension(kdm) :: ttem0,ssal0,delp0,dens0,sigr0,nu0 - real, dimension(kdm) :: rnd integer niter #ifdef TRC real, dimension(ntr,kdm) :: ttrc @@ -130,11 +129,6 @@ subroutine diapfl(m,n,mm,nn,k1m,k1n) enddo #endif enddo - if (mnproc.eq.ptest.and.i.eq.itest.and.j.eq.jtest) then - print*,'mehmet',ttem,ssal - print*,'mehmetniter',niter - print*,'mehmetdifdia',nu - endif c c --- --- Locate range of physical layers. kfpl=kfpla(i,j,n) @@ -205,8 +199,6 @@ subroutine diapfl(m,n,mm,nn,k1m,k1n) . *exp(-(delp(k+1)+.5*delp(k))*abs(coriop(i,j)) . *alpha0/(kappa*max(ustmin,ustarb(i,j))*g)) . /(alpha0*g*(sigr(k+1)-sigr(k))) - !Mehmet - ! nubbl = 0.001*L_mks2cgs**2 nu(k)=max(nu(k),nubbl) difdia(i,j,k)=nu(k) endif @@ -656,12 +648,10 @@ subroutine diapfl(m,n,mm,nn,k1m,k1n) enddo endif c - call random_number(rnd) c --- --- Copy 1d arrays to 3d arrays do k=1,kk kn=k+nn - !Mehmet - temp(i,j,kn)=ttem(k)!+(2e-11*(1.0-rnd(k)) - 1e-11) + temp(i,j,kn)=ttem(k) saln(i,j,kn)=ssal(k) dp(i,j,kn)=delp(k) sigma(i,j,kn)=dens(k) @@ -684,10 +674,6 @@ subroutine diapfl(m,n,mm,nn,k1m,k1n) enddo #endif enddo - if (mnproc.eq.ptest.and.i.eq.itest.and.j.eq.jtest) then - print*,'mehmetend',ttem,ssal - print*,'mehmetendniter',niter - endif c c --- --- Save variables used for momentum mixing kming(i,j)=kmin diff --git a/phy/diffus.F b/phy/diffus.F index 39e93bce..7b0321e2 100644 --- a/phy/diffus.F +++ b/phy/diffus.F @@ -76,8 +76,6 @@ subroutine diffus(m,n,mm,nn,k1m,k1n) #endif call xctilr(difiso, 1,kk, 2,2, halo_ps) endif - ! Mehmet - difiso(:,:,:) = 300.0 c do k=1,kk kn=k+nn @@ -92,7 +90,7 @@ subroutine diffus(m,n,mm,nn,k1m,k1n) do l=1,isu(j) do i=max(0,ifu(j,l)),min(ii+2,ilu(j,l)) q=delt1*.5*(difiso(i-1,j,k)+difiso(i,j,k)) -c . *scuy(i,j)*scuxi(i,j) + . *scuy(i,j)*scuxi(i,j) . *max(min(dp(i-1,j,kn),dp(i,j,kn)),dpeps) usflld(i,j,km)=q*(saln(i-1,j,kn)-saln(i,j,kn)) utflld(i,j,km)=q*(temp(i-1,j,kn)-temp(i,j,kn)) @@ -119,7 +117,7 @@ subroutine diffus(m,n,mm,nn,k1m,k1n) do l=1,isv(j) do i=max(0,ifv(j,l)),min(ii+1,ilv(j,l)) q=delt1*.5*(difiso(i,j-1,k)+difiso(i,j,k)) -c . *scvx(i,j)*scvyi(i,j) + . *scvx(i,j)*scvyi(i,j) . *max(min(dp(i,j-1,kn),dp(i,j,kn)),dpeps) vsflld(i,j,km)=q*(saln(i,j-1,kn)-saln(i,j,kn)) vtflld(i,j,km)=q*(temp(i,j-1,kn)-temp(i,j,kn)) @@ -145,8 +143,7 @@ subroutine diffus(m,n,mm,nn,k1m,k1n) do j=0,jj+1 do l=1,isp(j) do i=max(0,ifp(j,l)),min(ii+1,ilp(j,l)) - q=1./(max(dp(i,j,kn),dpeps)) -c q=1./(scp2(i,j)*max(dp(i,j,kn),dpeps)) + q=1./(scp2(i,j)*max(dp(i,j,kn),dpeps)) saln(i,j,kn)=saln(i,j,kn) . -q*(usflld(i+1,j,km)-usflld(i,j,km) . +vsflld(i,j+1,km)-vsflld(i,j,km)) From 31e8577b7645518c99dd580c71c62664f6230209 Mon Sep 17 00:00:00 2001 From: Mehmet Ilicak Date: Mon, 10 Oct 2022 19:56:13 +0200 Subject: [PATCH 194/366] cesm thermal forcing bug fixes for reproducibility --- cesm/thermf_cesm.F | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/cesm/thermf_cesm.F b/cesm/thermf_cesm.F index ce140d90..8a80ce8e 100644 --- a/cesm/thermf_cesm.F +++ b/cesm/thermf_cesm.F @@ -155,10 +155,10 @@ subroutine thermf_cesm(m,n,mm,nn,k1m,k1n) c --- --- due to the leap-frog time stepping. The melting potential uses c --- --- time averaged quantities since it is not accumulated. frzpot(i,j)=max(0.,tice_f-totl)*spcifh*dpotl - . /(2.*g)*L_mks2cgs*L_mks2cgs + . /(2.*g)*(L_mks2cgs**2) mltpot(i,j)= . min(0.,tfrzm(i,j)-.5*(temp(i,j,k1m)+temp(i,j,k1n))) - . *spcifh*.5*(dp(i,j,k1m)+dp(i,j,k1n))/g*L_mks2cgs*L_mks2cgs + . *spcifh*.5*(dp(i,j,k1m)+dp(i,j,k1n))/g*(L_mks2cgs**2) c c --- --- Heat flux due to melting/freezing [W m-2] (positive downwards) hmltfz(i,j)=hmlt(i,j)+frzpot(i,j)/baclin From fc2f09b31eefad9fac765dbb75f8917a050b8f91 Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Fri, 14 Oct 2022 16:02:38 +0200 Subject: [PATCH 195/366] move from Goreau O2-half saturation constant to more recent measured half saturation constant for NO2 prod --- hamocc/mo_extNbioproc.F90 | 4 ++-- hamocc/mo_extNsediment.F90 | 4 ++-- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/hamocc/mo_extNbioproc.F90 b/hamocc/mo_extNbioproc.F90 index c238bf53..d654453b 100644 --- a/hamocc/mo_extNbioproc.F90 +++ b/hamocc/mo_extNbioproc.F90 @@ -180,7 +180,7 @@ subroutine extNbioparam_init() bn2o = 0.077/(50.*mufn2o) !=0.2331 - before set to 0.3 - base fraction entering N2O !====== !bkamoxno2 = 0.479e-6 ! Half saturation constant for pathway splitting function N2O for nitrification on NH4 (kmol/m3) - bkamoxno2 = 0.1e-6 ! Half saturation constant for pathway splitting function N2O for nitrification on NH4 (kmol/m3) +! bkamoxno2 = 0.1e-6 ! Half saturation constant for pathway splitting function N2O for nitrification on NH4 (kmol/m3) n2omaxy = 0.003 ! Maximum yield of OM on NH4 nitrification (-) n2oybeta = 18. ! Decay factor for inhibition function for yield during nitrification on NH4 (kmol/m3) bkyamox = 0.333e-6 ! Half saturation constant for pathway splitting function OM-yield for nitrification on NH4 (kmol/m3) @@ -268,7 +268,7 @@ subroutine nitrification(kpie,kpje,kpke,kbnd,pddpo,omask,ptho) fn2o = mufn2o * (bn2o + (1.-bn2o)*bkoxamox/(ocetra(i,j,k,ioxygen)+bkoxamox)) & & * ocetra(i,j,k,ianh4)/(ocetra(i,j,k,ianh4)+bkamoxn2o) !===== - fno2 = ocetra(i,j,k,ioxygen)/(ocetra(i,j,k,ioxygen) + bkamoxno2) + fno2 = ocetra(i,j,k,ioxygen)/(ocetra(i,j,k,ioxygen) + bkoxamox) fdetamox = n2omaxy*2.*(1. + n2oybeta)*ocetra(i,j,k,ioxygen)*bkyamox & & /(ocetra(i,j,k,ioxygen)**2 + 2.*ocetra(i,j,k,ioxygen)*bkyamox + bkyamox**2) diff --git a/hamocc/mo_extNsediment.F90 b/hamocc/mo_extNsediment.F90 index 81d4bd30..a1939b42 100644 --- a/hamocc/mo_extNsediment.F90 +++ b/hamocc/mo_extNsediment.F90 @@ -192,7 +192,7 @@ subroutine extNsediment_param_init() bn2o_sed = 0.077/(50.*mufn2o_sed) !=0.2331 - before set to 0.3 - base fraction entering N2O !====== !bkamoxno2_sed = 0.479e-6 ! Half saturation constant for pathway splitting function N2O for nitrification on NH4 (kmol/m3) - bkamoxno2_sed = bkamoxno2 ! Half saturation constant for pathway splitting function N2O for nitrification on NH4 (kmol/m3) + ! bkamoxno2_sed = bkamoxno2 ! Half saturation constant for pathway splitting function N2O for nitrification on NH4 (kmol/m3) n2omaxy_sed = n2omaxy ! Maximum yield of OM on NH4 nitrification (-) n2oybeta_sed = n2oybeta ! Decay factor for inhibition function for yield during nitrification on NH4 (kmol/m3) bkyamox_sed = bkyamox ! Half saturation constant for pathway splitting function OM-yield for nitrification on NH4 (kmol/m3) @@ -253,7 +253,7 @@ subroutine sed_nitrification(j,kpie,kpje,kpke,kbnd,ptho,omask,ex_ddic,ex_dalk) fn2o = mufn2o_sed * (bn2o_sed + (1.-bn2o_sed)*bkoxamox_sed/(powtra(i,j,k,ipowaox)+bkoxamox_sed)) & & * powtra(i,j,k,ipownh4)/(powtra(i,j,k,ipownh4)+bkamoxn2o_sed) !===== - fno2 = powtra(i,j,k,ipowaox)/(powtra(i,j,k,ipowaox) + bkamoxno2_sed) + fno2 = powtra(i,j,k,ipowaox)/(powtra(i,j,k,ipowaox) + bkoxamox_sed) fdetamox = n2omaxy_sed*2.*(1. + n2oybeta_sed)*powtra(i,j,k,ipowaox)*bkyamox_sed & & /(powtra(i,j,k,ipowaox)**2 + 2.*powtra(i,j,k,ipowaox)*bkyamox_sed + bkyamox_sed**2) From e3950e6181ca2e20c3cc131f22da4910304d0335 Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Fri, 14 Oct 2022 16:41:53 +0200 Subject: [PATCH 196/366] Fix new O2-half saturation constant dependency --- hamocc/mo_extNbioproc.F90 | 8 ++++---- hamocc/mo_extNsediment.F90 | 6 +++--- 2 files changed, 7 insertions(+), 7 deletions(-) diff --git a/hamocc/mo_extNbioproc.F90 b/hamocc/mo_extNbioproc.F90 index d654453b..be34dd0c 100644 --- a/hamocc/mo_extNbioproc.F90 +++ b/hamocc/mo_extNbioproc.F90 @@ -78,7 +78,7 @@ MODULE mo_extNbioproc & rano2denit,q10ano2denit,Trefano2denit,bkoxano2denit,bkano2denit, & & ran2odenit,q10an2odenit,Trefan2odenit,bkoxan2odenit,bkan2odenit, & & rdnra,q10dnra,Trefdnra,bkoxdnra,bkdnra,ranh4nitr,q10anh4nitr, & - & Trefanh4nitr,bkoxamox,bkanh4nitr,bkamoxn2o,bkamoxno2,bkyamox, & + & Trefanh4nitr,bkoxamox,bkanh4nitr,bkamoxn2o,bkyamox, & & rano2nitr,q10ano2nitr,Trefano2nitr,bkoxnitr,bkano2nitr,n2omaxy, & & n2oybeta,NOB2AOAy,bn2o,mufn2o, & & rc2n,ro2nnit,rnoxp,rnoxpi,rno2anmx,rno2anmxi,rnh4anmx, & @@ -90,9 +90,9 @@ MODULE mo_extNbioproc & rano2denit,q10ano2denit,Trefano2denit,bkoxano2denit,bkano2denit, & & ran2odenit,q10an2odenit,Trefan2odenit,bkoxan2odenit,bkan2odenit, & & rdnra,q10dnra,Trefdnra,bkoxdnra,bkdnra,ranh4nitr,q10anh4nitr, & - & Trefanh4nitr,bkoxamox,bkanh4nitr,bkamoxn2o,bkamoxno2,bkyamox, & + & Trefanh4nitr,bkoxamox,bkanh4nitr,bkamoxn2o,bkyamox, & & rano2nitr,q10ano2nitr,Trefano2nitr,bkoxnitr,bkano2nitr,n2omaxy, & - & n2oybeta,bkphyanh4,bkphyano3,bkphosph,bkiron,NOB2AOAy,bn2o,mufn2o + & n2oybeta,bkphyanh4,bkphyano3,bkphosph,bkiron,NOB2AOAy,bn2o,mufn2o!,bkamoxno2, real :: rc2n,ro2utammo,ro2nnit,rnoxp,rnoxpi,rno2anmx,rno2anmxi,rnh4anmx, & & rnh4anmxi,rno2dnra,rno2dnrai,rnh4dnra,rnh4dnrai,rnm1 @@ -297,7 +297,7 @@ subroutine nitrification(kpie,kpje,kpke,kbnd,pddpo,omask,ptho) no2fn2o = mufn2o * (bn2o + (1.-bn2o)*bkoxamox/(ocetra(i,j,k,ioxygen)+bkoxamox)) & & * ocetra(i,j,k,ianh4)/(ocetra(i,j,k,ianh4)+bkamoxn2o) !===== - no2fno2 = ocetra(i,j,k,ioxygen)/(ocetra(i,j,k,ioxygen) + bkamoxno2) + no2fno2 = ocetra(i,j,k,ioxygen)/(ocetra(i,j,k,ioxygen) + bkoxamox) no2fdetamox = NOB2AOAy*n2omaxy*2.*(1. + n2oybeta)*ocetra(i,j,k,ioxygen)*bkyamox & & /(ocetra(i,j,k,ioxygen)**2 + 2.*ocetra(i,j,k,ioxygen)*bkyamox + bkyamox**2) diff --git a/hamocc/mo_extNsediment.F90 b/hamocc/mo_extNsediment.F90 index a1939b42..8e358254 100644 --- a/hamocc/mo_extNsediment.F90 +++ b/hamocc/mo_extNsediment.F90 @@ -68,7 +68,7 @@ MODULE mo_extNsediment & rano2denit_sed,q10ano2denit_sed,Trefano2denit_sed,bkoxano2denit_sed,bkano2denit_sed, & & ran2odenit_sed,q10an2odenit_sed,Trefan2odenit_sed,bkoxan2odenit_sed,bkan2odenit_sed, & & rdnra_sed,q10dnra_sed,Trefdnra_sed,bkoxdnra_sed,bkdnra_sed,ranh4nitr_sed,q10anh4nitr_sed, & - & Trefanh4nitr_sed,bkoxamox_sed,bkanh4nitr_sed,bkamoxn2o_sed,bkamoxno2_sed,bkyamox_sed, & + & Trefanh4nitr_sed,bkoxamox_sed,bkanh4nitr_sed,bkamoxn2o_sed,bkyamox_sed, & & rano2nitr_sed,q10ano2nitr_sed,Trefano2nitr_sed,bkoxnitr_sed,bkano2nitr_sed,n2omaxy_sed, & & n2oybeta_sed,NOB2AOAy_sed,bn2o_sed,mufn2o_sed,POM_remin_q10_sed, POM_remin_Tref_sed,bkox_drempoc_sed @@ -126,7 +126,7 @@ subroutine extNsediment_param_init() & q10ano2denit,Trefano2denit,bkoxano2denit,bkano2denit, & & q10an2odenit,Trefan2odenit,bkoxan2odenit,bkan2odenit, & & q10dnra,Trefdnra,bkoxdnra,bkdnra, & - & q10anh4nitr,Trefanh4nitr,bkoxamox,bkanh4nitr,bkamoxn2o,bkamoxno2,bkyamox,n2omaxy,n2oybeta, & + & q10anh4nitr,Trefanh4nitr,bkoxamox,bkanh4nitr,bkamoxn2o,bkyamox,n2omaxy,n2oybeta, & & q10ano2nitr,Trefano2nitr,bkoxnitr,bkano2nitr,NOB2AOAy,rno2anmx,rnh4anmx use mo_m4ago, only: POM_remin_q10,POM_remin_Tref use mo_biomod, only: bkox_drempoc @@ -278,7 +278,7 @@ subroutine sed_nitrification(j,kpie,kpje,kpke,kbnd,ptho,omask,ex_ddic,ex_dalk) no2fn2o = mufn2o_sed * (bn2o_sed + (1.-bn2o_sed)*bkoxamox_sed/(powtra(i,j,k,ipowaox)+bkoxamox_sed)) & & * powtra(i,j,k,ipownh4)/(powtra(i,j,k,ipownh4)+bkamoxn2o_sed) - no2fno2 = powtra(i,j,k,ipowaox)/(powtra(i,j,k,ipowaox) + bkamoxno2_sed) + no2fno2 = powtra(i,j,k,ipowaox)/(powtra(i,j,k,ipowaox) + bkoxamox_sed) no2fdetamox = NOB2AOAy_sed*n2omaxy_sed*2.*(1. + n2oybeta_sed)*powtra(i,j,k,ipowaox)*bkyamox_sed & & /(powtra(i,j,k,ipowaox)**2 + 2.*powtra(i,j,k,ipowaox)*bkyamox_sed + bkyamox_sed**2) From c927e3cdeb0784b94e56ed8450571d91e32c049b Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Sun, 16 Oct 2022 16:33:45 +0200 Subject: [PATCH 197/366] FIX 2D srf fields output extNcycle --- hamocc/ncout_hamocc.F90 | 11 ++++++++++- 1 file changed, 10 insertions(+), 1 deletion(-) diff --git a/hamocc/ncout_hamocc.F90 b/hamocc/ncout_hamocc.F90 index 577da9e7..39fb0afe 100644 --- a/hamocc/ncout_hamocc.F90 +++ b/hamocc/ncout_hamocc.F90 @@ -1322,7 +1322,16 @@ subroutine ncwrt_bgc(iogrp) call inisrf(jatmc13(iogrp),0.) call inisrf(jatmc14(iogrp),0.) #endif - +#ifdef extNcycle + call inisrf(jsrfanh4(iogrp),0.) + call inisrf(jsrfano2(iogrp),0.) + call inisrf(janh3fx(iogrp),0.) +#endif +#if defined(extNcycle) && ! defined(sedbypass) + call inisrf(jsediffnh4(iogrp),0.) + call inisrf(jsediffn2o(iogrp),0.) + call inisrf(jsediffno2(iogrp),0.) +#endif call inilyr(jdp(iogrp),0.) call inilyr(jdic(iogrp),0.) call inilyr(jalkali(iogrp),0.) From edef04fc50d171a7fd96c11c3535a44913e46089 Mon Sep 17 00:00:00 2001 From: Mehmet Ilicak Date: Mon, 17 Oct 2022 08:29:15 +0200 Subject: [PATCH 198/366] BLOM MKS update to export winds into the CESM using proper units. --- drivers/cpl_mct/export_mct.F | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/drivers/cpl_mct/export_mct.F b/drivers/cpl_mct/export_mct.F index d5ca668e..cff6c4c2 100644 --- a/drivers/cpl_mct/export_mct.F +++ b/drivers/cpl_mct/export_mct.F @@ -23,6 +23,7 @@ subroutine export_mct(o2x_o, lsize, perm, jjcpl, nsend, sbuff, ! Uses modules use mct_mod + use mod_constants, only: L_mks2cgs use shr_const_mod, only: SHR_CONST_TKFRZ use mod_types, only: r8 use blom_cpl_indices @@ -47,8 +48,10 @@ subroutine export_mct(o2x_o, lsize, perm, jjcpl, nsend, sbuff, integer i, j, n real(r8) :: tfac, utmp, vtmp + real(r8) :: iL_mks2cgs tfac = 1._r8/tlast_coupled + iL_mks2cgs = 1._r8/L_mks2cgs ! ---------------------------------------------------------------- ! Interpolate onto scalar points, rotate, and pack surface @@ -73,9 +76,9 @@ subroutine export_mct(o2x_o, lsize, perm, jjcpl, nsend, sbuff, vtmp = .5_r8*( sbuff(i,j ,index_o2x_So_v) . + sbuff(i,j+1,index_o2x_So_v)) o2x_o%rattr(index_o2x_So_u,n) = - . (utmp*cosang(i,j) - vtmp*sinang(i,j))*tfac*1.e-2_r8 + . (utmp*cosang(i,j) - vtmp*sinang(i,j))*tfac*iL_mks2cgs o2x_o%rattr(index_o2x_So_v,n) = - . (utmp*sinang(i,j) + vtmp*cosang(i,j))*tfac*1.e-2_r8 + . (utmp*sinang(i,j) + vtmp*cosang(i,j))*tfac*iL_mks2cgs utmp = ( sbuff(i ,j,index_o2x_So_dhdx)*iu(i ,j) . + sbuff(i+1,j,index_o2x_So_dhdx)*iu(i+1,j)) . /max(1,iu(i,j) + iu(i+1,j)) From e64bc4976a7282c30fe7aae5097c07655d5e7ee5 Mon Sep 17 00:00:00 2001 From: Mehmet Ilicak Date: Mon, 17 Oct 2022 15:19:19 +0200 Subject: [PATCH 199/366] input values in ocn_in case is updated for mks setup --- cime_config/buildnml | 55 +++++++++++++++++++++++++++++++++----------- 1 file changed, 42 insertions(+), 13 deletions(-) diff --git a/cime_config/buildnml b/cime_config/buildnml index 0154e8a1..14300b1a 100755 --- a/cime_config/buildnml +++ b/cime_config/buildnml @@ -7,6 +7,7 @@ set CASEROOT = `./xmlquery CASEROOT --value` set OCN_GRID = `./xmlquery OCN_GRID --value` set BLOM_VCOORD = `./xmlquery BLOM_VCOORD --value` +set BLOM_UNIT = `./xmlquery BLOM_UNIT --value` set DIN_LOC_ROOT = `./xmlquery DIN_LOC_ROOT --value` set RUN_TYPE = `./xmlquery RUN_TYPE --value` set CONTINUE_RUN = `./xmlquery CONTINUE_RUN --value` @@ -74,20 +75,37 @@ set EXPCNF = "'cesm'" set RUNTYP = "'$RUN_TYPE'" set GRFILE = "'unset'" set ICFILE = "'unset'" -set PREF = 2000.e5 +if ($BLOM_UNIT == cgs) then + set PREF = 2000.e5 +else + set PREF = 2000.e4 +endif set BACLIN = 1800. set BATROP = 36. -set MDV2HI = 2. -set MDV2LO = .4 -set MDV4HI = 0. -set MDV4LO = 0. -set MDC2HI = 5000.e4 -set MDC2LO = 300.e4 +if ($BLOM_UNIT == cgs) then + set MDV2HI = 2. + set MDV2LO = .4 + set MDV4HI = 0. + set MDV4LO = 0. + set MDC2HI = 5000.e4 + set MDC2LO = 300.e4 +else + set MDV2HI = 0.02 + set MDV2LO = 0.004 + set MDV4HI = 0. + set MDV4LO = 0. + set MDC2HI = 5000.0 + set MDC2LO = 300.0 +endif set VSC2HI = .5 set VSC2LO = .5 set VSC4HI = 0. set VSC4LO = 0. -set CBAR = 5. +if ($BLOM_UNIT == cgs) then + set CBAR = 5. +else + set CBAR = 0.05 +endif set CB = .002 set CWBDTS = 5.e-5 set CWBDLS = 25. @@ -159,14 +177,25 @@ set EDWMTH = "'smooth'" set EDSPRS = .true. set EGC = 0.85 set EGGAM = 200. -set EGLSMN = 4000.e2 -set EGMNDF = 100.e4 -set EGMXDF = 1500.e4 +if ($BLOM_UNIT == cgs) then + set EGLSMN = 4000.e2 + set EGMNDF = 100.e4 + set EGMXDF = 1500.e4 +else + set EGLSMN = 4000.0 + set EGMNDF = 100.0 + set EGMXDF = 1500.0 +endif set EGIDFQ = 1. set RI0 = 1.2 set BDMTYP = 2 -set BDMC1 = 5.e-4 -set BDMC2 = .1 +if ($BLOM_UNIT == cgs) then + set BDMC1 = 5.e-4 + set BDMC2 = .1 +else + set BDMC1 = 5.e-8 + set BDMC2 = 1.e-5 +endif set TKEPF = .006 if ($BLOM_VCOORD == isopyc_bulkml) then set LTEDTP = "'layer'" From f94265c604bfeda8b851adff4b3ac0975992180c Mon Sep 17 00:00:00 2001 From: Mehmet Ilicak Date: Fri, 21 Oct 2022 17:00:01 +0200 Subject: [PATCH 200/366] default cgsmks value changed --- meson_options.txt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/meson_options.txt b/meson_options.txt index abc274e5..e668730d 100644 --- a/meson_options.txt +++ b/meson_options.txt @@ -15,7 +15,7 @@ option('driver', type: 'combo', # List of BLOM options option('cgsmks', type: 'array', choices: ['cgs', 'mks'], - description: 'Enable CGS or MKS unit', value: ['mks']) + description: 'Enable CGS or MKS unit', value: ['cgs']) option('turbclo', type: 'array', choices: ['oneeq', 'twoeq', 'advection', 'isodif'], description: 'Turbulent closure options', value: ['oneeq', 'advection']) From ccc1d74d230917f7c950486393c1fa5b232bf8a5 Mon Sep 17 00:00:00 2001 From: Mats Bentsen Date: Fri, 4 Nov 2022 15:47:48 +0100 Subject: [PATCH 201/366] Initialize some variables in the k-epsilon model. --- phy/mod_tke.F90 | 15 ++++++++++++++- 1 file changed, 14 insertions(+), 1 deletion(-) diff --git a/phy/mod_tke.F90 b/phy/mod_tke.F90 index bd01ab90..adb82bd3 100644 --- a/phy/mod_tke.F90 +++ b/phy/mod_tke.F90 @@ -1,5 +1,5 @@ ! ------------------------------------------------------------------------------ -! Copyright (C) 2013-2020 Mehmet Ilicak, Mats Bentsen +! Copyright (C) 2013-2022 Mehmet Ilicak, Mats Bentsen ! ! This file is part of BLOM. ! @@ -24,6 +24,7 @@ module mod_tke ! ------------------------------------------------------------------------------ use mod_types, only: r8 + use mod_constants, only: spval use mod_xc use mod_diffusion, only: difdia use mod_forcing, only: ustarb @@ -103,6 +104,18 @@ subroutine initke ! Initialize fields holding turbulent kinetic energy, generic length ! scale, and other fields used in the turbulence closure. + !$omp parallel do private(i, k) + do j = 1 - nbdy, jj + nbdy + do i = 1 - nbdy, ii + nbdy + do k = 1, kk + Prod(i ,j ,k) = spval + Buoy(i ,j ,k) = spval + Shear2(i ,j ,k) = spval + L_scale(i ,j ,k) = spval + enddo + enddo + enddo + !$omp end parallel do !$omp parallel do private(k, l, i) do j = 1 - nbdy, jj + nbdy do k = 1, 2*kdm From bd03f1d8bcd4fe0dbfca62c23a0f75d2ace999b2 Mon Sep 17 00:00:00 2001 From: jmaerz <92309038+jmaerz@users.noreply.github.com> Date: Wed, 9 Nov 2022 21:46:15 +0100 Subject: [PATCH 202/366] Fix porosity read (#201) * Fixing the reading of variable porosity input field in preparation for the NorESM 2.0.6 release Cherry-picked from private Ncycleprivate branch 0d56930e2fdd62caba964d375b57304942568926 * Provide number of layers (3rd dim) via ks and not hard-coded * minor clean-up --- hamocc/mo_read_sedpor.F90 | 35 +++++++++++++++++++++++++++++------ 1 file changed, 29 insertions(+), 6 deletions(-) diff --git a/hamocc/mo_read_sedpor.F90 b/hamocc/mo_read_sedpor.F90 index 6ea984c6..8f51b0ca 100644 --- a/hamocc/mo_read_sedpor.F90 +++ b/hamocc/mo_read_sedpor.F90 @@ -51,9 +51,10 @@ module mo_read_sedpor subroutine read_sedpor(kpie,kpje,ks,omask,sed_por) use mod_xc, only: mnproc,xchalt - use mod_dia, only: iotype use mo_control_bgc, only: io_stdo_bgc,l_3Dvarsedpor - use mod_nctools, only: ncfopn,ncread,ncfcls + use netcdf, only: nf90_noerr,nf90_nowrite,nf90_close,nf90_open + + implicit none @@ -62,9 +63,10 @@ subroutine read_sedpor(kpie,kpje,ks,omask,sed_por) real, intent(inout) :: sed_por(kpie,kpje,ks) !local variables - integer :: i,j,k,errstat,dummymask(2) + integer :: i,j,k real :: sed_por_in(kpie,kpje,ks) logical :: file_exists = .false. + integer :: ncid,ncstat ! Return if l_3Dvarsedpor is turned off if (.not. l_3Dvarsedpor) then @@ -90,15 +92,36 @@ subroutine read_sedpor(kpie,kpje,ks,omask,sed_por) write(io_stdo_bgc,*) 'read_sedpor: read sediment porosity from ', & trim(sedporfile) endif - call ncfopn(trim(sedporfile),'r',' ',1,iotype) - call ncread('sedpor',sed_por_in,dummymask,0,0.) - call ncfcls + + ! Open netCDF data file + IF(mnproc==1) THEN + ncstat = NF90_OPEN(trim(sedporfile),NF90_NOWRITE, ncid) + IF (ncstat.NE.NF90_NOERR ) THEN + CALL xchalt('(read_sedpor: Problem with netCDF1)') + stop '(read_sedpor: Problem with netCDF1)' + END IF + END IF + + ! Read data + call read_netcdf_var(ncid,'sedpor',sed_por_in(1,1,1),ks,0,0) + + ! Close file + IF(mnproc==1) THEN + ncstat = NF90_CLOSE(ncid) + IF ( ncstat .NE. NF90_NOERR ) THEN + CALL xchalt('(read_sedpor: Problem with netCDF200)') + stop '(read_sedpor: Problem with netCDF200)' + END IF + END IF + do k=1,ks do j=1,kpje do i=1,kpie if(omask(i,j).gt. 0.5)then sed_por(i,j,k)=sed_por_in(i,j,k) + else + sed_por(i,j,k)=0. endif enddo enddo From 3f81ba9e7c74875d6dc40c6951a16f84a34f9fb4 Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Fri, 18 Nov 2022 18:52:59 +0100 Subject: [PATCH 203/366] Output for pN2O moist air; prepared for pNH3 output pNH3 moist air calculation in carchm missing --- cime_config/buildnml | 6 ++++++ hamocc/accfields.F90 | 10 +++++++--- hamocc/carchm.F90 | 12 +++++++++--- hamocc/mo_bgcmean.F90 | 10 +++++++++- hamocc/mo_carbch.F90 | 23 +++++++++++++++++++++++ hamocc/ncout_hamocc.F90 | 22 ++++++++++++++++------ 6 files changed, 70 insertions(+), 13 deletions(-) diff --git a/cime_config/buildnml b/cime_config/buildnml index 255beebb..5c05fbf0 100755 --- a/cime_config/buildnml +++ b/cime_config/buildnml @@ -432,7 +432,9 @@ set SRF_CO2FXD = '4, 2, 2' set SRF_CO2FXU = '4, 2, 2' set SRF_OXFLUX = '0, 2, 2' set SRF_NIFLUX = '0, 2, 2' +set SRF_PN2OM = '0, 2, 2' set SRF_N2OFX = '0, 0, 2' +set SRF_PNH3M = '0, 2, 2' set SRF_ANH3FX = '0, 0, 2' set SRF_DMSFLUX = '0, 2, 2' set SRF_DMS = '0, 2, 2' @@ -1695,7 +1697,9 @@ cat >>! $RUNDIR/ocn_in$inststr << EOF ! CO2FXU - Upward CO2 flux (co2fxu) [kg C m-2 s-1] ! NIFLUX - Nitrogen flux (fgn2) [mol N2 m-2 s-1] ! OXFLUX - Oxygen flux (fgo2) [mol O2 m-2 s-1] +! PN2OM - Surface pN2O under moist air [uatm] ! N2OFX - Nitrous oxide flux [mol N2O m-2 s-1] +! PNH3M - Surface pNH3 under moist air [uatm] ! ANH3FX - Ammonia flux [mol NH3 m-2 s-1] ! DMSFLUX - DMS flux (dmsflux) [mol DMS m-2 s-1] ! DMS - surface DMS concentration (dms) [mol DMS m-3] @@ -1799,7 +1803,9 @@ cat >>! $RUNDIR/ocn_in$inststr << EOF SRF_CO2FXU = $SRF_CO2FXU SRF_OXFLUX = $SRF_OXFLUX SRF_NIFLUX = $SRF_NIFLUX + SRF_PN2OM = $SRF_PN2OM SRF_N2OFX = $SRF_N2OFX + SRF_PNH3M = $SRF_PNH3M SRF_ANH3FX = $SRF_ANH3FX SRF_DMSFLUX = $SRF_DMSFLUX SRF_DMS = $SRF_DMS diff --git a/hamocc/accfields.F90 b/hamocc/accfields.F90 index a195d01f..3a73c588 100644 --- a/hamocc/accfields.F90 +++ b/hamocc/accfields.F90 @@ -46,7 +46,8 @@ SUBROUTINE ACCFIELDS(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask) !********************************************************************** use mod_xc, only: mnproc use mod_dia, only: ddm - use mo_carbch, only: atm,atmflx,co2fxd,co2fxu,co3,hi,kwco2sol,ndepflx,rivinflx,ocetra,omegaa,omegac,pco2d,satoxy,sedfluxo + use mo_carbch, only: atm,atmflx,co2fxd,co2fxu,co3,hi,kwco2sol,ndepflx,rivinflx,ocetra,omegaa,omegac,pco2d,satoxy, & + & sedfluxo, pn2om use mo_biomod, only: bsiflx_bot,bsiflx0100,bsiflx0500,bsiflx1000,bsiflx2000,bsiflx4000,calflx_bot,calflx0100,calflx0500,& & calflx1000,calflx2000,calflx4000,carflx_bot,carflx0100,carflx0500,carflx1000,carflx2000,carflx4000,& & expoca,expoor,exposi,intdms_bac,intdms_uv,intdmsprod,intdnit,intnfix,intphosy,phosy3d @@ -67,7 +68,7 @@ SUBROUTINE ACCFIELDS(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask) & jpoc,jprefalk,jprefdic,jprefo2,jprefpo4,jsilica,jsrfalkali,jsrfano3,jsrfdic,jsrfiron,jsrfoxygen, & & jsrfphosph,jsrfphyto,jsrfsilica,jwnos,jwphy,nbgc,nacc_bgc,bgcwrt,glb_inventory,bgct2d,acclvl, & & acclyr,accsrf,bgczlv,jlvlanh4,jlvlano2, & - & jlvl_nitr_NH4, & + & jlvl_nitr_NH4, jsrfpn2om,& & jlvl_nitr_NO2,jlvl_nitr_N2O_prod,jlvl_nitr_NH4_OM,jlvl_nitr_NO2_OM,jlvl_denit_NO3,jlvl_denit_NO2, & & jlvl_denit_N2O,jlvl_DNRA_NO2,jlvl_anmx_N2_prod,jlvl_anmx_OM_prod,jlvl_phosy_NH4,jlvl_phosy_NO3, & & jlvl_remin_aerob,jlvl_remin_sulf, & @@ -115,8 +116,9 @@ SUBROUTINE ACCFIELDS(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask) & jpowno3,jsssc12,jssso12,jssssil,jssster,accbur,accsdm #endif #ifdef extNcycle + use mo_carbch, only: pnh3m use mo_param1_bgc, only: iatmnh3,ianh4,iano2,ipownh4,ipown2o,ipowno2 - use mo_bgcmean, only: jnh3flux,janh3fx,janh4,jano2,jsrfanh4,jsrfano2, & + use mo_bgcmean, only: jnh3flux,janh3fx,janh4,jano2,jsrfanh4,jsrfano2,jsrfpnh3m, & & jnitr_NH4,jnitr_NO2,jnitr_N2O_prod,jnitr_NH4_OM,jnitr_NO2_OM,jdenit_NO3,jdenit_NO2,jdenit_N2O, & & jDNRA_NO2,janmx_N2_prod,janmx_OM_prod,jphosy_NH4,jphosy_NO3,jremin_aerob,jremin_sulf, & & jpownh4,jpown2o,jpowno2,jsdm_nitr_NH4,jsdm_nitr_NO2,jsdm_nitr_N2O_prod,jsdm_nitr_NH4_OM, & @@ -264,6 +266,7 @@ SUBROUTINE ACCFIELDS(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask) call accsrf(jsrfdic,ocetra(1,1,1,isco212),omask,0) call accsrf(jsrfphyto,ocetra(1,1,1,iphy),omask,0) call accsrf(jdms,ocetra(1,1,1,idms),omask,0) + call accsrf(jsrfpn2om,pn2om,omask,0) call accsrf(jexport,expoor,omask,0) call accsrf(jexpoca,expoca,omask,0) call accsrf(jexposi,exposi,omask,0) @@ -285,6 +288,7 @@ SUBROUTINE ACCFIELDS(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask) #endif #ifdef extNcycle call accsrf(jsrfanh4,ocetra(1,1,1,ianh4),omask,0) + call accsrf(jsrfpnh3m,pnh3m,omask,0) call accsrf(jsrfano2,ocetra(1,1,1,iano2),omask,0) #endif diff --git a/hamocc/carchm.F90 b/hamocc/carchm.F90 index c47d5e9c..d821329f 100644 --- a/hamocc/carchm.F90 +++ b/hamocc/carchm.F90 @@ -94,7 +94,7 @@ SUBROUTINE CARCHM(kpie,kpje,kpke,kbnd, & ! none. ! !********************************************************************** - use mo_carbch, only: atm,atmflx,co2fxd,co2fxu,co2star,co3,hi,keqb,kwco2sol,ocetra,omegaa,omegac,pco2d,satn2o,satoxy + use mo_carbch, only: atm,atmflx,co2fxd,co2fxu,co2star,co3,hi,keqb,kwco2sol,ocetra,omegaa,omegac,pco2d,satn2o,satoxy,pn2om use mo_chemcon, only: al1,al2,al3,al4,an0,an1,an2,an3,an4,an5,an6,atn2o,bl1,bl2,bl3,calcon,ox0,ox1,ox2,ox3,ox4,ox5,ox6, & & oxyco,tzero use mo_control_bgc, only: dtbgc @@ -118,6 +118,7 @@ SUBROUTINE CARCHM(kpie,kpje,kpke,kbnd, & use mo_param1_bgc, only: iatmnco2,inatalkali,inatcalc,inatsco212 #endif #ifdef extNcycle + use mo_carbch, only: pnh3m use mo_param1_bgc, only: iatmnh3,ianh4 use mo_chemcon, only: SV0_air,SV1_air,SV2_air,SV3_air,SV4_air,SD0_air,SD1_air,SD2_air,SD3_air,Vb_nh3,M_nh3,kappa #endif @@ -196,12 +197,16 @@ SUBROUTINE CARCHM(kpie,kpje,kpke,kbnd, & satoxy (:,:,:)=0. omegaA (:,:,:)=0. omegaC (:,:,:)=0. + pn2om (:,:)=0. #ifdef natDIC natpco2d (:,:)=0. natco3 (:,:,:)=0. natomegaA(:,:,:)=0. natomegaC(:,:,:)=0. #endif +#ifdef extNcycle + pnh3m (:,:)=0. +#endif !$OMP PARALLEL DO PRIVATE(t,t2,t3,t4,tk,tk100,s,rs,prb,Kh,Khd,K1,K2 & !$OMP ,Kb,K1p,K2p,K3p,Ksi,Kw,Ks1,Kf,Kspc,Kspa,tc,ta,sit,pt,ah1,ac & @@ -500,7 +505,9 @@ SUBROUTINE CARCHM(kpie,kpje,kpke,kbnd, & niflux=kwn2*dtbgc*(ocetra(i,j,1,igasnit)-anisa*(atn2/802000)*rpp0) ocetra(i,j,1,igasnit)=ocetra(i,j,1,igasnit)-niflux/pddpo(i,j,1) ! Surface flux of laughing gas (same piston velocity as for O2 and N2) - n2oflux=kwn2o*dtbgc*(ocetra(i,j,1,ian2o)-satn2o(i,j)*atn2ov*rpp0) + n2oflux=kwn2o*dtbgc*(ocetra(i,j,1,ian2o)-satn2o(i,j)*atn2ov*rpp0) + ! pN2O under moist air assumption at normal pressure + pn2om(i,j) = 1e6 * ocetra(i,j,1,ian2o)/satn2o(i,j) ocetra(i,j,1,ian2o)=ocetra(i,j,1,ian2o)-n2oflux/pddpo(i,j,1) #ifdef CFC ! Surface fluxes for CFC: eqn. (1a) in ocmip2 howto doc(hyc) @@ -605,7 +612,6 @@ SUBROUTINE CARCHM(kpie,kpje,kpke,kbnd, & ! Save product of piston velocity and solubility for output kwco2sol(i,j) = kwco2*Kh*1e-6 - endif ! k==1 #ifdef BROMO ! Degradation to hydrolysis (Eq. 2-4 of Stemmler et al., 2015) diff --git a/hamocc/mo_bgcmean.F90 b/hamocc/mo_bgcmean.F90 index 3b4c054c..2bbcd9ce 100644 --- a/hamocc/mo_bgcmean.F90 +++ b/hamocc/mo_bgcmean.F90 @@ -91,6 +91,7 @@ MODULE mo_bgcmean & SRF_NATCO2FX =0 , & & SRF_ATMBROMO =0 ,SRF_BROMO =0 ,SRF_BROMOFX =0 , & & SRF_ANH4 =0 ,SRF_ANO2 =0 ,SRF_ANH3FX =0 , & + & SRF_PN2OM =0 ,SRF_PNH3M =0 , & & INT_BROMOPRO =0 ,INT_BROMOUV =0 , & & INT_PHOSY =0 ,INT_NFIX =0 ,INT_DNIT =0 , & & FLX_CAR0100 =0 ,FLX_CAR0500 =0 ,FLX_CAR1000 =0 , & @@ -199,6 +200,7 @@ MODULE mo_bgcmean & SRF_NATCO2FX , & & SRF_ATMBROMO ,SRF_BROMO ,SRF_BROMOFX , & & SRF_ANH4 ,SRF_ANO2 ,SRF_ANH3FX , & + & SRF_PN2OM ,SRF_PNH3M , & & INT_BROMOPRO ,INT_BROMOUV , & & INT_PHOSY ,INT_NFIX ,INT_DNIT , & & FLX_CAR0100 ,FLX_CAR0500 ,FLX_CAR1000 , & @@ -396,7 +398,9 @@ MODULE mo_bgcmean INTEGER, DIMENSION(nbgcmax), SAVE :: & & janh3fx = 0 , & & jsrfanh4 = 0 , & - & jsrfano2 + & jsrfano2 = 0 , & + & jsrfpn2om = 0 , & + & jsrfpnh3m = 0 INTEGER, SAVE :: i_atm_m2d INTEGER, DIMENSION(nbgcmax), SAVE :: & @@ -734,6 +738,8 @@ SUBROUTINE ALLOC_MEM_BGCMEAN(kpie,kpje,kpke) jexposi(n)=i_bsc_m2d*min(1,SRF_EXPOSI(n)) IF (SRF_N2OFX(n).GT.0) i_bsc_m2d=i_bsc_m2d+1 jn2ofx(n)=i_bsc_m2d*min(1,SRF_N2OFX(n)) + IF (SRF_PN2OM(n).GT.0) i_bsc_m2d=i_bsc_m2d+1 + jsrfpn2om(n)=i_bsc_m2d*min(1,SRF_PN2OM(n)) IF (SRF_PHOSPH(n).GT.0) i_bsc_m2d=i_bsc_m2d+1 jsrfphosph(n)=i_bsc_m2d*min(1,SRF_PHOSPH(n)) IF (SRF_OXYGEN(n).GT.0) i_bsc_m2d=i_bsc_m2d+1 @@ -857,6 +863,8 @@ SUBROUTINE ALLOC_MEM_BGCMEAN(kpie,kpje,kpke) #ifdef extNcycle IF (SRF_ANH3FX(n).GT.0) i_bsc_m2d=i_bsc_m2d+1 janh3fx(n)=i_bsc_m2d*min(1,SRF_ANH3FX(n)) + IF (SRF_PNH3M(n).GT.0) i_bsc_m2d=i_bsc_m2d+1 + jsrfpnh3m(n)=i_bsc_m2d*min(1,SRF_PNH3M(n)) IF (SRF_ANH4(n).GT.0) i_bsc_m2d=i_bsc_m2d+1 jsrfanh4(n)=i_bsc_m2d*min(1,SRF_ANH4(n)) IF (SRF_ANO2(n).GT.0) i_bsc_m2d=i_bsc_m2d+1 diff --git a/hamocc/mo_carbch.F90 b/hamocc/mo_carbch.F90 index 2aecf82a..d5f57ab4 100644 --- a/hamocc/mo_carbch.F90 +++ b/hamocc/mo_carbch.F90 @@ -69,6 +69,7 @@ MODULE mo_carbch REAL, DIMENSION (:,:,:), ALLOCATABLE :: satoxy REAL, DIMENSION (:,:), ALLOCATABLE :: satn2o + REAL, DIMENSION (:,:), ALLOCATABLE :: pn2om REAL, DIMENSION (:,:), ALLOCATABLE :: atdifv REAL, DIMENSION (:,:), ALLOCATABLE :: suppco2 REAL, DIMENSION (:,:,:), ALLOCATABLE :: sedfluxo @@ -106,6 +107,7 @@ MODULE mo_carbch REAL :: atm_bromo, fbro1, fbro2 #endif #ifdef extNcycle + REAL, DIMENSION (:,:), ALLOCATABLE :: pnh3m REAL :: atm_nh3,atm_n2o #endif @@ -257,6 +259,16 @@ SUBROUTINE ALLOC_MEM_CARBCH(kpie,kpje,kpke) ALLOCATE (satn2o(kpie,kpje),stat=errstat) if(errstat.ne.0) stop 'not enough memory satn2o' satn2o(:,:) = 0.0 + + IF (mnproc.eq.1) THEN + WRITE(io_stdo_bgc,*)'Memory allocation for variable pn2om ...' + WRITE(io_stdo_bgc,*)'First dimension : ',kpie + WRITE(io_stdo_bgc,*)'Second dimension : ',kpje + ENDIF + + ALLOCATE (pn2om(kpie,kpje),stat=errstat) + if(errstat.ne.0) stop 'not enough memory pn2om' + pn2om(:,:) = 0.0 IF (mnproc.eq.1) THEN WRITE(io_stdo_bgc,*)'Memory allocation for variable keqb ...' @@ -378,6 +390,17 @@ SUBROUTINE ALLOC_MEM_CARBCH(kpie,kpje,kpke) co214fxd(:,:) = 0.0 co214fxu(:,:) = 0.0 #endif +#ifdef extNcycle + IF (mnproc.eq.1) THEN + WRITE(io_stdo_bgc,*)'Memory allocation for variable pnh3m ...' + WRITE(io_stdo_bgc,*)'First dimension : ',kpie + WRITE(io_stdo_bgc,*)'Second dimension : ',kpje + ENDIF + + ALLOCATE (pnh3m(kpie,kpje),stat=errstat) + if(errstat.ne.0) stop 'not enough memory pnh3m' + pnh3m(:,:) = 0.0 +#endif !****************************************************************************** END SUBROUTINE ALLOC_MEM_CARBCH diff --git a/hamocc/ncout_hamocc.F90 b/hamocc/ncout_hamocc.F90 index 39fb0afe..203ac8ee 100644 --- a/hamocc/ncout_hamocc.F90 +++ b/hamocc/ncout_hamocc.F90 @@ -72,7 +72,7 @@ subroutine ncwrt_bgc(iogrp) & jlvlphosy,jlvlphyto,jlvlphyto13,jlvlpoc, & & jlvlpoc13,jlvlprefalk,jlvlprefdic, & & jlvlprefo2,jlvlprefpo4,jlvlsf6,jlvlsilica, & - & jlvlwnos,jlvlwphy,jn2flux,jn2o,jn2oflux, & + & jlvlwnos,jlvlwphy,jn2flux,jn2o,jsrfpn2om,jn2oflux, & & jn2ofx,jndep,jniflux,jnos,jo2flux,jo2sat, & & jomegaa,jomegac,jopal,joxflux,joxygen,jpco2, & & jph,jphosph,jphosy,jphyto,jpoc,jprefalk, & @@ -94,7 +94,7 @@ subroutine ncwrt_bgc(iogrp) & lvl_co3,lvl_ph,lvl_omegaa,lvl_omegac, & & lvl_n2o,lvl_prefo2,lvl_o2sat,lvl_prefpo4, & & lvl_prefalk,lvl_prefdic,lvl_dicsat, & - & lvl_o2sat,srf_n2ofx,srf_atmco2,srf_kwco2, & + & lvl_o2sat,srf_n2ofx,srf_pn2om,srf_atmco2,srf_kwco2, & & srf_pco2,srf_dmsflux,srf_co2fxd, & & srf_co2fxu,srf_oxflux,srf_niflux,srf_dms, & & srf_dmsprod,srf_dms_bac,srf_dms_uv, & @@ -177,8 +177,8 @@ subroutine ncwrt_bgc(iogrp) & inisdm,inibur,wrtsdm,accbur,accsdm,wrtbur #endif #ifdef extNcycle - use mo_bgcmean, only: janh4,jano2,jlvlanh4,jlvlano2,jsrfanh4, & - & jsrfano2,janh3fx,srf_anh4,srf_ano2, & + use mo_bgcmean, only: janh4,jano2,jlvlanh4,jlvlano2,jsrfanh4,jsrfpnh3m, & + & jsrfano2,janh3fx,srf_pnh3m,srf_anh4,srf_ano2, & & srf_anh3fx,lyr_anh4,lyr_ano2,lvl_anh4, & & lvl_ano2, & & LYR_nitr_NH4,LYR_nitr_NO2,LYR_nitr_N2O_prod, & @@ -525,6 +525,8 @@ subroutine ncwrt_bgc(iogrp) & cmpflg,'co2fxu','Upward CO2 flux',' ','kg C m-2 s-1') call wrtsrf(joxflux(iogrp),SRF_OXFLUX(iogrp),rnacc*1e3/dtbgc,0., & & cmpflg,'fgo2','Oxygen flux',' ','mol O2 m-2 s-1') + call wrtsrf(jsrfpn2om(iogrp),SRF_PN2OM(iogrp),rnacc,0.,cmpflg, & + & 'pn2om','Surface pN2O under moist air',' ','uatm') call wrtsrf(jniflux(iogrp),SRF_NIFLUX(iogrp),rnacc*1e3/dtbgc,0., & & cmpflg,'fgn2','Nitrogen flux',' ','mol N2 m-2 s-1') call wrtsrf(jdms(iogrp),SRF_DMS(iogrp),rnacc,0.,cmpflg, & @@ -726,6 +728,8 @@ subroutine ncwrt_bgc(iogrp) call wrtsrf(jsrfanh4(iogrp),SRF_ANH4(iogrp), & & rnacc*1e3,0.,cmpflg,'srfnh4', & & 'Surface ammonium',' ','mol N m-3') + call wrtsrf(jsrfpnh3m(iogrp),SRF_PNH3M(iogrp),rnacc,0.,cmpflg, & + & 'pnh3m','Surface pNH3 under moist air',' ','uatm') call wrtsrf(jsrfano2(iogrp),SRF_ANO2(iogrp), & & rnacc*1e3,0.,cmpflg,'srfno2', & & 'Surface nitrite',' ','mol N m-3') @@ -1242,6 +1246,7 @@ subroutine ncwrt_bgc(iogrp) call inisrf(joxflux(iogrp),0.) call inisrf(jniflux(iogrp),0.) call inisrf(jn2ofx(iogrp),0.) + call inisrf(jsrfpn2om(iogrp),0.) call inisrf(jdms(iogrp),0.) call inisrf(jdmsprod(iogrp),0.) call inisrf(jdms_bac(iogrp),0.) @@ -1324,6 +1329,7 @@ subroutine ncwrt_bgc(iogrp) #endif #ifdef extNcycle call inisrf(jsrfanh4(iogrp),0.) + call inisrf(jsrfpnh3m(iogrp),0.) call inisrf(jsrfano2(iogrp),0.) call inisrf(janh3fx(iogrp),0.) #endif @@ -1568,7 +1574,7 @@ subroutine hamoccvardef(iogrp,timeunits,calendar,cmpflg) & nctime,ncfcls,ncedef,ncdefvar3d,ndouble use mo_bgcmean, only: srf_kwco2,srf_pco2,srf_dmsflux,srf_co2fxd, & - & srf_co2fxu,srf_oxflux,srf_niflux,srf_dms,srf_dmsprod, & + & srf_co2fxu,srf_oxflux,srf_niflux,srf_pn2om,srf_dms,srf_dmsprod, & & srf_dms_bac,srf_dms_uv,srf_export,srf_exposi,srf_expoca, & & srf_dic,srf_alkali,srf_phosph,srf_oxygen,srf_ano3,srf_silica, & & srf_iron,srf_phyto,int_phosy,int_nfix,int_dnit,flx_car0100, & @@ -1634,7 +1640,7 @@ subroutine hamoccvardef(iogrp,timeunits,calendar,cmpflg) #endif #ifdef extNcycle use mo_bgcmean, only: janh4,jano2,jlvlanh4,jlvlano2,jsrfanh4, & - & jsrfano2,janh3fx,srf_anh4,srf_ano2, & + & jsrfano2,janh3fx,srf_pnh3m,srf_anh4,srf_ano2, & & srf_anh3fx,lyr_anh4,lyr_ano2,lvl_anh4, & & lvl_ano2, & & LYR_nitr_NH4,LYR_nitr_NO2,LYR_nitr_N2O_prod, & @@ -1709,6 +1715,8 @@ subroutine hamoccvardef(iogrp,timeunits,calendar,cmpflg) & cmpflg,'p','co2fxu','Upward CO2 flux',' ','kg C m-2 s-1',0) call ncdefvar3d(SRF_OXFLUX(iogrp), & & cmpflg,'p','fgo2','Oxygen flux',' ','mol O2 m-2 s-1',0) + call ncdefvar3d(SRF_PN2OM(iogrp),cmpflg,'p', & + & 'pn2om','Surface pN2O moist air',' ','uatm',0) call ncdefvar3d(SRF_NIFLUX(iogrp), & & cmpflg,'p','fgn2','Nitrogen flux',' ','mol N2 m-2 s-1',0) call ncdefvar3d(SRF_DMS(iogrp),cmpflg,'p', & @@ -1877,6 +1885,8 @@ subroutine hamoccvardef(iogrp,timeunits,calendar,cmpflg) & 'atmc14','Atmospheric 14CO2',' ','ppm',0) #endif #ifdef extNcycle + call ncdefvar3d(SRF_PNH3M(iogrp),cmpflg,'p', & + & 'pnh3m','Surface pNH3 moist air',' ','uatm',0) call ncdefvar3d(SRF_ANH4(iogrp),cmpflg,'p','srfnh4', & & 'Surface ammonium',' ','mol N m-3',0) call ncdefvar3d(SRF_ANO2(iogrp),cmpflg,'p','srfno2', & From 8a79ed144c17b580a201aecedbf2e5000fe8ce64 Mon Sep 17 00:00:00 2001 From: Mats Bentsen Date: Sun, 20 Nov 2022 22:56:40 +0100 Subject: [PATCH 204/366] Correct unit of diagnostic variable dp_trc. --- phy/mod_dia.F | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/phy/mod_dia.F b/phy/mod_dia.F index 715f811b..e824a5fd 100644 --- a/phy/mod_dia.F +++ b/phy/mod_dia.F @@ -2919,7 +2919,7 @@ subroutine diaout(iogrp,m,n,mm,nn,k1m,k1n) call inilyr(ACC_UTILLYR(1),'p',0.) call acclyr(ACC_UTILLYR,dp(1-nbdy,1-nbdy,k1m),tmp3d,0,'p') call wrtlyr(ACC_UTILLYR(1), - . max(LYR_IDLAGE(iogrp),LYR_TRC(iogrp)),1.,0.,cmpflg,ip,'p', + . max(LYR_IDLAGE(iogrp),LYR_TRC(iogrp)),.1,0.,cmpflg,ip,'p', . 'dp_trc','Layer pressure thickness',' ','Pa') endif # ifdef IDLAGE From b51f8de0e3a9605a1e3fdbd9d55c78c03ee5937f Mon Sep 17 00:00:00 2001 From: Mats Bentsen Date: Mon, 21 Nov 2022 01:32:09 +0100 Subject: [PATCH 205/366] Made conservation and checksum diagnostics selectable by namelist options (default off). --- cime_config/buildnml | 6 ++++++ phy/mod_budget.F90 | 8 +++++--- phy/mod_checksum.F90 | 2 +- phy/rdlim.F | 8 +++++++- tests/fuk95/limits | 21 ++++++++++++--------- 5 files changed, 31 insertions(+), 14 deletions(-) diff --git a/cime_config/buildnml b/cime_config/buildnml index bd3d33a3..95ad80dd 100755 --- a/cime_config/buildnml +++ b/cime_config/buildnml @@ -123,6 +123,8 @@ set SPRFAC = .false. set ATM_PATH = "'unset'" set ITEST = 60 set JTEST = 60 +set CNSVDI = .false. +set CSDIAG = .false. set RSTFRQ = 1 if ($PIO_NETCDF_FORMAT_OCN == 64bit_offset) then set RSTFMT = 1 @@ -897,6 +899,8 @@ cat >! $RUNDIR/ocn_in$inststr << EOF ! 'ben02syn' (a) ! ITEST : Global i-index of point diagnostics (i) ! JTEST : Global j-index of point diagnostics (i) +! CNSVDI : Conservation diagnostics flag (l) +! CSDIAG : Checksum diagnostics flag (l) ! RSTFRQ : Restart frequency in days (30=1month,365=1year) (i) ! RSTFMT : Format of restart file (valid arguments are 0 for classic, ! 1 for 64-bit offset and 2 for netcdf4/hdf5 format) (i) @@ -961,6 +965,8 @@ cat >! $RUNDIR/ocn_in$inststr << EOF ATM_PATH = $ATM_PATH ITEST = $ITEST JTEST = $JTEST + CNSVDI = $CNSVDI + CSDIAG = $CSDIAG RSTFRQ = $RSTFRQ RSTFMT = $RSTFMT RSTCMP = $RSTCMP diff --git a/phy/mod_budget.F90 b/phy/mod_budget.F90 index ed6bda87..9eeaaddb 100644 --- a/phy/mod_budget.F90 +++ b/phy/mod_budget.F90 @@ -39,12 +39,14 @@ module mod_budget private + ! Options with default values, modifiable by namelist. + logical :: & + cnsvdi = .false. ! Flag that indicates whether conservation diagnostics + ! are written. + ! Constants. integer, parameter :: & ncalls = 7 ! Number of calls after which budgets are computed. - logical :: & - cnsvdi = .true. ! Flag that indicates whether conservation diagnostics - ! are written. real(r8), dimension(ncalls, 2) :: & sdp, & ! Global mass weighted sum of salinity. diff --git a/phy/mod_checksum.F90 b/phy/mod_checksum.F90 index d78a968c..ccf0f354 100644 --- a/phy/mod_checksum.F90 +++ b/phy/mod_checksum.F90 @@ -26,7 +26,7 @@ module mod_checksum private - ! Constants. + ! Options with default values, modifiable by namelist. logical :: & csdiag = .false. ! Flag that indicates whether checksums are written. diff --git a/phy/rdlim.F b/phy/rdlim.F index e45667f0..44949352 100644 --- a/phy/rdlim.F +++ b/phy/rdlim.F @@ -57,6 +57,7 @@ subroutine rdlim use mod_cesm, only: runid_cesm, ocn_cpl_dt_cesm, nstep_in_cpl, . smtfrc use mod_pointtest, only: itest, jtest + use mod_budget, only: cnsvdi use mod_checksum, only: csdiag c implicit none @@ -71,13 +72,14 @@ subroutine rdlim . mdv2hi,mdv2lo,mdv4hi,mdv4lo,mdc2hi,mdc2lo, . vsc2hi,vsc2lo,vsc4hi,vsc4lo,cbar,cb,cwbdts,cwbdls, . mommth,bmcmth,rmpmth,mlrttp, - . . rm0,rm5,ce,tdfile,niwgf,niwbf,niwlf, . swamth,jwtype,chlopt,ccfile, . trxday,srxday,trxdpt,srxdpt,trxlim,srxlim, . aptflx,apsflx,ditflx,disflx,srxbal,scfile,smtfrc,sprfac, . atm_path, . itest,jtest, + . cnsvdi, + . csdiag, . rstfrq,rstfmt,rstcmp,iotype c c --- read limits namelist @@ -163,6 +165,8 @@ subroutine rdlim write (lp,*) 'ATM_PATH ',trim(ATM_PATH) write (lp,*) 'ITEST',ITEST write (lp,*) 'JTEST',JTEST + write (lp,*) 'CNSVDI',CNSVDI + write (lp,*) 'CSDIAG',CSDIAG write (lp,*) 'RSTFRQ',RSTFRQ write (lp,*) 'RSTFMT',RSTFMT write (lp,*) 'RSTCMP',RSTCMP @@ -231,6 +235,8 @@ subroutine rdlim call xcbcst(atm_path) call xcbcst(itest) call xcbcst(jtest) + call xcbcst(cnsvdi) + call xcbcst(csdiag) call xcbcst(rstfrq) call xcbcst(rstfmt) call xcbcst(rstcmp) diff --git a/tests/fuk95/limits b/tests/fuk95/limits index fdcb58e3..b2dc21d5 100644 --- a/tests/fuk95/limits +++ b/tests/fuk95/limits @@ -79,6 +79,8 @@ ! 'ben02syn' (a) ! ITEST : Global i-index of point diagnostics (i) ! JTEST : Global j-index of point diagnostics (i) +! CNSVDI : Conservation diagnostics flag (l) +! CSDIAG : Checksum diagnostics flag (l) ! RSTFRQ : Restart frequency in days (30=1month,365=1year) (i) ! RSTFMT : Format of restart file (valid arguments are 0 for classic, ! 1 for 64-bit offset and 2 for netcdf4/hdf5 format) (i) @@ -319,8 +321,6 @@ ! LIP - liquid precipitation [kg m-2 s-1] ! MAXMLD - maximum mixed layer depth [m] ! MLD - mixed layer depth [m] -! MLDU - mixed layer depth at u-point [m] -! MLDV - mixed layer depth at v-point [m] ! MLTS - mixed layer thickness using "sigma-t" criterion [m] ! MLTSMN - minimum mixed layer thickness using "sigma-t" criterion [m] ! MLTSMX - maximum mixed layer thickness using "sigma-t" criterion [m] @@ -332,8 +332,6 @@ ! MTKEPE - mixed layer TKE tendency related to pot. energy change [kg s-3] ! MTKEKE - mixed layer TKE tendency related to kin. energy change [kg s-3] ! MTY - wind stress y-component [N m-2] -! MXLU - mixed layer velocity x-component [m s-1] -! MXLV - mixed layer velocity y-component [m s-1] ! NSF - non-solar heat flux [W m-2] ! PBOT - bottom pressure [Pa] ! PSRF - surface pressure [Pa] @@ -368,7 +366,10 @@ ! VICE - ice velocity y-component [m s-1] ! ZTX - wind stress x-component [N m-2] ! BFSQ - buoyancy frequency squared [s-1] -! DIFDIA - diapycnal diffusivity [log10(m2 s-1)] +! DIFDIA - vertical diffusivity [log10(m2 s-1)|m2 s-1] +! DIFVMO - vertical momentum diffusivity [log10(m2 s-1)|m2 s-1] +! DIFVHO - vertical heat diffusivity [log10(m2 s-1)|m2 s-1] +! DIFVSO - vertical salt diffusivity [log10(m2 s-1)|m2 s-1] ! DIFINT - layer interface diffusivity [log10(m2 s-1)] ! DIFISO - isopycnal diffusivity [log10(m2 s-1)] ! DP - layer pressure thickness [Pa] @@ -441,8 +442,6 @@ H2D_LIP = 0, 0 H2D_MAXMLD = 4, 4 H2D_MLD = 0, 4 - H2D_MLDU = 0, 0 - H2D_MLDV = 0, 0 H2D_MLTS = 0, 4 H2D_MLTSMN = 0, 4 H2D_MLTSMX = 0, 4 @@ -454,8 +453,6 @@ H2D_MTKEPE = 0, 4 H2D_MTKEKE = 0, 4 H2D_MTY = 0, 0 - H2D_MXLU = 4, 4 - H2D_MXLV = 4, 4 H2D_NSF = 0, 0 H2D_PBOT = 0, 4 H2D_PSRF = 0, 0 @@ -491,6 +488,9 @@ H2D_ZTX = 0, 0 LYR_BFSQ = 0, 4 LYR_DIFDIA = 0, 4 + LYR_DIFVMO = 0, 4 + LYR_DIFVHO = 0, 4 + LYR_DIFVSO = 0, 0 LYR_DIFINT = 0, 0 LYR_DIFISO = 0, 0 LYR_DP = 0, 4 @@ -524,6 +524,9 @@ LYR_IDLAGE = 0, 4 LVL_BFSQ = 0, 4 LVL_DIFDIA = 0, 4 + LVL_DIFVMO = 0, 4 + LVL_DIFVHO = 0, 4 + LVL_DIFVSO = 0, 0 LVL_DIFINT = 0, 0 LVL_DIFISO = 0, 0 LVL_DZ = 0, 4 From af660e25477967ff6364b911adf7d65fed57c54c Mon Sep 17 00:00:00 2001 From: jmaerz <92309038+jmaerz@users.noreply.github.com> Date: Tue, 22 Nov 2022 15:55:49 +0100 Subject: [PATCH 206/366] pCO2, Piston velocity and solubility output (#202) * add pCO2m (moist), CO2 piston velocity and solubility output - caution: kwco2 piston velocity now really holds only piston velocity (and not times solubility) --- cime_config/buildnml | 14 +++++++++++++- hamocc/accfields.F90 | 12 +++++++++--- hamocc/carchm.F90 | 17 ++++++++++++---- hamocc/mo_bgcmean.F90 | 16 +++++++++++++++ hamocc/mo_carbch.F90 | 43 +++++++++++++++++++++++++++++++++++++++++ hamocc/ncout_hamocc.F90 | 29 +++++++++++++++++++++++++-- 6 files changed, 121 insertions(+), 10 deletions(-) diff --git a/cime_config/buildnml b/cime_config/buildnml index 95ad80dd..2507d13d 100755 --- a/cime_config/buildnml +++ b/cime_config/buildnml @@ -426,7 +426,11 @@ set SRF_EXPORT = '0, 2, 2' set SRF_EXPOSI = '0, 2, 2' set SRF_EXPOCA = '0, 2, 2' set SRF_KWCO2 = '0, 2, 2' +set SRF_KWCO2KHM = '0, 2, 2' +set SRF_CO2KH = '0, 2, 2' +set SRF_CO2KHM = '0, 2, 2' set SRF_PCO2 = '0, 2, 2' +set SRF_PCO2M = '0, 2, 2' set SRF_CO2FXD = '4, 2, 2' set SRF_CO2FXU = '4, 2, 2' set SRF_OXFLUX = '0, 2, 2' @@ -1584,7 +1588,11 @@ cat >>! $RUNDIR/ocn_in$inststr << EOF ! EXPOCA - Ca export production (epcalc100) [mol Ca m-2 s-1] ! EXPOSI - Si export production (epsi100) [mol Si m-2 s-1] ! PCO2 - Surface PCO2 (spco2) [uatm] -! KWCO2 - kwco2 x solubility +! PCO2M - Surface PCO2 under moist air assumption [uatm] +! KWCO2 - Piston velocity (kwco2) [m s-1] +! KWCO2KHM - Piston velocity times solubility (kwco2*kh; moist air) [m s-1 mol kg-1 uatm-1] +! CO2KH - CO2 solubility under dry air assumption (khd) [mol kg-1 atm-1] +! CO2KHM - CO2 solubility under moist air assumption (kh) [mol kg-1 atm-1] ! CO2FXD - Downward CO2 flux (co2fxd) [kg C m-2 s-1] ! CO2FXU - Upward CO2 flux (co2fxu) [kg C m-2 s-1] ! NIFLUX - Nitrogen flux (fgn2) [mol N2 m-2 s-1] @@ -1664,7 +1672,11 @@ cat >>! $RUNDIR/ocn_in$inststr << EOF SRF_EXPOSI = $SRF_EXPOSI SRF_EXPOCA = $SRF_EXPOCA SRF_KWCO2 = $SRF_KWCO2 + SRF_KWCO2KHM = $SRF_KWCO2KHM + SRF_CO2KH = $SRF_CO2KH + SRF_CO2KHM = $SRF_CO2KHM SRF_PCO2 = $SRF_PCO2 + SRF_PCO2M = $SRF_PCO2M SRF_CO2FXD = $SRF_CO2FXD SRF_CO2FXU = $SRF_CO2FXU SRF_OXFLUX = $SRF_OXFLUX diff --git a/hamocc/accfields.F90 b/hamocc/accfields.F90 index ff87802d..a83fe953 100644 --- a/hamocc/accfields.F90 +++ b/hamocc/accfields.F90 @@ -46,7 +46,8 @@ SUBROUTINE ACCFIELDS(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask) !********************************************************************** use mod_xc, only: mnproc use mod_dia, only: ddm - use mo_carbch, only: atm,atmflx,co2fxd,co2fxu,co3,hi,kwco2sol,ndepflx,rivinflx,ocetra,omegaa,omegac,pco2d,satoxy,sedfluxo + use mo_carbch, only: atm,atmflx,co2fxd,co2fxu,co3,hi,kwco2sol,ndepflx,rivinflx,ocetra,omegaa,omegac,pco2d,satoxy, & + & sedfluxo,pco2m,kwco2d,co2sold,co2solm use mo_biomod, only: bsiflx_bot,bsiflx0100,bsiflx0500,bsiflx1000,bsiflx2000,bsiflx4000,calflx_bot,calflx0100,calflx0500,& & calflx1000,calflx2000,calflx4000,carflx_bot,carflx0100,carflx0500,carflx1000,carflx2000,carflx4000,& & expoca,expoor,exposi,intdms_bac,intdms_uv,intdmsprod,intdnit,intnfix,intphosy,phosy3d @@ -63,7 +64,8 @@ SUBROUTINE ACCFIELDS(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask) & jlvlph,jlvlphosph,jlvlphosy,jlvlphyto,jlvlphyto13,jlvlpoc,jlvlpoc13,jlvlprefalk,jlvlprefdic, & & jlvlprefo2,jlvlprefpo4,jlvlsf6,jlvlsilica,jlvlwnos,jlvlwphy,jn2flux,jn2o,jn2oflux,jn2ofx, & & jprorca,jprcaca,jsilpro,jpodiic,jpodial,jpodiph,jpodiox,jpodin2,jpodino3,jpodisi,jndep, & - & jniflux,jnos,jo2flux,jo2sat,jomegaa,jomegac,jopal,joxflux,joxygen,jpco2,jph,jphosph,jphosy,jphyto, & + & jniflux,jnos,jo2flux,jo2sat,jomegaa,jomegac,jopal,joxflux,joxygen,jpco2,jpco2m,jkwco2khm,jco2khm, & + & jco2kh,jph,jphosph,jphosy,jphyto, & & jpoc,jprefalk,jprefdic,jprefo2,jprefpo4,jsilica,jsrfalkali,jsrfano3,jsrfdic,jsrfiron,jsrfoxygen, & & jsrfphosph,jsrfphyto,jsrfsilica,jwnos,jwphy,nbgc,nacc_bgc,bgcwrt,glb_inventory,bgct2d,acclvl, & & acclyr,accsrf,bgczlv @@ -227,7 +229,11 @@ SUBROUTINE ACCFIELDS(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask) ! Accumulate 2d diagnostics call accsrf(jpco2,pco2d,omask,0) - call accsrf(jkwco2,kwco2sol,omask,0) + call accsrf(jpco2m,pco2m,omask,0) + call accsrf(jkwco2khm,kwco2sol,omask,0) + call accsrf(jkwco2,kwco2d,omask,0) + call accsrf(jco2kh,co2sold,omask,0) + call accsrf(jco2khm,co2solm,omask,0) call accsrf(jsrfphosph,ocetra(1,1,1,iphosph),omask,0) call accsrf(jsrfoxygen,ocetra(1,1,1,ioxygen),omask,0) call accsrf(jsrfiron,ocetra(1,1,1,iiron),omask,0) diff --git a/hamocc/carchm.F90 b/hamocc/carchm.F90 index bab04daf..f0563983 100644 --- a/hamocc/carchm.F90 +++ b/hamocc/carchm.F90 @@ -94,7 +94,8 @@ SUBROUTINE CARCHM(kpie,kpje,kpke,kbnd, & ! none. ! !********************************************************************** - use mo_carbch, only: atm,atmflx,co2fxd,co2fxu,co2star,co3,hi,keqb,kwco2sol,ocetra,omegaa,omegac,pco2d,satn2o,satoxy + use mo_carbch, only: atm,atmflx,co2fxd,co2fxu,co2star,co3,hi,keqb,kwco2sol,ocetra,omegaa,omegac,pco2d,satn2o,satoxy, & + pco2m,kwco2d,co2sold,co2solm use mo_chemcon, only: al1,al2,al3,al4,an0,an1,an2,an3,an4,an5,an6,atn2o,bl1,bl2,bl3,calcon,ox0,ox1,ox2,ox3,ox4,ox5,ox6, & & oxyco,tzero use mo_control_bgc, only: dtbgc @@ -180,7 +181,11 @@ SUBROUTINE CARCHM(kpie,kpje,kpke,kbnd, & co214fxd (:,:)=0. co214fxu (:,:)=0. #endif - pco2d (:,:)=0. + pco2d (:,:)=0. + pco2m (:,:)=0. + kwco2d (:,:)=0. + co2sold (:,:)=0. + co2solm (:,:)=0. kwco2sol (:,:)=0. co2star(:,:,:)=0. co3 (:,:,:)=0. @@ -518,13 +523,17 @@ SUBROUTINE CARCHM(kpie,kpje,kpke,kbnd, & ! Save pco2 w.r.t. dry air for output pco2d(i,j) = cu * 1.e6 / Khd + !pCO2 wrt moist air + pco2m(i,j) = cu * 1.e6 / Kh #ifdef natDIC natpco2d(i,j) = natcu * 1.e6 / Khd #endif ! Save product of piston velocity and solubility for output - kwco2sol(i,j) = kwco2*Kh*1e-6 - + kwco2sol(i,j) = kwco2*Kh*1e-6 !m/s mol/kg/muatm + kwco2d(i,j) = kwco2 ! m/s (incl. ice fraction!) + co2sold(i,j) = Khd ! mol/kg/atm + co2solm(i,j) = Kh ! mol/kg/atm endif ! k==1 #ifdef BROMO diff --git a/hamocc/mo_bgcmean.F90 b/hamocc/mo_bgcmean.F90 index 35687938..9bb44653 100644 --- a/hamocc/mo_bgcmean.F90 +++ b/hamocc/mo_bgcmean.F90 @@ -76,6 +76,8 @@ MODULE mo_bgcmean ! --- Namelist for diagnostic output INTEGER, DIMENSION(nbgcmax), SAVE :: & & SRF_KWCO2 =0 ,SRF_PCO2 =0 ,SRF_DMSFLUX =0 , & + & SRF_KWCO2KHM =0 ,SRF_CO2KHM =0 ,SRF_CO2KH =0 , & + & SRF_PCO2M =0 , & & SRF_CO2FXD =0 ,SRF_CO2FXU =0 ,SRF_CO213FXD =0 , & & SRF_CO213FXU =0 ,SRF_CO214FXD =0 ,SRF_CO214FXU =0 , & & SRF_OXFLUX =0 ,SRF_NIFLUX =0 ,SRF_DMS =0 , & @@ -150,6 +152,8 @@ MODULE mo_bgcmean CHARACTER(LEN=10), DIMENSION(nbgcmax), SAVE :: GLB_FNAMETAG namelist /DIABGC/ & & SRF_KWCO2 ,SRF_PCO2 ,SRF_DMSFLUX , & + & SRF_KWCO2KHM ,SRF_CO2KHM ,SRF_CO2KH , & + & SRF_PCO2M , & & SRF_CO2FXD ,SRF_CO2FXU ,SRF_CO213FXD , & & SRF_CO213FXU ,SRF_CO214FXD ,SRF_CO214FXU , & & SRF_OXFLUX ,SRF_NIFLUX ,SRF_DMS , & @@ -255,7 +259,11 @@ MODULE mo_bgcmean INTEGER, SAVE :: i_bsc_m2d INTEGER, DIMENSION(nbgcmax), SAVE :: & & jkwco2 = 0 , & + & jkwco2khm = 0 , & + & jco2kh = 0 , & + & jco2khm = 0 , & & jpco2 = 0 , & + & jpco2m = 0 , & & jdmsflux = 0 , & & jco2fxd = 0 , & & jco2fxu = 0 , & @@ -560,8 +568,16 @@ SUBROUTINE ALLOC_MEM_BGCMEAN(kpie,kpje,kpke) DO n=1,nbgc IF (SRF_KWCO2(n).GT.0) i_bsc_m2d=i_bsc_m2d+1 jkwco2(n)=i_bsc_m2d*min(1,SRF_KWCO2(n)) + IF (SRF_KWCO2KHM(n).GT.0) i_bsc_m2d=i_bsc_m2d+1 + jkwco2khm(n)=i_bsc_m2d*min(1,SRF_KWCO2KHM(n)) + IF (SRF_CO2KH(n).GT.0) i_bsc_m2d=i_bsc_m2d+1 + jco2kh(n)=i_bsc_m2d*min(1,SRF_CO2KH(n)) + IF (SRF_CO2KHM(n).GT.0) i_bsc_m2d=i_bsc_m2d+1 + jco2khm(n)=i_bsc_m2d*min(1,SRF_CO2KHM(n)) IF (SRF_PCO2(n).GT.0) i_bsc_m2d=i_bsc_m2d+1 jpco2(n)=i_bsc_m2d*min(1,SRF_PCO2(n)) + IF (SRF_PCO2M(n).GT.0) i_bsc_m2d=i_bsc_m2d+1 + jpco2m(n)=i_bsc_m2d*min(1,SRF_PCO2M(n)) IF (SRF_DMSFLUX(n).GT.0) i_bsc_m2d=i_bsc_m2d+1 jdmsflux(n)=i_bsc_m2d*min(1,SRF_DMSFLUX(n)) IF (SRF_CO2FXD(n).GT.0) i_bsc_m2d=i_bsc_m2d+1 diff --git a/hamocc/mo_carbch.F90 b/hamocc/mo_carbch.F90 index 234f3c48..6a83fc2b 100644 --- a/hamocc/mo_carbch.F90 +++ b/hamocc/mo_carbch.F90 @@ -74,7 +74,11 @@ MODULE mo_carbch REAL, DIMENSION (:,:,:), ALLOCATABLE :: sedfluxo REAL, DIMENSION (:,:), ALLOCATABLE :: pco2d + REAL, DIMENSION (:,:), ALLOCATABLE :: pco2m REAL, DIMENSION (:,:), ALLOCATABLE :: kwco2sol + REAL, DIMENSION (:,:), ALLOCATABLE :: kwco2d + REAL, DIMENSION (:,:), ALLOCATABLE :: co2sold + REAL, DIMENSION (:,:), ALLOCATABLE :: co2solm REAL, DIMENSION (:,:), ALLOCATABLE :: co2fxd REAL, DIMENSION (:,:), ALLOCATABLE :: co2fxu #ifdef cisonew @@ -334,12 +338,51 @@ SUBROUTINE ALLOC_MEM_CARBCH(kpie,kpje,kpke) if(errstat.ne.0) stop 'not enough memory pco2d' pco2d(:,:) = 0.0 + IF (mnproc.eq.1) THEN + WRITE(io_stdo_bgc,*)'Memory allocation for variable pco2m ...' + WRITE(io_stdo_bgc,*)'First dimension : ',kpie + WRITE(io_stdo_bgc,*)'Second dimension : ',kpje + ENDIF + + ALLOCATE (pco2m(kpie,kpje),stat=errstat) + if(errstat.ne.0) stop 'not enough memory pco2m' + pco2m(:,:) = 0.0 + + IF (mnproc.eq.1) THEN + WRITE(io_stdo_bgc,*)'Memory allocation for variable kwco2d ...' + WRITE(io_stdo_bgc,*)'First dimension : ',kpie + WRITE(io_stdo_bgc,*)'Second dimension : ',kpje + ENDIF + + ALLOCATE (kwco2d(kpie,kpje),stat=errstat) + if(errstat.ne.0) stop 'not enough memory kwco2d' + kwco2d(:,:) = 0.0 IF (mnproc.eq.1) THEN WRITE(io_stdo_bgc,*)'Memory allocation for variable kwco2sol ...' WRITE(io_stdo_bgc,*)'First dimension : ',kpie WRITE(io_stdo_bgc,*)'Second dimension : ',kpje ENDIF + + IF (mnproc.eq.1) THEN + WRITE(io_stdo_bgc,*)'Memory allocation for variable co2sold ...' + WRITE(io_stdo_bgc,*)'First dimension : ',kpie + WRITE(io_stdo_bgc,*)'Second dimension : ',kpje + ENDIF + + ALLOCATE (co2sold(kpie,kpje),stat=errstat) + if(errstat.ne.0) stop 'not enough memory co2sold' + co2sold(:,:) = 0.0 + + IF (mnproc.eq.1) THEN + WRITE(io_stdo_bgc,*)'Memory allocation for variable co2solm ...' + WRITE(io_stdo_bgc,*)'First dimension : ',kpie + WRITE(io_stdo_bgc,*)'Second dimension : ',kpje + ENDIF + + ALLOCATE (co2solm(kpie,kpje),stat=errstat) + if(errstat.ne.0) stop 'not enough memory co2solm' + co2solm(:,:) = 0.0 ALLOCATE (kwco2sol(kpie,kpje),stat=errstat) if(errstat.ne.0) stop 'not enough memory co2fxd,co2fxu' diff --git a/hamocc/ncout_hamocc.F90 b/hamocc/ncout_hamocc.F90 index c4bafdff..8e930519 100644 --- a/hamocc/ncout_hamocc.F90 +++ b/hamocc/ncout_hamocc.F90 @@ -75,6 +75,7 @@ subroutine ncwrt_bgc(iogrp) & jlvlwnos,jlvlwphy,jn2flux,jn2o,jn2oflux, & & jn2ofx,jndep,jniflux,jnos,jo2flux,jo2sat, & & jomegaa,jomegac,jopal,joxflux,joxygen,jpco2, & + & jpco2m,jkwco2khm,jco2kh,jco2khm, & & jph,jphosph,jphosy,jphyto,jpoc,jprefalk, & & jprefdic,jprefo2,jprefpo4,jsilica, & & jsrfalkali,jsrfano3,jsrfdic,jsrfiron, & @@ -95,6 +96,7 @@ subroutine ncwrt_bgc(iogrp) & lvl_n2o,lvl_prefo2,lvl_o2sat,lvl_prefpo4, & & lvl_prefalk,lvl_prefdic,lvl_dicsat, & & lvl_o2sat,srf_n2ofx,srf_atmco2,srf_kwco2, & + & srf_kwco2khm,srf_co2kh,srf_co2khm,srf_pco2m, & & srf_pco2,srf_dmsflux,srf_co2fxd, & & srf_co2fxu,srf_oxflux,srf_niflux,srf_dms, & & srf_dmsprod,srf_dms_bac,srf_dms_uv, & @@ -392,9 +394,18 @@ subroutine ncwrt_bgc(iogrp) ! --- Store 2d fields call wrtsrf(jkwco2(iogrp),SRF_KWCO2(iogrp),rnacc,0.,cmpflg, & - & 'kwco2',' ',' ',' ') + & 'kwco2','CO2 piston velocity',' ','m s-1') + call wrtsrf(jkwco2khm(iogrp),SRF_KWCO2KHM(iogrp),rnacc,0.,cmpflg, & + & 'kwco2khm','CO2 piston velocity times solubility (moist air)',' ', & + & 'm s-1 mol kg-1 uatm-1') + call wrtsrf(jco2kh(iogrp),SRF_CO2KH(iogrp),rnacc,0.,cmpflg, & + & 'co2kh','CO2 solubility (dry air) ',' ','mol kg-1 atm-1') + call wrtsrf(jco2khm(iogrp),SRF_CO2KHM(iogrp),rnacc,0.,cmpflg, & + & 'co2khm','CO2 solubility (moist air) ',' ','mol kg-1 atm-1') call wrtsrf(jpco2(iogrp),SRF_PCO2(iogrp),rnacc,0.,cmpflg, & & 'pco2','Surface PCO2',' ','uatm') + call wrtsrf(jpco2m(iogrp),SRF_PCO2M(iogrp),rnacc,0.,cmpflg, & + & 'pco2m','Surface PCO2 (moist air)',' ','uatm') call wrtsrf(jdmsflux(iogrp),SRF_DMSFLUX(iogrp),rnacc*1e3/dtbgc,0., & & cmpflg,'dmsflux','DMS flux',' ','mol DMS m-2 s-1') call wrtsrf(jco2fxd(iogrp),SRF_CO2FXD(iogrp),rnacc*12./dtbgc,0., & @@ -877,7 +888,11 @@ subroutine ncwrt_bgc(iogrp) ! --- Initialise fields call inisrf(jkwco2(iogrp),0.) + call inisrf(jkwco2khm(iogrp),0.) + call inisrf(jco2kh(iogrp),0.) + call inisrf(jco2khm(iogrp),0.) call inisrf(jpco2(iogrp),0.) + call inisrf(jpco2m(iogrp),0.) call inisrf(jdmsflux(iogrp),0.) call inisrf(jco2fxd(iogrp),0.) call inisrf(jco2fxu(iogrp),0.) @@ -1119,6 +1134,7 @@ subroutine hamoccvardef(iogrp,timeunits,calendar,cmpflg) & nctime,ncfcls,ncedef,ncdefvar3d,ndouble use mo_bgcmean, only: srf_kwco2,srf_pco2,srf_dmsflux,srf_co2fxd, & + & srf_kwco2khm,srf_co2kh,srf_co2khm,srf_pco2m, & & srf_co2fxu,srf_oxflux,srf_niflux,srf_dms,srf_dmsprod, & & srf_dms_bac,srf_dms_uv,srf_export,srf_exposi,srf_expoca, & & srf_dic,srf_alkali,srf_phosph,srf_oxygen,srf_ano3,srf_silica, & @@ -1195,9 +1211,18 @@ subroutine hamoccvardef(iogrp,timeunits,calendar,cmpflg) call ncattr('bounds','depth_bnds') call ncdefvar('depth_bnds','bounds depth',ndouble,8) call ncdefvar3d(SRF_KWCO2(iogrp),cmpflg,'p', & - & 'kwco2',' ',' ',' ',0) + & 'kwco2','CO2 piston velocity',' ','m s-1',0) + call ncdefvar3d(SRF_KWCO2KHM(iogrp),cmpflg,'p', & + & 'kwco2khm','CO2 piston velocity times solubility (moist air)',' ', & + & 'm s-1 mol kg-1 muatm-1',0) + call ncdefvar3d(SRF_CO2KH(iogrp),cmpflg,'p', & + & 'co2kh','CO2 solubility (dry air)',' ','mol kg-1 atm-1',0) + call ncdefvar3d(SRF_CO2KHM(iogrp),cmpflg,'p', & + & 'co2khm','CO2 solubility (moist air)',' ','mol kg-1 atm-1',0) call ncdefvar3d(SRF_PCO2(iogrp),cmpflg,'p', & & 'pco2','Surface PCO2',' ','uatm',0) + call ncdefvar3d(SRF_PCO2M(iogrp),cmpflg,'p', & + & 'pco2m','Surface PCO2 (moist air)',' ','uatm',0) call ncdefvar3d(SRF_DMSFLUX(iogrp), & & cmpflg,'p','dmsflux','DMS flux',' ','mol DMS m-2 s-1',0) call ncdefvar3d(SRF_CO2FXD(iogrp), & From adab448b2ea6ab739db330716b27333461a0713b Mon Sep 17 00:00:00 2001 From: Tomas Torsvik <43031053+TomasTorsvik@users.noreply.github.com> Date: Fri, 25 Nov 2022 14:10:45 +0100 Subject: [PATCH 207/366] Bugfix pnetcdf (#208) * Add variables used by PNETCDF to explicit use staements. * Move implicit none statments * update explicit use statement for pnetcdf --- hamocc/read_netcdf_var.F90 | 3 +++ hamocc/write_netcdf_var.F90 | 3 +++ 2 files changed, 6 insertions(+) diff --git a/hamocc/read_netcdf_var.F90 b/hamocc/read_netcdf_var.F90 index 8befec8e..90b56067 100644 --- a/hamocc/read_netcdf_var.F90 +++ b/hamocc/read_netcdf_var.F90 @@ -26,6 +26,9 @@ SUBROUTINE READ_NETCDF_VAR(ncid,desc,arr,klev,time,typeio) !************************************************************************** use netcdf, only: nf90_noerr,nf90_inq_varid,nf90_strerror,nf90_get_var use mod_xc, only: idm,itdm,jtdm,jdm,lp,mnproc,nbdy,xchalt,xcaput +#ifdef PNETCDF + use mod_xc, only: i0,ii,jj,j0 +#endif implicit none #ifdef PNETCDF #include diff --git a/hamocc/write_netcdf_var.F90 b/hamocc/write_netcdf_var.F90 index af15b90b..d07eb4f5 100644 --- a/hamocc/write_netcdf_var.F90 +++ b/hamocc/write_netcdf_var.F90 @@ -27,6 +27,9 @@ SUBROUTINE WRITE_NETCDF_VAR(ncid,desc,arr,klev,time) use netcdf, only: nf90_noerr,nf90_inq_varid,nf90_strerror,nf90_put_var use mod_xc, only: itdm,jtdm,jdm,lp,mnproc,nbdy,idm,xchalt,xcaget use mod_dia, only: iotype +#ifdef PNETCDF + use mod_xc, only: i0,ii,jj,j0,mproc,mpe_1,nproc,xcgetrow +#endif implicit none #ifdef PNETCDF # include From 5ca2bab06f4148123b6135c750165911384f14c4 Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Tue, 29 Nov 2022 19:22:56 +0100 Subject: [PATCH 208/366] Output for burial fluxes --- cime_config/buildnml | 12 ++++++++++++ hamocc/accfields.F90 | 11 ++++++++--- hamocc/mo_bgcmean.F90 | 22 +++++++++++++++++++--- hamocc/mo_carbch.F90 | 16 ++++++++++++++-- hamocc/ncout_hamocc.F90 | 33 +++++++++++++++++++++++++++++++-- hamocc/sedshi.F90 | 13 ++++++++++++- 6 files changed, 96 insertions(+), 11 deletions(-) diff --git a/cime_config/buildnml b/cime_config/buildnml index da756b60..680e6d2e 100755 --- a/cime_config/buildnml +++ b/cime_config/buildnml @@ -655,6 +655,10 @@ set FLX_SEDIFFSI = '0, 0, 2' set FLX_SEDIFFNH4 = '0, 0, 2' set FLX_SEDIFFN2O = '0, 0, 2' set FLX_SEDIFFNO2 = '0, 0, 2' +set FLX_BURSSO12 = '0, 0, 2' +set FLX_BURSSSC12 = '0, 0, 2' +set FLX_BURSSSSIL = '0, 0, 2' +set FLX_BURSSSTER = '0, 0, 2' set SDM_POWAIC = '0, 0, 2' set SDM_POWAAL = '0, 0, 2' set SDM_POWAPH = '0, 0, 2' @@ -1753,6 +1757,10 @@ cat >>! $RUNDIR/ocn_in$inststr << EOF ! SEDIFFNH4 - sediment - water-column diffusive flux of ammonia [mol NH4 m-2 s-1] ! SEDIFFN2O - sediment - water-column diffusive flux of N2O [mol N2O m-2 s-1] ! SEDIFFNO2 - sediment - water-column diffusive flux of NO2 [mol NO2 m-2 s-1] +! BURSSO12 - sediment - burial layer burial flux of organic matter [mol P m-2 s-1] +! BURSSSC12 - sediment - burial layer burial flux of CaCO3 [mol Ca m-2 s-1] +! BURSSSSIL - sediment - burial layer burial flux of opal [mol Si m-2 s-1] +! BURSSSTER - sediment - burial layer burial flux of ssster [g m-2 s-1] ! ! Sediment fields (SDM) ! POWAIC - (powdic) [mol C m-3] @@ -2061,6 +2069,10 @@ cat >>! $RUNDIR/ocn_in$inststr << EOF SDM_ANMX_OM_PROD = $SDM_ANMX_OM_PROD SDM_REMIN_AEROB = $SDM_REMIN_AEROB SDM_REMIN_SULF = $SDM_REMIN_SULF + FLX_BURSSO12 = $FLX_BURSSO12 + FLX_BURSSSC12 = $FLX_BURSSSC12 + FLX_BURSSSSIL = $FLX_BURSSSSIL + FLX_BURSSSTER = $FLX_BURSSSTER SDM_SSSO12 = $SDM_SSSO12 SDM_SSSSIL = $SDM_SSSSIL SDM_SSSC12 = $SDM_SSSC12 diff --git a/hamocc/accfields.F90 b/hamocc/accfields.F90 index f6e19a44..9103fae4 100644 --- a/hamocc/accfields.F90 +++ b/hamocc/accfields.F90 @@ -47,7 +47,7 @@ SUBROUTINE ACCFIELDS(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask) use mod_xc, only: mnproc use mod_dia, only: ddm use mo_carbch, only: atm,atmflx,co2fxd,co2fxu,co3,hi,kwco2sol,ndepflx,rivinflx,ocetra,omegaa,omegac,pco2d,satoxy, & - & sedfluxo,pco2m,kwco2d,co2sold,co2solm,pn2om + & sedfluxo,sedfluxb,pco2m,kwco2d,co2sold,co2solm,pn2om use mo_biomod, only: bsiflx_bot,bsiflx0100,bsiflx0500,bsiflx1000,bsiflx2000,bsiflx4000,calflx_bot,calflx0100,calflx0500,& & calflx1000,calflx2000,calflx4000,carflx_bot,carflx0100,carflx0500,carflx1000,carflx2000,carflx4000,& & expoca,expoor,exposi,intdms_bac,intdms_uv,intdmsprod,intdnit,intnfix,intphosy,phosy3d @@ -55,6 +55,7 @@ SUBROUTINE ACCFIELDS(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask) & jbsiflx4000,jbsiflx_bot,jcalc,jcalflx0100,jcalflx0500,jcalflx1000,jcalflx2000,jcalflx4000, & & jcalflx_bot,jcarflx0100,jcarflx0500,jcarflx1000,jcarflx2000,jcarflx4000,jcarflx_bot, & & jsediffic,jsediffal,jsediffph,jsediffox,jsediffn2,jsediffno3,jsediffsi,jco2flux, & + & jburflxsso12,jburflxsssc12,jburflxssssil,jburflxssster, & & jco2fxd,jco2fxu,jco3,jdic,jdicsat,jdms,jdms_bac,jdms_uv,jdmsflux,jdmsprod,jdoc,jdp,jeps,jexpoca, & & jexport,jexposi,jgrazer,jintdnit,jintnfix,jintphosy,jiralk,jirdet,jirdin,jirdip,jirdoc,jiriron, & & jiron,jirsi,jkwco2,jlvlalkali,jlvlano3,jlvlasize,jlvlbigd14c,jlvlbromo,jlvlcalc,jlvlcalc13, & @@ -79,7 +80,7 @@ SUBROUTINE ACCFIELDS(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask) use mo_control_bgc, only: io_stdo_bgc use mo_param1_bgc, only: ialkali,ian2o,iano3,iatmco2,iatmdms,iatmn2,iatmn2o,iatmo2,icalc,idet,idms,idicsat,idoc,iiron,iopal,& & ioxygen,iphosph,iphy,iprefalk,iprefdic,iprefpo4,iprefo2,isco212,isilica,izoo, & - & irdin,irdip,irsi,iralk,iriron,irdoc,irdet + & irdin,irdip,irsi,iralk,iriron,irdoc,irdet,issso12,isssc12,issssil,issster use mo_m4ago, only: aggregate_diagnostics,kav_dp,kav_rho_p,kav_d_C,kws_agg,kdf_agg,kstickiness_agg,kb_agg, & & kstickiness_frustule,kLmax_agg,kdynvis,kav_rhof_V,kav_por_V #ifdef AGG @@ -327,7 +328,11 @@ SUBROUTINE ACCFIELDS(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask) call accsrf(jsediffox,sedfluxo(1,1,ipowaox),omask,0) call accsrf(jsediffn2,sedfluxo(1,1,ipown2),omask,0) call accsrf(jsediffno3,sedfluxo(1,1,ipowno3),omask,0) - call accsrf(jsediffsi,sedfluxo(1,1,ipowasi),omask,0) + call accsrf(jsediffsi,sedfluxo(1,1,ipowasi),omask,0) + call accsrf(jburflxsso12,sedfluxb(1,1,issso12),omask,0) + call accsrf(jburflxsssc12,sedfluxb(1,1,isssc12),omask,0) + call accsrf(jburflxssssil,sedfluxb(1,1,issssil),omask,0) + call accsrf(jburflxssster,sedfluxb(1,1,issster),omask,0) #endif #if defined(extNcycle) && ! defined(sedbypass) call accsrf(jsediffnh4,sedfluxo(1,1,ipownh4),omask,0) diff --git a/hamocc/mo_bgcmean.F90 b/hamocc/mo_bgcmean.F90 index a2435dfe..82e03539 100644 --- a/hamocc/mo_bgcmean.F90 +++ b/hamocc/mo_bgcmean.F90 @@ -1,4 +1,4 @@ -! Copyright (C) 2002 P. Wetzel +! Copyright (C) 2002 P. setzel ! Copyright (C) 2020 I. Bethke, J. Tjiputra, J. Schwinger, A. Moree, ! P.-G. Chiu, M. Bentsen ! @@ -105,7 +105,9 @@ MODULE mo_bgcmean & FLX_SEDIFFIC =0 ,FLX_SEDIFFAL =0 ,FLX_SEDIFFPH =0 , & & FLX_SEDIFFOX =0 ,FLX_SEDIFFN2 =0 ,FLX_SEDIFFNO3 =0 , & & FLX_SEDIFFSI =0 ,FLX_SEDIFFNH4 =0 ,FLX_SEDIFFN2O =0 , & - & FLX_SEDIFFNO2 =0 , & + & FLX_SEDIFFNO2 =0 , & + & FLX_BURSSO12 =0 ,FLX_BURSSSC12 =0 ,FLX_BURSSSSIL =0 , & + & FLX_BURSSSTER =0 , & & LYR_PHYTO =0 ,LYR_GRAZER =0 ,LYR_DOC =0 , & & LYR_PHOSY =0 ,LYR_PHOSPH =0 ,LYR_OXYGEN =0 , & & LYR_IRON =0 ,LYR_ANO3 =0 ,LYR_ALKALI =0 , & @@ -217,6 +219,8 @@ MODULE mo_bgcmean & FLX_SEDIFFOX ,FLX_SEDIFFN2 ,FLX_SEDIFFNO3 , & & FLX_SEDIFFSI ,FLX_SEDIFFNH4 ,FLX_SEDIFFN2O , & & FLX_SEDIFFNO2 , & + & FLX_BURSSO12 ,FLX_BURSSSC12 ,FLX_BURSSSSIL , & + & FLX_BURSSSTER , & & LYR_PHYTO ,LYR_GRAZER ,LYR_DOC , & & LYR_PHOSY ,LYR_PHOSPH ,LYR_OXYGEN , & & LYR_IRON ,LYR_ANO3 ,LYR_ALKALI , & @@ -389,7 +393,11 @@ MODULE mo_bgcmean & jsediffsi = 0 , & & jsediffnh4 = 0 , & & jsediffn2o = 0 , & - & jsediffno2 = 0 + & jsediffno2 = 0 , & + & jburflxsso12 = 0 , & + & jburflxsssc12 = 0 , & + & jburflxssssil = 0 , & + & jburflxssster = 0 INTEGER, DIMENSION(nbgcmax), SAVE :: & & jsrfnatdic = 0 , & @@ -829,6 +837,14 @@ SUBROUTINE ALLOC_MEM_BGCMEAN(kpie,kpje,kpke) jsediffno3(n)=i_bsc_m2d*min(1,FLX_SEDIFFNO3(n)) IF (FLX_SEDIFFSI(n).GT.0) i_bsc_m2d=i_bsc_m2d+1 jsediffsi(n)=i_bsc_m2d*min(1,FLX_SEDIFFSI(n)) + IF (FLX_BURSSO12(n).GT.0) i_bsc_m2d=i_bsc_m2d+1 + jburflxsso12(n)=i_bsc_m2d*min(1,FLX_BURSSO12(n)) + IF (FLX_BURSSSC12(n).GT.0) i_bsc_m2d=i_bsc_m2d+1 + jburflxsssc12(n)=i_bsc_m2d*min(1,FLX_BURSSSC12(n)) + IF (FLX_BURSSSSIL(n).GT.0) i_bsc_m2d=i_bsc_m2d+1 + jburflxssssil(n)=i_bsc_m2d*min(1,FLX_BURSSSSIL(n)) + IF (FLX_BURSSSTER(n).GT.0) i_bsc_m2d=i_bsc_m2d+1 + jburflxssster(n)=i_bsc_m2d*min(1,FLX_BURSSSTER(n)) #endif #if defined (extNcycle) && ! defined(sedbypass) IF (FLX_SEDIFFNH4(n).GT.0) i_bsc_m2d=i_bsc_m2d+1 diff --git a/hamocc/mo_carbch.F90 b/hamocc/mo_carbch.F90 index 75b35625..d41ab83d 100644 --- a/hamocc/mo_carbch.F90 +++ b/hamocc/mo_carbch.F90 @@ -72,7 +72,8 @@ MODULE mo_carbch REAL, DIMENSION (:,:), ALLOCATABLE :: pn2om REAL, DIMENSION (:,:), ALLOCATABLE :: atdifv REAL, DIMENSION (:,:), ALLOCATABLE :: suppco2 - REAL, DIMENSION (:,:,:), ALLOCATABLE :: sedfluxo + REAL, DIMENSION (:,:,:), ALLOCATABLE :: sedfluxo + REAL, DIMENSION (:,:,:), ALLOCATABLE :: sedfluxb REAL, DIMENSION (:,:), ALLOCATABLE :: pco2d REAL, DIMENSION (:,:), ALLOCATABLE :: pco2m @@ -123,7 +124,7 @@ SUBROUTINE ALLOC_MEM_CARBCH(kpie,kpje,kpke) !****************************************************************************** use mod_xc, only: mnproc use mo_control_bgc, only: io_stdo_bgc - use mo_param1_bgc, only: nocetra,npowtra,natm,nriv + use mo_param1_bgc, only: nocetra,npowtra,nsedtra,natm,nriv INTEGER, intent(in) :: kpie,kpje,kpke INTEGER :: errstat @@ -254,6 +255,17 @@ SUBROUTINE ALLOC_MEM_CARBCH(kpie,kpje,kpke) if(errstat.ne.0) stop 'not enough memory sedfluxo' sedfluxo(:,:,:) = 0.0 + IF (mnproc.eq.1) THEN + WRITE(io_stdo_bgc,*)'Memory allocation for variable sedfluxb ..' + WRITE(io_stdo_bgc,*)'First dimension : ',kpie + WRITE(io_stdo_bgc,*)'Second dimension : ',kpje + WRITE(io_stdo_bgc,*)'Third dimension : ',nsedtra + ENDIF + + ALLOCATE (sedfluxb(kpie,kpje,nsedtra),stat=errstat) + if(errstat.ne.0) stop 'not enough memory sedfluxb' + sedfluxb(:,:,:) = 0.0 + IF (mnproc.eq.1) THEN WRITE(io_stdo_bgc,*)'Memory allocation for variable satn2o ...' WRITE(io_stdo_bgc,*)'First dimension : ',kpie diff --git a/hamocc/ncout_hamocc.F90 b/hamocc/ncout_hamocc.F90 index 2a4a2ecb..917e4328 100644 --- a/hamocc/ncout_hamocc.F90 +++ b/hamocc/ncout_hamocc.F90 @@ -44,8 +44,12 @@ subroutine ncwrt_bgc(iogrp) & flx_sediffic,flx_sediffal,flx_sediffph, & & flx_sediffox,flx_sediffn2,flx_sediffno3, & & flx_sediffsi, & + & flx_bursso12,flx_bursssc12,flx_burssssil, & + & flx_burssster, & & jsediffic,jsediffal,jsediffph,jsediffox, & & jsediffn2,jsediffno3,jsediffsi, & + & jburflxsso12,jburflxsssc12,jburflxssssil, & + & jburflxssster, & & jalkali,jano3,jasize,jatmco2, & & jbsiflx0100,jbsiflx0500,jbsiflx1000, & & jbsiflx2000,jbsiflx4000,jbsiflx_bot, & @@ -657,7 +661,15 @@ subroutine ncwrt_bgc(iogrp) call wrtsrf(jsediffno3(iogrp),FLX_SEDIFFNO3(iogrp), & & rnacc*1e3/dtbgc,0.,cmpflg,'sedfno3',' ',' ',' ') call wrtsrf(jsediffsi(iogrp),FLX_SEDIFFSI(iogrp), & - & rnacc*1e3/dtbgc,0.,cmpflg,'sedfsi',' ',' ',' ') + & rnacc*1e3/dtbgc,0.,cmpflg,'sedfsi',' ',' ',' ') + call wrtsrf(jburflxsso12(iogrp),FLX_BURSSO12(iogrp), & + & rnacc*1e3/dtbgc,0.,cmpflg,'burfsso12',' ',' ',' ') + call wrtsrf(jburflxsssc12(iogrp),FLX_BURSSSC12(iogrp), & + & rnacc*1e3/dtbgc,0.,cmpflg,'burfsssc12',' ',' ',' ') + call wrtsrf(jburflxssssil(iogrp),FLX_BURSSSSIL(iogrp), & + & rnacc*1e3/dtbgc,0.,cmpflg,'burfssssil',' ',' ',' ') + call wrtsrf(jburflxssster(iogrp),FLX_BURSSSTER(iogrp), & + & rnacc*1e3/dtbgc,0.,cmpflg,'burfssster',' ',' ',' ') #endif #if defined(extNcycle) && ! defined(sedbypass) call wrtsrf(jsediffnh4(iogrp),FLX_SEDIFFNH4(iogrp), & @@ -1306,6 +1318,10 @@ subroutine ncwrt_bgc(iogrp) call inisrf(jsediffn2(iogrp),0.) call inisrf(jsediffno3(iogrp),0.) call inisrf(jsediffsi(iogrp),0.) + call inisrf(jburflxsso12(iogrp),0.) + call inisrf(jburflxsssc12(iogrp),0.) + call inisrf(jburflxssssil(iogrp),0.) + call inisrf(jburflxssster(iogrp),0.) #endif #ifdef cisonew call inisrf(jco213fxd(iogrp),0.) @@ -1599,7 +1615,8 @@ subroutine hamoccvardef(iogrp,timeunits,calendar,cmpflg) & flx_bsi_bot,flx_cal0100,flx_cal0500,flx_cal1000,flx_cal2000, & & flx_cal4000,flx_cal_bot,flx_sediffic,flx_sediffal, & & flx_sediffph,flx_sediffox,flx_sediffn2,flx_sediffno3, & - & flx_sediffsi,srf_n2ofx,srf_atmco2,lyr_dp,lyr_dic, & + & flx_sediffsi,flx_bursso12,flx_bursssc12,flx_burssssil,flx_burssster, & + & srf_n2ofx,srf_atmco2,lyr_dp,lyr_dic, & & lyr_alkali,lyr_phosph,lyr_oxygen,lyr_ano3,lyr_silica,lyr_doc, & & lyr_phyto,lyr_grazer,lyr_poc,lyr_calc,lyr_opal,lyr_iron, & & lyr_phosy,lyr_co3,lyr_ph,lyr_omegaa,lyr_omegac,lyr_n2o, & @@ -1841,6 +1858,18 @@ subroutine hamoccvardef(iogrp,timeunits,calendar,cmpflg) call ncdefvar3d(FLX_SEDIFFSI(iogrp),cmpflg,'p','sedfsi', & & 'diffusive silica flux to sediment (positive downwards)', & & ' ','mol Si m-2 s-1',0) + call ncdefvar3d(FLX_BURSSO12(iogrp),cmpflg,'p','burfsso12', & + & 'Organic matter burial flux to burial layer (positive downwards)', & + & ' ','mol P m-2 s-1',0) + call ncdefvar3d(FLX_BURSSSC12(iogrp),cmpflg,'p','burfsssc12', & + & 'CaCO3 burial flux to burial layer (positive downwards)', & + & ' ','mol Ca m-2 s-1',0) + call ncdefvar3d(FLX_BURSSSSIL(iogrp),cmpflg,'p','burfssssil', & + & 'Opal burial flux to burial layer (positive downwards)', & + & ' ','mol Si m-2 s-1',0) + call ncdefvar3d(FLX_BURSSSTER(iogrp),cmpflg,'p','burfssster', & + & 'Clay burial flux to burial layer (positive downwards)', & + & ' ','g m-2 s-1',0) #endif #if defined(extNcycle) && ! defined(sedbypass) call ncdefvar3d(FLX_SEDIFFNH4(iogrp),cmpflg,'p','sedfnh4', & diff --git a/hamocc/sedshi.F90 b/hamocc/sedshi.F90 index 44058447..f3eb8dd2 100644 --- a/hamocc/sedshi.F90 +++ b/hamocc/sedshi.F90 @@ -53,7 +53,8 @@ SUBROUTINE SEDSHI(kpie,kpje,omask) use mo_sedmnt, only: burial,calfa,clafa,oplfa,orgfa,porsol,sedlay,seddw,solfu use mo_biomod, only: rcar - use mo_param1_bgc, only: isssc12,issssil,issso12,issster,ks,nsedtra + use mo_param1_bgc, only: isssc12,issssil,issso12,issster,ks,nsedtra + use mo_carbch, only: sedfluxb #ifdef cisonew use mo_param1_bgc, only: isssc13,isssc14,issso13,issso14 #endif @@ -65,6 +66,8 @@ SUBROUTINE SEDSHI(kpie,kpje,omask) REAL :: sedlo,uebers,seddef,spresent,buried REAL :: refill,frac + + sedfluxb(:,:,:) = 0. ! DOWNWARD SHIFTING ! shift solid sediment sediment downwards, if layer is full, i.e., if ! the volume filled by the four constituents poc, opal, caco3, clay @@ -141,6 +144,7 @@ SUBROUTINE SEDSHI(kpie,kpje,omask) uebers=wsed(i,j)*sedlay(i,j,k,iv) sedlay(i,j,ks ,iv)=sedlay(i,j,ks ,iv)-uebers burial(i,j,iv)=burial(i,j,iv)+uebers*seddw(k)*porsol(i,j,k) + sedfluxb(i,j,iv) = uebers*seddw(k)*porsol(i,j,k) endif enddo !end i-loop enddo !end j-loop @@ -240,6 +244,13 @@ SUBROUTINE SEDSHI(kpie,kpje,omask) burial(i,j,issster) = burial(i,j,issster) & & - refill*burial(i,j,issster) +! account for refluxes to get net-burial fluxes: +! note that this (and before) assumes no reflux of isotopes! - up to change? + sedfluxb(i,j,issso12) = sedfluxb(i,j,issso12) - refill*burial(i,j,issso12) + sedfluxb(i,j,isssc12) = sedfluxb(i,j,isssc12) - refill*burial(i,j,isssc12) + sedfluxb(i,j,issssil) = sedfluxb(i,j,issssil) - refill*burial(i,j,issssil) + sedfluxb(i,j,issster) = sedfluxb(i,j,issster) - refill*burial(i,j,issster) + endif enddo !end i-loop enddo !end j-loop From 55ccf0ebc4b3b381f0ea63b202289e5725a2f774 Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Wed, 30 Nov 2022 11:28:18 +0100 Subject: [PATCH 209/366] Revert accidentially changed name --- hamocc/mo_bgcmean.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/hamocc/mo_bgcmean.F90 b/hamocc/mo_bgcmean.F90 index 82e03539..e9ad8a39 100644 --- a/hamocc/mo_bgcmean.F90 +++ b/hamocc/mo_bgcmean.F90 @@ -1,4 +1,4 @@ -! Copyright (C) 2002 P. setzel +! Copyright (C) 2002 P. Wetzel ! Copyright (C) 2020 I. Bethke, J. Tjiputra, J. Schwinger, A. Moree, ! P.-G. Chiu, M. Bentsen ! From 9a6b1fdf3ef51fd8badf2ae6290aadad12d612f9 Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Wed, 30 Nov 2022 20:40:19 +0100 Subject: [PATCH 210/366] Implemented pNH3 in carchm.F90 --- hamocc/carchm.F90 | 3 +++ hamocc/ncout_hamocc.F90 | 4 ++-- 2 files changed, 5 insertions(+), 2 deletions(-) diff --git a/hamocc/carchm.F90 b/hamocc/carchm.F90 index 168870f6..58fced60 100644 --- a/hamocc/carchm.F90 +++ b/hamocc/carchm.F90 @@ -571,6 +571,9 @@ SUBROUTINE CARCHM(kpie,kpje,kpke,kbnd, & ! surface flux NH3: STILL REQUIRES TO CHECK CONVERSION FACTOR FOR atNH3 (currently assumed atNH3 in pptv) flx_nh3 = Kh_nh3*dtbgc*(atnh3*1e-12*ppao(i,j)*1e-5/(tk*0.08314510) - hstar_nh3*ocetra(i,j,1,ianh4)) ocetra(i,j,1,ianh4) = ocetra(i,j,1,ianh4) + flx_nh3/pddpo(i,j,1) + + ! pNH3 in natm + pnh3m(i,j) = hstar_nh3*ocetra(i,j,1,ianh4) * 8.20573660809596e-5 * (t+273.15) * 1e12 #endif ! Save surface fluxes diff --git a/hamocc/ncout_hamocc.F90 b/hamocc/ncout_hamocc.F90 index 917e4328..2e8bc86d 100644 --- a/hamocc/ncout_hamocc.F90 +++ b/hamocc/ncout_hamocc.F90 @@ -752,7 +752,7 @@ subroutine ncwrt_bgc(iogrp) & rnacc*1e3,0.,cmpflg,'srfnh4', & & 'Surface ammonium',' ','mol N m-3') call wrtsrf(jsrfpnh3m(iogrp),SRF_PNH3M(iogrp),rnacc,0.,cmpflg, & - & 'pnh3m','Surface pNH3 under moist air',' ','uatm') + & 'pnh3m','Surface pNH3 under moist air',' ','natm') call wrtsrf(jsrfano2(iogrp),SRF_ANO2(iogrp), & & rnacc*1e3,0.,cmpflg,'srfno2', & & 'Surface nitrite',' ','mol N m-3') @@ -1940,7 +1940,7 @@ subroutine hamoccvardef(iogrp,timeunits,calendar,cmpflg) #endif #ifdef extNcycle call ncdefvar3d(SRF_PNH3M(iogrp),cmpflg,'p', & - & 'pnh3m','Surface pNH3 moist air',' ','uatm',0) + & 'pnh3m','Surface pNH3 moist air',' ','natm',0) call ncdefvar3d(SRF_ANH4(iogrp),cmpflg,'p','srfnh4', & & 'Surface ammonium',' ','mol N m-3',0) call ncdefvar3d(SRF_ANO2(iogrp),cmpflg,'p','srfno2', & From 0be3f158330bf1f2b25d91967bbb0c1ac9a8c345 Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Wed, 30 Nov 2022 20:43:42 +0100 Subject: [PATCH 211/366] Move from k to ks to be explicit in sedshi.F90 for burial --- hamocc/sedshi.F90 | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/hamocc/sedshi.F90 b/hamocc/sedshi.F90 index f3eb8dd2..c5c7bf3c 100644 --- a/hamocc/sedshi.F90 +++ b/hamocc/sedshi.F90 @@ -141,10 +141,10 @@ SUBROUTINE SEDSHI(kpie,kpje,omask) do i=1,kpie if(omask(i,j).gt.0.5) then !ka if(bolay(i,j).gt.0.) then - uebers=wsed(i,j)*sedlay(i,j,k,iv) + uebers=wsed(i,j)*sedlay(i,j,ks,iv) sedlay(i,j,ks ,iv)=sedlay(i,j,ks ,iv)-uebers - burial(i,j,iv)=burial(i,j,iv)+uebers*seddw(k)*porsol(i,j,k) - sedfluxb(i,j,iv) = uebers*seddw(k)*porsol(i,j,k) + burial(i,j,iv)=burial(i,j,iv)+uebers*seddw(ks)*porsol(i,j,ks) + sedfluxb(i,j,iv) = uebers*seddw(ks)*porsol(i,j,ks) endif enddo !end i-loop enddo !end j-loop From 0ff4d4b413efcdd932748ed6959305d20c10f05e Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Thu, 1 Dec 2022 13:34:52 +0100 Subject: [PATCH 212/366] Rename pnh3m to pnh3 --- cime_config/buildnml | 6 +++--- hamocc/accfields.F90 | 6 +++--- hamocc/carchm.F90 | 6 +++--- hamocc/mo_bgcmean.F90 | 10 +++++----- hamocc/mo_carbch.F90 | 10 +++++----- hamocc/ncout_hamocc.F90 | 16 ++++++++-------- 6 files changed, 27 insertions(+), 27 deletions(-) diff --git a/cime_config/buildnml b/cime_config/buildnml index 680e6d2e..e7dded82 100755 --- a/cime_config/buildnml +++ b/cime_config/buildnml @@ -440,7 +440,7 @@ set SRF_OXFLUX = '0, 2, 2' set SRF_NIFLUX = '0, 2, 2' set SRF_PN2OM = '0, 2, 2' set SRF_N2OFX = '0, 0, 2' -set SRF_PNH3M = '0, 2, 2' +set SRF_PNH3 = '0, 2, 2' set SRF_ANH3FX = '0, 0, 2' set SRF_DMSFLUX = '0, 2, 2' set SRF_DMS = '0, 2, 2' @@ -1717,7 +1717,7 @@ cat >>! $RUNDIR/ocn_in$inststr << EOF ! OXFLUX - Oxygen flux (fgo2) [mol O2 m-2 s-1] ! PN2OM - Surface pN2O under moist air [uatm] ! N2OFX - Nitrous oxide flux [mol N2O m-2 s-1] -! PNH3M - Surface pNH3 under moist air [uatm] +! PNH3 - Surface pNH3 under moist air [natm] ! ANH3FX - Ammonia flux [mol NH3 m-2 s-1] ! DMSFLUX - DMS flux (dmsflux) [mol DMS m-2 s-1] ! DMS - surface DMS concentration (dms) [mol DMS m-3] @@ -1831,7 +1831,7 @@ cat >>! $RUNDIR/ocn_in$inststr << EOF SRF_NIFLUX = $SRF_NIFLUX SRF_PN2OM = $SRF_PN2OM SRF_N2OFX = $SRF_N2OFX - SRF_PNH3M = $SRF_PNH3M + SRF_PNH3 = $SRF_PNH3 SRF_ANH3FX = $SRF_ANH3FX SRF_DMSFLUX = $SRF_DMSFLUX SRF_DMS = $SRF_DMS diff --git a/hamocc/accfields.F90 b/hamocc/accfields.F90 index 9103fae4..a87d1c2d 100644 --- a/hamocc/accfields.F90 +++ b/hamocc/accfields.F90 @@ -118,9 +118,9 @@ SUBROUTINE ACCFIELDS(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask) & jpowno3,jsssc12,jssso12,jssssil,jssster,accbur,accsdm #endif #ifdef extNcycle - use mo_carbch, only: pnh3m + use mo_carbch, only: pnh3 use mo_param1_bgc, only: iatmnh3,ianh4,iano2,ipownh4,ipown2o,ipowno2 - use mo_bgcmean, only: jnh3flux,janh3fx,janh4,jano2,jsrfanh4,jsrfano2,jsrfpnh3m, & + use mo_bgcmean, only: jnh3flux,janh3fx,janh4,jano2,jsrfanh4,jsrfano2,jsrfpnh3, & & jnitr_NH4,jnitr_NO2,jnitr_N2O_prod,jnitr_NH4_OM,jnitr_NO2_OM,jdenit_NO3,jdenit_NO2,jdenit_N2O, & & jDNRA_NO2,janmx_N2_prod,janmx_OM_prod,jphosy_NH4,jphosy_NO3,jremin_aerob,jremin_sulf, & & jpownh4,jpown2o,jpowno2,jsdm_nitr_NH4,jsdm_nitr_NO2,jsdm_nitr_N2O_prod,jsdm_nitr_NH4_OM, & @@ -294,7 +294,7 @@ SUBROUTINE ACCFIELDS(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask) #endif #ifdef extNcycle call accsrf(jsrfanh4,ocetra(1,1,1,ianh4),omask,0) - call accsrf(jsrfpnh3m,pnh3m,omask,0) + call accsrf(jsrfpnh3,pnh3,omask,0) call accsrf(jsrfano2,ocetra(1,1,1,iano2),omask,0) #endif diff --git a/hamocc/carchm.F90 b/hamocc/carchm.F90 index 58fced60..ce856546 100644 --- a/hamocc/carchm.F90 +++ b/hamocc/carchm.F90 @@ -119,7 +119,7 @@ SUBROUTINE CARCHM(kpie,kpje,kpke,kbnd, & use mo_param1_bgc, only: iatmnco2,inatalkali,inatcalc,inatsco212 #endif #ifdef extNcycle - use mo_carbch, only: pnh3m + use mo_carbch, only: pnh3 use mo_param1_bgc, only: iatmnh3,ianh4 use mo_chemcon, only: SV0_air,SV1_air,SV2_air,SV3_air,SV4_air,SD0_air,SD1_air,SD2_air,SD3_air,Vb_nh3,M_nh3,kappa #endif @@ -210,7 +210,7 @@ SUBROUTINE CARCHM(kpie,kpje,kpke,kbnd, & natomegaC(:,:,:)=0. #endif #ifdef extNcycle - pnh3m (:,:)=0. + pnh3 (:,:)=0. #endif !$OMP PARALLEL DO PRIVATE(t,t2,t3,t4,tk,tk100,s,rs,prb,Kh,Khd,K1,K2 & @@ -573,7 +573,7 @@ SUBROUTINE CARCHM(kpie,kpje,kpke,kbnd, & ocetra(i,j,1,ianh4) = ocetra(i,j,1,ianh4) + flx_nh3/pddpo(i,j,1) ! pNH3 in natm - pnh3m(i,j) = hstar_nh3*ocetra(i,j,1,ianh4) * 8.20573660809596e-5 * (t+273.15) * 1e12 + pnh3(i,j) = hstar_nh3*ocetra(i,j,1,ianh4) * 8.20573660809596e-5 * (t+273.15) * 1e12 #endif ! Save surface fluxes diff --git a/hamocc/mo_bgcmean.F90 b/hamocc/mo_bgcmean.F90 index e9ad8a39..1850cc58 100644 --- a/hamocc/mo_bgcmean.F90 +++ b/hamocc/mo_bgcmean.F90 @@ -93,7 +93,7 @@ MODULE mo_bgcmean & SRF_NATCO2FX =0 , & & SRF_ATMBROMO =0 ,SRF_BROMO =0 ,SRF_BROMOFX =0 , & & SRF_ANH4 =0 ,SRF_ANO2 =0 ,SRF_ANH3FX =0 , & - & SRF_PN2OM =0 ,SRF_PNH3M =0 , & + & SRF_PN2OM =0 ,SRF_PNH3 =0 , & & INT_BROMOPRO =0 ,INT_BROMOUV =0 , & & INT_PHOSY =0 ,INT_NFIX =0 ,INT_DNIT =0 , & & FLX_CAR0100 =0 ,FLX_CAR0500 =0 ,FLX_CAR1000 =0 , & @@ -206,7 +206,7 @@ MODULE mo_bgcmean & SRF_NATCO2FX , & & SRF_ATMBROMO ,SRF_BROMO ,SRF_BROMOFX , & & SRF_ANH4 ,SRF_ANO2 ,SRF_ANH3FX , & - & SRF_PN2OM ,SRF_PNH3M , & + & SRF_PN2OM ,SRF_PNH3 , & & INT_BROMOPRO ,INT_BROMOUV , & & INT_PHOSY ,INT_NFIX ,INT_DNIT , & & FLX_CAR0100 ,FLX_CAR0500 ,FLX_CAR1000 , & @@ -416,7 +416,7 @@ MODULE mo_bgcmean & jsrfanh4 = 0 , & & jsrfano2 = 0 , & & jsrfpn2om = 0 , & - & jsrfpnh3m = 0 + & jsrfpnh3 = 0 INTEGER, SAVE :: i_atm_m2d INTEGER, DIMENSION(nbgcmax), SAVE :: & @@ -895,8 +895,8 @@ SUBROUTINE ALLOC_MEM_BGCMEAN(kpie,kpje,kpke) #ifdef extNcycle IF (SRF_ANH3FX(n).GT.0) i_bsc_m2d=i_bsc_m2d+1 janh3fx(n)=i_bsc_m2d*min(1,SRF_ANH3FX(n)) - IF (SRF_PNH3M(n).GT.0) i_bsc_m2d=i_bsc_m2d+1 - jsrfpnh3m(n)=i_bsc_m2d*min(1,SRF_PNH3M(n)) + IF (SRF_PNH3(n).GT.0) i_bsc_m2d=i_bsc_m2d+1 + jsrfpnh3(n)=i_bsc_m2d*min(1,SRF_PNH3(n)) IF (SRF_ANH4(n).GT.0) i_bsc_m2d=i_bsc_m2d+1 jsrfanh4(n)=i_bsc_m2d*min(1,SRF_ANH4(n)) IF (SRF_ANO2(n).GT.0) i_bsc_m2d=i_bsc_m2d+1 diff --git a/hamocc/mo_carbch.F90 b/hamocc/mo_carbch.F90 index d41ab83d..8c887ee6 100644 --- a/hamocc/mo_carbch.F90 +++ b/hamocc/mo_carbch.F90 @@ -112,7 +112,7 @@ MODULE mo_carbch REAL :: atm_bromo, fbro1, fbro2 #endif #ifdef extNcycle - REAL, DIMENSION (:,:), ALLOCATABLE :: pnh3m + REAL, DIMENSION (:,:), ALLOCATABLE :: pnh3 REAL :: atm_nh3,atm_n2o #endif @@ -447,14 +447,14 @@ SUBROUTINE ALLOC_MEM_CARBCH(kpie,kpje,kpke) #endif #ifdef extNcycle IF (mnproc.eq.1) THEN - WRITE(io_stdo_bgc,*)'Memory allocation for variable pnh3m ...' + WRITE(io_stdo_bgc,*)'Memory allocation for variable pnh3 ...' WRITE(io_stdo_bgc,*)'First dimension : ',kpie WRITE(io_stdo_bgc,*)'Second dimension : ',kpje ENDIF - ALLOCATE (pnh3m(kpie,kpje),stat=errstat) - if(errstat.ne.0) stop 'not enough memory pnh3m' - pnh3m(:,:) = 0.0 + ALLOCATE (pnh3(kpie,kpje),stat=errstat) + if(errstat.ne.0) stop 'not enough memory pnh3' + pnh3(:,:) = 0.0 #endif !****************************************************************************** diff --git a/hamocc/ncout_hamocc.F90 b/hamocc/ncout_hamocc.F90 index 2e8bc86d..82cb7aba 100644 --- a/hamocc/ncout_hamocc.F90 +++ b/hamocc/ncout_hamocc.F90 @@ -183,8 +183,8 @@ subroutine ncwrt_bgc(iogrp) & inisdm,inibur,wrtsdm,accbur,accsdm,wrtbur #endif #ifdef extNcycle - use mo_bgcmean, only: janh4,jano2,jlvlanh4,jlvlano2,jsrfanh4,jsrfpnh3m, & - & jsrfano2,janh3fx,srf_pnh3m,srf_anh4,srf_ano2, & + use mo_bgcmean, only: janh4,jano2,jlvlanh4,jlvlano2,jsrfanh4,jsrfpnh3, & + & jsrfano2,janh3fx,srf_pnh3,srf_anh4,srf_ano2, & & srf_anh3fx,lyr_anh4,lyr_ano2,lvl_anh4, & & lvl_ano2, & & LYR_nitr_NH4,LYR_nitr_NO2,LYR_nitr_N2O_prod, & @@ -751,8 +751,8 @@ subroutine ncwrt_bgc(iogrp) call wrtsrf(jsrfanh4(iogrp),SRF_ANH4(iogrp), & & rnacc*1e3,0.,cmpflg,'srfnh4', & & 'Surface ammonium',' ','mol N m-3') - call wrtsrf(jsrfpnh3m(iogrp),SRF_PNH3M(iogrp),rnacc,0.,cmpflg, & - & 'pnh3m','Surface pNH3 under moist air',' ','natm') + call wrtsrf(jsrfpnh3(iogrp),SRF_PNH3(iogrp),rnacc,0.,cmpflg, & + & 'pnh3','Surface pNH3',' ','natm') call wrtsrf(jsrfano2(iogrp),SRF_ANO2(iogrp), & & rnacc*1e3,0.,cmpflg,'srfno2', & & 'Surface nitrite',' ','mol N m-3') @@ -1360,7 +1360,7 @@ subroutine ncwrt_bgc(iogrp) #endif #ifdef extNcycle call inisrf(jsrfanh4(iogrp),0.) - call inisrf(jsrfpnh3m(iogrp),0.) + call inisrf(jsrfpnh3(iogrp),0.) call inisrf(jsrfano2(iogrp),0.) call inisrf(janh3fx(iogrp),0.) #endif @@ -1673,7 +1673,7 @@ subroutine hamoccvardef(iogrp,timeunits,calendar,cmpflg) #endif #ifdef extNcycle use mo_bgcmean, only: janh4,jano2,jlvlanh4,jlvlano2,jsrfanh4, & - & jsrfano2,janh3fx,srf_pnh3m,srf_anh4,srf_ano2, & + & jsrfano2,janh3fx,srf_pnh3,srf_anh4,srf_ano2, & & srf_anh3fx,lyr_anh4,lyr_ano2,lvl_anh4, & & lvl_ano2, & & LYR_nitr_NH4,LYR_nitr_NO2,LYR_nitr_N2O_prod, & @@ -1939,8 +1939,8 @@ subroutine hamoccvardef(iogrp,timeunits,calendar,cmpflg) & 'atmc14','Atmospheric 14CO2',' ','ppm',0) #endif #ifdef extNcycle - call ncdefvar3d(SRF_PNH3M(iogrp),cmpflg,'p', & - & 'pnh3m','Surface pNH3 moist air',' ','natm',0) + call ncdefvar3d(SRF_PNH3(iogrp),cmpflg,'p', & + & 'pnh3','Surface pNH3',' ','natm',0) call ncdefvar3d(SRF_ANH4(iogrp),cmpflg,'p','srfnh4', & & 'Surface ammonium',' ','mol N m-3',0) call ncdefvar3d(SRF_ANO2(iogrp),cmpflg,'p','srfno2', & From 201bb3c51ff135d00eb8a008e9d924841fe3aa04 Mon Sep 17 00:00:00 2001 From: jmaerz <92309038+jmaerz@users.noreply.github.com> Date: Fri, 2 Dec 2022 15:29:28 +0100 Subject: [PATCH 213/366] fixed units and renamed calcium burial to CaCO3 burial (#212) Fixed sediment clay units. --- hamocc/ncout_hamocc.F90 | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/hamocc/ncout_hamocc.F90 b/hamocc/ncout_hamocc.F90 index 8e930519..6293f96b 100644 --- a/hamocc/ncout_hamocc.F90 +++ b/hamocc/ncout_hamocc.F90 @@ -869,18 +869,18 @@ subroutine ncwrt_bgc(iogrp) & 'ssssil','Sediment silicate',' ','mol Si m-3') call wrtsdm(jsssc12(iogrp),SDM_SSSC12(iogrp),rnacc*1e3,0.,cmpflg, & & 'sssc12','Sediment CaCO3',' ','mol C m-3') - call wrtsdm(jssster(iogrp),SDM_SSSTER(iogrp),rnacc*1e3,0.,cmpflg, & - & 'ssster','Sediment clay',' ','mol m-3') + call wrtsdm(jssster(iogrp),SDM_SSSTER(iogrp),rnacc,0.,cmpflg, & + & 'ssster','Sediment clay',' ','kg m-3') ! --- Store sediment burial fields call wrtbur(jburssso12(iogrp),BUR_SSSO12(iogrp),rnacc*1e3,0., & & cmpflg,'buro12','Burial org carbon',' ','mol P m-2') call wrtbur(jbursssc12(iogrp),BUR_SSSC12(iogrp),rnacc*1e3,0., & - & cmpflg,'burc12','Burial calcium ',' ','mol C m-2') + & cmpflg,'burc12','Burial CaCO3',' ','mol C m-2') call wrtbur(jburssssil(iogrp),BUR_SSSSIL(iogrp),rnacc*1e3,0., & & cmpflg,'bursil','Burial silicate',' ','mol Si m-2') - call wrtbur(jburssster(iogrp),BUR_SSSTER(iogrp),rnacc*1e3,0., & - & cmpflg,'burter','Burial clay',' ','mol m-2') + call wrtbur(jburssster(iogrp),BUR_SSSTER(iogrp),rnacc,0., & + & cmpflg,'burter','Burial clay',' ','kg m-2') #endif ! --- close netcdf file @@ -1641,17 +1641,17 @@ subroutine hamoccvardef(iogrp,timeunits,calendar,cmpflg) call ncdefvar3d(SDM_SSSC12(iogrp),cmpflg,'p', & & 'sssc12','Sediment CaCO3',' ','mol C m-3',3) call ncdefvar3d(SDM_SSSTER(iogrp),cmpflg,'p', & - & 'ssster','Sediment clay',' ','mol m-3',3) + & 'ssster','Sediment clay',' ','kg m-3',3) ! --- define sediment burial fields call ncdefvar3d(BUR_SSSO12(iogrp), & & cmpflg,'p','buro12','Burial org carbon',' ','mol P m-2',4) call ncdefvar3d(BUR_SSSC12(iogrp), & - & cmpflg,'p','burc12','Burial calcium ',' ','mol C m-2',4) + & cmpflg,'p','burc12','Burial CaCO3',' ','mol C m-2',4) call ncdefvar3d(BUR_SSSSIL(iogrp), & & cmpflg,'p','bursil','Burial silicate',' ','mol Si m-2',4) call ncdefvar3d(BUR_SSSTER(iogrp), & - & cmpflg,'p','burter','Burial clay',' ','mol m-2',4) + & cmpflg,'p','burter','Burial clay',' ','kg m-2',4) #endif ! --- enddef netcdf file From 1742ed6ba65cfc8e73d717addb0bf1c24fc12eaa Mon Sep 17 00:00:00 2001 From: jmaerz <92309038+jmaerz@users.noreply.github.com> Date: Thu, 15 Sep 2022 16:28:54 +0200 Subject: [PATCH 214/366] Lon-lat variable sediment porosity (#189) Introducing a static 3D sediment porosity field that can be optionally read in with effects on molecular pore water diffusion and shifting. --- hamocc/powach.F90 | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/hamocc/powach.F90 b/hamocc/powach.F90 index ab7ca6fd..fd930fd6 100644 --- a/hamocc/powach.F90 +++ b/hamocc/powach.F90 @@ -374,7 +374,8 @@ subroutine powach(kpie,kpje,kpke,kbnd,prho,omask,psao,lspin) if(powtra(i,j,k,ipowaox) < 3.e-6 .and. powtra(i,j,k,ipowno3) < 3.e-6) then posol = denit * sedlay(i,j,k,issso12) ! remineralization of poc umfa = porsol(i,j,k) / porwat(i,j,k) - sulf(i,k) = posol*umfa !this has P units: kmol P/m3 of pore water + !this overwrites anaerob from denitrification. added =anaerob+..., works + anaerob(i,k) = anaerob(i,k) + posol*umfa !this has P units: kmol P/m3 of pore water #ifdef cisonew rato13 = sedlay(i,j,k,issso13) / (sedlay(i,j,k,issso12)+safediv) rato14 = sedlay(i,j,k,issso14) / (sedlay(i,j,k,issso12)+safediv) From ccbc18e97b034e52425139a3de0f62bac262d71f Mon Sep 17 00:00:00 2001 From: Tomas Torsvik Date: Fri, 5 Aug 2022 15:33:54 +0200 Subject: [PATCH 215/366] Remove redundant definition of kOBL. --- phy/mod_difest.F | 4 ---- 1 file changed, 4 deletions(-) diff --git a/phy/mod_difest.F b/phy/mod_difest.F index e661e8ba..823d0b12 100644 --- a/phy/mod_difest.F +++ b/phy/mod_difest.F @@ -1205,10 +1205,6 @@ subroutine difest_vertical_hyb(m,n,mm,nn,k1m,k1n) . kk, ! (in) Number of levels in array shape . CVMix_kpp_params_user=KPP_params ) ! KPP parameters - ! gets index of the level and interface above hbl - kOBL = CVMix_kpp_compute_kOBL_depth(iFaceHeight, - . cellHeight,OBLdepth(i,j)) - c ---- ccc ------- ! convert m2/s to cm2/s Kv_kpp = Kv_kpp*1e4 From f17e2250cc557d489178b7831aec7cdbf3b8b287 Mon Sep 17 00:00:00 2001 From: Tomas Torsvik Date: Tue, 27 Sep 2022 13:06:03 +0200 Subject: [PATCH 216/366] Redefine kOBL, cast as integer --- phy/mod_difest.F | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/phy/mod_difest.F b/phy/mod_difest.F index 823d0b12..2d2dde96 100644 --- a/phy/mod_difest.F +++ b/phy/mod_difest.F @@ -1161,8 +1161,8 @@ subroutine difest_vertical_hyb(m,n,mm,nn,k1m,k1n) . cellHeight,OBLdepth(i,j)) ! gets index of the level and interface above hbl - kOBL = CVMix_kpp_compute_kOBL_depth(iFaceHeight, - . cellHeight,OBLdepth(i,j)) + kOBL = int(hOBL(i,j)) ! index of interface above OBL depth + c --- ------ Diapycnal mixing when local stability is weak c --- ------ convection routine based on N2 not rho c --- ------ make sure it is in metrics if stability depends on rho From 234097f951d1303b83e49aa0ac3796dd863f3c2c Mon Sep 17 00:00:00 2001 From: jmaerz <92309038+jmaerz@users.noreply.github.com> Date: Tue, 27 Sep 2022 14:50:20 +0200 Subject: [PATCH 217/366] Fixing variable sediment porosity - field initialization in case of `sedbypass=true` (#198) * Removing bodensed - Initialization of sediment parameters and fields now in mo_sedmnt --- hamocc/bodensed.F90 | 193 -------------------------------------- hamocc/dipowa.F90 | 2 +- hamocc/hamocc_init.F90 | 8 +- hamocc/meson.build | 1 - hamocc/mo_sedmnt.F90 | 206 ++++++++++++++++++++++++++++++++++++++--- 5 files changed, 200 insertions(+), 210 deletions(-) delete mode 100644 hamocc/bodensed.F90 diff --git a/hamocc/bodensed.F90 b/hamocc/bodensed.F90 deleted file mode 100644 index 74cb9335..00000000 --- a/hamocc/bodensed.F90 +++ /dev/null @@ -1,193 +0,0 @@ -! Copyright (C) 2001 Ernst Maier-Reimer, S. Legutke -! Copyright (C) 2020 J. Schwinger -! -! This file is part of BLOM/iHAMOCC. -! -! 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 https://www.gnu.org/licenses/. - - -subroutine bodensed(kpie,kpje,kpke,pddpo,omask,sed_por) -!********************************************************************** -! -!**** *BODENSED* - . -! -! Ernst Maier-Reimer, *MPI-Met, HH* 10.04.01 -! -! Modified -! -------- -! S.Legutke, *MPI-MaD, HH* 10.04.01 -! -! Purpose -! ------- -! set up of sediment layer. -! -! -!** Interface to ocean model (parameter list): -! ----------------------------------------- -! -! *INTEGER* *kpie* - 1st dimension of model grid. -! *INTEGER* *kpje* - 2nd dimension of model grid. -! *INTEGER* *kpke* - 3rd (vertical) dimension of model grid. -! *REAL* *pddpo* - size of scalar grid cell (3rd dimension) [m]. -! -!********************************************************************** - - use mo_sedmnt, only: calcwei,calfa,clafa,claydens,calcdens,opaldens,opalwei,oplfa,orgdens,orgfa,seddzi,porwat,porwah, & - & porsol,dzs,seddw,sedict,solfu,orgwei,zcoefsu,zcoeflo,disso_sil,silsat,disso_poc,sed_denit,disso_caco3 - use mo_control_bgc, only: dtbgc,io_stdo_bgc,l_3Dvarsedpor - use mo_param1_bgc, only: ks - use mod_xc, only: mnproc - - implicit none - - integer, intent(in) :: kpie,kpje,kpke - real, intent(in) :: pddpo(kpie,kpje,kpke) - real, intent(in) :: omask(kpie,kpje) - real, intent(in) :: sed_por(kpie,kpje,ks) - - ! Local variables - integer :: i,j,k - real :: sumsed - - dzs(1) = 0.001 - dzs(2) = 0.003 - dzs(3) = 0.005 - dzs(4) = 0.007 - dzs(5) = 0.009 - dzs(6) = 0.011 - dzs(7) = 0.013 - dzs(8) = 0.015 - dzs(9) = 0.017 - dzs(10) = 0.019 - dzs(11) = 0.021 - dzs(12) = 0.023 - dzs(13) = 0.025 - - if (mnproc == 1) then - write(io_stdo_bgc,*) ' ' - write(io_stdo_bgc,*) 'Sediment layer thickness [m] : ' - write(io_stdo_bgc,'(5F9.3)') dzs - write(io_stdo_bgc,*) ' ' - endif - - ! this initialization can be done later via reading a porosity map - if (l_3Dvarsedpor)then - ! lon-lat variable sediment porosity from input file - do k=1,ks - do j=1,kpje - do i=1,kpie - if(omask(i,j).gt. 0.5)then - porwat(i,j,k) = sed_por(i,j,k) - endif - enddo - enddo - enddo - else - porwat(:,:,1) = 0.85 - porwat(:,:,2) = 0.83 - porwat(:,:,3) = 0.8 - porwat(:,:,4) = 0.79 - porwat(:,:,5) = 0.77 - porwat(:,:,6) = 0.75 - porwat(:,:,7) = 0.73 - porwat(:,:,8) = 0.7 - porwat(:,:,9) = 0.68 - porwat(:,:,10) = 0.66 - porwat(:,:,11) = 0.64 - porwat(:,:,12) = 0.62 - endif - - if (mnproc == 1) then - write(io_stdo_bgc,*) 'Pore water in sediment initialized' - endif - - seddzi(1) = 500. - do k = 1, ks - seddzi(k+1) = 1. / dzs(k+1) - seddw(k) = 0.5 * (dzs(k) + dzs(k+1)) - do j = 1, kpje - do i = 1, kpie - porsol(i,j,k) = 1. - porwat(i,j,k) - if(k >= 2) porwah(i,j,k) = 0.5 * (porwat(i,j,k) + porwat(i,j,k-1)) - if(k == 1) porwah(i,j,k) = 0.5 * (1. + porwat(i,j,1)) - enddo - enddo - enddo - - sedict = 1.e-9 * dtbgc ! Molecular diffusion coefficient - ! Dissolution rate constant of opal (disso) [1/(kmol Si(OH)4/m3)*1/sec] - ! THIS NEEDS TO BE CHANGED TO disso=3.e-8! THIS IS ONLY KEPT FOR THE MOMENT - ! FOR BACKWARDS COMPATIBILITY - !disso_sil = 3.e-8*dtbgc ! (2011-01-04) EMR - !disso_sil = 1.e-6*dtbgc ! test vom 03.03.04 half live sil ca. 20.000 yr - disso_sil = 1.e-6*dtbgc - ! Silicate saturation concentration is 1 mol/m3 - silsat = 0.001 - - ! Degradation rate constant of POP (disso) [1/(kmol O2/m3)*1/sec] - disso_poc = 0.01 / 86400. * dtbgc ! disso=3.e-5 was quite high - - ! Denitrification rate constant of POP (disso) [1/sec] - sed_denit = 0.01/86400. * dtbgc - - ! Dissolution rate constant of CaCO3 (disso) [1/(kmol CO3--/m3)*1/sec] - disso_caco3 = 1.e-7 * dtbgc - -! ****************************************************************** -! densities etc. for SEDIMENT SHIFTING - -! define weight of calcium carbonate, opal, and poc [kg/kmol] - calcwei = 100. ! 40+12+3*16 kg/kmol C - opalwei = 60. ! 28 + 2*16 kg/kmol Si - orgwei = 30. ! from 12 kg/kmol * 2.5 POC[kg]/DW[kg] - ! after Alldredge, 1998: - ! POC(g)/DW(g) = 0.4 of diatom marine snow, size 1mm3 - -! define densities of opal, caco3, poc [kg/m3] - calcdens = 2600. - opaldens = 2200. - orgdens = 1000. - claydens = 2600. !quartz - -! define volumes occupied by solid constituents [m3/kmol] - calfa = calcwei / calcdens - oplfa = opalwei / opaldens - orgfa = orgwei / orgdens - clafa = 1. / claydens !clay is calculated in kg/m3 - -! determine total solid sediment volume - solfu = 0. - do i = 1, kpie - do j = 1, kpje - do k = 1, ks - solfu(i,j) = solfu(i,j) + seddw(k) * porsol(i,j,k) - enddo - enddo - enddo - -! Initialize porosity-dependent diffusion coefficients of sediment - zcoefsu(:,:,0) = 0.0 - do k = 1,ks - do j = 1, kpje - do i = 1, kpie - ! sediment diffusion coefficient * 1/dz * fraction of pore water at half depths - zcoefsu(i,j,k ) = -sedict * seddzi(k) * porwah(i,j,k) - zcoeflo(i,j,k-1) = -sedict * seddzi(k) * porwah(i,j,k) ! why the same ? - enddo - enddo - enddo - zcoeflo(:,:,ks) = 0.0 ! diffusion coefficient for bottom sediment layer - - -end subroutine bodensed diff --git a/hamocc/dipowa.F90 b/hamocc/dipowa.F90 index e6fb22a2..f601b33b 100644 --- a/hamocc/dipowa.F90 +++ b/hamocc/dipowa.F90 @@ -40,7 +40,7 @@ subroutine dipowa(kpie,kpje,kpke,omask,lspin) ! Method ! ------- ! implicit formulation; -! constant diffusion coefficient : 1.e-9 set in BODENSED. +! constant diffusion coefficient : 1.e-9 set in ini_sedmnt in mo_sedmnt ! diffusion coefficient : zcoefsu/zcoeflo for upper/lower ! sediment layer boundary. ! diff --git a/hamocc/hamocc_init.F90 b/hamocc/hamocc_init.F90 index f7f2dcf3..72e05a36 100644 --- a/hamocc/hamocc_init.F90 +++ b/hamocc/hamocc_init.F90 @@ -47,10 +47,10 @@ subroutine hamocc_init(read_rest,rstfnm_hamocc) & sedspin_yr_s,sedspin_yr_e,sedspin_ncyc, & & dtb,dtbgc,io_stdo_bgc,ldtbgc, & & ldtrunbgc,ndtdaybgc,with_dmsph,l_3Dvarsedpor - use mo_param1_bgc, only: ks,nsedtra,npowtra,init_por2octra_mapping + use mo_param1_bgc, only: ks,init_por2octra_mapping use mo_carbch, only: alloc_mem_carbch,ocetra,atm,atm_co2 use mo_biomod, only: alloc_mem_biomod - use mo_sedmnt, only: alloc_mem_sedmnt,sedlay,powtra,burial + use mo_sedmnt, only: alloc_mem_sedmnt,sedlay,powtra,burial,ini_sedmnt use mo_vgrid, only: alloc_mem_vgrid,set_vgrid use mo_bgcmean, only: alloc_mem_bgcmean use mo_read_rivin, only: ini_read_rivin,rivinfile @@ -176,9 +176,9 @@ subroutine hamocc_init(read_rest,rstfnm_hamocc) call set_vgrid(idm,jdm,kdm,bgc_dp) ! ! --- Initialize sediment layering - ! First raed the porosity, then apply it in bodensed + ! First read the porosity, then apply it in ini_sedmnt CALL read_sedpor(idm,jdm,ks,omask,sed_por) - CALL BODENSED(idm,jdm,kdm,bgc_dp,omask,sed_por) + CALL ini_sedmnt(idm,jdm,kdm,omask,sed_por) ! ! --- Initialize parameters, sediment and ocean tracer. ! diff --git a/hamocc/meson.build b/hamocc/meson.build index acc6319d..cc6b7433 100644 --- a/hamocc/meson.build +++ b/hamocc/meson.build @@ -4,7 +4,6 @@ sources += files( 'aufw_bgc.F90', 'beleg_parm.F90', 'beleg_vars.F90', - 'bodensed.F90', 'carchm.F90', 'carchm_kequi.F90', 'carchm_solve.F90', diff --git a/hamocc/mo_sedmnt.F90 b/hamocc/mo_sedmnt.F90 index a1286f22..7fab49b4 100644 --- a/hamocc/mo_sedmnt.F90 +++ b/hamocc/mo_sedmnt.F90 @@ -17,7 +17,7 @@ ! along with BLOM. If not, see https://www.gnu.org/licenses/. - MODULE mo_sedmnt + MODULE mo_sedmnt !****************************************************************************** ! ! MODULE mo_sedmnt - Variables for sediment modules. @@ -32,6 +32,7 @@ MODULE mo_sedmnt ! Purpose ! ------- ! - declaration and memory allocation +! - initialization of sediment ! ! Description: ! ------------ @@ -62,8 +63,15 @@ MODULE mo_sedmnt ! *ansed* *REAL* - . ! *o2ut* *REAL* - . ! +! -subroutine ini_sedmnt +! Initialize sediment parameters (some are also used in water column) +! -subroutine ini_sedmnt_fields +! Initialize 2D and 3D sediment fields +! !****************************************************************************** - use mo_param1_bgc, only: ks,ksp,nsedtra,npowtra + use mo_param1_bgc, only: ks,ksp,nsedtra,npowtra + use mo_control_bgc, only: io_stdo_bgc + use mod_xc, only: mnproc implicit none @@ -97,16 +105,192 @@ MODULE mo_sedmnt REAL :: calfa, oplfa, orgfa, clafa REAL :: disso_sil,silsat,disso_poc,sed_denit,disso_caco3 - CONTAINS + CONTAINS + + !======================================================================== + SUBROUTINE ini_sedmnt(kpie,kpje,kpke,omask,sed_por) + use mo_control_bgc, only: dtbgc + implicit none - SUBROUTINE ALLOC_MEM_SEDMNT(kpie,kpje) -!****************************************************************************** -! ALLOC_MEM_SEDMNT - Allocate variables in this module -!****************************************************************************** - use mod_xc, only: mnproc - use mo_control_bgc, only: io_stdo_bgc + integer, intent(in) :: kpie,kpje,kpke + real, intent(in) :: omask(kpie,kpje) + real, intent(in) :: sed_por(kpie,kpje,ks) + + integer :: k + + sedict = 1.e-9 * dtbgc ! Molecular diffusion coefficient + ! Dissolution rate constant of opal (disso) [1/(kmol Si(OH)4/m3)*1/sec] + ! THIS NEEDS TO BE CHANGED TO disso=3.e-8! THIS IS ONLY KEPT FOR THE MOMENT + ! FOR BACKWARDS COMPATIBILITY + !disso_sil = 3.e-8*dtbgc ! (2011-01-04) EMR + !disso_sil = 1.e-6*dtbgc ! test vom 03.03.04 half live sil ca. 20.000 yr + disso_sil = 1.e-6*dtbgc + ! Silicate saturation concentration is 1 mol/m3 + silsat = 0.001 + + ! Degradation rate constant of POP (disso) [1/(kmol O2/m3)*1/sec] + disso_poc = 0.01 / 86400. * dtbgc ! disso=3.e-5 was quite high + + ! Denitrification rate constant of POP (disso) [1/sec] + sed_denit = 0.01/86400. * dtbgc + + ! Dissolution rate constant of CaCO3 (disso) [1/(kmol CO3--/m3)*1/sec] + disso_caco3 = 1.e-7 * dtbgc + + ! ****************************************************************** + ! densities etc. for SEDIMENT SHIFTING + + ! define weight of calcium carbonate, opal, and poc [kg/kmol] + calcwei = 100. ! 40+12+3*16 kg/kmol C + opalwei = 60. ! 28 + 2*16 kg/kmol Si + orgwei = 30. ! from 12 kg/kmol * 2.5 POC[kg]/DW[kg] + ! after Alldredge, 1998: + ! POC(g)/DW(g) = 0.4 of diatom marine snow, size 1mm3 + + ! define densities of opal, caco3, poc [kg/m3] + calcdens = 2600. + opaldens = 2200. + orgdens = 1000. + claydens = 2600. !quartz + + ! define volumes occupied by solid constituents [m3/kmol] + calfa = calcwei / calcdens + oplfa = opalwei / opaldens + orgfa = orgwei / orgdens + clafa = 1. / claydens !clay is calculated in kg/m3 + + ! sediment layer thickness + dzs(1) = 0.001 + dzs(2) = 0.003 + dzs(3) = 0.005 + dzs(4) = 0.007 + dzs(5) = 0.009 + dzs(6) = 0.011 + dzs(7) = 0.013 + dzs(8) = 0.015 + dzs(9) = 0.017 + dzs(10) = 0.019 + dzs(11) = 0.021 + dzs(12) = 0.023 + dzs(13) = 0.025 + + if (mnproc == 1) then + write(io_stdo_bgc,*) ' ' + write(io_stdo_bgc,*) 'Sediment layer thickness [m] : ' + write(io_stdo_bgc,'(5F9.3)') dzs + write(io_stdo_bgc,*) ' ' + endif + + seddzi(1) = 500. + do k = 1, ks + seddzi(k+1) = 1. / dzs(k+1) ! inverse of grid cell size + seddw(k) = 0.5 * (dzs(k) + dzs(k+1)) ! distance between grid cell centers (pressure points) + enddo + +#ifndef sedbypass + ! 2d and 3d fields are not allocated in case of sedbypass + ! so only initialize them if we are using the sediment + CALL ini_sedmnt_por(kpie,kpje,kpke,omask,sed_por) +#endif + END SUBROUTINE ini_sedmnt + + !======================================================================== + SUBROUTINE ini_sedmnt_por(kpie,kpje,kpke,omask,sed_por) + ! + ! Initialization of: + ! - 3D porosity field (cell center and cell boundaries) + ! - solid volume fraction at cell center + ! - vertical molecular diffusion coefficients scaled with porosity + ! + use mo_control_bgc, only: l_3Dvarsedpor + + implicit none + + integer, intent(in) :: kpie,kpje,kpke + real, intent(in) :: omask(kpie,kpje) + real, intent(in) :: sed_por(kpie,kpje,ks) + + ! local + integer :: i,j,k + + ! this initialization can be done via reading a porosity map + ! porwat is the poroisty at the (pressure point) center of the grid cell + if (l_3Dvarsedpor)then + ! lon-lat variable sediment porosity from input file + do k=1,ks + do j=1,kpje + do i=1,kpie + if(omask(i,j).gt. 0.5)then + porwat(i,j,k) = sed_por(i,j,k) + endif + enddo + enddo + enddo + else + porwat(:,:,1) = 0.85 + porwat(:,:,2) = 0.83 + porwat(:,:,3) = 0.8 + porwat(:,:,4) = 0.79 + porwat(:,:,5) = 0.77 + porwat(:,:,6) = 0.75 + porwat(:,:,7) = 0.73 + porwat(:,:,8) = 0.7 + porwat(:,:,9) = 0.68 + porwat(:,:,10) = 0.66 + porwat(:,:,11) = 0.64 + porwat(:,:,12) = 0.62 + endif + + if (mnproc == 1) then + write(io_stdo_bgc,*) 'Pore water in sediment initialized' + endif + + do k = 1, ks + do j = 1, kpje + do i = 1, kpie + porsol(i,j,k) = 1. - porwat(i,j,k) ! solid volume fraction at grid center + if(k >= 2) porwah(i,j,k) = 0.5 * (porwat(i,j,k) + porwat(i,j,k-1)) ! porosity at cell interfaces + if(k == 1) porwah(i,j,k) = 0.5 * (1. + porwat(i,j,1)) + enddo + enddo + enddo + + ! determine total solid sediment volume + solfu = 0. + do i = 1, kpie + do j = 1, kpje + do k = 1, ks + solfu(i,j) = solfu(i,j) + seddw(k) * porsol(i,j,k) + enddo + enddo + enddo + + ! Initialize porosity-dependent diffusion coefficients of sediment + zcoefsu(:,:,0) = 0.0 + do k = 1,ks + do j = 1, kpje + do i = 1, kpie + ! sediment diffusion coefficient * 1/dz * fraction of pore water at half depths + zcoefsu(i,j,k ) = -sedict * seddzi(k) * porwah(i,j,k) + zcoeflo(i,j,k-1) = -sedict * seddzi(k) * porwah(i,j,k) ! why the same ? + enddo + enddo + enddo + zcoeflo(:,:,ks) = 0.0 ! diffusion coefficient for bottom sediment layer + if (mnproc == 1) then + write(io_stdo_bgc,*) 'Pore water diffusion coefficients in sediment initialized' + endif + + END SUBROUTINE ini_sedmnt_por + + + !======================================================================== + SUBROUTINE ALLOC_MEM_SEDMNT(kpie,kpje) + !****************************************************************************** + ! ALLOC_MEM_SEDMNT - Allocate variables in this module + !****************************************************************************** INTEGER, intent(in) :: kpie,kpje INTEGER :: errstat @@ -290,6 +474,6 @@ SUBROUTINE ALLOC_MEM_SEDMNT(kpie,kpje) !****************************************************************************** - END SUBROUTINE ALLOC_MEM_SEDMNT + END SUBROUTINE ALLOC_MEM_SEDMNT - END MODULE mo_sedmnt + END MODULE mo_sedmnt From a981e561046d0c395d6f867673db720e1cedcdda Mon Sep 17 00:00:00 2001 From: Tomas Torsvik <43031053+TomasTorsvik@users.noreply.github.com> Date: Mon, 3 Oct 2022 13:41:18 +0200 Subject: [PATCH 218/366] Hamocc hybrid coord2 (#179) Make the surface mixed layer depth fractional index `hOBL` available for use in iHAMOCC, and adjust the internal iHAMOCC index `kmle` according to `hOBL`. Default value `kmle = 2` is retained for consistency with isopycnic coordinates. --- hamocc/beleg_vars.F90 | 10 ++--- hamocc/carchm.F90 | 11 +++-- hamocc/cyano.F90 | 87 ++++++++++++++++++--------------------- hamocc/mo_apply_rivin.F90 | 22 +++++----- hamocc/mo_intfcblom.F90 | 9 +++- hamocc/mo_vgrid.F90 | 19 +++++++-- hamocc/ocprod.F90 | 4 +- hamocc/preftrc.F90 | 38 ++++++++--------- phy/mod_difest.F | 10 ++++- 9 files changed, 112 insertions(+), 98 deletions(-) diff --git a/hamocc/beleg_vars.F90 b/hamocc/beleg_vars.F90 index 22cd8dc4..f7d68963 100644 --- a/hamocc/beleg_vars.F90 +++ b/hamocc/beleg_vars.F90 @@ -220,18 +220,16 @@ SUBROUTINE BELEG_VARS(kpaufr,kpie,kpje,kpke,kbnd,pddpo,prho,omask, & ! Initialise preformed tracers in the mixed layer; note that the ! whole field has been initialised to zero above - DO k=1,kmle DO j=1,kpje DO i=1,kpie IF(omask(i,j) .GT. 0.5) THEN - ocetra(i,j,k,iprefo2) =ocetra(i,j,k,ioxygen) - ocetra(i,j,k,iprefpo4)=ocetra(i,j,k,iphosph) - ocetra(i,j,k,iprefalk)=ocetra(i,j,k,ialkali) - ocetra(i,j,k,iprefdic)=ocetra(i,j,k,isco212) + ocetra(i,j,1:kmle(i,j),iprefo2) = ocetra(i,j,1:kmle(i,j),ioxygen) + ocetra(i,j,1:kmle(i,j),iprefpo4) = ocetra(i,j,1:kmle(i,j),iphosph) + ocetra(i,j,1:kmle(i,j),iprefalk) = ocetra(i,j,1:kmle(i,j),ialkali) + ocetra(i,j,1:kmle(i,j),iprefdic) = ocetra(i,j,1:kmle(i,j),isco212) ENDIF ENDDO ENDDO - ENDDO ! Initial values for sediment diff --git a/hamocc/carchm.F90 b/hamocc/carchm.F90 index d86013b8..bab04daf 100644 --- a/hamocc/carchm.F90 +++ b/hamocc/carchm.F90 @@ -96,11 +96,11 @@ SUBROUTINE CARCHM(kpie,kpje,kpke,kbnd, & !********************************************************************** use mo_carbch, only: atm,atmflx,co2fxd,co2fxu,co2star,co3,hi,keqb,kwco2sol,ocetra,omegaa,omegac,pco2d,satn2o,satoxy use mo_chemcon, only: al1,al2,al3,al4,an0,an1,an2,an3,an4,an5,an6,atn2o,bl1,bl2,bl3,calcon,ox0,ox1,ox2,ox3,ox4,ox5,ox6, & - & oxyco,tzero - use mo_control_bgc, only: dtbgc + & oxyco,tzero + use mo_control_bgc, only: dtbgc use mo_param1_bgc, only: ialkali,iatmo2,iatmco2,iatmdms,iatmn2,iatmn2o,ian2o,icalc,idicsat,idms,igasnit,ioxygen,iphosph, & - & isco212,isilica - use mo_vgrid, only: dp_min,kbo,ptiestu + & isco212,isilica + use mo_vgrid, only: dp_min,kmle,kbo,ptiestu #ifdef BROMO use mo_param1_bgc, only: iatmbromo,ibromo @@ -390,8 +390,7 @@ SUBROUTINE CARCHM(kpie,kpje,kpke,kbnd, & ta = ocetra(i,j,k,ialkali) / rrho CALL carchm_solve_DICsat(s,atco2*rpp0,ta,sit,pt,Kh,K1,K2,Kb,Kw,Ks1,Kf, & Ksi,K1p,K2p,K3p,tc_sat,niter) - ocetra(i,j,k, idicsat)=tc_sat * rrho ! convert mol/kg to kmol/m^3 - ocetra(i,j,k+1,idicsat)=tc_sat * rrho ! k+1 = the rest of the mixed layer + ocetra(i,j,1:kmle(i,j),idicsat) = tc_sat * rrho ! convert mol/kg to kmlo/m^3 #ifdef cisonew ! Ocean-Atmosphere fluxes for carbon isotopes diff --git a/hamocc/cyano.F90 b/hamocc/cyano.F90 index e39fa678..f3f696df 100644 --- a/hamocc/cyano.F90 +++ b/hamocc/cyano.F90 @@ -17,7 +17,7 @@ ! along with BLOM. If not, see https://www.gnu.org/licenses/. - SUBROUTINE CYANO(kpie,kpje,kpke,kbnd,pddpo,omask,ptho) +SUBROUTINE CYANO(kpie,kpje,kpke,kbnd,pddpo,omask,ptho) !********************************************************************** ! !**** *CYANO* - . @@ -61,74 +61,69 @@ SUBROUTINE CYANO(kpie,kpje,kpke,kbnd,pddpo,omask,ptho) ! . !********************************************************************** - use mo_carbch, only: ocetra - use mo_biomod, only: bluefix,intnfix,rnit,tf0,tf1,tf2,tff - use mo_param1_bgc, only: ialkali,iano3,igasnit,iphosph,ioxygen - use mo_vgrid, only: kmle + use mo_carbch, only: ocetra + use mo_biomod, only: bluefix,intnfix,rnit,tf0,tf1,tf2,tff + use mo_param1_bgc, only: ialkali,iano3,igasnit,iphosph,ioxygen + use mo_vgrid, only: kmle #ifdef natDIC - use mo_param1_bgc, only: inatalkali + use mo_param1_bgc, only: inatalkali #endif - implicit none + implicit none - INTEGER, intent(in) :: kpie,kpje,kpke,kbnd - REAL, intent(in) :: pddpo(kpie,kpje,kpke) - REAL, intent(in) :: omask(kpie,kpje) - REAL, intent(in) :: ptho(1-kbnd:kpie+kbnd,1-kbnd:kpje+kbnd,kpke) + INTEGER, intent(in) :: kpie,kpje,kpke,kbnd + REAL, intent(in) :: pddpo(kpie,kpje,kpke) + REAL, intent(in) :: omask(kpie,kpje) + REAL, intent(in) :: ptho(1-kbnd:kpie+kbnd,1-kbnd:kpje+kbnd,kpke) - ! Local variables - INTEGER :: i,j,k - REAL :: oldocetra,dano3 - REAL :: ttemp,nfixtfac + ! Local variables + INTEGER :: i,j,k + REAL :: oldocetra,dano3 + REAL :: ttemp,nfixtfac + + intnfix(:,:)=0.0 - intnfix(:,:)=0.0 - ! -! N-fixation by cyano bacteria (followed by remineralisation and nitrification), +! N-fixation by cyano bacteria (followed by remineralisation and nitrification), ! it is assumed here that this process is limited to the mixed layer ! - DO k=1,kmle -!$OMP PARALLEL DO PRIVATE(i,oldocetra,dano3,ttemp,nfixtfac) - DO j=1,kpje - DO i=1,kpie - IF(omask(i,j).gt.0.5) THEN - IF(ocetra(i,j,k,iano3).LT.(rnit*ocetra(i,j,k,iphosph))) THEN + DO j=1,kpje + DO i=1,kpie + IF(omask(i,j).gt.0.5) THEN + DO k=1,kmle(i,j) + IF(ocetra(i,j,k,iano3).LT.(rnit*ocetra(i,j,k,iphosph))) THEN - oldocetra = ocetra(i,j,k,iano3) - ttemp = min(40.,max(-3.,ptho(i,j,k))) + oldocetra = ocetra(i,j,k,iano3) + ttemp = min(40.,max(-3.,ptho(i,j,k))) ! Temperature dependence of nitrogen fixation, Kriest and Oschlies 2015. - nfixtfac = MAX(0.0,tf2*ttemp*ttemp + tf1*ttemp + tf0)/tff + nfixtfac = MAX(0.0,tf2*ttemp*ttemp + tf1*ttemp + tf0)/tff - ocetra(i,j,k,iano3)=ocetra(i,j,k,iano3)*(1-bluefix*nfixtfac) & - & +bluefix*nfixtfac*rnit*ocetra(i,j,k,iphosph) + ocetra(i,j,k,iano3)=ocetra(i,j,k,iano3)*(1-bluefix*nfixtfac) & + & + bluefix*nfixtfac*rnit*ocetra(i,j,k,iphosph) - dano3=ocetra(i,j,k,iano3)-oldocetra + dano3=ocetra(i,j,k,iano3)-oldocetra - ocetra(i,j,k,igasnit)=ocetra(i,j,k,igasnit)-dano3*(1./2.) + ocetra(i,j,k,igasnit)=ocetra(i,j,k,igasnit)-dano3*(1./2.) ! Note: to fix one mole N2 requires: N2+H2O+y*O2 = 2* HNO3 <-> y=2.5 mole O2. ! I.e., to release one mole HNO3 = H+ + NO3- requires 1.25 mole O2 - ocetra(i,j,k,ioxygen)=ocetra(i,j,k,ioxygen)-dano3*1.25 + ocetra(i,j,k,ioxygen)=ocetra(i,j,k,ioxygen)-dano3*1.25 ! Nitrogen fixation followed by remineralisation and nitrification decreases ! alkalinity by 1 mole per mole nitrogen fixed (Wolf-Gladrow et al. 2007) - ocetra(i,j,k,ialkali)=ocetra(i,j,k,ialkali)-dano3 + ocetra(i,j,k,ialkali)=ocetra(i,j,k,ialkali)-dano3 #ifdef natDIC - ocetra(i,j,k,inatalkali)=ocetra(i,j,k,inatalkali)-dano3 + ocetra(i,j,k,inatalkali)=ocetra(i,j,k,inatalkali)-dano3 #endif - intnfix(i,j) = intnfix(i,j) + & - & (ocetra(i,j,k,iano3)-oldocetra)*pddpo(i,j,k) - - ENDIF - ENDIF - ENDDO - ENDDO -!$OMP END PARALLEL DO - ENDDO - + intnfix(i,j) = intnfix(i,j) + & + & (ocetra(i,j,k,iano3)-oldocetra)*pddpo(i,j,k) + ENDIF + ENDDO + ENDIF + ENDDO + ENDDO - RETURN - END +END SUBROUTINE CYANO diff --git a/hamocc/mo_apply_rivin.F90 b/hamocc/mo_apply_rivin.F90 index 697990d1..0dfbc528 100644 --- a/hamocc/mo_apply_rivin.F90 +++ b/hamocc/mo_apply_rivin.F90 @@ -120,28 +120,28 @@ subroutine apply_rivin(kpie,kpje,kpke,pddpo,omask,rivin) ! Distribute riverine inputs over the model mixed layer volij = 0. - DO k=1,kmle + DO k=1,kmle(i,j) volij=volij+pddpo(i,j,k) ENDDO ! DIC is updated using the assumtions that a_t=a_c+a_n and DIC=a_c (a_t: total ! alkalinity, a_c: carbonate alkalinity, a_n: contribution of nutrients to a_t). - ocetra(i,j,1:kmle,iano3) = ocetra(i,j,1:kmle,iano3) + rivin(i,j,irdin)*fdt/volij - ocetra(i,j,1:kmle,iphosph) = ocetra(i,j,1:kmle,iphosph) + rivin(i,j,irdip)*fdt/volij - ocetra(i,j,1:kmle,isilica) = ocetra(i,j,1:kmle,isilica) + rivin(i,j,irsi) *fdt/volij - ocetra(i,j,1:kmle,isco212) = ocetra(i,j,1:kmle,isco212) + rivin(i,j,iralk)*fdt/volij & + ocetra(i,j,1:kmle(i,j),iano3) = ocetra(i,j,1:kmle(i,j),iano3) + rivin(i,j,irdin)*fdt/volij + ocetra(i,j,1:kmle(i,j),iphosph) = ocetra(i,j,1:kmle(i,j),iphosph) + rivin(i,j,irdip)*fdt/volij + ocetra(i,j,1:kmle(i,j),isilica) = ocetra(i,j,1:kmle(i,j),isilica) + rivin(i,j,irsi) *fdt/volij + ocetra(i,j,1:kmle(i,j),isco212) = ocetra(i,j,1:kmle(i,j),isco212) + rivin(i,j,iralk)*fdt/volij & + rivin(i,j,irdin)*fdt/volij & + rivin(i,j,irdip)*fdt/volij - ocetra(i,j,1:kmle,ialkali) = ocetra(i,j,1:kmle,ialkali) + rivin(i,j,iralk)*fdt/volij + ocetra(i,j,1:kmle(i,j),ialkali) = ocetra(i,j,1:kmle(i,j),ialkali) + rivin(i,j,iralk)*fdt/volij #ifdef natDIC - ocetra(i,j,1:kmle,inatsco212) = ocetra(i,j,1:kmle,inatsco212) + rivin(i,j,iralk)*fdt/volij & + ocetra(i,j,1:kmle(i,j),inatsco212) = ocetra(i,j,1:kmle(i,j),inatsco212) + rivin(i,j,iralk)*fdt/volij & + rivin(i,j,irdin)*fdt/volij & + rivin(i,j,irdip)*fdt/volij - ocetra(i,j,1:kmle,inatalkali) = ocetra(i,j,1:kmle,inatalkali) + rivin(i,j,iralk)*fdt/volij + ocetra(i,j,1:kmle(i,j),inatalkali) = ocetra(i,j,1:kmle(i,j),inatalkali) + rivin(i,j,iralk)*fdt/volij #endif - ocetra(i,j,1:kmle,iiron) = ocetra(i,j,1:kmle,iiron) + rivin(i,j,iriron)*fdt/volij*dFe_frac - ocetra(i,j,1:kmle,idoc) = ocetra(i,j,1:kmle,idoc) + rivin(i,j,irdoc)*fdt/volij - ocetra(i,j,1:kmle,idet) = ocetra(i,j,1:kmle,idet) + rivin(i,j,irdet)*fdt/volij + ocetra(i,j,1:kmle(i,j),iiron) = ocetra(i,j,1:kmle(i,j),iiron) + rivin(i,j,iriron)*fdt/volij*dFe_frac + ocetra(i,j,1:kmle(i,j),idoc) = ocetra(i,j,1:kmle(i,j),idoc) + rivin(i,j,irdoc)*fdt/volij + ocetra(i,j,1:kmle(i,j),idet) = ocetra(i,j,1:kmle(i,j),idet) + rivin(i,j,irdet)*fdt/volij rivinflx(i,j,irdin) = rivin(i,j,irdin)*fdt rivinflx(i,j,irdip) = rivin(i,j,irdip)*fdt diff --git a/hamocc/mo_intfcblom.F90 b/hamocc/mo_intfcblom.F90 index 68227f7b..e0d78b3b 100644 --- a/hamocc/mo_intfcblom.F90 +++ b/hamocc/mo_intfcblom.F90 @@ -244,14 +244,16 @@ subroutine blom2hamocc(m,n,mm,nn) !****************************************************************************** ! use mod_constants, only: onem - use mod_xc, only: ii,jdm,jj,kdm,kk,ifp,isp,ilp,idm + use mod_xc, only: ii,jdm,jj,kdm,kk,ifp,isp,ilp,idm use mod_grid, only: scpx,scpy use mod_state, only: dp,temp,saln use mod_eos, only: rho,p_alpha + use mod_difest, only: hOBL use mod_tracers, only: ntrbgc,itrbgc,trc use mo_param1_bgc, only: ks,nsedtra,npowtra,natm use mo_carbch, only: ocetra,atm use mo_sedmnt, only: sedlay,powtra,sedhpl,burial + use mo_vgrid, only: kmle, kmle_static implicit none @@ -292,6 +294,11 @@ subroutine blom2hamocc(m,n,mm,nn) ! --- - dimension of grid box in meters bgc_dx(i,j) = scpx(i,j)/1.e2 bgc_dy(i,j) = scpy(i,j)/1.e2 +! +! --- - index of level above OBL depth +! --- isopycninc coords: hOBL(i,j) = hOBL_static = 3. => kmle(i,j) = 2 +! --- hybrid coords: hOBL defined according to cvmix_kpp_compute_kOBL_depth + kmle(i,j) = nint(hOBL(i,j))-1 enddo enddo !$OMP END PARALLEL DO diff --git a/hamocc/mo_vgrid.F90 b/hamocc/mo_vgrid.F90 index 0f7cc08b..e010e92e 100644 --- a/hamocc/mo_vgrid.F90 +++ b/hamocc/mo_vgrid.F90 @@ -53,16 +53,18 @@ module mo_vgrid !****************************************************************************** implicit none - INTEGER, PARAMETER :: kmle = 2 ! k-end index for layers that - ! represent the mixed layer in BLOM + INTEGER, PARAMETER :: kmle_static = 2 ! k-end index for layers that + ! represent the mixed layer in BLOM. + ! Default value used for isopycnic coordinates. REAL, PARAMETER :: dp_ez = 100.0 ! depth of euphotic zone - REAL, PARAMETER :: dp_min = 1.0E-12 ! min layer thickness layers thinner + REAL, PARAMETER :: dp_min = 1.0E-12 ! min layer thickness layers thinner ! than this are ignored by HAMOCC REAL, PARAMETER :: dp_min_sink = 1.0 ! min layer thickness for sinking (layers thinner than ! this are ignored and set to the concentration of the ! layer above). Note that the bottom layer index kbo(i,j) ! is defined as the lowermost layer thicker than dp_min_sink. + INTEGER, DIMENSION(:,:), ALLOCATABLE :: kmle INTEGER, DIMENSION(:,:), ALLOCATABLE :: kbo INTEGER, DIMENSION(:,:), ALLOCATABLE :: kwrbioz INTEGER, DIMENSION(:,:), ALLOCATABLE :: k0100,k0500,k1000,k2000,k4000 @@ -263,6 +265,17 @@ subroutine alloc_mem_vgrid(kpie,kpje,kpke) ptiestw(:,:,:) = 0.0 + IF(mnproc.eq.1) THEN + WRITE(io_stdo_bgc,*)'Memory allocation for variable kmle ...' + WRITE(io_stdo_bgc,*)'First dimension : ',kpie + WRITE(io_stdo_bgc,*)'Second dimension : ',kpje + ENDIF + + ALLOCATE(kmle(kpie,kpje),stat=errstat) + if(errstat.ne.0) stop 'not enough memory kmle' + kmle(:,:) = kmle_static + + IF(mnproc.eq.1) THEN WRITE(io_stdo_bgc,*)'Memory allocation for variable kbo ...' WRITE(io_stdo_bgc,*)'First dimension : ',kpie diff --git a/hamocc/ocprod.F90 b/hamocc/ocprod.F90 index 9d2b82d7..4c242408 100644 --- a/hamocc/ocprod.F90 +++ b/hamocc/ocprod.F90 @@ -938,7 +938,7 @@ subroutine ocprod(kpie,kpje,kpke,kbnd,pdlxp,pdlyp,pddpo,omask,ptho,pi_ph) ! Set minimum particle number to nmldmin in the mixed layer. This is to prevent ! very small values of nos (and asscociated high sinking speed if there is mass) ! in high latitudes during winter - if ( k <= kmle ) then + if ( k <= kmle(i,j) ) then ocetra(i,j,k,inos) = MAX(nmldmin,ocetra(i,j,k,inos)) endif @@ -974,7 +974,7 @@ subroutine ocprod(kpie,kpje,kpke,kbnd,pdlxp,pdlyp,pddpo,omask,ptho,pi_ph) ! As a first step, assume that shear in the mixed layer is high and ! zero below. - if ( k <= kmle ) then + if ( k <= kmle(i,j) ) then fshear = fsh else fshear = 0. diff --git a/hamocc/preftrc.F90 b/hamocc/preftrc.F90 index 34a9161c..a33280d1 100644 --- a/hamocc/preftrc.F90 +++ b/hamocc/preftrc.F90 @@ -16,7 +16,7 @@ ! along with BLOM. If not, see https://www.gnu.org/licenses/. - SUBROUTINE PREFTRC(kpie,kpje,omask) +SUBROUTINE PREFTRC(kpie,kpje,omask) !**************************************************************** ! !**** *PREFTRC* - update preformed tracers in the mixed layer. @@ -43,31 +43,27 @@ SUBROUTINE PREFTRC(kpie,kpje,omask) ! !************************************************************************** - use mo_carbch, only: ocetra - use mo_param1_bgc, only: ialkali,ioxygen,iphosph,iprefalk,iprefdic,iprefo2,iprefpo4,isco212 - use mo_vgrid, only: kmle + use mo_carbch, only: ocetra + use mo_param1_bgc, only: ialkali,ioxygen,iphosph,iprefalk,iprefdic,iprefo2,iprefpo4,isco212 + use mo_vgrid, only: kmle - implicit none + implicit none - INTEGER :: kpie,kpje - REAL :: omask(kpie,kpje) + INTEGER :: kpie,kpje + REAL :: omask(kpie,kpje) - INTEGER :: i,j,k + INTEGER :: i,j - do k=1,kmle -!$OMP PARALLEL DO PRIVATE(i) - do j=1,kpje - do i=1,kpie + do j=1,kpje + do i=1,kpie if (omask(i,j) .gt. 0.5 ) then - ocetra(i,j,k,iprefo2) =ocetra(i,j,k,ioxygen) - ocetra(i,j,k,iprefpo4)=ocetra(i,j,k,iphosph) - ocetra(i,j,k,iprefalk)=ocetra(i,j,k,ialkali) - ocetra(i,j,k,iprefdic)=ocetra(i,j,k,isco212) + ocetra(i,j,1:kmle(i,j),iprefo2) = ocetra(i,j,1:kmle(i,j),ioxygen) + ocetra(i,j,1:kmle(i,j),iprefpo4) = ocetra(i,j,1:kmle(i,j),iphosph) + ocetra(i,j,1:kmle(i,j),iprefalk) = ocetra(i,j,1:kmle(i,j),ialkali) + ocetra(i,j,1:kmle(i,j),iprefdic) = ocetra(i,j,1:kmle(i,j),isco212) endif - enddo - enddo -!$OMP END PARALLEL DO - enddo + enddo + enddo - END SUBROUTINE PREFTRC +END SUBROUTINE PREFTRC diff --git a/phy/mod_difest.F b/phy/mod_difest.F index 2d2dde96..5bd4b2b9 100644 --- a/phy/mod_difest.F +++ b/phy/mod_difest.F @@ -78,6 +78,10 @@ module mod_difest implicit none c private +c +c Initialize hOBL with hOBL_static = 3. for consistency with bulk +c mixed layer formulation in iHAMOCC: kmle = nint(hOBL) - 1 = 2 + real, PARAMETER :: hOBL_static = 3. c real, dimension(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy,kdm+1) :: . rig @@ -85,6 +89,8 @@ module mod_difest . du2l,drhol,up,vp real, dimension(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy) :: . OBLdepth + real, dimension(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy) :: + . hOBL integer, dimension(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy,kdm) :: . mskv,msku integer, dimension(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy) :: @@ -174,7 +180,7 @@ module mod_difest . cs=98.96,minOBLdepth=1.0) c public :: OBLdepth, inivar_difest, init_difest, difest_isobml, - . difest_lateral_hybrid, difest_vertical_hybrid + . difest_lateral_hybrid, difest_vertical_hybrid, hOBL c contains c @@ -203,6 +209,7 @@ subroutine inivar_difest enddo do i=1-nbdy,ii+nbdy OBLdepth(i,j)=spval + hOBL(i,j) = hOBL_static enddo enddo c$OMP END PARALLEL DO @@ -904,7 +911,6 @@ subroutine difest_vertical_hyb(m,n,mm,nn,k1m,k1n) real :: Simmons_coeff, zBottomMinusOffset real :: bl1, bl2, bl3, bl4 integer ki, ksfc, ktmp, kOBL, kn1 - real, dimension(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy) :: hOBL c surf_layer_ext = 0.1 bl1 = 8e-5 From f9b0186111b183812155771f5cc6b53c2a5c2ebe Mon Sep 17 00:00:00 2001 From: Mats Bentsen Date: Thu, 15 Sep 2022 00:26:21 +0200 Subject: [PATCH 219/366] Added initial support for NUOPC driver. --- cime_config/buildlib_2.2 | 5 +- cime_config/config_archive.xml | 13 + drivers/nuopc/external_abort.F90 | 35 + drivers/nuopc/mod_nuopc_methods.F90 | 1034 +++++++++++++++++++++++ drivers/nuopc/mod_swtfrz.F90 | 81 ++ drivers/nuopc/ocn_comp_nuopc.F90 | 1189 +++++++++++++++++++++++++++ drivers/nuopc/setlogunit.F90 | 25 + 7 files changed, 2381 insertions(+), 1 deletion(-) create mode 100644 cime_config/config_archive.xml create mode 100644 drivers/nuopc/external_abort.F90 create mode 100644 drivers/nuopc/mod_nuopc_methods.F90 create mode 100644 drivers/nuopc/mod_swtfrz.F90 create mode 100644 drivers/nuopc/ocn_comp_nuopc.F90 create mode 100644 drivers/nuopc/setlogunit.F90 diff --git a/cime_config/buildlib_2.2 b/cime_config/buildlib_2.2 index 956c3116..3b800c15 100755 --- a/cime_config/buildlib_2.2 +++ b/cime_config/buildlib_2.2 @@ -80,10 +80,13 @@ def _main_func(): else: expect(False, "tracer module {} is not recognized".format(module)) - expect(driver != "nuopc", "NUOPC driver not supported") if driver == "mct": paths.append(os.path.join(comp_root_dir_ocn, "drivers", "cpl_share")) paths.append(os.path.join(comp_root_dir_ocn, "drivers", "cpl_mct")) + elif driver == "nuopc": + paths.append(os.path.join(comp_root_dir_ocn, "drivers", "nuopc")) + else: + expect(False, "Driver {} is not supported".format(driver)) with open(filepath_file, "w") as filepath: filepath.write("\n".join(paths)) diff --git a/cime_config/config_archive.xml b/cime_config/config_archive.xml new file mode 100644 index 00000000..0939f52d --- /dev/null +++ b/cime_config/config_archive.xml @@ -0,0 +1,13 @@ + + + r + rbgc + h[dmy]\d*.*\.nc$ + hbgc[dmy]\d*.*\.nc$ + unset + + rpointer.ocn$NINST_STRING + ./$CASE.blom$NINST_STRING.r.$DATENAME.nc + + + diff --git a/drivers/nuopc/external_abort.F90 b/drivers/nuopc/external_abort.F90 new file mode 100644 index 00000000..4e1932a1 --- /dev/null +++ b/drivers/nuopc/external_abort.F90 @@ -0,0 +1,35 @@ +! ------------------------------------------------------------------------------ +! Copyright (C) 2015 Mats Bentsen +! +! 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 . +! ------------------------------------------------------------------------------ + +subroutine external_abort(msg) +! ------------------------------------------------------------------------------ +! Call CESM shared abort routine. +! ------------------------------------------------------------------------------ + + use shr_sys_mod, only: shr_sys_abort + + implicit none + + ! Input/output arguments. + + character(len=*), intent(in) :: msg + + call shr_sys_abort(msg) + +end subroutine external_abort diff --git a/drivers/nuopc/mod_nuopc_methods.F90 b/drivers/nuopc/mod_nuopc_methods.F90 new file mode 100644 index 00000000..0d24e367 --- /dev/null +++ b/drivers/nuopc/mod_nuopc_methods.F90 @@ -0,0 +1,1034 @@ +! ------------------------------------------------------------------------------ +! Copyright (C) 2022 Mats Bentsen +! +! 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_nuopc_methods +! ------------------------------------------------------------------------------ +! This module contains routines operating on BLOM data structures needed by the +! NUOPC cap. +! ------------------------------------------------------------------------------ + + use mod_types, only: r8 + use mod_constants, only: rearth, onem + use mod_time, only: nstep, baclin, delt1, dlt + use mod_xc + use mod_grid, only: scuy, scvx, scp2, scuxi, scvyi, plon, plat, & + cosang, sinang + use mod_state, only: u, v, dp, temp, saln, pbu, pbv, ubflxs, vbflxs, sealv + use mod_forcing, only: sprfac, prfac, flxco2, flxdms, flxbrf + use mod_difest, only: obldepth + use mod_vcoord, only: vcoord_type_tag, isopyc_bulkml, cntiso_hybrid + 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, & + ustarw_da, slp_da, abswnd_da, atmco2_da, atmbrf_da, & + ficem_da, l1ci, l2ci + use mod_utility, only: util1, util2 + use mod_checksum, only: csdiag, chksummsk + use shr_const_mod, only: SHR_CONST_RHOSW, SHR_CONST_LATICE, SHR_CONST_TKFRZ + + implicit none + + private + + ! Parameters. + character(len=*), parameter :: modname = '(mod_nuopc_methods)' + + type :: fldlist_type + character(len=128) :: stdname + integer :: ungridded_lbound = 0 + integer :: ungridded_ubound = 0 + real(r8), dimension(:), pointer :: dataptr + end type fldlist_type + + real(r8), dimension(:), allocatable :: mod2med_areacor, med2mod_areacor + real(r8), dimension(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy) :: & + acc_u, acc_v, acc_dhdx, acc_dhdy, acc_t, acc_s, acc_frzpot, acc_bld, & + acc_fco2, acc_fdms, acc_fbrf + real(r8) :: tlast_coupled + integer :: jjcpl + logical :: fco2_requested, fdms_requested, fbrf_requested + + public :: fldlist_type, tlast_coupled, & + fco2_requested, fdms_requested, fbrf_requested, & + blom_logwrite, blom_getgindex, blom_checkmesh, blom_setareacor, & + blom_getglobdim, blom_getprecipfact, blom_accflds, & + blom_importflds, blom_exportflds + +contains + + ! --------------------------------------------------------------------------- + ! Private procedures. + ! --------------------------------------------------------------------------- + + subroutine getfldindex(fldlist_num, fldlist, stdname, fldindex) + ! --------------------------------------------------------------------------- + ! Get index of field with given standard name. If no field has a matching + ! name or a field with matching name has an unassociated data pointer, set + ! index to zero. + ! --------------------------------------------------------------------------- + + ! Input/output arguments. + integer, intent(in) :: fldlist_num + type(fldlist_type), dimension(:), intent(in) :: fldlist + character(len=*), intent(in) :: stdname + integer, intent(inout) :: fldindex + + ! Local variables. + integer :: n + + if (fldindex >= 0) return + + fldindex = 0 + + do n = 1, fldlist_num + if (fldlist(n)%stdname == stdname) then + if (associated(fldlist(n)%dataptr)) fldindex = n + return + endif + enddo + + end subroutine getfldindex + + ! --------------------------------------------------------------------------- + ! Public procedures. + ! --------------------------------------------------------------------------- + + subroutine blom_logwrite(msg) + ! --------------------------------------------------------------------------- + ! Write message string to standard out from master PE. + ! --------------------------------------------------------------------------- + + ! Input/output arguments. + character(len=*), intent(in) :: msg + + if (mnproc == 1) write(lp,'(a)') trim(msg) + + end subroutine blom_logwrite + + subroutine blom_getgindex(gindex) + ! --------------------------------------------------------------------------- + ! Get global index space for the computational domain. + ! --------------------------------------------------------------------------- + + ! Input/output arguments. + integer, allocatable, dimension(:), intent(out) :: gindex + + ! Local variables. + integer :: mproc_next, i, j, n + + ! Set the j-extent of the local ocean domain to be exchanged. Needed + ! because of duplication of the last global domain row when using a + ! tripolar grid. + if (nreg == 2 .and. nproc == jpr) then + jjcpl = jj - 1 + else + jjcpl = jj + endif + + ! Create the global index space for the computational domain. Also append + ! indices of eliminated grid cells adjacent to the domain and with larger + ! global i-index. + mproc_next = mod(mproc, ipr) + 1 + do while (ii_pe(mproc_next,nproc) == 0) + mproc_next = mod(mproc_next, ipr) + 1 + enddo + allocate(gindex(mod(i0_pe(mproc_next,nproc) - i0 + itdm, itdm)*jjcpl)) + n = 0 + do j = 1, jjcpl + do i = 1, ii + n = n + 1 + gindex(n) = (j0 + j - 1)*itdm + i0 + i + enddo + enddo + do j = 1, jjcpl + do i = ii + 1, mod(i0_pe(mproc_next,nproc) - i0 + itdm, itdm) + n = n + 1 + gindex(n) = (j0 + j - 1)*itdm + mod(i0 + i - 1, itdm) + 1 + enddo + enddo + + end subroutine blom_getgindex + + subroutine blom_checkmesh(lonmesh, latmesh, maskmesh) + ! --------------------------------------------------------------------------- + ! Check for consistency of lat, lon and mask between mediator mesh and model + ! grid. + ! --------------------------------------------------------------------------- + + ! Input/output arguments. + real(r8), dimension(:), pointer, intent(in) :: lonmesh, latmesh + integer, dimension(:), pointer, intent(in) :: maskmesh + + ! Local parameters. + character(len=*), parameter :: & + subname = modname//':(blom_checkmesh)' + + ! Local variables. + real(r8) :: diff_lon, diff_lat + integer :: mproc_next, i, j, n + + do j = 1, jjcpl + do i = 1, ii + n = (j - 1)*ii + i + diff_lon = abs(mod(lonmesh(n) - plon(i,j),360._r8)) + if (diff_lon > 1.e-3_r8) then + write(lp,'(a,3i6,2(f21.13,3x),d21.5)') subname// & + ': BLOM ERROR: n, i, j, lonmesh(n), plon(i,j), diff_lon = ', & + n, i, j, lonmesh(n), plon(i,j), diff_lon + call xchalt(subname) + stop subname + endif + diff_lat = abs(latmesh(n) - plat(i,j)) + if (diff_lat > 1.e-3_r8) then + write(lp,'(a,3i6,2(f21.13,3x),d21.5)') subname// & + ': BLOM ERROR: n, i, j, latmesh(n), plat(i,j), diff_lat = ', & + n, i, j, latmesh(n), plat(i,j), diff_lat + call xchalt(subname) + stop subname + endif + if (maskmesh(n) /= ip(i,j)) then + write(lp,'(a,3i6,2(f21.13,3x),d21.5)') subname// & + ': BLOM ERROR: n, i, j, maskmesh(n), ip(i,j) = ', & + n, i, j, maskmesh(n), ip(i,j) + call xchalt(subname) + stop subname + endif + enddo + enddo + + end subroutine blom_checkmesh + + subroutine blom_getprecipfact(precip_fact_provided, precip_fact) + ! --------------------------------------------------------------------------- + ! Get precipitation factor. + ! --------------------------------------------------------------------------- + + ! Input/output arguments. + logical, intent(out) :: precip_fact_provided + real(r8), intent(out) :: precip_fact + + precip_fact_provided = sprfac + precip_fact = prfac + + end subroutine blom_getprecipfact + + subroutine blom_getglobdim(nx_global, ny_global) + ! --------------------------------------------------------------------------- + ! Get global dimensions of export/import domain. + ! --------------------------------------------------------------------------- + + ! Input/output arguments. + integer, intent(out) :: nx_global, ny_global + + nx_global = itdm + if (nreg == 2) then + ny_global = jtdm - 1 + else + ny_global = jtdm + endif + + end subroutine blom_getglobdim + + subroutine blom_setareacor(areamesh, maskmesh) + ! --------------------------------------------------------------------------- + ! Set flux area correction factors. + ! --------------------------------------------------------------------------- + + ! Input/output arguments. + real(r8), dimension(:), pointer, intent(in) :: areamesh + integer, dimension(:), pointer, intent(in) :: maskmesh + + ! Local parameters. + character(len=*), parameter :: & + subname = modname//':(blom_setareacor)' + + ! Local variables. + real(r8) :: areamodel, & + max_mod2med_areacor, max_med2mod_areacor, & + min_mod2med_areacor, min_med2mod_areacor + integer :: i, j, n + + allocate(mod2med_areacor(size(areamesh)), & + med2mod_areacor(size(areamesh))) + mod2med_areacor(:) = 1._r8 + med2mod_areacor(:) = 1._r8 + + !$omp parallel do private(i, n) + do j = 1, jjcpl + do i = 1, ii + n = (j - 1)*ii + i + if (maskmesh(n) /= 0) then + areamodel = scp2(i,j)/(rearth*rearth) + mod2med_areacor(n) = areamodel/areamesh(n) + med2mod_areacor(n) = areamesh(n)/areamodel + endif + enddo + enddo + !$omp end parallel do + + min_mod2med_areacor = minval(mod2med_areacor) + max_mod2med_areacor = maxval(mod2med_areacor) + min_med2mod_areacor = minval(med2mod_areacor) + max_med2mod_areacor = maxval(med2mod_areacor) + call xcmax(max_mod2med_areacor) + call xcmin(min_mod2med_areacor) + call xcmax(max_med2mod_areacor) + call xcmin(min_med2mod_areacor) + if (mnproc == 1) then + write(lp,'(a,2g23.15)') & + subname//': min_mod2med_areacor, max_mod2med_areacor ', & + min_mod2med_areacor, max_mod2med_areacor + write(lp,'(a,2g23.15)') & + subname//': min_med2mod_areacor, max_med2mod_areacor ', & + min_med2mod_areacor, max_med2mod_areacor + endif + + end subroutine blom_setareacor + + subroutine blom_accflds + ! --------------------------------------------------------------------------- + ! Accumulate export fields to be averaged before sent to the mediator. + ! --------------------------------------------------------------------------- + + ! Local parameters. + character(len=*), parameter :: & + subname = modname//':(blom_accflds)' + + ! Local variables. + real(r8) :: q + integer m, n, mm, nn, k1m, k1n, i, j, l + + ! ------------------------------------------------------------------------ + ! Set accumulation arrays to zero if this is the first call after a + ! coupling interval. + ! ------------------------------------------------------------------------ + + if (tlast_coupled == 0._r8) then + acc_u (:,:) = 0._r8 + acc_v (:,:) = 0._r8 + acc_dhdx (:,:) = 0._r8 + acc_dhdy (:,:) = 0._r8 + acc_t (:,:) = 0._r8 + acc_s (:,:) = 0._r8 + acc_frzpot(:,:) = 0._r8 + acc_bld (:,:) = 0._r8 + acc_fco2 (:,:) = 0._r8 + acc_fdms (:,:) = 0._r8 + acc_fbrf (:,:) = 0._r8 + endif + + ! ------------------------------------------------------------------------ + ! Accumulate fields in send buffer + ! ------------------------------------------------------------------------ + + m = mod(nstep + 1, 2) + 1 + n = mod(nstep , 2) + 1 + mm = (m - 1)*kk + nn = (n - 1)*kk + k1m = 1 + mm + k1n = 1 + nn + + call xctilr(sealv, 1,1, 1,1, halo_ps) + + !$omp parallel do private(l, i) + do j = 1, jj + do l = 1, isu(j) + do i = max(1, ifu(j,l)), min(ii, ilu(j,l)) + acc_u(i,j) = acc_u(i,j) & + + ( u(i,j,k1n) & + + (ubflxs(i,j,m) + ubflxs(i,j,n))*dlt & + /(pbu(i,j,n)*scuy(i,j)*delt1))*baclin + acc_dhdx(i,j) = acc_dhdx(i,j) & + + (sealv(i,j) - sealv(i-1,j))*scuxi(i,j)*baclin + enddo + enddo + do l = 1, isv(j) + do i = max(1, ifv(j,l)), min(ii, ilv(j,l)) + acc_v(i,j) = acc_v(i,j) & + + ( v(i,j,k1n) & + + (vbflxs(i,j,m) + vbflxs(i,j,n))*dlt & + /(pbv(i,j,n)*scvx(i,j)*delt1))*baclin + acc_dhdy(i,j) = acc_dhdy(i,j) & + + (sealv(i,j) - sealv(i,j-1))*scvyi(i,j)*baclin + enddo + enddo + do l = 1, isp(j) + do i = max(1, ifp(j,l)), min(ii, ilp(j,l)) + acc_t(i,j) = acc_t(i,j) + temp(i,j,k1n)*baclin + acc_s(i,j) = acc_s(i,j) + saln(i,j,k1n)*baclin + acc_frzpot(i,j) = acc_frzpot(i,j) + frzpot(i,j) + enddo + enddo + enddo + !$omp end parallel do + + select case (vcoord_type_tag) + case (isopyc_bulkml) + q = baclin/onem + !$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)) + acc_bld(i,j) = (dp(i,j,1+nn) + dp(i,j,2+nn))*q + enddo + enddo + enddo + !$omp end parallel do + case (cntiso_hybrid) + !$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)) + acc_bld(i,j) = OBLdepth(i,j)*baclin + enddo + enddo + enddo + !$omp end parallel do + case default + if (mnproc == 1) & + write(lp,*) subname//': unsupported vertical coordinate!' + call xcstop(subname) + stop subname + end select + + if (fco2_requested) then + !$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)) + acc_fco2(i,j) = acc_fco2(i,j) + flxco2(i,j)*baclin + enddo + enddo + enddo + !$omp end parallel do + endif + + if (fdms_requested) then + !$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)) + acc_fdms(i,j) = acc_fdms(i,j) + flxdms(i,j)*baclin + enddo + enddo + enddo + !$omp end parallel do + endif + + if (fbrf_requested) then + !$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)) + acc_fbrf(i,j) = acc_fbrf(i,j) + flxbrf(i,j)*baclin + enddo + enddo + enddo + !$omp end parallel do + endif + + ! ------------------------------------------------------------------------ + ! Increment time since last coupling. + ! ------------------------------------------------------------------------ + + tlast_coupled = tlast_coupled + baclin + + end subroutine blom_accflds + + subroutine blom_importflds(fldlist_num, fldlist) + ! --------------------------------------------------------------------------- + ! Import fields from mediator to BLOM arrays. + ! --------------------------------------------------------------------------- + + ! Input/output arguments. + integer, intent(in) :: fldlist_num + type(fldlist_type), dimension(:), intent(in) :: fldlist + + ! Local parameters. + character(len=*), parameter :: & + subname = modname//':(blom_importflds)' + real(r8), parameter :: & + mval = - 1.e12_r8, & + fval = - 1.e13_r8 + + ! Local variables. + real(r8) :: afac, utmp, vtmp + integer :: n, i, j, l + integer, save :: & + index_Si_ifrac = - 1, & + index_Fioi_melth = - 1, & + index_Fioi_meltw = - 1, & + index_Fioi_salt = - 1, & + index_Fioi_bcpho = - 1, & + index_Fioi_bcphi = - 1, & + index_Fioi_flxdst = - 1, & + index_Foxx_rofl = - 1, & + index_Foxx_rofi = - 1, & + index_So_duu10n = - 1, & + index_Foxx_tauy = - 1, & + index_Foxx_taux = - 1, & + index_Foxx_lat = - 1, & + index_Foxx_sen = - 1, & + index_Foxx_lwup = - 1, & + index_Foxx_evap = - 1, & + index_Foxx_swnet = - 1, & + index_Sw_lamult = - 1, & + index_Sw_ustokes = - 1, & + index_Sw_vstokes = - 1, & + index_Sw_hstokes = - 1, & + index_Sa_pslv = - 1, & + index_Faxa_lwdn = - 1, & + index_Faxa_snow = - 1, & + index_Faxa_rain = - 1, & + index_Sa_co2diag = - 1, & + index_Sa_co2prog = - 1, & + index_Sa_brfprog = - 1 + + ! Update time level indices. + if (l1ci == 1 .and. l2ci == 1) then + l1ci = 2 + l2ci = 2 + else + l1ci = l2ci + l2ci = 3 - l2ci + endif + + call getfldindex(fldlist_num, fldlist, 'Foxx_taux', index_Foxx_taux) + call getfldindex(fldlist_num, fldlist, 'Foxx_tauy', index_Foxx_tauy) + + !$omp parallel do private(i, n) + do j = 1, jjcpl + do i = 1, ii + if (ip(i,j) == 0) then + util1(i,j) = mval + util2(i,j) = mval + ustarw_da(i,j,l2ci) = mval + elseif (cplmsk(i,j) == 0) then + util1(i,j) = fval + util2(i,j) = fval + ustarw_da(i,j,l2ci) = fval + else + n = (j - 1)*ii + i + afac = med2mod_areacor(n) + utmp = fldlist(index_Foxx_taux)%dataptr(n)*afac + vtmp = fldlist(index_Foxx_tauy)%dataptr(n)*afac + util1(i,j) = utmp*cosang(i,j) + vtmp*sinang(i,j) + util2(i,j) = - utmp*sinang(i,j) + vtmp*cosang(i,j) + + ! Friction velocity [m s-1]. + ustarw_da(i,j,l2ci) = sqrt(sqrt(utmp*utmp + vtmp*vtmp) & + /SHR_CONST_RHOSW) + endif + enddo + enddo + !$omp end parallel do + + call fill_global(mval, fval, halo_pv, util1) + call fill_global(mval, fval, halo_pv, util2) + call fill_global(mval, fval, halo_ps, ustarw_da(1-nbdy,1-nbdy,l2ci)) + + call xctilr(util1, 1,1, 1,1, halo_pv) + call xctilr(util2, 1,1, 1,1, halo_pv) + + !$omp parallel do private(l, i) + do j = 1, jj + do l = 1, isu(j) + do i = max(1,ifu(j,l)), min(ii,ilu(j,l)) + ! x-component of momentum flux [kg m-1 s-2]. + ztx_da(i,j,l2ci) = .5_r8*(util1(i-1,j) + util1(i,j)) + enddo + enddo + do l = 1,isv(j) + do i = max(1,ifv(j,l)), min(ii,ilv(j,l)) + ! y-component of momentum flux [kg m-1 s-2]. + mty_da(i,j,l2ci) = .5_r8*(util2(i,j-1) + util2(i,j)) + enddo + enddo + enddo + !$omp end parallel do + + call getfldindex(fldlist_num, fldlist, 'Faxa_rain', index_Faxa_rain) + call getfldindex(fldlist_num, fldlist, 'Faxa_snow', index_Faxa_snow) + call getfldindex(fldlist_num, fldlist, 'Foxx_evap', index_Foxx_evap) + call getfldindex(fldlist_num, fldlist, 'Foxx_rofl', index_Foxx_rofl) + call getfldindex(fldlist_num, fldlist, 'Foxx_rofi', index_Foxx_rofi) + call getfldindex(fldlist_num, fldlist, 'Fioi_meltw', index_Fioi_meltw) + call getfldindex(fldlist_num, fldlist, 'Fioi_salt', index_Fioi_salt) + call getfldindex(fldlist_num, fldlist, 'Foxx_swnet', index_Foxx_swnet) + call getfldindex(fldlist_num, fldlist, 'Foxx_lat', index_Foxx_lat) + call getfldindex(fldlist_num, fldlist, 'Foxx_sen', index_Foxx_sen) + call getfldindex(fldlist_num, fldlist, 'Foxx_lwup', index_Foxx_lwup) + call getfldindex(fldlist_num, fldlist, 'Faxa_lwdn', index_Faxa_lwdn) + call getfldindex(fldlist_num, fldlist, 'Fioi_melth', index_Fioi_melth) + call getfldindex(fldlist_num, fldlist, 'Sa_pslv', index_Sa_pslv) + call getfldindex(fldlist_num, fldlist, 'Si_ifrac', index_Si_ifrac) + call getfldindex(fldlist_num, fldlist, 'So_duu10n', index_So_duu10n) + + !$omp parallel do private(i, n) + do j = 1, jjcpl + do i = 1, ii + + if (ip(i,j) == 0) then + lip_da(i,j,l2ci) = mval + sop_da(i,j,l2ci) = mval + eva_da(i,j,l2ci) = mval + rnf_da(i,j,l2ci) = mval + rfi_da(i,j,l2ci) = mval + fmltfz_da(i,j,l2ci) = mval + sfl_da(i,j,l2ci) = mval + swa_da(i,j,l2ci) = mval + nsf_da(i,j,l2ci) = mval + hmlt_da(i,j,l2ci) = mval + slp_da(i,j,l2ci) = mval + ficem_da(i,j,l2ci) = mval + abswnd_da(i,j,l2ci) = mval + elseif (cplmsk(i,j) == 0) then + lip_da(i,j,l2ci) = 0._r8 + sop_da(i,j,l2ci) = 0._r8 + eva_da(i,j,l2ci) = 0._r8 + rnf_da(i,j,l2ci) = 0._r8 + rfi_da(i,j,l2ci) = 0._r8 + fmltfz_da(i,j,l2ci) = 0._r8 + sfl_da(i,j,l2ci) = 0._r8 + swa_da(i,j,l2ci) = 0._r8 + nsf_da(i,j,l2ci) = 0._r8 + hmlt_da(i,j,l2ci) = 0._r8 + slp_da(i,j,l2ci) = fval + ficem_da(i,j,l2ci) = fval + abswnd_da(i,j,l2ci) = fval + else + n = (j - 1)*ii + i + afac = med2mod_areacor(n) + + ! Liquid water flux, positive downwards [kg m-2 s-1]. + lip_da(i,j,l2ci) = fldlist(index_Faxa_rain)%dataptr(n)*afac + + ! Solid precipitation, positive downwards [kg m-2 s-1]. + sop_da(i,j,l2ci) = fldlist(index_Faxa_snow)%dataptr(n)*afac + + ! Evaporation, positive downwards [kg m-2 s-1]. + eva_da(i,j,l2ci) = fldlist(index_Foxx_evap)%dataptr(n)*afac + + ! Liquid runoff, positive downwards [kg m-2 s-1]. + rnf_da(i,j,l2ci) = fldlist(index_Foxx_rofl)%dataptr(n)*afac + + ! Frozen runoff, positive downwards [kg m-2 s-1]. + rfi_da(i,j,l2ci) = fldlist(index_Foxx_rofi)%dataptr(n)*afac + + ! Fresh water due to melting/freezing, positive downwards + ! [kg m-2 s-1]. + fmltfz_da(i,j,l2ci) = fldlist(index_Fioi_meltw)%dataptr(n)*afac + + ! Salt flux, positive downwards [kg m-2 s-1]. + sfl_da(i,j,l2ci) = fldlist(index_Fioi_salt)%dataptr(n)*afac + + ! Shortwave heat flux, positive downwards [W m-2]. + swa_da(i,j,l2ci) = fldlist(index_Foxx_swnet)%dataptr(n)*afac + + ! Non-solar heat flux, positive downwards [W m-2]. + nsf_da(i,j,l2ci) = ( fldlist(index_Foxx_lat)%dataptr(n) & + + fldlist(index_Foxx_sen)%dataptr(n) & + + fldlist(index_Foxx_lwup)%dataptr(n) & + + fldlist(index_Faxa_lwdn)%dataptr(n) & + - ( fldlist(index_Faxa_snow)%dataptr(n) & + + fldlist(index_Foxx_rofi)%dataptr(n)) & + *SHR_CONST_LATICE)*afac + + ! Heat flux due to melting, positive downwards [W m-2]. + hmlt_da(i,j,l2ci) = fldlist(index_Fioi_melth)%dataptr(n)*afac + + ! Sea level pressure [kg m-1 s-2]. + slp_da(i,j,l2ci) = fldlist(index_Sa_pslv)%dataptr(n) + + ! Ice fraction []. + ficem_da(i,j,l2ci) = fldlist(index_Si_ifrac)%dataptr(n) + + ! 10m wind speed [m s-1]. + abswnd_da(i,j,l2ci) = sqrt(fldlist(index_So_duu10n)%dataptr(n)) + + endif + + enddo + enddo + !$omp end parallel do + + if (nreg == 2) then + call xctilr(lip_da(1-nbdy,1-nbdy,l2ci), 1,1, 0,0, halo_ps) + call xctilr(sop_da(1-nbdy,1-nbdy,l2ci), 1,1, 0,0, halo_ps) + call xctilr(eva_da(1-nbdy,1-nbdy,l2ci), 1,1, 0,0, halo_ps) + call xctilr(rnf_da(1-nbdy,1-nbdy,l2ci), 1,1, 0,0, halo_ps) + call xctilr(rfi_da(1-nbdy,1-nbdy,l2ci), 1,1, 0,0, halo_ps) + call xctilr(fmltfz_da(1-nbdy,1-nbdy,l2ci), 1,1, 0,0, halo_ps) + call xctilr(sfl_da(1-nbdy,1-nbdy,l2ci), 1,1, 0,0, halo_ps) + call xctilr(swa_da(1-nbdy,1-nbdy,l2ci), 1,1, 0,0, halo_ps) + call xctilr(nsf_da(1-nbdy,1-nbdy,l2ci), 1,1, 0,0, halo_ps) + call xctilr(hmlt_da(1-nbdy,1-nbdy,l2ci), 1,1, 0,0, halo_ps) + endif + + call fill_global(mval, fval, halo_ps, slp_da(1-nbdy,1-nbdy,l2ci)) + call fill_global(mval, fval, halo_ps, ficem_da(1-nbdy,1-nbdy,l2ci)) + call fill_global(mval, fval, halo_ps, abswnd_da(1-nbdy,1-nbdy,l2ci)) + +#ifdef PROGCO2 + call getfldindex(fldlist_num, fldlist, 'Sa_co2prog', index_Sa_co2prog) + + if (index_Sa_co2prog > 0) then + !$omp parallel do private(i, n) + do j = 1, jjcpl + do i = 1, ii + if (ip(i,j) == 0) then + atmco2_da(i,j,l2ci) = mval + elseif (cplmsk(i,j) == 0) then + atmco2_da(i,j,l2ci) = fval + else + n = (j - 1)*ii + i + ! Atmospheric co2 concentration [ppmv?] + atmco2_da(i,j,l2ci) = fldlist(index_Sa_co2prog)%dataptr(n) + endif + enddo + enddo + !$omp end parallel do + call fill_global(mval, fval, halo_ps, atmco2_da(1-nbdy,1-nbdy,l2ci)) + if (mnproc == 1) & + write(lp,*) subname//': prog. atmospheric co2 read' + else + !$omp parallel do private(i) + do j = 1, jj + do i = 1, ii + if (ip(i,j) == 0) then + atmco2_da(i,j,l2ci) = mval + else + atmco2_da(i,j,l2ci) = -1 + endif + enddo + enddo + !$omp end parallel do + if (mnproc == 1) & + write(lp,*) subname//': prog. atmospheric co2 not read' + endif + +#elif defined(DIAGCO2) + call getfldindex(fldlist_num, fldlist, 'Sa_co2diag', index_Sa_co2diag) + + if (index_Sa_co2diag > 0) then + !$omp parallel do private(i, n) + do j = 1, jjcpl + do i = 1, ii + if (ip(i,j) == 0) then + atmco2_da(i,j,l2ci) = mval + elseif (cplmsk(i,j) == 0) then + atmco2_da(i,j,l2ci) = fval + else + n = (j - 1)*ii + i + ! Atmospheric co2 concentration [ppmv?] + atmco2_da(i,j,l2ci) = fldlist(index_Sa_co2diag)%dataptr(n) + endif + enddo + enddo + !$omp end parallel do + call fill_global(mval, fval, halo_ps, atmco2_da(1-nbdy,1-nbdy,l2ci)) + if (mnproc == 1) & + write(lp,*) subname//': diag. atmospheric co2 read' + else + !$omp parallel do private(i) + do j = 1, jj + do i = 1, ii + if (ip(i,j) == 0) then + atmco2_da(i,j,l2ci) = mval + else + atmco2_da(i,j,l2ci) = -1 + endif + enddo + enddo + !$omp end parallel do + if (mnproc == 1) & + write(lp,*) subname//': diag. atmospheric co2 not read' + endif +#else + !$omp parallel do private(i) + do j = 1, jj + do i = 1, ii + if (ip(i,j) == 0) then + atmco2_da(i,j,l2ci) = mval + else + atmco2_da(i,j,l2ci) = -1 + endif + enddo + enddo + !$omp end parallel do + if (mnproc == 1) & + write(lp,*) subname//': atmospheric co2 not read' +#endif + + call getfldindex(fldlist_num, fldlist, 'Sa_brfprog', index_Sa_brfprog) + + if (index_Sa_brfprog > 0) then + !$omp parallel do private(i, n) + do j = 1, jjcpl + do i = 1, ii + if (ip(i,j) == 0) then + atmbrf_da(i,j,l2ci) = mval + elseif (cplmsk(i,j) == 0) then + atmbrf_da(i,j,l2ci) = fval + else + n = (j - 1)*ii + i + ! Atmospheric bromoform concentration [ppt] + atmbrf_da(i,j,l2ci) = fldlist(index_Sa_brfprog)%dataptr(n) + endif + enddo + enddo + !$omp end parallel do + call fill_global(mval, fval, halo_ps, atmbrf_da(1-nbdy,1-nbdy,l2ci)) + if (mnproc == 1) & + write(lp,*) subname//': prog. atmospheric bromoform read' + else + !$omp parallel do private(i) + do j = 1, jj + do i = 1, ii + if (ip(i,j) == 0) then + atmbrf_da(i,j,l2ci) = mval + else + atmbrf_da(i,j,l2ci) = -1 + endif + enddo + enddo + !$omp end parallel do + if (mnproc == 1) & + write(lp,*) subname//': prog. atmospheric bromoform not read' + endif + + if (csdiag) then + if (mnproc == 1) then + write(lp,*) subname//':' + endif + call chksummsk(ustarw_da(1-nbdy,1-nbdy,l2ci),ip,1,'ustarw') + call chksummsk(ztx_da(1-nbdy,1-nbdy,l2ci),iu,1,'ztx') + call chksummsk(mty_da(1-nbdy,1-nbdy,l2ci),iv,1,'mty') + call chksummsk(lip_da(1-nbdy,1-nbdy,l2ci),ip,1,'lip') + call chksummsk(sop_da(1-nbdy,1-nbdy,l2ci),ip,1,'sop') + call chksummsk(eva_da(1-nbdy,1-nbdy,l2ci),ip,1,'eva') + call chksummsk(rnf_da(1-nbdy,1-nbdy,l2ci),ip,1,'rnf') + call chksummsk(rfi_da(1-nbdy,1-nbdy,l2ci),ip,1,'rfi') + call chksummsk(fmltfz_da(1-nbdy,1-nbdy,l2ci),ip,1,'fmltfz') + call chksummsk(sfl_da(1-nbdy,1-nbdy,l2ci),ip,1,'sfl') + call chksummsk(swa_da(1-nbdy,1-nbdy,l2ci),ip,1,'swa') + call chksummsk(nsf_da(1-nbdy,1-nbdy,l2ci),ip,1,'nsf') + call chksummsk(hmlt_da(1-nbdy,1-nbdy,l2ci),ip,1,'hmlt') + call chksummsk(slp_da(1-nbdy,1-nbdy,l2ci),ip,1,'slp') + call chksummsk(ficem_da(1-nbdy,1-nbdy,l2ci),ip,1,'ficem') + call chksummsk(abswnd_da(1-nbdy,1-nbdy,l2ci),ip,1,'abswnd') + call chksummsk(atmco2_da(1-nbdy,1-nbdy,l2ci),ip,1,'atmco2') + call chksummsk(atmbrf_da(1-nbdy,1-nbdy,l2ci),ip,1,'atmbrf') + endif + + end subroutine blom_importflds + + subroutine blom_exportflds(fldlist_num, fldlist) + ! --------------------------------------------------------------------------- + ! Export from BLOM arrays to mediator fields. + ! --------------------------------------------------------------------------- + + ! Input/output arguments. + integer, intent(in) :: fldlist_num + type(fldlist_type), dimension(:), intent(in) :: fldlist + + ! Local parameters. + character(len=*), parameter :: & + subname = modname//':(blom_exportflds)' + + ! Local variables. + real(r8) :: tfac, utmp, vtmp + integer :: n, l, i, j + integer, save :: & + index_So_omask = - 1, & + index_So_u = - 1, & + index_So_v = - 1, & + index_So_dhdx = - 1, & + index_So_dhdy = - 1, & + index_So_t = - 1, & + index_So_s = - 1, & + index_So_bldepth = - 1, & + index_Fioo_q = - 1, & + index_Faoo_fdms_ocn = - 1, & + index_Faoo_fco2_ocn = - 1, & + index_Faoo_fbrf_ocn = - 1 + + tfac = 1._r8/tlast_coupled + + ! ------------------------------------------------------------------------ + ! Provide standard export fields. + ! ------------------------------------------------------------------------ + + call xctilr(acc_u, 1,1, 1,1, halo_uv) + call xctilr(acc_v, 1,1, 1,1, halo_vv) + call xctilr(acc_dhdx, 1,1, 1,1, halo_uv) + call xctilr(acc_dhdy, 1,1, 1,1, halo_vv) + + call getfldindex(fldlist_num, fldlist, 'So_omask', index_So_omask) + call getfldindex(fldlist_num, fldlist, 'So_u', index_So_u) + call getfldindex(fldlist_num, fldlist, 'So_v', index_So_v) + call getfldindex(fldlist_num, fldlist, 'So_dhdx', index_So_dhdx) + call getfldindex(fldlist_num, fldlist, 'So_dhdy', index_So_dhdy) + call getfldindex(fldlist_num, fldlist, 'So_t', index_So_t) + call getfldindex(fldlist_num, fldlist, 'So_s', index_So_s) + call getfldindex(fldlist_num, fldlist, 'So_bldepth', index_So_bldepth) + call getfldindex(fldlist_num, fldlist, 'Fioo_q', index_Fioo_q) + + fldlist(index_So_omask)%dataptr(:) = 0._r8 + fldlist(index_So_u)%dataptr(:) = 0._r8 + fldlist(index_So_v)%dataptr(:) = 0._r8 + fldlist(index_So_dhdx)%dataptr(:) = 0._r8 + fldlist(index_So_dhdy)%dataptr(:) = 0._r8 + fldlist(index_So_t)%dataptr(:) = 0._r8 + fldlist(index_So_s)%dataptr(:) = 0._r8 + fldlist(index_So_bldepth)%dataptr(:) = 0._r8 + fldlist(index_Fioo_q)%dataptr(:) = 0._r8 + + !$omp parallel do private(l, i, n, utmp, vtmp) + do j = 1, jjcpl + do l = 1, isp(j) + do i = max(1, ifp(j,l)), min(ii, ilp(j,l)) + n = (j - 1)*ii + i + + ! Ocean mask []. + fldlist(index_So_omask)%dataptr(n) = 1._r8 + + ! Surface velocity, interpolated onto scalar points and rotated + ! [m s-1]. + utmp = .5_r8*(acc_u(i,j) + acc_u(i+1,j))*tfac*1.e-2_r8 + vtmp = .5_r8*(acc_v(i,j) + acc_v(i,j+1))*tfac*1.e-2_r8 + fldlist(index_So_u)%dataptr(n) = utmp*cosang(i,j) & + - vtmp*sinang(i,j) + fldlist(index_So_v)%dataptr(n) = utmp*sinang(i,j) & + + vtmp*cosang(i,j) + + ! Surface gradient, interpolated onto scalar points and rotated []. + utmp = (acc_dhdx(i,j)*iu(i,j) + acc_dhdx(i+1,j)*iu(i+1,j))*tfac & + /max(1, iu(i,j) + iu(i+1,j)) + vtmp = (acc_dhdy(i,j)*iv(i,j) + acc_dhdy(i,j+1)*iv(i,j+1))*tfac & + /max(1, iv(i,j) + iv(i,j+1)) + fldlist(index_So_dhdx)%dataptr(n) = utmp*cosang(i,j) & + - vtmp*sinang(i,j) + fldlist(index_So_dhdy)%dataptr(n) = utmp*sinang(i,j) & + + vtmp*cosang(i,j) + + ! Surface temperature [K]. + fldlist(index_So_t)%dataptr(n) = acc_t(i,j)*tfac & + + SHR_CONST_TKFRZ + + ! Surface salinity [g kg-1]. + fldlist(index_So_s)%dataptr(n) = acc_s(i,j)*tfac + + ! Boundary layer depth [m]. + fldlist(index_So_bldepth)%dataptr(n) = acc_bld(i,j)*tfac + + ! Freezing/melting potential [W m-2]. + if (acc_frzpot(i,j) > 0._r8) then + fldlist(index_Fioo_q)%dataptr(n) = & + acc_frzpot(i,j)*tfac*mod2med_areacor(n) + else + fldlist(index_Fioo_q)%dataptr(n) = & + mltpot(i,j)*tfac*mod2med_areacor(n) + endif + + enddo + enddo + enddo + !$omp end parallel do + + ! ------------------------------------------------------------------------ + ! Provide DMS flux [kmol DMS m-2 s-1], if requested. + ! ------------------------------------------------------------------------ + + call getfldindex(fldlist_num, fldlist, 'Faoo_fdms_ocn', & + index_Faoo_fdms_ocn) + + if (fbrf_requested .and. index_Faoo_fdms_ocn > 0) then + fldlist(index_Faoo_fdms_ocn)%dataptr(:) = 0._r8 + !$omp parallel do private(l, i, n) + do j = 1, jjcpl + do l = 1, isp(j) + do i = max(1, ifp(j,l)), min(ii, ilp(j,l)) + n = (j - 1)*ii + i + fldlist(index_Faoo_fdms_ocn)%dataptr(n) = & + acc_fbrf(i,j)*tfac*mod2med_areacor(n) + enddo + enddo + enddo + !$omp end parallel do + else + if (mnproc == 1) & + write(lp,*) subname//': dms flux not sent to coupler' + endif + + ! ------------------------------------------------------------------------ + ! Provide CO2 flux [kg CO2 m-2 s-1], if requested. + ! ------------------------------------------------------------------------ + + call getfldindex(fldlist_num, fldlist, 'Faoo_fco2_ocn', & + index_Faoo_fco2_ocn) + + if (fco2_requested .and. index_Faoo_fco2_ocn > 0) then + fldlist(index_Faoo_fco2_ocn)%dataptr(:) = 0._r8 + !$omp parallel do private(l, i, n) + do j = 1, jjcpl + do l = 1, isp(j) + do i = max(1, ifp(j,l)), min(ii, ilp(j,l)) + n = (j - 1)*ii + i + fldlist(index_Faoo_fco2_ocn)%dataptr(n) = & + acc_fco2(i,j)*tfac*mod2med_areacor(n) + enddo + enddo + enddo + !$omp end parallel do + else + if (mnproc == 1) & + write(lp,*) subname//': co2 flux not sent to coupler' + endif + + ! ------------------------------------------------------------------------ + ! Provide bromoform flux [kg CHBr3 m-2 s-1], if requested. + ! ------------------------------------------------------------------------ + + call getfldindex(fldlist_num, fldlist, 'Faoo_fbrf_ocn', & + index_Faoo_fbrf_ocn) + + if (fbrf_requested .and. index_Faoo_fbrf_ocn > 0) then + fldlist(index_Faoo_fbrf_ocn)%dataptr(:) = 0._r8 + !$omp parallel do private(l, i, n) + do j = 1, jjcpl + do l = 1, isp(j) + do i = max(1, ifp(j,l)), min(ii, ilp(j,l)) + n = (j - 1)*ii + i + fldlist(index_Faoo_fbrf_ocn)%dataptr(n) = & + acc_fbrf(i,j)*tfac*mod2med_areacor(n) + enddo + enddo + enddo + !$omp end parallel do + else + if (mnproc == 1) & + write(lp,*) subname//': bromoform flux not sent to coupler' + endif + + tlast_coupled = 0._r8 + + end subroutine blom_exportflds + +end module mod_nuopc_methods diff --git a/drivers/nuopc/mod_swtfrz.F90 b/drivers/nuopc/mod_swtfrz.F90 new file mode 100644 index 00000000..d5209eeb --- /dev/null +++ b/drivers/nuopc/mod_swtfrz.F90 @@ -0,0 +1,81 @@ +! ------------------------------------------------------------------------------ +! Copyright (C) 2018-2022 Mats Bentsen +! +! 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_swtfrz +! ------------------------------------------------------------------------------ +! This module contains routines for computing the freezing point of sea water. +! ------------------------------------------------------------------------------ + + use mod_types, only: r8 + use shr_frz_mod, only: shr_frz_freezetemp + + implicit none + + private + + public :: swtfrz + + interface swtfrz + module procedure swtfrz_0d + module procedure swtfrz_1d + module procedure swtfrz_2d + end interface swtfrz + +contains + + function swtfrz_0d(p,s) result(swtfrz) + ! --------------------------------------------------------------------------- + ! Retrieve freezing temperature from shared CESM function. + ! --------------------------------------------------------------------------- + + real(r8), intent(in) :: p ! Pressure [g cm-1 s-2] + real(r8), intent(in) :: s ! Salinity [g kg-1] + real(r8) :: swtfrz + + swtfrz = shr_frz_freezetemp(s) + + end function swtfrz_0d + + function swtfrz_1d(p,s) result(swtfrz) + ! --------------------------------------------------------------------------- + ! Retrieve freezing temperature from shared CESM function. + ! --------------------------------------------------------------------------- + + real(r8), intent(in) :: p(:) ! Pressure [g cm-1 s-2] + real(r8), intent(in) :: s(:) ! Salinity [g kg-1] + real(r8) :: swtfrz(size(s)) + + swtfrz(:) = shr_frz_freezetemp(s(:)) + + end function swtfrz_1d + + function swtfrz_2d(p,s) result(swtfrz) + ! --------------------------------------------------------------------------- + ! Retrieve freezing temperature from shared CESM function. + ! --------------------------------------------------------------------------- + + real(r8), intent(in) :: p(:,:) ! Pressure [g cm-1 s-2] + real(r8), intent(in) :: s(:,:) ! Salinity [g kg-1] + real(r8) :: swtfrz(size(s,1),size(s,2)) + + swtfrz(:,:) = shr_frz_freezetemp(s(:,:)) + + end function swtfrz_2d + +end module mod_swtfrz diff --git a/drivers/nuopc/ocn_comp_nuopc.F90 b/drivers/nuopc/ocn_comp_nuopc.F90 new file mode 100644 index 00000000..086501e5 --- /dev/null +++ b/drivers/nuopc/ocn_comp_nuopc.F90 @@ -0,0 +1,1189 @@ +! ------------------------------------------------------------------------------ +! Copyright (C) 2022 Mats Bentsen +! +! 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 ocn_comp_nuopc +! ------------------------------------------------------------------------------ +! This module contains the NUOPC cap for BLOM. +! ------------------------------------------------------------------------------ + + use ESMF ! TODO MOM6 uses "only" statements, while POP and CICE omits this. + use NUOPC, only: NUOPC_CompDerive, NUOPC_CompSetEntryPoint, & + NUOPC_CompSpecialize, NUOPC_CompFilterPhaseMap, & + NUOPC_IsUpdated, NUOPC_IsAtTime, NUOPC_CompAttributeGet, & + NUOPC_Advertise, NUOPC_SetAttribute, & + NUOPC_CompAttributeGet, NUOPC_CompAttributeSet, & + NUOPC_IsConnected, NUOPC_Realize + use NUOPC_Model, only: NUOPC_ModelGet, SetVM, & + model_routine_SS => SetServices, & + model_label_Advance => label_Advance, & + model_label_DataInitialize => label_DataInitialize, & + model_label_SetRunClock => label_SetRunClock, & + model_label_Finalize => label_Finalize + use nuopc_shr_methods, only : ChkErr, set_component_logging, & + get_component_instance, state_setscalar, & + alarmInit + use shr_file_mod, only: shr_file_getUnit, shr_file_getLogUnit, & + shr_file_setLogUnit + use shr_cal_mod, only : shr_cal_ymd2date + use mod_nuopc_methods, only: fldlist_type, tlast_coupled, fco2_requested, & + fdms_requested, fbrf_requested, & + blom_logwrite, blom_getgindex, blom_checkmesh, & + blom_setareacor, blom_getglobdim, & + blom_getprecipfact, blom_accflds, & + blom_importflds, blom_exportflds + use mod_xc, only: mpicom_external, lp, nfu + use mod_cesm, only: runid_cesm, runtyp_cesm, ocn_cpl_dt_cesm + use mod_config, only: inst_index, inst_name, inst_suffix + use mod_time, only: blom_time + + implicit none + + private + + integer, parameter :: cslen = 80 ! Short character string length. + integer, parameter :: cllen = 265 ! Long character string length. + character(len=*), parameter :: modname = '(ocn_comp_nuopc)' + character(len=*), parameter :: u_FILE_u = & + __FILE__ + + integer, parameter :: fldsMax = 100 + integer :: fldsToOcn_num = 0 + integer :: fldsFrOcn_num = 0 + type(fldlist_type) :: fldsToOcn(fldsMax) + type(fldlist_type) :: fldsFrOcn(fldsMax) + + character(len=cllen) :: flds_scalar_name = '' + integer :: flds_scalar_num = 0 + integer :: flds_scalar_index_nx = 0 + integer :: flds_scalar_index_ny = 0 + integer :: flds_scalar_index_precip_factor = 0 + + logical :: ldriver_has_atm_co2_diag, ldriver_has_atm_co2_prog, & + ocn2glc_coupling + + integer :: dbug = 0 + logical :: profile_memory = .false. + + public :: SetServices, SetVM + +contains + + ! --------------------------------------------------------------------------- + ! Private procedures. + ! --------------------------------------------------------------------------- + + subroutine fldlist_add(num, fldlist, stdname, & + ungridded_lbound, ungridded_ubound) + ! --------------------------------------------------------------------------- + ! Add to list of field information. + ! --------------------------------------------------------------------------- + + ! Input/output arguments. + integer , intent(inout) :: num + type(fldlist_type), intent(inout) :: fldlist(:) + character(len=*) , intent(in) :: stdname + integer, optional , intent(in) :: ungridded_lbound, ungridded_ubound + + ! Local parameters. + character(len=*), parameter :: & + subname = modname//':(fldlist_add)' + + ! Local variables. + integer :: rc + + num = num + 1 + if (num > fldsMax) then + call ESMF_LogSetError(ESMF_RC_VAL_OUTOFRANGE, & + msg=subname//": ERROR number of field exceeded fldsMax: "// & + trim(stdname), & + line=__LINE__, file=__FILE__, rcToReturn=rc) + return + endif + fldlist(num)%stdname = trim(stdname) + + if (present(ungridded_lbound) .and. present(ungridded_ubound)) then + fldlist(num)%ungridded_lbound = ungridded_lbound + fldlist(num)%ungridded_ubound = ungridded_ubound + endif + + end subroutine fldlist_add + + subroutine fldlist_realize(state, fldlist_num, fldlist, tag, mesh, rc) + ! --------------------------------------------------------------------------- + ! Realize list of import or export fields. + ! --------------------------------------------------------------------------- + + ! Input/output arguments. + type(ESMF_State) , intent(inout) :: state + integer , intent(in) :: fldlist_num + type(fldlist_type), intent(in) :: fldlist(:) + character(len=*) , intent(in) :: tag + type(ESMF_Mesh) , intent(in) :: mesh + integer , intent(inout) :: rc + + ! Local parameters. + character(len=*), parameter :: & + subname = modname//':(fldlist_realize)' + + ! Local variables. + integer :: n + type(ESMF_DistGrid) :: DistGrid + type(ESMF_Grid) :: grid + type(ESMF_Field) :: field + character(len=128) :: stdname + character(ESMF_MAXSTR) :: msg + + rc = ESMF_SUCCESS + + do n = 1, fldlist_num + + stdname = fldlist(n)%stdname + + if (NUOPC_IsConnected(state, fieldName=stdname)) then + + if (stdname == trim(flds_scalar_name)) then + + ! Create the scalar field. + call ESMF_LogWrite(subname//trim(tag)//" Field = "// & + trim(stdname)//" is connected on root pe", & + ESMF_LOGMSG_INFO) + DistGrid = ESMF_DistGridCreate(minIndex=(/1/), maxIndex=(/1/), rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + grid = ESMF_GridCreate(DistGrid, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + field = ESMF_FieldCreate(name=trim(flds_scalar_name), & + grid=grid, & + typekind=ESMF_TYPEKIND_R8, & + ungriddedLBound=(/1/), & + ungriddedUBound=(/flds_scalar_num/), & + gridToFieldMap=(/2/), rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + + else + + ! Create the field + if (fldlist(n)%ungridded_lbound > 0 .and. & + fldlist(n)%ungridded_ubound > 0) then + field = ESMF_FieldCreate(mesh, ESMF_TYPEKIND_R8, & + name=stdname, meshloc=ESMF_MESHLOC_ELEMENT, & + ungriddedLbound=(/fldlist(n)%ungridded_lbound/), & + ungriddedUbound=(/fldlist(n)%ungridded_ubound/), & + gridToFieldMap=(/2/), rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + write(msg,'(a,i4,2x,i4)') & + subname//trim(tag)//" Field = "//trim(stdname)// & + " is connected using mesh with lbound, ubound = ", & + fldlist(n)%ungridded_lbound, fldlist(n)%ungridded_ubound + call ESMF_LogWrite(msg, ESMF_LOGMSG_INFO) + else + field = ESMF_FieldCreate(mesh, ESMF_TYPEKIND_R8, & + name=stdname, & + meshloc=ESMF_MESHLOC_ELEMENT, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + write(msg,'(a)') & + subname//trim(tag)//" Field = "//trim(stdname)// & + " is connected using mesh without ungridded dimension" + call ESMF_LogWrite(msg, ESMF_LOGMSG_INFO) + endif + + endif + + ! Realize connected field. + call NUOPC_Realize(state, field=field, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + + else + + if (stdname /= trim(flds_scalar_name)) then + + call ESMF_LogWrite(subname//trim(tag)//" Field = "// & + trim(stdname)// " is not connected", & + ESMF_LOGMSG_INFO) + + ! Remove a not connected field from state. + call ESMF_StateRemove(state, (/stdname/), rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + + endif + + endif + + enddo + + end subroutine fldlist_realize + + subroutine ocn_import(importState, rc) + ! --------------------------------------------------------------------------- + ! Import data from the mediator to ocean. + ! --------------------------------------------------------------------------- + + ! Input/output arguments. + type(ESMF_State) :: importState + integer, intent(out) :: rc + + ! Local parameters. + character(len=*), parameter :: & + subname = modname//':(import)' + + ! Local variables. + type(ESMF_StateItem_Flag) :: itemType + type(ESMF_Field) :: field + integer :: n + + rc = ESMF_SUCCESS + + ! Get data pointers for the fields to be imported. + do n = 1, fldsToOcn_num + if (fldsToOcn(n)%stdname == trim(flds_scalar_name)) cycle + call ESMF_StateGet(importState, trim(fldsToOcn(n)%stdname), & + itemType, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + if (itemType == ESMF_STATEITEM_NOTFOUND) then + fldsToOcn(n)%dataptr => null() + else + call ESMF_StateGet(importState, trim(fldsToOcn(n)%stdname), & + field=field, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + call ESMF_FieldGet(field, farrayPtr=fldsToOcn(n)%dataptr, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + endif + enddo + + ! Import fields from mediator to BLOM arrays. + call blom_importflds(fldsToOcn_num, fldsToOcn) + + end subroutine ocn_import + + subroutine ocn_export(exportState, rc) + ! --------------------------------------------------------------------------- + ! Export data from ocean to the mediator. + ! --------------------------------------------------------------------------- + + ! Input/output arguments. + type(ESMF_State) :: exportState + integer, intent(out) :: rc + + ! Local parameters. + character(len=*), parameter :: & + subname = modname//':(export)' + + ! Local variables. + type(ESMF_StateItem_Flag) :: itemType + type(ESMF_Field) :: field + real(ESMF_KIND_R8) :: precip_fact + integer :: n + logical :: precip_fact_provided + + rc = ESMF_SUCCESS + + ! Get data pointers for the fields to be exported. + do n = 1, fldsFrOcn_num + if (fldsFrOcn(n)%stdname == trim(flds_scalar_name)) cycle + call ESMF_StateGet(exportState, trim(fldsFrOcn(n)%stdname), & + itemType, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + if (itemType == ESMF_STATEITEM_NOTFOUND) then + fldsFrOcn(n)%dataptr => null() + else + call ESMF_StateGet(exportState, trim(fldsFrOcn(n)%stdname), & + field=field, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + call ESMF_FieldGet(field, farrayPtr=fldsFrOcn(n)%dataptr, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + endif + enddo + + ! Export from BLOM arrays to mediator fields. + call blom_exportflds(fldsFrOcn_num, fldsFrOcn) + + ! Provide precipitation factor. + call blom_getprecipfact(precip_fact_provided, precip_fact) + if (precip_fact_provided) then + call state_setscalar(precip_fact, & + flds_scalar_index_precip_factor, exportState, & + flds_scalar_name, flds_scalar_num, rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + else + call state_setscalar(1._ESMF_KIND_R8, & + flds_scalar_index_precip_factor, exportState, & + flds_scalar_name, flds_scalar_num, rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + endif + + end subroutine ocn_export + + subroutine InitializeP0(gcomp, importState, exportState, clock, rc) + ! --------------------------------------------------------------------------- + ! Set which version of the Initialize Phase Definition (IPD) to use. + ! --------------------------------------------------------------------------- + + ! Input/output arguments. + type(ESMF_GridComp) :: gcomp + type(ESMF_State) :: importState, exportState + type(ESMF_Clock) :: clock + integer, intent(out) :: rc + + ! Local parameters. + character(len=*), parameter :: & + subname = modname//':(InitializeP0)' + + ! Local variables. + logical :: isPresent, isSet + character(len=cslen) :: cvalue + + ! Switch to IPDv01 by filtering all other PhaseMap entries + call NUOPC_CompFilterPhaseMap(gcomp, ESMF_METHOD_INITIALIZE, & + acceptStringList=(/"IPDv01p"/), rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + + profile_memory = .false. + call NUOPC_CompAttributeGet(gcomp, name="ProfileMemory", value=cvalue, & + isPresent=isPresent, isSet=isSet, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + if (isPresent .and. isSet) profile_memory = (trim(cvalue) == "true") + write(cvalue,*) profile_memory + call ESMF_LogWrite(subname//': ProfileMemory = '//trim(cvalue), & + ESMF_LOGMSG_INFO) + + end subroutine InitializeP0 + + subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) + ! --------------------------------------------------------------------------- + ! Called by NUOPC to advertise import and export fields. "Advertise" simply + ! means that the standard names of all import and export fields are supplied. + ! The NUOPC layer uses these to match fields between components in the + ! coupled system. + ! --------------------------------------------------------------------------- + + ! Input/output arguments. + type(ESMF_GridComp) :: gcomp + type(ESMF_State) :: importState, exportState + type(ESMF_Clock) :: clock + integer, intent(out) :: rc + + ! Local parameters. + character(len=*), parameter :: & + subname = modname//':(InitializeAdvertise)' + + ! local variables + type(ESMF_VM) :: vm + type(ESMF_TimeInterval) :: timeStep + integer :: localPet, nthrds, shrlogunit, n + character(len=cslen) :: starttype, stdname, cvalue, cname + character(len=cllen) :: msg + logical :: isPresent, isSet, flds_co2a, flds_co2b, flds_co2c + + ! Get debug flag. + call NUOPC_CompAttributeGet(gcomp, name='dbug_flag', value=cvalue, & + isPresent=isPresent, isSet=isSet, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + if (isPresent .and. isSet) read(cvalue,*) dbug + write(cvalue,*) dbug + call ESMF_LogWrite(subname//': dbug = '//trim(cvalue), ESMF_LOGMSG_INFO) + + ! Get local MPI communicator and Persistent Execution Thread (PET). + call ESMF_GridCompGet(gcomp, vm=vm, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + call ESMF_VMGet(vm, mpiCommunicator=mpicom_external, localPet=localPet, & + rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + + ! OpenMP threads + call ESMF_VMGet(vm, pet=localPet, peCount=nthrds, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + if (nthrds == 1) then + call NUOPC_CompAttributeGet(gcomp, "nthreads", value=cvalue, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + read(cvalue,*) nthrds + endif +!$ call omp_set_num_threads(nthrds) + + ! Reset shr logging to components log file. + call set_component_logging(gcomp, localPet==0, lp, shrlogunit, rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + + ! Get generic file unit for master task. + if (localPet == 0) then + nfu = shr_file_getUnit() + else + nfu = -1 + endif + + ! Get case name. + call NUOPC_CompAttributeGet(gcomp, name='case_name', value=cvalue, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + read(cvalue,*) runid_cesm + + ! Get start type. + call NUOPC_CompAttributeGet(gcomp, name='start_type', value=cvalue, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + read(cvalue,*) starttype + if (trim(starttype) == trim('startup')) then + runtyp_cesm = "initial" + else if (trim(starttype) == trim('continue') ) then + runtyp_cesm = "continue" + else if (trim(starttype) == trim('branch')) then + runtyp_cesm = "continue" + else + call ESMF_LogSetError(ESMF_RC_ARG_BAD, & + msg=subname//": unknown starttype - "//trim(starttype), & + line=__LINE__, file=u_FILE_u, rcToReturn=rc) + return + endif + + ! Get multiple instance data. + call get_component_instance(gcomp, inst_suffix, inst_index, rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + inst_name = "OCN" + + ! Get coupling time interval. + call ESMF_ClockGet(clock, timeStep=timeStep, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + call ESMF_TimeIntervalGet(timeStep, s=ocn_cpl_dt_cesm, rc=rc ) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + + ! ------------------------------------------------------------------------ + ! Initialize BLOM. + ! ------------------------------------------------------------------------ + + call blom_init + + ! ------------------------------------------------------------------------ + ! Get ScalarField attributes. + ! ------------------------------------------------------------------------ + + call NUOPC_CompAttributeGet(gcomp, name="ScalarFieldName", value=cvalue, & + isPresent=isPresent, isSet=isSet, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + if (isPresent .and. isSet) then + flds_scalar_name = trim(cvalue) + call ESMF_LogWrite(subname//': flds_scalar_name = '//trim(cvalue), & + ESMF_LOGMSG_INFO) + else + call ESMF_LogSetError(ESMF_RC_NOT_SET, & + msg=subname//": ScalarFieldName is not set", & + line=__LINE__, file=__FILE__, rcToReturn=rc) + return + endif + + call NUOPC_CompAttributeGet(gcomp, name="ScalarFieldCount", & + value=cvalue, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + read(cvalue,*) flds_scalar_num + write(cvalue,*) flds_scalar_num + call ESMF_LogWrite(subname//': flds_scalar_num = '//trim(cvalue), & + ESMF_LOGMSG_INFO) + + call NUOPC_CompAttributeGet(gcomp, name="ScalarFieldIdxGridNX", & + value=cvalue, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + read(cvalue,*) flds_scalar_index_nx + write(cvalue,*) flds_scalar_index_nx + call ESMF_LogWrite(subname//': flds_scalar_index_nx = '//trim(cvalue), & + ESMF_LOGMSG_INFO) + + call NUOPC_CompAttributeGet(gcomp, name="ScalarFieldIdxGridNY", & + value=cvalue, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + read(cvalue,*) flds_scalar_index_ny + write(cvalue,*) flds_scalar_index_ny + call ESMF_LogWrite(subname//': flds_scalar_index_ny = '//trim(cvalue), & + ESMF_LOGMSG_INFO) + + call NUOPC_CompAttributeGet(gcomp, name="ScalarFieldIdxPrecipFactor", & + value=cvalue, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + read(cvalue,*) flds_scalar_index_precip_factor + if ( .not. flds_scalar_index_precip_factor > 0 ) then + call ESMF_LogSetError(ESMF_RC_VAL_OUTOFRANGE, & + msg=subname//": flds_scalar_index_precip_factor must be > 0", & + line=__LINE__, file=u_FILE_u, rcToReturn=rc) + return + else + write(cvalue,*) flds_scalar_index_precip_factor + call ESMF_LogWrite(subname//': flds_scalar_index_precip_factor = '// & + trim(cvalue), ESMF_LOGMSG_INFO) + endif + + ! ------------------------------------------------------------------------ + ! Advertise import fields. + ! ------------------------------------------------------------------------ + + call fldlist_add(fldsToOcn_num, fldsToOcn, trim(flds_scalar_name)) + + ! From ice: + call fldlist_add(fldsToOcn_num, fldsToOcn, 'Si_ifrac') + call fldlist_add(fldsToOcn_num, fldsToOcn, 'Fioi_melth') + call fldlist_add(fldsToOcn_num, fldsToOcn, 'Fioi_meltw') + call fldlist_add(fldsToOcn_num, fldsToOcn, 'Fioi_salt') + call fldlist_add(fldsToOcn_num, fldsToOcn, 'Fioi_bcpho') + call fldlist_add(fldsToOcn_num, fldsToOcn, 'Fioi_bcphi') + call fldlist_add(fldsToOcn_num, fldsToOcn, 'Fioi_flxdst') + + ! From river: + call fldlist_add(fldsToOcn_num, fldsToOcn, 'Foxx_rofl') + call fldlist_add(fldsToOcn_num, fldsToOcn, 'Foxx_rofi') + + ! From mediator: + call fldlist_add(fldsToOcn_num, fldsToOcn, 'So_duu10n') + call fldlist_add(fldsToOcn_num, fldsToOcn, 'Foxx_tauy') + call fldlist_add(fldsToOcn_num, fldsToOcn, 'Foxx_taux') + call fldlist_add(fldsToOcn_num, fldsToOcn, 'Foxx_lat') + call fldlist_add(fldsToOcn_num, fldsToOcn, 'Foxx_sen') + call fldlist_add(fldsToOcn_num, fldsToOcn, 'Foxx_lwup') + call fldlist_add(fldsToOcn_num, fldsToOcn, 'Foxx_evap') + call fldlist_add(fldsToOcn_num, fldsToOcn, 'Foxx_swnet') + + ! From wave: + call fldlist_add(fldsToOcn_num, fldsToOcn, 'Sw_lamult') + call fldlist_add(fldsToOcn_num, fldsToOcn, 'Sw_ustokes') + call fldlist_add(fldsToOcn_num, fldsToOcn, 'Sw_vstokes') + call fldlist_add(fldsToOcn_num, fldsToOcn, 'Sw_hstokes') + + ! From atmosphere: + call fldlist_add(fldsToOcn_num, fldsToOcn, 'Sa_pslv') + call fldlist_add(fldsToOcn_num, fldsToOcn, 'Faxa_lwdn') + call fldlist_add(fldsToOcn_num, fldsToOcn, 'Faxa_snow') + call fldlist_add(fldsToOcn_num, fldsToOcn, 'Faxa_rain') + + ! From atm co2 fields: + + call NUOPC_CompAttributeGet(gcomp, name='flds_co2a', value=cvalue, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + read(cvalue,*) flds_co2a + call blom_logwrite(subname//': flds_co2a = '//trim(cvalue)) + + call NUOPC_CompAttributeGet(gcomp, name='flds_co2b', value=cvalue, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + read(cvalue,*) flds_co2b + call blom_logwrite(subname//': flds_co2b = '//trim(cvalue)) + + call NUOPC_CompAttributeGet(gcomp, name='flds_co2c', value=cvalue, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + read(cvalue,*) flds_co2c + call blom_logwrite(subname//': flds_co2c = '//trim(cvalue)) + + if (flds_co2a .or. flds_co2c) then + call fldlist_add(fldsToOcn_num, fldsToOcn, 'Sa_co2diag') + call fldlist_add(fldsToOcn_num, fldsToOcn, 'Sa_co2prog') + ldriver_has_atm_co2_prog = .true. + ldriver_has_atm_co2_diag = .true. + else + ldriver_has_atm_co2_prog = .false. + ldriver_has_atm_co2_diag = .false. + endif + + !TODO Determine if will get nitrogen deposition from atm + + do n = 1,fldsToOcn_num + call NUOPC_Advertise(importState, standardName=fldsToOcn(n)%stdname, & + TransferOfferGeomObject='will provide', rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + enddo + + ! ------------------------------------------------------------------------ + ! Advertise export fields. + ! ------------------------------------------------------------------------ + + ! Determine if ocn is sending temperature and salinity data to glc + call NUOPC_CompAttributeGet(gcomp, name="ocn2glc_coupling", value=cvalue, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + read(cvalue,*) ocn2glc_coupling + write(msg,'(a,l1)') subname//': ocn2glc coupling is ', ocn2glc_coupling + call blom_logwrite(msg) + + ! Determine number of ocean levels and ocean level indices + if (ocn2glc_coupling) then + call ESMF_LogSetError(ESMF_RC_NOT_IMPL, & + msg=subname//": ocn2glc coupling not implemented", & + line=__LINE__, file=u_FILE_u, rcToReturn=rc) + return + endif + + call fldlist_add(fldsFrOcn_num, fldsFrOcn, trim(flds_scalar_name)) + call fldlist_add(fldsFrOcn_num, fldsFrOcn, 'So_omask') + call fldlist_add(fldsFrOcn_num, fldsFrOcn, 'So_t') + call fldlist_add(fldsFrOcn_num, fldsFrOcn, 'So_u') + call fldlist_add(fldsFrOcn_num, fldsFrOcn, 'So_v') + call fldlist_add(fldsFrOcn_num, fldsFrOcn, 'So_s') + call fldlist_add(fldsFrOcn_num, fldsFrOcn, 'So_dhdx') + call fldlist_add(fldsFrOcn_num, fldsFrOcn, 'So_dhdy') + call fldlist_add(fldsFrOcn_num, fldsFrOcn, 'So_bldepth') + call fldlist_add(fldsFrOcn_num, fldsFrOcn, 'Fioo_q') + call fldlist_add(fldsFrOcn_num, fldsFrOcn, 'Faoo_fco2_ocn') + + do n = 1,fldsFrOcn_num + call NUOPC_Advertise(exportState, standardName=fldsFrOcn(n)%stdname, & + TransferOfferGeomObject='will provide', rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + enddo + + if (dbug > 5) call ESMF_LogWrite(subname//': done', ESMF_LOGMSG_INFO) + + end subroutine InitializeAdvertise + + subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) + ! --------------------------------------------------------------------------- + ! Called by NUOPC to realize import and export fields. "Realizing" a field + ! means that its grid has been defined and an ESMF_Field object has been + ! created and put into the import or export State. + ! --------------------------------------------------------------------------- + + ! Input/output arguments. + type(ESMF_GridComp) :: gcomp + type(ESMF_State) :: importState, exportState + type(ESMF_Clock) :: clock + integer, intent(out) :: rc + + ! Local parameters. + character(len=*), parameter :: & + subname = modname//':(InitializeRealize)' + + ! Local variables. + type(ESMF_DistGrid) :: DistGrid + type(ESMF_Mesh) :: EMesh + type(ESMF_Array) :: elemMaskArray + type(ESMF_Field) :: field + real(ESMF_KIND_R8), dimension(:), pointer :: & + ownedElemCoords, lonMesh, latMesh, areaMesh + integer(ESMF_KIND_I4), dimension(:), pointer :: maskMesh(:) + integer, allocatable, dimension(:) :: gindex + integer :: n, spatialDim, numOwnedElements, nx_global, ny_global + character(len=cslen) :: cvalue + + if (dbug > 5) call ESMF_LogWrite(subname//': called', ESMF_LOGMSG_INFO) + + ! Get the BLOM global index space for the computational domain. + call blom_getgindex(gindex) + + ! Create DistGrid from global index array. + DistGrid = ESMF_DistGridCreate(arbSeqIndexList=gindex, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + + ! Create the mesh. + call NUOPC_CompAttributeGet(gcomp, name='mesh_ocn', value=cvalue, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + EMesh = ESMF_MeshCreate(filename=trim(cvalue), & + fileformat=ESMF_FILEFORMAT_ESMFMESH, & + elementDistgrid=DistGrid, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + call blom_logwrite(subname//': mesh file for blom domain is '// & + trim(cvalue)) + + ! ------------------------------------------------------------------------ + ! Check for consistency of lat, lon and mask between mesh and model grid. + ! ------------------------------------------------------------------------ + + call ESMF_MeshGet(Emesh, spatialDim=spatialDim, & + numOwnedElements=numOwnedElements, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + + allocate(ownedElemCoords(spatialDim*numOwnedElements), & + lonMesh(numOwnedElements), latMesh(numOwnedElements), & + maskMesh(numOwnedElements)) + + call ESMF_MeshGet(Emesh, ownedElemCoords=ownedElemCoords, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + do n = 1, numOwnedElements + lonMesh(n) = ownedElemCoords(2*n-1) + latMesh(n) = ownedElemCoords(2*n) + enddo + + elemMaskArray = ESMF_ArrayCreate(Distgrid, maskMesh, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + call ESMF_MeshGet(Emesh, elemMaskArray=elemMaskArray, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + + call blom_checkmesh(lonMesh, latMesh, maskMesh) + + ! ------------------------------------------------------------------------ + ! Determine flux area correction factors. + ! ------------------------------------------------------------------------ + + field = ESMF_FieldCreate(Emesh, ESMF_TYPEKIND_R8, & + meshloc=ESMF_MESHLOC_ELEMENT, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + call ESMF_FieldRegridGetArea(field, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + call ESMF_FieldGet(field, farrayPtr=areaMesh, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + + call blom_setareacor(areaMesh, maskMesh) + + ! ------------------------------------------------------------------------ + ! Realize the actively coupled fields. + ! ------------------------------------------------------------------------ + + call fldlist_realize(state=importState, & + fldlist_num=fldsToOcn_num, fldlist=fldsToOcn, & + tag=subname//':BLOM_Import', mesh=EMesh, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + + call fldlist_realize(state=exportState, & + fldlist_num=fldsFrOcn_num, fldlist=fldsFrOcn, & + tag=subname//':BLOM_Export', mesh=EMesh, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + + ! ------------------------------------------------------------------------ + ! Set scalar data in export state. + ! ------------------------------------------------------------------------ + + call blom_getglobdim(nx_global, ny_global) + + call state_setscalar(real(nx_global, ESMF_KIND_R8), & + flds_scalar_index_nx, exportState, & + flds_scalar_name, flds_scalar_num, rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + + call state_setscalar(real(ny_global, ESMF_KIND_R8), & + flds_scalar_index_ny, exportState, & + flds_scalar_name, flds_scalar_num, rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + + if (dbug > 5) call ESMF_LogWrite(subname//': done', ESMF_LOGMSG_INFO) + + end subroutine InitializeRealize + + subroutine DataInitialize(gcomp, rc) + ! --------------------------------------------------------------------------- + ! Called by NUOPC to do the initial data export from ocean to mediator. + ! --------------------------------------------------------------------------- + + ! Input/output arguments. + type(ESMF_GridComp) :: gcomp + integer, intent(out) :: rc + + ! Local parameters. + character(len=*), parameter :: & + subname = modname//':(DataInitialize)' + + ! Local variables. + type(ESMF_State) :: exportState + type(ESMF_StateItem_flag) :: itemType + + if (dbug > 5) call ESMF_LogWrite(subname//': called', ESMF_LOGMSG_INFO) + + ! ------------------------------------------------------------------------ + ! Query the Component for its exportState. + ! ------------------------------------------------------------------------ + + call ESMF_GridCompGet(gcomp, exportState=exportState, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + + ! ------------------------------------------------------------------------ + ! Check whether non-standard export fields are present. + ! ------------------------------------------------------------------------ + + call ESMF_StateGet(exportState, 'Faoo_fco2_ocn', itemType) + fco2_requested = (itemType /= ESMF_STATEITEM_NOTFOUND) + + call ESMF_StateGet(exportState, 'Faoo_fdms_ocn', itemType) + fdms_requested = (itemType /= ESMF_STATEITEM_NOTFOUND) + + call ESMF_StateGet(exportState, 'Faoo_fbrf_ocn', itemType) + fbrf_requested = (itemType /= ESMF_STATEITEM_NOTFOUND) + + ! ------------------------------------------------------------------------ + ! TODO + ! ------------------------------------------------------------------------ + + tlast_coupled = 0._ESMF_KIND_R8 + call blom_accflds + call ocn_export(exportState, rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + + ! ------------------------------------------------------------------------ + ! Check whether all Fields in the exportState are "Updated" TODO + ! ------------------------------------------------------------------------ + + if (NUOPC_IsUpdated(exportState)) then + call NUOPC_CompAttributeSet(gcomp, name="InitializeDataComplete", & + value="true", rc=rc) + call ESMF_LogWrite("BLOM - Initialize-Data-Dependency SATISFIED!!!", & + ESMF_LOGMSG_INFO) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + else + call ESMF_LogWrite("BLOM - Initialize-Data-Dependency NOT SATISFIED!!!", & + ESMF_LOGMSG_INFO) + endif + + if (dbug > 5) call ESMF_LogWrite(subname//': done', ESMF_LOGMSG_INFO) + + end subroutine DataInitialize + + subroutine ModelAdvance(gcomp, rc) + ! --------------------------------------------------------------------------- + ! Called by NUOPC to advance the model a single timestep. + ! --------------------------------------------------------------------------- + + ! Input/output arguments. + type(ESMF_GridComp) :: gcomp + integer, intent(out) :: rc + + ! Local parameters. + character(len=*), parameter :: & + subname = modname//':(ModelAdvance)' + + ! Local variables. + type(ESMF_State) :: importState, exportState + type(ESMF_Clock) :: clock + type(ESMF_Time) :: currTime + type(ESMF_Alarm) :: restart_alarm + integer :: shrlogunit, yr_sync, mon_sync, day_sync, tod_sync, ymd_sync, & + ymd, tod + logical :: first_call = .true., restart_alarm_on + character(len=cllen) :: msg + + if (dbug > 5) call ESMF_LogWrite(subname//': called', ESMF_LOGMSG_INFO) + + rc = ESMF_SUCCESS + + ! ------------------------------------------------------------------------ + ! Reset shr logging to components log file. + ! ------------------------------------------------------------------------ + + call shr_file_getLogUnit(shrlogunit) + call shr_file_setLogUnit(lp) + + ! ------------------------------------------------------------------------ + ! Skip first coupling interval for an initial run. + ! ------------------------------------------------------------------------ + + if (first_call) then + first_call = .false. + if (runtyp_cesm == 'initial') then + call blom_logwrite('Returning at first coupling interval') + return + endif + endif + + ! ------------------------------------------------------------------------ + ! Query the Component for its clock, importState and exportState. + ! ------------------------------------------------------------------------ + + call NUOPC_ModelGet(gcomp, modelClock=clock, importState=importState, & + exportState=exportState, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + + ! ------------------------------------------------------------------------ + ! Check that internal clock is in sync with master clock. + ! ------------------------------------------------------------------------ + + if (ChkErr(rc, __LINE__, u_FILE_u)) return + call ESMF_ClockGet( clock, currTime=currTime, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + call ESMF_TimeGet(currTime, yy=yr_sync, mm=mon_sync, dd=day_sync, & + s=tod_sync, rc=rc ) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + call shr_cal_ymd2date(yr_sync, mon_sync, day_sync, ymd_sync) + + call blom_time(ymd, tod) + if (ymd /= ymd_sync .or. tod /= tod_sync) then + write(msg,*) ' blom ymd=',ymd ,' blom tod= ',tod + call blom_logwrite(msg) + write(msg,*) ' sync ymd=',ymd_sync,' sync tod= ',tod_sync + call blom_logwrite(msg) + call ESMF_LogSetError(ESMF_FAILURE, & + msg=subname//": Internal blom clock not in sync with Sync Clock", & + line=__LINE__, file=u_FILE_u, rcToReturn=rc) + return + endif + + ! ------------------------------------------------------------------------ + ! Advance the model in time over a coupling interval. + ! ------------------------------------------------------------------------ + + blom_loop: do + + if (nint(tlast_coupled) == 0) then + ! Obtain import state from driver + call ocn_import(importState, rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + endif + + ! Advance the model a time step. + call blom_step + + ! Accumulate BLOM export fields. + call blom_accflds + + if (nint(ocn_cpl_dt_cesm-tlast_coupled) == 0) then + ! Return export state to driver and exit integration loop + call ocn_export(exportState, rc) + exit blom_loop + endif + +! if (mnproc == 1) then +! call shr_sys_flush(lp) +! endif + + enddo blom_loop + + ! ------------------------------------------------------------------------ + ! If restart alarm is ringing - write restart file. TODO do we need to + ! consider stop alarm? + ! ------------------------------------------------------------------------ + + call ESMF_ClockGetAlarm(clock, alarmname='restart_alarm', & + alarm=restart_alarm, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + restart_alarm_on = ESMF_AlarmIsRinging(restart_alarm, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + + if (restart_alarm_on) then + + ! Turn off the alarm + call ESMF_AlarmRingerOff(restart_alarm, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + + ! Write BLOM restart files. + call restart_wt + + endif + + ! ------------------------------------------------------------------------ + ! Reset shr logging to original values. + ! ------------------------------------------------------------------------ + + call shr_file_setLogUnit(shrlogunit) + + if (dbug > 5) call ESMF_LogWrite(subname//': done', ESMF_LOGMSG_INFO) + + end subroutine ModelAdvance + + subroutine ModelSetRunClock(gcomp, rc) + ! --------------------------------------------------------------------------- + ! Synchronize driver and model clock and set restart and stop alarms. + ! --------------------------------------------------------------------------- + + ! Input/output arguments. + type(ESMF_GridComp) :: gcomp + integer, intent(out) :: rc + + ! Local parameters. + character(len=*), parameter :: & + subname = modname//':(ModelSetRunClock)' + + ! Local variables. + type(ESMF_Clock) :: mclock, dclock + type(ESMF_Time) :: mcurrtime, dcurrtime, mstoptime + type(ESMF_TimeInterval) :: mtimestep, dtimestep + type(ESMF_ALARM) :: restart_alarm, stop_alarm + integer :: restart_n, restart_ymd, stop_n, stop_ymd, alarmcount + character(len=256) :: cvalue, restart_option, stop_option + character(len=128) :: name + + if (dbug > 5) call ESMF_LogWrite(subname//': called', ESMF_LOGMSG_INFO) + + ! Query the component for its clocks. + + call NUOPC_ModelGet(gcomp, driverClock=dclock, modelClock=mclock, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + + call ESMF_ClockGet(dclock, currTime=dcurrtime, timeStep=dtimestep, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + + call ESMF_ClockGet(mclock, currTime=mcurrtime, timeStep=mtimestep, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + + ! ------------------------------------------------------------------------ + ! Force model clock currtime and timestep to match driver and set + ! stoptime. + ! ------------------------------------------------------------------------ + + mstoptime = mcurrtime + dtimestep + call ESMF_ClockSet(mclock, currTime=dcurrtime, timeStep=dtimestep, & + stopTime=mstoptime, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + + ! ------------------------------------------------------------------------ + ! Set restart and stop alarms. + ! ------------------------------------------------------------------------ + + call ESMF_ClockGetAlarmList(mclock, alarmlistflag=ESMF_ALARMLIST_ALL, & + alarmCount=alarmCount, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + + if (alarmCount == 0) then + + call ESMF_GridCompGet(gcomp, name=name, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + call ESMF_LogWrite(subname//': setting alarms for '//trim(name), & + ESMF_LOGMSG_INFO) + + + ! Restart alarm. + + call NUOPC_CompAttributeGet(gcomp, name="restart_option", & + value=restart_option, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + + call NUOPC_CompAttributeGet(gcomp, name="restart_n", & + value=cvalue, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + read(cvalue,*) restart_n + + call NUOPC_CompAttributeGet(gcomp, name="restart_ymd", & + value=cvalue, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + read(cvalue,*) restart_ymd + + call alarmInit(mclock, restart_alarm, restart_option, & + opt_n=restart_n, opt_ymd=restart_ymd, & + RefTime=mcurrTime, alarmname='restart_alarm', rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + + call ESMF_AlarmSet(restart_alarm, clock=mclock, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + + ! Stop alarm. + + call NUOPC_CompAttributeGet(gcomp, name="stop_option", & + value=stop_option, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + + call NUOPC_CompAttributeGet(gcomp, name="stop_n", & + value=cvalue, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + read(cvalue,*) stop_n + + call NUOPC_CompAttributeGet(gcomp, name="stop_ymd", & + value=cvalue, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + read(cvalue,*) stop_ymd + + call alarmInit(mclock, stop_alarm, stop_option, & + opt_n=stop_n, opt_ymd=stop_ymd, RefTime=mcurrTime, & + alarmname='stop_alarm', rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + + call ESMF_AlarmSet(stop_alarm, clock=mclock, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + + endif + + ! ------------------------------------------------------------------------ + ! Advance model clock to trigger alarms then reset model clock back to + ! currtime. + ! ------------------------------------------------------------------------ + + call ESMF_ClockAdvance(mclock, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + + call ESMF_ClockSet(mclock, currTime=dcurrtime, timeStep=dtimestep, & + stopTime=mstoptime, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + + if (dbug > 5) call ESMF_LogWrite(subname//': done', ESMF_LOGMSG_INFO) + + end subroutine ModelSetRunClock + + subroutine ModelFinalize(gcomp, rc) + ! --------------------------------------------------------------------------- + ! Called by NUOPC to finalize the model. + ! --------------------------------------------------------------------------- + + ! Input/output arguments. + type(ESMF_GridComp) :: gcomp + integer, intent(out) :: rc + + ! Local parameters. + character(len=*), parameter :: & + subname = modname//':(ModelFinalize)' + + if (dbug > 5) call ESMF_LogWrite(subname//': called', ESMF_LOGMSG_INFO) + + rc = ESMF_SUCCESS + + if (dbug > 5) call ESMF_LogWrite(subname//': done', ESMF_LOGMSG_INFO) + + end subroutine ModelFinalize + + ! --------------------------------------------------------------------------- + ! Public procedures. + ! --------------------------------------------------------------------------- + + subroutine SetServices(gcomp, rc) + ! --------------------------------------------------------------------------- + ! NUOPC SetService method is the only public entry point. SetServices + ! registers all of the user-provided subroutines in the module with the NUOPC + ! layer. + ! --------------------------------------------------------------------------- + + ! Input/output arguments. + type(ESMF_GridComp) :: gcomp ! ESMF_GridComp object. + integer, intent(out) :: rc ! Return code. + + ! Local parameters. + character(len=*), parameter :: & + subname = modname//':(SetServices)' + + if (dbug > 5) call ESMF_LogWrite(subname//': called', ESMF_LOGMSG_INFO) + + ! The NUOPC gcomp component will register the generic methods. + call NUOPC_CompDerive(gcomp, model_routine_SS, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + + ! Switching to IPD versions. + call ESMF_GridCompSetEntryPoint(gcomp, ESMF_METHOD_INITIALIZE, & + userRoutine=InitializeP0, phase=0, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + + ! Set entry point for methods that require specific implementation. + call NUOPC_CompSetEntryPoint(gcomp, ESMF_METHOD_INITIALIZE, & + phaseLabelList=(/"IPDv01p1"/), & + userRoutine=InitializeAdvertise, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + + call NUOPC_CompSetEntryPoint(gcomp, ESMF_METHOD_INITIALIZE, & + phaseLabelList=(/"IPDv01p3"/), & + userRoutine=InitializeRealize, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + + ! Attach specializing method(s). + call NUOPC_CompSpecialize(gcomp, specLabel=model_label_DataInitialize, & + specRoutine=DataInitialize, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + + call NUOPC_CompSpecialize(gcomp, specLabel=model_label_Advance, & + specRoutine=ModelAdvance, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + + call ESMF_MethodRemove(gcomp, label=model_label_SetRunClock, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + call NUOPC_CompSpecialize(gcomp, specLabel=model_label_SetRunClock, & + specRoutine=ModelSetRunClock, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + +! TODO Method used by POP, not by MOM6 and CICE. +! call ESMF_MethodRemove(gcomp, label=model_label_CheckImport, rc=rc) +! if (ChkErr(rc, __LINE__, u_FILE_u)) return +! call NUOPC_CompSpecialize(gcomp, specLabel=model_label_CheckImport, & +! specRoutine=ModelCheckImport, rc=rc) +! if (ChkErr(rc, __LINE__, u_FILE_u)) return + + call NUOPC_CompSpecialize(gcomp, specLabel=model_label_Finalize, & + specRoutine=ModelFinalize, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + + if (dbug > 5) call ESMF_LogWrite(subname//': done', ESMF_LOGMSG_INFO) + + end subroutine SetServices + +end module ocn_comp_nuopc diff --git a/drivers/nuopc/setlogunit.F90 b/drivers/nuopc/setlogunit.F90 new file mode 100644 index 00000000..fa73bd12 --- /dev/null +++ b/drivers/nuopc/setlogunit.F90 @@ -0,0 +1,25 @@ +! ------------------------------------------------------------------------------ +! Copyright (C) 2022 Mats Bentsen +! +! 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 . +! ------------------------------------------------------------------------------ + +subroutine setlogunit +! ------------------------------------------------------------------------------ +! Empty routine since log unit is set in routine InitializeAdvertise of the +! module ocn_comp_nuopc. +! ------------------------------------------------------------------------------ +end subroutine setlogunit From 014eec6bfc9d474982436825e6821ccb2c523819 Mon Sep 17 00:00:00 2001 From: Mats Bentsen Date: Thu, 15 Sep 2022 19:08:13 +0200 Subject: [PATCH 220/366] Added wave forcing fields. --- cesm/mod_cesm.F90 | 76 ++++++++++++++++-------- drivers/nuopc/mod_nuopc_methods.F90 | 90 ++++++++++++++++++++++++----- phy/mod_difest.F | 11 ++++ phy/mod_forcing.F90 | 11 +++- 4 files changed, 149 insertions(+), 39 deletions(-) diff --git a/cesm/mod_cesm.F90 b/cesm/mod_cesm.F90 index c02e0cdb..cc371c18 100644 --- a/cesm/mod_cesm.F90 +++ b/cesm/mod_cesm.F90 @@ -28,8 +28,8 @@ module mod_cesm use mod_time, only: nstep use mod_xc use mod_forcing, only: trxday, srxday, swa, nsf, lip, sop, eva, rnf, rfi, & - fmltfz, sfl, ztx, mty, ustarw, slp, abswnd, atmco2,& - atmbrf + fmltfz, sfl, ztx, mty, ustarw, slp, abswnd, & + lamult, lasl, ustokes, vstokes, atmco2, atmbrf use mod_ben02, only: initai, rdcsic, rdctsf, fnlzai use mod_seaice, only: ficem use mod_checksum, only: csdiag, chksummsk @@ -70,9 +70,13 @@ module mod_cesm ustarw_da, & ! Friction velocity for open water [m s-1]. slp_da, & ! Sea-level pressure [kg m-1 s-2]. abswnd_da, & ! Wind speed at measurement height (zu) [m s-1]. + ficem_da, & ! Ice concentration []. + lamult_da, & ! Langmuir enhancement factor []. + lasl_da, & ! Surface layer averaged Langmuir number []. + ustokes_da, & ! u-component of surface Stokes drift [m s-1]. + vstokes_da, & ! v-component of surface Stokes drift [m s-1]. atmco2_da, & ! Atmospheric CO2 concentration [ppm]. - atmbrf_da, & ! Atmospheric bromoform concentration [ppt]. - ficem_da ! Ice concentration []. + atmbrf_da ! Atmospheric bromoform concentration [ppt]. logical :: & smtfrc ! If true, time smooth CESM forcing fields. @@ -83,7 +87,8 @@ module mod_cesm public :: runid_cesm, runtyp_cesm, ocn_cpl_dt_cesm, nstep_in_cpl, hmlt, & 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, ustarw_da, & - slp_da, abswnd_da, atmco2_da, atmbrf_da, ficem_da, smtfrc, l1ci, l2ci, & + slp_da, abswnd_da, ficem_da, lamult_da, lasl_da, & + ustokes_da, vstokes_da, atmco2_da, atmbrf_da, smtfrc, l1ci, l2ci, & inicon_cesm, inifrc_cesm, getfrc_cesm contains @@ -146,6 +151,7 @@ subroutine getfrc_cesm #undef DIAG #ifdef DIAG use mod_nctools + use mod_dia, only : iotype #endif integer :: i, j, l @@ -163,22 +169,26 @@ subroutine getfrc_cesm do j = 1, jj do l = 1, isp(j) do i = max(1, ifp(j, l)), min(ii, ilp(j, l)) - ustarw(i, j) = w1*ustarw_da(i, j, l1ci) + w2*ustarw_da(i, j, l2ci) - lip(i, j) = w1*lip_da(i, j, l1ci) + w2*lip_da(i, j, l2ci) - sop(i, j) = w1*sop_da(i, j, l1ci) + w2*sop_da(i, j, l2ci) - eva(i, j) = w1*eva_da(i, j, l1ci) + w2*eva_da(i, j, l2ci) - rnf(i, j) = w1*rnf_da(i, j, l1ci) + w2*rnf_da(i, j, l2ci) - rfi(i, j) = w1*rfi_da(i, j, l1ci) + w2*rfi_da(i, j, l2ci) - fmltfz(i, j) = w1*fmltfz_da(i, j, l1ci) + w2*fmltfz_da(i, j, l2ci) - sfl(i, j) = w1*sfl_da(i, j, l1ci) + w2*sfl_da(i, j, l2ci) - swa(i, j) = w1*swa_da(i, j, l1ci) + w2*swa_da(i, j, l2ci) - nsf(i, j) = w1*nsf_da(i, j, l1ci) + w2*nsf_da(i, j, l2ci) - hmlt(i, j) = w1*hmlt_da(i, j, l1ci) + w2*hmlt_da(i, j, l2ci) - slp(i, j) = w1*slp_da(i, j, l1ci) + w2*slp_da(i, j, l2ci) - ficem(i, j) = w1*ficem_da(i, j, l1ci) + w2*ficem_da(i, j, l2ci) - abswnd(i, j) = w1*abswnd_da(i, j, l1ci) + w2*abswnd_da(i, j, l2ci) - atmco2(i, j) = w1*atmco2_da(i, j, l1ci) + w2*atmco2_da(i, j, l2ci) - atmbrf(i, j) = w1*atmbrf_da(i, j, l1ci) + w2*atmbrf_da(i, j, l2ci) + ustarw(i, j) = w1*ustarw_da(i, j, l1ci) + w2*ustarw_da(i, j, l2ci) + lip(i, j) = w1*lip_da(i, j, l1ci) + w2*lip_da(i, j, l2ci) + sop(i, j) = w1*sop_da(i, j, l1ci) + w2*sop_da(i, j, l2ci) + eva(i, j) = w1*eva_da(i, j, l1ci) + w2*eva_da(i, j, l2ci) + rnf(i, j) = w1*rnf_da(i, j, l1ci) + w2*rnf_da(i, j, l2ci) + rfi(i, j) = w1*rfi_da(i, j, l1ci) + w2*rfi_da(i, j, l2ci) + fmltfz(i, j) = w1*fmltfz_da(i, j, l1ci) + w2*fmltfz_da(i, j, l2ci) + sfl(i, j) = w1*sfl_da(i, j, l1ci) + w2*sfl_da(i, j, l2ci) + swa(i, j) = w1*swa_da(i, j, l1ci) + w2*swa_da(i, j, l2ci) + nsf(i, j) = w1*nsf_da(i, j, l1ci) + w2*nsf_da(i, j, l2ci) + hmlt(i, j) = w1*hmlt_da(i, j, l1ci) + w2*hmlt_da(i, j, l2ci) + slp(i, j) = w1*slp_da(i, j, l1ci) + w2*slp_da(i, j, l2ci) + abswnd(i, j) = w1*abswnd_da(i, j, l1ci) + w2*abswnd_da(i, j, l2ci) + ficem(i, j) = w1*ficem_da(i, j, l1ci) + w2*ficem_da(i, j, l2ci) + lamult(i, j) = w1*lamult_da(i, j, l1ci) + w2*lamult_da(i, j, l2ci) + lasl(i, j) = w1*lasl_da(i, j, l1ci) + w2*lasl_da(i, j, l2ci) + ustokes(i, j) = w1*ustokes_da(i, j, l1ci) + w2*ustokes_da(i, j, l2ci) + vstokes(i, j) = w1*vstokes_da(i, j, l1ci) + w2*vstokes_da(i, j, l2ci) + atmco2(i, j) = w1*atmco2_da(i, j, l1ci) + w2*atmco2_da(i, j, l2ci) + atmbrf(i, j) = w1*atmbrf_da(i, j, l1ci) + w2*atmbrf_da(i, j, l2ci) enddo enddo do l = 1, isu(j) @@ -210,8 +220,12 @@ subroutine getfrc_cesm call ncdefvar('nsf_da', 'x y', ndouble, 8) call ncdefvar('hmlt_da', 'x y', ndouble, 8) call ncdefvar('slp_da', 'x y', ndouble, 8) - call ncdefvar('ficem_da', 'x y', ndouble, 8) call ncdefvar('abswnd_da', 'x y', ndouble, 8) + call ncdefvar('ficem_da', 'x y', ndouble, 8) + call ncdefvar('lamult_da', 'x y', ndouble, 8) + call ncdefvar('lasl_da', 'x y', ndouble, 8) + call ncdefvar('ustokes_da', 'x y', ndouble, 8) + call ncdefvar('vstokes_da', 'x y', ndouble, 8) call ncdefvar('atmco2_da', 'x y', ndouble, 8) call ncdefvar('atmbrf_da', 'x y', ndouble, 8) call ncdefvar('ztx_da', 'x y', ndouble, 8) @@ -242,14 +256,22 @@ subroutine getfrc_cesm ip, 1, 1._r8, 0._r8, 8) call ncwrtr('slp_da', 'x y', slp_da(1 - nbdy, 1 - nbdy, l2ci), & ip, 1, 1._r8, 0._r8, 8) + call ncwrtr('abswnd_da', 'x y', abswnd_da(1 - nbdy, 1 - nbdy, l2ci), & + ip, 1, 1._r8, 0._r8, 8) call ncwrtr('ficem_da', 'x y', ficem_da(1 - nbdy, 1 - nbdy, l2ci), & ip, 1, 1._r8, 0._r8, 8) - call ncwrtr('abswnd_da', 'x y', abswnd_da(1 - nbdy, 1 - nbdy, l2ci), & + call ncwrtr('lamult_da', 'x y', lamult_da(1 - nbdy, 1 - nbdy, l2ci), & + ip, 1, 1._r8, 0._r8, 8) + call ncwrtr('lasl_da', 'x y', lasl_da(1 - nbdy, 1 - nbdy, l2ci), & + ip, 1, 1._r8, 0._r8, 8) + call ncwrtr('ustokes_da', 'x y', ustokes_da(1 - nbdy, 1 - nbdy, l2ci), & + ip, 1, 1._r8, 0._r8, 8) + call ncwrtr('vstokes_da', 'x y', vstokes_da(1 - nbdy, 1 - nbdy, l2ci), & ip, 1, 1._r8, 0._r8, 8) call ncwrtr('atmco2_da', 'x y', atmco2_da(1 - nbdy, 1 - nbdy, l2ci), & ip, 1, 1._r8, 0._r8, 8) call ncwrtr('atmbrf_da', 'x y', atmbrf_da(1 - nbdy, 1 - nbdy, l2ci), & - . ip, 1, 1._r8, 0._r8, 8) + ip, 1, 1._r8, 0._r8, 8) call ncwrtr('ztx_da', 'x y', ztx_da(1 - nbdy, 1 - nbdy, l2ci), & iu, 1, 1._r8, 0._r8, 8) call ncwrtr('mty_da', 'x y', mty_da(1 - nbdy, 1 - nbdy, l2ci), & @@ -277,8 +299,12 @@ subroutine getfrc_cesm call chksummsk(nsf, ip, 1, 'nsf') call chksummsk(hmlt, ip, 1, 'hmlt') call chksummsk(slp, ip, 1, 'slp') - call chksummsk(ficem, ip, 1, 'ficem') call chksummsk(abswnd, ip, 1, 'abswnd') + call chksummsk(ficem, ip, 1, 'ficem') + call chksummsk(lamult, ip, 1, 'lamult') + call chksummsk(lasl, ip, 1, 'lasl') + call chksummsk(ustokes, ip, 1, 'ustokes') + call chksummsk(vstokes, ip, 1, 'vstokes') call chksummsk(atmco2, ip, 1, 'atmco2') call chksummsk(atmbrf, ip, 1, 'atmbrf') endif diff --git a/drivers/nuopc/mod_nuopc_methods.F90 b/drivers/nuopc/mod_nuopc_methods.F90 index 0d24e367..6cdd659a 100644 --- a/drivers/nuopc/mod_nuopc_methods.F90 +++ b/drivers/nuopc/mod_nuopc_methods.F90 @@ -36,8 +36,9 @@ module mod_nuopc_methods 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, & - ustarw_da, slp_da, abswnd_da, atmco2_da, atmbrf_da, & - ficem_da, l1ci, l2ci + ustarw_da, slp_da, abswnd_da, ficem_da, lamult_da, & + lasl_da, ustokes_da, vstokes_da, atmco2_da, atmbrf_da, & + l1ci, l2ci use mod_utility, only: util1, util2 use mod_checksum, only: csdiag, chksummsk use shr_const_mod, only: SHR_CONST_RHOSW, SHR_CONST_LATICE, SHR_CONST_TKFRZ @@ -492,10 +493,10 @@ subroutine blom_importflds(fldlist_num, fldlist) index_Sw_ustokes = - 1, & index_Sw_vstokes = - 1, & index_Sw_hstokes = - 1, & - index_Sa_pslv = - 1, & index_Faxa_lwdn = - 1, & index_Faxa_snow = - 1, & index_Faxa_rain = - 1, & + index_Sa_pslv = - 1, & index_Sa_co2diag = - 1, & index_Sa_co2prog = - 1, & index_Sa_brfprog = - 1 @@ -512,7 +513,7 @@ subroutine blom_importflds(fldlist_num, fldlist) call getfldindex(fldlist_num, fldlist, 'Foxx_taux', index_Foxx_taux) call getfldindex(fldlist_num, fldlist, 'Foxx_tauy', index_Foxx_tauy) - !$omp parallel do private(i, n) + !$omp parallel do private(i, n, afac, utmp, vtmp) do j = 1, jjcpl do i = 1, ii if (ip(i,j) == 0) then @@ -526,6 +527,7 @@ subroutine blom_importflds(fldlist_num, fldlist) else n = (j - 1)*ii + i afac = med2mod_areacor(n) + utmp = fldlist(index_Foxx_taux)%dataptr(n)*afac vtmp = fldlist(index_Foxx_tauy)%dataptr(n)*afac util1(i,j) = utmp*cosang(i,j) + vtmp*sinang(i,j) @@ -577,10 +579,10 @@ subroutine blom_importflds(fldlist_num, fldlist) call getfldindex(fldlist_num, fldlist, 'Faxa_lwdn', index_Faxa_lwdn) call getfldindex(fldlist_num, fldlist, 'Fioi_melth', index_Fioi_melth) call getfldindex(fldlist_num, fldlist, 'Sa_pslv', index_Sa_pslv) - call getfldindex(fldlist_num, fldlist, 'Si_ifrac', index_Si_ifrac) call getfldindex(fldlist_num, fldlist, 'So_duu10n', index_So_duu10n) + call getfldindex(fldlist_num, fldlist, 'Si_ifrac', index_Si_ifrac) - !$omp parallel do private(i, n) + !$omp parallel do private(i, n, afac) do j = 1, jjcpl do i = 1, ii @@ -596,8 +598,8 @@ subroutine blom_importflds(fldlist_num, fldlist) nsf_da(i,j,l2ci) = mval hmlt_da(i,j,l2ci) = mval slp_da(i,j,l2ci) = mval - ficem_da(i,j,l2ci) = mval abswnd_da(i,j,l2ci) = mval + ficem_da(i,j,l2ci) = mval elseif (cplmsk(i,j) == 0) then lip_da(i,j,l2ci) = 0._r8 sop_da(i,j,l2ci) = 0._r8 @@ -610,8 +612,8 @@ subroutine blom_importflds(fldlist_num, fldlist) nsf_da(i,j,l2ci) = 0._r8 hmlt_da(i,j,l2ci) = 0._r8 slp_da(i,j,l2ci) = fval - ficem_da(i,j,l2ci) = fval abswnd_da(i,j,l2ci) = fval + ficem_da(i,j,l2ci) = fval else n = (j - 1)*ii + i afac = med2mod_areacor(n) @@ -656,12 +658,12 @@ subroutine blom_importflds(fldlist_num, fldlist) ! Sea level pressure [kg m-1 s-2]. slp_da(i,j,l2ci) = fldlist(index_Sa_pslv)%dataptr(n) - ! Ice fraction []. - ficem_da(i,j,l2ci) = fldlist(index_Si_ifrac)%dataptr(n) - ! 10m wind speed [m s-1]. abswnd_da(i,j,l2ci) = sqrt(fldlist(index_So_duu10n)%dataptr(n)) + ! Ice fraction []. + ficem_da(i,j,l2ci) = fldlist(index_Si_ifrac)%dataptr(n) + endif enddo @@ -682,8 +684,70 @@ subroutine blom_importflds(fldlist_num, fldlist) endif call fill_global(mval, fval, halo_ps, slp_da(1-nbdy,1-nbdy,l2ci)) - call fill_global(mval, fval, halo_ps, ficem_da(1-nbdy,1-nbdy,l2ci)) call fill_global(mval, fval, halo_ps, abswnd_da(1-nbdy,1-nbdy,l2ci)) + call fill_global(mval, fval, halo_ps, ficem_da(1-nbdy,1-nbdy,l2ci)) + + call getfldindex(fldlist_num, fldlist, 'Sw_lamult', index_Sw_lamult) + call getfldindex(fldlist_num, fldlist, 'Sw_ustokes', index_Sw_ustokes) + call getfldindex(fldlist_num, fldlist, 'Sw_vstokes', index_Sw_vstokes) + call getfldindex(fldlist_num, fldlist, 'Sw_hstokes', index_Sw_hstokes) + + !$omp parallel do private(i, n, utmp, vtmp) + do j = 1, jjcpl + do i = 1, ii + if (ip(i,j) == 0) then + util1(i,j) = mval + util2(i,j) = mval + lamult_da(i,j,l2ci) = mval + lasl_da(i,j,l2ci) = mval + elseif (cplmsk(i,j) == 0) then + util1(i,j) = fval + util2(i,j) = fval + lamult_da(i,j,l2ci) = fval + lasl_da(i,j,l2ci) = fval + else + n = (j - 1)*ii + i + + utmp = fldlist(index_Sw_ustokes)%dataptr(n) + vtmp = fldlist(index_Sw_vstokes)%dataptr(n) + util1(i,j) = utmp*cosang(i,j) + vtmp*sinang(i,j) + util2(i,j) = - utmp*sinang(i,j) + vtmp*cosang(i,j) + + ! Langmuir enhancement factor []. + lamult_da(i,j,l2ci) = fldlist(index_Sw_lamult)%dataptr(n) + + ! Surface layer averaged Langmuir number []. + lasl_da(i,j,l2ci) = fldlist(index_Sw_hstokes)%dataptr(n) + + endif + enddo + enddo + !$omp end parallel do + + call fill_global(mval, fval, halo_pv, util1) + call fill_global(mval, fval, halo_pv, util2) + call fill_global(mval, fval, halo_ps, lamult_da(1-nbdy,1-nbdy,l2ci)) + call fill_global(mval, fval, halo_ps, lasl_da(1-nbdy,1-nbdy,l2ci)) + + call xctilr(util1, 1,1, 1,1, halo_pv) + call xctilr(util2, 1,1, 1,1, halo_pv) + + !$omp parallel do private(l, i) + do j = 1, jj + do l = 1, isu(j) + do i = max(1,ifu(j,l)), min(ii,ilu(j,l)) + ! x-component of surface Stokes drift [m s-1]. + ustokes_da(i,j,l2ci) = .5_r8*(util1(i-1,j) + util1(i,j)) + enddo + enddo + do l = 1,isv(j) + do i = max(1,ifv(j,l)), min(ii,ilv(j,l)) + ! y-component of surface Stokes drift [m s-1]. + vstokes_da(i,j,l2ci) = .5_r8*(util2(i,j-1) + util2(i,j)) + enddo + enddo + enddo + !$omp end parallel do #ifdef PROGCO2 call getfldindex(fldlist_num, fldlist, 'Sa_co2prog', index_Sa_co2prog) @@ -831,8 +895,8 @@ subroutine blom_importflds(fldlist_num, fldlist) call chksummsk(nsf_da(1-nbdy,1-nbdy,l2ci),ip,1,'nsf') call chksummsk(hmlt_da(1-nbdy,1-nbdy,l2ci),ip,1,'hmlt') call chksummsk(slp_da(1-nbdy,1-nbdy,l2ci),ip,1,'slp') - call chksummsk(ficem_da(1-nbdy,1-nbdy,l2ci),ip,1,'ficem') call chksummsk(abswnd_da(1-nbdy,1-nbdy,l2ci),ip,1,'abswnd') + call chksummsk(ficem_da(1-nbdy,1-nbdy,l2ci),ip,1,'ficem') call chksummsk(atmco2_da(1-nbdy,1-nbdy,l2ci),ip,1,'atmco2') call chksummsk(atmbrf_da(1-nbdy,1-nbdy,l2ci),ip,1,'atmbrf') endif diff --git a/phy/mod_difest.F b/phy/mod_difest.F index 5bd4b2b9..3831bf38 100644 --- a/phy/mod_difest.F +++ b/phy/mod_difest.F @@ -221,6 +221,8 @@ subroutine init_difest c --- ------------------------------------------------------------------ c --- Initialize CVmix variables. c --- ------------------------------------------------------------------ +c + integer :: i,j,l c c -- ------- Background diapycnal mixing. c The Bryan-Lewis parameterization is based on the following: @@ -290,6 +292,15 @@ subroutine init_difest c . lnoDGat1=.true. , c . CVMix_kpp_params_user=KPP_params ) c +c$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)) + OBLdepth(i,j)=10. + enddo + enddo + enddo +c$OMP END PARALLEL DO c end subroutine init_difest c diff --git a/phy/mod_forcing.F90 b/phy/mod_forcing.F90 index c000d28c..64b546b3 100644 --- a/phy/mod_forcing.F90 +++ b/phy/mod_forcing.F90 @@ -106,6 +106,10 @@ module mod_forcing ustarw, & ! Friction velocity for open water [m s-1]. slp, & ! Sea-level pressure [kg m-1 s-2]. abswnd, & ! Wind speed at measurement height (zu) [m s-1]. + lamult, & ! Langmuir enhancement factor []. + lasl, & ! Surface layer averaged Langmuir number []. + ustokes, & ! u-component of surface Stokes drift [m s-1]. + vstokes, & ! v-component of surface Stokes drift [m s-1]. atmco2, & ! Atmospheric CO2 concentration [ppm]. flxco2, & ! Air-sea CO2 flux [kg m-2 s-1]. flxdms, & ! Sea-air DMS flux [kg m-2 s-1]. @@ -138,7 +142,8 @@ module mod_forcing sref, tflxap, sflxap, tflxdi, sflxdi, nflxdi, & sstclm, ricclm, sssclm, prfac, eiacc, pracc, & swa, nsf, hmltfz, lip, sop, eva, rnf, rfi, fmltfz, sfl, ztx, mty, & - ustarw, slp, abswnd, atmco2, flxco2, flxdms, flxbrf, atmbrf, & + ustarw, slp, abswnd, lamult, lasl, ustokes, vstokes, & + atmco2, flxco2, flxdms, flxbrf, atmbrf, & surflx, surrlx, sswflx, salflx, brnflx, salrlx, taux, tauy, & ustar, ustarb, ustar3, buoyfl, t_sw_nonloc, & inivar_forcing, fwbbal @@ -172,6 +177,10 @@ subroutine inivar_forcing ustarw(i, j) = spval slp(i, j) = spval abswnd(i, j) = spval + lamult(i, j) = spval + lasl(i, j) = spval + ustokes(i, j) = spval + vstokes(i, j) = spval atmco2(i, j) = spval flxco2(i, j) = spval flxdms(i, j) = spval From 3e639aa69bbc3bead4c5c8ea6cfc92d861ba5d3f Mon Sep 17 00:00:00 2001 From: Mats Bentsen Date: Thu, 15 Sep 2022 19:32:06 +0200 Subject: [PATCH 221/366] Renamed folder for MCT driver. --- cime_config/buildlib_2.1 | 2 +- cime_config/buildlib_2.2 | 2 +- drivers/{cpl_mct => mct}/domain_mct.F | 0 drivers/{cpl_mct => mct}/export_mct.F | 0 drivers/{cpl_mct => mct}/external_abort.F | 0 drivers/{cpl_mct => mct}/getprecipfact_mct.F | 0 drivers/{cpl_mct => mct}/import_mct.F | 0 drivers/{cpl_mct => mct}/mod_swtfrz.F | 0 drivers/{cpl_mct => mct}/ocn_comp_mct.F90 | 0 drivers/{cpl_mct => mct}/setlogunit.F | 0 drivers/{cpl_mct => mct}/sumsbuff_mct.F | 0 11 files changed, 2 insertions(+), 2 deletions(-) rename drivers/{cpl_mct => mct}/domain_mct.F (100%) rename drivers/{cpl_mct => mct}/export_mct.F (100%) rename drivers/{cpl_mct => mct}/external_abort.F (100%) rename drivers/{cpl_mct => mct}/getprecipfact_mct.F (100%) rename drivers/{cpl_mct => mct}/import_mct.F (100%) rename drivers/{cpl_mct => mct}/mod_swtfrz.F (100%) rename drivers/{cpl_mct => mct}/ocn_comp_mct.F90 (100%) rename drivers/{cpl_mct => mct}/setlogunit.F (100%) rename drivers/{cpl_mct => mct}/sumsbuff_mct.F (100%) diff --git a/cime_config/buildlib_2.1 b/cime_config/buildlib_2.1 index 99f5315d..758cb28b 100755 --- a/cime_config/buildlib_2.1 +++ b/cime_config/buildlib_2.1 @@ -82,7 +82,7 @@ def _main_func(): expect(driver != "nuopc", "NUOPC driver not supported") if driver == "mct": paths.append(os.path.join(comp_root_dir_ocn, "drivers", "cpl_share")) - paths.append(os.path.join(comp_root_dir_ocn, "drivers", "cpl_mct")) + paths.append(os.path.join(comp_root_dir_ocn, "drivers", "mct")) with open(filepath_file, "w") as filepath: filepath.write("\n".join(paths)) diff --git a/cime_config/buildlib_2.2 b/cime_config/buildlib_2.2 index 3b800c15..2facb5a3 100755 --- a/cime_config/buildlib_2.2 +++ b/cime_config/buildlib_2.2 @@ -82,7 +82,7 @@ def _main_func(): if driver == "mct": paths.append(os.path.join(comp_root_dir_ocn, "drivers", "cpl_share")) - paths.append(os.path.join(comp_root_dir_ocn, "drivers", "cpl_mct")) + paths.append(os.path.join(comp_root_dir_ocn, "drivers", "mct")) elif driver == "nuopc": paths.append(os.path.join(comp_root_dir_ocn, "drivers", "nuopc")) else: diff --git a/drivers/cpl_mct/domain_mct.F b/drivers/mct/domain_mct.F similarity index 100% rename from drivers/cpl_mct/domain_mct.F rename to drivers/mct/domain_mct.F diff --git a/drivers/cpl_mct/export_mct.F b/drivers/mct/export_mct.F similarity index 100% rename from drivers/cpl_mct/export_mct.F rename to drivers/mct/export_mct.F diff --git a/drivers/cpl_mct/external_abort.F b/drivers/mct/external_abort.F similarity index 100% rename from drivers/cpl_mct/external_abort.F rename to drivers/mct/external_abort.F diff --git a/drivers/cpl_mct/getprecipfact_mct.F b/drivers/mct/getprecipfact_mct.F similarity index 100% rename from drivers/cpl_mct/getprecipfact_mct.F rename to drivers/mct/getprecipfact_mct.F diff --git a/drivers/cpl_mct/import_mct.F b/drivers/mct/import_mct.F similarity index 100% rename from drivers/cpl_mct/import_mct.F rename to drivers/mct/import_mct.F diff --git a/drivers/cpl_mct/mod_swtfrz.F b/drivers/mct/mod_swtfrz.F similarity index 100% rename from drivers/cpl_mct/mod_swtfrz.F rename to drivers/mct/mod_swtfrz.F diff --git a/drivers/cpl_mct/ocn_comp_mct.F90 b/drivers/mct/ocn_comp_mct.F90 similarity index 100% rename from drivers/cpl_mct/ocn_comp_mct.F90 rename to drivers/mct/ocn_comp_mct.F90 diff --git a/drivers/cpl_mct/setlogunit.F b/drivers/mct/setlogunit.F similarity index 100% rename from drivers/cpl_mct/setlogunit.F rename to drivers/mct/setlogunit.F diff --git a/drivers/cpl_mct/sumsbuff_mct.F b/drivers/mct/sumsbuff_mct.F similarity index 100% rename from drivers/cpl_mct/sumsbuff_mct.F rename to drivers/mct/sumsbuff_mct.F From ed18d3aa9fca2df813a04a153e02395e624c1a81 Mon Sep 17 00:00:00 2001 From: Mats Bentsen Date: Thu, 15 Sep 2022 19:44:32 +0200 Subject: [PATCH 222/366] Moved MCT specific file from drivers/cpl_share/ to drivers/mct/. --- cime_config/buildlib_2.1 | 1 - cime_config/buildlib_2.2 | 1 - drivers/{cpl_share => mct}/blom_cpl_indices.F90 | 0 3 files changed, 2 deletions(-) rename drivers/{cpl_share => mct}/blom_cpl_indices.F90 (100%) diff --git a/cime_config/buildlib_2.1 b/cime_config/buildlib_2.1 index 758cb28b..a46abbdd 100755 --- a/cime_config/buildlib_2.1 +++ b/cime_config/buildlib_2.1 @@ -81,7 +81,6 @@ def _main_func(): expect(driver != "nuopc", "NUOPC driver not supported") if driver == "mct": - paths.append(os.path.join(comp_root_dir_ocn, "drivers", "cpl_share")) paths.append(os.path.join(comp_root_dir_ocn, "drivers", "mct")) with open(filepath_file, "w") as filepath: diff --git a/cime_config/buildlib_2.2 b/cime_config/buildlib_2.2 index 2facb5a3..d069e2eb 100755 --- a/cime_config/buildlib_2.2 +++ b/cime_config/buildlib_2.2 @@ -81,7 +81,6 @@ def _main_func(): expect(False, "tracer module {} is not recognized".format(module)) if driver == "mct": - paths.append(os.path.join(comp_root_dir_ocn, "drivers", "cpl_share")) paths.append(os.path.join(comp_root_dir_ocn, "drivers", "mct")) elif driver == "nuopc": paths.append(os.path.join(comp_root_dir_ocn, "drivers", "nuopc")) diff --git a/drivers/cpl_share/blom_cpl_indices.F90 b/drivers/mct/blom_cpl_indices.F90 similarity index 100% rename from drivers/cpl_share/blom_cpl_indices.F90 rename to drivers/mct/blom_cpl_indices.F90 From d83fbaed4c3a6525f3d4bf045d6da0b6552b6521 Mon Sep 17 00:00:00 2001 From: Mats Bentsen Date: Thu, 15 Sep 2022 20:40:59 +0200 Subject: [PATCH 223/366] Rename drivers/mct/mod_swtfrz.F to drivers/mct/mod_swtfrz.F90. --- drivers/mct/{mod_swtfrz.F => mod_swtfrz.F90} | 0 1 file changed, 0 insertions(+), 0 deletions(-) rename drivers/mct/{mod_swtfrz.F => mod_swtfrz.F90} (100%) diff --git a/drivers/mct/mod_swtfrz.F b/drivers/mct/mod_swtfrz.F90 similarity index 100% rename from drivers/mct/mod_swtfrz.F rename to drivers/mct/mod_swtfrz.F90 From d0cdcd8600c3079a5636022d610ffffcffdb3c54 Mon Sep 17 00:00:00 2001 From: Mats Bentsen Date: Thu, 15 Sep 2022 20:42:13 +0200 Subject: [PATCH 224/366] Rewrite to drivers/mct/mod_swtfrz.F90 to free format Fortran. --- drivers/mct/mod_swtfrz.F90 | 121 +++++++++++++++++-------------------- 1 file changed, 54 insertions(+), 67 deletions(-) diff --git a/drivers/mct/mod_swtfrz.F90 b/drivers/mct/mod_swtfrz.F90 index fd623993..d5209eeb 100644 --- a/drivers/mct/mod_swtfrz.F90 +++ b/drivers/mct/mod_swtfrz.F90 @@ -1,5 +1,5 @@ ! ------------------------------------------------------------------------------ -! Copyright (C) 2018-2020 Mats Bentsen +! Copyright (C) 2018-2022 Mats Bentsen ! ! This file is part of BLOM. ! @@ -17,78 +17,65 @@ ! along with BLOM. If not, see . ! ------------------------------------------------------------------------------ - module mod_swtfrz -c -c --- ------------------------------------------------------------------ -c --- This module contains routines for computing the freezing point of -c --- sea water. -c --- ------------------------------------------------------------------ -c - use mod_types, only: r8 - use shr_frz_mod, only: shr_frz_freezetemp -c - implicit none -c - private -c - public :: swtfrz -c - interface swtfrz - module procedure swtfrz_0d - module procedure swtfrz_1d - module procedure swtfrz_2d - end interface swtfrz -c - contains -c -c --- ------------------------------------------------------------------ -c - function swtfrz_0d(p,s) result(swtfrz) -c -c --- ------------------------------------------------------------------ -c --- Retrieve freezing temperature from shared CESM function. -c --- ------------------------------------------------------------------ -c +module mod_swtfrz +! ------------------------------------------------------------------------------ +! This module contains routines for computing the freezing point of sea water. +! ------------------------------------------------------------------------------ + + use mod_types, only: r8 + use shr_frz_mod, only: shr_frz_freezetemp + + implicit none + + private + + public :: swtfrz + + interface swtfrz + module procedure swtfrz_0d + module procedure swtfrz_1d + module procedure swtfrz_2d + end interface swtfrz + +contains + + function swtfrz_0d(p,s) result(swtfrz) + ! --------------------------------------------------------------------------- + ! Retrieve freezing temperature from shared CESM function. + ! --------------------------------------------------------------------------- + real(r8), intent(in) :: p ! Pressure [g cm-1 s-2] real(r8), intent(in) :: s ! Salinity [g kg-1] real(r8) :: swtfrz -c - swtfrz=shr_frz_freezetemp(s) -c - end function swtfrz_0d -c -c --- ------------------------------------------------------------------ -c - function swtfrz_1d(p,s) result(swtfrz) -c -c --- ------------------------------------------------------------------ -c --- Retrieve freezing temperature from shared CESM function. -c --- ------------------------------------------------------------------ -c + + swtfrz = shr_frz_freezetemp(s) + + end function swtfrz_0d + + function swtfrz_1d(p,s) result(swtfrz) + ! --------------------------------------------------------------------------- + ! Retrieve freezing temperature from shared CESM function. + ! --------------------------------------------------------------------------- + real(r8), intent(in) :: p(:) ! Pressure [g cm-1 s-2] real(r8), intent(in) :: s(:) ! Salinity [g kg-1] real(r8) :: swtfrz(size(s)) -c - swtfrz(:)=shr_frz_freezetemp(s(:)) -c - end function swtfrz_1d -c -c --- ------------------------------------------------------------------ -c - function swtfrz_2d(p,s) result(swtfrz) -c -c --- ------------------------------------------------------------------ -c --- Retrieve freezing temperature from shared CESM function. -c --- ------------------------------------------------------------------ -c + + swtfrz(:) = shr_frz_freezetemp(s(:)) + + end function swtfrz_1d + + function swtfrz_2d(p,s) result(swtfrz) + ! --------------------------------------------------------------------------- + ! Retrieve freezing temperature from shared CESM function. + ! --------------------------------------------------------------------------- + real(r8), intent(in) :: p(:,:) ! Pressure [g cm-1 s-2] real(r8), intent(in) :: s(:,:) ! Salinity [g kg-1] real(r8) :: swtfrz(size(s,1),size(s,2)) -c - swtfrz(:,:)=shr_frz_freezetemp(s(:,:)) -c - end function swtfrz_2d -c -c --- ------------------------------------------------------------------ -c - end module mod_swtfrz + + swtfrz(:,:) = shr_frz_freezetemp(s(:,:)) + + end function swtfrz_2d + +end module mod_swtfrz From 42926faf436e27fcadc3815649a07b1fb6976aef Mon Sep 17 00:00:00 2001 From: jmaerz <92309038+jmaerz@users.noreply.github.com> Date: Wed, 9 Nov 2022 21:46:15 +0100 Subject: [PATCH 225/366] Fix porosity read (#201) * Fixing the reading of variable porosity input field in preparation for the NorESM 2.0.6 release Cherry-picked from private Ncycleprivate branch 0d56930e2fdd62caba964d375b57304942568926 * Provide number of layers (3rd dim) via ks and not hard-coded * minor clean-up --- hamocc/mo_read_sedpor.F90 | 35 +++++++++++++++++++++++++++++------ 1 file changed, 29 insertions(+), 6 deletions(-) diff --git a/hamocc/mo_read_sedpor.F90 b/hamocc/mo_read_sedpor.F90 index 6ea984c6..8f51b0ca 100644 --- a/hamocc/mo_read_sedpor.F90 +++ b/hamocc/mo_read_sedpor.F90 @@ -51,9 +51,10 @@ module mo_read_sedpor subroutine read_sedpor(kpie,kpje,ks,omask,sed_por) use mod_xc, only: mnproc,xchalt - use mod_dia, only: iotype use mo_control_bgc, only: io_stdo_bgc,l_3Dvarsedpor - use mod_nctools, only: ncfopn,ncread,ncfcls + use netcdf, only: nf90_noerr,nf90_nowrite,nf90_close,nf90_open + + implicit none @@ -62,9 +63,10 @@ subroutine read_sedpor(kpie,kpje,ks,omask,sed_por) real, intent(inout) :: sed_por(kpie,kpje,ks) !local variables - integer :: i,j,k,errstat,dummymask(2) + integer :: i,j,k real :: sed_por_in(kpie,kpje,ks) logical :: file_exists = .false. + integer :: ncid,ncstat ! Return if l_3Dvarsedpor is turned off if (.not. l_3Dvarsedpor) then @@ -90,15 +92,36 @@ subroutine read_sedpor(kpie,kpje,ks,omask,sed_por) write(io_stdo_bgc,*) 'read_sedpor: read sediment porosity from ', & trim(sedporfile) endif - call ncfopn(trim(sedporfile),'r',' ',1,iotype) - call ncread('sedpor',sed_por_in,dummymask,0,0.) - call ncfcls + + ! Open netCDF data file + IF(mnproc==1) THEN + ncstat = NF90_OPEN(trim(sedporfile),NF90_NOWRITE, ncid) + IF (ncstat.NE.NF90_NOERR ) THEN + CALL xchalt('(read_sedpor: Problem with netCDF1)') + stop '(read_sedpor: Problem with netCDF1)' + END IF + END IF + + ! Read data + call read_netcdf_var(ncid,'sedpor',sed_por_in(1,1,1),ks,0,0) + + ! Close file + IF(mnproc==1) THEN + ncstat = NF90_CLOSE(ncid) + IF ( ncstat .NE. NF90_NOERR ) THEN + CALL xchalt('(read_sedpor: Problem with netCDF200)') + stop '(read_sedpor: Problem with netCDF200)' + END IF + END IF + do k=1,ks do j=1,kpje do i=1,kpie if(omask(i,j).gt. 0.5)then sed_por(i,j,k)=sed_por_in(i,j,k) + else + sed_por(i,j,k)=0. endif enddo enddo From 78e857409500c46ef6e510b7c0a9814f67e86467 Mon Sep 17 00:00:00 2001 From: Mats Bentsen Date: Sun, 20 Nov 2022 22:56:40 +0100 Subject: [PATCH 226/366] Correct unit of diagnostic variable dp_trc. --- phy/mod_dia.F | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/phy/mod_dia.F b/phy/mod_dia.F index 715f811b..e824a5fd 100644 --- a/phy/mod_dia.F +++ b/phy/mod_dia.F @@ -2919,7 +2919,7 @@ subroutine diaout(iogrp,m,n,mm,nn,k1m,k1n) call inilyr(ACC_UTILLYR(1),'p',0.) call acclyr(ACC_UTILLYR,dp(1-nbdy,1-nbdy,k1m),tmp3d,0,'p') call wrtlyr(ACC_UTILLYR(1), - . max(LYR_IDLAGE(iogrp),LYR_TRC(iogrp)),1.,0.,cmpflg,ip,'p', + . max(LYR_IDLAGE(iogrp),LYR_TRC(iogrp)),.1,0.,cmpflg,ip,'p', . 'dp_trc','Layer pressure thickness',' ','Pa') endif # ifdef IDLAGE From 233c39f2a0640575b6693069ab3b2d1be6621a20 Mon Sep 17 00:00:00 2001 From: Mats Bentsen Date: Mon, 21 Nov 2022 01:32:09 +0100 Subject: [PATCH 227/366] Made conservation and checksum diagnostics selectable by namelist options (default off). --- cime_config/buildnml | 6 ++++++ phy/mod_budget.F90 | 8 +++++--- phy/mod_checksum.F90 | 2 +- phy/rdlim.F | 8 +++++++- tests/fuk95/limits | 21 ++++++++++++--------- 5 files changed, 31 insertions(+), 14 deletions(-) diff --git a/cime_config/buildnml b/cime_config/buildnml index bd3d33a3..95ad80dd 100755 --- a/cime_config/buildnml +++ b/cime_config/buildnml @@ -123,6 +123,8 @@ set SPRFAC = .false. set ATM_PATH = "'unset'" set ITEST = 60 set JTEST = 60 +set CNSVDI = .false. +set CSDIAG = .false. set RSTFRQ = 1 if ($PIO_NETCDF_FORMAT_OCN == 64bit_offset) then set RSTFMT = 1 @@ -897,6 +899,8 @@ cat >! $RUNDIR/ocn_in$inststr << EOF ! 'ben02syn' (a) ! ITEST : Global i-index of point diagnostics (i) ! JTEST : Global j-index of point diagnostics (i) +! CNSVDI : Conservation diagnostics flag (l) +! CSDIAG : Checksum diagnostics flag (l) ! RSTFRQ : Restart frequency in days (30=1month,365=1year) (i) ! RSTFMT : Format of restart file (valid arguments are 0 for classic, ! 1 for 64-bit offset and 2 for netcdf4/hdf5 format) (i) @@ -961,6 +965,8 @@ cat >! $RUNDIR/ocn_in$inststr << EOF ATM_PATH = $ATM_PATH ITEST = $ITEST JTEST = $JTEST + CNSVDI = $CNSVDI + CSDIAG = $CSDIAG RSTFRQ = $RSTFRQ RSTFMT = $RSTFMT RSTCMP = $RSTCMP diff --git a/phy/mod_budget.F90 b/phy/mod_budget.F90 index ed6bda87..9eeaaddb 100644 --- a/phy/mod_budget.F90 +++ b/phy/mod_budget.F90 @@ -39,12 +39,14 @@ module mod_budget private + ! Options with default values, modifiable by namelist. + logical :: & + cnsvdi = .false. ! Flag that indicates whether conservation diagnostics + ! are written. + ! Constants. integer, parameter :: & ncalls = 7 ! Number of calls after which budgets are computed. - logical :: & - cnsvdi = .true. ! Flag that indicates whether conservation diagnostics - ! are written. real(r8), dimension(ncalls, 2) :: & sdp, & ! Global mass weighted sum of salinity. diff --git a/phy/mod_checksum.F90 b/phy/mod_checksum.F90 index d78a968c..ccf0f354 100644 --- a/phy/mod_checksum.F90 +++ b/phy/mod_checksum.F90 @@ -26,7 +26,7 @@ module mod_checksum private - ! Constants. + ! Options with default values, modifiable by namelist. logical :: & csdiag = .false. ! Flag that indicates whether checksums are written. diff --git a/phy/rdlim.F b/phy/rdlim.F index e45667f0..44949352 100644 --- a/phy/rdlim.F +++ b/phy/rdlim.F @@ -57,6 +57,7 @@ subroutine rdlim use mod_cesm, only: runid_cesm, ocn_cpl_dt_cesm, nstep_in_cpl, . smtfrc use mod_pointtest, only: itest, jtest + use mod_budget, only: cnsvdi use mod_checksum, only: csdiag c implicit none @@ -71,13 +72,14 @@ subroutine rdlim . mdv2hi,mdv2lo,mdv4hi,mdv4lo,mdc2hi,mdc2lo, . vsc2hi,vsc2lo,vsc4hi,vsc4lo,cbar,cb,cwbdts,cwbdls, . mommth,bmcmth,rmpmth,mlrttp, - . . rm0,rm5,ce,tdfile,niwgf,niwbf,niwlf, . swamth,jwtype,chlopt,ccfile, . trxday,srxday,trxdpt,srxdpt,trxlim,srxlim, . aptflx,apsflx,ditflx,disflx,srxbal,scfile,smtfrc,sprfac, . atm_path, . itest,jtest, + . cnsvdi, + . csdiag, . rstfrq,rstfmt,rstcmp,iotype c c --- read limits namelist @@ -163,6 +165,8 @@ subroutine rdlim write (lp,*) 'ATM_PATH ',trim(ATM_PATH) write (lp,*) 'ITEST',ITEST write (lp,*) 'JTEST',JTEST + write (lp,*) 'CNSVDI',CNSVDI + write (lp,*) 'CSDIAG',CSDIAG write (lp,*) 'RSTFRQ',RSTFRQ write (lp,*) 'RSTFMT',RSTFMT write (lp,*) 'RSTCMP',RSTCMP @@ -231,6 +235,8 @@ subroutine rdlim call xcbcst(atm_path) call xcbcst(itest) call xcbcst(jtest) + call xcbcst(cnsvdi) + call xcbcst(csdiag) call xcbcst(rstfrq) call xcbcst(rstfmt) call xcbcst(rstcmp) diff --git a/tests/fuk95/limits b/tests/fuk95/limits index fdcb58e3..b2dc21d5 100644 --- a/tests/fuk95/limits +++ b/tests/fuk95/limits @@ -79,6 +79,8 @@ ! 'ben02syn' (a) ! ITEST : Global i-index of point diagnostics (i) ! JTEST : Global j-index of point diagnostics (i) +! CNSVDI : Conservation diagnostics flag (l) +! CSDIAG : Checksum diagnostics flag (l) ! RSTFRQ : Restart frequency in days (30=1month,365=1year) (i) ! RSTFMT : Format of restart file (valid arguments are 0 for classic, ! 1 for 64-bit offset and 2 for netcdf4/hdf5 format) (i) @@ -319,8 +321,6 @@ ! LIP - liquid precipitation [kg m-2 s-1] ! MAXMLD - maximum mixed layer depth [m] ! MLD - mixed layer depth [m] -! MLDU - mixed layer depth at u-point [m] -! MLDV - mixed layer depth at v-point [m] ! MLTS - mixed layer thickness using "sigma-t" criterion [m] ! MLTSMN - minimum mixed layer thickness using "sigma-t" criterion [m] ! MLTSMX - maximum mixed layer thickness using "sigma-t" criterion [m] @@ -332,8 +332,6 @@ ! MTKEPE - mixed layer TKE tendency related to pot. energy change [kg s-3] ! MTKEKE - mixed layer TKE tendency related to kin. energy change [kg s-3] ! MTY - wind stress y-component [N m-2] -! MXLU - mixed layer velocity x-component [m s-1] -! MXLV - mixed layer velocity y-component [m s-1] ! NSF - non-solar heat flux [W m-2] ! PBOT - bottom pressure [Pa] ! PSRF - surface pressure [Pa] @@ -368,7 +366,10 @@ ! VICE - ice velocity y-component [m s-1] ! ZTX - wind stress x-component [N m-2] ! BFSQ - buoyancy frequency squared [s-1] -! DIFDIA - diapycnal diffusivity [log10(m2 s-1)] +! DIFDIA - vertical diffusivity [log10(m2 s-1)|m2 s-1] +! DIFVMO - vertical momentum diffusivity [log10(m2 s-1)|m2 s-1] +! DIFVHO - vertical heat diffusivity [log10(m2 s-1)|m2 s-1] +! DIFVSO - vertical salt diffusivity [log10(m2 s-1)|m2 s-1] ! DIFINT - layer interface diffusivity [log10(m2 s-1)] ! DIFISO - isopycnal diffusivity [log10(m2 s-1)] ! DP - layer pressure thickness [Pa] @@ -441,8 +442,6 @@ H2D_LIP = 0, 0 H2D_MAXMLD = 4, 4 H2D_MLD = 0, 4 - H2D_MLDU = 0, 0 - H2D_MLDV = 0, 0 H2D_MLTS = 0, 4 H2D_MLTSMN = 0, 4 H2D_MLTSMX = 0, 4 @@ -454,8 +453,6 @@ H2D_MTKEPE = 0, 4 H2D_MTKEKE = 0, 4 H2D_MTY = 0, 0 - H2D_MXLU = 4, 4 - H2D_MXLV = 4, 4 H2D_NSF = 0, 0 H2D_PBOT = 0, 4 H2D_PSRF = 0, 0 @@ -491,6 +488,9 @@ H2D_ZTX = 0, 0 LYR_BFSQ = 0, 4 LYR_DIFDIA = 0, 4 + LYR_DIFVMO = 0, 4 + LYR_DIFVHO = 0, 4 + LYR_DIFVSO = 0, 0 LYR_DIFINT = 0, 0 LYR_DIFISO = 0, 0 LYR_DP = 0, 4 @@ -524,6 +524,9 @@ LYR_IDLAGE = 0, 4 LVL_BFSQ = 0, 4 LVL_DIFDIA = 0, 4 + LVL_DIFVMO = 0, 4 + LVL_DIFVHO = 0, 4 + LVL_DIFVSO = 0, 0 LVL_DIFINT = 0, 0 LVL_DIFISO = 0, 0 LVL_DZ = 0, 4 From ca62d337718d2621f910b799090519ce1cb842d1 Mon Sep 17 00:00:00 2001 From: jmaerz <92309038+jmaerz@users.noreply.github.com> Date: Tue, 22 Nov 2022 15:55:49 +0100 Subject: [PATCH 228/366] pCO2, Piston velocity and solubility output (#202) * add pCO2m (moist), CO2 piston velocity and solubility output - caution: kwco2 piston velocity now really holds only piston velocity (and not times solubility) --- cime_config/buildnml | 14 +++++++++++++- hamocc/accfields.F90 | 12 +++++++++--- hamocc/carchm.F90 | 17 ++++++++++++---- hamocc/mo_bgcmean.F90 | 16 +++++++++++++++ hamocc/mo_carbch.F90 | 43 +++++++++++++++++++++++++++++++++++++++++ hamocc/ncout_hamocc.F90 | 29 +++++++++++++++++++++++++-- 6 files changed, 121 insertions(+), 10 deletions(-) diff --git a/cime_config/buildnml b/cime_config/buildnml index 95ad80dd..2507d13d 100755 --- a/cime_config/buildnml +++ b/cime_config/buildnml @@ -426,7 +426,11 @@ set SRF_EXPORT = '0, 2, 2' set SRF_EXPOSI = '0, 2, 2' set SRF_EXPOCA = '0, 2, 2' set SRF_KWCO2 = '0, 2, 2' +set SRF_KWCO2KHM = '0, 2, 2' +set SRF_CO2KH = '0, 2, 2' +set SRF_CO2KHM = '0, 2, 2' set SRF_PCO2 = '0, 2, 2' +set SRF_PCO2M = '0, 2, 2' set SRF_CO2FXD = '4, 2, 2' set SRF_CO2FXU = '4, 2, 2' set SRF_OXFLUX = '0, 2, 2' @@ -1584,7 +1588,11 @@ cat >>! $RUNDIR/ocn_in$inststr << EOF ! EXPOCA - Ca export production (epcalc100) [mol Ca m-2 s-1] ! EXPOSI - Si export production (epsi100) [mol Si m-2 s-1] ! PCO2 - Surface PCO2 (spco2) [uatm] -! KWCO2 - kwco2 x solubility +! PCO2M - Surface PCO2 under moist air assumption [uatm] +! KWCO2 - Piston velocity (kwco2) [m s-1] +! KWCO2KHM - Piston velocity times solubility (kwco2*kh; moist air) [m s-1 mol kg-1 uatm-1] +! CO2KH - CO2 solubility under dry air assumption (khd) [mol kg-1 atm-1] +! CO2KHM - CO2 solubility under moist air assumption (kh) [mol kg-1 atm-1] ! CO2FXD - Downward CO2 flux (co2fxd) [kg C m-2 s-1] ! CO2FXU - Upward CO2 flux (co2fxu) [kg C m-2 s-1] ! NIFLUX - Nitrogen flux (fgn2) [mol N2 m-2 s-1] @@ -1664,7 +1672,11 @@ cat >>! $RUNDIR/ocn_in$inststr << EOF SRF_EXPOSI = $SRF_EXPOSI SRF_EXPOCA = $SRF_EXPOCA SRF_KWCO2 = $SRF_KWCO2 + SRF_KWCO2KHM = $SRF_KWCO2KHM + SRF_CO2KH = $SRF_CO2KH + SRF_CO2KHM = $SRF_CO2KHM SRF_PCO2 = $SRF_PCO2 + SRF_PCO2M = $SRF_PCO2M SRF_CO2FXD = $SRF_CO2FXD SRF_CO2FXU = $SRF_CO2FXU SRF_OXFLUX = $SRF_OXFLUX diff --git a/hamocc/accfields.F90 b/hamocc/accfields.F90 index ff87802d..a83fe953 100644 --- a/hamocc/accfields.F90 +++ b/hamocc/accfields.F90 @@ -46,7 +46,8 @@ SUBROUTINE ACCFIELDS(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask) !********************************************************************** use mod_xc, only: mnproc use mod_dia, only: ddm - use mo_carbch, only: atm,atmflx,co2fxd,co2fxu,co3,hi,kwco2sol,ndepflx,rivinflx,ocetra,omegaa,omegac,pco2d,satoxy,sedfluxo + use mo_carbch, only: atm,atmflx,co2fxd,co2fxu,co3,hi,kwco2sol,ndepflx,rivinflx,ocetra,omegaa,omegac,pco2d,satoxy, & + & sedfluxo,pco2m,kwco2d,co2sold,co2solm use mo_biomod, only: bsiflx_bot,bsiflx0100,bsiflx0500,bsiflx1000,bsiflx2000,bsiflx4000,calflx_bot,calflx0100,calflx0500,& & calflx1000,calflx2000,calflx4000,carflx_bot,carflx0100,carflx0500,carflx1000,carflx2000,carflx4000,& & expoca,expoor,exposi,intdms_bac,intdms_uv,intdmsprod,intdnit,intnfix,intphosy,phosy3d @@ -63,7 +64,8 @@ SUBROUTINE ACCFIELDS(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask) & jlvlph,jlvlphosph,jlvlphosy,jlvlphyto,jlvlphyto13,jlvlpoc,jlvlpoc13,jlvlprefalk,jlvlprefdic, & & jlvlprefo2,jlvlprefpo4,jlvlsf6,jlvlsilica,jlvlwnos,jlvlwphy,jn2flux,jn2o,jn2oflux,jn2ofx, & & jprorca,jprcaca,jsilpro,jpodiic,jpodial,jpodiph,jpodiox,jpodin2,jpodino3,jpodisi,jndep, & - & jniflux,jnos,jo2flux,jo2sat,jomegaa,jomegac,jopal,joxflux,joxygen,jpco2,jph,jphosph,jphosy,jphyto, & + & jniflux,jnos,jo2flux,jo2sat,jomegaa,jomegac,jopal,joxflux,joxygen,jpco2,jpco2m,jkwco2khm,jco2khm, & + & jco2kh,jph,jphosph,jphosy,jphyto, & & jpoc,jprefalk,jprefdic,jprefo2,jprefpo4,jsilica,jsrfalkali,jsrfano3,jsrfdic,jsrfiron,jsrfoxygen, & & jsrfphosph,jsrfphyto,jsrfsilica,jwnos,jwphy,nbgc,nacc_bgc,bgcwrt,glb_inventory,bgct2d,acclvl, & & acclyr,accsrf,bgczlv @@ -227,7 +229,11 @@ SUBROUTINE ACCFIELDS(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask) ! Accumulate 2d diagnostics call accsrf(jpco2,pco2d,omask,0) - call accsrf(jkwco2,kwco2sol,omask,0) + call accsrf(jpco2m,pco2m,omask,0) + call accsrf(jkwco2khm,kwco2sol,omask,0) + call accsrf(jkwco2,kwco2d,omask,0) + call accsrf(jco2kh,co2sold,omask,0) + call accsrf(jco2khm,co2solm,omask,0) call accsrf(jsrfphosph,ocetra(1,1,1,iphosph),omask,0) call accsrf(jsrfoxygen,ocetra(1,1,1,ioxygen),omask,0) call accsrf(jsrfiron,ocetra(1,1,1,iiron),omask,0) diff --git a/hamocc/carchm.F90 b/hamocc/carchm.F90 index bab04daf..f0563983 100644 --- a/hamocc/carchm.F90 +++ b/hamocc/carchm.F90 @@ -94,7 +94,8 @@ SUBROUTINE CARCHM(kpie,kpje,kpke,kbnd, & ! none. ! !********************************************************************** - use mo_carbch, only: atm,atmflx,co2fxd,co2fxu,co2star,co3,hi,keqb,kwco2sol,ocetra,omegaa,omegac,pco2d,satn2o,satoxy + use mo_carbch, only: atm,atmflx,co2fxd,co2fxu,co2star,co3,hi,keqb,kwco2sol,ocetra,omegaa,omegac,pco2d,satn2o,satoxy, & + pco2m,kwco2d,co2sold,co2solm use mo_chemcon, only: al1,al2,al3,al4,an0,an1,an2,an3,an4,an5,an6,atn2o,bl1,bl2,bl3,calcon,ox0,ox1,ox2,ox3,ox4,ox5,ox6, & & oxyco,tzero use mo_control_bgc, only: dtbgc @@ -180,7 +181,11 @@ SUBROUTINE CARCHM(kpie,kpje,kpke,kbnd, & co214fxd (:,:)=0. co214fxu (:,:)=0. #endif - pco2d (:,:)=0. + pco2d (:,:)=0. + pco2m (:,:)=0. + kwco2d (:,:)=0. + co2sold (:,:)=0. + co2solm (:,:)=0. kwco2sol (:,:)=0. co2star(:,:,:)=0. co3 (:,:,:)=0. @@ -518,13 +523,17 @@ SUBROUTINE CARCHM(kpie,kpje,kpke,kbnd, & ! Save pco2 w.r.t. dry air for output pco2d(i,j) = cu * 1.e6 / Khd + !pCO2 wrt moist air + pco2m(i,j) = cu * 1.e6 / Kh #ifdef natDIC natpco2d(i,j) = natcu * 1.e6 / Khd #endif ! Save product of piston velocity and solubility for output - kwco2sol(i,j) = kwco2*Kh*1e-6 - + kwco2sol(i,j) = kwco2*Kh*1e-6 !m/s mol/kg/muatm + kwco2d(i,j) = kwco2 ! m/s (incl. ice fraction!) + co2sold(i,j) = Khd ! mol/kg/atm + co2solm(i,j) = Kh ! mol/kg/atm endif ! k==1 #ifdef BROMO diff --git a/hamocc/mo_bgcmean.F90 b/hamocc/mo_bgcmean.F90 index 35687938..9bb44653 100644 --- a/hamocc/mo_bgcmean.F90 +++ b/hamocc/mo_bgcmean.F90 @@ -76,6 +76,8 @@ MODULE mo_bgcmean ! --- Namelist for diagnostic output INTEGER, DIMENSION(nbgcmax), SAVE :: & & SRF_KWCO2 =0 ,SRF_PCO2 =0 ,SRF_DMSFLUX =0 , & + & SRF_KWCO2KHM =0 ,SRF_CO2KHM =0 ,SRF_CO2KH =0 , & + & SRF_PCO2M =0 , & & SRF_CO2FXD =0 ,SRF_CO2FXU =0 ,SRF_CO213FXD =0 , & & SRF_CO213FXU =0 ,SRF_CO214FXD =0 ,SRF_CO214FXU =0 , & & SRF_OXFLUX =0 ,SRF_NIFLUX =0 ,SRF_DMS =0 , & @@ -150,6 +152,8 @@ MODULE mo_bgcmean CHARACTER(LEN=10), DIMENSION(nbgcmax), SAVE :: GLB_FNAMETAG namelist /DIABGC/ & & SRF_KWCO2 ,SRF_PCO2 ,SRF_DMSFLUX , & + & SRF_KWCO2KHM ,SRF_CO2KHM ,SRF_CO2KH , & + & SRF_PCO2M , & & SRF_CO2FXD ,SRF_CO2FXU ,SRF_CO213FXD , & & SRF_CO213FXU ,SRF_CO214FXD ,SRF_CO214FXU , & & SRF_OXFLUX ,SRF_NIFLUX ,SRF_DMS , & @@ -255,7 +259,11 @@ MODULE mo_bgcmean INTEGER, SAVE :: i_bsc_m2d INTEGER, DIMENSION(nbgcmax), SAVE :: & & jkwco2 = 0 , & + & jkwco2khm = 0 , & + & jco2kh = 0 , & + & jco2khm = 0 , & & jpco2 = 0 , & + & jpco2m = 0 , & & jdmsflux = 0 , & & jco2fxd = 0 , & & jco2fxu = 0 , & @@ -560,8 +568,16 @@ SUBROUTINE ALLOC_MEM_BGCMEAN(kpie,kpje,kpke) DO n=1,nbgc IF (SRF_KWCO2(n).GT.0) i_bsc_m2d=i_bsc_m2d+1 jkwco2(n)=i_bsc_m2d*min(1,SRF_KWCO2(n)) + IF (SRF_KWCO2KHM(n).GT.0) i_bsc_m2d=i_bsc_m2d+1 + jkwco2khm(n)=i_bsc_m2d*min(1,SRF_KWCO2KHM(n)) + IF (SRF_CO2KH(n).GT.0) i_bsc_m2d=i_bsc_m2d+1 + jco2kh(n)=i_bsc_m2d*min(1,SRF_CO2KH(n)) + IF (SRF_CO2KHM(n).GT.0) i_bsc_m2d=i_bsc_m2d+1 + jco2khm(n)=i_bsc_m2d*min(1,SRF_CO2KHM(n)) IF (SRF_PCO2(n).GT.0) i_bsc_m2d=i_bsc_m2d+1 jpco2(n)=i_bsc_m2d*min(1,SRF_PCO2(n)) + IF (SRF_PCO2M(n).GT.0) i_bsc_m2d=i_bsc_m2d+1 + jpco2m(n)=i_bsc_m2d*min(1,SRF_PCO2M(n)) IF (SRF_DMSFLUX(n).GT.0) i_bsc_m2d=i_bsc_m2d+1 jdmsflux(n)=i_bsc_m2d*min(1,SRF_DMSFLUX(n)) IF (SRF_CO2FXD(n).GT.0) i_bsc_m2d=i_bsc_m2d+1 diff --git a/hamocc/mo_carbch.F90 b/hamocc/mo_carbch.F90 index 234f3c48..6a83fc2b 100644 --- a/hamocc/mo_carbch.F90 +++ b/hamocc/mo_carbch.F90 @@ -74,7 +74,11 @@ MODULE mo_carbch REAL, DIMENSION (:,:,:), ALLOCATABLE :: sedfluxo REAL, DIMENSION (:,:), ALLOCATABLE :: pco2d + REAL, DIMENSION (:,:), ALLOCATABLE :: pco2m REAL, DIMENSION (:,:), ALLOCATABLE :: kwco2sol + REAL, DIMENSION (:,:), ALLOCATABLE :: kwco2d + REAL, DIMENSION (:,:), ALLOCATABLE :: co2sold + REAL, DIMENSION (:,:), ALLOCATABLE :: co2solm REAL, DIMENSION (:,:), ALLOCATABLE :: co2fxd REAL, DIMENSION (:,:), ALLOCATABLE :: co2fxu #ifdef cisonew @@ -334,12 +338,51 @@ SUBROUTINE ALLOC_MEM_CARBCH(kpie,kpje,kpke) if(errstat.ne.0) stop 'not enough memory pco2d' pco2d(:,:) = 0.0 + IF (mnproc.eq.1) THEN + WRITE(io_stdo_bgc,*)'Memory allocation for variable pco2m ...' + WRITE(io_stdo_bgc,*)'First dimension : ',kpie + WRITE(io_stdo_bgc,*)'Second dimension : ',kpje + ENDIF + + ALLOCATE (pco2m(kpie,kpje),stat=errstat) + if(errstat.ne.0) stop 'not enough memory pco2m' + pco2m(:,:) = 0.0 + + IF (mnproc.eq.1) THEN + WRITE(io_stdo_bgc,*)'Memory allocation for variable kwco2d ...' + WRITE(io_stdo_bgc,*)'First dimension : ',kpie + WRITE(io_stdo_bgc,*)'Second dimension : ',kpje + ENDIF + + ALLOCATE (kwco2d(kpie,kpje),stat=errstat) + if(errstat.ne.0) stop 'not enough memory kwco2d' + kwco2d(:,:) = 0.0 IF (mnproc.eq.1) THEN WRITE(io_stdo_bgc,*)'Memory allocation for variable kwco2sol ...' WRITE(io_stdo_bgc,*)'First dimension : ',kpie WRITE(io_stdo_bgc,*)'Second dimension : ',kpje ENDIF + + IF (mnproc.eq.1) THEN + WRITE(io_stdo_bgc,*)'Memory allocation for variable co2sold ...' + WRITE(io_stdo_bgc,*)'First dimension : ',kpie + WRITE(io_stdo_bgc,*)'Second dimension : ',kpje + ENDIF + + ALLOCATE (co2sold(kpie,kpje),stat=errstat) + if(errstat.ne.0) stop 'not enough memory co2sold' + co2sold(:,:) = 0.0 + + IF (mnproc.eq.1) THEN + WRITE(io_stdo_bgc,*)'Memory allocation for variable co2solm ...' + WRITE(io_stdo_bgc,*)'First dimension : ',kpie + WRITE(io_stdo_bgc,*)'Second dimension : ',kpje + ENDIF + + ALLOCATE (co2solm(kpie,kpje),stat=errstat) + if(errstat.ne.0) stop 'not enough memory co2solm' + co2solm(:,:) = 0.0 ALLOCATE (kwco2sol(kpie,kpje),stat=errstat) if(errstat.ne.0) stop 'not enough memory co2fxd,co2fxu' diff --git a/hamocc/ncout_hamocc.F90 b/hamocc/ncout_hamocc.F90 index c4bafdff..8e930519 100644 --- a/hamocc/ncout_hamocc.F90 +++ b/hamocc/ncout_hamocc.F90 @@ -75,6 +75,7 @@ subroutine ncwrt_bgc(iogrp) & jlvlwnos,jlvlwphy,jn2flux,jn2o,jn2oflux, & & jn2ofx,jndep,jniflux,jnos,jo2flux,jo2sat, & & jomegaa,jomegac,jopal,joxflux,joxygen,jpco2, & + & jpco2m,jkwco2khm,jco2kh,jco2khm, & & jph,jphosph,jphosy,jphyto,jpoc,jprefalk, & & jprefdic,jprefo2,jprefpo4,jsilica, & & jsrfalkali,jsrfano3,jsrfdic,jsrfiron, & @@ -95,6 +96,7 @@ subroutine ncwrt_bgc(iogrp) & lvl_n2o,lvl_prefo2,lvl_o2sat,lvl_prefpo4, & & lvl_prefalk,lvl_prefdic,lvl_dicsat, & & lvl_o2sat,srf_n2ofx,srf_atmco2,srf_kwco2, & + & srf_kwco2khm,srf_co2kh,srf_co2khm,srf_pco2m, & & srf_pco2,srf_dmsflux,srf_co2fxd, & & srf_co2fxu,srf_oxflux,srf_niflux,srf_dms, & & srf_dmsprod,srf_dms_bac,srf_dms_uv, & @@ -392,9 +394,18 @@ subroutine ncwrt_bgc(iogrp) ! --- Store 2d fields call wrtsrf(jkwco2(iogrp),SRF_KWCO2(iogrp),rnacc,0.,cmpflg, & - & 'kwco2',' ',' ',' ') + & 'kwco2','CO2 piston velocity',' ','m s-1') + call wrtsrf(jkwco2khm(iogrp),SRF_KWCO2KHM(iogrp),rnacc,0.,cmpflg, & + & 'kwco2khm','CO2 piston velocity times solubility (moist air)',' ', & + & 'm s-1 mol kg-1 uatm-1') + call wrtsrf(jco2kh(iogrp),SRF_CO2KH(iogrp),rnacc,0.,cmpflg, & + & 'co2kh','CO2 solubility (dry air) ',' ','mol kg-1 atm-1') + call wrtsrf(jco2khm(iogrp),SRF_CO2KHM(iogrp),rnacc,0.,cmpflg, & + & 'co2khm','CO2 solubility (moist air) ',' ','mol kg-1 atm-1') call wrtsrf(jpco2(iogrp),SRF_PCO2(iogrp),rnacc,0.,cmpflg, & & 'pco2','Surface PCO2',' ','uatm') + call wrtsrf(jpco2m(iogrp),SRF_PCO2M(iogrp),rnacc,0.,cmpflg, & + & 'pco2m','Surface PCO2 (moist air)',' ','uatm') call wrtsrf(jdmsflux(iogrp),SRF_DMSFLUX(iogrp),rnacc*1e3/dtbgc,0., & & cmpflg,'dmsflux','DMS flux',' ','mol DMS m-2 s-1') call wrtsrf(jco2fxd(iogrp),SRF_CO2FXD(iogrp),rnacc*12./dtbgc,0., & @@ -877,7 +888,11 @@ subroutine ncwrt_bgc(iogrp) ! --- Initialise fields call inisrf(jkwco2(iogrp),0.) + call inisrf(jkwco2khm(iogrp),0.) + call inisrf(jco2kh(iogrp),0.) + call inisrf(jco2khm(iogrp),0.) call inisrf(jpco2(iogrp),0.) + call inisrf(jpco2m(iogrp),0.) call inisrf(jdmsflux(iogrp),0.) call inisrf(jco2fxd(iogrp),0.) call inisrf(jco2fxu(iogrp),0.) @@ -1119,6 +1134,7 @@ subroutine hamoccvardef(iogrp,timeunits,calendar,cmpflg) & nctime,ncfcls,ncedef,ncdefvar3d,ndouble use mo_bgcmean, only: srf_kwco2,srf_pco2,srf_dmsflux,srf_co2fxd, & + & srf_kwco2khm,srf_co2kh,srf_co2khm,srf_pco2m, & & srf_co2fxu,srf_oxflux,srf_niflux,srf_dms,srf_dmsprod, & & srf_dms_bac,srf_dms_uv,srf_export,srf_exposi,srf_expoca, & & srf_dic,srf_alkali,srf_phosph,srf_oxygen,srf_ano3,srf_silica, & @@ -1195,9 +1211,18 @@ subroutine hamoccvardef(iogrp,timeunits,calendar,cmpflg) call ncattr('bounds','depth_bnds') call ncdefvar('depth_bnds','bounds depth',ndouble,8) call ncdefvar3d(SRF_KWCO2(iogrp),cmpflg,'p', & - & 'kwco2',' ',' ',' ',0) + & 'kwco2','CO2 piston velocity',' ','m s-1',0) + call ncdefvar3d(SRF_KWCO2KHM(iogrp),cmpflg,'p', & + & 'kwco2khm','CO2 piston velocity times solubility (moist air)',' ', & + & 'm s-1 mol kg-1 muatm-1',0) + call ncdefvar3d(SRF_CO2KH(iogrp),cmpflg,'p', & + & 'co2kh','CO2 solubility (dry air)',' ','mol kg-1 atm-1',0) + call ncdefvar3d(SRF_CO2KHM(iogrp),cmpflg,'p', & + & 'co2khm','CO2 solubility (moist air)',' ','mol kg-1 atm-1',0) call ncdefvar3d(SRF_PCO2(iogrp),cmpflg,'p', & & 'pco2','Surface PCO2',' ','uatm',0) + call ncdefvar3d(SRF_PCO2M(iogrp),cmpflg,'p', & + & 'pco2m','Surface PCO2 (moist air)',' ','uatm',0) call ncdefvar3d(SRF_DMSFLUX(iogrp), & & cmpflg,'p','dmsflux','DMS flux',' ','mol DMS m-2 s-1',0) call ncdefvar3d(SRF_CO2FXD(iogrp), & From 0f791c209b36fcc098e61fa4f888236491663c7f Mon Sep 17 00:00:00 2001 From: Tomas Torsvik <43031053+TomasTorsvik@users.noreply.github.com> Date: Fri, 25 Nov 2022 14:10:45 +0100 Subject: [PATCH 229/366] Bugfix pnetcdf (#208) * Add variables used by PNETCDF to explicit use staements. * Move implicit none statments * update explicit use statement for pnetcdf --- hamocc/read_netcdf_var.F90 | 3 +++ hamocc/write_netcdf_var.F90 | 3 +++ 2 files changed, 6 insertions(+) diff --git a/hamocc/read_netcdf_var.F90 b/hamocc/read_netcdf_var.F90 index 8befec8e..90b56067 100644 --- a/hamocc/read_netcdf_var.F90 +++ b/hamocc/read_netcdf_var.F90 @@ -26,6 +26,9 @@ SUBROUTINE READ_NETCDF_VAR(ncid,desc,arr,klev,time,typeio) !************************************************************************** use netcdf, only: nf90_noerr,nf90_inq_varid,nf90_strerror,nf90_get_var use mod_xc, only: idm,itdm,jtdm,jdm,lp,mnproc,nbdy,xchalt,xcaput +#ifdef PNETCDF + use mod_xc, only: i0,ii,jj,j0 +#endif implicit none #ifdef PNETCDF #include diff --git a/hamocc/write_netcdf_var.F90 b/hamocc/write_netcdf_var.F90 index af15b90b..d07eb4f5 100644 --- a/hamocc/write_netcdf_var.F90 +++ b/hamocc/write_netcdf_var.F90 @@ -27,6 +27,9 @@ SUBROUTINE WRITE_NETCDF_VAR(ncid,desc,arr,klev,time) use netcdf, only: nf90_noerr,nf90_inq_varid,nf90_strerror,nf90_put_var use mod_xc, only: itdm,jtdm,jdm,lp,mnproc,nbdy,idm,xchalt,xcaget use mod_dia, only: iotype +#ifdef PNETCDF + use mod_xc, only: i0,ii,jj,j0,mproc,mpe_1,nproc,xcgetrow +#endif implicit none #ifdef PNETCDF # include From 64da111eb3a6dc9555f65f5118c150f78cdb5c6e Mon Sep 17 00:00:00 2001 From: jmaerz <92309038+jmaerz@users.noreply.github.com> Date: Fri, 2 Dec 2022 15:29:28 +0100 Subject: [PATCH 230/366] fixed units and renamed calcium burial to CaCO3 burial (#212) Fixed sediment clay units. --- hamocc/ncout_hamocc.F90 | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/hamocc/ncout_hamocc.F90 b/hamocc/ncout_hamocc.F90 index 8e930519..6293f96b 100644 --- a/hamocc/ncout_hamocc.F90 +++ b/hamocc/ncout_hamocc.F90 @@ -869,18 +869,18 @@ subroutine ncwrt_bgc(iogrp) & 'ssssil','Sediment silicate',' ','mol Si m-3') call wrtsdm(jsssc12(iogrp),SDM_SSSC12(iogrp),rnacc*1e3,0.,cmpflg, & & 'sssc12','Sediment CaCO3',' ','mol C m-3') - call wrtsdm(jssster(iogrp),SDM_SSSTER(iogrp),rnacc*1e3,0.,cmpflg, & - & 'ssster','Sediment clay',' ','mol m-3') + call wrtsdm(jssster(iogrp),SDM_SSSTER(iogrp),rnacc,0.,cmpflg, & + & 'ssster','Sediment clay',' ','kg m-3') ! --- Store sediment burial fields call wrtbur(jburssso12(iogrp),BUR_SSSO12(iogrp),rnacc*1e3,0., & & cmpflg,'buro12','Burial org carbon',' ','mol P m-2') call wrtbur(jbursssc12(iogrp),BUR_SSSC12(iogrp),rnacc*1e3,0., & - & cmpflg,'burc12','Burial calcium ',' ','mol C m-2') + & cmpflg,'burc12','Burial CaCO3',' ','mol C m-2') call wrtbur(jburssssil(iogrp),BUR_SSSSIL(iogrp),rnacc*1e3,0., & & cmpflg,'bursil','Burial silicate',' ','mol Si m-2') - call wrtbur(jburssster(iogrp),BUR_SSSTER(iogrp),rnacc*1e3,0., & - & cmpflg,'burter','Burial clay',' ','mol m-2') + call wrtbur(jburssster(iogrp),BUR_SSSTER(iogrp),rnacc,0., & + & cmpflg,'burter','Burial clay',' ','kg m-2') #endif ! --- close netcdf file @@ -1641,17 +1641,17 @@ subroutine hamoccvardef(iogrp,timeunits,calendar,cmpflg) call ncdefvar3d(SDM_SSSC12(iogrp),cmpflg,'p', & & 'sssc12','Sediment CaCO3',' ','mol C m-3',3) call ncdefvar3d(SDM_SSSTER(iogrp),cmpflg,'p', & - & 'ssster','Sediment clay',' ','mol m-3',3) + & 'ssster','Sediment clay',' ','kg m-3',3) ! --- define sediment burial fields call ncdefvar3d(BUR_SSSO12(iogrp), & & cmpflg,'p','buro12','Burial org carbon',' ','mol P m-2',4) call ncdefvar3d(BUR_SSSC12(iogrp), & - & cmpflg,'p','burc12','Burial calcium ',' ','mol C m-2',4) + & cmpflg,'p','burc12','Burial CaCO3',' ','mol C m-2',4) call ncdefvar3d(BUR_SSSSIL(iogrp), & & cmpflg,'p','bursil','Burial silicate',' ','mol Si m-2',4) call ncdefvar3d(BUR_SSSTER(iogrp), & - & cmpflg,'p','burter','Burial clay',' ','mol m-2',4) + & cmpflg,'p','burter','Burial clay',' ','kg m-2',4) #endif ! --- enddef netcdf file From 55b9aa014757e4439745b6f11a7bb50bdc234380 Mon Sep 17 00:00:00 2001 From: Tomas Torsvik Date: Tue, 6 Dec 2022 10:19:26 +0100 Subject: [PATCH 231/366] Fix mistake from merge conflict in hamocc/powach.F90 --- hamocc/powach.F90 | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/hamocc/powach.F90 b/hamocc/powach.F90 index fd930fd6..ab7ca6fd 100644 --- a/hamocc/powach.F90 +++ b/hamocc/powach.F90 @@ -374,8 +374,7 @@ subroutine powach(kpie,kpje,kpke,kbnd,prho,omask,psao,lspin) if(powtra(i,j,k,ipowaox) < 3.e-6 .and. powtra(i,j,k,ipowno3) < 3.e-6) then posol = denit * sedlay(i,j,k,issso12) ! remineralization of poc umfa = porsol(i,j,k) / porwat(i,j,k) - !this overwrites anaerob from denitrification. added =anaerob+..., works - anaerob(i,k) = anaerob(i,k) + posol*umfa !this has P units: kmol P/m3 of pore water + sulf(i,k) = posol*umfa !this has P units: kmol P/m3 of pore water #ifdef cisonew rato13 = sedlay(i,j,k,issso13) / (sedlay(i,j,k,issso12)+safediv) rato14 = sedlay(i,j,k,issso14) / (sedlay(i,j,k,issso12)+safediv) From 3ed3cb18f091b2d77b40fa12d5a619bce4e1e8a1 Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Tue, 6 Dec 2022 13:40:52 +0100 Subject: [PATCH 232/366] fix lost jsrfpn2o --- hamocc/ncout_hamocc.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/hamocc/ncout_hamocc.F90 b/hamocc/ncout_hamocc.F90 index 0cf88ac5..129d5f54 100644 --- a/hamocc/ncout_hamocc.F90 +++ b/hamocc/ncout_hamocc.F90 @@ -79,7 +79,7 @@ subroutine ncwrt_bgc(iogrp) & jlvlwnos,jlvlwphy,jn2flux,jn2o,jn2oflux, & & jn2ofx,jndep,jniflux,jnos,jo2flux,jo2sat, & & jomegaa,jomegac,jopal,joxflux,joxygen,jpco2, & - & jpco2m,jkwco2khm,jco2kh,jco2khm, & + & jpco2m,jkwco2khm,jco2kh,jco2khm,jsrfpn2om, & & jph,jphosph,jphosy,jphyto,jpoc,jprefalk, & & jprefdic,jprefo2,jprefpo4,jsilica, & & jsrfalkali,jsrfano3,jsrfdic,jsrfiron, & From 41beb70b523ba55f6c00f24ec63a4a0e439860f8 Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Tue, 6 Dec 2022 13:41:37 +0100 Subject: [PATCH 233/366] add nitrite to netcdf-inventory output --- hamocc/inventory_bgc.F90 | 26 ++++++++++++++++++++++---- 1 file changed, 22 insertions(+), 4 deletions(-) diff --git a/hamocc/inventory_bgc.F90 b/hamocc/inventory_bgc.F90 index 8733c8e2..f8b41d3a 100644 --- a/hamocc/inventory_bgc.F90 +++ b/hamocc/inventory_bgc.F90 @@ -698,7 +698,7 @@ subroutine write_netcdf(iogrp) use mo_param1_bgc, only: inatalkali,inatcalc,inatsco212 #endif #ifdef extNcycle - use mo_param1_bgc, only: ianh4 + use mo_param1_bgc, only: ianh4,iano2 #endif @@ -802,6 +802,7 @@ subroutine write_netcdf(iogrp) #endif #ifdef extNcycle integer :: zt_nh4_varid, zc_nh4_varid ! Ammonium (NH4+) + integer :: zt_ano2_varid, zc_ano2_varid ! Nitrite (NO2-) #endif !--- sum of inventory integer :: totcarb_varid, totphos_varid, totsili_varid, totnitr_varid @@ -1453,9 +1454,20 @@ subroutine write_netcdf(iogrp) call nccheck( NF90_PUT_ATT(ncid, zc_nh4_varid, 'long_name', & & 'Mean ammonium concentration') ) call nccheck( NF90_PUT_ATT(ncid, zc_nh4_varid, 'units', 'kmol/m^3') ) + + call nccheck( NF90_DEF_VAR(ncid, 'zt_ano2', NF90_DOUBLE, & + & time_dimid, zt_ano2_varid) ) + call nccheck( NF90_PUT_ATT(ncid, zt_ano2_varid, 'long_name', & + & 'Total nitrite tracer') ) + call nccheck( NF90_PUT_ATT(ncid, zt_ano2_varid, 'units', 'kmol') ) + + call nccheck( NF90_DEF_VAR(ncid, 'zc_ano2', NF90_DOUBLE, & + & time_dimid, zc_ano2_varid) ) + call nccheck( NF90_PUT_ATT(ncid, zc_ano2_varid, 'long_name', & + & 'Mean nitrite concentration') ) + call nccheck( NF90_PUT_ATT(ncid, zc_ano2_varid, 'units', 'kmol/m^3') ) #endif - !--- Define variables : sum of inventory call nccheck( NF90_DEF_VAR(ncid, 'totcarb', NF90_DOUBLE, time_dimid, & & totcarb_varid) ) @@ -1651,6 +1663,8 @@ subroutine write_netcdf(iogrp) #ifdef extNcycle call nccheck( NF90_INQ_VARID(ncid, "zt_nh4", zt_nh4_varid) ) call nccheck( NF90_INQ_VARID(ncid, "zc_nh4", zc_nh4_varid) ) + call nccheck( NF90_INQ_VARID(ncid, "zt_ano2", zt_ano2_varid) ) + call nccheck( NF90_INQ_VARID(ncid, "zc_ano2", zc_ano2_varid) ) #endif !--- Inquire varid : sum of inventory call nccheck( NF90_INQ_VARID(ncid, "totcarb", totcarb_varid) ) @@ -1882,10 +1896,14 @@ subroutine write_netcdf(iogrp) & zocetratoc(ibromo), start = wrstart) ) #endif #ifdef extNcycle - call nccheck( NF90_PUT_VAR(ncid, zt_nh4_varid, & + call nccheck( NF90_PUT_VAR(ncid, zt_nh4_varid, & & zocetratot(ianh4), start = wrstart) ) - call nccheck( NF90_PUT_VAR(ncid, zc_nh4_varid, & + call nccheck( NF90_PUT_VAR(ncid, zc_nh4_varid, & & zocetratoc(ianh4), start = wrstart) ) + call nccheck( NF90_PUT_VAR(ncid, zt_ano2_varid, & + & zocetratot(iano2), start = wrstart) ) + call nccheck( NF90_PUT_VAR(ncid, zc_ano2_varid, & + & zocetratoc(iano2), start = wrstart) ) #endif !--- Write data : sum of inventory call nccheck( NF90_PUT_VAR(ncid, totcarb_varid, totalcarbon, & From 2b2524d8c7904f04eef857308cc1c9520a51e945 Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Tue, 6 Dec 2022 14:03:34 +0100 Subject: [PATCH 234/366] minor reordering --- hamocc/ncout_hamocc.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/hamocc/ncout_hamocc.F90 b/hamocc/ncout_hamocc.F90 index 129d5f54..43a5a798 100644 --- a/hamocc/ncout_hamocc.F90 +++ b/hamocc/ncout_hamocc.F90 @@ -76,10 +76,10 @@ subroutine ncwrt_bgc(iogrp) & jlvlphosy,jlvlphyto,jlvlphyto13,jlvlpoc, & & jlvlpoc13,jlvlprefalk,jlvlprefdic, & & jlvlprefo2,jlvlprefpo4,jlvlsf6,jlvlsilica, & - & jlvlwnos,jlvlwphy,jn2flux,jn2o,jn2oflux, & + & jlvlwnos,jlvlwphy,jn2flux,jn2o,jsrfpn2om,jn2oflux, & & jn2ofx,jndep,jniflux,jnos,jo2flux,jo2sat, & & jomegaa,jomegac,jopal,joxflux,joxygen,jpco2, & - & jpco2m,jkwco2khm,jco2kh,jco2khm,jsrfpn2om, & + & jpco2m,jkwco2khm,jco2kh,jco2khm, & & jph,jphosph,jphosy,jphyto,jpoc,jprefalk, & & jprefdic,jprefo2,jprefpo4,jsilica, & & jsrfalkali,jsrfano3,jsrfdic,jsrfiron, & From 9a57ef71aa1583b02084307d2519148f6a1f9d3c Mon Sep 17 00:00:00 2001 From: Mats Bentsen Date: Thu, 8 Dec 2022 16:41:24 +0100 Subject: [PATCH 235/366] - Made the "fuk95" configuration work with MKS units. - Removed "CGS" CPP flag. - Changed some unit conversion factors from variables to parameters. - Introduced rho0 (= 1/alpha0) parameter. - Updated copyright statements. --- ben02/mod_ben02.F | 22 ++- ben02/sfcstr_ben02.F | 2 +- ben02/thermf_ben02.F | 25 ++- cesm/sfcstr_cesm.F | 2 +- cesm/thermf_cesm.F | 28 +-- fuk95/mod_fuk95.F90 | 76 +++++---- meson.build | 6 +- meson_options.txt | 5 +- phy/convec.F | 2 +- phy/diapfl.F | 6 +- phy/diffus.F | 2 +- phy/geoenv_file.F | 2 +- phy/mod_advect.F | 1 - phy/mod_cmnfld.F90 | 2 +- phy/mod_cmnfld_routines.F90 | 12 +- phy/mod_constants.F90 | 88 +++++----- phy/mod_dia.F | 256 +++++++++++++--------------- phy/mod_difest.F | 93 +++++----- phy/mod_diffusion.F90 | 2 +- phy/mod_eddtra.F90 | 27 ++- phy/mod_eos.F90 | 61 +++---- phy/mod_inicon.F | 4 +- phy/mod_momtum.F | 6 +- phy/mod_mxlayr.F | 27 +-- phy/mod_ndiff.F90 | 5 +- phy/mod_pbcor.F | 2 +- phy/mod_pgforc.F | 3 - phy/mod_remap.F | 8 +- phy/mod_tidaldissip.F90 | 4 +- phy/mod_time.F90 | 2 +- phy/mod_tke.F90 | 13 +- phy/mod_tmsmt.F | 2 +- phy/mod_vcoord.F90 | 2 +- phy/mod_vdiff.F90 | 4 +- phy/numerical_bounds.F90 | 4 +- phy/rdlim.F | 2 +- single_column/mod_single_column.F90 | 2 +- 37 files changed, 386 insertions(+), 424 deletions(-) diff --git a/ben02/mod_ben02.F b/ben02/mod_ben02.F index 39a8ef6a..2e6c63cb 100644 --- a/ben02/mod_ben02.F +++ b/ben02/mod_ben02.F @@ -1,5 +1,5 @@ ! ------------------------------------------------------------------------------ -! Copyright (C) 2002-2021 Mats Bentsen, Mehmet Ilicak +! Copyright (C) 2002-2022 Mats Bentsen, Mehmet Ilicak ! ! This file is part of BLOM. ! @@ -183,14 +183,13 @@ module mod_ben02 . atm_cswa_era ! short-wave radiation adjustment factor ! (NCEP) c -#if defined(CGS) - data atm_ice_csmt_ncep,atm_rnf_csmt_ncep /2.e14,1.e13/, +#ifdef MKS + data atm_ice_csmt_ncep,atm_rnf_csmt_ncep /2.e10,1.e9/, . atm_crnf_ncep,atm_cswa_ncep /0.82073,0.88340/, - . atm_ice_csmt_era,atm_rnf_csmt_era /0.0,1.e13/, + . atm_ice_csmt_era,atm_rnf_csmt_era /0.0,1.e9/, . atm_crnf_era,atm_cswa_era /0.7234,0.9721/ -#endif -#if defined(MKS) - data atm_ice_csmt_ncep,atm_rnf_csmt_ncep /2.e10,1.e9/, +#else + data atm_ice_csmt_ncep,atm_rnf_csmt_ncep /2.e14,1.e13/, . atm_crnf_ncep,atm_cswa_ncep /0.82073,0.88340/, . atm_ice_csmt_era,atm_rnf_csmt_era /0.0,1.e13/, . atm_crnf_era,atm_cswa_era /0.7234,0.9721/ @@ -2098,13 +2097,12 @@ subroutine inifrc_ben02clim integer, dimension(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy,12) :: smtmsk real dx2,dy2,prc_sum,eva_sum,rnf_sum,swa_sum,lwa_sum,lht_sum, . sht_sum,fwf_fac,dangle,garea,le,albedo,fac,swa_ave,lwa_ave, - . lht_ave,sht_ave,crnf,cswa + . lht_ave,sht_ave,crnf,cswa,A_cgs2mks real*4 rw4 integer i,j,k,l,il,jl integer*2 rn2,ri2,rj2 c - real iL_mks2cgssq - iL_mks2cgssq = 1.0 / (L_mks2cgs*L_mks2cgs) + A_cgs2mks=1./(L_mks2cgs**2) c c --- Allocate memory for additional monthly forcing fields. allocate(taud (1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy,12), @@ -2786,7 +2784,7 @@ subroutine inifrc_ben02clim do k=1,12 do l=1,isp(j) do i=max(1,ifp(j,l)),min(ii,ilp(j,l)) - garea=scp2(i,j)*iL_mks2cgssq ! [m^2] + garea=scp2(i,j)*A_cgs2mks ! [m^2] c c --- ----- freshwater fluxes [m/s] util1(i,j)=util1(i,j)+precip(i,j,k)*fwf_fac*garea @@ -2830,7 +2828,7 @@ subroutine inifrc_ben02clim do j=1,jj do l=1,isp(j) do i=max(1,ifp(j,l)),min(ii,ilp(j,l)) - garea=scp2(i,j)*iL_mks2cgssq ! [m^2] + garea=scp2(i,j)*A_cgs2mks ! [m^2] c c --- ----- heat fluxes albedo=albs_f*ricclm(i,j,k)+albw(i,j)*(1.-ricclm(i,j,k)) diff --git a/ben02/sfcstr_ben02.F b/ben02/sfcstr_ben02.F index e81c005d..ee8161a6 100644 --- a/ben02/sfcstr_ben02.F +++ b/ben02/sfcstr_ben02.F @@ -1,5 +1,5 @@ ! ------------------------------------------------------------------------------ -! Copyright (C) 2004-2020 Mats Bentsen +! Copyright (C) 2004-2022 Mats Bentsen, Mehmet Ilicak ! ! This file is part of BLOM. ! diff --git a/ben02/thermf_ben02.F b/ben02/thermf_ben02.F index 11fc1f66..fcd5bd19 100644 --- a/ben02/thermf_ben02.F +++ b/ben02/thermf_ben02.F @@ -1,5 +1,5 @@ ! ------------------------------------------------------------------------------ -! Copyright (C) 2002-2021 Mats Bentsen +! Copyright (C) 2002-2022 Mats Bentsen, Mehmet Ilicak ! ! This file is part of BLOM. ! @@ -21,8 +21,8 @@ subroutine thermf_ben02(m,n,mm,nn,k1m,k1n) c c --- NERSC version of thermf. c - use mod_constants, only: spcifh, t0deg, epsilt, onem - use mod_constants, only: L_mks2cgs, M_mks2cgs, g2kg, alpha0 + use mod_constants, only: spcifh, t0deg, alpha0, epsilt, onem, + . g2kg, kg2g, L_mks2cgs, M_mks2cgs use mod_time, only: nday_in_year, nday_of_year, nstep, . nstep_in_day, baclin, . xmi, l1mi, l2mi, l3mi, l4mi, l5mi @@ -67,12 +67,12 @@ subroutine thermf_ben02(m,n,mm,nn,k1m,k1n) real, dimension(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy) :: vrtsfl c integer i,j,k,l,m1,m2,m3,m4,m5 - real*8 dt,cpsw,rnf_fac,sag_fac,y, + real dt,cpsw,rnf_fac,sag_fac,y, . dpotl,hotl,totl,sotl,dpmxl,hmxl,tmxl,smxl,tice_f,hice_min, . fice,hice,hsnw,tsrf,fice0,hice0,hsnw0,qsww,qnsw,tice,albi, . tsmlt,albi_h,qswi,dh,qsnwf,fcond,qdamp,qsmlt,qo2i,qbot,swfac, . dtml,q,volice,df,dvi,dvs,fwflx,sstc,rice,trxflx,sssc,srxflx, - . totsfl,totwfl,sflxc,totsrp,totsrn + . totsfl,totwfl,sflxc,totsrp,totsrn,A_cgs2mks #ifdef TRC integer nt real, dimension(ntr,1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy) :: @@ -83,9 +83,8 @@ subroutine thermf_ben02(m,n,mm,nn,k1m,k1n) c real intp1d external intp1d - real iL_mks2cgssq c - iL_mks2cgssq = 1.0 / (L_mks2cgs**2) + A_cgs2mks=1./(L_mks2cgs**2) c c --- Due to conservation, the ratio of ice and snow density must be c --- equal to the ratio of ice and snow heat of fusion @@ -419,11 +418,11 @@ subroutine thermf_ben02(m,n,mm,nn,k1m,k1n) hmltfz(i,j)=(dvi*fusi+dvs*fuss)/dt c c --- --- Total heat flux in BLOM units [W cm-2] (positive upwards) - surflx(i,j)=-(swa(i,j)+nsf(i,j)+hmltfz(i,j))*iL_mks2cgssq + surflx(i,j)=-(swa(i,j)+nsf(i,j)+hmltfz(i,j))*A_cgs2mks c c --- --- Short-wave heat flux in BLOM units [W cm-2] (positive c --- --- upwards) - sswflx(i,j)=-qsww*(1.-fice0)*iL_mks2cgssq + sswflx(i,j)=-qsww*(1.-fice0)*A_cgs2mks c #ifdef TRC c --- ------------------------------------------------------------------ @@ -478,7 +477,7 @@ subroutine thermf_ben02(m,n,mm,nn,k1m,k1n) . ricclm(i,j,l5mi),xmi) sstc=(1.-rice)*max(sstc,tice_f)+rice*tice_f trxflx=spcifh*L_mks2cgs*min(hmxl,trxdpt)/(trxday*86400.) - . *min(trxlim,max(-trxlim,sstc-tmxl))/alpha0 + . *min(trxlim,max(-trxlim,sstc-tmxl))/alpha0 surrlx(i,j)=-trxflx else trxflx=0. @@ -505,7 +504,7 @@ subroutine thermf_ben02(m,n,mm,nn,k1m,k1n) . sssclm(i,j,l3mi),sssclm(i,j,l4mi), . sssclm(i,j,l5mi),xmi) srxflx=L_mks2cgs*min(hmxl,srxdpt)/(srxday*86400.) - . *min(srxlim,max(-srxlim,sssc-smxl))/alpha0 + . *min(srxlim,max(-srxlim,sssc-smxl))/alpha0 salrlx(i,j)=-srxflx util3(i,j)=max(0.,salrlx(i,j))*scp2(i,j) util4(i,j)=min(0.,salrlx(i,j))*scp2(i,j) @@ -572,9 +571,9 @@ subroutine thermf_ben02(m,n,mm,nn,k1m,k1n) do l=1,isp(j) do i=max(1,ifp(j,l)),min(ii,ilp(j,l)) salflx(i,j)=-(vrtsfl(i,j)+sflxc+sfl(i,j)) - . *(1e3*(M_mks2cgs/L_mks2cgs**2)) + . *(kg2g*(M_mks2cgs/L_mks2cgs**2)) brnflx(i,j)=-brnflx(i,j) - . *(1e3*(M_mks2cgs/L_mks2cgs**2)) + . *(kg2g*(M_mks2cgs/L_mks2cgs**2)) enddo enddo enddo diff --git a/cesm/sfcstr_cesm.F b/cesm/sfcstr_cesm.F index 55a8d205..d0d047b7 100644 --- a/cesm/sfcstr_cesm.F +++ b/cesm/sfcstr_cesm.F @@ -1,5 +1,5 @@ ! ------------------------------------------------------------------------------ -! Copyright (C) 2015-2020 Mats Bentsen +! Copyright (C) 2015-2022 Mats Bentsen, Mehmet Ilicak ! ! This file is part of BLOM. ! diff --git a/cesm/thermf_cesm.F b/cesm/thermf_cesm.F index 8a80ce8e..9b9740a0 100644 --- a/cesm/thermf_cesm.F +++ b/cesm/thermf_cesm.F @@ -1,5 +1,5 @@ ! ------------------------------------------------------------------------------ -! Copyright (C) 2008-2021 Mats Bentsen +! Copyright (C) 2008-2022 Mats Bentsen, Mehmet Ilicak ! ! This file is part of BLOM. ! @@ -21,8 +21,8 @@ subroutine thermf_cesm(m,n,mm,nn,k1m,k1n) c c --- NERSC version of thermf. To be used when coupled to CESM c - use mod_constants, only: g, spcifh, t0deg, epsilt, onem - use mod_constants, only: L_mks2cgs, M_mks2cgs, g2kg, alpha0 + use mod_constants, only: g, spcifh, t0deg, alpha0, epsilt, onem, + . g2kg, kg2g, L_mks2cgs, M_mks2cgs use mod_time, only: nstep, nstep_in_day, nday_in_year, . nday_of_year, baclin, . xmi, l1mi, l2mi, l3mi, l4mi, l5mi @@ -62,7 +62,7 @@ subroutine thermf_cesm(m,n,mm,nn,k1m,k1n) integer i,j,k,l,m1,m2,m3,m4,m5 real y,dpotl,hotl,totl,sotl,dpmxl,hmxl,tmxl,smxl,tice_f,fwflx, . sstc,rice,trxflx,sssc,srxflx,totsfl,totwfl,sflxc,totsrp, - . totsrn,qp,qn + . totsrn,qp,qn,A_cgs2mks #ifdef TRC integer nt real, dimension(ntr,1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy) :: @@ -70,11 +70,10 @@ subroutine thermf_cesm(m,n,mm,nn,k1m,k1n) real tottrsf,tottrav,trflxc #endif c - real iL_mks2cgssq real intp1d external intp1d c - iL_mks2cgssq = 1.0 / (L_mks2cgs*L_mks2cgs) + A_cgs2mks=1./(L_mks2cgs**2) c c --- Set parameters for time interpolation when applying diagnosed heat c --- and salt relaxation fluxes @@ -155,7 +154,7 @@ subroutine thermf_cesm(m,n,mm,nn,k1m,k1n) c --- --- due to the leap-frog time stepping. The melting potential uses c --- --- time averaged quantities since it is not accumulated. frzpot(i,j)=max(0.,tice_f-totl)*spcifh*dpotl - . /(2.*g)*(L_mks2cgs**2) + . /(2.*g)*(L_mks2cgs**2) mltpot(i,j)= . min(0.,tfrzm(i,j)-.5*(temp(i,j,k1m)+temp(i,j,k1n))) . *spcifh*.5*(dp(i,j,k1m)+dp(i,j,k1n))/g*(L_mks2cgs**2) @@ -164,11 +163,11 @@ subroutine thermf_cesm(m,n,mm,nn,k1m,k1n) hmltfz(i,j)=hmlt(i,j)+frzpot(i,j)/baclin c c --- --- Total heat flux in BLOM units [W cm-2] (positive upwards) - surflx(i,j)=-(swa(i,j)+nsf(i,j)+hmltfz(i,j))*iL_mks2cgssq + surflx(i,j)=-(swa(i,j)+nsf(i,j)+hmltfz(i,j))*A_cgs2mks c c --- --- Short-wave heat flux in BLOM units [W cm-2] (positive c --- --- upwards) - sswflx(i,j)=-swa(i,j)*iL_mks2cgssq + sswflx(i,j)=-swa(i,j)*A_cgs2mks c #ifdef TRC c --- ------------------------------------------------------------------ @@ -187,7 +186,7 @@ subroutine thermf_cesm(m,n,mm,nn,k1m,k1n) if (nt.eq.itrgls) then trflx(nt,i,j)=-gls_n*difdia(i,j,1)*(gls_cmu0**gls_p) . *(trc(i,j,k1n,itrtke)**gls_m) - . *(vonKar**gls_n)*Zos**(gls_n-1.) + . *(vonKar**gls_n)*zos**(gls_n-1.) ttrsf(nt,i,j)=0. ttrav(nt,i,j)=0. cycle @@ -206,6 +205,7 @@ subroutine thermf_cesm(m,n,mm,nn,k1m,k1n) ttrav(nt,i,j)=trc(i,j,k1n,nt)*scp2(i,j) enddo #endif +c c --- ------------------------------------------------------------------ c --- --- Relaxation fluxes c --- ------------------------------------------------------------------ @@ -222,7 +222,7 @@ subroutine thermf_cesm(m,n,mm,nn,k1m,k1n) . ricclm(i,j,l5mi),xmi) sstc=(1.-rice)*max(sstc,tice_f)+rice*tice_f trxflx=spcifh*L_mks2cgs*min(hmxl,trxdpt)/(trxday*86400.) - . *min(trxlim,max(-trxlim,sstc-tmxl))/alpha0 + . *min(trxlim,max(-trxlim,sstc-tmxl))/alpha0 surrlx(i,j)=-trxflx else trxflx=0. @@ -249,7 +249,7 @@ subroutine thermf_cesm(m,n,mm,nn,k1m,k1n) . sssclm(i,j,l3mi),sssclm(i,j,l4mi), . sssclm(i,j,l5mi),xmi) srxflx=L_mks2cgs*min(hmxl,srxdpt)/(srxday*86400.) - . *min(srxlim,max(-srxlim,sssc-smxl))/alpha0 + . *min(srxlim,max(-srxlim,sssc-smxl))/alpha0 salrlx(i,j)=-srxflx util3(i,j)=max(0.,salrlx(i,j))*scp2(i,j) util4(i,j)=min(0.,salrlx(i,j))*scp2(i,j) @@ -304,9 +304,9 @@ subroutine thermf_cesm(m,n,mm,nn,k1m,k1n) do l=1,isp(j) do i=max(1,ifp(j,l)),min(ii,ilp(j,l)) salflx(i,j)=-(vrtsfl(i,j)+sflxc+sfl(i,j)) - . *(1e3*(M_mks2cgs/L_mks2cgs**2)) + . *(kg2g*(M_mks2cgs/L_mks2cgs**2)) brnflx(i,j)=-brnflx(i,j) - . *(1e3*(M_mks2cgs/L_mks2cgs**2)) + . *(kg2g*(M_mks2cgs/L_mks2cgs**2)) enddo enddo enddo diff --git a/fuk95/mod_fuk95.F90 b/fuk95/mod_fuk95.F90 index cd35535e..9a2b7054 100644 --- a/fuk95/mod_fuk95.F90 +++ b/fuk95/mod_fuk95.F90 @@ -1,5 +1,5 @@ ! ------------------------------------------------------------------------------ -! Copyright (C) 2021 Mats Bentsen +! Copyright (C) 2021-2022 Mats Bentsen ! ! This file is part of BLOM. ! @@ -25,7 +25,8 @@ module mod_fuk95 ! ------------------------------------------------------------------------------ use mod_types, only: r8 - use mod_constants, only: g, rearth, pi, radian, epsilt + 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_grid, only: qclon, qclat, pclon, pclat, uclon, uclat, vclon, vclat, & @@ -45,19 +46,32 @@ module mod_fuk95 private +! real(r8), parameter :: & +! u0 = 30._r8, & ! Maximum jet velocity [cm s-1]. +! h1 = 1.e4_r8, & ! Depth of active layer [cm]. +! h0 = 2.e4_r8, & ! Depth of water column [cm]. +! l0 = 2.e6_r8, & ! Half-width of the jet [cm]. +! drho = 0.19e-3_r8, & ! Active layer density difference [g cm-3]. +! rhoc = 1.0259_r8, & ! Density at the center of active layer [g cm-3]. +! rhob = 1.0270_r8, & ! Density of water beneath active layer [g cm-3]. +! f = 1.e-4_r8, & ! Coriolis parameter [1 s-1]. +! lat0 = 45._r8, & ! Center latitude of grid domain [deg]. +! lambda = 20.8e5, & ! Channel length [cm]. +! mindz = 1.e2_r8, & ! Minimum interior layer thickness [cm]. +! saln0 = 35._r8 ! Constant salinity value [g kg-1]. real(r8), parameter :: & - u0 = 30._r8, & ! Maximum jet velocity [cm s-1]. - h1 = 1.e4_r8, & ! Depth of active layer [cm]. - h0 = 2.e4_r8, & ! Depth of water column [cm]. - l0 = 2.e6_r8, & ! Half-width of the jet [cm]. - drho = 0.19e-3_r8, & ! Active layer density difference [g cm-3]. - rho1 = 1.0259_r8, & ! Density at the center of active layer [g cm-3]. - rho0 = 1.0270_r8, & ! Density of water beneath active layer [g cm-3]. - f = 1.e-4_r8, & ! Coriolis parameter [1 s-1]. - lat0 = 45._r8, & ! Center latitude of grid domain [deg]. - lambda = 20.8e5, & ! Channel length [cm]. - mindz = 1.e2_r8, & ! Minimum interior layer thickness [cm]. - saln0 = 35._r8 ! Constant salinity value [g kg-1]. + u0 = .3_r8*L_mks2cgs, & ! Maximum jet velocity [m s-1]. + h1 = 1.e2_r8*L_mks2cgs, & ! Depth of active layer [m]. + h0 = 2.e2_r8*L_mks2cgs, & ! Depth of water column [m]. + l0 = 2.e4_r8*L_mks2cgs, & ! Half-width of the jet [m]. + drho = 0.19_r8*R_mks2cgs, & ! Active layer density difference [kg m-3]. + rhoc = 1025.9_r8*R_mks2cgs, & ! Density at the center of active layer [kg m-3]. + rhob = 1027.0_r8*R_mks2cgs, & ! Density of water beneath active layer [kg m-3]. + f = 1.e-4_r8, & ! Coriolis parameter [1 s-1]. + lat0 = 45._r8, & ! Center latitude of grid domain [deg]. + lambda = 20.8e3*L_mks2cgs, & ! Channel length [m]. + mindz = 1._r8*L_mks2cgs, & ! Minimum interior layer thickness [m]. + saln0 = 35._r8 ! Constant salinity value [g kg-1]. public :: geoenv_fuk95, inifrc_fuk95, ictsz_fuk95 @@ -132,7 +146,7 @@ subroutine geoenv_fuk95 tmpg(1 , j) = 0._r8 tmpg(itdm, j) = 0._r8 do i = 2, itdm - 1 - tmpg(i, j) = h0*1.e-2 + tmpg(i, j) = h0*L_mks2cgs**(-1) enddo enddo !$omp end parallel do @@ -281,10 +295,10 @@ subroutine ictsz_fuk95 ! and corresponding isopycnic layer structure. The bulk mixed layer ! is set to the minimum mixed layer thickness. - drhojet = rho1*f*u0*l0/(g*h1) + drhojet = rhoc*f*u0*l0/(g*h1) dsig = (drho + drhojet)/(kk - 4) - sigref(kk) = rho0 - 1._r8 - sigref(kk - 1) = rho1 + .5_r8*(drho + drhojet) - 1._r8 + 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 @@ -310,11 +324,11 @@ subroutine ictsz_fuk95 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*1.e2_r8 - z(i, j, 3) = mltmin*1.e2_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 = rho1*(1._r8 + f*u0*x_psi(x)/(g*h1)) - 1._r8 + 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 & @@ -327,7 +341,7 @@ subroutine ictsz_fuk95 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 = rho1*(1._r8 + f*u0*x_psi(x)/(g*h1)) - 1._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), & @@ -347,20 +361,20 @@ subroutine ictsz_fuk95 ! active layer is distributed equally among the remaining model ! layers using constant z-level interfaces. -! drhojet = rho1*f*u0*l0/(g*h1) +! drhojet = rhoc*f*u0*l0/(g*h1) ! dsig = (drho + drhojet)/(kk - 4) -! sigref(kk) = .5_r8*(rho0 + rho1) + .25_r8*(drho + drhojet) - 1._r8 -! sigref(kk - 1) = rho1 + .5_r8*(drho + drhojet - dsig) - 1._r8 +! 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 = rho1*f*u0*l0/(g*h1) + drhojet = rhoc*f*u0*l0/(g*h1) dsig = (drho + drhojet)/(kk - 5) - sigref(kk - 2) = rho1 + .5_r8*(drho + drhojet - dsig) - 1._r8 + 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 ) = rho0 - 1._r8 + 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 @@ -383,14 +397,14 @@ subroutine ictsz_fuk95 enddo !$omp end parallel do - s0 = rho0 - 1._r8 + 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 = rho1*(1._r8 + f*u0*x_psi(x)/(g*h1)) - 1._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)) & @@ -426,7 +440,7 @@ subroutine ictsz_fuk95 zl = .5_r8*(z(i, j - 1, k + 1) + z(i, j, k + 1)) v1 = u0*psi(x)*(h1 - .5*(zu + zl))/h1 v1 = 0._r8 - if (abs(zl - zu) < epsilt) then + if (abs(zl - zu) < epsilz) then v(i, j, k) = v1 else v(i, j, k) = ( v1*max(0._r8, min(zl, h1) - zu) & diff --git a/meson.build b/meson.build index 2581a3a7..9f237b7e 100644 --- a/meson.build +++ b/meson.build @@ -71,11 +71,7 @@ subdir('pkgs/') # Handle options and add necessary flags and subfolders with source files -cgsmks = get_option('cgsmks') -if cgsmks.contains('cgs') - add_project_arguments('-DCGS', language: 'fortran') -endif -if cgsmks.contains('mks') +if get_option('mks') add_project_arguments('-DMKS', language: 'fortran') endif diff --git a/meson_options.txt b/meson_options.txt index e668730d..8e48383f 100644 --- a/meson_options.txt +++ b/meson_options.txt @@ -13,9 +13,8 @@ option('vcoord', type: 'combo', option('driver', type: 'combo', choices: ['nocoupler', 'noforc'], value: 'nocoupler') # List of BLOM options -option('cgsmks', type: 'array', - choices: ['cgs', 'mks'], - description: 'Enable CGS or MKS unit', value: ['cgs']) +option('mks', type: 'boolean', + description: 'Enable MKS units', value: false) option('turbclo', type: 'array', choices: ['oneeq', 'twoeq', 'advection', 'isodif'], description: 'Turbulent closure options', value: ['oneeq', 'advection']) diff --git a/phy/convec.F b/phy/convec.F index d3c32388..9b68bfcb 100644 --- a/phy/convec.F +++ b/phy/convec.F @@ -1,5 +1,5 @@ ! ------------------------------------------------------------------------------ -! Copyright (C) 2009-2021 Mats Bentsen +! Copyright (C) 2009-2022 Mats Bentsen, Mehmet Ilicak ! ! This file is part of BLOM. ! diff --git a/phy/diapfl.F b/phy/diapfl.F index b228fd35..6d6badc5 100644 --- a/phy/diapfl.F +++ b/phy/diapfl.F @@ -1,5 +1,5 @@ ! ------------------------------------------------------------------------------ -! Copyright (C) 2009-2021 Mats Bentsen, Mehmet Ilicak +! Copyright (C) 2009-2022 Mats Bentsen, Mehmet Ilicak ! ! This file is part of BLOM. ! @@ -23,8 +23,7 @@ subroutine diapfl(m,n,mm,nn,k1m,k1n) c --- Diapycnal mixing c --- ------------------------------------------------------------------ c - use mod_constants, only: g, alpha0, spval, epsilp, onem - use mod_constants, only: L_mks2cgs + use mod_constants, only: g, alpha0, spval, epsilp, onem, L_mks2cgs use mod_time, only: delt1 use mod_xc use mod_vcoord, only: sigmar @@ -34,7 +33,6 @@ subroutine diapfl(m,n,mm,nn,k1m,k1n) use mod_state, only: u, v, dp, dpu, dpv, temp, saln, sigma, . p, pu, pv, kfpla use mod_diffusion, only: difdia - use mod_pointtest, only: itest, jtest, ptest use mod_forcing, only: ustarb use mod_utility, only: util1 use mod_checksum, only: csdiag, chksummsk diff --git a/phy/diffus.F b/phy/diffus.F index 7b0321e2..fc590fd7 100644 --- a/phy/diffus.F +++ b/phy/diffus.F @@ -1,5 +1,5 @@ ! ------------------------------------------------------------------------------ -! Copyright (C) 2006-2022 Mats Bentsen +! Copyright (C) 2006-2022 Mats Bentsen, Mehmet Ilicak ! ! This file is part of BLOM. ! diff --git a/phy/geoenv_file.F b/phy/geoenv_file.F index 4c26a982..c130fd50 100644 --- a/phy/geoenv_file.F +++ b/phy/geoenv_file.F @@ -1,5 +1,5 @@ ! ------------------------------------------------------------------------------ -! Copyright (C) 2015-2020 Mats Bentsen, Ping-Gin Chiu +! Copyright (C) 2015-2022 Mats Bentsen, Ping-Gin Chiu, Mehmet Ilicak ! ! This file is part of BLOM. ! diff --git a/phy/mod_advect.F b/phy/mod_advect.F index 6d6f9280..e91b894a 100644 --- a/phy/mod_advect.F +++ b/phy/mod_advect.F @@ -37,7 +37,6 @@ module mod_advect use mod_remap, only: remap_eitvel, remap_eitflx use mod_utility, only: utotm, vtotm, umax, vmax use mod_checksum, only: csdiag, chksummsk - use mod_pointtest, only: itest, jtest, ptest #ifdef TRC use mod_tracers, only: ntr, itrtke, itrgls, trc, uflxtr, vflxtr #endif diff --git a/phy/mod_cmnfld.F90 b/phy/mod_cmnfld.F90 index a6a0bd8f..4b9b8890 100644 --- a/phy/mod_cmnfld.F90 +++ b/phy/mod_cmnfld.F90 @@ -1,5 +1,5 @@ ! ------------------------------------------------------------------------------ -! Copyright (C) 2015-2022 Mats Bentsen +! Copyright (C) 2015-2022 Mats Bentsen, Mehmet Ilicak ! ! This file is part of BLOM. ! diff --git a/phy/mod_cmnfld_routines.F90 b/phy/mod_cmnfld_routines.F90 index 14ff2fbf..ef6f7cb1 100644 --- a/phy/mod_cmnfld_routines.F90 +++ b/phy/mod_cmnfld_routines.F90 @@ -1,5 +1,5 @@ ! ------------------------------------------------------------------------------ -! Copyright (C) 2015-2022 Mats Bentsen +! Copyright (C) 2015-2022 Mats Bentsen, Mehmet Ilicak ! ! This file is part of BLOM. ! @@ -24,7 +24,7 @@ module mod_cmnfld_routines ! ------------------------------------------------------------------------------ use mod_types, only: r8 - use mod_constants, only: g, alpha0, epsilp, onem, onecm, onemm + 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_grid, only: scuxi, scvyi @@ -420,7 +420,7 @@ subroutine cmnfld_nslope_isopyc_bulkml(m, n, mm, nn, k1m, k1n) integer, intent(in) :: m, n, mm, nn, k1m, k1n - real(r8) :: rho0, pm, rho_x, phi_x, bfsqm, rho_y, phi_y + real(r8) :: pm, rho_x, phi_x, bfsqm, rho_y, phi_y integer :: i, j, k, l, kn, kintr, kmax, knnsl ! ------------------------------------------------------------------------ @@ -454,8 +454,6 @@ subroutine cmnfld_nslope_isopyc_bulkml(m, n, mm, nn, k1m, k1n) ! bathymetry and in this case values are extrapolated from above. ! ------------------------------------------------------------------------ - rho0 = 1._r8/alpha0 - !$omp parallel do private(l, i, k, kmax, kn, kintr, knnsl, pm, rho_x, & !$omp phi_x, bfsqm) do j = - 1, jj + 2 @@ -653,7 +651,7 @@ subroutine cmnfld_nslope_cntiso_hybrid(m, n, mm, nn, k1m, k1n) integer, intent(in) :: m, n, mm, nn, k1m, k1n - real(r8) :: rho0, pm, rho_x, phi_x, bfsqm, rho_y, phi_y + real(r8) :: pm, rho_x, phi_x, bfsqm, rho_y, phi_y integer :: i, j, k, l, kn, kmax, knnsl ! ------------------------------------------------------------------------ @@ -687,8 +685,6 @@ subroutine cmnfld_nslope_cntiso_hybrid(m, n, mm, nn, k1m, k1n) ! bathymetry and in this case values are extrapolated from above. ! ------------------------------------------------------------------------ - rho0 = 1._r8/alpha0 - !$omp parallel do private(l, i, k, kmax, kn, knnsl, pm, rho_x, phi_x, bfsqm) do j = - 1, jj + 2 do l = 1, isu(j) diff --git a/phy/mod_constants.F90 b/phy/mod_constants.F90 index c5e85033..adc6ce9c 100644 --- a/phy/mod_constants.F90 +++ b/phy/mod_constants.F90 @@ -1,5 +1,5 @@ ! ------------------------------------------------------------------------------ -! Copyright (C) 2020-2021 Mats Bentsen +! Copyright (C) 2020-2022 Mats Bentsen, Mehmet Ilicak ! ! This file is part of BLOM. ! @@ -28,36 +28,7 @@ module mod_constants private -#if defined(CGS) - real(r8), parameter :: & - g = 980.6_r8, & ! Gravitational acceleration [cm s-2]. - rearth = 6.37122e8_r8, & ! Radius of the Earth [cm]. - spcifh = 3.99_r8, & ! Specific heat capacity of sea water - ! [J g-1 K-1]. - t0deg = 273.15_r8, & ! Zero degrees Celsius in Kelvin [K]. - alpha0 = 1._r8, & ! Reference value of specific volume - ! [cm3 g-1]. - pi = 3.1415926536_r8, & ! pi []. - radian = 57.295779513_r8, & ! 180/pi []. - epsilpl = 1.e-11_r8, & ! Small value for pressure*dx []. - epsilp = 1.e-11_r8, & ! Small value for pressure []. - epsilt = 1.e-11_r8, & ! Small value for time []. - epsilk = 1.e-11_r8, & ! Small value for kappa []. - spval = 1.e33_r8, & ! Large value []. - tenm = 980600._r8, & ! 10 m in units of pressure [g cm-1 s-2]. - onem = 98060._r8, & ! 1 m in units of pressure [g cm-1 s-2]. - tencm = 9806._r8, & ! 10 cm in units of pressure [g cm-1 s-2]. - onecm = 980.6_r8, & ! 1 cm in units of pressure [g cm-1 s-2]. - onemm = 98.06_r8, & ! 1 mm in units of pressure [g cm-1 s-2]. - onemu = .09806_r8, & ! 1 micrometer in units of pressure - ! [g cm-1 s-2]. - L_mks2cgs = 1.e2_r8, & ! length coefficient converting CGS to MKS - M_mks2cgs = 1.e3_r8, & ! mass coefficient converting CGS to MKS - P_mks2cgs = 1.e1_r8, & ! pressure coefficient converting CGS to MKS - R_mks2cgs = 1.e-3_r8, & ! rho coefficient converting CGS to MKS - g2kg = 1.e-3_r8 ! convert g to kg coeff -#endif -#if defined(MKS) +#ifdef MKS ! MKS unit real(r8), parameter :: & g = 9.806_r8, & ! Gravitational acceleration [m s-2]. @@ -67,10 +38,12 @@ module mod_constants t0deg = 273.15_r8, & ! Zero degrees Celsius in Kelvin [K]. alpha0 = 1.e-3_r8, & ! Reference value of specific volume ! [m3 kg-1]. + rho0 = 1.e3_r8, & ! Reference value of density [kg m-3]. pi = 3.1415926536_r8, & ! pi []. radian = 57.295779513_r8, & ! 180/pi []. - epsilpl = 1.e-14_r8, & ! Small value for pressure*dx []. + epsilpl = 1.e-14_r8, & ! Small value for pressure*dx []. epsilp = 1.e-12_r8, & ! Small value for pressure []. + epsilz = 1.e-9_r8, & ! Small value for depth []. epsilt = 1.e-11_r8, & ! Small value for time []. epsilk = 1.e-15_r8, & ! Small value for kappa []. spval = 1.e33_r8, & ! Large value []. @@ -81,17 +54,48 @@ module mod_constants onemm = 9.806_r8, & ! 1 mm in units of pressure [kg m-1 s-2]. onemu = .009806_r8, & ! 1 micrometer in units of pressure ! [kg m-1 s-2]. - L_mks2cgs = 1._r8, & ! length coefficient converting CGS to MKS - M_mks2cgs = 1._r8, & ! mass coefficient converting CGS to MKS - P_mks2cgs = 1._r8, & ! pressure coefficient converting CGS to MKS - R_mks2cgs = 1._r8, & ! rho coefficient converting CGS to MKS - g2kg = 1.e-3_r8 ! convert g to kg coeff + g2kg = 1.e-3_r8, & ! convert g to kg coeff + kg2g = 1.e3_r8, & ! convert kg to g coeff + L_mks2cgs = 1._r8, & ! length coefficient converting CGS to MKS + M_mks2cgs = 1._r8, & ! mass coefficient converting CGS to MKS + P_mks2cgs = 1._r8, & ! pressure coefficient converting CGS to MKS + R_mks2cgs = 1._r8 ! rho coefficient converting CGS to MKS +#else + real(r8), parameter :: & + g = 980.6_r8, & ! Gravitational acceleration [cm s-2]. + rearth = 6.37122e8_r8, & ! Radius of the Earth [cm]. + spcifh = 3.99_r8, & ! Specific heat capacity of sea water + ! [J g-1 K-1]. + t0deg = 273.15_r8, & ! Zero degrees Celsius in Kelvin [K]. + alpha0 = 1._r8, & ! Reference value of specific volume + ! [cm3 g-1]. + rho0 = 1._r8, & ! Reference value of density [kg m-3]. + pi = 3.1415926536_r8, & ! pi []. + radian = 57.295779513_r8, & ! 180/pi []. + epsilpl = 1.e-11_r8, & ! Small value for pressure*dx []. + epsilp = 1.e-11_r8, & ! Small value for pressure []. + epsilz = 1.e-11_r8, & ! Small value for depth []. + epsilt = 1.e-11_r8, & ! Small value for time []. + epsilk = 1.e-11_r8, & ! Small value for kappa []. + spval = 1.e33_r8, & ! Large value []. + tenm = 980600._r8, & ! 10 m in units of pressure [g cm-1 s-2]. + onem = 98060._r8, & ! 1 m in units of pressure [g cm-1 s-2]. + tencm = 9806._r8, & ! 10 cm in units of pressure [g cm-1 s-2]. + onecm = 980.6_r8, & ! 1 cm in units of pressure [g cm-1 s-2]. + onemm = 98.06_r8, & ! 1 mm in units of pressure [g cm-1 s-2]. + onemu = .09806_r8, & ! 1 micrometer in units of pressure + ! [g cm-1 s-2]. + g2kg = 1.e-3_r8, & ! convert g to kg coeff + kg2g = 1.e3_r8, & ! convert kg to g coeff + L_mks2cgs = 1.e2_r8, & ! length coefficient converting CGS to MKS + M_mks2cgs = 1.e3_r8, & ! mass coefficient converting CGS to MKS + P_mks2cgs = 1.e1_r8, & ! pressure coefficient converting CGS to MKS + R_mks2cgs = 1.e-3_r8 ! rho coefficient converting CGS to MKS #endif - - public :: g, rearth, spcifh, t0deg, alpha0, pi, radian, & - epsilpl, epsilp, epsilt, epsilk, spval, & - tenm, onem, tencm, onecm, onemm, onemu, L_mks2cgs, M_mks2cgs, & - P_mks2cgs, R_mks2cgs, g2kg + public :: g, rearth, spcifh, t0deg, alpha0, rho0, pi, radian, & + epsilpl, epsilp, epsilz, epsilt, epsilk, spval, & + tenm, onem, tencm, onecm, onemm, onemu, g2kg, kg2g, & + L_mks2cgs, M_mks2cgs, P_mks2cgs, R_mks2cgs end module mod_constants diff --git a/phy/mod_dia.F b/phy/mod_dia.F index 2099cc51..1edf48fd 100644 --- a/phy/mod_dia.F +++ b/phy/mod_dia.F @@ -26,8 +26,9 @@ module mod_dia use mod_time, only: date0, date, calendar, nstep, nstep_in_day, . nday_of_year, time, time0, baclin, dlt use mod_constants, only: g, spcifh, t0deg, alpha0, epsilp, spval, - . onem, onecm, onemm - use mod_constants, only: L_mks2cgs, M_mks2cgs, g2kg + . onem, onecm, onemm, + . L_mks2cgs, M_mks2cgs, P_mks2cgs, + . R_mks2cgs, g2kg use mod_xc use mod_nctools use netcdf, only : nf90_fill_double @@ -171,6 +172,14 @@ module mod_dia c --- Pressure thickness [g cm-1 s-2] of region for bottom salinity and c --- temperature diagnostics real, parameter :: dpbot=onem +c + real, parameter :: + . L_cgs2mks=1./L_mks2cgs, + . A_cgs2mks=1./(L_mks2cgs**2), + . V_cgs2mks=1./(L_mks2cgs**3), + . M_cgs2mks=1./M_mks2cgs, + . P_cgs2mks=1./P_mks2cgs, + . R_cgs2mks=1./R_mks2cgs c c --- Namelist integer, dimension(nphymax), save :: @@ -1749,12 +1758,6 @@ subroutine diaout(iogrp,m,n,mm,nn,k1m,k1n) real treps parameter (treps=1.e-14) #endif -c - real iM_mks2cgs, iL_mks2cgs, iL_mks2cgssq -c - iM_mks2cgs = 1.0 / (M_mks2cgs) - iL_mks2cgs = 1.0 / (L_mks2cgs) - iL_mks2cgssq = 1.0 / (L_mks2cgs**2) c c --- prepare output fields if (mnproc.eq.1) @@ -1887,7 +1890,7 @@ subroutine diaout(iogrp,m,n,mm,nn,k1m,k1n) enddo c$OMP END PARALLEL DO call xcsum(volgs(1),util1,ips) - volgs(1)=rnacc*(iL_mks2cgs**3)*volgs(1)/g + volgs(1)=rnacc*V_cgs2mks*volgs(1)/g endif if (MSC_SALNGA(iogrp).ne.0) then c$OMP PARALLEL DO PRIVATE(l,i) @@ -1956,7 +1959,7 @@ subroutine diaout(iogrp,m,n,mm,nn,k1m,k1n) tempga(1)=tempga(1)/massgs(1) endif if (MSC_MASSGS(iogrp).ne.0) then - massgs(1)=rnacc*iM_mks2cgs*massgs(1)/g + massgs(1)=rnacc*M_cgs2mks*massgs(1)/g endif if (MSC_SSSGA(iogrp).ne.0) then c$OMP PARALLEL DO PRIVATE(l,i) @@ -2011,30 +2014,30 @@ subroutine diaout(iogrp,m,n,mm,nn,k1m,k1n) c c --- compute log10 of diffusivities if (LYR_DIFDIA(iogrp).eq.2) - . call loglyr(ACC_DIFDIA(iogrp),'p',iL_mks2cgssq,0.) + . call loglyr(ACC_DIFDIA(iogrp),'p',A_cgs2mks,0.) if (LYR_DIFVMO(iogrp).eq.2) - . call loglyr(ACC_DIFVMO(iogrp),'p',iL_mks2cgssq,0.) + . call loglyr(ACC_DIFVMO(iogrp),'p',A_cgs2mks,0.) if (LYR_DIFVHO(iogrp).eq.2) - . call loglyr(ACC_DIFVHO(iogrp),'p',iL_mks2cgssq,0.) + . call loglyr(ACC_DIFVHO(iogrp),'p',A_cgs2mks,0.) if (LYR_DIFVSO(iogrp).eq.2) - . call loglyr(ACC_DIFVSO(iogrp),'p',iL_mks2cgssq,0.) + . call loglyr(ACC_DIFVSO(iogrp),'p',A_cgs2mks,0.) if (LYR_DIFINT(iogrp).eq.2) - . call loglyr(ACC_DIFINT(iogrp),'p',iL_mks2cgssq,0.) + . call loglyr(ACC_DIFINT(iogrp),'p',A_cgs2mks,0.) if (LYR_DIFISO(iogrp).eq.2) - . call loglyr(ACC_DIFISO(iogrp),'p',iL_mks2cgssq,0.) + . call loglyr(ACC_DIFISO(iogrp),'p',A_cgs2mks,0.) c if (LVL_DIFDIA(iogrp).eq.2) - . call loglvl(ACC_DIFDIALVL(iogrp),'p',iL_mks2cgssq*rnacc,0.) + . call loglvl(ACC_DIFDIALVL(iogrp),'p',A_cgs2mks*rnacc,0.) if (LVL_DIFVMO(iogrp).eq.2) - . call loglvl(ACC_DIFVMOLVL(iogrp),'p',iL_mks2cgssq*rnacc,0.) + . call loglvl(ACC_DIFVMOLVL(iogrp),'p',A_cgs2mks*rnacc,0.) if (LVL_DIFVHO(iogrp).eq.2) - . call loglvl(ACC_DIFVHOLVL(iogrp),'p',iL_mks2cgssq*rnacc,0.) + . call loglvl(ACC_DIFVHOLVL(iogrp),'p',A_cgs2mks*rnacc,0.) if (LVL_DIFVSO(iogrp).eq.2) - . call loglvl(ACC_DIFVSOLVL(iogrp),'p',iL_mks2cgssq*rnacc,0.) + . call loglvl(ACC_DIFVSOLVL(iogrp),'p',A_cgs2mks*rnacc,0.) if (LVL_DIFINT(iogrp).eq.2) - . call loglvl(ACC_DIFINTLVL(iogrp),'p',iL_mks2cgssq*rnacc,0.) + . call loglvl(ACC_DIFINTLVL(iogrp),'p',A_cgs2mks*rnacc,0.) if (LVL_DIFISO(iogrp).eq.2) - . call loglvl(ACC_DIFISOLVL(iogrp),'p',iL_mks2cgssq*rnacc,0.) + . call loglvl(ACC_DIFISOLVL(iogrp),'p',A_cgs2mks*rnacc,0.) c c --- mask sea floor of level fields call msklvl(ACC_BFSQLVL(iogrp),'p') @@ -2231,32 +2234,34 @@ subroutine diaout(iogrp,m,n,mm,nn,k1m,k1n) endif c c --- write 2d fields - call wrth2d(ACC_SIGMX(iogrp),H2D_SIGMX(iogrp),rnacc*M_mks2cgs, + call wrth2d(ACC_SIGMX(iogrp),H2D_SIGMX(iogrp),rnacc*R_cgs2mks, , 0.,cmpflg,ip,'p','sigmx','Mixed layer density',' ','kg m-3') c - call wrth2d(ACC_UB(iogrp),H2D_UB(iogrp),rnacc*iL_mks2cgs, + call wrth2d(ACC_UB(iogrp),H2D_UB(iogrp),rnacc*L_cgs2mks, . 0.,cmpflg,iuu,'u','ubaro','Barotropic velocity x-component', . ' ','m s-1') c - call wrth2d(ACC_VB(iogrp),H2D_VB(iogrp),rnacc*iL_mks2cgs, + call wrth2d(ACC_VB(iogrp),H2D_VB(iogrp),rnacc*L_cgs2mks, . 0.,cmpflg,ivv,'v','vbaro','Barotropic velocity y-component', . ' ','m s-1') c call wrth2d(ACC_PSRF(iogrp),H2D_PSRF(iogrp), - . rnacc*.1,0.,cmpflg,ip,'p','psrf','Surface pressure',' ','Pa') + . rnacc*P_cgs2mks,0.,cmpflg,ip,'p','psrf','Surface pressure', + . ' ','Pa') c call wrth2d(ACC_PBOT(iogrp),H2D_PBOT(iogrp), - . rnacc*.1,0.,cmpflg,ip,'p','pbot','Bottom pressure',' ','Pa') + . rnacc*P_cgs2mks,0.,cmpflg,ip,'p','pbot','Bottom pressure', + . ' ','Pa') c call wrth2d(ACC_SEALV(iogrp),H2D_SEALV(iogrp), - . -rnacc*iL_mks2cgs,0.,cmpflg,ip,'p','sealv','Sea level',' ','m') + . -rnacc*L_cgs2mks,0.,cmpflg,ip,'p','sealv','Sea level',' ','m') c call wrth2d(ACC_SLVSQ(iogrp),H2D_SLVSQ(iogrp), - . rnacc*iL_mks2cgssq,0.,cmpflg,ip, - . 'p','slvsq','Sea level squared',' ','m2') + . rnacc*A_cgs2mks,0.,cmpflg,ip,'p','slvsq','Sea level squared', + . ' ','m2') c call wrth2d(ACC_UTILH2D(1),H2D_BTMSTR(iogrp), - . rnacc*0.5*iM_mks2cgs*dlt/(g*baclin),0.,cmpflg,ip,'p','btmstr', + . rnacc*0.5*M_cgs2mks*dlt/(g*baclin),0.,cmpflg,ip,'p','btmstr', . 'Barotropic mass streamfunction',' ','kg s-1') c call wrth2d(ACC_HICE(iogrp),H2D_HICE(iogrp),1.,0., @@ -2277,10 +2282,10 @@ subroutine diaout(iogrp,m,n,mm,nn,k1m,k1n) call wrth2d(ACC_IAGE(iogrp),H2D_IAGE(iogrp),1.,0., . cmpflg,ip,'p','iage','Ice age',' ','day') c - call wrth2d(ACC_UICE(iogrp),H2D_UICE(iogrp),iL_mks2cgs,0., + call wrth2d(ACC_UICE(iogrp),H2D_UICE(iogrp),L_cgs2mks,0., . cmpflg,iuu,'u','uice','Ice velocity x-component',' ','m s-1') c - call wrth2d(ACC_VICE(iogrp),H2D_VICE(iogrp),iL_mks2cgs,0., + call wrth2d(ACC_VICE(iogrp),H2D_VICE(iogrp),L_cgs2mks,0., . cmpflg,ivv,'v','vice','Ice velocity y-component',' ','m s-1') c call wrth2d(ACC_SWA(iogrp),H2D_SWA(iogrp),rnacc,0., @@ -2325,16 +2330,16 @@ subroutine diaout(iogrp,m,n,mm,nn,k1m,k1n) . rnacc,0.,cmpflg,ip,'p','rfi','Frozen runoff',' ','kg m-2 s-1') c call wrth2d(ACC_SALFLX(iogrp),H2D_SALFLX(iogrp), - . -rnacc*iL_mks2cgs,0.,cmpflg,ip,'p','sflx', + . -rnacc*(g2kg*M_cgs2mks/A_cgs2mks),0.,cmpflg,ip,'p','sflx', . 'Salt flux received by ocean',' ','kg m-2 s-1') c call wrth2d(ACC_SALRLX(iogrp),H2D_SALRLX(iogrp), - . -rnacc*iL_mks2cgs,0.,cmpflg,ip,'p','srflx', + . -rnacc*(g2kg*M_cgs2mks/A_cgs2mks),0.,cmpflg,ip,'p','srflx', . 'Restoring salt flux received by ocean',' ','kg m-2 s-1') c call wrth2d(ACC_BRNFLX(iogrp),H2D_BRNFLX(iogrp), - . rnacc*(-iL_mks2cgs),0.,cmpflg,ip,'p','bflx','Brine flux',' ', - . 'kg m-2 s-1') + . rnacc*(-g2kg*M_cgs2mks/A_cgs2mks),0.,cmpflg,ip,'p','bflx', + . 'Brine flux',' ','kg m-2 s-1') c call wrth2d(ACC_ZTX(iogrp),H2D_ZTX(iogrp),rnacc,0., . cmpflg,iuu,'u','ztx','Wind stress x-component',' ','N m-2') @@ -2351,16 +2356,16 @@ subroutine diaout(iogrp,m,n,mm,nn,k1m,k1n) . 'Momentum flux received by ocean y-component',' ','N m-2') c call wrth2d(ACC_IDKEDT(iogrp),H2D_IDKEDT(iogrp), - . rnacc*iM_mks2cgs/alpha0,0.,cmpflg,ip,'p','idkedt', + . rnacc*M_cgs2mks/alpha0,0.,cmpflg,ip,'p','idkedt', . 'Mixed layer inertial kinetic energy tendency per unit area', . ' ','kg s-3') c call wrth2d(ACC_USTAR(iogrp),H2D_USTAR(iogrp), - . rnacc*iL_mks2cgs,0.,cmpflg,ip, - . 'p','ustar','Friction velocity',' ','m s-1') + . rnacc*L_cgs2mks,0.,cmpflg,ip,'p','ustar','Friction velocity', + . ' ','m s-1') c call wrth2d(ACC_USTAR3(iogrp),H2D_USTAR3(iogrp), - . rnacc*(iL_mks2cgs**3),0.,cmpflg,ip,'p','ustar3', + . rnacc*V_cgs2mks,0.,cmpflg,ip,'p','ustar3', . 'Friction velocity cubed',' ','m3 s-3') c call wrth2d(ACC_ABSWND(iogrp),H2D_ABSWND(iogrp), @@ -2368,37 +2373,37 @@ subroutine diaout(iogrp,m,n,mm,nn,k1m,k1n) . 'm s-1') c call wrth2d(ACC_MTKEUS(iogrp),H2D_MTKEUS(iogrp), - . rnacc*iM_mks2cgs/alpha0,0.,cmpflg,ip,'p','mtkeus', + . rnacc*M_cgs2mks/alpha0,0.,cmpflg,ip,'p','mtkeus', . 'Mixed layer turbulent kinetic energy tendency '// . 'per unit area related to friction velocity', . ' ','kg s-3') c call wrth2d(ACC_MTKENI(iogrp),H2D_MTKENI(iogrp), - . rnacc*iM_mks2cgs/alpha0,0.,cmpflg,ip,'p','mtkeni', + . rnacc*M_cgs2mks/alpha0,0.,cmpflg,ip,'p','mtkeni', . 'Mixed layer turbulent kinetic energy tendency '// . 'per unit area related to near inertial motions', . ' ','kg s-3') c call wrth2d(ACC_MTKEBF(iogrp),H2D_MTKEBF(iogrp), - . rnacc*iM_mks2cgs/alpha0,0.,cmpflg,ip,'p','mtkebf', + . rnacc*M_cgs2mks/alpha0,0.,cmpflg,ip,'p','mtkebf', . 'Mixed layer turbulent kinetic energy tendency '// . 'per unit area related to buoyancy forcing', . ' ','kg s-3') c call wrth2d(ACC_MTKERS(iogrp),H2D_MTKERS(iogrp), - . rnacc*iM_mks2cgs/alpha0,0.,cmpflg,ip,'p','mtkers', + . rnacc*M_cgs2mks/alpha0,0.,cmpflg,ip,'p','mtkers', . 'Mixed layer turbulent kinetic energy tendency '// . 'per unit area related to eddy restratification', . ' ','kg s-3') c call wrth2d(ACC_MTKEPE(iogrp),H2D_MTKEPE(iogrp), - . rnacc*iM_mks2cgs/alpha0,0.,cmpflg,ip,'p','mtkepe', + . rnacc*M_cgs2mks/alpha0,0.,cmpflg,ip,'p','mtkepe', . 'Mixed layer turbulent kinetic energy tendency '// . 'per unit area related to potential energy change', . ' ','kg s-3') c call wrth2d(ACC_MTKEKE(iogrp),H2D_MTKEKE(iogrp), - . rnacc*iM_mks2cgs/alpha0,0.,cmpflg,ip,'p','mtkeke', + . rnacc*M_cgs2mks/alpha0,0.,cmpflg,ip,'p','mtkeke', . 'Mixed layer turbulent kinetic energy tendency '// . 'per unit area related to kinetic energy change', . ' ','kg s-3') @@ -2416,23 +2421,23 @@ subroutine diaout(iogrp,m,n,mm,nn,k1m,k1n) . 1./onem,0.,cmpflg,ip,'p','maxmld','Maximum mixed layer depth', . ' ','m') c - call wrth2d(ACC_MLTS(iogrp),H2D_MLTS(iogrp),rnacc*iL_mks2cgs, + call wrth2d(ACC_MLTS(iogrp),H2D_MLTS(iogrp),rnacc*L_cgs2mks, . 0.,cmpflg,ip,'p','mlts', . 'Mixed layer thickness defined by sigma t',' ','m') c - call wrth2d(ACC_MLTSMN(iogrp),H2D_MLTSMN(iogrp),iL_mks2cgs, + call wrth2d(ACC_MLTSMN(iogrp),H2D_MLTSMN(iogrp),L_cgs2mks, . 0.,cmpflg,ip,'p','mltsmn', . 'Minimum mixed layer thickness defined by sigma t',' ','m') c - call wrth2d(ACC_MLTSMX(iogrp),H2D_MLTSMX(iogrp),iL_mks2cgs, + call wrth2d(ACC_MLTSMX(iogrp),H2D_MLTSMX(iogrp),L_cgs2mks, . 0.,cmpflg,ip,'p','mltsmx', . 'Maximum mixed layer thickness defined by sigma t',' ','m') c - call wrth2d(ACC_MLTSSQ(iogrp),H2D_MLTSSQ(iogrp), - . rnacc*iL_mks2cgssq,0.,cmpflg,ip,'p','mltssq', + call wrth2d(ACC_MLTSSQ(iogrp),H2D_MLTSSQ(iogrp),rnacc*A_cgs2mks, + . 0.,cmpflg,ip,'p','mltssq', . 'Mixed layer thickness squared defined by sigma t',' ','m2') c - call wrth2d(ACC_T20D(iogrp),H2D_T20D(iogrp),rnacc*iL_mks2cgs, + call wrth2d(ACC_T20D(iogrp),H2D_T20D(iogrp),rnacc*L_cgs2mks, . 0.,cmpflg,ip,'p','t20d','20C isoterm depth',' ','m') c call wrth2d(ACC_BRNPD(iogrp),H2D_BRNPD(iogrp),rnacc/onem, @@ -2459,12 +2464,11 @@ subroutine diaout(iogrp,m,n,mm,nn,k1m,k1n) . cmpflg,ip,'p','tbot','Bottom temperature',' ','degC') c c --- write 3d layer fields - call wrtlyr(ACC_DP(iogrp),LYR_DP(iogrp),rnacc*.1,0., + call wrtlyr(ACC_DP(iogrp),LYR_DP(iogrp),rnacc*P_cgs2mks,0., . cmpflg,ip,'p','dp','Layer pressure thickness',' ','Pa') c call wrtlyr(ACC_DZ(iogrp),LYR_DZ(iogrp), - . rnacc*iL_mks2cgs,0.,cmpflg,ip, - . 'p','dz','Layer thickness',' ','m') + . rnacc*L_cgs2mks,0.,cmpflg,ip,'p','dz','Layer thickness',' ','m') c call wrtlyr(ACC_TEMP(iogrp),LYR_TEMP(iogrp),1.,0., . cmpflg,ip,'p','temp','Temperature','Ocean temperature', @@ -2473,18 +2477,18 @@ subroutine diaout(iogrp,m,n,mm,nn,k1m,k1n) call wrtlyr(ACC_SALN(iogrp),LYR_SALN(iogrp),1.,0., . cmpflg,ip,'p','saln','Salinity','Ocean salinity','g kg-1') c - call wrtlyr(ACC_UVEL(iogrp),LYR_UVEL(iogrp),iL_mks2cgs, + call wrtlyr(ACC_UVEL(iogrp),LYR_UVEL(iogrp),L_cgs2mks, . 0.,cmpflg,iuu,'u','uvel','Velocity x-component',' ','m s-1') c - call wrtlyr(ACC_VVEL(iogrp),LYR_VVEL(iogrp),iL_mks2cgs, + call wrtlyr(ACC_VVEL(iogrp),LYR_VVEL(iogrp),L_cgs2mks, . 0.,cmpflg,ivv,'v','vvel','Velocity y-component',' ','m s-1') c call wrtlyr(ACC_UFLX(iogrp),LYR_UFLX(iogrp), - . rnacc*0.5*iM_mks2cgs/(g*baclin),0.,cmpflg,iuu,'u','uflx', + . rnacc*0.5*M_cgs2mks/(g*baclin),0.,cmpflg,iuu,'u','uflx', . 'Mass flux in x-direction',' ','kg s-1') c call wrtlyr(ACC_VFLX(iogrp),LYR_VFLX(iogrp), - . rnacc*0.5*iM_mks2cgs/(g*baclin),0.,cmpflg,ivv,'v','vflx', + . rnacc*0.5*M_cgs2mks/(g*baclin),0.,cmpflg,ivv,'v','vflx', . 'Mass flux in y-direction',' ','kg s-1') c call wrtlyr(ACC_UTFLX(iogrp),LYR_UTFLX(iogrp), @@ -2496,20 +2500,20 @@ subroutine diaout(iogrp,m,n,mm,nn,k1m,k1n) . 'Heat flux in y-direction',' ','W') c call wrtlyr(ACC_USFLX(iogrp),LYR_USFLX(iogrp), - . rnacc*0.5*g2kg*iM_mks2cgs/(g*baclin),0.,cmpflg,iuu,'u','usflx', + . rnacc*0.5*g2kg*M_cgs2mks/(g*baclin),0.,cmpflg,iuu,'u','usflx', . 'Salt flux in x-direction',' ','kg s-1') c call wrtlyr(ACC_VSFLX(iogrp),LYR_VSFLX(iogrp), - . rnacc*0.5*g2kg*iM_mks2cgs/(g*baclin),0.,cmpflg,ivv,'v','vsflx', + . rnacc*0.5*g2kg*M_cgs2mks/(g*baclin),0.,cmpflg,ivv,'v','vsflx', . 'Salt flux in y-direction',' ','kg s-1') c call wrtlyr(ACC_UMFLTD(iogrp),LYR_UMFLTD(iogrp), - . rnacc*0.5*iM_mks2cgs/(g*baclin),0.,cmpflg,iuu,'u','umfltd', + . rnacc*0.5*M_cgs2mks/(g*baclin),0.,cmpflg,iuu,'u','umfltd', . 'Mass flux due to thickness diffusion in x-direction',' ', . 'kg s-1') c call wrtlyr(ACC_VMFLTD(iogrp),LYR_VMFLTD(iogrp), - . rnacc*0.5*iM_mks2cgs/(g*baclin),0.,cmpflg,ivv,'v','vmfltd', + . rnacc*0.5*M_cgs2mks/(g*baclin),0.,cmpflg,ivv,'v','vmfltd', . 'Mass flux due to thickness diffusion in y-direction',' ', . 'kg s-1') c @@ -2534,31 +2538,31 @@ subroutine diaout(iogrp,m,n,mm,nn,k1m,k1n) . 'W') c call wrtlyr(ACC_USFLTD(iogrp),LYR_USFLTD(iogrp), - . rnacc*0.5*g2kg*iM_mks2cgs/(g*baclin),0.,cmpflg,iuu,'u','usfltd', + . rnacc*0.5*g2kg*M_cgs2mks/(g*baclin),0.,cmpflg,iuu,'u','usfltd', . 'Salt flux due to thickness diffusion in x-direction',' ', . 'kg s-1') c call wrtlyr(ACC_VSFLTD(iogrp),LYR_VSFLTD(iogrp), - . rnacc*0.5*g2kg*iM_mks2cgs/(g*baclin),0.,cmpflg,ivv,'v','vsfltd', + . rnacc*0.5*g2kg*M_cgs2mks/(g*baclin),0.,cmpflg,ivv,'v','vsfltd', . 'Salt flux due to thickness diffusion in y-direction',' ', . 'kg s-1') c call wrtlyr(ACC_USFLLD(iogrp),LYR_USFLLD(iogrp), - . rnacc*0.5*g2kg*iM_mks2cgs/(g*baclin),0.,cmpflg,iuu,'u','usflld', + . rnacc*0.5*g2kg*M_cgs2mks/(g*baclin),0.,cmpflg,iuu,'u','usflld', . 'Salt flux due to lateral diffusion in x-direction',' ', . 'kg s-1') c call wrtlyr(ACC_VSFLLD(iogrp),LYR_VSFLLD(iogrp), - . rnacc*0.5*g2kg*iM_mks2cgs/(g*baclin),0.,cmpflg,ivv,'v','vsflld', + . rnacc*0.5*g2kg*M_cgs2mks/(g*baclin),0.,cmpflg,ivv,'v','vsflld', . 'Salt flux due to lateral diffusion in y-direction',' ', . 'kg s-1') c call wrtlyr(ACC_WFLX(iogrp),LYR_WFLX(iogrp), - . rnacc*0.5*iM_mks2cgs/(g*baclin),0.,cmpflg,ip,'p','wflx', + . rnacc*0.5*M_cgs2mks/(g*baclin),0.,cmpflg,ip,'p','wflx', . 'Vertical mass flux',' ','kg s-1') c call wrtlyr(ACC_WFLX2(iogrp),LYR_WFLX2(iogrp), - . rnacc*(0.5*iM_mks2cgs/(g*baclin))**2,0.,cmpflg,ip,'p','wflx2', + . rnacc*(0.5*M_cgs2mks/(g*baclin))**2,0.,cmpflg,ip,'p','wflx2', . 'Vertical mass flux squared',' ','kg2 s-2') c call wrtlyr(ACC_BFSQ(iogrp),LYR_BFSQ(iogrp),1.,0., @@ -2574,7 +2578,7 @@ subroutine diaout(iogrp,m,n,mm,nn,k1m,k1n) . 0.,cmpflg,ip,'p','difint','Layer interface diffusivity', . ' ','log10(m2 s-1)') else - call wrtlyr(ACC_DIFINT(iogrp),LYR_DIFINT(iogrp),iL_mks2cgssq, + call wrtlyr(ACC_DIFINT(iogrp),LYR_DIFINT(iogrp),A_cgs2mks, . 0.,cmpflg,ip,'p','difint','Layer interface diffusivity', . ' ','m2 s-1') endif @@ -2584,7 +2588,7 @@ subroutine diaout(iogrp,m,n,mm,nn,k1m,k1n) . 0.,cmpflg,ip,'p','difiso','Isopycnal diffusivity',' ', . 'log10(m2 s-1)') else - call wrtlyr(ACC_DIFISO(iogrp),LYR_DIFISO(iogrp),iL_mks2cgssq, + call wrtlyr(ACC_DIFISO(iogrp),LYR_DIFISO(iogrp),A_cgs2mks, . 0.,cmpflg,ip,'p','difiso','Isopycnal diffusivity',' ', . 'm2 s-1') endif @@ -2594,7 +2598,7 @@ subroutine diaout(iogrp,m,n,mm,nn,k1m,k1n) . 0.,cmpflg,ip,'p','difdia','Vertical diffusivity',' ', . 'log10(m2 s-1)') else - call wrtlyr(ACC_DIFDIA(iogrp),LYR_DIFDIA(iogrp),iL_mks2cgssq, + call wrtlyr(ACC_DIFDIA(iogrp),LYR_DIFDIA(iogrp),A_cgs2mks, . 0.,cmpflg,ip,'p','difdia','Vertical diffusivity',' ', . 'm2 s-1') endif @@ -2604,7 +2608,7 @@ subroutine diaout(iogrp,m,n,mm,nn,k1m,k1n) . 0.,cmpflg,ip,'p','difvmo','Vertical momentum diffusivity',' ', . 'log10(m2 s-1)') else - call wrtlyr(ACC_DIFVMO(iogrp),LYR_DIFVMO(iogrp),iL_mks2cgssq, + call wrtlyr(ACC_DIFVMO(iogrp),LYR_DIFVMO(iogrp),A_cgs2mks, . 0.,cmpflg,ip,'p','difvmo','Vertical momentum diffusivity',' ', . 'm2 s-1') endif @@ -2614,7 +2618,7 @@ subroutine diaout(iogrp,m,n,mm,nn,k1m,k1n) . 0.,cmpflg,ip,'p','difvho','Vertical heat diffusivity',' ', . 'log10(m2 s-1)') else - call wrtlyr(ACC_DIFVHO(iogrp),LYR_DIFVHO(iogrp),iL_mks2cgssq, + call wrtlyr(ACC_DIFVHO(iogrp),LYR_DIFVHO(iogrp),A_cgs2mks, . 0.,cmpflg,ip,'p','difvho','Vertical heat diffusivity',' ', . 'm2 s-1') endif @@ -2624,24 +2628,24 @@ subroutine diaout(iogrp,m,n,mm,nn,k1m,k1n) . 0.,cmpflg,ip,'p','difvso','Vertical salt diffusivity',' ', . 'log10(m2 s-1)') else - call wrtlyr(ACC_DIFVSO(iogrp),LYR_DIFVSO(iogrp),iL_mks2cgssq, + call wrtlyr(ACC_DIFVSO(iogrp),LYR_DIFVSO(iogrp),A_cgs2mks, . 0.,cmpflg,ip,'p','difvso','Vertical salt diffusivity',' ', . 'm2 s-1') endif c #if defined(TRC) && defined(TKE) - call wrtlyr(ACC_TKE(iogrp),LYR_TKE(iogrp),iL_mks2cgssq,0., + call wrtlyr(ACC_TKE(iogrp),LYR_TKE(iogrp),A_cgs2mks,0., . cmpflg,ip,'p','tke','TKE','Turbulent kinetic energy', . 'm2 s-2') c - call wrtlyr(ACC_GLS_PSI(iogrp),LYR_GLS_PSI(iogrp),iL_mks2cgssq,0., + call wrtlyr(ACC_GLS_PSI(iogrp),LYR_GLS_PSI(iogrp),A_cgs2mks,0., . cmpflg,ip,'p','gls_psi','GLS_PSI','Generic length scale', . 'm2 s-3') c #endif c --- Write 3d depth fields call wrtlvl(ACC_DZLVL(iogrp),LVL_DZ(iogrp), - . rnacc*iL_mks2cgs,0.,cmpflg,ip, + . rnacc*L_cgs2mks,0.,cmpflg,ip, . 'p','dzlvl','Layer thickness',' ','m') c call wrtlvl(ACC_TEMPLVL(iogrp),LVL_TEMP(iogrp), @@ -2653,19 +2657,19 @@ subroutine diaout(iogrp,m,n,mm,nn,k1m,k1n) . 'Ocean salinity','g kg-1') c call wrtlvl(ACC_UVELLVL(iogrp),LVL_UVEL(iogrp), - . rnacc*iL_mks2cgs,0.,cmpflg,iuu,'u','uvellvl', + . rnacc*L_cgs2mks,0.,cmpflg,iuu,'u','uvellvl', . 'Velocity x-component',' ','m s-1') c call wrtlvl(ACC_VVELLVL(iogrp),LVL_VVEL(iogrp), - . rnacc*iL_mks2cgs,0.,cmpflg,ivv,'v','vvellvl', + . rnacc*L_cgs2mks,0.,cmpflg,ivv,'v','vvellvl', . 'Velocity y-component',' ','m s-1') c call wrtlvl(ACC_UFLXLVL(iogrp),LVL_UFLX(iogrp), - . rnacc*0.5*iM_mks2cgs/(g*baclin),0.,cmpflg,iuu,'u','uflxlvl', + . rnacc*0.5*M_cgs2mks/(g*baclin),0.,cmpflg,iuu,'u','uflxlvl', . 'Mass flux in x-direction',' ','kg s-1') c call wrtlvl(ACC_VFLXLVL(iogrp),LVL_VFLX(iogrp), - . rnacc*0.5*iM_mks2cgs/(g*baclin),0.,cmpflg,ivv,'v','vflxlvl', + . rnacc*0.5*M_cgs2mks/(g*baclin),0.,cmpflg,ivv,'v','vflxlvl', . 'Mass flux in y-direction',' ','kg s-1') c call wrtlvl(ACC_UTFLXLVL(iogrp),LVL_UTFLX(iogrp), @@ -2677,20 +2681,20 @@ subroutine diaout(iogrp,m,n,mm,nn,k1m,k1n) . 'Heat flux in y-direction',' ','W') c call wrtlvl(ACC_USFLXLVL(iogrp),LVL_USFLX(iogrp), - . rnacc*0.5*g2kg*iM_mks2cgs/(g*baclin),0.,cmpflg,iuu, - . 'u','usflxlvl','Salt flux in x-direction',' ','kg s-1') + . rnacc*0.5*g2kg*M_cgs2mks/(g*baclin),0.,cmpflg,iuu,'u', + . 'usflxlvl','Salt flux in x-direction',' ','kg s-1') c call wrtlvl(ACC_VSFLXLVL(iogrp),LVL_VSFLX(iogrp), - . rnacc*0.5*g2kg*iM_mks2cgs/(g*baclin),0.,cmpflg,ivv, - . 'v','vsflxlvl','Salt flux in y-direction',' ','kg s-1') + . rnacc*0.5*g2kg*M_cgs2mks/(g*baclin),0.,cmpflg,ivv,'v', + . 'vsflxlvl','Salt flux in y-direction',' ','kg s-1') c call wrtlvl(ACC_UMFLTDLVL(iogrp),LVL_UMFLTD(iogrp), - . rnacc*0.5*iM_mks2cgs/(g*baclin),0.,cmpflg,iuu,'u','umfltdlvl', + . rnacc*0.5*M_cgs2mks/(g*baclin),0.,cmpflg,iuu,'u','umfltdlvl', . 'Mass flux due to thickness diffusion in x-direction',' ', . 'kg s-1') c call wrtlvl(ACC_VMFLTDLVL(iogrp),LVL_VMFLTD(iogrp), - . rnacc*0.5*iM_mks2cgs/(g*baclin),0.,cmpflg,ivv,'v','vmfltdlvl', + . rnacc*0.5*M_cgs2mks/(g*baclin),0.,cmpflg,ivv,'v','vmfltdlvl', . 'Mass flux due to thickness diffusion in y-direction',' ', . 'kg s-1') c @@ -2715,35 +2719,35 @@ subroutine diaout(iogrp,m,n,mm,nn,k1m,k1n) . 'W') c call wrtlvl(ACC_USFLTDLVL(iogrp),LVL_USFLTD(iogrp), - . rnacc*0.5*g2kg*iM_mks2cgs/(g*baclin),0.,cmpflg,iuu, + . rnacc*0.5*g2kg*M_cgs2mks/(g*baclin),0.,cmpflg,iuu, . 'u','usfltdlvl', . 'Salt flux due to thickness diffusion in x-direction',' ', . 'kg s-1') c call wrtlvl(ACC_VSFLTDLVL(iogrp),LVL_VSFLTD(iogrp), - . rnacc*0.5*g2kg*iM_mks2cgs/(g*baclin),0.,cmpflg,ivv, + . rnacc*0.5*g2kg*M_cgs2mks/(g*baclin),0.,cmpflg,ivv, . 'v','vsfltdlvl', . 'Salt flux due to thickness diffusion in y-direction',' ', . 'kg s-1') c call wrtlvl(ACC_USFLLDLVL(iogrp),LVL_USFLLD(iogrp), - . rnacc*0.5*g2kg*iM_mks2cgs/(g*baclin),0.,cmpflg,iuu, + . rnacc*0.5*g2kg*M_cgs2mks/(g*baclin),0.,cmpflg,iuu, . 'u','usflldlvl', . 'Salt flux due to lateral diffusion in x-direction',' ', . 'kg s-1') c call wrtlvl(ACC_VSFLLDLVL(iogrp),LVL_VSFLLD(iogrp), - . rnacc*0.5*g2kg*iM_mks2cgs/(g*baclin),0.,cmpflg,ivv, + . rnacc*0.5*g2kg*M_cgs2mks/(g*baclin),0.,cmpflg,ivv, . 'v','vsflldlvl', . 'Salt flux due to lateral diffusion in y-direction',' ', . 'kg s-1') c call wrtlvl(ACC_WFLXLVL(iogrp),LVL_WFLX(iogrp), - . rnacc*0.5*iM_mks2cgs/(g*baclin),0.,cmpflg,ip,'p','wflxlvl', + . rnacc*0.5*M_cgs2mks/(g*baclin),0.,cmpflg,ip,'p','wflxlvl', . 'Vertical mass flux',' ','kg s-1') c call wrtlvl(ACC_WFLX2LVL(iogrp),LVL_WFLX2(iogrp), - . rnacc*(0.5*iM_mks2cgs/(g*baclin))**2,0.,cmpflg,ip,'p','wflx2lvl', + . rnacc*(0.5*M_cgs2mks/(g*baclin))**2,0.,cmpflg,ip,'p','wflx2lvl', . 'Vertical mass flux squared',' ','kg2 s-2') c call wrtlvl(ACC_BFSQLVL(iogrp),LVL_BFSQ(iogrp), @@ -2760,9 +2764,8 @@ subroutine diaout(iogrp,m,n,mm,nn,k1m,k1n) . ' ','log10(m2 s-1)') else call wrtlvl(ACC_DIFINTLVL(iogrp),LVL_DIFINT(iogrp), - . iL_mks2cgssq*rnacc, - . 0.,cmpflg,ip,'p','difintlvl','Layer interface diffusivity', - . ' ','m2 s-1') + . A_cgs2mks*rnacc,0.,cmpflg,ip,'p','difintlvl', + . 'Layer interface diffusivity',' ','m2 s-1') endif c if (LVL_DIFISO(iogrp).eq.2) then @@ -2771,9 +2774,8 @@ subroutine diaout(iogrp,m,n,mm,nn,k1m,k1n) . 'log10(m2 s-1)') else call wrtlvl(ACC_DIFISOLVL(iogrp),LVL_DIFISO(iogrp), - . iL_mks2cgssq*rnacc, - . 0.,cmpflg,ip,'p','difisolvl','Isopycnal diffusivity',' ', - . 'm2 s-1') + . A_cgs2mks*rnacc,0.,cmpflg,ip,'p','difisolvl', + . 'Isopycnal diffusivity',' ','m2 s-1') endif c if (LVL_DIFDIA(iogrp).eq.2) then @@ -2782,9 +2784,8 @@ subroutine diaout(iogrp,m,n,mm,nn,k1m,k1n) . 'log10(m2 s-1)') else call wrtlvl(ACC_DIFDIALVL(iogrp),LVL_DIFDIA(iogrp), - . iL_mks2cgssq*rnacc, - . 0.,cmpflg,ip,'p','difdialvl','Vertical diffusivity',' ', - . 'm2 s-1') + . A_cgs2mks*rnacc,0.,cmpflg,ip,'p','difdialvl', + . 'Vertical diffusivity',' ','m2 s-1') endif c if (LVL_DIFVMO(iogrp).eq.2) then @@ -2793,9 +2794,8 @@ subroutine diaout(iogrp,m,n,mm,nn,k1m,k1n) . ' ','log10(m2 s-1)') else call wrtlvl(ACC_DIFVMOLVL(iogrp),LVL_DIFVMO(iogrp), - . iL_mks2cgssq*rnacc, - . 0.,cmpflg,ip,'p','difvmolvl','Vertical momentum diffusivity', - . ' ','m2 s-1') + . A_cgs2mks*rnacc,0.,cmpflg,ip,'p','difvmolvl', + . 'Vertical momentum diffusivity',' ','m2 s-1') endif c if (LVL_DIFVHO(iogrp).eq.2) then @@ -2804,9 +2804,8 @@ subroutine diaout(iogrp,m,n,mm,nn,k1m,k1n) . ' ','log10(m2 s-1)') else call wrtlvl(ACC_DIFVHOLVL(iogrp),LVL_DIFVHO(iogrp), - . iL_mks2cgssq*rnacc, - . 0.,cmpflg,ip,'p','difvholvl','Vertical heat diffusivity', - . ' ','m2 s-1') + . A_cgs2mks*rnacc,0.,cmpflg,ip,'p','difvholvl', + . 'Vertical heat diffusivity',' ','m2 s-1') endif c if (LVL_DIFVSO(iogrp).eq.2) then @@ -2815,20 +2814,18 @@ subroutine diaout(iogrp,m,n,mm,nn,k1m,k1n) . ' ','log10(m2 s-1)') else call wrtlvl(ACC_DIFVSOLVL(iogrp),LVL_DIFVSO(iogrp), - . iL_mks2cgssq*rnacc, - . 0.,cmpflg,ip,'p','difvsolvl','Vertical salt diffusivity', - . ' ','m2 s-1') + . A_cgs2mks*rnacc,0.,cmpflg,ip,'p','difvsolvl', + . 'Vertical salt diffusivity',' ','m2 s-1') endif c #if defined(TRC) && defined(TKE) - call wrtlvl(ACC_TKELVL(iogrp),LVL_TKE(iogrp),rnacc*iL_mks2cgssq, + call wrtlvl(ACC_TKELVL(iogrp),LVL_TKE(iogrp),rnacc*A_cgs2mks, . 0.,cmpflg,ip,'p','tkelvl','Turbulent kinetic energy',' ', . 'm2 s-2') c call wrtlvl(ACC_GLS_PSILVL(iogrp),LVL_GLS_PSI(iogrp), - . rnacc*iL_mks2cgssq, - . 0.,cmpflg,ip,'p','gls_psilvl','Generic length scale',' ', - . 'm2 s-3') + . rnacc*A_cgs2mks,0.,cmpflg,ip,'p','gls_psilvl', + . 'Generic length scale',' ','m2 s-3') c #endif c @@ -2939,8 +2936,8 @@ subroutine diaout(iogrp,m,n,mm,nn,k1m,k1n) call inilyr(ACC_UTILLYR(1),'p',0.) call acclyr(ACC_UTILLYR,dp(1-nbdy,1-nbdy,k1m),tmp3d,0,'p') call wrtlyr(ACC_UTILLYR(1), - . max(LYR_IDLAGE(iogrp),LYR_TRC(iogrp)),1.,0.,cmpflg,ip,'p', - . 'dp_trc','Layer pressure thickness',' ','Pa') + . max(LYR_IDLAGE(iogrp),LYR_TRC(iogrp)),P_cgs2mks,0.,cmpflg,ip, + . 'p','dp_trc','Layer pressure thickness',' ','Pa') endif # ifdef IDLAGE c @@ -3100,9 +3097,6 @@ subroutine diasec(iogrp) real, dimension(itdm,jtdm) :: uflx_cumt,vflx_cumt . ,uflx_cum350t,vflx_cum350t real*8 :: volu,volv - real iM_mks2cgs -c - iM_mks2cgs = 1.0 / (M_mks2cgs) c c --- ------------------------------------------------------------------ c --- read section information @@ -3157,14 +3151,14 @@ subroutine diasec(iogrp) do i=max(1,ifu(j,l)),min(ii,ilu(j,l)) uflx_cum(i,j)=uflx_cum(i,j)+ . phylvl(i,j,k,ACC_UFLXLVL(iogrp)) - . *0.5*iM_mks2cgs/(g*baclin*nacc_phy(iogrp)) + . *0.5*M_cgs2mks/(g*baclin*nacc_phy(iogrp)) enddo enddo do l=1,isv(j) do i=max(1,ifv(j,l)),min(ii,ilv(j,l)) vflx_cum(i,j)=vflx_cum(i,j)+ . phylvl(i,j,k,ACC_VFLXLVL(iogrp)) - . *0.5*iM_mks2cgs/(g*baclin*nacc_phy(iogrp)) + . *0.5*M_cgs2mks/(g*baclin*nacc_phy(iogrp)) enddo enddo c @@ -3254,12 +3248,8 @@ subroutine diamer(iogrp) character :: c20*20 c logical :: iniflg=.true. -c - real iM_mks2cgs c save nind,iind,jind,oflg,uflg,vflg,depthst,iniflg,ocn_nreg -c - iM_mks2cgs = 1.0 / (M_mks2cgs) c if (iniflg) then c @@ -3397,17 +3387,17 @@ subroutine diamer(iogrp) if (ACC_MSFLX(iogrp).eq.0) exit ACC_UIND=ACC_USFLX(iogrp) ACC_VIND=ACC_VSFLX(iogrp) - r=0.5*g2kg*iM_mks2cgs/(g*baclin*nacc_phy(iogrp)) + r=0.5*g2kg*M_cgs2mks/(g*baclin*nacc_phy(iogrp)) elseif (nfld.eq.5) then if (ACC_MSFTD(iogrp).eq.0) exit ACC_UIND=ACC_USFLTD(iogrp) ACC_VIND=ACC_VSFLTD(iogrp) - r=0.5*g2kg*iM_mks2cgs/(g*baclin*nacc_phy(iogrp)) + r=0.5*g2kg*M_cgs2mks/(g*baclin*nacc_phy(iogrp)) elseif (nfld.eq.6) then if (ACC_MSFLD(iogrp).eq.0) exit ACC_UIND=ACC_USFLLD(iogrp) ACC_VIND=ACC_VSFLLD(iogrp) - r=0.5*g2kg*iM_mks2cgs/(g*baclin*nacc_phy(iogrp)) + r=0.5*g2kg*M_cgs2mks/(g*baclin*nacc_phy(iogrp)) else write(lp,*) 'field index out of range' call xchalt('(diamer)') @@ -3568,7 +3558,7 @@ subroutine diamer(iogrp) enddo c$OMP END PARALLEL DO c - r=0.5*iM_mks2cgs/(g*baclin*nacc_phy(iogrp)) + r=0.5*M_cgs2mks/(g*baclin*nacc_phy(iogrp)) c do nfld=1,2 c @@ -3733,7 +3723,7 @@ subroutine diamer(iogrp) enddo endif c - r=0.5*iM_mks2cgs/(g*baclin*nacc_phy(iogrp)) + r=0.5*M_cgs2mks/(g*baclin*nacc_phy(iogrp)) c do nfld=1,2 c diff --git a/phy/mod_difest.F b/phy/mod_difest.F index 07e176b8..2f3add01 100644 --- a/phy/mod_difest.F +++ b/phy/mod_difest.F @@ -20,8 +20,8 @@ module mod_difest c use mod_types, only: r8 - use mod_constants, only: g, alpha0, pi, epsilp, spval, onem, onecm - use mod_constants, only: L_mks2cgs, M_mks2cgs, R_mks2cgs + use mod_constants, only: g, alpha0, pi, epsilp, spval, onem, + . onecm, L_mks2cgs, M_mks2cgs, R_mks2cgs use mod_time, only: delt1 use mod_xc use mod_vcoord, only: vcoord_type_tag, isopyc_bulkml, @@ -64,7 +64,6 @@ module mod_difest use CVMix_kpp, only : CVMix_put_kpp use CVMix_kpp, only : CVMix_init_kpp use CVMix_put_get, only : CVMix_put - use mod_pointtest, only: itest, jtest, ptest #if defined(TRC) && defined(TKE) use mod_tracers, only: itrtke, itrgls, trc use mod_tke, only: gls_cmu0, Pr_t, tke_min, gls_psi_min, gls_p, @@ -97,6 +96,12 @@ module mod_difest type(CVMix_kpp_params_type) :: KPP_params c type(CVMix_kpp_params_type), pointer :: CVmix_kpp_params_in c type(CVMix_kpp_params_type) :: CVmix_kpp_params_in +c + real, parameter :: + . iL_mks2cgs = 1./L_mks2cgs, + . iM_mks2cgs = 1./M_mks2cgs, + . A_mks2cgs = L_mks2cgs**2, + . A_cgs2mks = 1./(L_mks2cgs*L_mks2cgs) c c --- parameters: c --- iidtyp - type of interface and isopycnal diffusivities. If @@ -158,10 +163,10 @@ module mod_difest c --- non-isopycnic layers [g/cm/s**2]. c --- dpnbav - thickness of region near the bottom used to estimate c --- bottom Brunt-Vaisala frequency [g/cm/s**2]. -c --- cpsemin - Zonal eddy phase speed minus zonal barotropic velocity -c --- with a lower bound of -20 cm s-1. -c --- urmsemin- Eddy mixing suppresion factor of -c --- RMS eddy velocity is set to 5 cm s-1 +c --- cpsemin - Lower bound of zonal eddy phase speed minus zonal +c --- barotropic velocity [cm/s]. +c --- urmsemin- Lower bound of absolute value of RMS eddy velocity +c --- [cm/s]. integer iidtyp,bdmldp,tdmflg,iwdflg real dptmin,dpbmin,drhomn,thkdff,temdff,nu0,nus0,nug0,drho0,nuls0, . iwdfac,dmxeff,tdmq,tdmls0,tdmls1,tdclat,tddlat,tkepls,niwls, @@ -171,18 +176,18 @@ module mod_difest parameter (iidtyp=2,bdmldp=1,tdmflg=1,iwdflg=1,dptmin=onem, . dpbmin=onecm,drhomn=6.e-3*R_mks2cgs, . thkdff=5.e-3*L_mks2cgs,temdff=3.5e-3*L_mks2cgs, - . nu0=1.e-5*L_mks2cgs**2, - . nus0=5.e-3*L_mks2cgs**2, - . nug0=2.5e-1*L_mks2cgs**2, + . nu0=1.e-5*A_mks2cgs, + . nus0=5.e-3*A_mks2cgs, + . nug0=2.5e-1*A_mks2cgs, . drho0=6.e-3*R_mks2cgs, - . nuls0=5.e-2*L_mks2cgs**2,iwdfac=.06, + . nuls0=5.e-2*A_mks2cgs,iwdfac=.06, . dmxeff=.2,tdmq=1./3.,tdmls0=500.*onem, . tdmls1=100.*onem,tdclat=74.5,tddlat=3., . tkepls=20.*onem,niwls=300.*onem,cori30=7.2722e-5, - . bvf0=5.24e-3,nubmin=1.e-6*L_mks2cgs**2, + . bvf0=5.24e-3,nubmin=1.e-6*A_mks2cgs, . dpgc=300.*onem,dpgrav=100.*onem,dpdiav=100.*onem, . dpddav=10.*onem,dpnbav=250.*onem,ustmin=.001*L_mks2cgs, - . kappa=.4,bfeps=1.e-16*L_mks2cgs**2,sleps=.1,zetas=-1., + . kappa=.4,bfeps=1.e-16*A_mks2cgs,sleps=.1,zetas=-1., . cpsemin=-0.2*L_mks2cgs,urmsemin=0.05*L_mks2cgs, . as=-28.86,cs=98.96,minOBLdepth=1.0) c @@ -223,10 +228,6 @@ subroutine inivar_difest end subroutine inivar_difest c subroutine init_difest -c - real iL_mks2cgs, iL_mks2cgssq - iL_mks2cgs = 1.0 / (L_mks2cgs) - iL_mks2cgssq = 1.0 / (L_mks2cgs*L_mks2cgs) c c --- ------------------------------------------------------------------ c --- Initialize CVmix variables. @@ -244,8 +245,8 @@ subroutine init_difest c --- ------ convection routine based on N2 not rho c --- ------ if lBruntVaisala is TRUE, otherwise based on rho c --- ------ convert nuls0 to m2/s - call CVMix_init_conv(convect_diff=20.0*nuls0*iL_mks2cgssq, - . convect_visc=20.0*nuls0*iL_mks2cgssq, + call CVMix_init_conv(convect_diff=20.0*nuls0*A_cgs2mks, + . convect_visc=20.0*nuls0*A_cgs2mks, . lBruntVaisala=.true., . BVsqr_convect=0.0) call CVMix_put(CVMix_glb_params,'max_nlev',kk) @@ -253,7 +254,7 @@ subroutine init_difest call CVMix_put(CVMix_glb_params,'FreshWaterDensity',1000.0) call CVMix_put(CVMix_glb_params,'SaltWaterDensity',1025.0) call cvmix_init_shear(mix_scheme='KPP', - . KPP_nu_zero=nus0*iL_mks2cgssq, + . KPP_nu_zero=nus0*A_cgs2mks, . KPP_Ri_zero=ri0, . KPP_exp=3.0) ! CVmix_kpp_params_in => CVmix_kpp_params_user @@ -517,7 +518,7 @@ subroutine difest_common_iso(m,n,mm,nn,k1m,k1n) c --- ------- Local gradient Richardson number. rig(i,j,k)=alpha0*alpha0 . *max(drhomn,drhol(i,j,k))*dp(i,j,kn) - . /max(1.e-13*L_mks2cgs**2,du2l(i,j,k)) + . /max(1.e-13*A_mks2cgs,du2l(i,j,k)) c endif enddo @@ -639,8 +640,8 @@ subroutine difest_common_hyb(m,n,mm,nn,k1m,k1n) . +(mskv(i,j,k)*dv2(i,j,k)+mskv(i,j+1,k)*dv2(i,j+1,k)) . /max(1,mskv(i,j,k)+mskv(i,j+1,k)) dz=.5*(dp(i,j,kn-1)+dp(i,j,kn))*alpha0/g - rig(i,j,k)=max(0.,bfsqi(i,j,k)*dz*dz)/ - . max(1.e-13*L_mks2cgs**2,q) + rig(i,j,k)=max(0.,bfsqi(i,j,k)*dz*dz) + . /max(1.e-13*A_mks2cgs,q) else rig(i,j,k)=rig(i,j,k-1) endif @@ -923,12 +924,7 @@ subroutine difest_vertical_hyb(m,n,mm,nn,k1m,k1n) real :: bl1, bl2, bl3, bl4 integer ki, ksfc, ktmp, kOBL, kn1 real, dimension(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy) :: hOBL - real iL_mks2cgs, iL_mks2cgssq, iM_mks2cgs c -c - iL_mks2cgs = 1.0 / (L_mks2cgs) - iM_mks2cgs = 1.0 / (M_mks2cgs) - iL_mks2cgssq = 1.0 / (L_mks2cgs*L_mks2cgs) surf_layer_ext = 0.1 bl1 = 8e-5 bl2 = 1.05e-4 @@ -970,16 +966,16 @@ subroutine difest_vertical_hyb(m,n,mm,nn,k1m,k1n) Kt_kpp = 0.0 Ks_kpp = 0.0 do k=1,kk+1 - Kv_kpp(k) = Kvisc_m(i,j,k)*iL_mks2cgssq - Kt_kpp(k) = Kdiff_t(i,j,k)*iL_mks2cgssq - Ks_kpp(k) = Kdiff_s(i,j,k)*iL_mks2cgssq + Kv_kpp(k) = Kvisc_m(i,j,k)*A_cgs2mks + Kt_kpp(k) = Kdiff_t(i,j,k)*A_cgs2mks + Ks_kpp(k) = Kdiff_s(i,j,k)*A_cgs2mks enddo depth_int(1) = p(i,j,1)/onem iFaceHeight(1) = -depth_int(1) ! convert cm/s to m/s surfFricVel = ustar(i,j) * iL_mks2cgs ! convert cm2/s3 to m2/s3 - surfBuoyFlux = - buoyfl(i,j,1) * iL_mks2cgssq + surfBuoyFlux = - buoyfl(i,j,1) * A_cgs2mks do k=1,kk kn = k + nn kn1 = max(nn+1,kn-1) @@ -1062,12 +1058,12 @@ subroutine difest_vertical_hyb(m,n,mm,nn,k1m,k1n) rig_i(k)=rig(i,j,k) surfBuoyFlux2(k) = ( buoyfl(i,j,k+1) - . - buoyfl(i,j,1 )) * iL_mks2cgssq + . - buoyfl(i,j,1 )) * A_cgs2mks c enddo ! k if(dps.gt.0.) bvfbot=bvfbot/dps ! convert cm2/s2 to m2/s2 - deltaU2 = deltaU2*iL_mks2cgssq + deltaU2 = deltaU2*A_cgs2mks ! bottom values for the Ri, N2, and N rig_i(kk+1) = rig_i(kk) @@ -1085,8 +1081,8 @@ subroutine difest_vertical_hyb(m,n,mm,nn,k1m,k1n) elseif (bdmtyp.eq.2) then c --- --------- Type 2: Background diffusivity is a constant ! convert cm2/s2 to m2/s2 - Kv_col(:) = bdmc2*iL_mks2cgssq - Kd_col(:) = bdmc2*iL_mks2cgssq + Kv_col(:) = bdmc2*A_cgs2mks + Kd_col(:) = bdmc2*A_cgs2mks else Kv_col(:) = 0. Kd_col(:) = 0. @@ -1207,7 +1203,7 @@ subroutine difest_vertical_hyb(m,n,mm,nn,k1m,k1n) ! Buoyancy flux acting on the OBL surfBuoyFlux = ( buoyfl(i,j,kOBL+1) - . - buoyfl(i,j,1 )) * iL_mks2cgssq + . - buoyfl(i,j,1 )) * A_cgs2mks ! Compute KPP using CVMix call CVMix_coeffs_kpp(Kv_kpp(:), ! (inout) Total viscosity [m2 s-1] @@ -1234,9 +1230,9 @@ subroutine difest_vertical_hyb(m,n,mm,nn,k1m,k1n) c ---- ccc ------- ! convert m2/s to cm2/s - Kv_kpp = Kv_kpp*L_mks2cgs**2 - Kt_kpp = Kt_kpp*L_mks2cgs**2 - Ks_kpp = Ks_kpp*L_mks2cgs**2 + Kv_kpp = Kv_kpp*A_mks2cgs + Kt_kpp = Kt_kpp*A_mks2cgs + Ks_kpp = Ks_kpp*A_mks2cgs Kv_kpp=max(nubmin,Kv_kpp) Kt_kpp=max(nubmin,Kt_kpp) Ks_kpp=max(nubmin,Ks_kpp) @@ -1305,8 +1301,7 @@ subroutine difest_lateral_hyb(m,n,mm,nn,k1m,k1n) do i=max(1,ifp(j,l)),min(ii,ilp(j,l)) kfil(i,j)=kk+1 do k=kk,2,-1 - ! if (p(i,j,k).gt.mlts(i,j)*onecm) kfil(i,j)=k - if (p(i,j,k).gt.mlts(i,j)*(onem/L_mks2cgs)) kfil(i,j)=k + if (p(i,j,k).gt.mlts(i,j)*onecm) kfil(i,j)=k enddo enddo enddo @@ -1530,7 +1525,7 @@ subroutine difest_lateral_hyb(m,n,mm,nn,k1m,k1n) . kmax(i,j)-kfil(i,j).ge.1) then c c --- --------- Rhines scale. - rhisc=egr(i,k)/max(1.e-22*L_mks2cgs**-1,betafp(i,j)) + rhisc=egr(i,k)/max(1.e-22*iL_mks2cgs,betafp(i,j)) c c --- --------- Eddy length scale. els=max(eglsmn,min(bcrrd(i),rhisc)) @@ -1593,7 +1588,7 @@ subroutine difest_lateral_hyb(m,n,mm,nn,k1m,k1n) c --- ------- RMS eddy velocity estimated from K = Gamma*u_rms*L, where c --- ------- a mixing efficiency of Gamma = 0.35 is used (Klocker and c --- ------- Abernathey, 2014). - rhisc=egrs(i)/max(1.e-22*L_mks2cgs**-1,betafp(i,j)) + rhisc=egrs(i)/max(1.e-22*iL_mks2cgs,betafp(i,j)) els=max(eglsmn,min(bcrrd(i),rhisc)) urmse(i)=2.86*egc*egrs(i)*els c @@ -1928,7 +1923,7 @@ subroutine difest_lateral_iso(m,n,mm,nn,k1m,k1n) . kmax(i,j)-kfil(i,j).ge.1) then c c --- --------- Rhines scale. - rhisc=egr(i,k)/max(1.e-22*L_mks2cgs**-1,betafp(i,j)) + rhisc=egr(i,k)/max(1.e-22*iL_mks2cgs,betafp(i,j)) c c --- --------- Eddy length scale. els=max(eglsmn,min(bcrrd(i),rhisc)) @@ -1964,7 +1959,7 @@ subroutine difest_lateral_iso(m,n,mm,nn,k1m,k1n) c --- ------- RMS eddy velocity estimated from K = Gamma*u_rms*L, where c --- ------- a mixing efficiency of Gamma = 0.35 is used (Klocker and c --- ------- Abernathey, 2014). - rhisc=egrs(i)/max(1.e-22*L_mks2cgs**-1,betafp(i,j)) + rhisc=egrs(i)/max(1.e-22*iL_mks2cgs,betafp(i,j)) els=max(eglsmn,min(bcrrd(i),rhisc)) urmse(i)=2.86*egc*egrs(i)*els c @@ -2061,8 +2056,8 @@ subroutine difest_lateral_iso(m,n,mm,nn,k1m,k1n) . -cpse(i) c c --- ----------- Eddy mixing suppresion factor. - esfac=1./ - . (1.+4.*(umnsc/max(urmsemin,abs(urmse(i))))**2) + esfac= + . 1./(1.+4.*(umnsc/max(urmsemin,abs(urmse(i))))**2) c else esfac=1. @@ -2167,7 +2162,7 @@ subroutine difest_vertical_iso(m,n,mm,nn,k1m,k1n) h=max(onem,dp(i,j,kn))*alpha0/g c h=max(onem*1e-8,dp(i,j,kn))*alpha0/g c h=max(onemm,dp(i,j,kn))*alpha0/g - Shear2(i,j,k)=max(1.e-13*L_mks2cgs**2,du2l(i,j,k))/(h*h) + Shear2(i,j,k)=max(1.e-13*A_mks2cgs,du2l(i,j,k))/(h*h) Prod(i,j,k)=difdia(i,j,k)*Pr_t*Shear2(i,j,k) else Buoy(i,j,k)=0. diff --git a/phy/mod_diffusion.F90 b/phy/mod_diffusion.F90 index 4f91834c..4f82d958 100644 --- a/phy/mod_diffusion.F90 +++ b/phy/mod_diffusion.F90 @@ -1,5 +1,5 @@ ! ------------------------------------------------------------------------------ -! Copyright (C) 2020-2022 Mats Bentsen +! Copyright (C) 2020-2022 Mats Bentsen, Mehmet Ilicak ! ! This file is part of BLOM. ! diff --git a/phy/mod_eddtra.F90 b/phy/mod_eddtra.F90 index 2c97eaac..3c086422 100644 --- a/phy/mod_eddtra.F90 +++ b/phy/mod_eddtra.F90 @@ -1,5 +1,5 @@ ! ------------------------------------------------------------------------------ -! Copyright (C) 2015-2022 Mats Bentsen +! Copyright (C) 2015-2022 Mats Bentsen, Mehmet Ilicak ! ! This file is part of BLOM. ! @@ -24,7 +24,7 @@ module mod_eddtra ! ------------------------------------------------------------------------------ use mod_types, only: r8 - use mod_constants, only: g, alpha0, epsilp, onem, onecm, onemm, L_mks2cgs + use mod_constants, only: g, alpha0, rho0, epsilp, onem, onecm, onemm use mod_time, only: delt1 use mod_xc use mod_vcoord, only: vcoord_type_tag, isopyc_bulkml, cntiso_hybrid @@ -36,7 +36,6 @@ module mod_eddtra usfltd, vsfltd use mod_cmnfld, only: nslpx, nslpy, mlts use mod_checksum, only: csdiag, chksummsk - use mod_pointtest, only: itest, jtest, ptest implicit none @@ -150,12 +149,10 @@ subroutine eddtra_gm_isopyc_bulkml(m, n, mm, nn, k1m, k1n) real(r8), dimension(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy) :: ptu, ptv real(r8), dimension(kdm+1) :: upsilon, mfl real(r8), dimension(kdm) :: dlm, dlp - real(r8) :: rho0, q, et2mf, kappa, fhi, flo + real(r8) :: q, et2mf, kappa, fhi, flo integer :: i, j, k, l, km, kn, kintr, kmax, kmin, niter, kdir logical :: changed - rho0 = 1._r8/alpha0 - call xctilr(difint, 1, kk, 2, 2, halo_ps) call xctilr(pbu, 1, 2, 2, 2, halo_us) call xctilr(pbv, 1, 2, 2, 2, halo_vs) @@ -206,7 +203,7 @@ subroutine eddtra_gm_isopyc_bulkml(m, n, mm, nn, k1m, k1n) kmax = 1 do k = 3, kk kn = k + nn - if (dp(i - 1, j, kn) > epsilp .or. dp(i, j, kn) > epsilp) kmax=k + if (dp(i - 1, j, kn) > epsilp .or. dp(i, j, kn) > epsilp) kmax = k enddo ! ------------------------------------------------------------------ @@ -592,7 +589,7 @@ subroutine eddtra_gm_isopyc_bulkml(m, n, mm, nn, k1m, k1n) kmax = 1 do k = 3, kk kn = k + nn - if (dp(i, j - 1, kn) > epsilp .or. dp(i, j, kn) > epsilp) kmax=k + if (dp(i, j - 1, kn) > epsilp .or. dp(i, j, kn) > epsilp) kmax = k enddo ! ------------------------------------------------------------------ @@ -972,12 +969,10 @@ subroutine eddtra_gm_cntiso_hybrid(m, n, mm, nn, k1m, k1n) real(r8), dimension(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy) :: ptu, ptv real(r8), dimension(kdm+1) :: mfl real(r8), dimension(kdm) :: puv, dlm, dlp - real(r8) :: rho0, q, et2mf, mlp, kappa + real(r8) :: q, et2mf, mlp, kappa integer :: i, j, k, l, km, kn, kmax, kml, niter, kdir logical :: changed - rho0 = 1._r8/alpha0 - call xctilr(difint, 1, kk, 2, 2, halo_ps) call xctilr(pbu, 1, 2, 2, 2, halo_us) call xctilr(pbv, 1, 2, 2, 2, halo_vs) @@ -1029,13 +1024,12 @@ subroutine eddtra_gm_cntiso_hybrid(m, n, mm, nn, k1m, k1n) do k = 2, kk kn = k + nn puv(k) = puv(k - 1) + dpu(i, j, kn - 1) - if (dp(i - 1, j, kn) > epsilp .or. dp(i, j, kn) > epsilp) kmax=k + if (dp(i - 1, j, kn) > epsilp .or. dp(i, j, kn) > epsilp) kmax = k enddo ! Compute the eddy induced mass flux at layer interfaces below the ! mixed layer. - ! mlp = .5_r8*(mlts(i - 1, j) + mlts(i, j))*onecm - mlp = .5_r8*(mlts(i - 1, j) + mlts(i, j))*(onem/L_mks2cgs) + mlp = .5_r8*(mlts(i - 1, j) + mlts(i, j))*onecm kml = kmax + 1 mfl(kmax + 1) = 0._r8 do k = kmax, 2, -1 @@ -1224,13 +1218,12 @@ subroutine eddtra_gm_cntiso_hybrid(m, n, mm, nn, k1m, k1n) do k = 2, kk kn = k + nn puv(k) = puv(k - 1) + dpv(i, j, kn - 1) - if (dp(i, j - 1, kn) > epsilp .or. dp(i, j, kn) > epsilp) kmax=k + if (dp(i, j - 1, kn) > epsilp .or. dp(i, j, kn) > epsilp) kmax = k enddo ! Compute the eddy induced mass flux at layer interfaces below the ! mixed layer. - ! mlp = .5_r8*(mlts(i, j - 1) + mlts(i, j))*onecm - mlp = .5_r8*(mlts(i, j - 1) + mlts(i, j))*(onem/L_mks2cgs) + mlp = .5_r8*(mlts(i, j - 1) + mlts(i, j))*onecm kml = kmax + 1 mfl(kmax + 1) = 0._r8 do k = kmax, 2, -1 diff --git a/phy/mod_eos.F90 b/phy/mod_eos.F90 index 4a99f38c..7226abff 100644 --- a/phy/mod_eos.F90 +++ b/phy/mod_eos.F90 @@ -33,28 +33,7 @@ module mod_eos private ! Coefficients for the functional fit of in situ density. -#if defined(CGS) - real(r8), parameter :: & - a11 = 9.9985372432159340e-01_r8, & - a12 = 1.0380621928183473e-02_r8, & - a13 = 1.7073577195684715e-03_r8, & - a14 = -3.6570490496333680e-05_r8, & - a15 = -7.3677944503527477e-06_r8, & - a16 = -3.5529175999643348e-06_r8, & - b11 = 1.7083494994335439e-10_r8, & - b12 = 7.1567921402953455e-13_r8, & - b13 = 1.2821026080049485e-13_r8, & - a21 = 1.0_r8 , & - a22 = 1.0316374535350838e-02_r8, & - a23 = 8.9521792365142522e-04_r8, & - a24 = -2.8438341552142710e-05_r8, & - a25 = -1.1887778959461776e-05_r8, & - a26 = -4.0163964812921489e-06_r8, & - b21 = 1.1995545126831476e-10_r8, & - b22 = 5.5234008384648383e-13_r8, & - b23 = 8.4310335919950873e-14_r8 -#endif -#if defined(MKS) +#ifdef MKS real(r8), parameter :: & a11 = 9.9985372432159340e+02_r8, & a12 = 1.0380621928183473e+01_r8, & @@ -74,24 +53,26 @@ module mod_eos b21 = 1.1995545126831476e-09_r8, & b22 = 5.5234008384648383e-12_r8, & b23 = 8.4310335919950873e-13_r8 -!c a11 = 9.9985372432159340e+02_r8, & -!c a12 = 1.0380621928183473e+01_r8, & -!c a13 = 1.7073577195684715e+00_r8, & -!c a14 = -3.6570490496333680e-02_r8, & -!c a15 = -7.3677944503527477e-03_r8, & -!c a16 = -3.5529175999643348e-03_r8, & -!c b11 = 1.7083494994335439e-02_r8, & -!c b12 = 7.1567921402953455e-05_r8, & -!c b13 = 1.2821026080049485e-05_r8, & -!c a21 = 1.0_r8 , & -!c a22 = 1.0316374535350838e-02_r8, & -!c a23 = 8.9521792365142522e-04_r8, & -!c a24 = -2.8438341552142710e-05_r8, & -!c a25 = -1.1887778959461776e-05_r8, & -!c a26 = -4.0163964812921489e-06_r8, & -!c b21 = 1.1995545126831476e-05_r8, & -!c b22 = 5.5234008384648383e-08_r8, & -!c b23 = 8.4310335919950873e-09_r8 +#else + real(r8), parameter :: & + a11 = 9.9985372432159340e-01_r8, & + a12 = 1.0380621928183473e-02_r8, & + a13 = 1.7073577195684715e-03_r8, & + a14 = -3.6570490496333680e-05_r8, & + a15 = -7.3677944503527477e-06_r8, & + a16 = -3.5529175999643348e-06_r8, & + b11 = 1.7083494994335439e-10_r8, & + b12 = 7.1567921402953455e-13_r8, & + b13 = 1.2821026080049485e-13_r8, & + a21 = 1.0_r8 , & + a22 = 1.0316374535350838e-02_r8, & + a23 = 8.9521792365142522e-04_r8, & + a24 = -2.8438341552142710e-05_r8, & + a25 = -1.1887778959461776e-05_r8, & + a26 = -4.0163964812921489e-06_r8, & + b21 = 1.1995545126831476e-10_r8, & + b22 = 5.5234008384648383e-13_r8, & + b23 = 8.4310335919950873e-14_r8 #endif ! Reference pressure [g cm-1 s-2]. diff --git a/phy/mod_inicon.F b/phy/mod_inicon.F index d5c18140..70e0c371 100644 --- a/phy/mod_inicon.F +++ b/phy/mod_inicon.F @@ -27,8 +27,8 @@ module mod_inicon c use mod_types, only: r8 use mod_config, only: expcnf - use mod_constants, only: g, epsilp, onem - use mod_constants, only: L_mks2cgs, M_mks2cgs, P_mks2cgs + use mod_constants, only: g, epsilp, onem, + . L_mks2cgs, M_mks2cgs, P_mks2cgs use mod_time, only: nstep, delt1, dlt use mod_xc use mod_vcoord, only: vcoord_type_tag, isopyc_bulkml, diff --git a/phy/mod_momtum.F b/phy/mod_momtum.F index dafedb2d..9eea25bf 100644 --- a/phy/mod_momtum.F +++ b/phy/mod_momtum.F @@ -1,6 +1,6 @@ ! ------------------------------------------------------------------------------ ! Copyright (C) 2000 HYCOM Consortium and contributors -! Copyright (C) 2001-2020 Mats Bentsen, Lars Inge Enstad, Mehmet Ilicak +! Copyright (C) 2001-2022 Mats Bentsen, Lars Inge Enstad, Mehmet Ilicak ! ! This file is part of BLOM. ! @@ -26,8 +26,8 @@ module mod_momtum c --- ------------------------------------------------------------------ c use mod_types, only: r8 - use mod_constants, only: g, alpha0, spval, onem, onemm - use mod_constants, only: epsilp, epsilpl + use mod_constants, only: g, alpha0, epsilp, epsilpl, spval, + . onem, onemm use mod_time, only: delt1, dlt use mod_xc use mod_grid, only: scqx, scqy, scpx, scpy, scux, scuy, diff --git a/phy/mod_mxlayr.F b/phy/mod_mxlayr.F index 4c3a397b..fa5ebffb 100644 --- a/phy/mod_mxlayr.F +++ b/phy/mod_mxlayr.F @@ -26,8 +26,8 @@ module mod_mxlayr c use mod_types, only: r8 use mod_constants, only: g, spcifh, alpha0, epsilp, spval, onem, - . tencm, onecm, onemm, onemu - use mod_constants, only: L_mks2cgs, R_mks2cgs + . tencm, onecm, onemm, onemu, + . L_mks2cgs, R_mks2cgs use mod_time, only: delt1 use mod_xc use mod_vcoord, only: sigmar @@ -90,6 +90,11 @@ module mod_mxlayr . mtkeke, ! Mixed layer TKE tendency related to kin. ! energy change [cm3 s-3]. . pbrnda ! Brine plume pressure depth [g cm-1 s-2]. +c + real(r8), parameter :: + . iL_mks2cgs = 1./L_mks2cgs, + . A_cgs2mks = 1./(L_mks2cgs*L_mks2cgs), + . V_mks2cgs = L_mks2cgs**3 c public :: rm0,rm5,ce,mlrttp,mltmin, . mtkeus,mtkeni,mtkebf,mtkers,mtkepe,mtkeke,pbrnda, @@ -420,8 +425,8 @@ subroutine mxlayr(m,n,mm,nn,k1m,k1n) tkew=mtkeus(i,j)+mtkeni(i,j)+mtkebf(i,j)+mtkers(i,j) if (.not.(nitr.eq.1.and.pres(3)*lbi.gt.1.)) then dtke=(tkew-tkeo)/dpmxl - if (abs(dtke)<(abs(tkew)+1.e-22*L_mks2cgs**3) - . /(pres(3)-pres(1))) then + if (abs(dtke)<(abs(tkew)+1.e-22*V_mks2cgs) + . /(pres(3)-pres(1))) then if (tkew.lt.0.) then dpmxl=.5*(pres(1)-pmxl) else @@ -440,9 +445,9 @@ subroutine mxlayr(m,n,mm,nn,k1m,k1n) write (lp,*) 'dpth=',pres(3)/onem,';' write (lp,*) 'pmxl=',pmxl/onem,';' write (lp,*) 'corio=',coriop(i,j),';' - write (lp,*) 'ustar=',ustar(i,j)*L_mks2cgs**-1,';' - write (lp,*) 'bfltot=',bfltot*L_mks2cgs**-2,';' - write (lp,*) 'bflpsw=',bflpsw*L_mks2cgs**-2,';' + write (lp,*) 'ustar=',ustar(i,j)*iL_mks2cgs,';' + write (lp,*) 'bfltot=',bfltot*A_cgs2mks,';' + write (lp,*) 'bflpsw=',bflpsw*A_cgs2mks,';' write (lp,*) 'bg2=',util1(i,j),';' write (lp,*) 'ce=',ce*sqrt(scp2(i,j))*rlf,';' write (lp,*) @@ -932,7 +937,7 @@ subroutine mxlayr(m,n,mm,nn,k1m,k1n) endif if (.not.chngd) then if (abs(dtke).lt. - . (abs(tkew)+1.e-22*L_mks2cgs**3)/delp(k)) then + . (abs(tkew)+1.e-22*V_mks2cgs)/delp(k)) then if (tkew.lt.0.) then dpmxl=.5*(pres(k)-pmxl) else @@ -955,9 +960,9 @@ subroutine mxlayr(m,n,mm,nn,k1m,k1n) write (lp,*) 'dpth=',pres(3)/onem,';' write (lp,*) 'pmxl=',pmxl/onem,';' write (lp,*) 'corio=',coriop(i,j),';' - write (lp,*) 'ustar=',ustar(i,j)*L_mks2cgs**-1,';' - write (lp,*) 'bfltot=',bfltot*L_mks2cgs**-2,';' - write (lp,*) 'bflpsw=',bflpsw*L_mks2cgs**-2,';' + write (lp,*) 'ustar=',ustar(i,j)*iL_mks2cgs,';' + write (lp,*) 'bfltot=',bfltot*A_cgs2mks,';' + write (lp,*) 'bflpsw=',bflpsw*A_cgs2mks,';' write (lp,*) 'bg2=',util1(i,j),';' write (lp,*) 'ce=',ce*sqrt(scp2(i,j))*rlf,';' write (lp,*) 'pres(3)=',pres(3)/onem,';' diff --git a/phy/mod_ndiff.F90 b/phy/mod_ndiff.F90 index e4baa771..d31b0f34 100644 --- a/phy/mod_ndiff.F90 +++ b/phy/mod_ndiff.F90 @@ -1,5 +1,5 @@ ! ------------------------------------------------------------------------------ -! Copyright (C) 2022 Mats Bentsen +! Copyright (C) 2022 Mats Bentsen, Mehmet Ilicak ! ! This file is part of BLOM. ! @@ -23,8 +23,7 @@ module mod_ndiff ! ------------------------------------------------------------------------------ use mod_types, only: r8 - use mod_constants, only: g, alpha0, epsilp, onemm - use mod_constants, only: P_mks2cgs, R_mks2cgs + use mod_constants, only: g, alpha0, epsilp, onemm, P_mks2cgs, R_mks2cgs use mod_time, only: delt1 use mod_xc use mod_grid, only: scuy, scvx, scp2, scuxi, scvyi diff --git a/phy/mod_pbcor.F b/phy/mod_pbcor.F index 606509bd..b0d84df6 100644 --- a/phy/mod_pbcor.F +++ b/phy/mod_pbcor.F @@ -1,5 +1,5 @@ ! ------------------------------------------------------------------------------ -! Copyright (C) 2005-2020 Mats Bentsen, Mehmet Ilicak +! Copyright (C) 2005-2022 Mats Bentsen, Mehmet Ilicak ! ! This file is part of BLOM. ! diff --git a/phy/mod_pgforc.F b/phy/mod_pgforc.F index 80a04a37..7fdac606 100644 --- a/phy/mod_pgforc.F +++ b/phy/mod_pgforc.F @@ -140,9 +140,6 @@ subroutine pgforc(m,n,mm,nn,k1m,k1n) c --- ------------------------------------------------------------------ c --- compute the pressure gradient force c --- ------------------------------------------------------------------ -c - use mod_constants, only: g, epsilp - use mod_xc c implicit none c diff --git a/phy/mod_remap.F b/phy/mod_remap.F index a671b80c..10e19318 100644 --- a/phy/mod_remap.F +++ b/phy/mod_remap.F @@ -1985,7 +1985,7 @@ subroutine remap_eitflx(scuy,scvx,scp2i,scp2,pbmin,pbu,pbv,plo, ca=aa*scp2i(i-1,j) q=dlm+.5*dx(i-1,j)*(1.-ca) if (abs(2.*dx(i-1,j)*umfl(i,j)*scp2i(i-1,j)).lt. - . 1.e-6*P_mks2cgs**-2*q*q) then + . 1.e-8*q*q) then cu(i,j)=ca+umfl(i,j)*scp2i(i-1,j)/q else cdiag @@ -2005,7 +2005,7 @@ subroutine remap_eitflx(scuy,scvx,scp2i,scp2,pbmin,pbu,pbv,plo, ca=aa*scp2i(i ,j) q=dlp-.5*dx(i ,j)*(1.+ca) if (abs(2.*dx(i ,j)*umfl(i,j)*scp2i(i ,j)).lt. - . 1.e-6*P_mks2cgs**-2*q*q) then + . 1.e-8*q*q) then cu(i,j)=ca+umfl(i,j)*scp2i(i ,j)/q else cdiag @@ -2049,7 +2049,7 @@ subroutine remap_eitflx(scuy,scvx,scp2i,scp2,pbmin,pbu,pbv,plo, ca=aa*scp2i(i,j-1) q=dlm+.5*dy(i,j-1)*(1.-ca) if (abs(2.*dy(i,j-1)*vmfl(i,j)*scp2i(i,j-1)).lt. - . 1.e-6*P_mks2cgs**-2*q*q) then + . 1.e-8*q*q) then cv(i,j)=ca+vmfl(i,j)*scp2i(i,j-1)/q else cdiag @@ -2069,7 +2069,7 @@ subroutine remap_eitflx(scuy,scvx,scp2i,scp2,pbmin,pbu,pbv,plo, ca=aa*scp2i(i,j ) q=dlp-.5*dy(i,j )*(1.+ca) if (abs(2.*dy(i,j )*vmfl(i,j)*scp2i(i,j )).lt. - . 1.e-6*P_mks2cgs**-2*q*q) then + . 1.e-8*q*q) then cv(i,j)=ca+vmfl(i,j)*scp2i(i,j )/q else cdiag diff --git a/phy/mod_tidaldissip.F90 b/phy/mod_tidaldissip.F90 index 8cab45c6..d3a61236 100644 --- a/phy/mod_tidaldissip.F90 +++ b/phy/mod_tidaldissip.F90 @@ -1,5 +1,5 @@ ! ------------------------------------------------------------------------------ -! Copyright (C) 2015-2020 Mats Bentsen +! Copyright (C) 2015-2020 Mats Bentsen, Mehmet Ilicak ! ! This file is part of BLOM. ! @@ -78,7 +78,7 @@ subroutine read_tidaldissip real(r8), dimension(itdm,jtdm) :: tmpg integer :: i, j, l, errstat, ncid, dimid, varid - + if (mnproc == 1) then write (lp, '(2a)') ' reading tidal dissipation data from ', & trim(tdfile) diff --git a/phy/mod_time.F90 b/phy/mod_time.F90 index bbd1632e..f4f0442b 100644 --- a/phy/mod_time.F90 +++ b/phy/mod_time.F90 @@ -1,5 +1,5 @@ ! ------------------------------------------------------------------------------ -! Copyright (C) 2020-2021 Mats Bentsen, Mehmet Ilicak, Aleksi Nummelin +! Copyright (C) 2020-2022 Mats Bentsen, Mehmet Ilicak, Aleksi Nummelin ! ! This file is part of BLOM. ! diff --git a/phy/mod_tke.F90 b/phy/mod_tke.F90 index adb82bd3..73dc2c95 100644 --- a/phy/mod_tke.F90 +++ b/phy/mod_tke.F90 @@ -57,17 +57,16 @@ module mod_tke gls_Ghcri = .03_r8, & ! vonKar = .4_r8 ! -#if defined(CGS) - real(r8), parameter :: & - tke_min = 7.6e-4_r8, & ! Minimum TKE value [cm2/s2]. - gls_psi_min = 1.e-10_r8, & ! Minimum GLS value [cm2/s3]. - Ls_unlmt_min = 1.e-6_r8 ! [cm] -#endif -#if defined(MKS) +#ifdef MKS real(r8), parameter :: & tke_min = 7.6e-8_r8, & ! Minimum TKE value [m2/s2]. gls_psi_min = 1.e-14_r8, & ! Minimum GLS value [m2/s3]. Ls_unlmt_min = 1.e-8_r8 ! [m] +#else + real(r8), parameter :: & + tke_min = 7.6e-4_r8, & ! Minimum TKE value [cm2/s2]. + gls_psi_min = 1.e-10_r8, & ! Minimum GLS value [cm2/s3]. + Ls_unlmt_min = 1.e-6_r8 ! [cm] #endif real(r8), dimension(1 - nbdy:idm + nbdy, 1 - nbdy:jdm + nbdy, kdm) :: & diff --git a/phy/mod_tmsmt.F b/phy/mod_tmsmt.F index 639af0c6..cf7ef21a 100644 --- a/phy/mod_tmsmt.F +++ b/phy/mod_tmsmt.F @@ -1,5 +1,5 @@ ! ------------------------------------------------------------------------------ -! Copyright (C) 2005-2022 Mats Bentsen +! Copyright (C) 2005-2022 Mats Bentsen, Mehmet Ilicak ! ! This file is part of BLOM. ! diff --git a/phy/mod_vcoord.F90 b/phy/mod_vcoord.F90 index 4b974748..f63e6cbd 100644 --- a/phy/mod_vcoord.F90 +++ b/phy/mod_vcoord.F90 @@ -1,5 +1,5 @@ ! ------------------------------------------------------------------------------ -! Copyright (C) 2021-2022 Mats Bentsen +! Copyright (C) 2021-2022 Mats Bentsen, Mehmet Ilicak ! ! This file is part of BLOM. ! diff --git a/phy/mod_vdiff.F90 b/phy/mod_vdiff.F90 index 4a8b0864..61778a72 100644 --- a/phy/mod_vdiff.F90 +++ b/phy/mod_vdiff.F90 @@ -1,5 +1,5 @@ ! ------------------------------------------------------------------------------ -! Copyright (C) 2021-2022 Mats Bentsen +! Copyright (C) 2021-2022 Mats Bentsen, Mehmet Ilicak ! ! This file is part of BLOM. ! @@ -23,7 +23,7 @@ module mod_vdiff ! ------------------------------------------------------------------------------ use mod_types, only: r8 - use mod_constants, only: g, spcifh, alpha0, onem + use mod_constants, only: g, spcifh, alpha0, onem use mod_time, only: delt1 use mod_xc use mod_eos, only: sig diff --git a/phy/numerical_bounds.F90 b/phy/numerical_bounds.F90 index 79097cca..a38c5b55 100644 --- a/phy/numerical_bounds.F90 +++ b/phy/numerical_bounds.F90 @@ -1,5 +1,5 @@ ! ------------------------------------------------------------------------------ -! Copyright (C) 2020 Mats Bentsen +! Copyright (C) 2020-2022 Mats Bentsen, Mehmet Ilicak ! ! This file is part of BLOM. ! @@ -62,7 +62,7 @@ subroutine numerical_bounds btdtmx = min(btdtmx, & scpx(i, j)*scpy(i, j) & /sqrt(g*depths(i, j)*L_mks2cgs*( scpx(i, j)*scpx(i, j) & - + scpy(i, j)*scpy(i, j)))) + + scpy(i, j)*scpy(i, j)))) enddo enddo enddo diff --git a/phy/rdlim.F b/phy/rdlim.F index 1db45a3e..4f44fe08 100644 --- a/phy/rdlim.F +++ b/phy/rdlim.F @@ -1,5 +1,5 @@ ! ------------------------------------------------------------------------------ -! Copyright (C) 2008-2021 Mats Bentsen, Mehmet Ilicak, Ingo Bethke, +! Copyright (C) 2008-2022 Mats Bentsen, Mehmet Ilicak, Ingo Bethke, ! Ping-Gin Chiu, Aleksi Nummelin ! ! This file is part of BLOM. diff --git a/single_column/mod_single_column.F90 b/single_column/mod_single_column.F90 index 1071d155..6017c0d9 100644 --- a/single_column/mod_single_column.F90 +++ b/single_column/mod_single_column.F90 @@ -1,5 +1,5 @@ ! ------------------------------------------------------------------------------ -! Copyright (C) 2021 Mehmet Ilicak, Mats Bentsen +! Copyright (C) 2021-2022 Mehmet Ilicak, Mats Bentsen ! ! This file is part of BLOM. ! From 34a99a146d6a08ecdb6cec2cb4e861b4459b7fc3 Mon Sep 17 00:00:00 2001 From: Mats Bentsen Date: Thu, 8 Dec 2022 20:28:36 +0100 Subject: [PATCH 236/366] Correct unit conversion of mixed layer depth to pressure. --- phy/mod_difest.F | 4 ++-- phy/mod_eddtra.F90 | 22 +++++++++++++++------- 2 files changed, 17 insertions(+), 9 deletions(-) diff --git a/phy/mod_difest.F b/phy/mod_difest.F index 2f3add01..9a42b6f0 100644 --- a/phy/mod_difest.F +++ b/phy/mod_difest.F @@ -1301,7 +1301,7 @@ subroutine difest_lateral_hyb(m,n,mm,nn,k1m,k1n) do i=max(1,ifp(j,l)),min(ii,ilp(j,l)) kfil(i,j)=kk+1 do k=kk,2,-1 - if (p(i,j,k).gt.mlts(i,j)*onecm) kfil(i,j)=k + if (p(i,j,k).gt.mlts(i,j)*(onem*iL_mks2cgs)) kfil(i,j)=k enddo enddo enddo @@ -2529,7 +2529,7 @@ subroutine difest_vertical_iso(m,n,mm,nn,k1m,k1n) . -buoyfl(i,j,1))) c c --- --- Mixed layer thickness - h=(p(i,j,3)-p(i,j,1))/(onem/L_mks2cgs) + h=(p(i,j,3)-p(i,j,1))/(onem*iL_mks2cgs) c c --- --- Dimensionless vertical coordinate in the boundary layer sg=(p(i,j,2)-p(i,j,1))/(p(i,j,3)-p(i,j,1)) diff --git a/phy/mod_eddtra.F90 b/phy/mod_eddtra.F90 index 3c086422..1490cf92 100644 --- a/phy/mod_eddtra.F90 +++ b/phy/mod_eddtra.F90 @@ -24,7 +24,8 @@ module mod_eddtra ! ------------------------------------------------------------------------------ use mod_types, only: r8 - use mod_constants, only: g, alpha0, rho0, epsilp, onem, onecm, onemm + use mod_constants, only: g, alpha0, rho0, epsilp, onem, onecm, onemm, & + L_mks2cgs use mod_time, only: delt1 use mod_xc use mod_vcoord, only: vcoord_type_tag, isopyc_bulkml, cntiso_hybrid @@ -39,6 +40,9 @@ module mod_eddtra implicit none + real(r8), parameter :: & + iL_mks2cgs = 1./L_mks2cgs + private public :: eddtra @@ -203,7 +207,8 @@ subroutine eddtra_gm_isopyc_bulkml(m, n, mm, nn, k1m, k1n) kmax = 1 do k = 3, kk kn = k + nn - if (dp(i - 1, j, kn) > epsilp .or. dp(i, j, kn) > epsilp) kmax = k + if (dp(i - 1, j, kn) > epsilp .or. dp(i, j, kn) > epsilp) & + kmax = k enddo ! ------------------------------------------------------------------ @@ -589,7 +594,8 @@ subroutine eddtra_gm_isopyc_bulkml(m, n, mm, nn, k1m, k1n) kmax = 1 do k = 3, kk kn = k + nn - if (dp(i, j - 1, kn) > epsilp .or. dp(i, j, kn) > epsilp) kmax = k + if (dp(i, j - 1, kn) > epsilp .or. dp(i, j, kn) > epsilp) & + kmax = k enddo ! ------------------------------------------------------------------ @@ -1024,12 +1030,13 @@ subroutine eddtra_gm_cntiso_hybrid(m, n, mm, nn, k1m, k1n) do k = 2, kk kn = k + nn puv(k) = puv(k - 1) + dpu(i, j, kn - 1) - if (dp(i - 1, j, kn) > epsilp .or. dp(i, j, kn) > epsilp) kmax = k + if (dp(i - 1, j, kn) > epsilp .or. dp(i, j, kn) > epsilp) & + kmax = k enddo ! Compute the eddy induced mass flux at layer interfaces below the ! mixed layer. - mlp = .5_r8*(mlts(i - 1, j) + mlts(i, j))*onecm + mlp = .5_r8*(mlts(i - 1, j) + mlts(i, j))*(onem*iL_mks2cgs) kml = kmax + 1 mfl(kmax + 1) = 0._r8 do k = kmax, 2, -1 @@ -1218,12 +1225,13 @@ subroutine eddtra_gm_cntiso_hybrid(m, n, mm, nn, k1m, k1n) do k = 2, kk kn = k + nn puv(k) = puv(k - 1) + dpv(i, j, kn - 1) - if (dp(i, j - 1, kn) > epsilp .or. dp(i, j, kn) > epsilp) kmax = k + if (dp(i, j - 1, kn) > epsilp .or. dp(i, j, kn) > epsilp) & + kmax = k enddo ! Compute the eddy induced mass flux at layer interfaces below the ! mixed layer. - mlp = .5_r8*(mlts(i, j - 1) + mlts(i, j))*onecm + mlp = .5_r8*(mlts(i, j - 1) + mlts(i, j))*(onem*iL_mks2cgs) kml = kmax + 1 mfl(kmax + 1) = 0._r8 do k = kmax, 2, -1 From e7538af9f224626a1cf15a6948dea1322cca6a8c Mon Sep 17 00:00:00 2001 From: Mats Bentsen Date: Fri, 9 Dec 2022 10:55:52 +0100 Subject: [PATCH 237/366] Updated NorESM coupling scripts for the use of MKS units. --- cime_config/buildcpp | 14 +++--- cime_config/buildnml | 77 +++++++++++++++++++++++--------- cime_config/config_component.xml | 2 +- 3 files changed, 61 insertions(+), 32 deletions(-) diff --git a/cime_config/buildcpp b/cime_config/buildcpp index 39a6a280..4a670c93 100644 --- a/cime_config/buildcpp +++ b/cime_config/buildcpp @@ -87,7 +87,7 @@ def buildcpp(case): hamocc_sedbypass = case.get_value("HAMOCC_SEDBYPASS") hamocc_ciso = case.get_value("HAMOCC_CISO") hamocc_vsls = case.get_value("HAMOCC_VSLS") - cgsmks = case.get_value("BLOM_UNIT") + blom_unit = case.get_value("BLOM_UNIT") expect(blom_vcoord != "cntiso_hybrid" or not turbclo, "BLOM_VCOORD == {} and BLOM_TURBULENT_CLOSURE == {} is not a valid combination".format(blom_vcoord, turbclo)) @@ -147,14 +147,10 @@ def buildcpp(case): else: expect(False, "tracer module {} is not recognized".format(module)) - if cgsmks: - for option in cgsmks.split(): - if option == "cgs": - blom_cppdefs = blom_cppdefs + " -DCGS" - elif option == "mks": - blom_cppdefs = blom_cppdefs + " -DMKS" - else: - expect(False, "SI_UNIT module {} is not recognized".format(option)) + if blom_unit == "mks": + blom_cppdefs = blom_cppdefs + " -DMKS" + else: + expect(blom_unit == "cgs", "Unit system {} is not recognized".format(option)) blom_cppdefs = "-DMPI" + blom_cppdefs diff --git a/cime_config/buildnml b/cime_config/buildnml index 14300b1a..795aecd1 100755 --- a/cime_config/buildnml +++ b/cime_config/buildnml @@ -90,12 +90,12 @@ if ($BLOM_UNIT == cgs) then set MDC2HI = 5000.e4 set MDC2LO = 300.e4 else - set MDV2HI = 0.02 - set MDV2LO = 0.004 + set MDV2HI = .02 + set MDV2LO = .004 set MDV4HI = 0. set MDV4LO = 0. - set MDC2HI = 5000.0 - set MDC2LO = 300.0 + set MDC2HI = 5000. + set MDC2LO = 300. endif set VSC2HI = .5 set VSC2LO = .5 @@ -104,7 +104,7 @@ set VSC4LO = 0. if ($BLOM_UNIT == cgs) then set CBAR = 5. else - set CBAR = 0.05 + set CBAR = .05 endif set CB = .002 set CWBDTS = 5.e-5 @@ -182,9 +182,9 @@ if ($BLOM_UNIT == cgs) then set EGMNDF = 100.e4 set EGMXDF = 1500.e4 else - set EGLSMN = 4000.0 - set EGMNDF = 100.0 - set EGMXDF = 1500.0 + set EGLSMN = 4000. + set EGMNDF = 100. + set EGMXDF = 1500. endif set EGIDFQ = 1. set RI0 = 1.2 @@ -637,7 +637,11 @@ else if ($OCN_GRID == tnx2v1 ) then set BACLIN = 4800. set BATROP = 96. set EGC = 0.5 - set EGMXDF = 1000.e4 + if ($BLOM_UNIT == cgs) then + set EGMXDF = 1000.e4 + else + set EGMXDF = 1000. + endif set CWMTAG = "'Gibraltar','Gibraltar'" set CWMEDG = " 'u', 'u'" set CWMI = " 53, 54" @@ -647,7 +651,11 @@ else if ($OCN_GRID == tnx1.5v1 ) then set BACLIN = 4800. set BATROP = 96. set EGC = 0.5 - set EGMXDF = 1000.e4 + if ($BLOM_UNIT == cgs) then + set EGMXDF = 1000.e4 + else + set EGMXDF = 1000. + endif else if ($OCN_GRID == tnx1v1 || $OCN_GRID == tnx1v3 || $OCN_GRID == tnx1v4) then if ($OCN_NCPL == 24) then set BACLIN = 3600. @@ -668,33 +676,58 @@ else if ($OCN_GRID == tnx1v1 || $OCN_GRID == tnx1v3 || $OCN_GRID == tnx1v4) then else if ($OCN_GRID == tnx0.25v1 || $OCN_GRID == tnx0.25v3 || $OCN_GRID == tnx0.25v4) then set BACLIN = 900. set BATROP = 15. - set MDV2HI = .15 - set MDV2LO = .15 + if ($BLOM_UNIT == cgs) then + set MDV2HI = .15 + set MDV2LO = .15 + set MDV4HI = 0. + set MDV4LO = 0. + set MDC2HI = 300.e4 + set MDC2LO = 300.e4 + else + set MDV2HI = .0015 + set MDV2LO = .0015 + set MDV4HI = 0. + set MDV4LO = 0. + set MDC2HI = 300. + set MDC2LO = 300. + endif set VSC2HI = .15 set VSC2LO = .15 set VSC4HI = 0.0625 set VSC4LO = 0.0625 - set MDC2HI = 300.e4 set CWBDTS = 0.75e-4 set CWBDLS = 25. set EDWMTH = "'step'" set EGC = 0.85 - set EGMXDF = 1500.e4 + if ($BLOM_UNIT == cgs) then + set EGMXDF = 1500.e4 + else + set EGMXDF = 1500. + endif set CE = 1.0 else if ($OCN_GRID == tnx0.125v4) then set BACLIN = 300. set BATROP = 6. - set EGMNDF = 0.0 - set EGMXDF = 0.0 + set EGMNDF = 0. + set EGMXDF = 0. set EDWMTH = "'step'" set CWBDTS = .75e-4 set CWBDLS = 25 - set MDV2HI = .5 - set MDV2LO = .1 - set MDV4HI = 0. - set MDV4LO = 0. - set MDC2HI = 300.e4 - set MDC2LO = 100.e4 + if ($BLOM_UNIT == cgs) then + set MDV2HI = .5 + set MDV2LO = .1 + set MDV4HI = 0. + set MDV4LO = 0. + set MDC2HI = 300.e4 + set MDC2LO = 100.e4 + else + set MDV2HI = .005 + set MDV2LO = .001 + set MDV4HI = 0. + set MDV4LO = 0. + set MDC2HI = 300. + set MDC2LO = 100. + endif set VSC2HI = .5 set VSC2LO = .5 set VSC4HI = 0.0 diff --git a/cime_config/config_component.xml b/cime_config/config_component.xml index 25448c0e..facef683 100644 --- a/cime_config/config_component.xml +++ b/cime_config/config_component.xml @@ -224,7 +224,7 @@ cgs build_component_blom env_build.xml - BLOM UNIT values. Valid values one of: cgs mks. + Unit system. Valid values one of: cgs mks. From 641b42feefe4ea12376f855902d6f929d1517309 Mon Sep 17 00:00:00 2001 From: Mats Bentsen Date: Sun, 11 Dec 2022 00:56:55 +0100 Subject: [PATCH 238/366] Fixed check of unit system when building as NorESM component. --- cime_config/buildcpp | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/cime_config/buildcpp b/cime_config/buildcpp index 69bbfd35..ca879e86 100644 --- a/cime_config/buildcpp +++ b/cime_config/buildcpp @@ -153,7 +153,7 @@ def buildcpp(case): if blom_unit == "mks": blom_cppdefs = blom_cppdefs + " -DMKS" else: - expect(blom_unit == "cgs", "Unit system {} is not recognized".format(option)) + expect(blom_unit == "cgs", "Unit system {} is not recognized".format(blom_unit)) blom_cppdefs = "-DMPI" + blom_cppdefs From 010295459b1fd6d7219c37396dc819a5a0a2a875 Mon Sep 17 00:00:00 2001 From: Mats Bentsen Date: Fri, 23 Dec 2022 15:35:23 +0100 Subject: [PATCH 239/366] Corrected pressure interface calculation. --- phy/mod_cmnfld_routines.F90 | 13 +++++++++++++ phy/mod_difest.F | 34 ---------------------------------- phy/mod_vcoord.F90 | 4 ++-- 3 files changed, 15 insertions(+), 36 deletions(-) diff --git a/phy/mod_cmnfld_routines.F90 b/phy/mod_cmnfld_routines.F90 index ef6f7cb1..f8879d07 100644 --- a/phy/mod_cmnfld_routines.F90 +++ b/phy/mod_cmnfld_routines.F90 @@ -365,6 +365,19 @@ subroutine cmnfld_bfsqi_cntiso_hybrid(m, n, mm, nn, k1m, k1n) real(r8) :: pup, tup, sup, plo, tlo, slo integer :: i, j, k, l, kn + !$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 + bfsqi = 0.0_r8 !$omp parallel do private(l, i, k, pup, tup, sup, kn, plo, tlo, slo) do j = 1, jj diff --git a/phy/mod_difest.F b/phy/mod_difest.F index 67f0f486..b3ccd87f 100644 --- a/phy/mod_difest.F +++ b/phy/mod_difest.F @@ -798,23 +798,6 @@ subroutine difest_lateral_hybrid(m,n,mm,nn,k1m,k1n) call xctilr(pbv, 1,2, 2,2, halo_vs) c c --- ------------------------------------------------------------------ -c --- Update layer interface pressure. -c --- ------------------------------------------------------------------ -c -c$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 -c$OMP END PARALLEL DO -c -c --- ------------------------------------------------------------------ c --- Estimate friction velocity cubed. c --- ------------------------------------------------------------------ c @@ -863,23 +846,6 @@ subroutine difest_vertical_hybrid(m,n,mm,nn,k1m,k1n) call xctilr(u(1-nbdy,1-nbdy,k1n), 1,kk, 1,1, halo_uv) call xctilr(v(1-nbdy,1-nbdy,k1n), 1,kk, 1,1, halo_vv) c -c --- ------------------------------------------------------------------ -c --- Update layer interface pressure. -c --- ------------------------------------------------------------------ -c -c$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 -c$OMP END PARALLEL DO -c c --- Obtain common fields for the estimation of lateral and vertical c --- diffusivities diapycnal diffusivities. call difest_common_hyb(m,n,mm,nn,k1m,k1n) diff --git a/phy/mod_vcoord.F90 b/phy/mod_vcoord.F90 index f63e6cbd..80913d5a 100644 --- a/phy/mod_vcoord.F90 +++ b/phy/mod_vcoord.F90 @@ -1238,11 +1238,11 @@ subroutine remap_velocity(m, n, mm, nn, k1m, k1n) 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+2 + 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+2, ilp(j,l)) + 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 From a6ea1457a1938b39af7df72c069c62fef40b28a4 Mon Sep 17 00:00:00 2001 From: Mats Bentsen Date: Fri, 23 Dec 2022 16:35:43 +0100 Subject: [PATCH 240/366] Added functionality for vcoord_type = cntiso_hybrid to allow for a gradual change of layer thickness in a transition zone separating interfaces with constant pressure and constant potential density, respectively. --- phy/mod_vcoord.F90 | 94 +++++++++++++++++++++++++++++++++++----------- 1 file changed, 73 insertions(+), 21 deletions(-) diff --git a/phy/mod_vcoord.F90 b/phy/mod_vcoord.F90 index 80913d5a..91bfc31e 100644 --- a/phy/mod_vcoord.F90 +++ b/phy/mod_vcoord.F90 @@ -69,6 +69,9 @@ module mod_vcoord dpmin_inflation_factor = 1._r8, & dpmin_interior = .1_r8, & regrid_nudge_factor = .1_r8 + integer :: & + dktzu = 4, & + dktzl = 1 ! Options derived from string options. integer :: & @@ -533,9 +536,12 @@ subroutine cntiso_regrid_nudge_jslice(p_src, p_dst, i_lb, i_ub, j, j_rs, nn) integer, dimension(1-nbdy:idm+nbdy) :: ksmx, kdmx real(r8), dimension(kdm+1) :: sigmar_1d, pmin, sig_pmin - real(r8) :: sig_max, dpmin_sfc, dsig, dsigdx, q - integer :: l, i, nt, k, kr, kl, klastok, kt, errstat - logical :: ok + real(r8) :: dpmin_inflation_factor_i, sig_max, dpmin_sfc, dsig, dsigdx, & + ckt, a, p1, dp0, b, c, q, d, rk + integer :: l, i, nt, k, kt, kl, ktzmin, ktzmax, klastok, errstat + logical :: tzfound, ok + + 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)) @@ -590,6 +596,7 @@ subroutine cntiso_regrid_nudge_jslice(p_src, p_dst, i_lb, i_ub, j, j_rs, nn) p_dst(k,i) = p_src(kk+1,i) enddo + ! Set minimum interface pressure. dpmin_sfc = dpmin_surface pmin(1) = p_src(1,i) do k = 1, kk @@ -598,23 +605,37 @@ subroutine cntiso_regrid_nudge_jslice(p_src, p_dst, i_lb, i_ub, j, j_rs, nn) enddo p_dst(1,i) = pmin(1) + ! Find the index of the first interface with potential density at + ! minimum interface pressure smaller than the reference potential + ! density of that interface. This transition interface is the first + ! interface below layers with prescribed minimum thickness. sig_pmin(1) = sig_srcdi(1,1) - kr = 2 + kt = 2 kl = 1 - do while (kr <= kdmx(i)) - do while (p_src(kl+1,i) < pmin(kr)) + tzfound = .false. + do while (kt <= kdmx(i)) + do while (p_src(kl+1,i) < pmin(kt)) kl = kl + 1 enddo - sig_pmin(kr) = ( (p_src(kl+1,i) - pmin(kr))*sig_srcdi(1,kl) & - + (pmin(kr) - p_src(kl,i))*sig_srcdi(2,kl)) & + 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(kr) > sig_pmin(kr)) exit - p_dst(kr,i) = pmin(kr) - kr = kr + 1 + if (sigmar_1d(kt) > sig_pmin(kt)) then + ktzmin = max(2, kt - dktzu) + ktzmax = min(ksmx(i), kdmx(i), kt + dktzl) + if (ktzmin < kt .and. ktzmax - ktzmin > 1) tzfound = .true. + exit + endif + p_dst(kt,i) = pmin(kt) + kt = kt + 1 enddo - klastok = kr - 1 - do k = kr, min(ksmx(i), kdmx(i)) + ! Starting at the transition interface, nudge the interface pressures + ! to reduce the deviation from the interface reference potential + ! density. + + klastok = kt - 1 + do k = kt, min(ksmx(i), kdmx(i)) ok = .true. if (sigmar_1d(k) < sig_srcdi(2,k-1) .and. & sigmar_1d(k) < sig_srcdi(1,k )) then @@ -652,8 +673,8 @@ subroutine cntiso_regrid_nudge_jslice(p_src, p_dst, i_lb, i_ub, j, j_rs, nn) p_src(kk+1,i)) if (k - klastok > 1) then q = (p_dst(k,i) - p_dst(klastok,i))/(k - klastok) - do kt = klastok+1, k-1 - p_dst(kt,i) = min(max(p_dst(kt-1,i) + q, pmin(kt)), & + do kl = klastok+1, k-1 + p_dst(kl,i) = min(max(p_dst(kl-1,i) + q, pmin(kl)), & p_src(kk+1,i)) enddo endif @@ -661,7 +682,7 @@ subroutine cntiso_regrid_nudge_jslice(p_src, p_dst, i_lb, i_ub, j, j_rs, nn) endif enddo - do k = max(kr, min(ksmx(i), kdmx(i))) + 1, kdmx(i) + do k = max(kt, min(ksmx(i), kdmx(i))) + 1, kdmx(i) ok = .true. if (sigmar_1d(k) < sig_srcdi(2,ksmx(i))) then dsig = (sigmar_1d(k) - sig_srcdi(2,ksmx(i)))*regrid_nudge_factor @@ -688,8 +709,8 @@ subroutine cntiso_regrid_nudge_jslice(p_src, p_dst, i_lb, i_ub, j, j_rs, nn) p_src(kk+1,i)) if (k - klastok > 1) then q = (p_dst(k,i) - p_dst(klastok,i))/(k - klastok) - do kt = klastok+1, k-1 - p_dst(kt,i) = min(max(p_dst(kt-1,i) + q, pmin(kt)), & + do kl = klastok+1, k-1 + p_dst(kl,i) = min(max(p_dst(kl-1,i) + q, pmin(kl)), & p_src(kk+1,i)) enddo endif @@ -699,12 +720,39 @@ subroutine cntiso_regrid_nudge_jslice(p_src, p_dst, i_lb, i_ub, j, j_rs, nn) if (kdmx(i) - klastok > 0) then q = (p_dst(kdmx(i)+1,i) - p_dst(klastok,i))/(kdmx(i) + 1 - klastok) - do kt = klastok+1, kdmx(i) - p_dst(kt,i) = min(max(p_dst(kt-1,i) + q, pmin(kt)), & + do kl = klastok+1, kdmx(i) + p_dst(kl,i) = min(max(p_dst(kl-1,i) + q, pmin(kl)), & p_src(kk+1,i)) enddo endif + ! Enforce a gradual change of layer thickness in a transition zone that + ! is defined by prescribed layer range above and below the transition + ! interface. + if (tzfound) then + ckt = (sigmar_1d(kt) - sig_pmin(kt)) & + /( sigmar_1d(kt) - sigmar_1d(kt-1) & + - sig_pmin (kt) + sig_pmin (kt-1)) + a = p_dst(ktzmin-1,i)*ckt + p_dst(ktzmin,i)*(1 - ckt) + p1 = p_dst(ktzmax-1,i)*ckt + p_dst(ktzmax,i)*(1 - ckt) + dp0 = p_dst(ktzmin,i) - p_dst(ktzmin-1,i) + if (ckt > .5_r8) then + b = dp0*((ckt - .5_r8)*dpmin_inflation_factor_i + 1.5_r8 - ckt) + else + b = dp0*(ckt + .5_r8 + dpmin_inflation_factor*(.5_r8 - ckt)) + endif + c = .5_r8*dp0*(dpmin_inflation_factor - 1._r8) & + *(ckt*dpmin_inflation_factor_i + 1._r8 - ckt) + q = 1._r8/(ktzmax - ktzmin) + d = (((p1 - a)*q - b)*q - c)*q + if (d > 0._r8) then + do k = ktzmin, ktzmax-1 + rk = k - ktzmin + ckt + p_dst(k,i) = a + rk*(b + rk*(c + rk*d)) + enddo + endif + endif + enddo enddo @@ -756,7 +804,7 @@ subroutine readnml_vcoord 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_factor + regrid_nudge_factor, dktzu, dktzl ! Read variables in the namelist group 'vcoord'. if (mnproc == 1) then @@ -800,6 +848,8 @@ subroutine readnml_vcoord call xcbcst(dpmin_inflation_factor) call xcbcst(dpmin_interior) call xcbcst(regrid_nudge_factor) + call xcbcst(dktzu) + call xcbcst(dktzl) endif if (mnproc == 1) then write (lp,*) 'readnml_vcoord: vertical coordinate variables:' @@ -823,6 +873,8 @@ subroutine readnml_vcoord write (lp,*) ' dpmin_inflation_factor = ', dpmin_inflation_factor write (lp,*) ' dpmin_interior = ', dpmin_interior write (lp,*) ' regrid_nudge_factor = ', regrid_nudge_factor + write (lp,*) ' dktzu = ', dktzu + write (lp,*) ' dktzl = ', dktzl endif ! Resolve options. From d4738df41fbe03c7e7f140610cd38cded5403867 Mon Sep 17 00:00:00 2001 From: Mats Bentsen Date: Sat, 31 Dec 2022 15:59:23 +0100 Subject: [PATCH 241/366] Added submesoscale eddy-induced transport parameterization for hybrid vertical coordinate. --- cime_config/buildnml | 50 +- phy/mod_advect.F | 19 +- phy/mod_dia.F | 524 +++++++++++++--- phy/mod_diffusion.F90 | 31 +- phy/mod_eddtra.F90 | 1367 ++++++++++++++++++++++++----------------- phy/rdlim.F | 58 +- phy/restart_rd.F | 90 +++ phy/restart_wt.F | 72 +++ tests/fuk95/limits | 24 + 9 files changed, 1551 insertions(+), 684 deletions(-) diff --git a/cime_config/buildnml b/cime_config/buildnml index d95bece9..940bec57 100755 --- a/cime_config/buildnml +++ b/cime_config/buildnml @@ -359,18 +359,24 @@ set LYR_UFLX = '0, 4, 0' set LYR_UTFLX = '0, 4, 0' set LYR_USFLX = '0, 4, 0' set LYR_UMFLTD = '0, 0, 4' +set LYR_UMFLSM = '0, 0, 4' set LYR_UTFLTD = '0, 0, 4' +set LYR_UTFLSM = '0, 0, 4' set LYR_UTFLLD = '0, 0, 4' set LYR_USFLTD = '0, 0, 4' +set LYR_USFLSM = '0, 0, 4' set LYR_USFLLD = '0, 0, 4' set LYR_UVEL = '0, 4, 0' set LYR_VFLX = '0, 4, 0' set LYR_VTFLX = '0, 4, 0' set LYR_VSFLX = '0, 4, 0' set LYR_VMFLTD = '0, 0, 4' +set LYR_VMFLSM = '0, 0, 4' set LYR_VTFLTD = '0, 0, 4' +set LYR_VTFLSM = '0, 0, 4' set LYR_VTFLLD = '0, 0, 4' set LYR_VSFLTD = '0, 0, 4' +set LYR_VSFLSM = '0, 0, 4' set LYR_VSFLLD = '0, 0, 4' set LYR_VVEL = '0, 4, 0' set LYR_WFLX = '0, 4, 0' @@ -394,18 +400,24 @@ set LVL_UFLX = '0, 4, 0' set LVL_UTFLX = '0, 4, 0' set LVL_USFLX = '0, 4, 0' set LVL_UMFLTD = '0, 0, 4' +set LVL_UMFLSM = '0, 0, 4' set LVL_UTFLTD = '0, 0, 4' +set LVL_UTFLSM = '0, 0, 4' set LVL_UTFLLD = '0, 0, 4' set LVL_USFLTD = '0, 0, 4' +set LVL_USFLSM = '0, 0, 4' set LVL_USFLLD = '0, 0, 4' set LVL_UVEL = '0, 4, 0' set LVL_VFLX = '0, 4, 0' set LVL_VTFLX = '0, 4, 0' set LVL_VSFLX = '0, 4, 0' set LVL_VMFLTD = '0, 0, 4' +set LVL_VMFLSM = '0, 0, 4' set LVL_VTFLTD = '0, 0, 4' +set LVL_VTFLSM = '0, 0, 4' set LVL_VTFLLD = '0, 0, 4' set LVL_VSFLTD = '0, 0, 4' +set LVL_VSFLSM = '0, 0, 4' set LVL_VSFLLD = '0, 0, 4' set LVL_VVEL = '0, 4, 0' set LVL_WFLX = '0, 4, 0' @@ -417,12 +429,16 @@ set LVL_IDLAGE = '0, 4, 0' set MSC_MMFLXL = '0, 4, 0' set MSC_MMFLXD = '0, 4, 0' set MSC_MMFTDL = '0, 4, 0' +set MSC_MMFSML = '0, 4, 0' set MSC_MMFTDD = '0, 4, 0' +set MSC_MMFSMD = '0, 4, 0' set MSC_MHFLX = '0, 4, 0' set MSC_MHFTD = '0, 4, 0' +set MSC_MHFSM = '0, 4, 0' set MSC_MHFLD = '0, 4, 0' set MSC_MSFLX = '0, 4, 0' set MSC_MSFTD = '0, 4, 0' +set MSC_MSFSM = '0, 4, 0' set MSC_MSFLD = '0, 4, 0' set MSC_VOLTR = '0, 4, 0' set MSC_MASSGS = '0, 4, 0' @@ -675,9 +691,11 @@ else if ($OCN_GRID == tnx1v1 || $OCN_GRID == tnx1v3 || $OCN_GRID == tnx1v4) then set BACLIN = 3600. set BATROP = 60. set CWBDTS = .75e-4 - set CE = .5 set NIWGF = .4 set SMTFRC = .false. + if ($BLOM_VCOORD == isopyc_bulkml) then + set CE = .5 + endif else set BACLIN = 3200. set BATROP = 64. @@ -718,7 +736,9 @@ else if ($OCN_GRID == tnx0.25v1 || $OCN_GRID == tnx0.25v3 || $OCN_GRID == tnx0.2 else set EGMXDF = 1500. endif - set CE = 1.0 + if ($BLOM_VCOORD == isopyc_bulkml) then + set CE = 1.0 + endif else if ($OCN_GRID == tnx0.125v4) then set BACLIN = 300. set BATROP = 6. @@ -1305,18 +1325,24 @@ cat >>! $RUNDIR/ocn_in$inststr << EOF ! UTFLX - heat flux in x-direction [W] ! USFLX - salt flux in x-direction [kg s-1] ! UMFLTD - mass flux due to thickness diffusion in x-direction [kg s-1] +! UMFLSM - mass flux due to submesoscale transport in x-direction [kg s-1] ! UTFLTD - heat flux due to thickness diffusion in x-direction [W] +! UTFLSM - heat flux due to submesoscale transport in x-direction [W] ! UTFLLD - heat flux due to lateral diffusion in x-direction [W] ! USFLTD - salt flux due to thickness diffusion in x-direction [kg s-1] +! USFLSM - salt flux due to submesoscale transport in x-direction [kg s-1] ! USFLLD - salt flux due to lateral diffusion in x-direction [kg s-1] ! UVEL - velocity x-component [m s-1] ! VFLX - mass flux in y-direction [kg s-1] ! VTFLX - heat flux in y-direction [W] ! VSFLX - salt flux in y-direction [kg s-1] ! VMFLTD - mass flux due to thickness diffusion in y-direction [kg s-1] +! VMFLSM - mass flux due to submesoscale transport in y-direction [kg s-1] ! VTFLTD - heat flux due to thickness diffusion in y-direction [W] +! VTFLSM - heat flux due to submesoscale transport in y-direction [W] ! VTFLLD - heat flux due to lateral diffusion in y-direction [W] ! VSFLTD - salt flux due to thickness diffusion in y-direction [kg s-1] +! VSFLSM - salt flux due to submesoscale transport in y-direction [kg s-1] ! VSFLLD - salt flux due to lateral diffusion in y-direction [kg s-1] ! VVEL - velocity x-component [m s-1] ! WFLX - vertical mass flux [kg s-1] @@ -1328,12 +1354,16 @@ cat >>! $RUNDIR/ocn_in$inststr << EOF ! MMFLXL - meridional overturning circ. (MOC) on isopycnic layers [kg s-1] ! MMFLXD - MOC on z-levels [kg s-1] ! MMFTDL - MOC due to thickness diffusion on isopycnic layers [kg s-1] +! MMFSML - MOC due to submesoscale transport on isopycnic layers [kg s-1] ! MMFTDD - MOC due to thickness diffusion on z-levels [kg s-1] +! MMFSMD - MOC due to submesoscale transport on z-levels [kg s-1] ! MHFLX - meridional heat flux [W] ! MHFTD - meridional heat flux due to thickness diffusion [W] +! MHFSM - meridional heat flux due to submesoscale transport [W] ! MHFLD - meridional heat flux due to lateral diffusion [W] ! MSFLX - meridional salt flux [kg s-1] ! MSFTD - meridional salt flux due to thickness diffusion [kg s-1] +! MSFSM - meridional salt flux due to submesoscale transport [kg s-1] ! MSFLD - meridional salt flux due to lateral diffusion [kg s-1] ! VOLTR - section transports [kg s-1] ! MASSGS - global sum of mass [kg] @@ -1426,18 +1456,24 @@ cat >>! $RUNDIR/ocn_in$inststr << EOF LYR_UTFLX = $LYR_UTFLX LYR_USFLX = $LYR_USFLX LYR_UMFLTD = $LYR_UMFLTD + LYR_UMFLSM = $LYR_UMFLSM LYR_UTFLTD = $LYR_UTFLTD + LYR_UTFLSM = $LYR_UTFLSM LYR_UTFLLD = $LYR_UTFLLD LYR_USFLTD = $LYR_USFLTD + LYR_USFLSM = $LYR_USFLSM LYR_USFLLD = $LYR_USFLLD LYR_UVEL = $LYR_UVEL LYR_VFLX = $LYR_VFLX LYR_VTFLX = $LYR_VTFLX LYR_VSFLX = $LYR_VSFLX LYR_VMFLTD = $LYR_VMFLTD + LYR_VMFLSM = $LYR_VMFLSM LYR_VTFLTD = $LYR_VTFLTD + LYR_VTFLSM = $LYR_VTFLSM LYR_VTFLLD = $LYR_VTFLLD LYR_VSFLTD = $LYR_VSFLTD + LYR_VSFLSM = $LYR_VSFLSM LYR_VSFLLD = $LYR_VSFLLD LYR_VVEL = $LYR_VVEL LYR_WFLX = $LYR_WFLX @@ -1461,18 +1497,24 @@ cat >>! $RUNDIR/ocn_in$inststr << EOF LVL_UTFLX = $LVL_UTFLX LVL_USFLX = $LVL_USFLX LVL_UMFLTD = $LVL_UMFLTD + LVL_UMFLSM = $LVL_UMFLSM LVL_UTFLTD = $LVL_UTFLTD + LVL_UTFLSM = $LVL_UTFLSM LVL_UTFLLD = $LVL_UTFLLD LVL_USFLTD = $LVL_USFLTD + LVL_USFLSM = $LVL_USFLSM LVL_USFLLD = $LVL_USFLLD LVL_UVEL = $LVL_UVEL LVL_VFLX = $LVL_VFLX LVL_VTFLX = $LVL_VTFLX LVL_VSFLX = $LVL_VSFLX LVL_VMFLTD = $LVL_VMFLTD + LVL_VMFLSM = $LVL_VMFLSM LVL_VTFLTD = $LVL_VTFLTD + LVL_VTFLSM = $LVL_VTFLSM LVL_VTFLLD = $LVL_VTFLLD LVL_VSFLTD = $LVL_VSFLTD + LVL_VSFLSM = $LVL_VSFLSM LVL_VSFLLD = $LVL_VSFLLD LVL_VVEL = $LVL_VVEL LVL_WFLX = $LVL_WFLX @@ -1484,12 +1526,16 @@ cat >>! $RUNDIR/ocn_in$inststr << EOF MSC_MMFLXL = $MSC_MMFLXL MSC_MMFLXD = $MSC_MMFLXD MSC_MMFTDL = $MSC_MMFTDL + MSC_MMFSML = $MSC_MMFSML MSC_MMFTDD = $MSC_MMFTDD + MSC_MMFSMD = $MSC_MMFSMD MSC_MHFLX = $MSC_MHFLX MSC_MHFTD = $MSC_MHFTD + MSC_MHFSM = $MSC_MHFSM MSC_MHFLD = $MSC_MHFLD MSC_MSFLX = $MSC_MSFLX MSC_MSFTD = $MSC_MSFTD + MSC_MSFSM = $MSC_MSFSM MSC_MSFLD = $MSC_MSFLD MSC_VOLTR = $MSC_VOLTR MSC_MASSGS = $MSC_MASSGS diff --git a/phy/mod_advect.F b/phy/mod_advect.F index e91b894a..c91d1c88 100644 --- a/phy/mod_advect.F +++ b/phy/mod_advect.F @@ -33,7 +33,7 @@ module mod_advect use mod_state, only: u, v, dp, dpu, dpv, temp, saln, sigma, . uflx, vflx, utflx, vtflx, usflx, vsflx, . p, pbu, pbv, ubflxs_p, vbflxs_p - use mod_diffusion, only: umfltd, vmfltd + use mod_diffusion, only: umfltd, vmfltd, umflsm, vmflsm use mod_remap, only: remap_eitvel, remap_eitflx use mod_utility, only: utotm, vtotm, umax, vmax use mod_checksum, only: csdiag, chksummsk @@ -61,7 +61,8 @@ subroutine advect(m,n,mm,nn,k1m,k1n) integer m,n,mm,nn,k1m,k1n c integer i,j,k,l,km,kn,iw,ie,js,jn,isw,jsw,ise,jse,inw,jnw,ine,jne - real, dimension(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy) :: pbmin + real, dimension(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy) :: + . pbmin,umflei,vmflei #ifdef TRC integer nt #endif @@ -119,7 +120,8 @@ subroutine advect(m,n,mm,nn,k1m,k1n) do i=max(0,ifu(j,l)),min(ii+2,ilu(j,l)) utotm(i,j)=u(i,j,km) . +(ubflxs_p(i,j,m)*dlt/pbu(i,j,m) - . +umfltd(i,j,km)/max(onemm,dpu(i,j,kn))) + . +(umfltd(i,j,km)+umflsm(i,j,km)) + . /max(onemm,dpu(i,j,kn))) . /(delt1*scuy(i,j)) utotm(i,j)=max(-umax(i,j),min(umax(i,j),utotm(i,j))) enddo @@ -130,7 +132,8 @@ subroutine advect(m,n,mm,nn,k1m,k1n) do i=max(-1,ifv(j,l)),min(ii+2,ilv(j,l)) vtotm(i,j)=v(i,j,km) . +(vbflxs_p(i,j,m)*dlt/pbv(i,j,m) - . +vmfltd(i,j,km)/max(onemm,dpv(i,j,kn))) + . +(vmfltd(i,j,km)+vmflsm(i,j,km)) + . /max(onemm,dpv(i,j,kn))) . /(delt1*scvx(i,j)) vtotm(i,j)=max(-vmax(i,j),min(vmax(i,j),vtotm(i,j))) enddo @@ -163,7 +166,8 @@ subroutine advect(m,n,mm,nn,k1m,k1n) km=k+mm kn=k+nn c -c --- --- advective velocity at mid time level +c --- --- advective velocity and total eddy-induced mass flux at mid +c --- --- time level c do j=-1,jj+2 do l=1,isu(j) @@ -172,6 +176,7 @@ subroutine advect(m,n,mm,nn,k1m,k1n) . +dlt*ubflxs_p(i,j,m) . /(delt1*pbu(i,j,m)*scuy(i,j)) utotm(i,j)=max(-umax(i,j),min(umax(i,j),utotm(i,j))) + umflei(i,j)=umfltd(i,j,km)+umflsm(i,j,km) enddo enddo enddo @@ -182,6 +187,7 @@ subroutine advect(m,n,mm,nn,k1m,k1n) . +dlt*vbflxs_p(i,j,m) . /(delt1*pbv(i,j,m)*scvx(i,j)) vtotm(i,j)=max(-vmax(i,j),min(vmax(i,j),vtotm(i,j))) + vmflei(i,j)=vmfltd(i,j,km)+vmflsm(i,j,km) enddo enddo enddo @@ -189,8 +195,7 @@ subroutine advect(m,n,mm,nn,k1m,k1n) call remap_eitflx(scuy,scvx,scp2i,scp2,pbmin, . pbu(1-nbdy,1-nbdy,n),pbv(1-nbdy,1-nbdy,n), . p(1-nbdy,1-nbdy,k+1),utotm,vtotm, - . umfltd(1-nbdy,1-nbdy,km), - . vmfltd(1-nbdy,1-nbdy,km), + . umflei,vmflei, . delt1,1, . dp(1-nbdy,1-nbdy,kn), . temp(1-nbdy,1-nbdy,kn), diff --git a/phy/mod_dia.F b/phy/mod_dia.F index 1edf48fd..daf2ef5c 100644 --- a/phy/mod_dia.F +++ b/phy/mod_dia.F @@ -46,8 +46,10 @@ module mod_dia use mod_difest, only: OBLdepth use mod_diffusion, only: difint, difiso, difdia, . Kvisc_m, Kdiff_t, Kdiff_s, - . umfltd, vmfltd, utfltd, vtfltd, utflld, - . vtflld, usfltd, vsfltd, usflld, vsflld + . umfltd, vmfltd, umflsm, vmflsm, + . utfltd, vtfltd, utflsm, vtflsm, + . utflld, vtflld, usfltd, vsfltd, + . usflsm, vsflsm, usflld, vsflld use mod_cmnfld, only: z, bfsql, dz, mlts use mod_seaice, only: ficem, hicem, hsnwm, uicem, vicem, iagem use mod_forcing, only: swa, nsf, hmltfz, lip, sop, eva, rnf, rfi, @@ -155,9 +157,9 @@ module mod_dia real, save, dimension(ldm) :: mtlat real, save, dimension(kdm) :: sigmar1 real, save, allocatable, dimension(:,:,:) :: - . mmflxl,mmftdl,mmflxd,mmftdd + . mmflxl,mmftdl,mmfsml,mmflxd,mmftdd,mmfsmd real, save, allocatable, dimension(:,:) :: - . mhflx,mhftd,mhfld,msflx,msftd,msfld + . mhflx,mhftd,mhfsm,mhfld,msflx,msftd,msfsm,msfld c c --- Section transports character(len=256), save :: sec_sifile @@ -199,22 +201,26 @@ module mod_dia . LYR_BFSQ ,LYR_DIFDIA ,LYR_DIFVMO ,LYR_DIFVHO ,LYR_DIFVSO , . LYR_DIFINT ,LYR_DIFISO ,LYR_DP ,LYR_DPU ,LYR_DPV , . LYR_DZ ,LYR_SALN ,LYR_TEMP ,LYR_TRC ,LYR_UFLX , - . LYR_UTFLX ,LYR_USFLX ,LYR_UMFLTD ,LYR_UTFLTD ,LYR_UTFLLD , - . LYR_USFLTD ,LYR_USFLLD ,LYR_UVEL ,LYR_VFLX ,LYR_VTFLX , - . LYR_VSFLX ,LYR_VMFLTD ,LYR_VTFLTD ,LYR_VTFLLD ,LYR_VSFLTD , - . LYR_VSFLLD ,LYR_VVEL ,LYR_WFLX ,LYR_WFLX2 ,LYR_PV , - . LYR_TKE ,LYR_GLS_PSI,LYR_IDLAGE , + . LYR_UTFLX ,LYR_USFLX ,LYR_UMFLTD ,LYR_UMFLSM ,LYR_UTFLTD , + . LYR_UTFLSM ,LYR_UTFLLD ,LYR_USFLTD ,LYR_USFLSM ,LYR_USFLLD , + . LYR_UVEL ,LYR_VFLX ,LYR_VTFLX ,LYR_VSFLX ,LYR_VMFLTD , + . LYR_VMFLSM ,LYR_VTFLTD ,LYR_VTFLSM ,LYR_VTFLLD ,LYR_VSFLTD , + . LYR_VSFLSM ,LYR_VSFLLD ,LYR_VVEL ,LYR_WFLX ,LYR_WFLX2 , + . LYR_PV ,LYR_TKE ,LYR_GLS_PSI,LYR_IDLAGE , . LVL_BFSQ ,LVL_DIFDIA ,LVL_DIFVMO ,LVL_DIFVHO ,LVL_DIFVSO , . LVL_DIFINT ,LVL_DIFISO ,LVL_DZ ,LVL_SALN ,LVL_TEMP , . LVL_TRC ,LVL_UFLX ,LVL_UTFLX ,LVL_USFLX ,LVL_UMFLTD , - . LVL_UTFLTD ,LVL_UTFLLD ,LVL_USFLTD ,LVL_USFLLD ,LVL_UVEL , - . LVL_VFLX ,LVL_VTFLX ,LVL_VSFLX ,LVL_VMFLTD ,LVL_VTFLTD , - . LVL_VTFLLD ,LVL_VSFLTD ,LVL_VSFLLD ,LVL_VVEL ,LVL_WFLX , - . LVL_WFLX2 ,LVL_PV ,LVL_TKE ,LVL_GLS_PSI,LVL_IDLAGE , - . MSC_MMFLXL ,MSC_MMFLXD ,MSC_MMFTDL ,MSC_MMFTDD ,MSC_MHFLX , - . MSC_MHFTD ,MSC_MHFLD ,MSC_MSFLX ,MSC_MSFTD ,MSC_MSFLD , - . MSC_VOLTR ,MSC_MASSGS ,MSC_VOLGS ,MSC_SALNGA ,MSC_TEMPGA , - . MSC_SSSGA ,MSC_SSTGA , + . LVL_UMFLSM ,LVL_UTFLTD ,LVL_UTFLSM ,LVL_UTFLLD ,LVL_USFLTD , + . LVL_USFLSM ,LVL_USFLLD ,LVL_UVEL ,LVL_VFLX ,LVL_VTFLX , + . LVL_VSFLX ,LVL_VMFLTD ,LVL_VMFLSM ,LVL_VTFLTD ,LVL_VTFLSM , + . LVL_VTFLLD ,LVL_VSFLTD ,LVL_VSFLSM ,LVL_VSFLLD ,LVL_VVEL , + . LVL_WFLX ,LVL_WFLX2 ,LVL_PV ,LVL_TKE ,LVL_GLS_PSI, + . LVL_IDLAGE , + . MSC_MMFLXL ,MSC_MMFLXD ,MSC_MMFTDL ,MSC_MMFSML ,MSC_MMFTDD , + . MSC_MMFSMD ,MSC_MHFLX ,MSC_MHFTD ,MSC_MHFSM ,MSC_MHFLD , + . MSC_MSFLX ,MSC_MSFTD ,MSC_MSFSM ,MSC_MSFLD ,MSC_VOLTR , + . MSC_MASSGS ,MSC_VOLGS ,MSC_SALNGA ,MSC_TEMPGA ,MSC_SSSGA , + . MSC_SSTGA , . GLB_AVEPERIO,GLB_FILEFREQ,GLB_COMPFLAG,GLB_NCFORMAT character(len=10), dimension(nphymax), save :: GLB_FNAMETAG integer, dimension(nphymax), save :: @@ -234,22 +240,26 @@ module mod_dia . ACC_BFSQ ,ACC_DIFDIA ,ACC_DIFVMO ,ACC_DIFVHO ,ACC_DIFVSO , . ACC_DIFINT ,ACC_DIFISO ,ACC_DP ,ACC_DPU ,ACC_DPV , . ACC_DZ ,ACC_SALN ,ACC_TEMP ,ACC_UFLX ,ACC_UTFLX , - . ACC_USFLX ,ACC_UMFLTD ,ACC_UTFLTD ,ACC_UTFLLD ,ACC_USFLTD , - . ACC_USFLLD ,ACC_UVEL ,ACC_VFLX ,ACC_VTFLX ,ACC_VSFLX , - . ACC_VMFLTD ,ACC_VTFLTD ,ACC_VTFLLD ,ACC_VSFLTD ,ACC_VSFLLD , - . ACC_VVEL ,ACC_WFLX ,ACC_WFLX2 ,ACC_AVDSG ,ACC_DPVOR , - . ACC_TKE ,ACC_GLS_PSI,ACC_UTILLYR, - . ACC_BFSQLVL ,ACC_DIFDIALVL,ACC_DIFVMOLVL,ACC_DIFVHOLVL, - . ACC_DIFVSOLVL ,ACC_DIFINTLVL,ACC_DIFISOLVL,ACC_DZLVL , - . ACC_SALNLVL ,ACC_TEMPLVL ,ACC_UFLXLVL ,ACC_UTFLXLVL , - . ACC_USFLXLVL ,ACC_UMFLTDLVL,ACC_UTFLTDLVL,ACC_UTFLLDLVL, - . ACC_USFLTDLVL ,ACC_USFLLDLVL,ACC_UVELLVL ,ACC_VFLXLVL , - . ACC_VTFLXLVL ,ACC_VSFLXLVL ,ACC_VMFLTDLVL,ACC_VTFLTDLVL, - . ACC_VTFLLDLVL ,ACC_VSFLTDLVL,ACC_VSFLLDLVL,ACC_VVELLVL , - . ACC_WFLXLVL ,ACC_WFLX2LVL ,ACC_PVLVL ,ACC_TKELVL , - . ACC_GLS_PSILVL,ACC_UFLXOLD ,ACC_VFLXOLD ,ACC_UTILLVL , - . ACC_MMFLXL,ACC_MMFLXD,ACC_MMFTDL,ACC_MMFTDD,ACC_MHFLX,ACC_MHFTD, - . ACC_MHFLD ,ACC_MSFLX ,ACC_MSFTD ,ACC_MSFLD ,ACC_VOLTR + . ACC_USFLX ,ACC_UMFLTD ,ACC_UMFLSM ,ACC_UTFLTD ,ACC_UTFLSM , + . ACC_UTFLLD ,ACC_USFLTD ,ACC_USFLSM ,ACC_USFLLD ,ACC_UVEL , + . ACC_VFLX ,ACC_VTFLX ,ACC_VSFLX ,ACC_VMFLTD ,ACC_VMFLSM , + . ACC_VTFLTD ,ACC_VTFLSM ,ACC_VTFLLD ,ACC_VSFLTD ,ACC_VSFLSM , + . ACC_VSFLLD ,ACC_VVEL ,ACC_WFLX ,ACC_WFLX2 ,ACC_AVDSG , + . ACC_DPVOR ,ACC_TKE ,ACC_GLS_PSI,ACC_UTILLYR, + . ACC_BFSQLVL ,ACC_DIFDIALVL ,ACC_DIFVMOLVL ,ACC_DIFVHOLVL , + . ACC_DIFVSOLVL ,ACC_DIFINTLVL ,ACC_DIFISOLVL ,ACC_DZLVL , + . ACC_SALNLVL ,ACC_TEMPLVL ,ACC_UFLXLVL ,ACC_UTFLXLVL , + . ACC_USFLXLVL ,ACC_UMFLTDLVL ,ACC_UMFLSMLVL ,ACC_UTFLTDLVL , + . ACC_UTFLSMLVL ,ACC_UTFLLDLVL ,ACC_USFLTDLVL ,ACC_USFLSMLVL , + . ACC_USFLLDLVL ,ACC_UVELLVL ,ACC_VFLXLVL ,ACC_VTFLXLVL , + . ACC_VSFLXLVL ,ACC_VMFLTDLVL ,ACC_VMFLSMLVL ,ACC_VTFLTDLVL , + . ACC_VTFLSMLVL ,ACC_VTFLLDLVL ,ACC_VSFLTDLVL ,ACC_VSFLSMLVL , + . ACC_VSFLLDLVL ,ACC_VVELLVL ,ACC_WFLXLVL ,ACC_WFLX2LVL , + . ACC_PVLVL ,ACC_TKELVL ,ACC_GLS_PSILVL,ACC_UFLXOLD , + . ACC_VFLXOLD ,ACC_UTILLVL , + . ACC_MMFLXL,ACC_MMFLXD,ACC_MMFTDL,ACC_MMFSML,ACC_MMFTDD, + . ACC_MMFSMD,ACC_MHFLX ,ACC_MHFTD ,ACC_MHFSM ,ACC_MHFLD , + . ACC_MSFLX ,ACC_MSFTD ,ACC_MSFSM ,ACC_MSFLD ,ACC_VOLTR namelist /MERDIA/ . MER_ORFILE,MER_MIFILE,MER_REGNAM,MER_REGFLG,MER_MINLAT,MER_MAXLAT namelist /SECDIA/ @@ -271,22 +281,26 @@ module mod_dia . LYR_BFSQ ,LYR_DIFDIA ,LYR_DIFVMO ,LYR_DIFVHO ,LYR_DIFVSO , . LYR_DIFINT ,LYR_DIFISO ,LYR_DP ,LYR_DPU ,LYR_DPV , . LYR_DZ ,LYR_SALN ,LYR_TEMP ,LYR_TRC ,LYR_UFLX , - . LYR_UTFLX ,LYR_USFLX ,LYR_UMFLTD ,LYR_UTFLTD ,LYR_UTFLLD , - . LYR_USFLTD ,LYR_USFLLD ,LYR_UVEL ,LYR_VFLX ,LYR_VTFLX , - . LYR_VSFLX ,LYR_VMFLTD ,LYR_VTFLTD ,LYR_VTFLLD ,LYR_VSFLTD , - . LYR_VSFLLD ,LYR_VVEL ,LYR_WFLX ,LYR_WFLX2 ,LYR_PV , - . LYR_TKE ,LYR_GLS_PSI,LYR_IDLAGE , + . LYR_UTFLX ,LYR_USFLX ,LYR_UMFLTD ,LYR_UMFLSM ,LYR_UTFLTD , + . LYR_UTFLSM ,LYR_UTFLLD ,LYR_USFLTD ,LYR_USFLSM ,LYR_USFLLD , + . LYR_UVEL ,LYR_VFLX ,LYR_VTFLX ,LYR_VSFLX ,LYR_VMFLTD , + . LYR_VMFLSM ,LYR_VTFLTD ,LYR_VTFLSM ,LYR_VTFLLD ,LYR_VSFLTD , + . LYR_VSFLSM ,LYR_VSFLLD ,LYR_VVEL ,LYR_WFLX ,LYR_WFLX2 , + . LYR_PV ,LYR_TKE ,LYR_GLS_PSI,LYR_IDLAGE , . LVL_BFSQ ,LVL_DIFDIA ,LVL_DIFVMO ,LVL_DIFVHO ,LVL_DIFVSO , . LVL_DIFINT ,LVL_DIFISO ,LVL_DZ ,LVL_SALN ,LVL_TEMP , . LVL_TRC ,LVL_UFLX ,LVL_UTFLX ,LVL_USFLX ,LVL_UMFLTD , - . LVL_UTFLTD ,LVL_UTFLLD ,LVL_USFLTD ,LVL_USFLLD ,LVL_UVEL , - . LVL_VFLX ,LVL_VTFLX ,LVL_VSFLX ,LVL_VMFLTD ,LVL_VTFLTD , - . LVL_VTFLLD ,LVL_VSFLTD ,LVL_VSFLLD ,LVL_VVEL ,LVL_WFLX , - . LVL_WFLX2 ,LVL_PV ,LVL_TKE ,LVL_GLS_PSI,LVL_IDLAGE , - . MSC_MMFLXL ,MSC_MMFLXD ,MSC_MMFTDL ,MSC_MMFTDD ,MSC_MHFLX , - . MSC_MHFTD ,MSC_MHFLD ,MSC_MSFLX ,MSC_MSFTD ,MSC_MSFLD , - . MSC_VOLTR ,MSC_MASSGS ,MSC_VOLGS ,MSC_SALNGA ,MSC_TEMPGA , - . MSC_SSSGA ,MSC_SSTGA , + . LVL_UMFLSM ,LVL_UTFLTD ,LVL_UTFLSM ,LVL_UTFLLD ,LVL_USFLTD , + . LVL_USFLSM ,LVL_USFLLD ,LVL_UVEL ,LVL_VFLX ,LVL_VTFLX , + . LVL_VSFLX ,LVL_VMFLTD ,LVL_VMFLSM ,LVL_VTFLTD ,LVL_VTFLSM , + . LVL_VTFLLD ,LVL_VSFLTD ,LVL_VSFLSM ,LVL_VSFLLD ,LVL_VVEL , + . LVL_WFLX ,LVL_WFLX2 ,LVL_PV ,LVL_TKE ,LVL_GLS_PSI, + . LVL_IDLAGE , + . MSC_MMFLXL ,MSC_MMFLXD ,MSC_MMFTDL ,MSC_MMFSML ,MSC_MMFTDD , + . MSC_MMFSMD ,MSC_MHFLX ,MSC_MHFTD ,MSC_MHFSM ,MSC_MHFLD , + . MSC_MSFLX ,MSC_MSFTD ,MSC_MSFSM ,MSC_MSFLD ,MSC_VOLTR , + . MSC_MASSGS ,MSC_VOLGS ,MSC_SALNGA ,MSC_TEMPGA ,MSC_SSSGA , + . MSC_SSTGA , . GLB_AVEPERIO,GLB_FILEFREQ,GLB_COMPFLAG,GLB_NCFORMAT, . GLB_FNAMETAG @@ -395,9 +409,10 @@ subroutine diaini c --- diagnostics if (mnproc.eq.1) then if (sum(MSC_MMFLXL(1:nphy)+MSC_MMFLXD(1:nphy)+MSC_MMFTDL(1:nphy) - . +MSC_MMFTDD(1:nphy)+MSC_MHFLX(1:nphy)+MSC_MHFTD(1:nphy) - . +MSC_MHFLD(1:nphy)+MSC_MSFLX(1:nphy)+MSC_MSFTD(1:nphy) - . +MSC_MSFLD(1:nphy)).ne.0) then + . +MSC_MMFSML(1:nphy)+MSC_MMFTDD(1:nphy)+MSC_MMFSMD(1:nphy) + . +MSC_MHFLX (1:nphy)+MSC_MHFTD (1:nphy)+MSC_MHFSM (1:nphy) + . +MSC_MHFLD (1:nphy)+MSC_MSFLX (1:nphy)+MSC_MSFTD (1:nphy) + . +MSC_MSFSM (1:nphy)+MSC_MSFLD (1:nphy)).ne.0) then inquire(file=mer_orfile,exist=fexist) if (.not.fexist) then write (lp,'(3a)') ' Could not find file ', @@ -477,6 +492,7 @@ subroutine diaini ACC_SLVSQ(n) = H2D_SLVSQ(n) ACC_SFL(n) = H2D_SFL(n) ACC_SIGMX(n) = H2D_SIGMX(n) + MSC_MMFLXL(n) + MSC_MMFTDL(n) + . + MSC_MMFSML(n) ACC_SOP(n) = H2D_SOP(n) ACC_SSS(n) = H2D_SSS(n) + MSC_SSSGA(n) ACC_SSSSQ(n) = H2D_SSSSQ(n) @@ -539,13 +555,19 @@ subroutine diaini ACC_USFLX(n) = LYR_USFLX(n) + MSC_MSFLX(n) ACC_USFLXLVL(n) = LVL_USFLX(n) ACC_UMFLTD(n) = LYR_UMFLTD(n) + MSC_MMFTDL(n) + ACC_UMFLSM(n) = LYR_UMFLSM(n) + MSC_MMFSML(n) ACC_UMFLTDLVL(n)= LVL_UMFLTD(n) + MSC_MMFTDD(n) + ACC_UMFLSMLVL(n)= LVL_UMFLSM(n) + MSC_MMFSMD(n) ACC_UTFLTD(n) = LYR_UTFLTD(n) + MSC_MHFTD(n) + ACC_UTFLSM(n) = LYR_UTFLSM(n) + MSC_MHFSM(n) ACC_UTFLTDLVL(n)= LVL_UTFLTD(n) + ACC_UTFLSMLVL(n)= LVL_UTFLSM(n) ACC_UTFLLD(n) = LYR_UTFLLD(n) + MSC_MHFLD(n) ACC_UTFLLDLVL(n)= LVL_UTFLLD(n) ACC_USFLTD(n) = LYR_USFLTD(n) + MSC_MSFTD(n) + ACC_USFLSM(n) = LYR_USFLSM(n) + MSC_MSFSM(n) ACC_USFLTDLVL(n)= LVL_USFLTD(n) + ACC_USFLSMLVL(n)= LVL_USFLSM(n) ACC_USFLLD(n) = LYR_USFLLD(n) + MSC_MSFLD(n) ACC_USFLLDLVL(n)= LVL_USFLLD(n) ACC_UVEL(n) = LYR_UVEL(n) @@ -560,13 +582,19 @@ subroutine diaini ACC_VSFLX(n) = LYR_VSFLX(n) + MSC_MSFLX(n) ACC_VSFLXLVL(n) = LVL_VSFLX(n) ACC_VMFLTD(n) = LYR_VMFLTD(n) + MSC_MMFTDL(n) + ACC_VMFLSM(n) = LYR_VMFLSM(n) + MSC_MMFSML(n) ACC_VMFLTDLVL(n)= LVL_VMFLTD(n) + MSC_MMFTDD(n) + ACC_VMFLSMLVL(n)= LVL_VMFLSM(n) + MSC_MMFSMD(n) ACC_VTFLTD(n) = LYR_VTFLTD(n) + MSC_MHFTD(n) + ACC_VTFLSM(n) = LYR_VTFLSM(n) + MSC_MHFSM(n) ACC_VTFLTDLVL(n)= LVL_VTFLTD(n) + ACC_VTFLSMLVL(n)= LVL_VTFLSM(n) ACC_VTFLLD(n) = LYR_VTFLLD(n) + MSC_MHFLD(n) ACC_VTFLLDLVL(n)= LVL_VTFLLD(n) ACC_VSFLTD(n) = LYR_VSFLTD(n) + MSC_MSFTD(n) + ACC_VSFLSM(n) = LYR_VSFLSM(n) + MSC_MSFSM(n) ACC_VSFLTDLVL(n)= LVL_VSFLTD(n) + ACC_VSFLSMLVL(n)= LVL_VSFLSM(n) ACC_VSFLLD(n) = LYR_VSFLLD(n) + MSC_MSFLD(n) ACC_VSFLLDLVL(n)= LVL_VSFLLD(n) ACC_VVEL(n) = LYR_VVEL(n) @@ -589,12 +617,16 @@ subroutine diaini ACC_MMFLXL(n) = MSC_MMFLXL(n) ACC_MMFLXD(n) = MSC_MMFLXD(n) ACC_MMFTDL(n) = MSC_MMFTDL(n) + ACC_MMFSML(n) = MSC_MMFSML(n) ACC_MMFTDD(n) = MSC_MMFTDD(n) + ACC_MMFSMD(n) = MSC_MMFSMD(n) ACC_MHFLX(n) = MSC_MHFLX(n) ACC_MHFTD(n) = MSC_MHFTD(n) + ACC_MHFSM(n) = MSC_MHFSM(n) ACC_MHFLD(n) = MSC_MHFLD(n) ACC_MSFLX(n) = MSC_MSFLX(n) ACC_MSFTD(n) = MSC_MSFTD(n) + ACC_MSFSM(n) = MSC_MSFSM(n) ACC_MSFLD(n) = MSC_MSFLD(n) ACC_VOLTR(n) = MSC_VOLTR(n) c @@ -762,12 +794,18 @@ subroutine diaini ACC_USFLX(n)=nphylyr*min(1,ACC_USFLX(n)) if (ACC_UMFLTD(n).ne.0) nphylyr=nphylyr+1 ACC_UMFLTD(n)=nphylyr*min(1,ACC_UMFLTD(n)) + if (ACC_UMFLSM(n).ne.0) nphylyr=nphylyr+1 + ACC_UMFLSM(n)=nphylyr*min(1,ACC_UMFLSM(n)) if (ACC_UTFLTD(n).ne.0) nphylyr=nphylyr+1 ACC_UTFLTD(n)=nphylyr*min(1,ACC_UTFLTD(n)) + if (ACC_UTFLSM(n).ne.0) nphylyr=nphylyr+1 + ACC_UTFLSM(n)=nphylyr*min(1,ACC_UTFLSM(n)) if (ACC_UTFLLD(n).ne.0) nphylyr=nphylyr+1 ACC_UTFLLD(n)=nphylyr*min(1,ACC_UTFLLD(n)) if (ACC_USFLTD(n).ne.0) nphylyr=nphylyr+1 ACC_USFLTD(n)=nphylyr*min(1,ACC_USFLTD(n)) + if (ACC_USFLSM(n).ne.0) nphylyr=nphylyr+1 + ACC_USFLSM(n)=nphylyr*min(1,ACC_USFLSM(n)) if (ACC_USFLLD(n).ne.0) nphylyr=nphylyr+1 ACC_USFLLD(n)=nphylyr*min(1,ACC_USFLLD(n)) if (ACC_UVEL(n).ne.0) nphylyr=nphylyr+1 @@ -780,12 +818,18 @@ subroutine diaini ACC_VSFLX(n)=nphylyr*min(1,ACC_VSFLX(n)) if (ACC_VMFLTD(n).ne.0) nphylyr=nphylyr+1 ACC_VMFLTD(n)=nphylyr*min(1,ACC_VMFLTD(n)) + if (ACC_VMFLSM(n).ne.0) nphylyr=nphylyr+1 + ACC_VMFLSM(n)=nphylyr*min(1,ACC_VMFLSM(n)) if (ACC_VTFLTD(n).ne.0) nphylyr=nphylyr+1 ACC_VTFLTD(n)=nphylyr*min(1,ACC_VTFLTD(n)) + if (ACC_VTFLSM(n).ne.0) nphylyr=nphylyr+1 + ACC_VTFLSM(n)=nphylyr*min(1,ACC_VTFLSM(n)) if (ACC_VTFLLD(n).ne.0) nphylyr=nphylyr+1 ACC_VTFLLD(n)=nphylyr*min(1,ACC_VTFLLD(n)) if (ACC_VSFLTD(n).ne.0) nphylyr=nphylyr+1 ACC_VSFLTD(n)=nphylyr*min(1,ACC_VSFLTD(n)) + if (ACC_VSFLSM(n).ne.0) nphylyr=nphylyr+1 + ACC_VSFLSM(n)=nphylyr*min(1,ACC_VSFLSM(n)) if (ACC_VSFLLD(n).ne.0) nphylyr=nphylyr+1 ACC_VSFLLD(n)=nphylyr*min(1,ACC_VSFLLD(n)) if (ACC_VVEL(n).ne.0) nphylyr=nphylyr+1 @@ -833,12 +877,18 @@ subroutine diaini ACC_USFLXLVL(n)=nphylvl*min(1,ACC_USFLXLVL(n)) if (ACC_UMFLTDLVL(n).ne.0) nphylvl=nphylvl+1 ACC_UMFLTDLVL(n)=nphylvl*min(1,ACC_UMFLTDLVL(n)) + if (ACC_UMFLSMLVL(n).ne.0) nphylvl=nphylvl+1 + ACC_UMFLSMLVL(n)=nphylvl*min(1,ACC_UMFLSMLVL(n)) if (ACC_UTFLTDLVL(n).ne.0) nphylvl=nphylvl+1 ACC_UTFLTDLVL(n)=nphylvl*min(1,ACC_UTFLTDLVL(n)) + if (ACC_UTFLSMLVL(n).ne.0) nphylvl=nphylvl+1 + ACC_UTFLSMLVL(n)=nphylvl*min(1,ACC_UTFLSMLVL(n)) if (ACC_UTFLLDLVL(n).ne.0) nphylvl=nphylvl+1 ACC_UTFLLDLVL(n)=nphylvl*min(1,ACC_UTFLLDLVL(n)) if (ACC_USFLTDLVL(n).ne.0) nphylvl=nphylvl+1 ACC_USFLTDLVL(n)=nphylvl*min(1,ACC_USFLTDLVL(n)) + if (ACC_USFLSMLVL(n).ne.0) nphylvl=nphylvl+1 + ACC_USFLSMLVL(n)=nphylvl*min(1,ACC_USFLSMLVL(n)) if (ACC_USFLLDLVL(n).ne.0) nphylvl=nphylvl+1 ACC_USFLLDLVL(n)=nphylvl*min(1,ACC_USFLLDLVL(n)) if (ACC_UVELLVL(n).ne.0) nphylvl=nphylvl+1 @@ -853,12 +903,18 @@ subroutine diaini ACC_VSFLXLVL(n)=nphylvl*min(1,ACC_VSFLXLVL(n)) if (ACC_VMFLTDLVL(n).ne.0) nphylvl=nphylvl+1 ACC_VMFLTDLVL(n)=nphylvl*min(1,ACC_VMFLTDLVL(n)) + if (ACC_VMFLSMLVL(n).ne.0) nphylvl=nphylvl+1 + ACC_VMFLSMLVL(n)=nphylvl*min(1,ACC_VMFLSMLVL(n)) if (ACC_VTFLTDLVL(n).ne.0) nphylvl=nphylvl+1 ACC_VTFLTDLVL(n)=nphylvl*min(1,ACC_VTFLTDLVL(n)) + if (ACC_VTFLSMLVL(n).ne.0) nphylvl=nphylvl+1 + ACC_VTFLSMLVL(n)=nphylvl*min(1,ACC_VTFLSMLVL(n)) if (ACC_VTFLLDLVL(n).ne.0) nphylvl=nphylvl+1 ACC_VTFLLDLVL(n)=nphylvl*min(1,ACC_VTFLLDLVL(n)) if (ACC_VSFLTDLVL(n).ne.0) nphylvl=nphylvl+1 ACC_VSFLTDLVL(n)=nphylvl*min(1,ACC_VSFLTDLVL(n)) + if (ACC_VSFLSMLVL(n).ne.0) nphylvl=nphylvl+1 + ACC_VSFLSMLVL(n)=nphylvl*min(1,ACC_VSFLSMLVL(n)) if (ACC_VSFLLDLVL(n).ne.0) nphylvl=nphylvl+1 ACC_VSFLLDLVL(n)=nphylvl*min(1,ACC_VSFLLDLVL(n)) if (ACC_VVELLVL(n).ne.0) nphylvl=nphylvl+1 @@ -1443,15 +1499,24 @@ subroutine diaacc(m,n,mm,nn,k1m,k1n) c --- u-component of mass flux due to thickness diffusion [g*cm/s^2] call acclyr(ACC_UMFLTD,umfltd(1-nbdy,1-nbdy,k1n),dummy,0,'u') c +c --- u-component of mass flux due to submesoscale transport [g*cm/s^2] + call acclyr(ACC_UMFLSM,umflsm(1-nbdy,1-nbdy,k1n),dummy,0,'u') +c c --- u-component of heat flux due to thickness diffusion [K*g*cm/s^2] call acclyr(ACC_UTFLTD,utfltd(1-nbdy,1-nbdy,k1n),dummy,0,'u') c +c --- u-component of heat flux due to submesoscale transport [K*g*cm/s^2] + call acclyr(ACC_UTFLSM,utflsm(1-nbdy,1-nbdy,k1n),dummy,0,'u') +c c --- u-component of heat flux due to lateral diffusion [K*g*cm/s^2] call acclyr(ACC_UTFLLD,utflld(1-nbdy,1-nbdy,k1n),dummy,0,'u') c c --- u-component of salt flux due to thickness diffusion [g^2*cm/kg/s^2] call acclyr(ACC_USFLTD,usfltd(1-nbdy,1-nbdy,k1n),dummy,0,'u') c +c --- u-component of salt flux due to submesoscale transport [g^2*cm/kg/s^2] + call acclyr(ACC_USFLSM,usflsm(1-nbdy,1-nbdy,k1n),dummy,0,'u') +c c --- u-component of salt flux due to lateral diffusion [g^2*cm/kg/s^2] call acclyr(ACC_USFLLD,usflld(1-nbdy,1-nbdy,k1n),dummy,0,'u') c @@ -1473,15 +1538,24 @@ subroutine diaacc(m,n,mm,nn,k1m,k1n) c --- v-component of mass flux due to thickness diffusion [g*cm/s^2] call acclyr(ACC_VMFLTD,vmfltd(1-nbdy,1-nbdy,k1n),dummy,0,'v') c +c --- v-component of mass flux due to submesoscale transport [g*cm/s^2] + call acclyr(ACC_VMFLSM,vmflsm(1-nbdy,1-nbdy,k1n),dummy,0,'v') +c c --- v-component of heat flux due to thickness diffusion [K*g*cm/s^2] call acclyr(ACC_VTFLTD,vtfltd(1-nbdy,1-nbdy,k1n),dummy,0,'v') c +c --- v-component of heat flux due to submesoscale transport [K*g*cm/s^2] + call acclyr(ACC_VTFLSM,vtflsm(1-nbdy,1-nbdy,k1n),dummy,0,'v') +c c --- v-component of heat flux due to lateral diffusion [K*g*cm/s^2] call acclyr(ACC_VTFLLD,vtflld(1-nbdy,1-nbdy,k1n),dummy,0,'v') c c --- v-component of salt flux due to thickness diffusion [g^2*cm/kg/s^2] call acclyr(ACC_VSFLTD,vsfltd(1-nbdy,1-nbdy,k1n),dummy,0,'v') c +c --- v-component of salt flux due to submesoscale transport [g^2*cm/kg/s^2] + call acclyr(ACC_VSFLSM,vsflsm(1-nbdy,1-nbdy,k1n),dummy,0,'v') +c c --- v-component of salt flux due to lateral diffusion [g^2*cm/kg/s^2] call acclyr(ACC_VSFLLD,vsflld(1-nbdy,1-nbdy,k1n),dummy,0,'v') c @@ -1564,11 +1638,12 @@ subroutine diaacc(m,n,mm,nn,k1m,k1n) endif enddo c - if (sum(ACC_UVELLVL(1:nphy)+ACC_UFLXLVL(1:nphy)+ - . ACC_UTFLXLVL(1:nphy)+ACC_USFLXLVL(1:nphy)+ - . ACC_UMFLTDLVL(1:nphy)+ACC_UTFLTDLVL(1:nphy)+ - . ACC_UTFLLDLVL(1:nphy)+ACC_USFLTDLVL(1:nphy)+ - . ACC_USFLLDLVL(1:nphy)).ne.0) then + if (sum(ACC_UVELLVL (1:nphy)+ACC_UFLXLVL (1:nphy) + . +ACC_UTFLXLVL (1:nphy)+ACC_USFLXLVL (1:nphy) + . +ACC_UMFLTDLVL(1:nphy)+ACC_UMFLSMLVL(1:nphy) + . +ACC_UTFLTDLVL(1:nphy)+ACC_UTFLSMLVL(1:nphy) + . +ACC_UTFLLDLVL(1:nphy)+ACC_USFLTDLVL(1:nphy) + . +ACC_USFLSMLVL(1:nphy)+ACC_USFLLDLVL(1:nphy)).ne.0) then do k=1,kk call diazlv('u',k,mm,nn,ind1,ind2,wghts,wghtsflx) c @@ -1591,10 +1666,18 @@ subroutine diaacc(m,n,mm,nn,k1m,k1n) call acclvl(ACC_UMFLTDLVL,umfltd(1-nbdy,1-nbdy,k1n), . 'u',k,ind1,ind2,wghtsflx) c +c --- --- u-component of mass flux due to submesoscale transport [g*cm/s^2] + call acclvl(ACC_UMFLSMLVL,umflsm(1-nbdy,1-nbdy,k1n), + . 'u',k,ind1,ind2,wghtsflx) +c c --- --- u-component of heat flux due to thickness diffusion [K*g*cm/s^2] call acclvl(ACC_UTFLTDLVL,utfltd(1-nbdy,1-nbdy,k1n), . 'u',k,ind1,ind2,wghtsflx) c +c --- --- u-component of heat flux due to submesoscale transport [K*g*cm/s^2] + call acclvl(ACC_UTFLSMLVL,utflsm(1-nbdy,1-nbdy,k1n), + . 'u',k,ind1,ind2,wghtsflx) +c c --- --- u-component of heat flux due to lateral diffusion [K*g*cm/s^2] call acclvl(ACC_UTFLLDLVL,utflld(1-nbdy,1-nbdy,k1n), . 'u',k,ind1,ind2,wghtsflx) @@ -1603,17 +1686,22 @@ subroutine diaacc(m,n,mm,nn,k1m,k1n) call acclvl(ACC_USFLTDLVL,usfltd(1-nbdy,1-nbdy,k1n), . 'u',k,ind1,ind2,wghtsflx) c +c --- --- u-component of salt flux due to submesoscale transport [g^2*cm/kg/s^2] + call acclvl(ACC_USFLSMLVL,usflsm(1-nbdy,1-nbdy,k1n), + . 'u',k,ind1,ind2,wghtsflx) +c c --- --- u-component of salt flux due to lateral diffusion [g^2*cm/kg/s^2] call acclvl(ACC_USFLLDLVL,usflld(1-nbdy,1-nbdy,k1n), . 'u',k,ind1,ind2,wghtsflx) enddo endif c - if (sum(ACC_VVELLVL(1:nphy)+ACC_VFLXLVL(1:nphy)+ - . ACC_VTFLXLVL(1:nphy)+ACC_VSFLXLVL(1:nphy)+ - . ACC_VMFLTDLVL(1:nphy)+ACC_VTFLTDLVL(1:nphy)+ - . ACC_VTFLLDLVL(1:nphy)+ACC_VSFLTDLVL(1:nphy)+ - . ACC_VSFLLDLVL(1:nphy)).ne.0) then + if (sum(ACC_VVELLVL (1:nphy)+ACC_VFLXLVL (1:nphy) + . +ACC_VTFLXLVL (1:nphy)+ACC_VSFLXLVL (1:nphy) + . +ACC_VMFLTDLVL(1:nphy)+ACC_VMFLSMLVL(1:nphy) + . +ACC_VTFLTDLVL(1:nphy)+ACC_VTFLSMLVL(1:nphy) + . +ACC_VTFLLDLVL(1:nphy)+ACC_VSFLTDLVL(1:nphy) + . +ACC_VSFLSMLVL(1:nphy)+ACC_VSFLLDLVL(1:nphy)).ne.0) then do k=1,kk call diazlv('v',k,mm,nn,ind1,ind2,wghts,wghtsflx) c @@ -1636,10 +1724,18 @@ subroutine diaacc(m,n,mm,nn,k1m,k1n) call acclvl(ACC_VMFLTDLVL,vmfltd(1-nbdy,1-nbdy,k1n), . 'v',k,ind1,ind2,wghtsflx) c +c --- --- v-component of mass flux due to submesoscale transport [g*cm/s^2] + call acclvl(ACC_VMFLSMLVL,vmflsm(1-nbdy,1-nbdy,k1n), + . 'v',k,ind1,ind2,wghtsflx) +c c --- --- v-component of heat flux due to thickness diffusion [K*g*cm/s^2] call acclvl(ACC_VTFLTDLVL,vtfltd(1-nbdy,1-nbdy,k1n), . 'v',k,ind1,ind2,wghtsflx) c +c --- --- v-component of heat flux due to submesoscale transport [K*g*cm/s^2] + call acclvl(ACC_VTFLSMLVL,vtflsm(1-nbdy,1-nbdy,k1n), + . 'v',k,ind1,ind2,wghtsflx) +c c --- --- v-component of heat flux due to lateral diffusion [K*g*cm/s^2] call acclvl(ACC_VTFLLDLVL,vtflld(1-nbdy,1-nbdy,k1n), . 'v',k,ind1,ind2,wghtsflx) @@ -1648,6 +1744,10 @@ subroutine diaacc(m,n,mm,nn,k1m,k1n) call acclvl(ACC_VSFLTDLVL,vsfltd(1-nbdy,1-nbdy,k1n), . 'v',k,ind1,ind2,wghtsflx) c +c --- --- v-component of salt flux due to submesoscale transport [g^2*cm/kg/s^2] + call acclvl(ACC_VSFLSMLVL,vsflsm(1-nbdy,1-nbdy,k1n), + . 'v',k,ind1,ind2,wghtsflx) +c c --- --- v-component of salt flux due to lateral diffusion [g^2*cm/kg/s^2] call acclvl(ACC_VSFLLDLVL,vsflld(1-nbdy,1-nbdy,k1n), . 'v',k,ind1,ind2,wghtsflx) @@ -1769,9 +1869,10 @@ subroutine diaout(iogrp,m,n,mm,nn,k1m,k1n) c c --- compute meridional transports and transports through sections if (ACC_MMFLXL(iogrp)+ACC_MMFLXD(iogrp)+ACC_MMFTDL(iogrp) - . +ACC_MMFTDD(iogrp)+ACC_MHFLX(iogrp)+ACC_MHFTD(iogrp) - . +ACC_MHFLD(iogrp)+ACC_MSFLX(iogrp)+ACC_MSFTD(iogrp) - . +ACC_MSFLD(iogrp).ne.0) call diamer(iogrp) + . +ACC_MMFSML(iogrp)+ACC_MMFTDD(iogrp)+ACC_MMFSMD(iogrp) + . +ACC_MHFLX (iogrp)+ACC_MHFTD (iogrp)+ACC_MHFSM (iogrp) + . +ACC_MHFLD (iogrp)+ACC_MSFLX (iogrp)+ACC_MSFTD (iogrp) + . +ACC_MSFSM (iogrp) +ACC_MSFLD(iogrp).ne.0) call diamer(iogrp) if (ACC_VOLTR(iogrp).ne.0) call diasec(iogrp) c c --- compute barotropic mass streamfunction @@ -2058,12 +2159,18 @@ subroutine diaout(iogrp,m,n,mm,nn,k1m,k1n) call msklvl(ACC_VSFLXLVL(iogrp),'v') call msklvl(ACC_UMFLTDLVL(iogrp),'u') call msklvl(ACC_VMFLTDLVL(iogrp),'v') + call msklvl(ACC_UMFLSMLVL(iogrp),'u') + call msklvl(ACC_VMFLSMLVL(iogrp),'v') call msklvl(ACC_UTFLTDLVL(iogrp),'u') call msklvl(ACC_VTFLTDLVL(iogrp),'v') + call msklvl(ACC_UTFLSMLVL(iogrp),'u') + call msklvl(ACC_VTFLSMLVL(iogrp),'v') call msklvl(ACC_UTFLLDLVL(iogrp),'u') call msklvl(ACC_VTFLLDLVL(iogrp),'v') call msklvl(ACC_USFLTDLVL(iogrp),'u') call msklvl(ACC_VSFLTDLVL(iogrp),'v') + call msklvl(ACC_USFLSMLVL(iogrp),'u') + call msklvl(ACC_VSFLSMLVL(iogrp),'v') call msklvl(ACC_USFLLDLVL(iogrp),'u') call msklvl(ACC_VSFLLDLVL(iogrp),'v') call msklvl(ACC_SALNLVL(iogrp),'p') @@ -2164,16 +2271,17 @@ subroutine diaout(iogrp,m,n,mm,nn,k1m,k1n) call ncdims('time',0) c if (ACC_MMFLXL(iogrp)+ACC_MMFLXD(iogrp)+ACC_MMFTDL(iogrp) - . +ACC_MMFTDD(iogrp)+ACC_MHFLX(iogrp)+ACC_MHFTD(iogrp) - . +ACC_MHFLD(iogrp)+ACC_MSFLX(iogrp)+ACC_MSFTD(iogrp) - . +ACC_MSFLD(iogrp)+MSC_VOLTR(iogrp).ne.0) then - call ncdims('slenmax',slenmax) - endif + . +ACC_MMFSML(iogrp)+ACC_MMFTDD(iogrp)+ACC_MMFSMD(iogrp) + . +ACC_MHFLX (iogrp)+ACC_MHFTD (iogrp)+ACC_MHFSM (iogrp) + . +ACC_MHFLD (iogrp)+ACC_MSFLX (iogrp)+ACC_MSFTD (iogrp) + . +ACC_MSFSM (iogrp)+ACC_MSFLD (iogrp)+MSC_VOLTR (iogrp).ne.0) + . call ncdims('slenmax',slenmax) c if (ACC_MMFLXL(iogrp)+ACC_MMFLXD(iogrp)+ACC_MMFTDL(iogrp) - . +ACC_MMFTDD(iogrp)+ACC_MHFLX(iogrp)+ACC_MHFTD(iogrp) - . +ACC_MHFLD(iogrp)+ACC_MSFLX(iogrp)+ACC_MSFTD(iogrp) - . +ACC_MSFLD(iogrp).ne.0) then + . +ACC_MMFSML(iogrp)+ACC_MMFTDD(iogrp)+ACC_MMFSMD(iogrp) + . +ACC_MHFLX (iogrp)+ACC_MHFTD (iogrp)+ACC_MHFSM (iogrp) + . +ACC_MHFLD (iogrp)+ACC_MSFLX (iogrp)+ACC_MSFTD (iogrp) + . +ACC_MSFSM (iogrp)+ACC_MSFLD (iogrp).ne.0) then if ((lmax.gt.0.and.lmax.le.ldm)) then call ncdims('lat',lmax) call ncdims('region',mer_nreg) @@ -2217,9 +2325,10 @@ subroutine diaout(iogrp,m,n,mm,nn,k1m,k1n) call ncattr('bounds','depth_bnds') call ncwrt1('depth_bnds','bounds depth',depthslev_bnds) if (MSC_MMFLXL(iogrp)+MSC_MMFLXD(iogrp)+MSC_MMFTDL(iogrp) - . +MSC_MMFTDD(iogrp)+MSC_MHFLX(iogrp)+MSC_MHFTD(iogrp) - . +MSC_MHFLD(iogrp)+MSC_MSFLX(iogrp)+MSC_MSFTD(iogrp) - . +MSC_MSFLD(iogrp).ne.0) then + . +MSC_MMFSML(iogrp)+MSC_MMFTDD(iogrp)+MSC_MMFSMD(iogrp) + . +MSC_MHFLX (iogrp)+MSC_MHFTD (iogrp)+MSC_MHFSM (iogrp) + . +MSC_MHFLD (iogrp)+MSC_MSFLX (iogrp)+MSC_MSFTD (iogrp) + . +MSC_MSFSM (iogrp)+MSC_MSFLD (iogrp).ne.0) then call ncwrt1('lat','lat',mtlat) call ncattr('long_name','Latitude') call ncattr('standard_name','latitude') @@ -2516,6 +2625,16 @@ subroutine diaout(iogrp,m,n,mm,nn,k1m,k1n) . rnacc*0.5*M_cgs2mks/(g*baclin),0.,cmpflg,ivv,'v','vmfltd', . 'Mass flux due to thickness diffusion in y-direction',' ', . 'kg s-1') +c + call wrtlyr(ACC_UMFLSM(iogrp),LYR_UMFLSM(iogrp), + . rnacc*0.5*M_cgs2mks/(g*baclin),0.,cmpflg,iuu,'u','umflsm', + . 'Mass flux due to submesoscale transport in x-direction',' ', + . 'kg s-1') +c + call wrtlyr(ACC_VMFLSM(iogrp),LYR_VMFLSM(iogrp), + . rnacc*0.5*M_cgs2mks/(g*baclin),0.,cmpflg,ivv,'v','vmflsm', + . 'Mass flux due to submesoscale transport in y-direction',' ', + . 'kg s-1') c call wrtlyr(ACC_UTFLTD(iogrp),LYR_UTFLTD(iogrp), . rnacc*spcifh*0.5/(g*baclin),0.,cmpflg,iuu,'u','uhfltd', @@ -2526,6 +2645,16 @@ subroutine diaout(iogrp,m,n,mm,nn,k1m,k1n) . rnacc*spcifh*0.5/(g*baclin),0.,cmpflg,ivv,'v','vhfltd', . 'Heat flux due to thickness diffusion in y-direction',' ', . 'W') +c + call wrtlyr(ACC_UTFLSM(iogrp),LYR_UTFLSM(iogrp), + . rnacc*spcifh*0.5/(g*baclin),0.,cmpflg,iuu,'u','uhflsm', + . 'Heat flux due to submesoscale transport in x-direction',' ', + . 'W') +c + call wrtlyr(ACC_VTFLSM(iogrp),LYR_VTFLSM(iogrp), + . rnacc*spcifh*0.5/(g*baclin),0.,cmpflg,ivv,'v','vhflsm', + . 'Heat flux due to submesoscale transport in y-direction',' ', + . 'W') c call wrtlyr(ACC_UTFLLD(iogrp),LYR_UTFLLD(iogrp), . rnacc*spcifh*0.5/(g*baclin),0.,cmpflg,iuu,'u','uhflld', @@ -2546,6 +2675,16 @@ subroutine diaout(iogrp,m,n,mm,nn,k1m,k1n) . rnacc*0.5*g2kg*M_cgs2mks/(g*baclin),0.,cmpflg,ivv,'v','vsfltd', . 'Salt flux due to thickness diffusion in y-direction',' ', . 'kg s-1') +c + call wrtlyr(ACC_USFLSM(iogrp),LYR_USFLSM(iogrp), + . rnacc*0.5*g2kg*M_cgs2mks/(g*baclin),0.,cmpflg,iuu,'u','usflsm', + . 'Salt flux due to submesoscale transport in x-direction',' ', + . 'kg s-1') +c + call wrtlyr(ACC_VSFLSM(iogrp),LYR_VSFLSM(iogrp), + . rnacc*0.5*g2kg*M_cgs2mks/(g*baclin),0.,cmpflg,ivv,'v','vsflsm', + . 'Salt flux due to submesoscale transport in y-direction',' ', + . 'kg s-1') c call wrtlyr(ACC_USFLLD(iogrp),LYR_USFLLD(iogrp), . rnacc*0.5*g2kg*M_cgs2mks/(g*baclin),0.,cmpflg,iuu,'u','usflld', @@ -2697,6 +2836,16 @@ subroutine diaout(iogrp,m,n,mm,nn,k1m,k1n) . rnacc*0.5*M_cgs2mks/(g*baclin),0.,cmpflg,ivv,'v','vmfltdlvl', . 'Mass flux due to thickness diffusion in y-direction',' ', . 'kg s-1') +c + call wrtlvl(ACC_UMFLSMLVL(iogrp),LVL_UMFLSM(iogrp), + . rnacc*0.5*M_cgs2mks/(g*baclin),0.,cmpflg,iuu,'u','umflsmlvl', + . 'Mass flux due to submesoscale transport in x-direction',' ', + . 'kg s-1') +c + call wrtlvl(ACC_VMFLSMLVL(iogrp),LVL_VMFLSM(iogrp), + . rnacc*0.5*M_cgs2mks/(g*baclin),0.,cmpflg,ivv,'v','vmflsmlvl', + . 'Mass flux due to submesoscale transport in y-direction',' ', + . 'kg s-1') c call wrtlvl(ACC_UTFLTDLVL(iogrp),LVL_UTFLTD(iogrp), . rnacc*spcifh*0.5/(g*baclin),0.,cmpflg,iuu,'u','uhfltdlvl', @@ -2707,6 +2856,16 @@ subroutine diaout(iogrp,m,n,mm,nn,k1m,k1n) . rnacc*spcifh*0.5/(g*baclin),0.,cmpflg,ivv,'v','vhfltdlvl', . 'Heat flux due to thickness diffusion in y-direction',' ', . 'W') +c + call wrtlvl(ACC_UTFLSMLVL(iogrp),LVL_UTFLSM(iogrp), + . rnacc*spcifh*0.5/(g*baclin),0.,cmpflg,iuu,'u','uhflsmlvl', + . 'Heat flux due to submesoscale transport in x-direction',' ', + . 'W') +c + call wrtlvl(ACC_VTFLSMLVL(iogrp),LVL_VTFLSM(iogrp), + . rnacc*spcifh*0.5/(g*baclin),0.,cmpflg,ivv,'v','vhflsmlvl', + . 'Heat flux due to submesoscale transport in y-direction',' ', + . 'W') c call wrtlvl(ACC_UTFLLDLVL(iogrp),LVL_UTFLLD(iogrp), . rnacc*spcifh*0.5/(g*baclin),0.,cmpflg,iuu,'u','uhflldlvl', @@ -2729,6 +2888,18 @@ subroutine diaout(iogrp,m,n,mm,nn,k1m,k1n) . 'v','vsfltdlvl', . 'Salt flux due to thickness diffusion in y-direction',' ', . 'kg s-1') +c + call wrtlvl(ACC_USFLSMLVL(iogrp),LVL_USFLSM(iogrp), + . rnacc*0.5*g2kg*M_cgs2mks/(g*baclin),0.,cmpflg,iuu, + . 'u','usflsmlvl', + . 'Salt flux due to submesoscale transport in x-direction',' ', + . 'kg s-1') +c + call wrtlvl(ACC_VSFLSMLVL(iogrp),LVL_VSFLSM(iogrp), + . rnacc*0.5*g2kg*M_cgs2mks/(g*baclin),0.,cmpflg,ivv, + . 'v','vsflsmlvl', + . 'Salt flux due to submesoscale transport in y-direction',' ', + . 'kg s-1') c call wrtlvl(ACC_USFLLDLVL(iogrp),LVL_USFLLD(iogrp), . rnacc*0.5*g2kg*M_cgs2mks/(g*baclin),0.,cmpflg,iuu, @@ -2846,6 +3017,13 @@ subroutine diaout(iogrp,m,n,mm,nn,k1m,k1n) call ncwrt1('mmftdl','lat sigma region time',mmftdl) call ncattr('long_name', . 'Overturning stream-function due to thickness diffusion '// + . 'on isopycnic layers') + call ncattr('units','kg s-1') + endif + if (MSC_MMFSML(iogrp).ne.0) then + call ncwrt1('mmfsml','lat sigma region time',mmfsml) + call ncattr('long_name', + . 'Overturning stream-function due to submesoscale transport '// . 'on isopycnic layers') call ncattr('units','kg s-1') endif @@ -2853,6 +3031,13 @@ subroutine diaout(iogrp,m,n,mm,nn,k1m,k1n) call ncwrt1('mmftdd','lat depth region time',mmftdd) call ncattr('long_name', . 'Overturning stream-function due to thickness diffusion '// + . 'on z-levels') + call ncattr('units','kg s-1') + endif + if (MSC_MMFSMD(iogrp).ne.0) then + call ncwrt1('mmfsmd','lat depth region time',mmfsmd) + call ncattr('long_name', + . 'Overturning stream-function due to submesoscale transport '// . 'on z-levels') call ncattr('units','kg s-1') endif @@ -2867,6 +3052,12 @@ subroutine diaout(iogrp,m,n,mm,nn,k1m,k1n) . 'Meridional heat flux due to thickness diffusion') call ncattr('units','W') endif + if (MSC_MHFSM(iogrp).ne.0) then + call ncwrt1('mhfsm','lat region time',mhfsm) + call ncattr('long_name', + . 'Meridional heat flux due to submesoscale transport') + call ncattr('units','W') + endif if (MSC_MHFLD(iogrp).ne.0) then call ncwrt1('mhfld','lat region time',mhfld) call ncattr('long_name', @@ -2884,6 +3075,12 @@ subroutine diaout(iogrp,m,n,mm,nn,k1m,k1n) . 'Meridional salt flux due to thickness diffusion') call ncattr('units','kg s-1') endif + if (MSC_MSFSM(iogrp).ne.0) then + call ncwrt1('msfsm','lat region time',msfsm) + call ncattr('long_name', + . 'Meridional salt flux due to submesoscale transport') + call ncattr('units','kg s-1') + endif if (MSC_MSFLD(iogrp).ne.0) then call ncwrt1('msfld','lat region time',msfld) call ncattr('long_name', @@ -3342,10 +3539,12 @@ subroutine diamer(iogrp) c c --- - Allocate arrays for meridional fluxes allocate(mmflxl(lmax,kdm,mer_nreg),mmftdl(lmax,kdm,mer_nreg), - . mmflxd(lmax,ddm,mer_nreg),mmftdd(lmax,ddm,mer_nreg), + . mmfsml(lmax,kdm,mer_nreg),mmflxd(lmax,ddm,mer_nreg), + . mmftdd(lmax,ddm,mer_nreg),mmfsmd(lmax,ddm,mer_nreg), . mhflx(lmax,mer_nreg),mhftd(lmax,mer_nreg), - . mhfld(lmax,mer_nreg),msflx(lmax,mer_nreg), - . msftd(lmax,mer_nreg),msfld(lmax,mer_nreg), + . mhfsm(lmax,mer_nreg),mhfld(lmax,mer_nreg), + . msflx(lmax,mer_nreg),msftd(lmax,mer_nreg), + . msfsm(lmax,mer_nreg),msfld(lmax,mer_nreg), . stat=istat) if (istat.ne.0) then write (lp,*) 'Cannot allocate enough memory!' @@ -3366,35 +3565,45 @@ subroutine diamer(iogrp) enddo c$OMP END PARALLEL DO c - do nfld=1,6 + do nfld=1,8 c if (nfld.eq.1) then - if (ACC_MHFLX(iogrp).eq.0) exit + if (ACC_MHFLX(iogrp).eq.0) cycle ACC_UIND=ACC_UTFLX(iogrp) ACC_VIND=ACC_VTFLX(iogrp) r=spcifh*0.5/(g*baclin*nacc_phy(iogrp)) elseif (nfld.eq.2) then - if (ACC_MHFTD(iogrp).eq.0) exit + if (ACC_MHFTD(iogrp).eq.0) cycle ACC_UIND=ACC_UTFLTD(iogrp) ACC_VIND=ACC_VTFLTD(iogrp) r=spcifh*0.5/(g*baclin*nacc_phy(iogrp)) elseif (nfld.eq.3) then - if (ACC_MHFLD(iogrp).eq.0) exit + if (ACC_MHFSM(iogrp).eq.0) cycle + ACC_UIND=ACC_UTFLSM(iogrp) + ACC_VIND=ACC_VTFLSM(iogrp) + r=spcifh*0.5/(g*baclin*nacc_phy(iogrp)) + elseif (nfld.eq.4) then + if (ACC_MHFLD(iogrp).eq.0) cycle ACC_UIND=ACC_UTFLLD(iogrp) ACC_VIND=ACC_VTFLLD(iogrp) r=spcifh*0.5/(g*baclin*nacc_phy(iogrp)) - elseif (nfld.eq.4) then - if (ACC_MSFLX(iogrp).eq.0) exit + elseif (nfld.eq.5) then + if (ACC_MSFLX(iogrp).eq.0) cycle ACC_UIND=ACC_USFLX(iogrp) ACC_VIND=ACC_VSFLX(iogrp) r=0.5*g2kg*M_cgs2mks/(g*baclin*nacc_phy(iogrp)) - elseif (nfld.eq.5) then - if (ACC_MSFTD(iogrp).eq.0) exit + elseif (nfld.eq.6) then + if (ACC_MSFTD(iogrp).eq.0) cycle ACC_UIND=ACC_USFLTD(iogrp) ACC_VIND=ACC_VSFLTD(iogrp) r=0.5*g2kg*M_cgs2mks/(g*baclin*nacc_phy(iogrp)) - elseif (nfld.eq.6) then - if (ACC_MSFLD(iogrp).eq.0) exit + elseif (nfld.eq.7) then + if (ACC_MSFSM(iogrp).eq.0) cycle + ACC_UIND=ACC_USFLSM(iogrp) + ACC_VIND=ACC_VSFLSM(iogrp) + r=0.5*g2kg*M_cgs2mks/(g*baclin*nacc_phy(iogrp)) + elseif (nfld.eq.8) then + if (ACC_MSFLD(iogrp).eq.0) cycle ACC_UIND=ACC_USFLLD(iogrp) ACC_VIND=ACC_VSFLLD(iogrp) r=0.5*g2kg*M_cgs2mks/(g*baclin*nacc_phy(iogrp)) @@ -3490,22 +3699,34 @@ subroutine diamer(iogrp) elseif (nfld.eq.3) then do l=1,lmax do m=1,mer_nreg - mhfld(l,m)=mflx_mr(l,m) + mhfsm(l,m)=mflx_mr(l,m) enddo enddo elseif (nfld.eq.4) then do l=1,lmax do m=1,mer_nreg - msflx(l,m)=mflx_mr(l,m) + mhfld(l,m)=mflx_mr(l,m) enddo enddo elseif (nfld.eq.5) then do l=1,lmax do m=1,mer_nreg - msftd(l,m)=mflx_mr(l,m) + msflx(l,m)=mflx_mr(l,m) enddo enddo elseif (nfld.eq.6) then + do l=1,lmax + do m=1,mer_nreg + msftd(l,m)=mflx_mr(l,m) + enddo + enddo + elseif (nfld.eq.7) then + do l=1,lmax + do m=1,mer_nreg + msfsm(l,m)=mflx_mr(l,m) + enddo + enddo + elseif (nfld.eq.8) then do l=1,lmax do m=1,mer_nreg msfld(l,m)=mflx_mr(l,m) @@ -3560,16 +3781,20 @@ subroutine diamer(iogrp) c r=0.5*M_cgs2mks/(g*baclin*nacc_phy(iogrp)) c - do nfld=1,2 + do nfld=1,3 c if (nfld.eq.1) then - if (ACC_MMFLXL(iogrp).eq.0) exit + if (ACC_MMFLXL(iogrp).eq.0) cycle ACC_UIND=ACC_UFLX(iogrp) ACC_VIND=ACC_VFLX(iogrp) elseif (nfld.eq.2) then - if (ACC_MMFTDL(iogrp).eq.0) exit + if (ACC_MMFTDL(iogrp).eq.0) cycle ACC_UIND=ACC_UMFLTD(iogrp) ACC_VIND=ACC_VMFLTD(iogrp) + elseif (nfld.eq.3) then + if (ACC_MMFSML(iogrp).eq.0) cycle + ACC_UIND=ACC_UMFLSM(iogrp) + ACC_VIND=ACC_VMFLSM(iogrp) else write(lp,*) 'field index out of range' call xchalt('(diamer)') @@ -3682,6 +3907,12 @@ subroutine diamer(iogrp) mmftdl(l,k,m)=mflx_mr(l,m) enddo enddo + elseif (nfld.eq.3) then + do l=1,lmax + do m=1,mer_nreg + mmfsml(l,k,m)=mflx_mr(l,m) + enddo + enddo else write(lp,*) 'field index out of range' call xchalt('(diamer)') @@ -3725,16 +3956,20 @@ subroutine diamer(iogrp) c r=0.5*M_cgs2mks/(g*baclin*nacc_phy(iogrp)) c - do nfld=1,2 + do nfld=1,3 c if (nfld.eq.1) then - if (ACC_MMFLXD(iogrp).eq.0) exit + if (ACC_MMFLXD(iogrp).eq.0) cycle ACC_UIND=ACC_UFLXLVL(iogrp) ACC_VIND=ACC_VFLXLVL(iogrp) elseif (nfld.eq.2) then - if (ACC_MMFTDD(iogrp).eq.0) exit + if (ACC_MMFTDD(iogrp).eq.0) cycle ACC_UIND=ACC_UMFLTDLVL(iogrp) ACC_VIND=ACC_VMFLTDLVL(iogrp) + elseif (nfld.eq.3) then + if (ACC_MMFSMD(iogrp).eq.0) cycle + ACC_UIND=ACC_UMFLSMLVL(iogrp) + ACC_VIND=ACC_VMFLSMLVL(iogrp) else write(lp,*) 'field index out of range' call xchalt('(diamer)') @@ -3821,6 +4056,12 @@ subroutine diamer(iogrp) mmftdd(l,k,m)=mflx_mr(l,m) enddo enddo + elseif (nfld.eq.3) then + do l=1,lmax + do m=1,mer_nreg + mmfsmd(l,k,m)=mflx_mr(l,m) + enddo + enddo else write(lp,*) 'field index out of range' call xchalt('(diamer)') @@ -5187,9 +5428,12 @@ subroutine inifld(iogrp) call inilyr(ACC_UTFLX(iogrp),'u',0.) call inilyr(ACC_USFLX(iogrp),'u',0.) call inilyr(ACC_UMFLTD(iogrp),'u',0.) + call inilyr(ACC_UMFLSM(iogrp),'u',0.) call inilyr(ACC_UTFLTD(iogrp),'u',0.) + call inilyr(ACC_UTFLSM(iogrp),'u',0.) call inilyr(ACC_UTFLLD(iogrp),'u',0.) call inilyr(ACC_USFLTD(iogrp),'u',0.) + call inilyr(ACC_USFLSM(iogrp),'u',0.) call inilyr(ACC_USFLLD(iogrp),'u',0.) c call inilyr(ACC_VVEL(iogrp),'v',0.) @@ -5198,9 +5442,12 @@ subroutine inifld(iogrp) call inilyr(ACC_VTFLX(iogrp),'v',0.) call inilyr(ACC_VSFLX(iogrp),'v',0.) call inilyr(ACC_VMFLTD(iogrp),'v',0.) + call inilyr(ACC_VMFLSM(iogrp),'v',0.) call inilyr(ACC_VTFLTD(iogrp),'v',0.) + call inilyr(ACC_VTFLSM(iogrp),'v',0.) call inilyr(ACC_VTFLLD(iogrp),'v',0.) call inilyr(ACC_VSFLTD(iogrp),'v',0.) + call inilyr(ACC_VSFLSM(iogrp),'v',0.) call inilyr(ACC_VSFLLD(iogrp),'v',0.) c call inilyr(ACC_SALN(iogrp),'p',0.) @@ -5229,9 +5476,12 @@ subroutine inifld(iogrp) call inilvl(ACC_UTFLXLVL(iogrp),'u',0.) call inilvl(ACC_USFLXLVL(iogrp),'u',0.) call inilvl(ACC_UMFLTDLVL(iogrp),'u',0.) + call inilvl(ACC_UMFLSMLVL(iogrp),'u',0.) call inilvl(ACC_UTFLTDLVL(iogrp),'u',0.) + call inilvl(ACC_UTFLSMLVL(iogrp),'u',0.) call inilvl(ACC_UTFLLDLVL(iogrp),'u',0.) call inilvl(ACC_USFLTDLVL(iogrp),'u',0.) + call inilvl(ACC_USFLSMLVL(iogrp),'u',0.) call inilvl(ACC_USFLLDLVL(iogrp),'u',0.) c call inilvl(ACC_VVELLVL(iogrp),'v',0.) @@ -5239,9 +5489,12 @@ subroutine inifld(iogrp) call inilvl(ACC_VTFLXLVL(iogrp),'v',0.) call inilvl(ACC_VSFLXLVL(iogrp),'v',0.) call inilvl(ACC_VMFLTDLVL(iogrp),'v',0.) + call inilvl(ACC_VMFLSMLVL(iogrp),'v',0.) call inilvl(ACC_VTFLTDLVL(iogrp),'v',0.) + call inilvl(ACC_VTFLSMLVL(iogrp),'v',0.) call inilvl(ACC_VTFLLDLVL(iogrp),'v',0.) call inilvl(ACC_VSFLTDLVL(iogrp),'v',0.) + call inilvl(ACC_VSFLSMLVL(iogrp),'v',0.) call inilvl(ACC_VSFLLDLVL(iogrp),'v',0.) c call inilvl(ACC_BFSQLVL(iogrp),'p',0.) @@ -6035,9 +6288,10 @@ subroutine definevar(irec,iogrp,cmpflg,timeunits,calendar) call ncattr('bounds','depth_bnds') call ncdefvar('depth_bnds','bounds depth',ndouble,8) if (MSC_MMFLXL(iogrp)+MSC_MMFLXD(iogrp)+MSC_MMFTDL(iogrp) - . +MSC_MMFTDD(iogrp)+MSC_MHFLX(iogrp)+MSC_MHFTD(iogrp) - . +MSC_MHFLD(iogrp)+MSC_MSFLX(iogrp)+MSC_MSFTD(iogrp) - . +MSC_MSFLD(iogrp).ne.0) then + . +MSC_MMFSML(iogrp)+MSC_MMFTDD(iogrp)+MSC_MMFSMD(iogrp) + . +MSC_MHFLX (iogrp)+MSC_MHFTD (iogrp)+MSC_MHFSM (iogrp) + . +MSC_MHFLD (iogrp)+MSC_MSFLX (iogrp)+MSC_MSFTD (iogrp) + . +MSC_MSFSM (iogrp)+MSC_MSFLD (iogrp).ne.0) then call ncdefvar('lat','lat',ndouble,8) call ncattr('long_name','Latitude') call ncattr('standard_name','latitude') @@ -6292,6 +6546,14 @@ subroutine definevar(irec,iogrp,cmpflg,timeunits,calendar) call ncdefvar3d(LYR_VMFLTD(iogrp),cmpflg,'v','vmfltd', . 'Mass flux due to thickness diffusion in y-direction',' ', . 'kg s-1',1) +c + call ncdefvar3d(LYR_UMFLSM(iogrp),cmpflg,'u','umflsm', + . 'Mass flux due to submesoscale transport in x-direction',' ', + . 'kg s-1',1) +c + call ncdefvar3d(LYR_VMFLSM(iogrp),cmpflg,'v','vmflsm', + . 'Mass flux due to submesoscale transport in y-direction',' ', + . 'kg s-1',1) c call ncdefvar3d(LYR_UTFLTD(iogrp),cmpflg,'u','uhfltd', . 'Heat flux due to thickness diffusion in x-direction',' ', @@ -6300,6 +6562,14 @@ subroutine definevar(irec,iogrp,cmpflg,timeunits,calendar) call ncdefvar3d(LYR_VTFLTD(iogrp),cmpflg,'v','vhfltd', . 'Heat flux due to thickness diffusion in y-direction',' ', . 'W',1) +c + call ncdefvar3d(LYR_UTFLSM(iogrp),cmpflg,'u','uhflsm', + . 'Heat flux due to submesoscale transport in x-direction',' ', + . 'W',1) +c + call ncdefvar3d(LYR_VTFLSM(iogrp),cmpflg,'v','vhflsm', + . 'Heat flux due to submesoscale transport in y-direction',' ', + . 'W',1) c call ncdefvar3d(LYR_UTFLLD(iogrp),cmpflg,'u','uhflld', . 'Heat flux due to lateral diffusion in x-direction',' ', @@ -6316,6 +6586,14 @@ subroutine definevar(irec,iogrp,cmpflg,timeunits,calendar) call ncdefvar3d(LYR_VSFLTD(iogrp),cmpflg,'v','vsfltd', . 'Salt flux due to thickness diffusion in y-direction',' ', . 'W',1) +c + call ncdefvar3d(LYR_USFLSM(iogrp),cmpflg,'u','usflsm', + . 'Salt flux due to submesoscale transport in x-direction',' ', + . 'W',1) +c + call ncdefvar3d(LYR_VSFLSM(iogrp),cmpflg,'v','vsflsm', + . 'Salt flux due to submesoscale transport in y-direction',' ', + . 'W',1) c call ncdefvar3d(LYR_USFLLD(iogrp),cmpflg,'u','usflld', . 'Salt flux due to lateral diffusion in x-direction',' ', @@ -6435,6 +6713,14 @@ subroutine definevar(irec,iogrp,cmpflg,timeunits,calendar) call ncdefvar3d(LVL_VMFLTD(iogrp),cmpflg,'v','vmfltdlvl', . 'Mass flux due to thickness diffusion in y-direction',' ', . 'kg s-1',2) +c + call ncdefvar3d(LVL_UMFLSM(iogrp),cmpflg,'u','umflsmlvl', + . 'Mass flux due to submesoscale transport in x-direction',' ', + . 'kg s-1',2) +c + call ncdefvar3d(LVL_VMFLSM(iogrp),cmpflg,'v','vmflsmlvl', + . 'Mass flux due to submesoscale transport in y-direction',' ', + . 'kg s-1',2) c call ncdefvar3d(LVL_UTFLTD(iogrp),cmpflg,'u','uhfltdlvl', . 'Heat flux due to thickness diffusion in x-direction',' ', @@ -6443,6 +6729,14 @@ subroutine definevar(irec,iogrp,cmpflg,timeunits,calendar) call ncdefvar3d(LVL_VTFLTD(iogrp),cmpflg,'v','vhfltdlvl', . 'Heat flux due to thickness diffusion in y-direction',' ', . 'W',2) +c + call ncdefvar3d(LVL_UTFLSM(iogrp),cmpflg,'u','uhflsmlvl', + . 'Heat flux due to submesoscale transport in x-direction',' ', + . 'W',2) +c + call ncdefvar3d(LVL_VTFLSM(iogrp),cmpflg,'v','vhflsmlvl', + . 'Heat flux due to submesoscale transport in y-direction',' ', + . 'W',2) c call ncdefvar3d(LVL_UTFLLD(iogrp),cmpflg,'u','uhflldlvl', . 'Heat flux due to lateral diffusion in x-direction',' ', @@ -6459,6 +6753,14 @@ subroutine definevar(irec,iogrp,cmpflg,timeunits,calendar) call ncdefvar3d(LVL_VSFLTD(iogrp),cmpflg,'v','vsfltdlvl', . 'Salt flux due to thickness diffusion in y-direction',' ', . 'kg s-1',2) +c + call ncdefvar3d(LVL_USFLSM(iogrp),cmpflg,'u','usflsmlvl', + . 'Salt flux due to submesoscale transport in x-direction',' ', + . 'kg s-1',2) +c + call ncdefvar3d(LVL_VSFLSM(iogrp),cmpflg,'v','vsflsmlvl', + . 'Salt flux due to submesoscale transport in y-direction',' ', + . 'kg s-1',2) c call ncdefvar3d(LVL_USFLLD(iogrp),cmpflg,'u','usflldlvl', . 'Salt flux due to lateral diffusion in x-direction',' ', @@ -6554,6 +6856,13 @@ subroutine definevar(irec,iogrp,cmpflg,timeunits,calendar) call ncdefvar('mmftdl','lat sigma region time',ndouble,8) call ncattr('long_name', . 'Overturning stream-function due to thickness diffusion '// + . 'on isopycnic layers') + call ncattr('units','kg s-1') + endif + if (MSC_MMFSML(iogrp).ne.0) then + call ncdefvar('mmfsml','lat sigma region time',ndouble,8) + call ncattr('long_name', + . 'Overturning stream-function due to submesoscale transport '// . 'on isopycnic layers') call ncattr('units','kg s-1') endif @@ -6561,6 +6870,13 @@ subroutine definevar(irec,iogrp,cmpflg,timeunits,calendar) call ncdefvar('mmftdd','lat depth region time',ndouble,8) call ncattr('long_name', . 'Overturning stream-function due to thickness diffusion '// + . 'on z-levels') + call ncattr('units','kg s-1') + endif + if (MSC_MMFSMD(iogrp).ne.0) then + call ncdefvar('mmfsmd','lat depth region time',ndouble,8) + call ncattr('long_name', + . 'Overturning stream-function due to submesoscale transport '// . 'on z-levels') call ncattr('units','kg s-1') endif @@ -6575,6 +6891,12 @@ subroutine definevar(irec,iogrp,cmpflg,timeunits,calendar) . 'Meridional heat flux due to thickness diffusion') call ncattr('units','W') endif + if (MSC_MHFSM(iogrp).ne.0) then + call ncdefvar('mhfsm','lat region time',ndouble,8) + call ncattr('long_name', + . 'Meridional heat flux due to submesoscale transport') + call ncattr('units','W') + endif if (MSC_MHFLD(iogrp).ne.0) then call ncdefvar('mhfld','lat region time',ndouble,8) call ncattr('long_name', @@ -6592,6 +6914,12 @@ subroutine definevar(irec,iogrp,cmpflg,timeunits,calendar) . 'Meridional salt flux due to thickness diffusion') call ncattr('units','kg s-1') endif + if (MSC_MSFSM(iogrp).ne.0) then + call ncdefvar('msfsm','lat region time',ndouble,8) + call ncattr('long_name', + . 'Meridional salt flux due to submesoscale transport') + call ncattr('units','kg s-1') + endif if (MSC_MSFLD(iogrp).ne.0) then call ncdefvar('msfld','lat region time',ndouble,8) call ncattr('long_name', diff --git a/phy/mod_diffusion.F90 b/phy/mod_diffusion.F90 index 4f82d958..97aafb45 100644 --- a/phy/mod_diffusion.F90 +++ b/phy/mod_diffusion.F90 @@ -120,10 +120,18 @@ module mod_diffusion ! [g cm s-2]. vmfltd, & ! v-component of horizontal mass flux due to thickness diffusion ! [g cm s-2]. + umflsm, & ! u-component of horizontal mass flux due to submesoscale + ! eddy-induced transport [g cm s-2]. + vmflsm, & ! v-component of horizontal mass flux due to submesoscale + ! eddy-induced transport [g cm s-2]. utfltd, & ! u-component of horizontal heat flux due to thickness diffusion ! [K g cm s-2]. vtfltd, & ! v-component of horizontal heat flux due to thickness diffusion ! [K g cm s-2]. + utflsm, & ! u-component of horizontal heat flux due to submesoscale + ! eddy-induced transport [K g cm s-2]. + vtflsm, & ! v-component of horizontal heat flux due to submesoscale + ! eddy-induced transport [K g cm s-2]. utflld, & ! u-component of horizontal heat flux due to lateral diffusion ! [K g cm s-2]. vtflld, & ! v-component of horizontal heat flux due to lateral diffusion @@ -132,6 +140,10 @@ module mod_diffusion ! [g2 cm kg-1 s-2]. vsfltd, & ! v-component of horizontal salt flux due to thickness diffusion ! [g2 cm kg-1 s-2]. + usflsm, & ! u-component of horizontal salt flux due to submesoscale + ! eddy-induced transport [g2 cm kg-1 s-2]. + vsflsm, & ! v-component of horizontal salt flux due to submesoscale + ! eddy-induced transport [g2 cm kg-1 s-2]. usflld, & ! u-component of horizontal salt flux due to lateral diffusion ! [g2 cm kg-1 s-2]. vsflld ! v-component of horizontal salt flux due to lateral diffusion @@ -143,8 +155,9 @@ module mod_diffusion edwmth_opt, edwmth_smooth, edwmth_step, & ltedtp_opt, ltedtp_layer, ltedtp_neutral, & difint, difiso, difdia, difmxp, difmxq, difwgt, & - umfltd, vmfltd, utfltd, vtfltd, utflld, vtflld, & - usfltd, vsfltd, usflld, vsflld, & + umfltd, vmfltd, umflsm, vmflsm, & + utfltd, vtfltd, utflsm, vtflsm, utflld, vtflld, & + usfltd, vsfltd, usflsm, vsflsm, usflld, vsflld, & Kvisc_m, Kdiff_t, Kdiff_s, t_ns_nonloc, s_nonloc, & readnml_diffusion, inivar_diffusion @@ -308,12 +321,18 @@ subroutine inivar_diffusion do i = 1 - nbdy, ii + nbdy umfltd(i, j, k) = spval vmfltd(i, j, k) = spval + umflsm(i, j, k) = spval + vmflsm(i, j, k) = spval utfltd(i, j, k) = spval vtfltd(i, j, k) = spval + utflsm(i, j, k) = spval + vtflsm(i, j, k) = spval utflld(i, j, k) = spval vtflld(i, j, k) = spval usfltd(i, j, k) = spval vsfltd(i, j, k) = spval + usflsm(i, j, k) = spval + vsflsm(i, j, k) = spval usflld(i, j, k) = spval vsflld(i, j, k) = spval enddo @@ -350,9 +369,12 @@ subroutine inivar_diffusion do l = 1, isp(j) do i = max(1, ifp(j, l)), min(ii, ilp(j, l) + 1) umfltd(i, j, k) = 0._r8 + umflsm(i, j, k) = 0._r8 utfltd(i, j, k) = 0._r8 + utflsm(i, j, k) = 0._r8 utflld(i, j, k) = 0._r8 usfltd(i, j, k) = 0._r8 + usflsm(i, j, k) = 0._r8 usflld(i, j, k) = 0._r8 enddo enddo @@ -360,6 +382,7 @@ subroutine inivar_diffusion enddo !$omp end parallel do call xctilr(umfltd, 1, 2*kk, nbdy, nbdy, halo_us) + call xctilr(umflsm, 1, 2*kk, nbdy, nbdy, halo_us) call xctilr(utflld, 1, 2*kk, nbdy, nbdy, halo_us) call xctilr(usflld, 1, 2*kk, nbdy, nbdy, halo_us) @@ -371,9 +394,12 @@ subroutine inivar_diffusion do l = 1, jsp(i) do j = max(1, jfp(i, l)), min(jj, jlp(i, l) + 1) vmfltd(i, j, k) = 0._r8 + vmflsm(i, j, k) = 0._r8 vtfltd(i, j, k) = 0._r8 + vtflsm(i, j, k) = 0._r8 vtflld(i, j, k) = 0._r8 vsfltd(i, j, k) = 0._r8 + vsflsm(i, j, k) = 0._r8 vsflld(i, j, k) = 0._r8 enddo enddo @@ -381,6 +407,7 @@ subroutine inivar_diffusion enddo !$omp end parallel do call xctilr(vmfltd, 1, 2*kk, nbdy, nbdy, halo_vs) + call xctilr(vmflsm, 1, 2*kk, nbdy, nbdy, halo_vs) call xctilr(vtflld, 1, 2*kk, nbdy, nbdy, halo_vs) call xctilr(vsflld, 1, 2*kk, nbdy, nbdy, halo_vs) diff --git a/phy/mod_eddtra.F90 b/phy/mod_eddtra.F90 index 1490cf92..bb28175a 100644 --- a/phy/mod_eddtra.F90 +++ b/phy/mod_eddtra.F90 @@ -29,13 +29,16 @@ module mod_eddtra use mod_time, only: delt1 use mod_xc use mod_vcoord, only: vcoord_type_tag, isopyc_bulkml, cntiso_hybrid - use mod_grid, only: scuy, scvx, scp2, scu2, scv2, scuxi, scvyi - use mod_eos, only: rho + 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 use mod_diffusion, only: eitmth_opt, eitmth_intdif, eitmth_gm, & - difint, umfltd, vmfltd, utfltd, vtfltd, & - usfltd, vsfltd - use mod_cmnfld, only: nslpx, nslpy, mlts + difint, umfltd, vmfltd, umflsm, vmflsm, & + utfltd, vtfltd, utflsm, vtflsm, & + usfltd, vsfltd, usflsm, vsflsm + use mod_cmnfld, only: dbcrit, nslpx, nslpy, mlts + use mod_mxlayr, only: ce + use mod_utility, only: util1 use mod_checksum, only: csdiag, chksummsk implicit none @@ -66,23 +69,23 @@ subroutine eddtra_intdif_isopyc_bulkml(m, n, mm, nn, k1m, k1n) call xctilr(difint, 1,kk, 2,2, halo_ps) !$omp parallel do private(l, i) - do j = - 1, jj + 2 + do j = -1, jj+2 do l = 1, isu(j) - do i = max(0, ifu(j, l)), min(ii + 2, ilu(j, l)) - umfltd(i, j, 1 + mm) = 0._r8 - umfltd(i, j, 2 + mm) = 0._r8 - umfltd(i, j, 3 + mm) = 0._r8 + do i = max(0, ifu(j,l)), min(ii+2, ilu(j,l)) + umfltd(i,j,1+mm) = 0._r8 + umfltd(i,j,2+mm) = 0._r8 + umfltd(i,j,3+mm) = 0._r8 enddo enddo enddo !$omp end parallel do !$omp parallel do private(l, i) - do j = 0, jj + 2 + do j = 0, jj+2 do l = 1, isv(j) - do i = max(- 1, ifv(j, l)), min(ii + 2, ilv(j, l)) - vmfltd(i, j, 1 + mm) = 0._r8 - vmfltd(i, j, 2 + mm) = 0._r8 - vmfltd(i, j, 3 + mm) = 0._r8 + do i = max(-1, ifv(j,l)), min(ii+2, ilv(j,l)) + vmfltd(i,j,1+mm) = 0._r8 + vmfltd(i,j,2+mm) = 0._r8 + vmfltd(i,j,3+mm) = 0._r8 enddo enddo enddo @@ -93,40 +96,39 @@ subroutine eddtra_intdif_isopyc_bulkml(m, n, mm, nn, k1m, k1n) kn = k + nn !$omp parallel do private(l, i, flxhi, flxlo, q) - do j = - 1, jj + 2 + do j = -1, jj+2 do l = 1, isu(j) - do i = max(0, ifu(j, l)), min(ii + 2, ilu(j, l)) - flxhi = .125_r8*min(dp(i - 1, j, kn - 1)*scp2(i - 1, j), & - dp(i , j, kn )*scp2(i , j)) - flxlo = - .125_r8*min(dp(i , j, kn - 1)*scp2(i , j), & - dp(i - 1, j, kn )*scp2(i - 1, j)) - q = .25_r8*( difint(i - 1, j, k - 1) + difint(i, j, k - 1) & - + difint(i - 1, j, k ) + difint(i, j, k )) + do i = max(0, ifu(j,l)), min(ii+2, ilu(j,l)) + flxhi = .125_r8*min(dp(i-1,j,kn-1)*scp2(i-1,j), & + dp(i ,j,kn )*scp2(i ,j)) + flxlo = - .125_r8*min(dp(i ,j,kn-1)*scp2(i ,j), & + dp(i-1,j,kn )*scp2(i-1,j)) + q = .25_r8*( difint(i-1,j,k-1) + difint(i,j,k-1) & + + difint(i-1,j,k ) + difint(i,j,k )) q = min(flxhi, max(flxlo, & - delt1*q*(p(i - 1, j, k) - p(i, j, k)) & - *scuy(i, j)*scuxi(i, j))) - umfltd(i, j, km - 1) = umfltd(i, j, km - 1) + q - umfltd(i, j, km ) = - q + delt1*q*(p(i-1,j,k) - p(i,j,k))*scuy(i,j)*scuxi(i,j))) + umfltd(i,j,km-1) = umfltd(i,j,km-1) + q + umfltd(i,j,km ) = - q enddo enddo enddo !$omp end parallel do !$omp parallel do private(l, i, flxhi, flxlo, q) - do j = 0, jj + 2 + do j = 0, jj+2 do l = 1, isv(j) - do i = max(- 1, ifv(j, l)), min(ii + 2, ilv(j, l)) - flxhi = .125_r8*min(dp(i, j - 1, kn - 1)*scp2(i, j - 1), & - dp(i, j , kn )*scp2(i, j )) - flxlo = - .125_r8*min(dp(i, j , kn - 1)*scp2(i, j ), & - dp(i, j - 1, kn )*scp2(i, j - 1)) - q = .25_r8*( difint(i, j - 1, k - 1) + difint(i, j, k - 1) & - + difint(i, j - 1, k ) + difint(i, j, k )) + do i = max(-1, ifv(j,l)), min(ii+2, ilv(j,l)) + flxhi = .125_r8*min(dp(i,j-1,kn-1)*scp2(i,j-1), & + dp(i,j ,kn )*scp2(i,j )) + flxlo = - .125_r8*min(dp(i,j ,kn-1)*scp2(i,j ), & + dp(i,j-1,kn )*scp2(i,j-1)) + q = .25_r8*( difint(i,j-1,k-1) + difint(i,j,k-1) & + + difint(i,j-1,k ) + difint(i,j,k )) q = min(flxhi, max(flxlo, & - delt1*q*(p(i, j - 1, k) - p(i, j, k)) & - *scvx(i, j)*scvyi(i, j))) - vmfltd(i, j, km - 1) = vmfltd(i, j, km - 1) + q - vmfltd(i, j, km ) = - q + delt1*q*(p(i,j-1,k) - p(i,j,k)) & + *scvx(i,j)*scvyi(i,j))) + vmfltd(i,j,km-1) = vmfltd(i,j,km-1) + q + vmfltd(i,j,km ) = - q enddo enddo enddo @@ -146,9 +148,10 @@ subroutine eddtra_gm_isopyc_bulkml(m, n, mm, nn, k1m, k1n) ! Parameters: real(r8), parameter :: & - ffac = .0625_r8, & ! Fraction of the mass of a grid cell a mass flux - ! is allowed to deplete []. - fface = .99_r8*ffac ! (1-epsilon)*ffac []. + ffac = .0625_r8, & ! Fraction of the mass of a grid cell a mass + ! flux is allowed to deplete []. + fface = .99_r8*ffac, & ! (1-epsilon)*ffac []. + eps = 1.e-14_r8 ! Small non-dimensional value []. real(r8), dimension(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy) :: ptu, ptv real(r8), dimension(kdm+1) :: upsilon, mfl @@ -164,19 +167,19 @@ subroutine eddtra_gm_isopyc_bulkml(m, n, mm, nn, k1m, k1n) ! Compute top pressure at velocity points. !$omp parallel do private(l, i) - do j= - 1, jj + 2 + do j= -1, jj+2 do l = 1, isu(j) - do i = max(0, ifu(j, l)), min(ii + 2, ilu(j, l)) - ptu(i, j) = max(p(i - 1, j, 1), p(i, j, 1)) + do i = max(0, ifu(j,l)), min(ii+2, ilu(j,l)) + ptu(i,j) = max(p(i-1,j,1), p(i,j,1)) enddo enddo enddo !$omp end parallel do !$omp parallel do private(l, i) - do j = 0, jj + 2 + do j = 0, jj+2 do l = 1, isv(j) - do i = max(- 1, ifv(j, l)), min(ii + 2, ilv(j, l)) - ptv(i, j) = max(p(i, j - 1, 1), p(i, j, 1)) + do i = max(-1, ifv(j,l)), min(ii+2, ilv(j,l)) + ptv(i,j) = max(p(i,j-1,1), p(i,j,1)) enddo enddo enddo @@ -189,47 +192,46 @@ subroutine eddtra_gm_isopyc_bulkml(m, n, mm, nn, k1m, k1n) !$omp parallel do private(l, i, k, km, et2mf, kmax, kn, kintr, kappa, & !$omp upsilon, kmin, mfl, dlm, dlp, fhi, flo, changed, & !$omp niter, kdir, q) - do j = - 1, jj + 2 + do j = -1, jj+2 do l = 1, isu(j) - do i = max(0, ifu(j, l)), min(ii + 2, ilu(j, l)) + do i = max(0, ifu(j,l)), min(ii+2, ilu(j,l)) ! Set eddy-induced mass fluxes to zero initially. do k = 1, kk km = k + mm - umfltd(i, j, km) = 0._r8 + umfltd(i,j,km) = 0._r8 enddo ! Eddy transport to mass flux conversion factor. - et2mf = - g*rho0*delt1*scuy(i, j) + et2mf = - g*rho0*delt1*scuy(i,j) ! Index of last layer containing mass at either of the scalar points ! adjacent to the velocity point. kmax = 1 do k = 3, kk kn = k + nn - if (dp(i - 1, j, kn) > epsilp .or. dp(i, j, kn) > epsilp) & - kmax = k + if (dp(i-1,j,kn) > epsilp .or. dp(i,j,kn) > epsilp) kmax = k enddo ! ------------------------------------------------------------------ ! Proceed with mass flux computation if at least one of the adjacent ! scalar points to the velocity point has a mass containing interior ! layer. Mass fluxes will be assigned at layer interface - ! corresponding to the eddy induced transport. The final layer mass + ! corresponding to the eddy-induced transport. The final layer mass ! flux will be the lower minus the upper interface flux. The mass ! fluxes are limited to keep interfaces within the water column. ! There are 3 cases to consider: ! Case 1: The mixed layer extends to the bottom at both adjacent ! scalar points to the velocity point ! Case 2: The mixed layer extends to the bottom at scalar point - ! (i, j). + ! (i,j). ! Case 3: The mixed layer extends to the bottom at scalar point - ! (i - 1, j). + ! (i-1,j). ! Case 4: The mixed layer does not reach the bottom at neither of ! the scalar points adjacent to the velocity point. ! ------------------------------------------------------------------ - if (kfpla(i - 1, j, n) > kk .and. kfpla(i, j, n) > kk) then + if (kfpla(i-1,j,n) > kk .and. kfpla(i,j,n) > kk) then ! --------------------------------------------------------------- ! Case 1: ! --------------------------------------------------------------- @@ -237,21 +239,19 @@ subroutine eddtra_gm_isopyc_bulkml(m, n, mm, nn, k1m, k1n) ! Keep the initial zero mass fluxes for this column. cycle - elseif (kfpla(i - 1, j, n) <= kk .and. kfpla(i, j, n) > kk) then + elseif (kfpla(i-1,j,n) <= kk .and. kfpla(i,j,n) > kk) then ! --------------------------------------------------------------- ! Case 2: ! --------------------------------------------------------------- - ! Find the index of the first layer at (i - 1, j) that is - ! hydrostatically stable at the mixed layer base at (i, j). + ! Find the index of the first layer at (i-1,j) that is + ! hydrostatically stable at the mixed layer base at (i,j). km = 2 + nn - kintr = kfpla(i - 1, j, n) + kintr = kfpla(i-1,j,n) kn = kintr + nn - do while (rho(p(i , j, 3), & - temp(i - 1, j, kn), saln(i - 1, j, kn)) < & - rho(p(i , j, 3), & - temp(i , j, km), saln(i , j, km)) .or. & - dp(i - 1, j, kn) < epsilp) + do while (rho(p(i ,j,3), temp(i-1,j,kn), saln(i-1,j,kn)) < & + rho(p(i ,j,3), temp(i ,j,km), saln(i ,j,km)) .or. & + dp(i-1,j,kn) < epsilp) kintr = kintr + 1 if (kintr == kmax + 1) exit kn = kintr + nn @@ -261,10 +261,10 @@ subroutine eddtra_gm_isopyc_bulkml(m, n, mm, nn, k1m, k1n) ! fluxes for this column. if (kintr == kmax + 1) cycle - ! Compute the eddy induced transport (upsilon) at the mixed layer + ! Compute the eddy-induced transport (upsilon) at the mixed layer ! base. - kappa = .5_r8*(difint(i - 1, j, 2) + difint(i, j, 2)) - upsilon(3) = - kappa*nslpx(i, j, 3) + kappa = .5_r8*(difint(i-1,j,2) + difint(i,j,2)) + upsilon(3) = - kappa*nslpx(i,j,3) ! If the eddy-induced transport at the base of the mixed layer ! would cause a negative mass flux below the mixed layer, keep @@ -275,25 +275,23 @@ subroutine eddtra_gm_isopyc_bulkml(m, n, mm, nn, k1m, k1n) kmin = kintr - 1 mfl(kmin) = 0._r8 mfl(kintr) = et2mf*upsilon(3) - do k = kintr + 1, kmax + 1 + do k = kintr+1, kmax+1 mfl(k) = 0._r8 enddo - elseif (kfpla(i - 1, j, n) > kk .and. kfpla(i, j, n) <= kk) then + elseif (kfpla(i-1,j,n) > kk .and. kfpla(i,j,n) <= kk) then ! --------------------------------------------------------------- ! Case 3: ! --------------------------------------------------------------- - ! Find the index of the first layer at (i, j) that is - ! hydrostatically stable at the mixed layer base at (i - 1, j). + ! Find the index of the first layer at (i,j) that is + ! hydrostatically stable at the mixed layer base at (i-1,j). km = 2 + nn - kintr = kfpla(i , j, n) + kintr = kfpla(i ,j,n) kn = kintr + nn - do while (rho(p(i - 1, j, 3), & - temp(i , j, kn), saln(i , j, kn)) < & - rho(p(i - 1, j, 3), & - temp(i - 1, j, km), saln(i - 1, j, km)) .or. & - dp(i , j, kn) < epsilp) + do while (rho(p(i-1,j,3), temp(i ,j,kn), saln(i ,j,kn)) < & + rho(p(i-1,j,3), temp(i-1,j,km), saln(i-1,j,km)) .or. & + dp(i ,j,kn) < epsilp) kintr = kintr + 1 if (kintr == kmax + 1) exit kn = kintr + nn @@ -303,10 +301,10 @@ subroutine eddtra_gm_isopyc_bulkml(m, n, mm, nn, k1m, k1n) ! fluxes for this column. if (kintr == kmax + 1) cycle - ! Compute the eddy induced transport (upsilon) at the mixed layer + ! Compute the eddy-induced transport (upsilon) at the mixed layer ! base. - kappa = .5_r8*(difint(i - 1, j, 2) + difint(i, j, 2)) - upsilon(3) = - kappa*nslpx(i, j, 3) + kappa = .5_r8*(difint(i-1,j,2) + difint(i,j,2)) + upsilon(3) = - kappa*nslpx(i,j,3) ! If the eddy-induced transport at the base of the mixed layer ! would cause a positive mass flux below the mixed layer, keep @@ -317,7 +315,7 @@ subroutine eddtra_gm_isopyc_bulkml(m, n, mm, nn, k1m, k1n) kmin = kintr - 1 mfl(kmin) = 0._r8 mfl(kintr) = et2mf*upsilon(3) - do k = kintr + 1, kmax + 1 + do k = kintr+1, kmax+1 mfl(k) = 0._r8 enddo @@ -326,59 +324,53 @@ subroutine eddtra_gm_isopyc_bulkml(m, n, mm, nn, k1m, k1n) ! Case 4: ! --------------------------------------------------------------- - ! The first interior interface where the eddy induced transport + ! The first interior interface where the eddy-induced transport ! is estimated is at index kintr + 1. - kintr = max(kfpla(i - 1, j, n), kfpla(i, j, n)) + kintr = max(kfpla(i-1,j,n), kfpla(i,j,n)) - ! Compute the eddy induced transport (upsilon) at the mixed layer + ! Compute the eddy-induced transport (upsilon) at the mixed layer ! base. - kappa = .5_r8*(difint(i - 1, j, 2) + difint(i, j, 2)) - upsilon(3) = - kappa*nslpx(i, j, 3) + kappa = .5_r8*(difint(i-1,j,2) + difint(i,j,2)) + upsilon(3) = - kappa*nslpx(i,j,3) - ! Compute the eddy induced transport at interior interfaces. - do k = kintr + 1, kmax + ! Compute the eddy-induced transport at interior interfaces. + do k = kintr+1, kmax kn = k + nn - kappa = .25_r8*( difint(i - 1, j, k - 1) & - + difint(i , j, k - 1) & - + difint(i - 1, j, k ) & - + difint(i , j, k )) - upsilon(k) = - kappa*nslpx(i, j, k) + kappa = .25_r8*( difint(i-1,j,k-1) + difint(i,j,k-1) & + + difint(i-1,j,k ) + difint(i,j,k )) + upsilon(k) = - kappa*nslpx(i,j,k) enddo - upsilon(kmax + 1) = 0._r8 + upsilon(kmax+1) = 0._r8 ! If the layer kintr - 1 is a physical layer at either of the ! adjacent scalar points to the velocity point, then apply an - ! upper interface mass flux corresponding to the eddy induced + ! upper interface mass flux corresponding to the eddy-induced ! transport at the mixed layer base and a lower interface mass - ! flux corresponding to the eddy induced transport at the + ! flux corresponding to the eddy-induced transport at the ! kintr + 1 interface if this would lead to a hydrostatically ! stable layer arrangement. km = 2 + nn kn = kintr - 1 + nn - if ((kfpla(i - 1, j, n) < kintr .and. & - upsilon(3) - upsilon(kintr + 1) > 0._r8 .and. & - rho(p(i , j, 3), & - temp(i - 1, j, kn), saln(i - 1, j, kn)) > & - rho(p(i , j, 3), & - temp(i , j, km), saln(i , j, km))) .or. & - (kfpla(i , j, n) < kintr .and. & - upsilon(3) - upsilon(kintr + 1) < 0._r8 .and. & - rho(p(i - 1, j, 3), & - temp(i , j, kn), saln(i , j, kn)) > & - rho(p(i - 1, j, 3), & - temp(i - 1, j, km), saln(i - 1, j, km)))) then + if ((kfpla(i-1,j,n) < kintr .and. & + upsilon(3) - upsilon(kintr+1) > 0._r8 .and. & + rho(p(i ,j,3), temp(i-1,j,kn), saln(i-1,j,kn)) > & + rho(p(i ,j,3), temp(i ,j,km), saln(i ,j,km))) .or. & + (kfpla(i ,j,n) < kintr .and. & + upsilon(3) - upsilon(kintr+1) < 0._r8 .and. & + rho(p(i-1,j,3), temp(i ,j,kn), saln(i ,j,kn)) > & + rho(p(i-1,j,3), temp(i-1,j,km), saln(i-1,j,km)))) then kintr = kintr - 1 - upsilon(kintr + 1) = upsilon(kintr + 2) + upsilon(kintr+1) = upsilon(kintr+2) endif ! Assign interface mass fluxes. kmin = kintr - 1 mfl(kmin) = 0._r8 mfl(kintr) = et2mf*upsilon(3) - do k = kintr + 1, kmax + do k = kintr+1, kmax mfl(k) = et2mf*upsilon(k) enddo - mfl(kmax + 1) = 0._r8 + mfl(kmax+1) = 0._r8 endif @@ -390,36 +382,34 @@ subroutine eddtra_gm_isopyc_bulkml(m, n, mm, nn, k1m, k1n) ! fluxes at the scalar points adjacent to the velocity point. These ! bounded layer thicknesses are consistent with the transport ! algorithm. - dlm(kmin) = max(0._r8, min(p(i - 1, j, 3), pbu(i, j, n)) & - - max(p(i - 1, j, 1), ptu(i, j))) - dlp(kmin) = max(0._r8, min(p(i , j, 3), pbu(i, j, n)) & - - max(p(i , j, 1), ptu(i, j))) + dlm(kmin) = max(0._r8, min(p(i-1,j,3), pbu(i,j,n)) & + - max(p(i-1,j,1), ptu(i,j))) + dlp(kmin) = max(0._r8, min(p(i ,j,3), pbu(i,j,n)) & + - max(p(i ,j,1), ptu(i,j))) do k = kintr, kmax - dlm(k) = max(0._r8, min(p(i - 1, j, k + 1), pbu(i, j, n)) & - - max(p(i - 1, j, k ), ptu(i, j))) - dlp(k) = max(0._r8, min(p(i , j, k + 1), pbu(i, j, n)) & - - max(p(i , j, k ), ptu(i, j))) + dlm(k) = max(0._r8, min(p(i-1,j,k+1), pbu(i,j,n)) & + - max(p(i-1,j,k ), ptu(i,j))) + dlp(k) = max(0._r8, min(p(i ,j,k+1), pbu(i,j,n)) & + - max(p(i ,j,k ), ptu(i,j))) enddo ! If excessive depletion of layers occur beneath the mixed layer ! base, try to adjust interface fluxes other than the mixed layer ! base interface flux. - fhi = fface*max(0._r8, min((p(i - 1, j, 3) - ptu(i, j)) & - *scp2(i - 1, j), & - (pbu(i, j, n) - p(i , j, kintr)) & - *scp2(i , j))) - flo = - fface*max(0._r8, min((p(i , j, 3) - ptu(i, j)) & - *scp2(i , j), & - (pbu(i, j, n) - p(i - 1, j, kintr)) & - *scp2(i - 1, j))) - mfl(kmin + 1) = min(fhi, max(flo, mfl(kmin + 1))) - do k = kmin + 1, kmax - 1 - if (mfl(k + 1) - mfl(k) > & - ffac*max(epsilp, dlm(k))*scp2(i - 1, j)) then - mfl(k + 1) = mfl(k) + fface*dlm(k)*scp2(i - 1, j) - elseif (mfl(k + 1) - mfl(k) < & - - ffac*max(epsilp, dlp(k))*scp2(i , j)) then - mfl(k + 1) = mfl(k) - fface*dlp(k)*scp2(i , j) + fhi = fface*max(0._r8, & + min((p(i-1,j,3) - ptu(i,j) )*scp2(i-1,j), & + (pbu(i,j,n) - p(i ,j,kintr))*scp2(i ,j))) + flo = - fface*max(0._r8, & + min((p(i ,j,3) - ptu(i,j) )*scp2(i ,j), & + (pbu(i,j,n) - p(i-1,j,kintr))*scp2(i-1,j))) + mfl(kmin+1) = min(fhi, max(flo, mfl(kmin+1))) + do k = kmin+1, kmax-1 + if (mfl(k+1) - mfl(k) > & + ffac*max(epsilp, dlm(k))*scp2(i-1,j)) then + mfl(k+1) = mfl(k) + fface*dlm(k)*scp2(i-1,j) + elseif (mfl(k+1) - mfl(k) < & + - ffac*max(epsilp, dlp(k))*scp2(i ,j)) then + mfl(k+1) = mfl(k) - fface*dlp(k)*scp2(i ,j) else exit endif @@ -439,18 +429,18 @@ subroutine eddtra_gm_isopyc_bulkml(m, n, mm, nn, k1m, k1n) k = kmin write(lp,*) write(lp,'(i3,3e16.8)') & - 1, mfl(k + 1), mfl(k), & - (mfl(k + 1) - mfl(k)) & - /(max(onemm, dpu(i, j, 1 + nn) + dpu(i, j, 2 + nn)) & - *delt1*scuy(i, j)) + 1, mfl(k+1), mfl(k), & + (mfl(k+1) - mfl(k)) & + /(max(onemm, dpu(i,j,1+nn) + dpu(i,j,2+nn)) & + *delt1*scuy(i,j)) do k = kintr, kmax kn = k + nn write(lp,'(i3,3e16.8)') & - k, mfl(k + 1), mfl(k), & - (mfl(k + 1) - mfl(k)) & - /(max(onemm, dpu(i, j, kn))*delt1*scuy(i, j)) + k, mfl(k+1), mfl(k), & + (mfl(k+1) - mfl(k)) & + /(max(onemm, dpu(i,j,kn))*delt1*scuy(i,j)) enddo - write(lp,*) 'no convergence u', i + i0, j + j0 + write(lp,*) 'no convergence u', i+i0, j+j0 call xchalt('(eddtra_gm_isopyc_bulkml)') stop '(eddtra_gm_isopyc_bulkml)' endif @@ -458,57 +448,56 @@ subroutine eddtra_gm_isopyc_bulkml(m, n, mm, nn, k1m, k1n) changed = .false. kdir = - kdir - do k = ((1 - kdir)*kmax + (1 + kdir)*kmin)/2, & - ((1 - kdir)*kmin + (1 + kdir)*kmax)/2, kdir + do k = ((1-kdir)*kmax+(1+kdir)*kmin)/2, & + ((1-kdir)*kmin+(1+kdir)*kmax)/2, kdir ! Proceed with flux limiting of this layer if the mass flux ! difference between lower and upper interface is beyond the ! floating point accuracy limitation. - if (abs(mfl(k + 1) - mfl(k)) > & - 1.e-14_r8*max(epsilp*scu2(i, j), & - abs(mfl(k + 1) + mfl(k)))) then + if (abs(mfl(k+1) - mfl(k)) > & + eps*max(epsilp*scu2(i,j), abs(mfl(k+1) + mfl(k)))) then - if (mfl(k + 1) - mfl(k) > & - ffac*max(epsilp, dlm(k))*scp2(i - 1, j)) then + if (mfl(k+1) - mfl(k) > & + ffac*max(epsilp, dlm(k))*scp2(i-1,j)) then ! In this case, the mass fluxes are removing too much - ! mass from the grid cell at (i - 1, j, k). Limit the + ! mass from the grid cell at (i-1,j,k). Limit the ! dominating interface flux. - q = fface*dlm(k)*scp2(i - 1, j) - if (mfl(k + 1) > - mfl(k)) then - if (mfl(k ) > - .5_r8*q) then - mfl(k + 1) = mfl(k ) + q + q = fface*dlm(k)*scp2(i-1,j) + if (mfl(k+1) > - mfl(k)) then + if (mfl(k ) > - .5_r8*q) then + mfl(k+1) = mfl(k ) + q else - mfl(k + 1) = .5_r8*q - mfl(k ) = - mfl(k + 1) + mfl(k+1) = .5_r8*q + mfl(k ) = - mfl(k+1) endif else - if (mfl(k + 1) < .5_r8*q) then - mfl(k ) = mfl(k + 1) - q + if (mfl(k+1) < .5_r8*q) then + mfl(k ) = mfl(k+1) - q else - mfl(k ) = - .5_r8*q - mfl(k + 1) = - mfl(k ) + mfl(k ) = - .5_r8*q + mfl(k+1) = - mfl(k ) endif endif changed = .true. - elseif (mfl(k + 1) - mfl(k) < & - - ffac*max(epsilp, dlp(k))*scp2(i , j)) then + elseif (mfl(k+1) - mfl(k) < & + - ffac*max(epsilp, dlp(k))*scp2(i ,j)) then ! In this case, the mass fluxes are removing too much - ! mass from the grid cell at (i, j, k). Limit the + ! mass from the grid cell at (i,j,k). Limit the ! dominating interface flux. - q = fface*dlp(k)*scp2(i , j) - if (mfl(k + 1) < - mfl(k)) then - if (mfl(k ) < .5_r8*q) then - mfl(k + 1) = mfl(k ) - q + q = fface*dlp(k)*scp2(i ,j) + if (mfl(k+1) < - mfl(k)) then + if (mfl(k ) < .5_r8*q) then + mfl(k+1) = mfl(k ) - q else - mfl(k + 1) = - .5_r8*q - mfl(k ) = - mfl(k + 1) + mfl(k+1) = - .5_r8*q + mfl(k ) = - mfl(k+1) endif else - if (mfl(k + 1) > - .5_r8*q) then - mfl(k ) = mfl(k + 1) + q + if (mfl(k+1) > - .5_r8*q) then + mfl(k ) = mfl(k+1) + q else - mfl(k ) = .5_r8*q - mfl(k + 1) = - mfl(k ) + mfl(k ) = .5_r8*q + mfl(k+1) = - mfl(k ) endif endif changed = .true. @@ -524,41 +513,37 @@ subroutine eddtra_gm_isopyc_bulkml(m, n, mm, nn, k1m, k1n) ! ------------------------------------------------------------------ k = kmin - if (abs(mfl(k + 1) - mfl(k)) > & - 1.e-14_r8*max(epsilp*scu2(i, j), & - abs(mfl(k + 1) + mfl(k)))) then - umfltd(i, j, 2 + mm) = mfl(k + 1) - mfl(k) - umfltd(i, j, 1 + mm) = umfltd(i, j, 2 + mm) & - *dpu(i, j, 1 + nn)/( dpu(i, j, 1 + nn) & - + dpu(i, j, 2 + nn)) - umfltd(i, j, 2 + mm) = umfltd(i, j, 2 + mm) & - - umfltd(i, j, 1 + mm) + if (abs(mfl(k+1) - mfl(k)) > & + eps*max(epsilp*scu2(i,j), abs(mfl(k+1) + mfl(k)))) then + umfltd(i,j,2+mm) = mfl(k+1) - mfl(k) + umfltd(i,j,1+mm) = umfltd(i,j,2+mm)*dpu(i,j,1+nn) & + /(dpu(i,j,1+nn) + dpu(i,j,2+nn)) + umfltd(i,j,2+mm) = umfltd(i,j,2+mm) - umfltd(i,j,1+mm) else - umfltd(i, j, 1 + mm) = 0._r8 - umfltd(i, j, 2 + mm) = 0._r8 + umfltd(i,j,1+mm) = 0._r8 + umfltd(i,j,2+mm) = 0._r8 endif do k = kintr, kmax km = k + mm - if (abs(mfl(k + 1) - mfl(k)) > & - 1.e-14_r8*max(epsilp*scu2(i, j), & - abs(mfl(k + 1) + mfl(k)))) then - umfltd(i, j, km) = mfl(k + 1) - mfl(k) + if (abs(mfl(k+1) - mfl(k)) > & + eps*max(epsilp*scu2(i,j), abs(mfl(k+1) + mfl(k)))) then + umfltd(i,j,km) = mfl(k+1) - mfl(k) else - umfltd(i, j, km) = 0._r8 + umfltd(i,j,km) = 0._r8 endif - if (umfltd(i, j, km) > & - ffac*max(epsilp, dlm(k))*scp2(i - 1, j)) then + if (umfltd(i,j,km) > & + ffac*max(epsilp, dlm(k))*scp2(i-1,j)) then write(lp,*) 'eddtra_gm_isopyc_bulkml u >', & - i + i0, j + j0, k, umfltd(i, j, km), & - ffac*max(epsilp, dlm(k))*scp2(i - 1, j) + i+i0, j+j0, k, umfltd(i,j,km), & + ffac*max(epsilp, dlm(k))*scp2(i-1,j) call xchalt('(eddtra_gm_isopyc_bulkml)') stop '(eddtra_gm_isopyc_bulkml)' endif - if (umfltd(i, j, km) < & - - ffac*max(epsilp, dlp(k))*scp2(i , j)) then + if (umfltd(i,j,km) < & + - ffac*max(epsilp, dlp(k))*scp2(i ,j)) then write(lp,*) 'eddtra_gm_isopyc_bulkml u <', & - i + i0, j + j0, k, umfltd(i, j, km), & - - ffac*max(epsilp, dlp(k))*scp2(i , j) + i+i0, j+j0, k, umfltd(i,j,km), & + - ffac*max(epsilp, dlp(k))*scp2(i ,j) call xchalt('(eddtra_gm_isopyc_bulkml)') stop '(eddtra_gm_isopyc_bulkml)' endif @@ -576,47 +561,46 @@ subroutine eddtra_gm_isopyc_bulkml(m, n, mm, nn, k1m, k1n) !$omp parallel do private(l, i, k, km, et2mf, kmax, kn, kintr, kappa, & !$omp upsilon, kmin, mfl, dlm, dlp, fhi, flo, changed, & !$omp niter, kdir, q) - do j = 0, jj + 2 + do j = 0, jj+2 do l = 1, isv(j) - do i = max(- 1, ifv(j, l)), min(ii + 2, ilv(j, l)) + do i = max(-1, ifv(j,l)), min(ii+2, ilv(j,l)) ! Set eddy-induced mass fluxes to zero initially. do k = 1, kk km = k + mm - vmfltd(i, j, km) = 0._r8 + vmfltd(i,j,km) = 0._r8 enddo ! Eddy transport to mass flux conversion factor. - et2mf = - g*rho0*delt1*scvx(i, j) + et2mf = - g*rho0*delt1*scvx(i,j) ! Index of last layer containing mass at either of the scalar points ! adjacent to the velocity point. kmax = 1 do k = 3, kk kn = k + nn - if (dp(i, j - 1, kn) > epsilp .or. dp(i, j, kn) > epsilp) & - kmax = k + if (dp(i,j-1,kn) > epsilp .or. dp(i,j,kn) > epsilp) kmax = k enddo ! ------------------------------------------------------------------ ! Proceed with mass flux computation if at least one of the adjacent ! scalar points to the velocity point has a mass containing interior ! layer. Mass fluxes will be assigned at layer interface - ! corresponding to the eddy induced transport. The final layer mass + ! corresponding to the eddy-induced transport. The final layer mass ! flux will be the lower minus the upper interface flux. The mass ! fluxes are limited to keep interfaces within the water column. ! There are 3 cases to consider: ! Case 1: The mixed layer extends to the bottom at both adjacent ! scalar points to the velocity point ! Case 2: The mixed layer extends to the bottom at scalar point - ! (i, j). + ! (i,j). ! Case 3: The mixed layer extends to the bottom at scalar point - ! (i, j - 1). + ! (i,j-1). ! Case 4: The mixed layer does not reach the bottom at neither of ! the scalar points adjacent to the velocity point. ! ------------------------------------------------------------------ - if (kfpla(i, j - 1, n) > kk .and. kfpla(i, j, n) > kk) then + if (kfpla(i,j-1,n) > kk .and. kfpla(i,j,n) > kk) then ! --------------------------------------------------------------- ! Case 1: ! --------------------------------------------------------------- @@ -624,21 +608,19 @@ subroutine eddtra_gm_isopyc_bulkml(m, n, mm, nn, k1m, k1n) ! Keep the initial zero mass fluxes for this column. cycle - elseif (kfpla(i, j - 1, n) <= kk .and. kfpla(i, j, n) > kk) then + elseif (kfpla(i,j-1,n) <= kk .and. kfpla(i,j,n) > kk) then ! --------------------------------------------------------------- ! Case 2: ! --------------------------------------------------------------- - ! Find the index of the first layer at (i, j - 1) that is - ! hydrostatically stable at the mixed layer base at (i, j). + ! Find the index of the first layer at (i,j-1) that is + ! hydrostatically stable at the mixed layer base at (i,j). km = 2 + nn - kintr = kfpla(i, j - 1, n) + kintr = kfpla(i,j-1,n) kn = kintr + nn - do while (rho(p(i, j , 3), & - temp(i, j - 1, kn), saln(i, j - 1, kn)) < & - rho(p(i, j , 3), & - temp(i, j , km), saln(i, j , km)) .or. & - dp(i, j - 1, kn) < epsilp) + do while (rho(p(i,j ,3), temp(i,j-1,kn), saln(i,j-1,kn)) < & + rho(p(i,j ,3), temp(i,j ,km), saln(i,j ,km)) .or. & + dp(i,j-1,kn) < epsilp) kintr = kintr + 1 if (kintr == kmax + 1) exit kn = kintr + nn @@ -648,10 +630,10 @@ subroutine eddtra_gm_isopyc_bulkml(m, n, mm, nn, k1m, k1n) ! fluxes for this column. if (kintr == kmax + 1) cycle - ! Compute the eddy induced transport (upsilon) at the mixed layer + ! Compute the eddy-induced transport (upsilon) at the mixed layer ! base. - kappa = .5_r8*(difint(i, j - 1, 2) + difint(i, j, 2)) - upsilon(3) = - kappa*nslpy(i, j, 3) + kappa = .5_r8*(difint(i,j-1,2) + difint(i,j,2)) + upsilon(3) = - kappa*nslpy(i,j,3) ! If the eddy-induced transport at the base of the mixed layer ! would cause a negative mass flux below the mixed layer, keep @@ -662,25 +644,23 @@ subroutine eddtra_gm_isopyc_bulkml(m, n, mm, nn, k1m, k1n) kmin = kintr - 1 mfl(kmin) = 0._r8 mfl(kintr) = et2mf*upsilon(3) - do k = kintr + 1, kmax + 1 + do k = kintr+1, kmax+1 mfl(k) = 0._r8 enddo - elseif (kfpla(i, j - 1, n) > kk .and. kfpla(i, j, n) <= kk) then + elseif (kfpla(i,j-1,n) > kk .and. kfpla(i,j,n) <= kk) then ! --------------------------------------------------------------- ! Case 3: ! --------------------------------------------------------------- - ! Find the index of the first layer at (i, j) that is - ! hydrostatically stable at the mixed layer base at (i, j - 1). + ! Find the index of the first layer at (i,j) that is + ! hydrostatically stable at the mixed layer base at (i,j-1). km = 2 + nn - kintr = kfpla(i, j , n) + kintr = kfpla(i,j ,n) kn = kintr + nn - do while (rho(p(i, j - 1, 3), & - temp(i, j , kn), saln(i, j , kn)) < & - rho(p(i, j - 1, 3), & - temp(i, j - 1, km), saln(i, j - 1, km)) .or. & - dp(i, j , kn) < epsilp) + do while (rho(p(i,j-1,3), temp(i,j ,kn), saln(i,j ,kn)) < & + rho(p(i,j-1,3), temp(i,j-1,km), saln(i,j-1,km)) .or. & + dp(i,j ,kn) < epsilp) kintr = kintr + 1 if (kintr == kmax + 1) exit kn = kintr + nn @@ -690,10 +670,10 @@ subroutine eddtra_gm_isopyc_bulkml(m, n, mm, nn, k1m, k1n) ! fluxes for this column. if (kintr == kmax + 1) cycle - ! Compute the eddy induced transport (upsilon) at the mixed layer + ! Compute the eddy-induced transport (upsilon) at the mixed layer ! base. - kappa = .5_r8*(difint(i, j - 1, 2) + difint(i, j, 2)) - upsilon(3) = - kappa*nslpy(i, j, 3) + kappa = .5_r8*(difint(i,j-1,2) + difint(i,j,2)) + upsilon(3) = - kappa*nslpy(i,j,3) ! If the eddy-induced transport at the base of the mixed layer ! would cause a positive mass flux below the mixed layer, keep @@ -704,7 +684,7 @@ subroutine eddtra_gm_isopyc_bulkml(m, n, mm, nn, k1m, k1n) kmin = kintr - 1 mfl(kmin) = 0._r8 mfl(kintr) = et2mf*upsilon(3) - do k = kintr + 1, kmax + 1 + do k = kintr+1, kmax+1 mfl(k) = 0._r8 enddo @@ -713,59 +693,53 @@ subroutine eddtra_gm_isopyc_bulkml(m, n, mm, nn, k1m, k1n) ! Case 4: ! --------------------------------------------------------------- - ! The first interior interface where the eddy induced transport + ! The first interior interface where the eddy-induced transport ! is estimated is at index kintr + 1. - kintr = max(kfpla(i, j - 1, n), kfpla(i, j, n)) + kintr = max(kfpla(i,j-1,n), kfpla(i,j,n)) - ! Compute the eddy induced transport (upsilon) at the mixed layer + ! Compute the eddy-induced transport (upsilon) at the mixed layer ! base. - kappa = .5_r8*(difint(i, j - 1, 2) + difint(i, j, 2)) - upsilon(3) = - kappa*nslpy(i, j, 3) + kappa = .5_r8*(difint(i,j-1,2) + difint(i,j,2)) + upsilon(3) = - kappa*nslpy(i,j,3) - ! Compute the eddy induced transport at interior interfaces. - do k = kintr + 1, kmax + ! Compute the eddy-induced transport at interior interfaces. + do k = kintr+1, kmax kn = k + nn - kappa = .25_r8*( difint(i, j - 1, k - 1) & - + difint(i, j , k - 1) & - + difint(i, j - 1, k ) & - + difint(i, j , k )) - upsilon(k) = - kappa*nslpy(i, j, k) + kappa = .25_r8*( difint(i,j-1,k-1) + difint(i,j,k-1) & + + difint(i,j-1,k ) + difint(i,j,k )) + upsilon(k) = - kappa*nslpy(i,j,k) enddo - upsilon(kmax + 1) = 0._r8 + upsilon(kmax+1) = 0._r8 ! If the layer kintr - 1 is a physical layer at either of the ! adjacent scalar points to the velocity point, then apply an - ! upper interface mass flux corresponding to the eddy induced + ! upper interface mass flux corresponding to the eddy-induced ! transport at the mixed layer base and a lower interface mass - ! flux corresponding to the eddy induced transport at the + ! flux corresponding to the eddy-induced transport at the ! kintr + 1 interface if this would lead to a hydrostatically ! stable layer arrangement. km = 2 + nn kn = kintr - 1 + nn - if ((kfpla(i, j - 1, n) < kintr .and. & - upsilon(3) - upsilon(kintr + 1) > 0._r8 .and. & - rho(p(i, j , 3), & - temp(i, j - 1, kn), saln(i, j - 1, kn)) > & - rho(p(i, j , 3), & - temp(i, j , km), saln(i, j , km))) .or. & - (kfpla(i, j , n) < kintr .and. & - upsilon(3) - upsilon(kintr + 1) < 0._r8 .and. & - rho(p(i, j - 1, 3), & - temp(i, j , kn), saln(i, j , kn)) > & - rho(p(i, j - 1, 3), & - temp(i, j - 1, km), saln(i, j - 1, km)))) then + if ((kfpla(i,j-1,n) < kintr .and. & + upsilon(3) - upsilon(kintr+1) > 0._r8 .and. & + rho(p(i,j ,3), temp(i,j-1,kn), saln(i,j-1,kn)) > & + rho(p(i,j ,3), temp(i,j ,km), saln(i,j ,km))) .or. & + (kfpla(i,j ,n) < kintr .and. & + upsilon(3) - upsilon(kintr+1) < 0._r8 .and. & + rho(p(i,j-1,3), temp(i,j ,kn), saln(i,j ,kn)) > & + rho(p(i,j-1,3), temp(i,j-1,km), saln(i,j-1,km)))) then kintr = kintr - 1 - upsilon(kintr + 1) = upsilon(kintr + 2) + upsilon(kintr+1) = upsilon(kintr+2) endif ! Assign interface mass fluxes. kmin = kintr - 1 mfl(kmin) = 0._r8 mfl(kintr) = et2mf*upsilon(3) - do k = kintr + 1, kmax + do k = kintr+1, kmax mfl(k) = et2mf*upsilon(k) enddo - mfl(kmax + 1) = 0._r8 + mfl(kmax+1) = 0._r8 endif @@ -777,36 +751,34 @@ subroutine eddtra_gm_isopyc_bulkml(m, n, mm, nn, k1m, k1n) ! fluxes at the scalar points adjacent to the velocity point. These ! bounded layer thicknesses are consistent with the transport ! algorithm. - dlm(kmin) = max(0._r8, min(p(i, j - 1, 3), pbv(i, j, n)) & - - max(p(i, j - 1, 1), ptv(i, j))) - dlp(kmin) = max(0._r8, min(p(i, j , 3), pbv(i, j, n)) & - - max(p(i, j , 1), ptv(i, j))) + dlm(kmin) = max(0._r8, min(p(i,j-1,3), pbv(i,j,n)) & + - max(p(i,j-1,1), ptv(i,j))) + dlp(kmin) = max(0._r8, min(p(i,j ,3), pbv(i,j,n)) & + - max(p(i,j ,1), ptv(i,j))) do k = kintr, kmax - dlm(k) = max(0._r8, min(p(i, j - 1, k + 1), pbv(i, j, n)) & - - max(p(i, j - 1, k ), ptv(i, j))) - dlp(k) = max(0._r8, min(p(i, j , k + 1), pbv(i, j, n)) & - - max(p(i, j , k ), ptv(i, j))) + dlm(k) = max(0._r8, min(p(i,j-1,k+1), pbv(i,j,n)) & + - max(p(i,j-1,k ), ptv(i,j))) + dlp(k) = max(0._r8, min(p(i,j ,k+1), pbv(i,j,n)) & + - max(p(i,j ,k ), ptv(i,j))) enddo ! If excessive depletion of layers occur beneath the mixed layer ! base, try to adjust interface fluxes other than the mixed layer ! base interface flux. - fhi = fface*max(0._r8, min((p(i, j - 1, 3) - ptv(i, j)) & - *scp2(i, j - 1), & - (pbv(i, j, n) - p(i, j , kintr)) & - *scp2(i, j ))) - flo = - fface*max(0._r8, min((p(i, j , 3) - ptv(i, j)) & - *scp2(i, j ), & - (pbv(i, j, n) - p(i, j - 1, kintr)) & - *scp2(i, j - 1))) - mfl(kmin + 1) = min(fhi, max(flo, mfl(kmin + 1))) - do k = kmin + 1, kmax - 1 - if (mfl(k + 1) - mfl(k) > & - ffac*max(epsilp, dlm(k))*scp2(i, j - 1)) then - mfl(k + 1) = mfl(k) + fface*dlm(k)*scp2(i, j - 1) - elseif (mfl(k + 1) - mfl(k) < & - - ffac*max(epsilp, dlp(k))*scp2(i, j )) then - mfl(k + 1) = mfl(k) - fface*dlp(k)*scp2(i, j ) + fhi = fface*max(0._r8, & + min((p(i,j-1,3) - ptv(i,j) )*scp2(i,j-1), & + (pbv(i,j,n) - p(i,j ,kintr))*scp2(i,j ))) + flo = - fface*max(0._r8, & + min((p(i,j ,3) - ptv(i,j) )*scp2(i,j ), & + (pbv(i,j,n) - p(i,j-1,kintr))*scp2(i,j-1))) + mfl(kmin+1) = min(fhi, max(flo, mfl(kmin+1))) + do k = kmin+1, kmax-1 + if (mfl(k+1) - mfl(k) > & + ffac*max(epsilp, dlm(k))*scp2(i,j-1)) then + mfl(k+1) = mfl(k) + fface*dlm(k)*scp2(i,j-1) + elseif (mfl(k+1) - mfl(k) < & + - ffac*max(epsilp, dlp(k))*scp2(i,j )) then + mfl(k+1) = mfl(k) - fface*dlp(k)*scp2(i,j ) else exit endif @@ -826,18 +798,18 @@ subroutine eddtra_gm_isopyc_bulkml(m, n, mm, nn, k1m, k1n) k = kmin write(lp,*) write(lp,'(i3,3e16.8)') & - 1, mfl(k + 1), mfl(k), & - (mfl(k + 1) - mfl(k)) & - /(max(onemm, dpv(i, j, 1 + nn) + dpv(i, j, 2 + nn)) & - *delt1*scvx(i, j)) + 1, mfl(k+1), mfl(k), & + (mfl(k+1) - mfl(k)) & + /(max(onemm, dpv(i,j,1+nn) + dpv(i,j,2+nn)) & + *delt1*scvx(i,j)) do k = kintr, kmax kn = k + nn write(lp,'(i3,3e16.8)') & - k, mfl(k + 1), mfl(k), & - (mfl(k + 1) - mfl(k)) & - /(max(onemm, dpv(i, j, kn))*delt1*scvx(i, j)) + k, mfl(k+1), mfl(k), & + (mfl(k+1) - mfl(k)) & + /(max(onemm, dpv(i,j,kn))*delt1*scvx(i,j)) enddo - write(lp,*) 'no convergence v', i + i0, j + j0 + write(lp,*) 'no convergence v', i+i0, j+j0 call xchalt('(eddtra_gm_isopyc_bulkml)') stop '(eddtra_gm_isopyc_bulkml)' endif @@ -845,57 +817,56 @@ subroutine eddtra_gm_isopyc_bulkml(m, n, mm, nn, k1m, k1n) changed = .false. kdir = - kdir - do k = ((1 - kdir)*kmax + (1 + kdir)*kmin)/2, & - ((1 - kdir)*kmin + (1 + kdir)*kmax)/2, kdir + do k = ((1-kdir)*kmax+(1+kdir)*kmin)/2, & + ((1-kdir)*kmin+(1+kdir)*kmax)/2, kdir ! Proceed with flux limiting of this layer if the mass flux ! difference between lower and upper interface is beyond the ! floating point accuracy limitation. - if (abs(mfl(k + 1) - mfl(k)) > & - 1.e-14_r8*max(epsilp*scv2(i, j), & - abs(mfl(k + 1) + mfl(k)))) then + if (abs(mfl(k+1) - mfl(k)) > & + eps*max(epsilp*scv2(i,j), abs(mfl(k+1) + mfl(k)))) then - if (mfl(k + 1) - mfl(k) > & - ffac*max(epsilp, dlm(k))*scp2(i, j - 1)) then + if (mfl(k+1) - mfl(k) > & + ffac*max(epsilp, dlm(k))*scp2(i,j-1)) then ! In this case, the mass fluxes are removing too much - ! mass from the grid cell at (i, j - 1, k). Limit the + ! mass from the grid cell at (i,j-1,k). Limit the ! dominating interface flux. - q = fface*dlm(k)*scp2(i, j - 1) - if (mfl(k + 1) > - mfl(k)) then - if (mfl(k ) > - .5_r8*q) then - mfl(k + 1) = mfl(k ) + q + q = fface*dlm(k)*scp2(i,j-1) + if (mfl(k+1) > - mfl(k)) then + if (mfl(k ) > - .5_r8*q) then + mfl(k+1) = mfl(k ) + q else - mfl(k + 1) = .5_r8*q - mfl(k ) = - mfl(k + 1) + mfl(k+1) = .5_r8*q + mfl(k ) = - mfl(k+1) endif else - if (mfl(k + 1) < .5_r8*q) then - mfl(k ) = mfl(k + 1) - q + if (mfl(k+1) < .5_r8*q) then + mfl(k ) = mfl(k+1) - q else - mfl(k ) = - .5_r8*q - mfl(k + 1) = - mfl(k ) + mfl(k ) = - .5_r8*q + mfl(k+1) = - mfl(k ) endif endif changed = .true. - elseif (mfl(k + 1) - mfl(k) < & - - ffac*max(epsilp, dlp(k))*scp2(i, j )) then + elseif (mfl(k+1) - mfl(k) < & + - ffac*max(epsilp, dlp(k))*scp2(i,j )) then ! In this case, the mass fluxes are removing too much - ! mass from the grid cell at (i, j, k). Limit the + ! mass from the grid cell at (i,j,k). Limit the ! dominating interface flux. - q = fface*dlp(k)*scp2(i, j ) - if (mfl(k + 1) < - mfl(k)) then - if (mfl(k ) < .5_r8*q) then - mfl(k + 1) = mfl(k ) - q + q = fface*dlp(k)*scp2(i,j ) + if (mfl(k+1) < - mfl(k)) then + if (mfl(k ) < .5_r8*q) then + mfl(k+1) = mfl(k ) - q else - mfl(k + 1) = - .5_r8*q - mfl(k ) = - mfl(k + 1) + mfl(k+1) = - .5_r8*q + mfl(k ) = - mfl(k+1) endif else - if (mfl(k + 1) > - .5_r8*q) then - mfl(k ) = mfl(k + 1) + q + if (mfl(k+1) > - .5_r8*q) then + mfl(k ) = mfl(k+1) + q else - mfl(k ) = .5_r8*q - mfl(k + 1) = - mfl(k ) + mfl(k ) = .5_r8*q + mfl(k+1) = - mfl(k ) endif endif changed = .true. @@ -911,41 +882,37 @@ subroutine eddtra_gm_isopyc_bulkml(m, n, mm, nn, k1m, k1n) ! ------------------------------------------------------------------ k = kmin - if (abs(mfl(k + 1) - mfl(k)) > & - 1.e-14_r8*max(epsilp*scv2(i, j), & - abs(mfl(k + 1) + mfl(k)))) then - vmfltd(i, j, 2 + mm) = mfl(k + 1) - mfl(k) - vmfltd(i, j, 1 + mm) = vmfltd(i, j, 2 + mm) & - *dpv(i, j, 1 + nn)/( dpv(i, j, 1 + nn) & - + dpv(i, j, 2 + nn)) - vmfltd(i, j, 2 + mm) = vmfltd(i, j, 2 + mm) & - - vmfltd(i, j, 1 + mm) + if (abs(mfl(k+1) - mfl(k)) > & + eps*max(epsilp*scv2(i,j), abs(mfl(k+1) + mfl(k)))) then + vmfltd(i,j,2+mm) = mfl(k+1) - mfl(k) + vmfltd(i,j,1+mm) = vmfltd(i,j,2+mm)*dpv(i,j,1+nn) & + /(dpv(i,j,1+nn) + dpv(i,j,2+nn)) + vmfltd(i,j,2+mm) = vmfltd(i,j,2+mm) - vmfltd(i,j,1+mm) else - vmfltd(i, j, 1 + mm) = 0._r8 - vmfltd(i, j, 2 + mm) = 0._r8 + vmfltd(i,j,1+mm) = 0._r8 + vmfltd(i,j,2+mm) = 0._r8 endif do k = kintr, kmax km = k + mm - if (abs(mfl(k + 1) - mfl(k)) > & - 1.e-14_r8*max(epsilp*scv2(i, j), & - abs(mfl(k + 1) + mfl(k)))) then - vmfltd(i, j, km) = mfl(k + 1) - mfl(k) + if (abs(mfl(k+1) - mfl(k)) > & + eps*max(epsilp*scv2(i,j), abs(mfl(k+1) + mfl(k)))) then + vmfltd(i,j,km) = mfl(k+1) - mfl(k) else - vmfltd(i, j, km) = 0._r8 + vmfltd(i,j,km) = 0._r8 endif - if (vmfltd(i, j, km) > & - ffac*max(epsilp, dlm(k))*scp2(i, j - 1)) then + if (vmfltd(i,j,km) > & + ffac*max(epsilp, dlm(k))*scp2(i,j-1)) then write(lp,*) 'eddtra_gm_isopyc_bulkml v >', & - i + i0, j + j0, k, vmfltd(i, j, km), & - ffac*max(epsilp, dlm(k))*scp2(i, j - 1) + i+i0, j+j0, k, vmfltd(i,j,km), & + ffac*max(epsilp, dlm(k))*scp2(i,j-1) call xchalt('(eddtra_gm_isopyc_bulkml)') stop '(eddtra_gm_isopyc_bulkml)' endif - if (vmfltd(i, j, km) < & - - ffac*max(epsilp, dlp(k))*scp2(i, j )) then + if (vmfltd(i,j,km) < & + - ffac*max(epsilp, dlp(k))*scp2(i,j )) then write(lp,*) 'eddtra_gm_isopyc_bulkml v <', & - i + i0, j + j0, k, vmfltd(i, j, km), & - - ffac*max(epsilp, dlp(k))*scp2(i, j ) + i+i0, j+j0, k, vmfltd(i,j,km), & + - ffac*max(epsilp, dlp(k))*scp2(i,j ) call xchalt('(eddtra_gm_isopyc_bulkml)') stop '(eddtra_gm_isopyc_bulkml)' endif @@ -958,7 +925,7 @@ subroutine eddtra_gm_isopyc_bulkml(m, n, mm, nn, k1m, k1n) end subroutine eddtra_gm_isopyc_bulkml - subroutine eddtra_gm_cntiso_hybrid(m, n, mm, nn, k1m, k1n) + subroutine eddtra_cntiso_hybrid(m, n, mm, nn, k1m, k1n) ! --------------------------------------------------------------------------- ! Estimate eddy-induced transport following the Gent-McWilliams ! parameterization. @@ -968,37 +935,106 @@ subroutine eddtra_gm_cntiso_hybrid(m, n, mm, nn, k1m, k1n) ! Parameters: real(r8), parameter :: & - ffac = .0625_r8, & ! Fraction of the mass of a grid cell a mass flux - ! is allowed to deplete []. - fface = .99_r8*ffac ! (1-epsilon)*ffac []. - - real(r8), dimension(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy) :: ptu, ptv - real(r8), dimension(kdm+1) :: mfl - real(r8), dimension(kdm) :: puv, dlm, dlp - real(r8) :: q, et2mf, mlp, kappa + ffac = .0625_r8, & ! Fraction of the mass of a grid cell a mass + ! flux is allowed to deplete []. + fface = .99_r8*ffac, & ! (1-epsilon)*ffac []. + eps = 1.e-14_r8, & ! Small non-dimensional value []. + rtau = 1._r8/86400._r8, & + lfmin = 5.e3_r8*L_mks2cgs, & + c5_21 = 5._r8/21._r8 + + real(r8), dimension(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy) :: & + upssmx, upssmy, ptu, ptv + real(r8), dimension(kdm+1) :: puv, mflgm, mflsm, mfl + real(r8), dimension(kdm) :: dlm, dlp + real(r8) :: mlp, mldpi, tmldp, smldp, csm, f, absfi, lfi, & + mfleps, et2mf, mldh, kappa, q integer :: i, j, k, l, km, kn, kmax, kml, niter, kdir logical :: changed call xctilr(difint, 1, kk, 2, 2, halo_ps) call xctilr(pbu, 1, 2, 2, 2, halo_us) call xctilr(pbv, 1, 2, 2, 2, halo_vs) - call xctilr(mlts, 1, 1, 1, 1, halo_ps) + call xctilr(mlts, 1, 1, 2, 2, halo_ps) + + ! ------------------------------------------------------------------------ + ! Compute the depth invariant lateral components of submesoscale eddy + ! transport (upsilon) according to Fox-Kemper et al. (2008). + ! ------------------------------------------------------------------------ + + ! Compute vertically averaged mixed layer density [g cm-3]. + !$omp parallel do private(l, i, mlp, mldpi, tmldp, smldp, k, kn) + do j=1,jj + do l=1,isp(j) + do i=max(1,ifp(j,l)),min(ii,ilp(j,l)) + mlp = min(p(i,j,1) + mlts(i,j)*(onem*iL_mks2cgs), p(i,j,kk+1)) + mldpi = 1._r8/(mlp - p(i,j,1)) + tmldp = 0._r8 + smldp = 0._r8 + do k = 1, kk + kn = k + nn + if (p(i,j,k+1) < mlp) then + tmldp = tmldp + temp(i,j,kn)*dp(i,j,kn) + smldp = smldp + saln(i,j,kn)*dp(i,j,kn) + else + tmldp = tmldp + temp(i,j,kn)*(mlp - p(i,j,k)) + smldp = smldp + saln(i,j,kn)*(mlp - p(i,j,k)) + exit + endif + enddo + util1(i,j) = sig0(tmldp*mldpi, smldp*mldpi) + enddo + enddo + enddo + !$omp end parallel do + call xctilr(util1, 1,1, 2,2, halo_ps) + + ! Compute components of submesoscale eddy transport [cm2 s-1]. + csm = g*alpha0*ce + !$omp parallel do private(l, i, mldh, f, absfi, lfi) + do j = -1, jj+2 + do l = 1, isu(j) + do i = max(0, ifu(j,l)), min(ii+2, ilu(j,l)) + mldh = .5_r8*(mlts(i-1,j) + mlts(i,j)) + f = .5_r8*(coriop(i-1,j) + coriop(i,j)) + absfi = 1._r8/sqrt(f*f + rtau*rtau) + lfi = 1._r8/max(sqrt(dbcrit*mldh)*absfi, lfmin) +! lfi = 1._r8/lfmin + upssmx(i,j) = csm*mldh*mldh*(util1(i,j) - util1(i-1,j))*lfi*absfi + enddo + enddo + enddo + !$omp end parallel do + !$omp parallel do private(l, i, mldh, f, absfi, lfi) + do j = 0, jj+2 + do l = 1, isv(j) + do i = max(-1, ifv(j,l)), min(ii+2, ilv(j,l)) + mldh = .5_r8*(mlts(i,j-1) + mlts(i,j)) + f = .5_r8*(coriop(i,j-1) + coriop(i,j)) + absfi = 1._r8/sqrt(f*f + rtau*rtau) + lfi = 1._r8/max(sqrt(dbcrit*mldh)*absfi, lfmin) +! lfi = 1._r8/lfmin + upssmy(i,j) = csm*mldh*mldh*(util1(i,j) - util1(i,j-1))*lfi*absfi + enddo + enddo + enddo + !$omp end parallel do ! Compute top pressure at velocity points. !$omp parallel do private(l, i) - do j= - 1, jj + 2 + do j = -1, jj+2 do l = 1, isu(j) - do i = max(0, ifu(j, l)), min(ii + 2, ilu(j, l)) - ptu(i, j) = max(p(i - 1, j, 1), p(i, j, 1)) + do i = max(0, ifu(j,l)), min(ii+2, ilu(j,l)) + ptu(i,j) = max(p(i-1,j,1), p(i,j,1)) enddo enddo enddo !$omp end parallel do !$omp parallel do private(l, i) - do j = 0, jj + 2 + do j = 0, jj+2 do l = 1, isv(j) - do i = max(- 1, ifv(j, l)), min(ii + 2, ilv(j, l)) - ptv(i, j) = max(p(i, j - 1, 1), p(i, j, 1)) + do i = max(-1, ifv(j,l)), min(ii+2, ilv(j,l)) + ptv(i,j) = max(p(i,j-1,1), p(i,j,1)) enddo enddo enddo @@ -1008,72 +1044,106 @@ subroutine eddtra_gm_cntiso_hybrid(m, n, mm, nn, k1m, k1n) ! Compute u-component of eddy-induced mass fluxes. ! ------------------------------------------------------------------------- - !$omp parallel do private(l, i, k, km, et2mf, kmax, puv, kn, mlp, kml, & - !$omp kappa, mfl, dlm, dlp, changed, niter, kdir, q) - do j = - 1, jj + 2 + !$omp parallel do private(l, i, k, km, mfleps, et2mf, kmax, puv, kn, mldh, & + !$omp mlp, mldpi, kml, kappa, mflgm, mflsm, q, mfl, & + !$omp dlm, dlp, changed, niter, kdir) + do j = -1, jj+2 do l = 1, isu(j) - do i = max(0, ifu(j, l)), min(ii + 2, ilu(j, l)) + do i = max(0, ifu(j,l)), min(ii+2, ilu(j,l)) ! Set eddy-induced mass fluxes to zero initially. do k = 1, kk km = k + mm - umfltd(i, j, km) = 0._r8 + umfltd(i,j,km) = 0._r8 + umflsm(i,j,km) = 0._r8 enddo + ! Small value with the same dimension as eddy-induced mass flux. + mfleps = eps*epsilp*scu2(i,j) + ! Eddy transport to mass flux conversion factor. - et2mf = - g*rho0*delt1*scuy(i, j) + et2mf = - g*rho0*delt1*scuy(i,j) - ! Find index of last layer containing mass at either of the scalar - ! points adjacent to the velocity point and pressure at interfaces. + ! Get interface pressures and find index of last layer containing + ! mass at either of the scalar points adjacent to the velocity point + ! and pressure at interfaces. kmax = 1 puv(1) = ptu(i,j) - do k = 2, kk + do k = 1, kk kn = k + nn - puv(k) = puv(k - 1) + dpu(i, j, kn - 1) - if (dp(i - 1, j, kn) > epsilp .or. dp(i, j, kn) > epsilp) & - kmax = k + puv(k+1) = puv(k) + dpu(i,j,kn) + if (dp(i-1,j,kn) > epsilp .or. dp(i,j,kn) > epsilp) kmax = k enddo - ! Compute the eddy induced mass flux at layer interfaces below the + ! Mixed layer thickness [cm]. + mldh = .5_r8*(mlts(i-1,j) + mlts(i,j)) + + ! Pressure of mixed layer base [g cm-1 s-2]. + mlp = min(puv(1) + mldh*(onem*iL_mks2cgs), puv(kmax+1)) + + ! Multiplicative inverse of mixed layer pressure thickness + ! [g cm-1 s-2]. + mldpi = 1._r8/(mlp - puv(1)) + + ! Find index of first interface below the mixed layer base. ! mixed layer. - mlp = .5_r8*(mlts(i - 1, j) + mlts(i, j))*(onem*iL_mks2cgs) kml = kmax + 1 - mfl(kmax + 1) = 0._r8 do k = kmax, 2, -1 if (puv(k) > mlp) then - kappa = .25_r8*( difint(i - 1, j, k - 1) & - + difint(i , j, k - 1) & - + difint(i - 1, j, k ) & - + difint(i , j, k )) - mfl(k) = - kappa*nslpx(i, j, k)*et2mf kml = k else exit endif enddo - ! In the mixed layer, let the eddy induced mass flux change + ! Compute the GM eddy-induced mass flux at layer interfaces below + ! the mixed layer base. + do k = kml, kmax + kappa = .25_r8*( difint(i-1,j,k-1) + difint(i,j,k-1) & + + difint(i-1,j,k ) + difint(i,j,k )) + mflgm(k) = - kappa*nslpx(i,j,k)*et2mf + enddo + mflgm(kmax+1) = 0._r8 + + ! In the mixed layer, let the GM eddy-induced mass flux change ! linearly, with respect to interface pressure, from zero at the ! surface to the mass flux below the mixed layer. - mfl(1) = 0._r8 - q = 1._r8/(mlp - puv(1)) + mflgm(1) = 0._r8 do k = 2, kml - 1 - mfl(k) = mfl(kml)*(puv(k) - puv(1))*q + mflgm(k) = mflgm(kml)*(puv(k) - puv(1))*mldpi + enddo + + ! Using a prescibed vertical structure function, compute the + ! submesoscale eddy-induced mass flux at layer interfaces within the + ! mixed layer. + mflsm(1) = 0._r8 + do k = 2, kml - 1 + q = (2._r8*(puv(1) - puv(k))*mldpi + 1._r8)**2 + mflsm(k) = - upssmx(i,j)*(1._r8 - q)*(1._r8 + c5_21*q)*et2mf + enddo + do k = kml, kmax+1 + mflsm(k) = 0._r8 enddo ! ------------------------------------------------------------------ ! Ensure that mass fluxes do not create negative layer thicknesses. ! ------------------------------------------------------------------ + ! Apply limiting on the sum of GM and submesoscale eddy-induced mass + ! fluxes. + do k = 1, kmax+1 + mfl(k) = mflgm(k) + mflsm(k) + enddo + ! Compute the layer thicknesses available to be depleted by mass ! fluxes at the scalar points adjacent to the velocity point. These ! bounded layer thicknesses are consistent with the transport ! algorithm. do k = 1, kmax - dlm(k) = max(0._r8, min(p(i - 1, j, k + 1), pbu(i, j, n)) & - - max(p(i - 1, j, k ), ptu(i, j))) - dlp(k) = max(0._r8, min(p(i , j, k + 1), pbu(i, j, n)) & - - max(p(i , j, k ), ptu(i, j))) + dlm(k) = max(0._r8, min(p(i-1,j,k+1), pbu(i,j,n)) & + - max(p(i-1,j,k ), ptu(i,j))) + dlp(k) = max(0._r8, min(p(i ,j,k+1), pbu(i,j,n)) & + - max(p(i ,j,k ), ptu(i,j))) enddo ! Apply an iterative procedure for flux limiting by alternate upward @@ -1090,69 +1160,67 @@ subroutine eddtra_gm_cntiso_hybrid(m, n, mm, nn, k1m, k1n) do k = 1, kmax kn = k + nn write(lp,'(i3,3e16.8)') & - k, mfl(k + 1), mfl(k), & - (mfl(k + 1) - mfl(k)) & - /(max(onemm, dpu(i, j, kn))*delt1*scuy(i, j)) + k, mfl(k+1), mfl(k), & + (mfl(k+1) - mfl(k)) & + /(max(onemm, dpu(i,j,kn))*delt1*scuy(i,j)) enddo - write(lp,*) 'no convergence u', i + i0, j + j0 - call xchalt('(eddtra_gm_cntiso_hybrid)') - stop '(eddtra_gm_cntiso_hybrid)' + write(lp,*) 'no convergence u', i+i0, j+j0 + call xchalt('(eddtra_cntiso_hybrid)') + stop '(eddtra_cntiso_hybrid)' endif changed = .false. kdir = - kdir - do k = (1 + kdir + (1 - kdir)*kmax)/2, & - (1 - kdir + (1 + kdir)*kmax)/2, kdir + do k = (1+kdir+(1-kdir)*kmax)/2, (1-kdir+(1+kdir)*kmax)/2, kdir ! Proceed with flux limiting of this layer if the mass flux ! difference between lower and upper interface is beyond the ! floating point accuracy limitation. - if (abs(mfl(k + 1) - mfl(k)) > & - 1.e-14_r8*max(epsilp*scu2(i, j), & - abs(mfl(k + 1) + mfl(k)))) then + if (abs(mfl(k+1) - mfl(k)) > & + max(mfleps, eps*abs(mfl(k+1) + mfl(k)))) then - if (mfl(k + 1) - mfl(k) > & - ffac*max(epsilp, dlm(k))*scp2(i - 1, j)) then + if (mfl(k+1) - mfl(k) > & + ffac*max(epsilp, dlm(k))*scp2(i-1,j)) then ! In this case, the mass fluxes are removing too much - ! mass from the grid cell at (i - 1, j, k). Limit the + ! mass from the grid cell at (i-1,j,k). Limit the ! dominating interface flux. - q = fface*dlm(k)*scp2(i - 1, j) - if (mfl(k + 1) > - mfl(k)) then - if (mfl(k ) > - .5_r8*q) then - mfl(k + 1) = mfl(k ) + q + q = fface*dlm(k)*scp2(i-1,j) + if (mfl(k+1) > - mfl(k)) then + if (mfl(k ) > - .5_r8*q) then + mfl(k+1) = mfl(k ) + q else - mfl(k + 1) = .5_r8*q - mfl(k ) = - mfl(k + 1) + mfl(k+1) = .5_r8*q + mfl(k ) = - mfl(k+1) endif else - if (mfl(k + 1) < .5_r8*q) then - mfl(k ) = mfl(k + 1) - q + if (mfl(k+1) < .5_r8*q) then + mfl(k ) = mfl(k+1) - q else - mfl(k ) = - .5_r8*q - mfl(k + 1) = - mfl(k ) + mfl(k ) = - .5_r8*q + mfl(k+1) = - mfl(k ) endif endif changed = .true. - elseif (mfl(k + 1) - mfl(k) < & - - ffac*max(epsilp, dlp(k))*scp2(i , j)) then + elseif (mfl(k+1) - mfl(k) < & + - ffac*max(epsilp, dlp(k))*scp2(i ,j)) then ! In this case, the mass fluxes are removing too much - ! mass from the grid cell at (i, j, k). Limit the + ! mass from the grid cell at (i,j,k). Limit the ! dominating interface flux. - q = fface*dlp(k)*scp2(i , j) - if (mfl(k + 1) < - mfl(k)) then - if (mfl(k ) < .5_r8*q) then - mfl(k + 1) = mfl(k ) - q + q = fface*dlp(k)*scp2(i ,j) + if (mfl(k+1) < - mfl(k)) then + if (mfl(k ) < .5_r8*q) then + mfl(k+1) = mfl(k ) - q else - mfl(k + 1) = - .5_r8*q - mfl(k ) = - mfl(k + 1) + mfl(k+1) = - .5_r8*q + mfl(k ) = - mfl(k+1) endif else - if (mfl(k + 1) > - .5_r8*q) then - mfl(k ) = mfl(k + 1) + q + if (mfl(k+1) > - .5_r8*q) then + mfl(k ) = mfl(k+1) + q else - mfl(k ) = .5_r8*q - mfl(k + 1) = - mfl(k ) + mfl(k ) = .5_r8*q + mfl(k+1) = - mfl(k ) endif endif changed = .true. @@ -1163,34 +1231,77 @@ subroutine eddtra_gm_cntiso_hybrid(m, n, mm, nn, k1m, k1n) enddo + ! Adjust the GM and submesoscale eddy-induced mass fluxes so their + ! sum matches the limited total mass flux. + do k = 1, kmax+1 + if (abs(mfl(k)) < mfleps) then + mfl(k) = 0._r8 + mflgm(k) = 0._r8 + mflsm(k) = 0._r8 + elseif (mfl(k) > 0._r8) then + if (mflgm(k) > mflsm(k)) then + if (mfl(k) > 2._r8*mflsm(k)) then + mflgm(k) = mfl(k) - mflsm(k) + else + mflgm(k) = .5_r8*mfl(k) + mflsm(k) = mflgm(k) + endif + else + if (mfl(k) > 2._r8*mflgm(k)) then + mflsm(k) = mfl(k) - mflgm(k) + else + mflsm(k) = .5_r8*mfl(k) + mflgm(k) = mflsm(k) + endif + endif + else + if (mflgm(k) < mflsm(k)) then + if (mfl(k) < 2._r8*mflsm(k)) then + mflgm(k) = mfl(k) - mflsm(k) + else + mflgm(k) = .5_r8*mfl(k) + mflsm(k) = mflgm(k) + endif + else + if (mfl(k) < 2._r8*mflgm(k)) then + mflsm(k) = mfl(k) - mflgm(k) + else + mflsm(k) = .5_r8*mfl(k) + mflgm(k) = mflsm(k) + endif + endif + endif + enddo + ! ------------------------------------------------------------------ ! Compute the final mass fluxes. ! ------------------------------------------------------------------ do k = 1, kmax km = k + mm - if (abs(mfl(k + 1) - mfl(k)) > & - 1.e-14_r8*max(epsilp*scu2(i, j), & - abs(mfl(k + 1) + mfl(k)))) then - umfltd(i, j, km) = mfl(k + 1) - mfl(k) + if (abs(mfl(k+1) - mfl(k)) > & + max(mfleps, eps*abs(mfl(k+1) + mfl(k)))) then + umfltd(i,j,km) = mflgm(k+1) - mflgm(k) + umflsm(i,j,km) = mflsm(k+1) - mflsm(k) else - umfltd(i, j, km) = 0._r8 + umfltd(i,j,km) = 0._r8 + umflsm(i,j,km) = 0._r8 endif - if (umfltd(i, j, km) > & - ffac*max(epsilp, dlm(k))*scp2(i - 1, j)) then - write(lp,*) 'eddtra_gm_cntiso_hybrid u >', & - i + i0, j + j0, k, umfltd(i, j, km), & - ffac*max(epsilp, dlm(k))*scp2(i - 1, j) - call xchalt('(eddtra_gm_cntiso_hybrid)') - stop '(eddtra_gm_cntiso_hybrid)' + 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 >', & + 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)' endif - if (umfltd(i, j, km) < & - - ffac*max(epsilp, dlp(k))*scp2(i , j)) then - write(lp,*) 'eddtra_gm_cntiso_hybrid u <', & - i + i0, j + j0, k, umfltd(i, j, km), & - - ffac*max(epsilp, dlp(k))*scp2(i , j) - call xchalt('(eddtra_gm_cntiso_hybrid)') - stop '(eddtra_gm_cntiso_hybrid)' + if (umfltd(i,j,km) + umflsm(i,j,km) < & + - ffac*max(epsilp, dlp(k))*scp2(i ,j)) then + write(lp,*) 'eddtra_cntiso_hybrid 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)' endif enddo @@ -1203,72 +1314,106 @@ subroutine eddtra_gm_cntiso_hybrid(m, n, mm, nn, k1m, k1n) ! Compute v-component of eddy-induced mass fluxes. ! ------------------------------------------------------------------------- - !$omp parallel do private(l, i, k, km, et2mf, kmax, puv, kn, mlp, kml, & - !$omp kappa, mfl, dlm, dlp, changed, niter, kdir, q) - do j = 0, jj + 2 + !$omp parallel do private(l, i, k, km, mfleps, et2mf, kmax, puv, kn, mldh, & + !$omp mlp, mldpi, kml, kappa, mflgm, mflsm, q, mfl, & + !$omp dlm, dlp, changed, niter, kdir) + do j = 0, jj+2 do l = 1, isv(j) - do i = max(- 1, ifv(j, l)), min(ii + 2, ilv(j, l)) + do i = max(-1, ifv(j,l)), min(ii+2, ilv(j,l)) ! Set eddy-induced mass fluxes to zero initially. do k = 1, kk km = k + mm - vmfltd(i, j, km) = 0._r8 + vmfltd(i,j,km) = 0._r8 + vmflsm(i,j,km) = 0._r8 enddo + ! Small value with the same dimension as eddy-induced mass flux. + mfleps = eps*epsilp*scv2(i,j) + ! Eddy transport to mass flux conversion factor. - et2mf = - g*rho0*delt1*scvx(i, j) + et2mf = - g*rho0*delt1*scvx(i,j) - ! Find index of last layer containing mass at either of the scalar - ! points adjacent to the velocity point and pressure at interfaces. + ! Get interface pressures and find index of last layer containing + ! mass at either of the scalar points adjacent to the velocity point + ! and pressure at interfaces. kmax = 1 puv(1) = ptv(i,j) - do k = 2, kk + do k = 1, kk kn = k + nn - puv(k) = puv(k - 1) + dpv(i, j, kn - 1) - if (dp(i, j - 1, kn) > epsilp .or. dp(i, j, kn) > epsilp) & - kmax = k + puv(k+1) = puv(k) + dpv(i,j,kn) + if (dp(i,j-1,kn) > epsilp .or. dp(i,j,kn) > epsilp) kmax = k enddo - ! Compute the eddy induced mass flux at layer interfaces below the + ! Mixed layer thickness [cm]. + mldh = .5_r8*(mlts(i,j-1) + mlts(i,j)) + + ! Pressure of mixed layer base [g cm-1 s-2]. + mlp = min(puv(1) + mldh*(onem*iL_mks2cgs), puv(kmax+1)) + + ! Multiplicative inverse of mixed layer pressure thickness + ! [g cm-1 s-2]. + mldpi = 1._r8/(mlp - puv(1)) + + ! Find index of first interface below the mixed layer base. ! mixed layer. - mlp = .5_r8*(mlts(i, j - 1) + mlts(i, j))*(onem*iL_mks2cgs) kml = kmax + 1 - mfl(kmax + 1) = 0._r8 do k = kmax, 2, -1 if (puv(k) > mlp) then - kappa = .25_r8*( difint(i, j - 1, k - 1) & - + difint(i, j , k - 1) & - + difint(i, j - 1, k ) & - + difint(i, j , k )) - mfl(k) = - kappa*nslpy(i, j, k)*et2mf kml = k else exit endif enddo - ! In the mixed layer, let the eddy induced mass flux change + ! Compute the GM eddy-induced mass flux at layer interfaces below + ! the mixed layer base. + do k = kml, kmax + kappa = .25_r8*( difint(i,j-1,k-1) + difint(i,j,k-1) & + + difint(i,j-1,k ) + difint(i,j,k )) + mflgm(k) = - kappa*nslpy(i,j,k)*et2mf + enddo + mflgm(kmax+1) = 0._r8 + + ! In the mixed layer, let the GM eddy-induced mass flux change ! linearly, with respect to interface pressure, from zero at the ! surface to the mass flux below the mixed layer. - mfl(1) = 0._r8 - q = 1._r8/(mlp - puv(1)) + mflgm(1) = 0._r8 do k = 2, kml - 1 - mfl(k) = mfl(kml)*(puv(k) - puv(1))*q + mflgm(k) = mflgm(kml)*(puv(k) - puv(1))*mldpi + enddo + + ! Using a prescibed vertical structure function, compute the + ! submesoscale eddy-induced mass flux at layer interfaces within the + ! mixed layer. + mflsm(1) = 0._r8 + do k = 2, kml - 1 + q = (2._r8*(puv(1) - puv(k))*mldpi + 1._r8)**2 + mflsm(k) = - upssmy(i,j)*(1._r8 - q)*(1._r8 + c5_21*q)*et2mf + enddo + do k = kml, kmax+1 + mflsm(k) = 0._r8 enddo ! ------------------------------------------------------------------ ! Ensure that mass fluxes do not create negative layer thicknesses. ! ------------------------------------------------------------------ + ! Apply limiting on the sum of GM and submesoscale eddy-induced mass + ! fluxes. + do k = 1, kmax+1 + mfl(k) = mflgm(k) + mflsm(k) + enddo + ! Compute the layer thicknesses available to be depleted by mass ! fluxes at the scalar points adjacent to the velocity point. These ! bounded layer thicknesses are consistent with the transport ! algorithm. do k = 1, kmax - dlm(k) = max(0._r8, min(p(i, j - 1, k + 1), pbv(i, j, n)) & - - max(p(i, j - 1, k ), ptv(i, j))) - dlp(k) = max(0._r8, min(p(i, j , k + 1), pbv(i, j, n)) & - - max(p(i, j , k ), ptv(i, j))) + dlm(k) = max(0._r8, min(p(i,j-1,k+1), pbv(i,j,n)) & + - max(p(i,j-1,k ), ptv(i,j))) + dlp(k) = max(0._r8, min(p(i,j ,k+1), pbv(i,j,n)) & + - max(p(i,j ,k ), ptv(i,j))) enddo ! Apply an iterative procedure for flux limiting by alternate upward @@ -1285,69 +1430,67 @@ subroutine eddtra_gm_cntiso_hybrid(m, n, mm, nn, k1m, k1n) do k = 1, kmax kn = k + nn write(lp,'(i3,3e16.8)') & - k, mfl(k + 1), mfl(k), & - (mfl(k + 1) - mfl(k)) & - /(max(onemm, dpv(i, j, kn))*delt1*scvx(i, j)) + k, mfl(k+1), mfl(k), & + (mfl(k+1) - mfl(k)) & + /(max(onemm, dpv(i,j,kn))*delt1*scvx(i,j)) enddo - write(lp,*) 'no convergence v', i + i0, j + j0 - call xchalt('(eddtra_gm_cntiso_hybrid)') - stop '(eddtra_gm_cntiso_hybrid)' + write(lp,*) 'no convergence v', i+i0, j+j0 + call xchalt('(eddtra_cntiso_hybrid)') + stop '(eddtra_cntiso_hybrid)' endif changed = .false. kdir = - kdir - do k = (1 + kdir + (1 - kdir)*kmax)/2, & - (1 - kdir + (1 + kdir)*kmax)/2, kdir + do k = (1+kdir+(1-kdir)*kmax)/2, (1-kdir+(1+kdir)*kmax)/2, kdir ! Proceed with flux limiting of this layer if the mass flux ! difference between lower and upper interface is beyond the ! floating point accuracy limitation. - if (abs(mfl(k + 1) - mfl(k)) > & - 1.e-14_r8*max(epsilp*scv2(i, j), & - abs(mfl(k + 1) + mfl(k)))) then + if (abs(mfl(k+1) - mfl(k)) > & + max(mfleps, eps*abs(mfl(k+1) + mfl(k)))) then - if (mfl(k + 1) - mfl(k) > & - ffac*max(epsilp, dlm(k))*scp2(i, j - 1)) then + if (mfl(k+1) - mfl(k) > & + ffac*max(epsilp, dlm(k))*scp2(i,j-1)) then ! In this case, the mass fluxes are removing too much - ! mass from the grid cell at (i, j - 1, k). Limit the + ! mass from the grid cell at (i,j-1,k). Limit the ! dominating interface flux. - q = fface*dlm(k)*scp2(i, j - 1) - if (mfl(k + 1) > - mfl(k)) then - if (mfl(k ) > - .5_r8*q) then - mfl(k + 1) = mfl(k ) + q + q = fface*dlm(k)*scp2(i,j-1) + if (mfl(k+1) > - mfl(k)) then + if (mfl(k ) > - .5_r8*q) then + mfl(k+1) = mfl(k ) + q else - mfl(k + 1) = .5_r8*q - mfl(k ) = - mfl(k + 1) + mfl(k+1) = .5_r8*q + mfl(k ) = - mfl(k+1) endif else - if (mfl(k + 1) < .5_r8*q) then - mfl(k ) = mfl(k + 1) - q + if (mfl(k+1) < .5_r8*q) then + mfl(k ) = mfl(k+1) - q else - mfl(k ) = - .5_r8*q - mfl(k + 1) = - mfl(k ) + mfl(k ) = - .5_r8*q + mfl(k+1) = - mfl(k ) endif endif changed = .true. - elseif (mfl(k + 1) - mfl(k) < & - - ffac*max(epsilp, dlp(k))*scp2(i, j )) then + elseif (mfl(k+1) - mfl(k) < & + - ffac*max(epsilp, dlp(k))*scp2(i,j )) then ! In this case, the mass fluxes are removing too much - ! mass from the grid cell at (i, j, k). Limit the + ! mass from the grid cell at (i,j,k). Limit the ! dominating interface flux. - q = fface*dlp(k)*scp2(i, j ) - if (mfl(k + 1) < - mfl(k)) then - if (mfl(k ) < .5_r8*q) then - mfl(k + 1) = mfl(k ) - q + q = fface*dlp(k)*scp2(i,j ) + if (mfl(k+1) < - mfl(k)) then + if (mfl(k ) < .5_r8*q) then + mfl(k+1) = mfl(k ) - q else - mfl(k + 1) = - .5_r8*q - mfl(k ) = - mfl(k + 1) + mfl(k+1) = - .5_r8*q + mfl(k ) = - mfl(k+1) endif else - if (mfl(k + 1) > - .5_r8*q) then - mfl(k ) = mfl(k + 1) + q + if (mfl(k+1) > - .5_r8*q) then + mfl(k ) = mfl(k+1) + q else - mfl(k ) = .5_r8*q - mfl(k + 1) = - mfl(k ) + mfl(k ) = .5_r8*q + mfl(k+1) = - mfl(k ) endif endif changed = .true. @@ -1358,34 +1501,77 @@ subroutine eddtra_gm_cntiso_hybrid(m, n, mm, nn, k1m, k1n) enddo + ! Adjust the GM and submesoscale eddy-induced mass fluxes so their + ! sum matches the limited total mass flux. + do k = 1, kmax+1 + if (abs(mfl(k)) < mfleps) then + mfl(k) = 0._r8 + mflgm(k) = 0._r8 + mflsm(k) = 0._r8 + elseif (mfl(k) > 0._r8) then + if (mflgm(k) > mflsm(k)) then + if (mfl(k) > 2._r8*mflsm(k)) then + mflgm(k) = mfl(k) - mflsm(k) + else + mflgm(k) = .5_r8*mfl(k) + mflsm(k) = mflgm(k) + endif + else + if (mfl(k) > 2._r8*mflgm(k)) then + mflsm(k) = mfl(k) - mflgm(k) + else + mflsm(k) = .5_r8*mfl(k) + mflgm(k) = mflsm(k) + endif + endif + else + if (mflgm(k) < mflsm(k)) then + if (mfl(k) < 2._r8*mflsm(k)) then + mflgm(k) = mfl(k) - mflsm(k) + else + mflgm(k) = .5_r8*mfl(k) + mflsm(k) = mflgm(k) + endif + else + if (mfl(k) < 2._r8*mflgm(k)) then + mflsm(k) = mfl(k) - mflgm(k) + else + mflsm(k) = .5_r8*mfl(k) + mflgm(k) = mflsm(k) + endif + endif + endif + enddo + ! ------------------------------------------------------------------ ! Compute the final mass fluxes. ! ------------------------------------------------------------------ do k = 1, kmax km = k + mm - if (abs(mfl(k + 1) - mfl(k)) > & - 1.e-14_r8*max(epsilp*scv2(i, j), & - abs(mfl(k + 1) + mfl(k)))) then - vmfltd(i, j, km) = mfl(k + 1) - mfl(k) + if (abs(mfl(k+1) - mfl(k)) > & + max(mfleps, eps*abs(mfl(k+1) + mfl(k)))) then + vmfltd(i,j,km) = mflgm(k+1) - mflgm(k) + vmflsm(i,j,km) = mflsm(k+1) - mflsm(k) else - vmfltd(i, j, km) = 0._r8 + vmfltd(i,j,km) = 0._r8 + vmflsm(i,j,km) = 0._r8 endif - if (vmfltd(i, j, km) > & - ffac*max(epsilp, dlm(k))*scp2(i, j - 1)) then - write(lp,*) 'eddtra_gm_cntiso_hybrid v >', & - i + i0, j + j0, k, vmfltd(i, j, km), & - ffac*max(epsilp, dlm(k))*scp2(i, j - 1) - call xchalt('(eddtra_gm_cntiso_hybrid)') - stop '(eddtra_gm_cntiso_hybrid)' + 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 >', & + 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)' endif - if (vmfltd(i, j, km) < & - - ffac*max(epsilp, dlp(k))*scp2(i, j )) then - write(lp,*) 'eddtra_gm_cntiso_hybrid v <', & - i + i0, j + j0, k, vmfltd(i, j, km), & - - ffac*max(epsilp, dlp(k))*scp2(i, j ) - call xchalt('(eddtra_gm_cntiso_hybrid)') - stop '(eddtra_gm_cntiso_hybrid)' + if (vmfltd(i,j,km) + vmflsm(i,j,km) < & + - ffac*max(epsilp, dlp(k))*scp2(i,j )) then + write(lp,*) 'eddtra_cntiso_hybrid 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)' endif enddo @@ -1394,7 +1580,7 @@ subroutine eddtra_gm_cntiso_hybrid(m, n, mm, nn, k1m, k1n) enddo !$omp end parallel do - end subroutine eddtra_gm_cntiso_hybrid + end subroutine eddtra_cntiso_hybrid ! --------------------------------------------------------------------------- ! Public procedures. @@ -1407,10 +1593,12 @@ subroutine eddtra(m, n, mm, nn, k1m, k1n) integer, intent(in) :: m, n, mm, nn, k1m, k1n + real(r8) :: q integer :: i, j, k, l, km - ! Compute eddy-induced transport of mass. if (vcoord_type_tag == isopyc_bulkml) then + + ! Compute eddy-induced transport of mass. if (eitmth_opt == eitmth_intdif) then call eddtra_intdif_isopyc_bulkml(m, n, mm, nn, k1m, k1n) elseif (eitmth_opt == eitmth_gm) then @@ -1424,9 +1612,37 @@ subroutine eddtra(m, n, mm, nn, k1m, k1n) call xcstop('(eddtra)') stop '(eddtra)' endif + + ! Diagnose eddy-induced transport components of heat and salt. + !$omp parallel do private(k, km, l, i) + do j = 1, jj + do k = 1, kk + km = k + mm + do l = 1, isu(j) + do i = max(1, ifu(j,l)), min(ii, ilu(j,l)) + utfltd(i,j,km) = .5_r8*umfltd(i,j,km) & + *(temp(i-1,j,km) + temp(i,j,km)) + usfltd(i,j,km) = .5_r8*umfltd(i,j,km) & + *(saln(i-1,j,km) + saln(i,j,km)) + enddo + enddo + do l = 1, isv(j) + do i = max(1, ifv(j,l)), min(ii, ilv(j,l)) + vtfltd(i,j,km) = .5_r8*vmfltd(i,j,km) & + *(temp(i,j-1,km) + temp(i,j,km)) + vsfltd(i,j,km) = .5_r8*vmfltd(i,j,km) & + *(saln(i,j-1,km) + saln(i,j,km)) + enddo + enddo + enddo + enddo + !$omp end parallel do + else + + ! Compute eddy-induced transport of mass. if (eitmth_opt == eitmth_gm) then - call eddtra_gm_cntiso_hybrid(m, n, mm, nn, k1m, k1n) + call eddtra_cntiso_hybrid(m, n, mm, nn, k1m, k1n) else if (mnproc == 1) then write(lp,'(a,i1,2a)') & @@ -1436,43 +1652,54 @@ subroutine eddtra(m, n, mm, nn, k1m, k1n) call xcstop('(eddtra)') stop '(eddtra)' endif - endif - ! Diagnose eddy-induced transport components of heat and salt. - !$omp parallel do private(k,km,l,i) - do j = 1, jj - do k = 1, kk - km = k + mm - do l = 1, isu(j) - do i = max(1, ifu(j, l)), min(ii, ilu(j, l)) - utfltd(i, j, km) = .5_r8*umfltd(i, j, km) & - *(temp(i - 1, j, km) + temp(i, j, km)) - usfltd(i, j, km) = .5_r8*umfltd(i, j, km) & - *(saln(i - 1, j, km) + saln(i, j, km)) - enddo - enddo - do l = 1, isv(j) - do i = max(1, ifv(j, l)), min(ii, ilv(j, l)) - vtfltd(i, j, km) = .5_r8*vmfltd(i, j, km) & - *(temp(i, j - 1, km) + temp(i, j, km)) - vsfltd(i, j, km) = .5_r8*vmfltd(i, j, km) & - *(saln(i, j - 1, km) + saln(i, j, km)) - enddo + ! Diagnose eddy-induced transport components of heat and salt. + !$omp parallel do private(k, km, l, i, q) + do j = 1, jj + do k = 1, kk + km = k + mm + do l = 1, isu(j) + do i = max(1, ifu(j,l)), min(ii, ilu(j,l)) + q = .5_r8*(temp(i-1,j,km) + temp(i,j,km)) + utfltd(i,j,km) = umfltd(i,j,km)*q + utflsm(i,j,km) = umflsm(i,j,km)*q + q = .5_r8*(saln(i-1,j,km) + saln(i,j,km)) + usfltd(i,j,km) = umfltd(i,j,km)*q + usflsm(i,j,km) = umflsm(i,j,km)*q + enddo + enddo + do l = 1, isv(j) + do i = max(1, ifv(j,l)), min(ii, ilv(j,l)) + q = .5_r8*(temp(i,j-1,km) + temp(i,j,km)) + vtfltd(i,j,km) = vmfltd(i,j,km)*q + vtflsm(i,j,km) = vmflsm(i,j,km)*q + q = .5_r8*(saln(i,j-1,km) + saln(i,j,km)) + vsfltd(i,j,km) = vmfltd(i,j,km)*q + vsflsm(i,j,km) = vmflsm(i,j,km)*q + enddo + enddo enddo enddo - enddo - !$omp end parallel do + !$omp end parallel do + + endif if (csdiag) then if (mnproc == 1) then write(lp,*) 'eddtra:' endif - call chksummsk(umfltd(1 - nbdy, 1 - nbdy, k1m), iu, kk, 'umfltd') - call chksummsk(vmfltd(1 - nbdy, 1 - nbdy, k1m), iv, kk, 'vmfltd') - call chksummsk(utfltd(1 - nbdy, 1 - nbdy, k1m), iu, kk, 'utfltd') - call chksummsk(vtfltd(1 - nbdy, 1 - nbdy, k1m), iv, kk, 'vtfltd') - call chksummsk(usfltd(1 - nbdy, 1 - nbdy, k1m), iu, kk, 'usfltd') - call chksummsk(vsfltd(1 - nbdy, 1 - nbdy, k1m), iv, kk, 'vsfltd') + call chksummsk(umfltd(1-nbdy, 1-nbdy, k1m), iu, kk, 'umfltd') + call chksummsk(vmfltd(1-nbdy, 1-nbdy, k1m), iv, kk, 'vmfltd') + call chksummsk(umflsm(1-nbdy, 1-nbdy, k1m), iu, kk, 'umflsm') + call chksummsk(vmflsm(1-nbdy, 1-nbdy, k1m), iv, kk, 'vmflsm') + call chksummsk(utfltd(1-nbdy, 1-nbdy, k1m), iu, kk, 'utfltd') + call chksummsk(vtfltd(1-nbdy, 1-nbdy, k1m), iv, kk, 'vtfltd') + call chksummsk(utflsm(1-nbdy, 1-nbdy, k1m), iu, kk, 'utflsm') + call chksummsk(vtflsm(1-nbdy, 1-nbdy, k1m), iv, kk, 'vtflsm') + call chksummsk(usfltd(1-nbdy, 1-nbdy, k1m), iu, kk, 'usfltd') + call chksummsk(vsfltd(1-nbdy, 1-nbdy, k1m), iv, kk, 'vsfltd') + call chksummsk(usflsm(1-nbdy, 1-nbdy, k1m), iu, kk, 'usflsm') + call chksummsk(vsflsm(1-nbdy, 1-nbdy, k1m), iv, kk, 'vsflsm') endif end subroutine eddtra diff --git a/phy/rdlim.F b/phy/rdlim.F index f4d00f76..17927f3b 100644 --- a/phy/rdlim.F +++ b/phy/rdlim.F @@ -27,8 +27,7 @@ subroutine rdlim use mod_config, only: expcnf, runid, inst_suffix use mod_constants, only: epsilt use mod_calendar, only: date_type, daynum_diff, calendar_errstr, - . calendar_noerr, operator(==), operator(<), - . operator(/=) + . operator(==), operator(<), operator(/=) use mod_time, only: date0, date, nday1, nday2, nstep0, nstep1, . nstep2, nstep, lstep, nstep_in_day, time0, . time, baclin, batrop, init_timevars, @@ -271,6 +270,22 @@ subroutine rdlim LYR_DIFVMO(1:nphy)=0 LYR_DIFVHO(1:nphy)=0 LYR_DIFVSO(1:nphy)=0 + LYR_UMFLSM(1:nphy)=0 + LYR_UTFLSM(1:nphy)=0 + LYR_USFLSM(1:nphy)=0 + LYR_VMFLSM(1:nphy)=0 + LYR_VTFLSM(1:nphy)=0 + LYR_VSFLSM(1:nphy)=0 + LVL_UMFLSM(1:nphy)=0 + LVL_UTFLSM(1:nphy)=0 + LVL_USFLSM(1:nphy)=0 + LVL_VMFLSM(1:nphy)=0 + LVL_VTFLSM(1:nphy)=0 + LVL_VSFLSM(1:nphy)=0 + MSC_MMFSML(1:nphy)=0 + MSC_MMFSMD(1:nphy)=0 + MSC_MHFSM (1:nphy)=0 + MSC_MSFSM (1:nphy)=0 LVL_DIFVMO(1:nphy)=0 LVL_DIFVHO(1:nphy)=0 LVL_DIFVSO(1:nphy)=0 @@ -383,18 +398,24 @@ subroutine rdlim write (lp,*) 'LYR_UTFLX ',LYR_UTFLX(1:nphy) write (lp,*) 'LYR_USFLX ',LYR_USFLX(1:nphy) write (lp,*) 'LYR_UMFLTD ',LYR_UMFLTD(1:nphy) + write (lp,*) 'LYR_UMFLSM ',LYR_UMFLSM(1:nphy) write (lp,*) 'LYR_UTFLTD ',LYR_UTFLTD(1:nphy) + write (lp,*) 'LYR_UTFLSM ',LYR_UTFLSM(1:nphy) write (lp,*) 'LYR_UTFLLD ',LYR_UTFLLD(1:nphy) write (lp,*) 'LYR_USFLTD ',LYR_USFLTD(1:nphy) + write (lp,*) 'LYR_USFLSM ',LYR_USFLSM(1:nphy) write (lp,*) 'LYR_USFLLD ',LYR_USFLLD(1:nphy) write (lp,*) 'LYR_UVEL ',LYR_UVEL(1:nphy) write (lp,*) 'LYR_VFLX ',LYR_VFLX(1:nphy) write (lp,*) 'LYR_VTFLX ',LYR_VTFLX(1:nphy) write (lp,*) 'LYR_VSFLX ',LYR_VSFLX(1:nphy) write (lp,*) 'LYR_VMFLTD ',LYR_VMFLTD(1:nphy) + write (lp,*) 'LYR_USFLSM ',LYR_USFLSM(1:nphy) write (lp,*) 'LYR_VTFLTD ',LYR_VTFLTD(1:nphy) + write (lp,*) 'LYR_VTFLSM ',LYR_VTFLSM(1:nphy) write (lp,*) 'LYR_VTFLLD ',LYR_VTFLLD(1:nphy) write (lp,*) 'LYR_VSFLTD ',LYR_VSFLTD(1:nphy) + write (lp,*) 'LYR_VSFLSM ',LYR_VSFLSM(1:nphy) write (lp,*) 'LYR_VSFLLD ',LYR_VSFLLD(1:nphy) write (lp,*) 'LYR_VVEL ',LYR_VVEL(1:nphy) write (lp,*) 'LYR_WFLX ',LYR_WFLX(1:nphy) @@ -419,18 +440,24 @@ subroutine rdlim write (lp,*) 'LVL_UTFLX ',LVL_UTFLX(1:nphy) write (lp,*) 'LVL_USFLX ',LVL_USFLX(1:nphy) write (lp,*) 'LVL_UMFLTD ',LVL_UMFLTD(1:nphy) + write (lp,*) 'LVL_UMFLSM ',LVL_UMFLSM(1:nphy) write (lp,*) 'LVL_UTFLTD ',LVL_UTFLTD(1:nphy) + write (lp,*) 'LVL_UTFLSM ',LVL_UTFLSM(1:nphy) write (lp,*) 'LVL_UTFLLD ',LVL_UTFLLD(1:nphy) write (lp,*) 'LVL_USFLTD ',LVL_USFLTD(1:nphy) + write (lp,*) 'LVL_USFLSM ',LVL_USFLSM(1:nphy) write (lp,*) 'LVL_USFLLD ',LVL_USFLLD(1:nphy) write (lp,*) 'LVL_UVEL ',LVL_UVEL(1:nphy) write (lp,*) 'LVL_VFLX ',LVL_VFLX(1:nphy) write (lp,*) 'LVL_VTFLX ',LVL_VTFLX(1:nphy) write (lp,*) 'LVL_VSFLX ',LVL_VSFLX(1:nphy) write (lp,*) 'LVL_VMFLTD ',LVL_VMFLTD(1:nphy) + write (lp,*) 'LVL_VMFLSM ',LVL_VMFLSM(1:nphy) write (lp,*) 'LVL_VTFLTD ',LVL_VTFLTD(1:nphy) + write (lp,*) 'LVL_VTFLSM ',LVL_VTFLSM(1:nphy) write (lp,*) 'LVL_VTFLLD ',LVL_VTFLLD(1:nphy) write (lp,*) 'LVL_VSFLTD ',LVL_VSFLTD(1:nphy) + write (lp,*) 'LVL_VSFLSM ',LVL_VSFLSM(1:nphy) write (lp,*) 'LVL_VSFLLD ',LVL_VSFLLD(1:nphy) write (lp,*) 'LVL_VVEL ',LVL_VVEL(1:nphy) write (lp,*) 'LVL_WFLX ',LVL_WFLX(1:nphy) @@ -442,12 +469,16 @@ subroutine rdlim write (lp,*) 'MSC_MMFLXL ',MSC_MMFLXL(1:nphy) write (lp,*) 'MSC_MMFLXD ',MSC_MMFLXD(1:nphy) write (lp,*) 'MSC_MMFTDL ',MSC_MMFTDL(1:nphy) + write (lp,*) 'MSC_MMFSML ',MSC_MMFSML(1:nphy) write (lp,*) 'MSC_MMFTDD ',MSC_MMFTDD(1:nphy) + write (lp,*) 'MSC_MMFSMD ',MSC_MMFSMD(1:nphy) write (lp,*) 'MSC_MHFLX ',MSC_MHFLX(1:nphy) write (lp,*) 'MSC_MHFTD ',MSC_MHFTD(1:nphy) + write (lp,*) 'MSC_MHFSM ',MSC_MHFSM(1:nphy) write (lp,*) 'MSC_MHFLD ',MSC_MHFLD(1:nphy) write (lp,*) 'MSC_MSFLX ',MSC_MSFLX(1:nphy) write (lp,*) 'MSC_MSFTD ',MSC_MSFTD(1:nphy) + write (lp,*) 'MSC_MSFSM ',MSC_MSFSM(1:nphy) write (lp,*) 'MSC_MSFLD ',MSC_MSFLD(1:nphy) write (lp,*) 'MSC_VOLTR ',MSC_VOLTR(1:nphy) write (lp,*) 'MSC_MASSGS ',MSC_MASSGS(1:nphy) @@ -541,18 +572,24 @@ subroutine rdlim call xcbcst(LYR_UTFLX) call xcbcst(LYR_USFLX) call xcbcst(LYR_UMFLTD) + call xcbcst(LYR_UMFLSM) call xcbcst(LYR_UTFLTD) + call xcbcst(LYR_UTFLSM) call xcbcst(LYR_UTFLLD) call xcbcst(LYR_USFLTD) + call xcbcst(LYR_USFLSM) call xcbcst(LYR_USFLLD) call xcbcst(LYR_UVEL) call xcbcst(LYR_VFLX) call xcbcst(LYR_VTFLX) call xcbcst(LYR_VSFLX) call xcbcst(LYR_VMFLTD) + call xcbcst(LYR_VMFLSM) call xcbcst(LYR_VTFLTD) + call xcbcst(LYR_VTFLSM) call xcbcst(LYR_VTFLLD) call xcbcst(LYR_VSFLTD) + call xcbcst(LYR_VSFLSM) call xcbcst(LYR_VSFLLD) call xcbcst(LYR_VVEL) call xcbcst(LYR_WFLX) @@ -576,18 +613,24 @@ subroutine rdlim call xcbcst(LVL_UTFLX) call xcbcst(LVL_USFLX) call xcbcst(LVL_UMFLTD) + call xcbcst(LVL_UMFLSM) call xcbcst(LVL_UTFLTD) + call xcbcst(LVL_UTFLSM) call xcbcst(LVL_UTFLLD) call xcbcst(LVL_USFLTD) + call xcbcst(LVL_USFLSM) call xcbcst(LVL_USFLLD) call xcbcst(LVL_UVEL) call xcbcst(LVL_VFLX) call xcbcst(LVL_VTFLX) call xcbcst(LVL_VSFLX) call xcbcst(LVL_VMFLTD) + call xcbcst(LVL_VMFLSM) call xcbcst(LVL_VTFLTD) + call xcbcst(LVL_VTFLSM) call xcbcst(LVL_VTFLLD) call xcbcst(LVL_VSFLTD) + call xcbcst(LVL_VSFLSM) call xcbcst(LVL_VSFLLD) call xcbcst(LVL_VVEL) call xcbcst(LVL_WFLX) @@ -599,12 +642,16 @@ subroutine rdlim call xcbcst(MSC_MMFLXL) call xcbcst(MSC_MMFLXD) call xcbcst(MSC_MMFTDL) + call xcbcst(MSC_MMFSML) call xcbcst(MSC_MMFTDD) + call xcbcst(MSC_MMFSMD) call xcbcst(MSC_MHFLX) call xcbcst(MSC_MHFTD) + call xcbcst(MSC_MHFSM) call xcbcst(MSC_MHFLD) call xcbcst(MSC_MSFLX) call xcbcst(MSC_MSFTD) + call xcbcst(MSC_MSFSM) call xcbcst(MSC_MSFLD) call xcbcst(MSC_VOLTR) call xcbcst(MSC_MASSGS) @@ -626,9 +673,10 @@ subroutine rdlim c --- read merdia namelist if needed c if (sum(MSC_MMFLXL(1:nphy)+MSC_MMFLXD(1:nphy)+MSC_MMFTDL(1:nphy) - . +MSC_MMFTDD(1:nphy)+MSC_MHFLX(1:nphy)+MSC_MHFTD(1:nphy) - . +MSC_MHFLD(1:nphy)+MSC_MSFLX(1:nphy)+MSC_MSFTD(1:nphy) - . +MSC_MSFLD(1:nphy)).ne.0) then + . +MSC_MMFSML(1:nphy)+MSC_MMFTDD(1:nphy)+MSC_MMFSMD(1:nphy) + . +MSC_MHFLX (1:nphy)+MSC_MHFTD (1:nphy)+MSC_MHFSM (1:nphy) + . +MSC_MHFLD (1:nphy)+MSC_MSFLX (1:nphy)+MSC_MSFTD (1:nphy) + . +MSC_MSFSM (1:nphy)+MSC_MSFLD (1:nphy)).ne.0) then c if (mnproc.eq.1) then c diff --git a/phy/restart_rd.F b/phy/restart_rd.F index 4a9edc36..576f1a56 100644 --- a/phy/restart_rd.F +++ b/phy/restart_rd.F @@ -277,6 +277,17 @@ subroutine restart_rd write (lp,*) . 'will be initialized to zero.' endif +c + vexist=ncinqv('umflsm') +! call xcbcst(vexist) + if (vexist) then + call ncread('umflsm',umflsm,iuu,1,0.) + elseif (mnproc.eq.1) then + write (lp,*) + . 'Warning: field ''umflsm'' is not read from restart file and' + write (lp,*) + . 'will be initialized to zero.' + endif c vexist=ncinqv('utfltd') ! call xcbcst(vexist) @@ -288,6 +299,17 @@ subroutine restart_rd write (lp,*) . 'will be initialized to zero.' endif +c + vexist=ncinqv('utflsm') +! call xcbcst(vexist) + if (vexist) then + call ncread('utflsm',utflsm,iuu,1,0.) + elseif (mnproc.eq.1) then + write (lp,*) + . 'Warning: field ''utflsm'' is not read from restart file and' + write (lp,*) + . 'will be initialized to zero.' + endif c vexist=ncinqv('utflld') ! call xcbcst(vexist) @@ -310,6 +332,17 @@ subroutine restart_rd write (lp,*) . 'will be initialized to zero.' endif +c + vexist=ncinqv('usflsm') +! call xcbcst(vexist) + if (vexist) then + call ncread('usflsm',usflsm,iuu,1,0.) + elseif (mnproc.eq.1) then + write (lp,*) + . 'Warning: field ''usflsm'' is not read from restart file and' + write (lp,*) + . 'will be initialized to zero.' + endif c vexist=ncinqv('usflld') ! call xcbcst(vexist) @@ -336,6 +369,17 @@ subroutine restart_rd write (lp,*) . 'will be initialized to zero.' endif +c + vexist=ncinqv('vmflsm') +! call xcbcst(vexist) + if (vexist) then + call ncread('vmflsm',vmflsm,ivv,1,0.) + elseif (mnproc.eq.1) then + write (lp,*) + . 'Warning: field ''vmflsm'' is not read from restart file and' + write (lp,*) + . 'will be initialized to zero.' + endif c vexist=ncinqv('vtfltd') ! call xcbcst(vexist) @@ -347,6 +391,17 @@ subroutine restart_rd write (lp,*) . 'will be initialized to zero.' endif +c + vexist=ncinqv('vtflsm') +! call xcbcst(vexist) + if (vexist) then + call ncread('vtflsm',vtflsm,ivv,1,0.) + elseif (mnproc.eq.1) then + write (lp,*) + . 'Warning: field ''vtflsm'' is not read from restart file and' + write (lp,*) + . 'will be initialized to zero.' + endif c vexist=ncinqv('vtflld') ! call xcbcst(vexist) @@ -369,6 +424,17 @@ subroutine restart_rd write (lp,*) . 'will be initialized to zero.' endif +c + vexist=ncinqv('vsflsm') +! call xcbcst(vexist) + if (vexist) then + call ncread('vsflsm',vsflsm,ivv,1,0.) + elseif (mnproc.eq.1) then + write (lp,*) + . 'Warning: field ''vsflsm'' is not read from restart file and' + write (lp,*) + . 'will be initialized to zero.' + endif c vexist=ncinqv('vsflld') ! call xcbcst(vexist) @@ -811,10 +877,18 @@ subroutine restart_rd . phylyr(1-nbdy,1-nbdy,1,ACC_UMFLTD(n)),iuu,1,0.) if (ACC_VMFLTD(n).ne.0) call ncread('vmfltd_phy'//c2, . phylyr(1-nbdy,1-nbdy,1,ACC_VMFLTD(n)),ivv,1,0.) + if (ACC_UMFLSM(n).ne.0) call ncread('umflsm_phy'//c2, + . phylyr(1-nbdy,1-nbdy,1,ACC_UMFLSM(n)),iuu,1,0.) + if (ACC_VMFLSM(n).ne.0) call ncread('vmflsm_phy'//c2, + . phylyr(1-nbdy,1-nbdy,1,ACC_VMFLSM(n)),ivv,1,0.) if (ACC_UTFLTD(n).ne.0) call ncread('utfltd_phy'//c2, . phylyr(1-nbdy,1-nbdy,1,ACC_UTFLTD(n)),iuu,1,0.) if (ACC_VTFLTD(n).ne.0) call ncread('vtfltd_phy'//c2, . phylyr(1-nbdy,1-nbdy,1,ACC_VTFLTD(n)),ivv,1,0.) + if (ACC_UTFLSM(n).ne.0) call ncread('utflsm_phy'//c2, + . phylyr(1-nbdy,1-nbdy,1,ACC_UTFLSM(n)),iuu,1,0.) + if (ACC_VTFLSM(n).ne.0) call ncread('vtflsm_phy'//c2, + . phylyr(1-nbdy,1-nbdy,1,ACC_VTFLSM(n)),ivv,1,0.) if (ACC_UTFLLD(n).ne.0) call ncread('utflld_phy'//c2, . phylyr(1-nbdy,1-nbdy,1,ACC_UTFLLD(n)),iuu,1,0.) if (ACC_VTFLLD(n).ne.0) call ncread('vtflld_phy'//c2, @@ -823,6 +897,10 @@ subroutine restart_rd . phylyr(1-nbdy,1-nbdy,1,ACC_USFLTD(n)),iuu,1,0.) if (ACC_VSFLTD(n).ne.0) call ncread('vsfltd_phy'//c2, . phylyr(1-nbdy,1-nbdy,1,ACC_VSFLTD(n)),ivv,1,0.) + if (ACC_USFLSM(n).ne.0) call ncread('usflsm_phy'//c2, + . phylyr(1-nbdy,1-nbdy,1,ACC_USFLSM(n)),iuu,1,0.) + if (ACC_VSFLSM(n).ne.0) call ncread('vsflsm_phy'//c2, + . phylyr(1-nbdy,1-nbdy,1,ACC_VSFLSM(n)),ivv,1,0.) if (ACC_USFLLD(n).ne.0) call ncread('usflld_phy'//c2, . phylyr(1-nbdy,1-nbdy,1,ACC_USFLLD(n)),iuu,1,0.) if (ACC_VSFLLD(n).ne.0) call ncread('vsflld_phy'//c2, @@ -887,10 +965,18 @@ subroutine restart_rd . phylvl(1-nbdy,1-nbdy,1,ACC_UMFLTDLVL(n)),iuu,1,0.) if (ACC_VMFLTDLVL(n).ne.0) call ncread('vmfltdlvl_phy'//c2, . phylvl(1-nbdy,1-nbdy,1,ACC_VMFLTDLVL(n)),ivv,1,0.) + if (ACC_UMFLSMLVL(n).ne.0) call ncread('umflsmlvl_phy'//c2, + . phylvl(1-nbdy,1-nbdy,1,ACC_UMFLSMLVL(n)),iuu,1,0.) + if (ACC_VMFLSMLVL(n).ne.0) call ncread('vmflsmlvl_phy'//c2, + . phylvl(1-nbdy,1-nbdy,1,ACC_VMFLSMLVL(n)),ivv,1,0.) if (ACC_UTFLTDLVL(n).ne.0) call ncread('utfltdlvl_phy'//c2, . phylvl(1-nbdy,1-nbdy,1,ACC_UTFLTDLVL(n)),iuu,1,0.) if (ACC_VTFLTDLVL(n).ne.0) call ncread('vtfltdlvl_phy'//c2, . phylvl(1-nbdy,1-nbdy,1,ACC_VTFLTDLVL(n)),ivv,1,0.) + if (ACC_UTFLSMLVL(n).ne.0) call ncread('utflsmlvl_phy'//c2, + . phylvl(1-nbdy,1-nbdy,1,ACC_UTFLSMLVL(n)),iuu,1,0.) + if (ACC_VTFLSMLVL(n).ne.0) call ncread('vtflsmlvl_phy'//c2, + . phylvl(1-nbdy,1-nbdy,1,ACC_VTFLSMLVL(n)),ivv,1,0.) if (ACC_UTFLLDLVL(n).ne.0) call ncread('utflldlvl_phy'//c2, . phylvl(1-nbdy,1-nbdy,1,ACC_UTFLLDLVL(n)),iuu,1,0.) if (ACC_VTFLLDLVL(n).ne.0) call ncread('vtflldlvl_phy'//c2, @@ -899,6 +985,10 @@ subroutine restart_rd . phylvl(1-nbdy,1-nbdy,1,ACC_USFLTDLVL(n)),iuu,1,0.) if (ACC_VSFLTDLVL(n).ne.0) call ncread('vsfltdlvl_phy'//c2, . phylvl(1-nbdy,1-nbdy,1,ACC_VSFLTDLVL(n)),ivv,1,0.) + if (ACC_USFLSMLVL(n).ne.0) call ncread('usflsmlvl_phy'//c2, + . phylvl(1-nbdy,1-nbdy,1,ACC_USFLSMLVL(n)),iuu,1,0.) + if (ACC_VSFLSMLVL(n).ne.0) call ncread('vsflsmlvl_phy'//c2, + . phylvl(1-nbdy,1-nbdy,1,ACC_VSFLSMLVL(n)),ivv,1,0.) if (ACC_USFLLDLVL(n).ne.0) call ncread('usflldlvl_phy'//c2, . phylvl(1-nbdy,1-nbdy,1,ACC_USFLLDLVL(n)),iuu,1,0.) if (ACC_VSFLLDLVL(n).ne.0) call ncread('vsflldlvl_phy'//c2, diff --git a/phy/restart_wt.F b/phy/restart_wt.F index b843888e..a7cc43a5 100644 --- a/phy/restart_wt.F +++ b/phy/restart_wt.F @@ -299,6 +299,12 @@ subroutine restart_wt call wrtrst('dpv',trim(c5p)//' kk2 time',dpv,iv) call wrtrst('difiso',trim(c5p)//' kk time',difiso,ip) call wrtrst('OBLdepth',trim(c5p)//' time',OBLdepth,ip) + call wrtrst('umflsm',trim(c5u)//' kk2 time',umflsm,iuu) + call wrtrst('utflsm',trim(c5u)//' kk2 time',utflsm,iuu) + call wrtrst('usflsm',trim(c5u)//' kk2 time',usflsm,iuu) + call wrtrst('vmflsm',trim(c5v)//' kk2 time',vmflsm,ivv) + call wrtrst('vtflsm',trim(c5v)//' kk2 time',vtflsm,ivv) + call wrtrst('vsflsm',trim(c5v)//' kk2 time',vsflsm,ivv) endif c if (sprfac) then @@ -542,12 +548,24 @@ subroutine restart_wt . iuu) if (ACC_VMFLTD(n).ne.0) call wrtrst('vmfltd_phy'//c2, . trim(c5v)//' kk time',phylyr(1-nbdy,1-nbdy,1,ACC_VMFLTD(n)), + . ivv) + if (ACC_UMFLSM(n).ne.0) call wrtrst('umflsm_phy'//c2, + . trim(c5u)//' kk time',phylyr(1-nbdy,1-nbdy,1,ACC_UMFLSM(n)), + . iuu) + if (ACC_VMFLSM(n).ne.0) call wrtrst('vmflsm_phy'//c2, + . trim(c5v)//' kk time',phylyr(1-nbdy,1-nbdy,1,ACC_VMFLSM(n)), . ivv) if (ACC_UTFLTD(n).ne.0) call wrtrst('utfltd_phy'//c2, . trim(c5u)//' kk time',phylyr(1-nbdy,1-nbdy,1,ACC_UTFLTD(n)), . iuu) if (ACC_VTFLTD(n).ne.0) call wrtrst('vtfltd_phy'//c2, . trim(c5v)//' kk time',phylyr(1-nbdy,1-nbdy,1,ACC_VTFLTD(n)), + . ivv) + if (ACC_UTFLSM(n).ne.0) call wrtrst('utflsm_phy'//c2, + . trim(c5u)//' kk time',phylyr(1-nbdy,1-nbdy,1,ACC_UTFLSM(n)), + . iuu) + if (ACC_VTFLSM(n).ne.0) call wrtrst('vtflsm_phy'//c2, + . trim(c5v)//' kk time',phylyr(1-nbdy,1-nbdy,1,ACC_VTFLSM(n)), . ivv) if (ACC_UTFLLD(n).ne.0) call wrtrst('utflld_phy'//c2, . trim(c5u)//' kk time',phylyr(1-nbdy,1-nbdy,1,ACC_UTFLLD(n)), @@ -560,6 +578,12 @@ subroutine restart_wt . iuu) if (ACC_VSFLTD(n).ne.0) call wrtrst('vsfltd_phy'//c2, . trim(c5v)//' kk time',phylyr(1-nbdy,1-nbdy,1,ACC_VSFLTD(n)), + . ivv) + if (ACC_USFLSM(n).ne.0) call wrtrst('usflsm_phy'//c2, + . trim(c5u)//' kk time',phylyr(1-nbdy,1-nbdy,1,ACC_USFLSM(n)), + . iuu) + if (ACC_VSFLSM(n).ne.0) call wrtrst('vsflsm_phy'//c2, + . trim(c5v)//' kk time',phylyr(1-nbdy,1-nbdy,1,ACC_VSFLSM(n)), . ivv) if (ACC_USFLLD(n).ne.0) call wrtrst('usflld_phy'//c2, . trim(c5u)//' kk time',phylyr(1-nbdy,1-nbdy,1,ACC_USFLLD(n)), @@ -639,12 +663,24 @@ subroutine restart_wt if (ACC_VMFLTDLVL(n).ne.0) call wrtrst('vmfltdlvl_phy'//c2, . trim(c5v)//' plev time',phylvl(1-nbdy,1-nbdy,1, . ACC_VMFLTDLVL(n)),ivv) + if (ACC_UMFLSMLVL(n).ne.0) call wrtrst('umflsmlvl_phy'//c2, + . trim(c5u)//' plev time',phylvl(1-nbdy,1-nbdy,1, + . ACC_UMFLSMLVL(n)),iuu) + if (ACC_VMFLSMLVL(n).ne.0) call wrtrst('vmflsmlvl_phy'//c2, + . trim(c5v)//' plev time',phylvl(1-nbdy,1-nbdy,1, + . ACC_VMFLSMLVL(n)),ivv) if (ACC_UTFLTDLVL(n).ne.0) call wrtrst('utfltdlvl_phy'//c2, . trim(c5u)//' plev time',phylvl(1-nbdy,1-nbdy,1, . ACC_UTFLTDLVL(n)),iuu) if (ACC_VTFLTDLVL(n).ne.0) call wrtrst('vtfltdlvl_phy'//c2, . trim(c5v)//' plev time',phylvl(1-nbdy,1-nbdy,1, . ACC_VTFLTDLVL(n)),ivv) + if (ACC_UTFLSMLVL(n).ne.0) call wrtrst('utflsmlvl_phy'//c2, + . trim(c5u)//' plev time',phylvl(1-nbdy,1-nbdy,1, + . ACC_UTFLSMLVL(n)),iuu) + if (ACC_VTFLSMLVL(n).ne.0) call wrtrst('vtflsmlvl_phy'//c2, + . trim(c5v)//' plev time',phylvl(1-nbdy,1-nbdy,1, + . ACC_VTFLSMLVL(n)),ivv) if (ACC_UTFLLDLVL(n).ne.0) call wrtrst('utflldlvl_phy'//c2, . trim(c5u)//' plev time',phylvl(1-nbdy,1-nbdy,1, . ACC_UTFLLDLVL(n)),iuu) @@ -657,6 +693,12 @@ subroutine restart_wt if (ACC_VSFLTDLVL(n).ne.0) call wrtrst('vsfltdlvl_phy'//c2, . trim(c5v)//' plev time',phylvl(1-nbdy,1-nbdy,1, . ACC_VSFLTDLVL(n)),ivv) + if (ACC_USFLSMLVL(n).ne.0) call wrtrst('usflsmlvl_phy'//c2, + . trim(c5u)//' plev time',phylvl(1-nbdy,1-nbdy,1, + . ACC_USFLSMLVL(n)),iuu) + if (ACC_VSFLSMLVL(n).ne.0) call wrtrst('vsflsmlvl_phy'//c2, + . trim(c5v)//' plev time',phylvl(1-nbdy,1-nbdy,1, + . ACC_VSFLSMLVL(n)),ivv) if (ACC_USFLLDLVL(n).ne.0) call wrtrst('usflldlvl_phy'//c2, . trim(c5u)//' plev time',phylvl(1-nbdy,1-nbdy,1, . ACC_USFLLDLVL(n)),iuu) @@ -903,6 +945,12 @@ subroutine defvar_restart(c5p,c5u,c5v,c5q) call defvarrst('dpv',trim(c5p)//' kk2 time') call defvarrst('difiso',trim(c5p)//' kk time') call defvarrst('OBLdepth',trim(c5p)//' time') + call defvarrst('umflsm',trim(c5u)//' kk2 time') + call defvarrst('utflsm',trim(c5u)//' kk2 time') + call defvarrst('usflsm',trim(c5u)//' kk2 time') + call defvarrst('vmflsm',trim(c5v)//' kk2 time') + call defvarrst('vtflsm',trim(c5v)//' kk2 time') + call defvarrst('vsflsm',trim(c5v)//' kk2 time') endif c if (sprfac) then @@ -1131,10 +1179,18 @@ subroutine defvar_restart(c5p,c5u,c5v,c5q) if (ACC_UMFLTD(n).ne.0) call defvarrst('umfltd_phy'//c2, . trim(c5u)//' kk time') if (ACC_VMFLTD(n).ne.0) call defvarrst('vmfltd_phy'//c2, + . trim(c5v)//' kk time') + if (ACC_UMFLSM(n).ne.0) call defvarrst('umflsm_phy'//c2, + . trim(c5u)//' kk time') + if (ACC_VMFLSM(n).ne.0) call defvarrst('vmflsm_phy'//c2, . trim(c5v)//' kk time') if (ACC_UTFLTD(n).ne.0) call defvarrst('utfltd_phy'//c2, . trim(c5u)//' kk time') if (ACC_VTFLTD(n).ne.0) call defvarrst('vtfltd_phy'//c2, + . trim(c5v)//' kk time') + if (ACC_UTFLSM(n).ne.0) call defvarrst('utflsm_phy'//c2, + . trim(c5u)//' kk time') + if (ACC_VTFLSM(n).ne.0) call defvarrst('vtflsm_phy'//c2, . trim(c5v)//' kk time') if (ACC_UTFLLD(n).ne.0) call defvarrst('utflld_phy'//c2, . trim(c5u)//' kk time') @@ -1143,6 +1199,10 @@ subroutine defvar_restart(c5p,c5u,c5v,c5q) if (ACC_USFLTD(n).ne.0) call defvarrst('usfltd_phy'//c2, . trim(c5u)//' kk time') if (ACC_VSFLTD(n).ne.0) call defvarrst('vsfltd_phy'//c2, + . trim(c5v)//' kk time') + if (ACC_USFLSM(n).ne.0) call defvarrst('usflsm_phy'//c2, + . trim(c5u)//' kk time') + if (ACC_VSFLSM(n).ne.0) call defvarrst('vsflsm_phy'//c2, . trim(c5v)//' kk time') if (ACC_USFLLD(n).ne.0) call defvarrst('usflld_phy'//c2, . trim(c5u)//' kk time') @@ -1197,10 +1257,18 @@ subroutine defvar_restart(c5p,c5u,c5v,c5q) if (ACC_UMFLTDLVL(n).ne.0) call defvarrst('umfltdlvl_phy'//c2, . trim(c5u)//' plev time') if (ACC_VMFLTDLVL(n).ne.0) call defvarrst('vmfltdlvl_phy'//c2, + . trim(c5v)//' plev time') + if (ACC_UMFLSMLVL(n).ne.0) call defvarrst('umflsmlvl_phy'//c2, + . trim(c5u)//' plev time') + if (ACC_VMFLSMLVL(n).ne.0) call defvarrst('vmflsmlvl_phy'//c2, . trim(c5v)//' plev time') if (ACC_UTFLTDLVL(n).ne.0) call defvarrst('utfltdlvl_phy'//c2, . trim(c5u)//' plev time') if (ACC_VTFLTDLVL(n).ne.0) call defvarrst('vtfltdlvl_phy'//c2, + . trim(c5v)//' plev time') + if (ACC_UTFLSMLVL(n).ne.0) call defvarrst('utflsmlvl_phy'//c2, + . trim(c5u)//' plev time') + if (ACC_VTFLSMLVL(n).ne.0) call defvarrst('vtflsmlvl_phy'//c2, . trim(c5v)//' plev time') if (ACC_UTFLLDLVL(n).ne.0) call defvarrst('utflldlvl_phy'//c2, . trim(c5u)//' plev time') @@ -1209,6 +1277,10 @@ subroutine defvar_restart(c5p,c5u,c5v,c5q) if (ACC_USFLTDLVL(n).ne.0) call defvarrst('usfltdlvl_phy'//c2, . trim(c5u)//' plev time') if (ACC_VSFLTDLVL(n).ne.0) call defvarrst('vsfltdlvl_phy'//c2, + . trim(c5v)//' plev time') + if (ACC_USFLSMLVL(n).ne.0) call defvarrst('usflsmlvl_phy'//c2, + . trim(c5u)//' plev time') + if (ACC_VSFLSMLVL(n).ne.0) call defvarrst('vsflsmlvl_phy'//c2, . trim(c5v)//' plev time') if (ACC_USFLLDLVL(n).ne.0) call defvarrst('usflldlvl_phy'//c2, . trim(c5u)//' plev time') diff --git a/tests/fuk95/limits b/tests/fuk95/limits index b2dc21d5..af781e52 100644 --- a/tests/fuk95/limits +++ b/tests/fuk95/limits @@ -384,15 +384,19 @@ ! UTFLTD - heat flux due to thickness diffusion in x-direction [W] ! UTFLLD - heat flux due to lateral diffusion in x-direction [W] ! USFLTD - salt flux due to thickness diffusion in x-direction [kg s-1] +! USFLSM - salt flux due to submesoscale transport in x-direction [kg s-1] ! USFLLD - salt flux due to lateral diffusion in x-direction [kg s-1] ! UVEL - velocity x-component [m s-1] ! VFLX - mass flux in y-direction [kg s-1] ! VTFLX - heat flux in y-direction [W] ! VSFLX - salt flux in y-direction [kg s-1] ! VMFLTD - mass flux due to thickness diffusion in y-direction [kg s-1] +! VMFLSM - mass flux due to submesoscale transport in y-direction [kg s-1] ! VTFLTD - heat flux due to thickness diffusion in y-direction [W] +! VTFLSM - heat flux due to submesoscale transport in y-direction [W] ! VTFLLD - heat flux due to lateral diffusion in y-direction [W] ! VSFLTD - salt flux due to thickness diffusion in y-direction [kg s-1] +! VSFLSM - salt flux due to submesoscale transport in y-direction [kg s-1] ! VSFLLD - salt flux due to lateral diffusion in y-direction [kg s-1] ! VVEL - velocity x-component [m s-1] ! WFLX - vertical mass flux [kg s-1] @@ -404,12 +408,16 @@ ! MMFLXL - meridional overturning circ. (MOC) on isopycnic layers [kg s-1] ! MMFLXD - MOC on z-levels [kg s-1] ! MMFTDL - MOC due to thickness diffusion on isopycnic layers [kg s-1] +! MMFSML - MOC due to submesoscale transport on isopycnic layers [kg s-1] ! MMFTDD - MOC due to thickness diffusion on z-levels [kg s-1] +! MMFSMD - MOC due to submesoscale transport on z-levels [kg s-1] ! MHFLX - meridional heat flux [W] ! MHFTD - meridional heat flux due to thickness diffusion [W] +! MHFSM - meridional heat flux due to submesoscale transport [W] ! MHFLD - meridional heat flux due to lateral diffusion [W] ! MSFLX - meridional salt flux [kg s-1] ! MSFTD - meridional salt flux due to thickness diffusion [kg s-1] +! MSFSM - meridional salt flux due to submesoscale transport [kg s-1] ! MSFLD - meridional salt flux due to lateral diffusion [kg s-1] ! VOLTR - section transports [kg s-1] ! MASSGS - global sum of mass [kg] @@ -502,18 +510,24 @@ LYR_UTFLX = 0, 4 LYR_USFLX = 0, 4 LYR_UMFLTD = 0, 0 + LYR_UMFLSM = 0, 0 LYR_UTFLTD = 0, 0 + LYR_UTFLSM = 0, 0 LYR_UTFLLD = 0, 0 LYR_USFLTD = 0, 0 + LYR_USFLSM = 0, 0 LYR_USFLLD = 0, 0 LYR_UVEL = 0, 4 LYR_VFLX = 0, 4 LYR_VTFLX = 0, 4 LYR_VSFLX = 0, 4 LYR_VMFLTD = 0, 0 + LYR_VMFLSM = 0, 0 LYR_VTFLTD = 0, 0 + LYR_VTFLSM = 0, 0 LYR_VTFLLD = 0, 0 LYR_VSFLTD = 0, 0 + LYR_VSFLSM = 0, 0 LYR_VSFLLD = 0, 0 LYR_VVEL = 0, 4 LYR_WFLX = 0, 4 @@ -537,18 +551,24 @@ LVL_UTFLX = 0, 4 LVL_USFLX = 0, 4 LVL_UMFLTD = 0, 0 + LVL_UMFLSM = 0, 0 LVL_UTFLTD = 0, 0 + LVL_UTFLSM = 0, 0 LVL_UTFLLD = 0, 0 LVL_USFLTD = 0, 0 + LVL_USFLSM = 0, 0 LVL_USFLLD = 0, 0 LVL_UVEL = 0, 4 LVL_VFLX = 0, 4 LVL_VTFLX = 0, 4 LVL_VSFLX = 0, 4 LVL_VMFLTD = 0, 0 + LVL_VMFLSM = 0, 0 LVL_VTFLTD = 0, 0 + LVL_VTFLSM = 0, 0 LVL_VTFLLD = 0, 0 LVL_VSFLTD = 0, 0 + LVL_VSFLSM = 0, 0 LVL_VSFLLD = 0, 0 LVL_VVEL = 0, 4 LVL_WFLX = 0, 4 @@ -560,12 +580,16 @@ MSC_MMFLXL = 0, 0 MSC_MMFLXD = 0, 0 MSC_MMFTDL = 0, 0 + MSC_MMFSML = 0, 0 MSC_MMFTDD = 0, 0 + MSC_MMFSMD = 0, 0 MSC_MHFLX = 0, 0 MSC_MHFTD = 0, 0 + MSC_MHFSM = 0, 0 MSC_MHFLD = 0, 0 MSC_MSFLX = 0, 0 MSC_MSFTD = 0, 0 + MSC_MSFSM = 0, 0 MSC_MSFLD = 0, 0 MSC_VOLTR = 0, 0 MSC_MASSGS = 4, 0 From 2310ec359d975157544f97df4b2dc50382a7c2ce Mon Sep 17 00:00:00 2001 From: Mats Bentsen Date: Mon, 2 Jan 2023 22:56:05 +0100 Subject: [PATCH 242/366] Added separate non-local terms for vertical distribution of surface temperature restoring flux, surface salinity restoring flux and brine flux. --- ben02/thermf_ben02.F | 121 +++++++++++++++++------ cesm/thermf_cesm.F | 114 ++++++++++++++++------ cime_config/buildnml | 11 ++- phy/cntiso_hybrid_forcing.F90 | 176 ++++++++++++++++++++++++++-------- phy/mod_difest.F | 8 +- phy/mod_diffusion.F90 | 31 +++++- phy/mod_forcing.F90 | 36 ++++++- phy/mod_vdiff.F90 | 60 +++++++----- phy/restart_rd.F | 7 +- phy/restart_wt.F | 11 ++- 10 files changed, 441 insertions(+), 134 deletions(-) diff --git a/ben02/thermf_ben02.F b/ben02/thermf_ben02.F index fcd5bd19..dad8a331 100644 --- a/ben02/thermf_ben02.F +++ b/ben02/thermf_ben02.F @@ -1,5 +1,5 @@ ! ------------------------------------------------------------------------------ -! Copyright (C) 2002-2022 Mats Bentsen, Mehmet Ilicak +! Copyright (C) 2002-2023 Mats Bentsen, Mehmet Ilicak ! ! This file is part of BLOM. ! @@ -27,6 +27,7 @@ subroutine thermf_ben02(m,n,mm,nn,k1m,k1n) . nstep_in_day, baclin, . xmi, l1mi, l2mi, l3mi, l4mi, l5mi use mod_xc + use mod_vcoord, only: vcoord_type_tag, isopyc_bulkml use mod_grid, only: scp2, plat, area use mod_state, only: dp, temp, saln, p use mod_swtfrz, only: swtfrz @@ -36,7 +37,8 @@ subroutine thermf_ben02(m,n,mm,nn,k1m,k1n) . trxdpt, srxdpt, trxlim, srxlim, srxbal, . swa, nsf, hmltfz, lip, sop, eva, rnf, rfi, . fmltfz, sfl, ustarw, surflx, surrlx, - . sswflx, salflx, brnflx, salrlx, ustar + . sswflx, salflx, brnflx, salrlx, ustar, + . t_rs_nonloc, s_rs_nonloc use mod_swabs, only: swbgal, swbgfc use mod_ben02, only: tsi_tda, tml_tda, sml_tda, alb_tda, fice_tda, . tsi, ntda, dfl, albw, alb, @@ -53,7 +55,7 @@ subroutine thermf_ben02(m,n,mm,nn,k1m,k1n) use mod_tracers, only: ntr, itrtke, itrgls, trc, trflx # ifdef GLS use mod_diffusion, only: difdia - use mod_tke, only: gls_cmu0, zos, gls_p, gls_m, gls_n, vonKar + use mod_tke, only: gls_cmu0, Zos, gls_p, gls_m, gls_n, vonKar # endif # else use mod_tracers, only: ntr, trc, trflx @@ -66,13 +68,13 @@ subroutine thermf_ben02(m,n,mm,nn,k1m,k1n) c real, dimension(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy) :: vrtsfl c - integer i,j,k,l,m1,m2,m3,m4,m5 + integer i,j,k,l,m1,m2,m3,m4,m5,ntld,kn,kl real dt,cpsw,rnf_fac,sag_fac,y, - . dpotl,hotl,totl,sotl,dpmxl,hmxl,tmxl,smxl,tice_f,hice_min, - . fice,hice,hsnw,tsrf,fice0,hice0,hsnw0,qsww,qnsw,tice,albi, - . tsmlt,albi_h,qswi,dh,qsnwf,fcond,qdamp,qsmlt,qo2i,qbot,swfac, - . dtml,q,volice,df,dvi,dvs,fwflx,sstc,rice,trxflx,sssc,srxflx, - . totsfl,totwfl,sflxc,totsrp,totsrn,A_cgs2mks + . dpotl,hotl,totl,sotl,tice_f,hice_min,fice,hice,hsnw,tsrf, + . fice0,hice0,hsnw0,qsww,qnsw,tice,albi,tsmlt,albi_h,qswi,dh, + . qsnwf,fcond,qdamp,qsmlt,qo2i,qbot,swfac,dtml,q,volice,df,dvi, + . dvs,fwflx,sstc,rice,dpmxl,hmxl,tmxl,trxflx,pbot,dprsi,sssc, + . smxl,srxflx,totsfl,totwfl,sflxc,totsrp,totsrn,A_cgs2mks #ifdef TRC integer nt real, dimension(ntr,1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy) :: @@ -116,15 +118,16 @@ subroutine thermf_ben02(m,n,mm,nn,k1m,k1n) m5=mod(m3+ 1,48)+1 c c --- Time level for diagnosing heat and salt relaxation fluxes - k=m3 + ntld=m3 c - if (ditflx.or.disflx) nflxdi(k)=nflxdi(k)+1 + if (ditflx.or.disflx) nflxdi(ntld)=nflxdi(ntld)+1 c c$OMP PARALLEL DO PRIVATE( -c$OMP+ l,i,dpotl,hotl,totl,sotl,dpmxl,hmxl,tmxl,smxl,tice_f,hice_min, -c$OMP+ fice,hice,hsnw,tsrf,fice0,hice0,hsnw0,qsww,qnsw,tice,albi,tsmlt, -c$OMP+ albi_h,qswi,dh,qsnwf,fcond,qdamp,qsmlt,qo2i,qbot,swfac,dtml,q, -c$OMP+ volice,df,dvi,dvs,fwflx,sstc,rice,trxflx,sssc,srxflx +c$OMP+ l,i,dpotl,hotl,totl,sotl,tice_f,hice_min,fice,hice,hsnw,tsrf, +c$OMP+ fice0,hice0,hsnw0,qsww,qnsw,tice,albi,tsmlt,albi_h,qswi,dh,qsnwf, +c$OMP+ fcond,qdamp,qsmlt,qo2i,qbot,swfac,dtml,q,volice,df,dvi,dvs,fwflx, +c$OMP+ sstc,rice,dpmxl,hmxl,tmxl,trxflx,pbot,dprsi,kn,kl,sssc,smxl, +c$OMP+ srxflx #ifdef TRC c$OMP+ ,nt #endif @@ -139,13 +142,6 @@ subroutine thermf_ben02(m,n,mm,nn,k1m,k1n) hotl=dpotl/onem totl=temp(i,j,k1n)+t0deg sotl=saln(i,j,k1n) -c - 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 - smxl=(saln(i,j,1+nn)*dp(i,j,1+nn) - . +saln(i,j,2+nn)*dp(i,j,2+nn))/dpmxl c fice=ficem(i,j) hice=hicem(i,j) @@ -441,7 +437,7 @@ subroutine thermf_ben02(m,n,mm,nn,k1m,k1n) if (nt.eq.itrgls) then trflx(nt,i,j)=-gls_n*difdia(i,j,1)*(gls_cmu0**gls_p) . *(trc(i,j,k1n,itrtke)**gls_m) - . *(vonKar**gls_n)*zos**(gls_n-1.) + . *(vonKar**gls_n)*Zos**(gls_n-1.) ttrsf(nt,i,j)=0. ttrav(nt,i,j)=0. cycle @@ -476,8 +472,39 @@ 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 - trxflx=spcifh*L_mks2cgs*min(hmxl,trxdpt)/(trxday*86400.) - . *min(trxlim,max(-trxlim,sstc-tmxl))/alpha0 + if (vcoord_type_tag == 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 + trxflx=spcifh*L_mks2cgs*min(hmxl,trxdpt)/(trxday*86400.) + . *min(trxlim,max(-trxlim,sstc-tmxl))/alpha0 + else + pbot=p(i,j,1) + do k=1,kk + kn=k+nn + pbot=pbot+dp(i,j,kn) + enddo + dprsi=1./min(trxdpt*onem,pbot-p(i,j,1)) + t_rs_nonloc(i,j,1)=1. + tmxl=0. + do k=1,kk + kn=k+nn + t_rs_nonloc(i,j,k+1)=t_rs_nonloc(i,j,k)-dp(i,j,kn)*dprsi + if (t_rs_nonloc(i,j,k+1).lt.0.) then + tmxl=tmxl+temp(i,j,kn)*t_rs_nonloc(i,j,k)+t0deg + exit + else + tmxl=tmxl+temp(i,j,kn)*(t_rs_nonloc(i,j,k ) + . -t_rs_nonloc(i,j,k+1)) + endif + enddo + do kl=k,kk + t_rs_nonloc(i,j,kl+1)=0. + enddo + trxflx=spcifh*L_mks2cgs*trxdpt/(trxday*86400.) + . *min(trxlim,max(-trxlim,sstc-tmxl))/alpha0 + endif surrlx(i,j)=-trxflx else trxflx=0. @@ -493,7 +520,7 @@ subroutine thermf_ben02(m,n,mm,nn,k1m,k1n) c --- --- If ditflx=.true., diagnose relaxation flux by accumulating the c --- --- relaxation flux if (ditflx) then - tflxdi(i,j,k)=tflxdi(i,j,k)+trxflx + tflxdi(i,j,ntld)=tflxdi(i,j,ntld)+trxflx endif c salrlx(i,j)=0. @@ -503,8 +530,39 @@ 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) - srxflx=L_mks2cgs*min(hmxl,srxdpt)/(srxday*86400.) - . *min(srxlim,max(-srxlim,sssc-smxl))/alpha0 + if (vcoord_type_tag == 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 + srxflx=L_mks2cgs*min(hmxl,srxdpt)/(srxday*86400.) + . *min(srxlim,max(-srxlim,sssc-smxl))/alpha0 + else + pbot=p(i,j,1) + do k=1,kk + kn=k+nn + pbot=pbot+dp(i,j,kn) + enddo + dprsi=1./min(srxdpt*onem,pbot-p(i,j,1)) + s_rs_nonloc(i,j,1)=1. + smxl=0. + do k=1,kk + kn=k+nn + s_rs_nonloc(i,j,k+1)=s_rs_nonloc(i,j,k)-dp(i,j,kn)*dprsi + if (s_rs_nonloc(i,j,k+1).lt.0.) then + smxl=smxl+saln(i,j,kn)*s_rs_nonloc(i,j,k) + exit + else + smxl=smxl+saln(i,j,kn)*(s_rs_nonloc(i,j,k ) + . -s_rs_nonloc(i,j,k+1)) + endif + enddo + do kl=k,kk + s_rs_nonloc(i,j,kl+1)=0. + enddo + srxflx=L_mks2cgs*srxdpt/(srxday*86400.) + . *min(srxlim,max(-srxlim,sssc-smxl))/alpha0 + endif salrlx(i,j)=-srxflx util3(i,j)=max(0.,salrlx(i,j))*scp2(i,j) util4(i,j)=min(0.,salrlx(i,j))*scp2(i,j) @@ -522,7 +580,7 @@ subroutine thermf_ben02(m,n,mm,nn,k1m,k1n) c --- --- If disflx=.true., diagnose relaxation flux by accumulating the c --- --- relaxation flux if (disflx) then - sflxdi(i,j,k)=sflxdi(i,j,k)+srxflx + sflxdi(i,j,ntld)=sflxdi(i,j,ntld)+srxflx endif c c --- ------------------------------------------------------------------ @@ -678,10 +736,15 @@ subroutine thermf_ben02(m,n,mm,nn,k1m,k1n) call chksummsk(surflx,ip,1,'surflx') call chksummsk(sswflx,ip,1,'sswflx') call chksummsk(salflx,ip,1,'salflx') + call chksummsk(brnflx,ip,1,'brnflx') call chksummsk(surrlx,ip,1,'surrlx') 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 + call chksummsk(t_rs_nonloc, ip, kk+1, 't_rs_nonloc') + call chksummsk(s_rs_nonloc, ip, kk+1, 's_rs_nonloc') + endif endif c return diff --git a/cesm/thermf_cesm.F b/cesm/thermf_cesm.F index 9b9740a0..5c175b1e 100644 --- a/cesm/thermf_cesm.F +++ b/cesm/thermf_cesm.F @@ -1,5 +1,5 @@ ! ------------------------------------------------------------------------------ -! Copyright (C) 2008-2022 Mats Bentsen, Mehmet Ilicak +! Copyright (C) 2008-2023 Mats Bentsen, Mehmet Ilicak ! ! This file is part of BLOM. ! @@ -27,6 +27,7 @@ subroutine thermf_cesm(m,n,mm,nn,k1m,k1n) . nday_of_year, baclin, . xmi, l1mi, l2mi, l3mi, l4mi, l5mi use mod_xc + use mod_vcoord, only: vcoord_type_tag, isopyc_bulkml use mod_grid, only: scp2, area use mod_state, only: dp, temp, saln, p use mod_swtfrz, only: swtfrz @@ -36,7 +37,8 @@ subroutine thermf_cesm(m,n,mm,nn,k1m,k1n) . trxdpt, srxdpt, trxlim, srxlim, srxbal, . swa, nsf, hmltfz, lip, sop, eva, rnf, rfi, . fmltfz, sfl, ustarw, surflx, surrlx, - . sswflx, salflx, brnflx, salrlx, ustar + . sswflx, salflx, brnflx, salrlx, ustar, + . t_rs_nonloc, s_rs_nonloc use mod_cesm, only: hmlt, frzpot, mltpot use mod_utility, only: util1, util2, util3, util4 use mod_checksum, only: csdiag, chksummsk @@ -45,7 +47,7 @@ subroutine thermf_cesm(m,n,mm,nn,k1m,k1n) use mod_tracers, only: ntr, itrtke, itrgls, trc, trflx # ifdef GLS use mod_diffusion, only: difdia - use mod_tke, only: gls_cmu0, zos, gls_p, gls_m, gls_n, vonKar + use mod_tke, only: gls_cmu0, Zos, gls_p, gls_m, gls_n, vonKar # endif # else use mod_tracers, only: ntr, trc, trflx @@ -59,10 +61,10 @@ subroutine thermf_cesm(m,n,mm,nn,k1m,k1n) real, dimension(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy) :: . tfrz,tfrzm,vrtsfl c - integer i,j,k,l,m1,m2,m3,m4,m5 - real y,dpotl,hotl,totl,sotl,dpmxl,hmxl,tmxl,smxl,tice_f,fwflx, - . sstc,rice,trxflx,sssc,srxflx,totsfl,totwfl,sflxc,totsrp, - . totsrn,qp,qn,A_cgs2mks + integer i,j,k,l,m1,m2,m3,m4,m5,ntld,kn,kl + real y,dpotl,hotl,totl,sotl,tice_f,fwflx,sstc,rice,dpmxl,hmxl, + . tmxl,trxflx,pbot,dprsi,sssc,smxl,srxflx,totsfl,totwfl,sflxc, + . totsrp,totsrn,qp,qn,A_cgs2mks #ifdef TRC integer nt real, dimension(ntr,1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy) :: @@ -74,7 +76,7 @@ subroutine thermf_cesm(m,n,mm,nn,k1m,k1n) external intp1d c A_cgs2mks=1./(L_mks2cgs**2) -c +c c --- Set parameters for time interpolation when applying diagnosed heat c --- and salt relaxation fluxes y=(nday_of_year-1+mod(nstep,nstep_in_day)/real(nstep_in_day))*48. @@ -87,17 +89,17 @@ subroutine thermf_cesm(m,n,mm,nn,k1m,k1n) m5=mod(m3+ 1,48)+1 c c --- Time level for diagnosing heat and salt relaxation fluxes - k=m3 + ntld=m3 c c --- Compute freezing temperatures of sea water tfrz(:,:)=swtfrz(p(:,:,1),saln(:,:,k1n)) tfrzm(:,:)=swtfrz(p(:,:,1),.5*(saln(:,:,k1m)+saln(:,:,k1n))) c - if (ditflx.or.disflx) nflxdi(k)=nflxdi(k)+1 + if (ditflx.or.disflx) nflxdi(ntld)=nflxdi(ntld)+1 c c$OMP PARALLEL DO PRIVATE( -c$OMP+ l,i,dpotl,hotl,totl,sotl,dpmxl,hmxl,tmxl,smxl,tice_f,fwflx,sstc, -c$OMP+ rice,trxflx,sssc,srxflx +c$OMP+ l,i,dpotl,hotl,totl,sotl,tice_f,fwflx,sstc,rice,dpmxl,hmxl,tmxl, +c$OMP+ trxflx,pbot,dprsi,kn,kl,sssc,smxl,srxflx #ifdef TRC c$OMP+ ,nt #endif @@ -115,14 +117,6 @@ subroutine thermf_cesm(m,n,mm,nn,k1m,k1n) hotl=dpotl/onem totl=temp(i,j,k1n)+t0deg sotl=saln(i,j,k1n) -c -c --- --- ocean mixed layer quantities - 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 - smxl=(saln(i,j,1+nn)*dp(i,j,1+nn) - . +saln(i,j,2+nn)*dp(i,j,2+nn))/dpmxl c tice_f=tfrz(i,j)+t0deg c @@ -186,7 +180,7 @@ subroutine thermf_cesm(m,n,mm,nn,k1m,k1n) if (nt.eq.itrgls) then trflx(nt,i,j)=-gls_n*difdia(i,j,1)*(gls_cmu0**gls_p) . *(trc(i,j,k1n,itrtke)**gls_m) - . *(vonKar**gls_n)*zos**(gls_n-1.) + . *(vonKar**gls_n)*Zos**(gls_n-1.) ttrsf(nt,i,j)=0. ttrav(nt,i,j)=0. cycle @@ -221,8 +215,39 @@ 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 - trxflx=spcifh*L_mks2cgs*min(hmxl,trxdpt)/(trxday*86400.) - . *min(trxlim,max(-trxlim,sstc-tmxl))/alpha0 + if (vcoord_type_tag == 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 + trxflx=spcifh*L_mks2cgs*min(hmxl,trxdpt)/(trxday*86400.) + . *min(trxlim,max(-trxlim,sstc-tmxl))/alpha0 + else + pbot=p(i,j,1) + do k=1,kk + kn=k+nn + pbot=pbot+dp(i,j,kn) + enddo + dprsi=1./min(trxdpt*onem,pbot-p(i,j,1)) + t_rs_nonloc(i,j,1)=1. + tmxl=0. + do k=1,kk + kn=k+nn + t_rs_nonloc(i,j,k+1)=t_rs_nonloc(i,j,k)-dp(i,j,kn)*dprsi + if (t_rs_nonloc(i,j,k+1).lt.0.) then + tmxl=tmxl+temp(i,j,kn)*t_rs_nonloc(i,j,k)+t0deg + exit + else + tmxl=tmxl+temp(i,j,kn)*(t_rs_nonloc(i,j,k ) + . -t_rs_nonloc(i,j,k+1)) + endif + enddo + do kl=k,kk + t_rs_nonloc(i,j,kl+1)=0. + enddo + trxflx=spcifh*L_mks2cgs*trxdpt/(trxday*86400.) + . *min(trxlim,max(-trxlim,sstc-tmxl))/alpha0 + endif surrlx(i,j)=-trxflx else trxflx=0. @@ -238,7 +263,7 @@ subroutine thermf_cesm(m,n,mm,nn,k1m,k1n) c --- --- If ditflx=.true., diagnose relaxation flux by accumulating the c --- --- relaxation flux if (ditflx) then - tflxdi(i,j,k)=tflxdi(i,j,k)+trxflx + tflxdi(i,j,ntld)=tflxdi(i,j,ntld)+trxflx endif c salrlx(i,j)=0. @@ -248,8 +273,39 @@ 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) - srxflx=L_mks2cgs*min(hmxl,srxdpt)/(srxday*86400.) - . *min(srxlim,max(-srxlim,sssc-smxl))/alpha0 + if (vcoord_type_tag == 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 + srxflx=L_mks2cgs*min(hmxl,srxdpt)/(srxday*86400.) + . *min(srxlim,max(-srxlim,sssc-smxl))/alpha0 + else + pbot=p(i,j,1) + do k=1,kk + kn=k+nn + pbot=pbot+dp(i,j,kn) + enddo + dprsi=1./min(srxdpt*onem,pbot-p(i,j,1)) + s_rs_nonloc(i,j,1)=1. + smxl=0. + do k=1,kk + kn=k+nn + s_rs_nonloc(i,j,k+1)=s_rs_nonloc(i,j,k)-dp(i,j,kn)*dprsi + if (s_rs_nonloc(i,j,k+1).lt.0.) then + smxl=smxl+saln(i,j,kn)*s_rs_nonloc(i,j,k) + exit + else + smxl=smxl+saln(i,j,kn)*(s_rs_nonloc(i,j,k ) + . -s_rs_nonloc(i,j,k+1)) + endif + enddo + do kl=k,kk + s_rs_nonloc(i,j,kl+1)=0. + enddo + srxflx=L_mks2cgs*srxdpt/(srxday*86400.) + . *min(srxlim,max(-srxlim,sssc-smxl))/alpha0 + endif salrlx(i,j)=-srxflx util3(i,j)=max(0.,salrlx(i,j))*scp2(i,j) util4(i,j)=min(0.,salrlx(i,j))*scp2(i,j) @@ -267,7 +323,7 @@ subroutine thermf_cesm(m,n,mm,nn,k1m,k1n) c --- --- If disflx=.true., diagnose relaxation flux by accumulating the c --- --- relaxation flux if (disflx) then - sflxdi(i,j,k)=sflxdi(i,j,k)+srxflx + sflxdi(i,j,ntld)=sflxdi(i,j,ntld)+srxflx endif c c --- ------------------------------------------------------------------- @@ -389,6 +445,10 @@ 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 + call chksummsk(t_rs_nonloc, ip, kk+1, 't_rs_nonloc') + call chksummsk(s_rs_nonloc, ip, kk+1, 's_rs_nonloc') + endif endif c return diff --git a/cime_config/buildnml b/cime_config/buildnml index 940bec57..4edfdb28 100755 --- a/cime_config/buildnml +++ b/cime_config/buildnml @@ -171,6 +171,8 @@ set VELOCITY_PC_LOWER_BNDR = .false. set DPMIN_SURFACE = 2.5 set DPMIN_INFLATION_FACTOR = 1.08 set DPMIN_INTERIOR = .1 +set DKTZU = 4 +set DKTZL = 1 # set DIFFUSION defaults set EITMTH = "'gm'" @@ -651,7 +653,12 @@ set BUR_SSSTER = '0, 0, 2' # if partial coupling, enable SSS relaxation if ($BLOM_COUPLING =~ *partial*) then - set SRXDAY = 6. + if ($BLOM_VCOORD == isopyc_bulkml) then + set SRXDAY = 6. + else + set SRXDAY = 60. + set SRXDPT = 10. + endif set SPRFAC = .true. set SRXBAL = .true. endif @@ -1078,6 +1085,8 @@ cat >>! $RUNDIR/ocn_in$inststr << EOF DPMIN_SURFACE = $DPMIN_SURFACE DPMIN_INFLATION_FACTOR = $DPMIN_INFLATION_FACTOR DPMIN_INTERIOR = $DPMIN_INTERIOR + DKTZU = $DKTZU + DKTZL = $DKTZL / EOF endif diff --git a/phy/cntiso_hybrid_forcing.F90 b/phy/cntiso_hybrid_forcing.F90 index 254dacfc..3bc528f7 100644 --- a/phy/cntiso_hybrid_forcing.F90 +++ b/phy/cntiso_hybrid_forcing.F90 @@ -1,5 +1,5 @@ ! ------------------------------------------------------------------------------ -! Copyright (C) 2021-2022 Mats Bentsen +! Copyright (C) 2021-2023 Mats Bentsen ! ! This file is part of BLOM. ! @@ -18,81 +18,176 @@ ! ------------------------------------------------------------------------------ subroutine cntiso_hybrid_forcing(m, n, mm, nn, k1m, k1n) -! --------------------------------------------------------------------------- -! Apply surface forcing to the water column. -! --------------------------------------------------------------------------- +! ------------------------------------------------------------------------------ +! Compute penetration factors for shortwave and brine flux and compute interface +! buoyancy flux. +! ------------------------------------------------------------------------------ use mod_types, only: r8 - use mod_constants, only: g, spcifh, alpha0, onem, onemu + use mod_constants, only: g, spcifh, alpha0, onem, onecm, onemu, L_mks2cgs use mod_xc use mod_eos, only: dsigdt0, dsigds0 - use mod_state, only: dp, temp, saln + use mod_state, only: dp, temp, saln, p use mod_swabs, only: swbgal, swbgfc, swamxd - use mod_forcing, only: surflx, sswflx, salflx, buoyfl, t_sw_nonloc + use mod_forcing, only: surflx, sswflx, salflx, brnflx, buoyfl, & + t_sw_nonloc, s_br_nonloc + use mod_diffusion, only: t_ns_nonloc, s_nb_nonloc + use mod_cmnfld, only: mlts use mod_checksum, only: csdiag, chksummsk implicit none + ! Numeric constants for brine absorption profile. + real(r8), parameter :: & +! cbra1 = 2._r8**(1._r8/3._r8), & +! cbra2 = cbra1*cbra1/288._r8 + cbra1 = 2._r8**(1._r8/3._r8), & + cbra2 = cbra1*cbra1/12._r8 + + real(r8), parameter :: & + iL_mks2cgs = 1./L_mks2cgs + integer, intent(in) :: m, n, mm, nn, k1m, k1n - real(r8) :: pres(kk+1) - real(r8) :: cpi, pswamx, gaa, dsgdt, dsgds, lei, pswamxi, pswbot - integer :: i, j, k, l, kswamx, kn + real(r8) :: cpi, gaa, pmax, lei, q, q3, pmaxi, nlbot, dsgdt, dsgds, & + hf, hfsw, hfns, sf, sfbr, sfnb + integer :: i, j, k, l, kmax, kn ! Set some constants: cpi = 1._r8/spcifh ! Multiplicative inverse of specific heat capacity. - pswamx = swamxd*onem ! Maximum pressure of shortwave absorption. gaa = g*alpha0*alpha0 -!$omp parallel do private(l, i, dsgdt, dsgds, lei, pres, kswamx, k, kn, & -!$omp pswamxi, pswbot) + ! --------------------------------------------------------------------------- + ! Compute shortwave flux penetration factors. + ! --------------------------------------------------------------------------- + + ! Maximum pressure of shortwave absorption. + pmax = swamxd*onem + +!$omp parallel do private(l, i, lei, kmax, k, kn, pmaxi, nlbot) do j = 1, jj do l = 1, isp(j) do i = max(1, ifp(j,l)), min(ii, ilp(j,l)) - ! Derivatives of potential density referenced at the surface. - dsgdt = dsigdt0(temp(i,j,k1n), saln(i,j,k1n)) - dsgds = dsigds0(temp(i,j,k1n), saln(i,j,k1n)) - - ! Compute surface buoyancy flux [cm2 s-3]. - buoyfl(i,j,1) = - (dsgdt*surflx(i,j)*cpi + dsgds*salflx(i,j))*gaa - - ! Compute shortwave penetration factors at layer interfaces. - lei = 1._r8/(onem*swbgal(i,j)) - pres(1) = 0._r8 - kswamx = 1 + ! Penetration factors at layer interfaces. + lei = 1._r8/(swbgal(i,j)*onem) + kmax = 1 t_sw_nonloc(i,j,1) = 1._r8 do k = 1, kk kn = k + nn - pres(k+1) = pres(k) + dp(i,j,kn) if (dp(i,j,kn) > onemu) then t_sw_nonloc(i,j,k+1) = & - swbgfc(i,j)*exp( - lei*min(pswamx, pres(k+1))) - kswamx = k + swbgfc(i,j)*exp( - lei*min(pmax, p(i,j,k+1))) + kmax = k else t_sw_nonloc(i,j,k+1) = t_sw_nonloc(i,j,k) endif - if (pres(k+1) > pswamx) exit + if (p(i,j,k+1) > pmax) exit enddo - ! Compute buoyancy flux at subsurface layer interfaces. Penetration - ! factors are modified so that shortwave radiation destined to - ! penetrate below the lowest model layer is evenly absorbed in the - ! water column. - pswamxi = 1._r8/min(pswamx, pres(kswamx+1)) - pswbot = t_sw_nonloc(i,j,kswamx+1) - do k = kswamx+1, kk+1 + ! 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 t_sw_nonloc(i,j,k) = 0._r8 - buoyfl(i,j,k) = 0._r8 enddo - do k = kswamx, 2, -1 + do k = kmax, 2, -1 kn = k + nn if (dp(i,j,kn) > onemu) then - t_sw_nonloc(i,j,k) = t_sw_nonloc(i,j,k) - pswbot*pres(k)*pswamxi + t_sw_nonloc(i,j,k) = t_sw_nonloc(i,j,k) - nlbot*p(i,j,k)*pmaxi else t_sw_nonloc(i,j,k) = t_sw_nonloc(i,j,k+1) endif - buoyfl(i,j,k) = - dsgdt*t_sw_nonloc(i,j,k)*sswflx(i,j)*cpi*gaa + enddo + + enddo + enddo + 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 + do l = 1, isp(j) + do i = max(1, ifp(j,l)), min(ii, ilp(j,l)) + + ! Penetration factors at layer interfaces. + lei = 1._r8/(mlts(i,j)*(onem*iL_mks2cgs)) + pmax = cbra1*mlts(i,j)*(onem*iL_mks2cgs) + kmax = 1 + s_br_nonloc(i,j,1) = 1._r8 + do k = 1, kk + kn = k + nn + if (dp(i,j,kn) > onemu) then + q = min(cbra1, lei*p(i,j,k+1)) + q3 = q*q*q +! s_br_nonloc(i,j,k+1) = & +! 1._r8 - cbra2*q*q3*q3*(q3*(35._r8*q3 - 182._r8) + 260._r8) + s_br_nonloc(i,j,k+1) = 1._r8 - cbra2*q*q3*(7._r8-2._r8*q3) + kmax = k + else + s_br_nonloc(i,j,k+1) = s_br_nonloc(i,j,k) + endif + 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. + pmaxi = 1._r8/min(pmax, p(i,j,kmax+1)) + nlbot = s_br_nonloc(i,j,kmax+1) + do k = kmax+1, kk+1 + s_br_nonloc(i,j,k) = 0._r8 + enddo + do k = kmax, 2, -1 + kn = k + nn + if (dp(i,j,kn) > onemu) then + s_br_nonloc(i,j,k) = s_br_nonloc(i,j,k) - nlbot*p(i,j,k)*pmaxi + else + s_br_nonloc(i,j,k) = s_br_nonloc(i,j,k+1) + endif + enddo + + enddo + enddo + 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 + do l = 1, isp(j) + do i = max(1, ifp(j,l)), min(ii, ilp(j,l)) + + ! Derivatives of potential density referenced at the surface. + dsgdt = dsigdt0(temp(i,j,k1n), saln(i,j,k1n)) + dsgds = dsigds0(temp(i,j,k1n), saln(i,j,k1n)) + + ! Surface heat fluxes. + hf = surflx(i,j) ! Total. + hfsw = sswflx(i,j) ! Shortwave. + hfns = hf - hfsw ! Non-shortwave. + + ! Surface salt fluxes. + sf = salflx(i,j) ! Total. + sfbr = brnflx(i,j) ! Brine. + sfnb = sf - sfbr ! Non-brine. + + ! Surface buoyancy flux [cm2 s-3]. + buoyfl(i,j,1) = - (dsgdt*hf*cpi + dsgds*sf)*gaa + + ! Buoyancy flux at subsurface layer interfaces [cm2 s-3]. + do k = 2, kk+1 + buoyfl(i,j,k) = - ( dsgdt*( t_ns_nonloc(i,j,k)*hfns & + + t_sw_nonloc(i,j,k)*hfsw)*cpi & + + dsgds*( s_nb_nonloc(i,j,k)*sfnb & + + s_br_nonloc(i,j,k)*sfbr))*gaa enddo enddo @@ -104,8 +199,9 @@ subroutine cntiso_hybrid_forcing(m, n, mm, nn, k1m, k1n) if (mnproc == 1) then write (lp,*) 'cntiso_hybrid_forcing:' endif - call chksummsk(buoyfl, ip, kk+1, 'buoyfl') 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 diff --git a/phy/mod_difest.F b/phy/mod_difest.F index b3ccd87f..4d3cac22 100644 --- a/phy/mod_difest.F +++ b/phy/mod_difest.F @@ -1,5 +1,5 @@ ! ------------------------------------------------------------------------------ -! Copyright (C) 2009-2022 Mats Bentsen, Mehmet Ilicak +! Copyright (C) 2009-2023 Mats Bentsen, Mehmet Ilicak ! ! This file is part of BLOM. ! @@ -38,7 +38,7 @@ module mod_difest . edwmth_smooth, edwmth_step, . difint, difiso, difdia, difmxp, difwgt, . Kvisc_m, Kdiff_t, Kdiff_s, - . t_ns_nonloc, s_nonloc + . t_ns_nonloc, s_nb_nonloc use mod_cmnfld, only: bfsqi, nnslpx, nnslpy, mlts use mod_forcing, only: ustar, ustarb, ustar3, buoyfl, t_sw_nonloc . , surflx, sswflx, salflx @@ -1219,7 +1219,7 @@ subroutine difest_vertical_hyb(m,n,mm,nn,k1m,k1n) Kdiff_t(i,j,:) = Kt_kpp(:) Kdiff_s(i,j,:) = Ks_kpp(:) t_ns_nonloc(i,j,:) = nonLocalTrans(:,1) - s_nonloc(i,j,:) = nonLocalTrans(:,2) + s_nb_nonloc(i,j,:) = nonLocalTrans(:,2) do k = 1, kk+1 t_sw_nonloc(i,j,k) = max(t_sw_nonloc(i,j,k), . nonLocalTrans(k,1)) @@ -1238,6 +1238,8 @@ subroutine difest_vertical_hyb(m,n,mm,nn,k1m,k1n) call chksummsk(Kvisc_m,ip,kk+1,'Kvisc_m') call chksummsk(Kdiff_t,ip,kk+1,'Kdiff_t') call chksummsk(Kdiff_s,ip,kk+1,'Kdiff_s') + call chksummsk(t_ns_nonloc,ip,kk+1,'t_ns_nonloc') + call chksummsk(s_nb_nonloc,ip,kk+1,'s_nb_nonloc') endif c end subroutine difest_vertical_hyb diff --git a/phy/mod_diffusion.F90 b/phy/mod_diffusion.F90 index 97aafb45..0d32e8ac 100644 --- a/phy/mod_diffusion.F90 +++ b/phy/mod_diffusion.F90 @@ -1,5 +1,5 @@ ! ------------------------------------------------------------------------------ -! Copyright (C) 2020-2022 Mats Bentsen, Mehmet Ilicak +! Copyright (C) 2020-2023 Mats Bentsen, Mehmet Ilicak ! ! This file is part of BLOM. ! @@ -107,8 +107,9 @@ module mod_diffusion Kdiff_s, & ! salinity eddy diffusivity [cm2 s-1]. t_ns_nonloc, & ! Non-local transport term that is the fraction of ! non-shortwave flux passing a layer interface []. - s_nonloc ! Non-local transport term that is the fraction of - ! material tracer flux passing a layer interface []. + s_nb_nonloc ! Non-local transport term that is the fraction of + ! non-brine material tracer flux passing a layer interface + ! []. real(r8), dimension(1 - nbdy:idm + nbdy,1 - nbdy:jdm + nbdy) :: & difmxp, & ! Maximum lateral diffusivity at p-points [cm2 s-1]. @@ -158,7 +159,7 @@ module mod_diffusion umfltd, vmfltd, umflsm, vmflsm, & utfltd, vtfltd, utflsm, vtflsm, utflld, vtflld, & usfltd, vsfltd, usflsm, vsflsm, usflld, vsflld, & - Kvisc_m, Kdiff_t, Kdiff_s, t_ns_nonloc, s_nonloc, & + Kvisc_m, Kdiff_t, Kdiff_s, t_ns_nonloc, s_nb_nonloc, & readnml_diffusion, inivar_diffusion contains @@ -342,6 +343,8 @@ subroutine inivar_diffusion Kvisc_m(i, j, k) = epsilk Kdiff_t(i, j, k) = epsilk Kdiff_s(i, j, k) = epsilk + t_ns_nonloc(i, j, k) = spval + s_nb_nonloc(i, j, k) = spval enddo enddo enddo @@ -411,6 +414,26 @@ subroutine inivar_diffusion call xctilr(vtflld, 1, 2*kk, nbdy, nbdy, halo_vs) call xctilr(vsflld, 1, 2*kk, nbdy, nbdy, halo_vs) + ! Initialize non-local transport. + !$omp parallel do private(k, l, i) + do j = 1, jj + do l = 1, isp(j) + do i = max(1, ifp(j, l)), min(ii, ilp(j, l)) + t_ns_nonloc(i, j, 1) = 1._r8 + s_nb_nonloc(i, j, 1) = 1._r8 + enddo + enddo + do k = 2, kk + 1 + do l = 1, isp(j) + do i = max(1, ifp(j, l)), min(ii, ilp(j, l)) + t_ns_nonloc(i, j, k) = 0._r8 + s_nb_nonloc(i, j, k) = 0._r8 + enddo + enddo + enddo + enddo + !$omp end parallel do + end subroutine inivar_diffusion end module mod_diffusion diff --git a/phy/mod_forcing.F90 b/phy/mod_forcing.F90 index 64b546b3..515009fc 100644 --- a/phy/mod_forcing.F90 +++ b/phy/mod_forcing.F90 @@ -1,5 +1,5 @@ ! ------------------------------------------------------------------------------ -! Copyright (C) 2002-2022 Mats Bentsen, Jerry Tjiputra, Jörg Schwinger +! Copyright (C) 2002-2023 Mats Bentsen, Jerry Tjiputra, Jörg Schwinger ! ! This file is part of BLOM. ! @@ -134,8 +134,14 @@ module mod_forcing real(r8), dimension(1 - nbdy:idm + nbdy,1 - nbdy:jdm + nbdy, kk + 1) :: & buoyfl, & ! Buoyancy flux [cm2 s-3]. - t_sw_nonloc ! Non-local transport term that is the fraction of + t_sw_nonloc, & ! Non-local transport term that is the fraction of ! shortwave flux passing a layer interface []. + t_rs_nonloc, & ! Non-local transport term that is the fraction of + ! restoring heat flux passing a layer interface []. + s_br_nonloc, & ! Non-local transport term that is the fraction of + ! brine flux passing a layer interface []. + s_rs_nonloc ! Non-local transport term that is the fraction of + ! restoring salt flux passing a layer interface []. public :: aptflx, apsflx, ditflx, disflx, srxbal, sprfac, & trxday, srxday, trxdpt, srxdpt, trxlim, srxlim, scfile, & @@ -145,8 +151,8 @@ module mod_forcing ustarw, slp, abswnd, lamult, lasl, ustokes, vstokes, & atmco2, flxco2, flxdms, flxbrf, atmbrf, & surflx, surrlx, sswflx, salflx, brnflx, salrlx, taux, tauy, & - ustar, ustarb, ustar3, buoyfl, t_sw_nonloc, & - inivar_forcing, fwbbal + ustar, ustarb, ustar3, buoyfl, t_sw_nonloc, t_rs_nonloc, & + s_br_nonloc, s_rs_nonloc, inivar_forcing, fwbbal contains @@ -206,11 +212,33 @@ subroutine inivar_forcing do k = 1, kk + 1 do i = 1 - nbdy, ii + nbdy buoyfl(i, j, k) = spval + t_sw_nonloc(i, j, k) = spval + t_rs_nonloc(i, j, k) = spval + s_br_nonloc(i, j, k) = spval + s_rs_nonloc(i, j, k) = spval enddo enddo enddo !$omp end parallel do + !$omp parallel do private(l, i, k) + do j = 1, jj + do l = 1, isp(j) + do i = max(1, ifp(j, l)), min(ii, ilp(j, l)) + t_rs_nonloc(i, j, 1) = 1._r8 + s_rs_nonloc(i, j, 1) = 1._r8 + enddo + enddo + do k = 2, kk+1 + do l = 1, isp(j) + do i = max(1, ifp(j, l)), min(ii, ilp(j, l)) + t_rs_nonloc(i, j, k) = 0._r8 + s_rs_nonloc(i, j, k) = 0._r8 + enddo + enddo + enddo + enddo + !$omp end parallel do !$omp parallel do private(l, i) do j = 1, jj do l = 1, isp(j) diff --git a/phy/mod_vdiff.F90 b/phy/mod_vdiff.F90 index 61778a72..2cb2c213 100644 --- a/phy/mod_vdiff.F90 +++ b/phy/mod_vdiff.F90 @@ -1,5 +1,5 @@ ! ------------------------------------------------------------------------------ -! Copyright (C) 2021-2022 Mats Bentsen, Mehmet Ilicak +! Copyright (C) 2021-2023 Mats Bentsen, Mehmet Ilicak ! ! This file is part of BLOM. ! @@ -29,8 +29,9 @@ module mod_vdiff use mod_eos, only: sig use mod_state, only: u, v, dp, dpu, dpv, temp, saln, sigma use mod_checksum, only: csdiag, chksummsk - use mod_diffusion, only: Kvisc_m, Kdiff_t, Kdiff_s, t_ns_nonloc, s_nonloc - use mod_forcing, only: surflx, sswflx, surrlx, salflx, salrlx, t_sw_nonloc + use mod_diffusion, only: Kvisc_m, Kdiff_t, Kdiff_s, t_ns_nonloc, s_nb_nonloc + use mod_forcing, only: surflx, sswflx, surrlx, salflx, brnflx, salrlx, & + t_sw_nonloc, t_rs_nonloc, s_br_nonloc, s_rs_nonloc #ifdef TRC use mod_tracers, only: ntr, trc, trflx #endif @@ -53,7 +54,7 @@ subroutine cntiso_hybrid_vdifft(m, n, mm, nn, k1m, k1n) real(r8), dimension(kdm) :: dp_1d, temp_1d, saln_1d, & nut_1d, nus_1d, nutrc_1d real(r8), dimension(2:kdm) :: fpbase, fp, gam - real(r8) :: cpi, dtg, c, bei, rhs + real(r8) :: cpi, dtg, c, hfsw, hfns, hfrs, sfbr, sfnb, sfrs, bei, rhs integer :: i, j, k, l, kn, nt #ifdef TRC real(r8), dimension(kdm, ntr) :: trc_1d @@ -83,6 +84,16 @@ subroutine cntiso_hybrid_vdifft(m, n, mm, nn, k1m, k1n) #endif enddo + ! Surface heat fluxes. + hfsw = sswflx(i,j) ! Shortwave. + hfns = surflx(i,j) - hfsw ! Non-shortwave. + hfrs = surrlx(i,j) ! Restoring. + + ! Surface salt fluxes. + sfbr = brnflx(i,j) ! Brine. + sfnb = salflx(i,j) - sfbr ! Non-brine. + sfrs = salrlx(i,j) ! Restoring. + ! Vertical diffusion equations are solved by backward integration ! forming a tridiagonal set of equations: ! @@ -104,27 +115,25 @@ subroutine cntiso_hybrid_vdifft(m, n, mm, nn, k1m, k1n) enddo bei = 1._r8/(dp_1d(1) + fp(2)) rhs = dp_1d(1)*temp_1d(1) & - - ( (1._r8 - t_ns_nonloc(i,j,2))*(surflx(i,j) - sswflx(i,j)) & - + (1._r8 - t_sw_nonloc(i,j,2))*sswflx(i,j) & - + surrlx(i,j))*dtg*cpi + - ( (1._r8 - t_ns_nonloc(i,j,2))*hfns & + + (1._r8 - t_sw_nonloc(i,j,2))*hfsw & + + (1._r8 - t_rs_nonloc(i,j,2))*hfrs)*dtg*cpi temp_1d(1) = rhs*bei do k = 2, kk - 1 gam(k) = - fp(k)*bei bei = 1._r8/(dp_1d(k) + fp(k)*(1._r8 + gam(k)) + fp(k + 1)) rhs = dp_1d(k)*temp_1d(k) & - - ( (t_ns_nonloc(i,j,k) - t_ns_nonloc(i,j,k+1)) & - *(surflx(i,j) - sswflx(i,j)) & - + (t_sw_nonloc(i,j,k) - t_sw_nonloc(i,j,k+1)) & - *sswflx(i,j))*dtg*cpi + - ( (t_ns_nonloc(i,j,k) - t_ns_nonloc(i,j,k+1))*hfns & + + (t_sw_nonloc(i,j,k) - t_sw_nonloc(i,j,k+1))*hfsw & + + (t_rs_nonloc(i,j,k) - t_rs_nonloc(i,j,k+1))*hfrs)*dtg*cpi temp_1d(k) = (rhs + fp(k)*temp_1d(k - 1))*bei enddo gam(kk) = - fp(kk)*bei bei = 1._r8/(dp_1d(kk) + fp(kk)*(1._r8 + gam(kk))) rhs = dp_1d(kk)*temp_1d(kk) & - - ( (t_ns_nonloc(i,j,kk) - t_ns_nonloc(i,j,kk+1)) & - *(surflx(i,j) - sswflx(i,j)) & - + (t_sw_nonloc(i,j,kk) - t_sw_nonloc(i,j,kk+1)) & - *sswflx(i,j))*dtg*cpi + - ( (t_ns_nonloc(i,j,kk) - t_ns_nonloc(i,j,kk+1))*hfns & + + (t_sw_nonloc(i,j,kk) - t_sw_nonloc(i,j,kk+1))*hfsw & + + (t_rs_nonloc(i,j,kk) - t_rs_nonloc(i,j,kk+1))*hfrs)*dtg*cpi temp_1d(kk) = (rhs + fp(kk)*temp_1d(kk - 1))*bei do k = kk - 1, 1, - 1 temp_1d(k) = temp_1d(k) - gam(k + 1)*temp_1d(k + 1) @@ -136,20 +145,25 @@ subroutine cntiso_hybrid_vdifft(m, n, mm, nn, k1m, k1n) enddo bei = 1._r8/(dp_1d(1) + fp(2)) rhs = dp_1d(1)*saln_1d(1) & - - ((1._r8 - s_nonloc(i,j,2))*salflx(i,j) & - + salrlx(i,j))*dtg + - ( (1._r8 - s_nb_nonloc(i,j,2))*sfnb & + + (1._r8 - s_br_nonloc(i,j,2))*sfbr & + + (1._r8 - s_rs_nonloc(i,j,2))*sfrs)*dtg saln_1d(1) = rhs*bei do k = 2, kk - 1 gam(k) = - fp(k)*bei bei = 1._r8/(dp_1d(k) + fp(k)*(1._r8 + gam(k)) + fp(k + 1)) rhs = dp_1d(k)*saln_1d(k) & - - (s_nonloc(i,j,k) - s_nonloc(i,j,k+1))*salflx(i,j)*dtg + - ( (s_nb_nonloc(i,j,k) - s_nb_nonloc(i,j,k+1))*sfnb & + + (s_br_nonloc(i,j,k) - s_br_nonloc(i,j,k+1))*sfbr & + + (s_rs_nonloc(i,j,k) - s_rs_nonloc(i,j,k+1))*sfrs)*dtg saln_1d(k) = (rhs + fp(k)*saln_1d(k - 1))*bei enddo gam(kk) = - fp(kk)*bei bei = 1._r8/(dp_1d(kk) + fp(kk)*(1._r8 + gam(kk))) rhs = dp_1d(kk)*saln_1d(kk) & - - (s_nonloc(i,j,kk) - s_nonloc(i,j,kk+1))*salflx(i,j)*dtg + - ( (s_nb_nonloc(i,j,kk) - s_nb_nonloc(i,j,kk+1))*sfnb & + + (s_br_nonloc(i,j,kk) - s_br_nonloc(i,j,kk+1))*sfbr & + + (s_rs_nonloc(i,j,kk) - s_rs_nonloc(i,j,kk+1))*sfrs)*dtg saln_1d(kk) = (rhs + fp(kk)*saln_1d(kk - 1))*bei do k = kk - 1, 1, - 1 saln_1d(k) = saln_1d(k) - gam(k + 1)*saln_1d(k + 1) @@ -163,7 +177,7 @@ subroutine cntiso_hybrid_vdifft(m, n, mm, nn, k1m, k1n) bei = 1._r8/(dp_1d(1) + fp(2)) do nt = 1, ntr rhs = dp_1d(1)*trc_1d(1,nt) & - - (1._r8 - s_nonloc(i,j,2))*trflx(nt,i,j)*dtg + - (1._r8 - s_nb_nonloc(i,j,2))*trflx(nt,i,j)*dtg trc_1d(1, nt) = rhs*bei enddo do k = 2, kk - 1 @@ -171,7 +185,8 @@ subroutine cntiso_hybrid_vdifft(m, n, mm, nn, k1m, k1n) bei = 1._r8/(dp_1d(k) + fp(k)*(1._r8 + gam(k)) + fp(k + 1)) do nt = 1, ntr rhs = dp_1d(k)*trc_1d(k,nt) & - - (s_nonloc(i,j,k) - s_nonloc(i,j,k+1))*trflx(nt,i,j)*dtg + - (s_nb_nonloc(i,j,k) - s_nb_nonloc(i,j,k+1)) & + *trflx(nt,i,j)*dtg trc_1d(k, nt) = (rhs + fp(k)*trc_1d(k - 1, nt))*bei enddo enddo @@ -179,7 +194,8 @@ subroutine cntiso_hybrid_vdifft(m, n, mm, nn, k1m, k1n) bei = 1._r8/(dp_1d(kk) + fp(kk)*(1._r8 + gam(kk))) do nt = 1, ntr rhs = dp_1d(kk)*trc_1d(kk,nt) & - - (s_nonloc(i,j,kk) - s_nonloc(i,j,kk+1))*trflx(nt,i,j)*dtg + - (s_nb_nonloc(i,j,kk) - s_nb_nonloc(i,j,kk+1)) & + *trflx(nt,i,j)*dtg trc_1d(kk, nt) = (rhs + fp(kk)*trc_1d(kk - 1, nt))*bei enddo do k = kk - 1, 1, - 1 diff --git a/phy/restart_rd.F b/phy/restart_rd.F index 576f1a56..83af8266 100644 --- a/phy/restart_rd.F +++ b/phy/restart_rd.F @@ -1,5 +1,5 @@ ! ------------------------------------------------------------------------------ -! Copyright (C) 2006-2022 Mats Bentsen, Mehmet Ilicak, Alok Kumar Gupta, +! Copyright (C) 2006-2023 Mats Bentsen, Mehmet Ilicak, Alok Kumar Gupta, ! Jerry Tjiputra, Ping-Gin Chiu, Aleksi Nummelin, ! Jörg Schwinger ! @@ -49,7 +49,8 @@ subroutine restart_rd . flxco2, flxdms, flxbrf, ustarb, buoyfl use mod_niw, only: uml, vml, umlres, vmlres use mod_difest, only: OBLdepth - use mod_diffusion, only: difiso, Kvisc_m, Kdiff_t, Kdiff_s + use mod_diffusion, only: difiso, Kvisc_m, Kdiff_t, Kdiff_s, + . t_ns_nonloc, s_nb_nonloc 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, ustarw_da, @@ -523,6 +524,8 @@ subroutine restart_rd call ncread('dpv',dpv,iv,1,0.) call ncread('difiso',difiso,ip,1,0.) call ncread('OBLdepth',OBLdepth,ip,1,0.) + call ncread('t_ns_nonloc',t_ns_nonloc,ip,1,0.) + call ncread('s_nb_nonloc',s_nb_nonloc,ip,1,0.) endif c if (sprfac) then diff --git a/phy/restart_wt.F b/phy/restart_wt.F index a7cc43a5..861dee7d 100644 --- a/phy/restart_wt.F +++ b/phy/restart_wt.F @@ -1,5 +1,5 @@ ! ------------------------------------------------------------------------------ -! Copyright (C) 2006-2022 Mats Bentsen, Mehmet Ilicak, Alok Kumar Gupta, +! Copyright (C) 2006-2023 Mats Bentsen, Mehmet Ilicak, Alok Kumar Gupta, ! Ingo Bethke, Jerry Tjiputra, Ping-Gin Chiu, ! Aleksi Nummelin, Jörg Schwinger ! @@ -47,7 +47,8 @@ subroutine restart_wt . flxco2, flxdms, ustarb, buoyfl,flxbrf use mod_niw, only: uml, vml, umlres, vmlres use mod_difest, only: OBLdepth - use mod_diffusion, only: difiso, Kvisc_m, Kdiff_t, Kdiff_s + use mod_diffusion, only: difiso, Kvisc_m, Kdiff_t, Kdiff_s, + . t_ns_nonloc, s_nb_nonloc 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, ustarw_da, @@ -299,6 +300,10 @@ subroutine restart_wt call wrtrst('dpv',trim(c5p)//' kk2 time',dpv,iv) call wrtrst('difiso',trim(c5p)//' kk time',difiso,ip) call wrtrst('OBLdepth',trim(c5p)//' time',OBLdepth,ip) + call wrtrst('t_ns_nonloc',trim(c5p)//' kkp1 time', + . t_ns_nonloc,ip) + call wrtrst('s_nb_nonloc',trim(c5p)//' kkp1 time', + . s_nb_nonloc,ip) call wrtrst('umflsm',trim(c5u)//' kk2 time',umflsm,iuu) call wrtrst('utflsm',trim(c5u)//' kk2 time',utflsm,iuu) call wrtrst('usflsm',trim(c5u)//' kk2 time',usflsm,iuu) @@ -945,6 +950,8 @@ subroutine defvar_restart(c5p,c5u,c5v,c5q) call defvarrst('dpv',trim(c5p)//' kk2 time') call defvarrst('difiso',trim(c5p)//' kk time') call defvarrst('OBLdepth',trim(c5p)//' time') + call defvarrst('t_ns_nonloc',trim(c5p)//' kkp1 time') + call defvarrst('s_nb_nonloc',trim(c5p)//' kkp1 time') call defvarrst('umflsm',trim(c5u)//' kk2 time') call defvarrst('utflsm',trim(c5u)//' kk2 time') call defvarrst('usflsm',trim(c5u)//' kk2 time') From 8644da25be9dfde8d1a88b532befd8c8b751faa6 Mon Sep 17 00:00:00 2001 From: Mats Bentsen Date: Mon, 2 Jan 2023 23:36:21 +0100 Subject: [PATCH 243/366] Latitude dependency of background diapycnal mixing is now available for hybrid vertical coordinate and selectable as namelist flag. --- cime_config/buildnml | 5 +++++ phy/mod_difest.F | 17 +++++++++++------ phy/mod_diffusion.F90 | 12 ++++++++---- tests/fuk95/limits | 3 +++ 4 files changed, 27 insertions(+), 10 deletions(-) diff --git a/cime_config/buildnml b/cime_config/buildnml index 4edfdb28..dff37274 100755 --- a/cime_config/buildnml +++ b/cime_config/buildnml @@ -202,8 +202,10 @@ else endif set TKEPF = .006 if ($BLOM_VCOORD == isopyc_bulkml) then + set BDMLDP = .true. set LTEDTP = "'layer'" else + set BDMLDP = .false. set LTEDTP = "'neutral'" endif @@ -1124,6 +1126,8 @@ cat >>! $RUNDIR/ocn_in$inststr << EOF ! BDMC1 : Background diapycnal diffusivity times buoyancy frequency ! frequency (cm**2/s**2) (f) ! BDMC2 : Background diapycnal diffusivity (cm**2/s) (f) +! BDMLDP : Make the background mixing latitude dependent according to +! Gregg et al. (2003) (l) ! TKEPF : Fraction of surface TKE that penetrates beneath mixed layer ! () (f) ! LTEDTP : Type of lateral tracer eddy diffusion: Valid methods: @@ -1143,6 +1147,7 @@ cat >>! $RUNDIR/ocn_in$inststr << EOF BDMTYP = $BDMTYP BDMC1 = $BDMC1 BDMC2 = $BDMC2 + BDMLDP = $BDMLDP TKEPF = $TKEPF LTEDTP = $LTEDTP / diff --git a/phy/mod_difest.F b/phy/mod_difest.F index 4d3cac22..f5a348cb 100644 --- a/phy/mod_difest.F +++ b/phy/mod_difest.F @@ -33,7 +33,7 @@ module mod_difest . pbu, pbv, ubflxs_p, vbflxs_p, kfpla use mod_diffusion, only: egc, eggam, eglsmn, egmndf, egmxdf, . egidfq, ri0, bdmc1, bdmc2, tkepf, bdmtyp, - . edsprs, edritp_opt, edritp_shear, + . edsprs, bdmldp, edritp_opt, edritp_shear, . edritp_large_scale, edwmth_opt, . edwmth_smooth, edwmth_step, . difint, difiso, difdia, difmxp, difwgt, @@ -115,8 +115,6 @@ module mod_difest c --- multiplied by the local horizontal grid scale, if c --- iidtyp=2 the diffusivities are parameterized according c --- to Eden and Greatbatch (2008). -c --- bdmldp - If bdmldp=1, make the background mixing latitude -c --- dependent according to Gregg et al. (2003). c --- tdmflg - If tdmflg=1, apply tidally driven diapycnal mixing. c --- iwdflg - If iwdflg=1, reduce background diapycnal diffusivity c --- due to internal wave damping under sea-ice. @@ -173,13 +171,13 @@ module mod_difest c --- barotropic velocity [cm/s]. c --- urmsemin- Lower bound of absolute value of RMS eddy velocity c --- [cm/s]. - integer iidtyp,bdmldp,tdmflg,iwdflg + integer iidtyp,tdmflg,iwdflg real dptmin,dpbmin,drhomn,thkdff,temdff,nu0,nus0,nug0,drho0,nuls0, . iwdfac,dmxeff,tdmq,tdmls0,tdmls1,tdclat,tddlat,tkepls,niwls, . cori30,bvf0,nubmin,dpgc,dpgrav,dpdiav,dpddav,dpnbav,ustmin, . kappa,bfeps,sleps,zetas,as,cs,minOBLdepth, . cpsemin,urmsemin - parameter (iidtyp=2,bdmldp=1,tdmflg=1,iwdflg=1,dptmin=onem, + parameter (iidtyp=2,tdmflg=1,iwdflg=1,dptmin=onem, . dpbmin=onecm,drhomn=6.e-3*R_mks2cgs, . thkdff=5.e-3*L_mks2cgs,temdff=3.5e-3*L_mks2cgs, . nu0=1.e-5*A_mks2cgs, @@ -1074,6 +1072,13 @@ subroutine difest_vertical_hyb(m,n,mm,nn,k1m,k1n) Kv_col=Kv_col*(1.+(iwdfac-1.)*ficem(i,j)) Kd_col=Kd_col*(1.+(iwdfac-1.)*ficem(i,j)) endif +c +c --- ------ Latitude dependency of background diapycnal mixing + if (bdmldp) then + q=max(1.e-9,abs(coriop(i,j))) + Kv_col=Kv_col*q/cori30*log(2.*bvf0/q)/log(2.*bvf0/cori30) + Kd_col=Kd_col*q/cori30*log(2.*bvf0/q)/log(2.*bvf0/cori30) + endif c --- ------ Tidally driven diapycnal mixing c @@ -2208,7 +2213,7 @@ subroutine difest_vertical_iso(m,n,mm,nn,k1m,k1n) endif c c --- ------- Latitude dependency of background diapycnal mixing - if (bdmldp.eq.1) then + if (bdmldp) then q=max(1.e-9,abs(coriop(i,j))) nub=nub*q/cori30*log(2.*bvf0/q)/log(2.*bvf0/cori30) endif diff --git a/phy/mod_diffusion.F90 b/phy/mod_diffusion.F90 index 0d32e8ac..baef8bce 100644 --- a/phy/mod_diffusion.F90 +++ b/phy/mod_diffusion.F90 @@ -59,8 +59,10 @@ module mod_diffusion ! Brunt-Vaisala frequency, if bdmtyp = 2 the background ! diffusivity is constant []. logical :: & - edsprs ! If true, apply eddy mixing suppression away from steering + edsprs, & ! If true, apply eddy mixing suppression away from steering ! level. + bdmldp ! If true, make the background mixing latitude dependent + ! according to Gregg et al. (2003). character(len = 80) :: & eitmth, & ! Eddy-induced transport parameterization method. Valid ! methods: 'intdif', 'gm'. @@ -151,8 +153,8 @@ module mod_diffusion ! [g2 cm kg-1 s-2]. public :: egc, eggam, eglsmn, egmndf, egmxdf, egidfq, ri0, bdmc1, bdmc2, & - tkepf, bdmtyp, edsprs, eitmth_opt, eitmth_intdif, eitmth_gm, & - edritp_opt, edritp_shear, edritp_large_scale, & + tkepf, bdmtyp, edsprs, bdmldp, eitmth_opt, eitmth_intdif, & + eitmth_gm, edritp_opt, edritp_shear, edritp_large_scale, & edwmth_opt, edwmth_smooth, edwmth_step, & ltedtp_opt, ltedtp_layer, ltedtp_neutral, & difint, difiso, difdia, difmxp, difmxq, difwgt, & @@ -175,7 +177,7 @@ subroutine readnml_diffusion namelist /diffusion/ & egc, eggam, eglsmn, egmndf, egmxdf, egidfq, ri0, bdmc1, bdmc2, tkepf, & - bdmtyp, edsprs, eitmth, edritp, edwmth, ltedtp + bdmtyp, edsprs, bdmldp, eitmth, edritp, edwmth, ltedtp ! Read variables in the namelist group 'diffusion'. if (mnproc == 1) then @@ -216,6 +218,7 @@ subroutine readnml_diffusion call xcbcst(tkepf) call xcbcst(bdmtyp) call xcbcst(edsprs) + call xcbcst(bdmldp) call xcbcst(eitmth) call xcbcst(edritp) call xcbcst(edwmth) @@ -235,6 +238,7 @@ subroutine readnml_diffusion write (lp,*) ' tkepf = ', tkepf write (lp,*) ' bdmtyp = ', bdmtyp write (lp,*) ' edsprs = ', edsprs + write (lp,*) ' bdmldp = ', bdmldp write (lp,*) ' eitmth = ', trim(eitmth) write (lp,*) ' edritp = ', trim(edritp) write (lp,*) ' edwmth = ', trim(edwmth) diff --git a/tests/fuk95/limits b/tests/fuk95/limits index af781e52..ee745bb9 100644 --- a/tests/fuk95/limits +++ b/tests/fuk95/limits @@ -182,6 +182,8 @@ ! BDMC1 : Background diapycnal diffusivity times buoyancy frequency ! frequency (cm**2/s**2) (f) ! BDMC2 : Background diapycnal diffusivity (cm**2/s) (f) +! BDMLDP : Make the background mixing latitude dependent according to +! Gregg et al. (2003) (l) ! TKEPF : Fraction of surface TKE that penetrates beneath mixed layer ! () (f) ! LTEDTP : Type of lateral tracer eddy diffusion: Valid methods: @@ -201,6 +203,7 @@ BDMTYP = 2 BDMC1 = 5.e-4 BDMC2 = .15 + BDMLDP = .false. TKEPF = 0. LTEDTP = 'layer' / From 9067ec725e184e2dea9a6249d9bf064109503caa Mon Sep 17 00:00:00 2001 From: Mats Bentsen Date: Mon, 2 Jan 2023 23:47:59 +0100 Subject: [PATCH 244/366] Set MatchTechnique = ParabolicNonLocal as default for CVMix. --- phy/mod_difest.F | 38 +++++++++++++++++++------------------- 1 file changed, 19 insertions(+), 19 deletions(-) diff --git a/phy/mod_difest.F b/phy/mod_difest.F index f5a348cb..85cf1527 100644 --- a/phy/mod_difest.F +++ b/phy/mod_difest.F @@ -265,20 +265,6 @@ subroutine init_difest . KPP_Ri_zero=ri0, . KPP_exp=3.0) ! CVmix_kpp_params_in => CVmix_kpp_params_user - call CVMix_init_kpp(Ri_crit=0.3, - . minOBLdepth=minOBLdepth, - . minVtsqr=1e-10, - . vonKarman=0.4, - . surf_layer_ext=0.1, - . interp_type='quadratic', - . interp_type2='LMD94', - . lEkman=.false., - . lMonOb=.false., - . MatchTechnique='SimpleShapes', - . lenhanced_diff=.true., - . lnonzero_surf_nonlocal=.false. , - . lnoDGat1=.true. , - . CVMix_kpp_params_user=KPP_params ) c call CVMix_init_kpp(Ri_crit=0.3, c . minOBLdepth=minOBLdepth, c . minVtsqr=1e-10, @@ -288,10 +274,10 @@ subroutine init_difest c . interp_type2='LMD94', c . lEkman=.false., c . lMonOb=.false., -c . MatchTechnique='MatchGradient', +c . MatchTechnique='SimpleShapes', c . lenhanced_diff=.true., c . lnonzero_surf_nonlocal=.false. , -c . lnoDGat1=.false. , +c . lnoDGat1=.true. , c . CVMix_kpp_params_user=KPP_params ) c call CVMix_init_kpp(Ri_crit=0.3, c . minOBLdepth=minOBLdepth, @@ -302,11 +288,25 @@ subroutine init_difest c . interp_type2='LMD94', c . lEkman=.false., c . lMonOb=.false., -c . MatchTechnique='ParabolicNonLocal', +c . MatchTechnique='MatchGradient', c . lenhanced_diff=.true., -c . lnonzero_surf_nonlocal=.true. , -c . lnoDGat1=.true. , +c . lnonzero_surf_nonlocal=.false. , +c . lnoDGat1=.false. , c . CVMix_kpp_params_user=KPP_params ) + call CVMix_init_kpp(Ri_crit=0.3, + . minOBLdepth=minOBLdepth, + . minVtsqr=1e-10, + . vonKarman=0.4, + . surf_layer_ext=0.1, + . interp_type='quadratic', + . interp_type2='LMD94', + . lEkman=.false., + . lMonOb=.false., + . MatchTechnique='ParabolicNonLocal', + . lenhanced_diff=.true., + . lnonzero_surf_nonlocal=.true. , + . lnoDGat1=.true. , + . CVMix_kpp_params_user=KPP_params ) c c$OMP PARALLEL DO PRIVATE(l,i) do j=1,jj From 81a96ca9c1c58fdd668f0554ba7e6f582732c1e8 Mon Sep 17 00:00:00 2001 From: Mats Bentsen Date: Tue, 3 Jan 2023 14:52:08 +0100 Subject: [PATCH 245/366] Updated gcc version used in CI. --- .github/workflows/ci.yml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index 63ac0786..3371a169 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -44,8 +44,8 @@ jobs: - name: Build env: - CC: gcc-10 - FC: gfortran-10 + CC: gcc-12 + FC: gfortran-12 run: | meson setup builddir -Dmpi=${{ matrix.mpi }} -Dopenmp=${{ matrix.openmp }} --buildtype=debugoptimized meson compile -C builddir From 09ced994950cd8f4642a464a189f1beb0f99d614 Mon Sep 17 00:00:00 2001 From: Mats Bentsen Date: Tue, 3 Jan 2023 15:05:35 +0100 Subject: [PATCH 246/366] Install netcdf-fortran instead of netcdf on macOS for CI. --- .github/workflows/ci.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index 3371a169..8938e2c3 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -26,7 +26,7 @@ jobs: if: runner.os == 'Linux' - name: Install dependencies - macOS - run: brew install netcdf open-mpi ninja + run: brew install netcdf-fortran open-mpi ninja env: HOMEBREW_NO_INSTALL_CLEANUP: 1 if: runner.os == 'macOS' From 65e670419624f5911d4455d3677c81e8064ebd10 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?J=C3=B6rg=20Schwinger?= Date: Fri, 6 Jan 2023 20:28:55 +0100 Subject: [PATCH 247/366] Add option for surface pH output (#221) --- cime_config/buildnml | 8 ++++-- hamocc/accfields.F90 | 11 +++++---- hamocc/mo_bgcmean.F90 | 14 ++++++++--- hamocc/ncout_hamocc.F90 | 54 +++++++++++++++++++++++++---------------- 4 files changed, 56 insertions(+), 31 deletions(-) diff --git a/cime_config/buildnml b/cime_config/buildnml index 2507d13d..57cc45eb 100755 --- a/cime_config/buildnml +++ b/cime_config/buildnml @@ -422,6 +422,7 @@ set SRF_ALKALI = '4, 2, 2' set SRF_SILICA = '0, 2, 2' set SRF_DIC = '4, 2, 2' set SRF_PHYTO = '4, 2, 2' +set SRF_PH = '0, 2, 2' set SRF_EXPORT = '0, 2, 2' set SRF_EXPOSI = '0, 2, 2' set SRF_EXPOCA = '0, 2, 2' @@ -446,6 +447,7 @@ set SRF_ATMO2 = '0, 2, 2' set SRF_ATMN2 = '0, 2, 2' set SRF_NATDIC = '0, 2, 2' set SRF_NATALKALI = '0, 2, 2' +set SRF_NATPH = '0, 2, 2' set SRF_NATPCO2 = '0, 2, 2' set SRF_NATCO2FX = '0, 2, 2' set SRF_CO213FXD = '0, 2, 2' @@ -1535,8 +1537,10 @@ cat >>! $RUNDIR/ocn_in$inststr << EOF ! IRON - Dissolved iron (dfe) [mol Fe m-3] ! SILICA - Silicate (si) [mol Si m-3] ! PHYTO - Phytoplankton (phyc) [mol C m-3] +! PH - pH (ph) [-log10([h+])] ! NATDIC - Natural dissolved carbon (natdissic) [mol C m-3] ! NATALKALI - Natural alkalinity (nattalk) [eq m-3] +! NATPH - Natural pH (natph) [-log10([h+])] ! ! Other 3d tracer or diagnostic variables (LYR or LVL) ! DP - Layer thickness (pddpo) [m] @@ -1554,14 +1558,12 @@ cat >>! $RUNDIR/ocn_in$inststr << EOF ! PHOSY - Primary production (pp) [mol C m-3 s-1] ! CO3 - Carbonate ions (co3) [mol C m-3] ! N2O - Nitrous oxide concentration [mol N2O m-3] -! PH - pH (ph) [-log10([h+])] ! OMEGAA - Aragonite saturation state (omegaa) [1] ! OMEGAC - Calcite saturation state (omegac) [1] ! NATDIC - Natural dissolved carbon (natdissic) [mol C m-3] ! NATALKALI - Natural alkalinity (nattalk) [eq m-3] ! NATCO3 - Natural carbonate ion concentration (natco3) [mol C m-3] ! NATCALC - Natural CaCO3 shells (natcalc) [mol C m-3] -! NATPH - Natural pH (natph) [-log10([h+])] ! NATOMEGAA - Natural aragonite saturation state (natomegaa) [1] ! NATOMEGAC - Natural calcite saturation state (natomegac) [1] ! DIC13 - Dissolved C13 (dissic13) [mol C m-3] @@ -1668,6 +1670,7 @@ cat >>! $RUNDIR/ocn_in$inststr << EOF SRF_SILICA = $SRF_SILICA SRF_DIC = $SRF_DIC SRF_PHYTO = $SRF_PHYTO + SRF_PH = $SRF_PH SRF_EXPORT = $SRF_EXPORT SRF_EXPOSI = $SRF_EXPOSI SRF_EXPOCA = $SRF_EXPOCA @@ -1692,6 +1695,7 @@ cat >>! $RUNDIR/ocn_in$inststr << EOF SRF_ATMN2 = $SRF_ATMN2 SRF_NATDIC = $SRF_NATDIC SRF_NATALKALI = $SRF_NATALKALI + SRF_NATPH = $SRF_NATPH SRF_NATPCO2 = $SRF_NATPCO2 SRF_NATCO2FX = $SRF_NATCO2FX SRF_CO213FXD = $SRF_CO213FXD diff --git a/hamocc/accfields.F90 b/hamocc/accfields.F90 index a83fe953..d27dba68 100644 --- a/hamocc/accfields.F90 +++ b/hamocc/accfields.F90 @@ -65,10 +65,9 @@ SUBROUTINE ACCFIELDS(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask) & jlvlprefo2,jlvlprefpo4,jlvlsf6,jlvlsilica,jlvlwnos,jlvlwphy,jn2flux,jn2o,jn2oflux,jn2ofx, & & jprorca,jprcaca,jsilpro,jpodiic,jpodial,jpodiph,jpodiox,jpodin2,jpodino3,jpodisi,jndep, & & jniflux,jnos,jo2flux,jo2sat,jomegaa,jomegac,jopal,joxflux,joxygen,jpco2,jpco2m,jkwco2khm,jco2khm, & - & jco2kh,jph,jphosph,jphosy,jphyto, & - & jpoc,jprefalk,jprefdic,jprefo2,jprefpo4,jsilica,jsrfalkali,jsrfano3,jsrfdic,jsrfiron,jsrfoxygen, & - & jsrfphosph,jsrfphyto,jsrfsilica,jwnos,jwphy,nbgc,nacc_bgc,bgcwrt,glb_inventory,bgct2d,acclvl, & - & acclyr,accsrf,bgczlv + & jco2kh,jph,jphosph,jphosy,jphyto,jpoc,jprefalk,jprefdic,jprefo2,jprefpo4,jsilica,jsrfalkali, & + & jsrfano3,jsrfdic,jsrfiron,jsrfoxygen,jsrfphosph,jsrfphyto,jsrfsilica,jsrfph,jwnos,jwphy, & + & nbgc,nacc_bgc,bgcwrt,glb_inventory,bgct2d,acclvl,acclyr,accsrf,bgczlv use mo_control_bgc, only: io_stdo_bgc use mo_param1_bgc, only: ialkali,ian2o,iano3,iatmco2,iatmdms,iatmn2,iatmn2o,iatmo2,icalc,idet,idms,idicsat,idoc,iiron,iopal,& & ioxygen,iphosph,iphy,iprefalk,iprefdic,iprefpo4,iprefo2,isco212,isilica,izoo, & @@ -100,7 +99,7 @@ SUBROUTINE ACCFIELDS(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask) use mo_param1_bgc, only: iatmnco2,inatalkali,inatcalc,inatsco212 use mo_carbch, only: natco3,nathi,natomegaa,natomegac,natpco2d use mo_bgcmean, only: jlvlnatph,jnatalkali,jnatcalc,jnatco2fx,jnatco3,jnatdic,jnatomegaa,jnatomegac,jnatpco2,jnatph, & - & jsrfnatalk,jsrfnatdic + & jsrfnatalk,jsrfnatdic,jsrfnatph #endif #ifndef sedbypass use mo_param1_bgc, only: ipowaal,ipowaic,ipowaox,ipowaph,ipowasi,ipown2,ipowno3,isssc12,issso12,issssil,issster @@ -242,6 +241,7 @@ SUBROUTINE ACCFIELDS(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask) call accsrf(jsrfsilica,ocetra(1,1,1,isilica),omask,0) call accsrf(jsrfdic,ocetra(1,1,1,isco212),omask,0) call accsrf(jsrfphyto,ocetra(1,1,1,iphy),omask,0) + call accsrf(jsrfph,hi(1,1,1),omask,0) call accsrf(jdms,ocetra(1,1,1,idms),omask,0) call accsrf(jexport,expoor,omask,0) call accsrf(jexpoca,expoca,omask,0) @@ -256,6 +256,7 @@ SUBROUTINE ACCFIELDS(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask) call accsrf(jsrfnatdic,ocetra(1,1,1,inatsco212),omask,0) call accsrf(jsrfnatalk,ocetra(1,1,1,inatalkali),omask,0) call accsrf(jnatpco2,natpco2d,omask,0) + call accsrf(jsrfnatph,nathi(1,1,1),omask,0) #endif #ifdef BROMO call accsrf(jsrfbromo,ocetra(1,1,1,ibromo),omask,0) diff --git a/hamocc/mo_bgcmean.F90 b/hamocc/mo_bgcmean.F90 index 9bb44653..bbabd104 100644 --- a/hamocc/mo_bgcmean.F90 +++ b/hamocc/mo_bgcmean.F90 @@ -89,8 +89,9 @@ MODULE mo_bgcmean & SRF_SF6 =0 ,SRF_PHOSPH =0 ,SRF_OXYGEN =0 , & & SRF_IRON =0 ,SRF_ANO3 =0 ,SRF_ALKALI =0 , & & SRF_SILICA =0 ,SRF_DIC =0 ,SRF_PHYTO =0 , & + & SRF_PH =0 , & & SRF_NATDIC =0 ,SRF_NATALKALI =0 ,SRF_NATPCO2 =0 , & - & SRF_NATCO2FX =0 , & + & SRF_NATCO2FX =0 ,SRF_NATPH =0 , & & SRF_ATMBROMO =0 ,SRF_BROMO =0 ,SRF_BROMOFX =0 , & & INT_BROMOPRO =0 ,INT_BROMOUV =0 , & & INT_PHOSY =0 ,INT_NFIX =0 ,INT_DNIT =0 , & @@ -165,8 +166,9 @@ MODULE mo_bgcmean & SRF_SF6 ,SRF_PHOSPH ,SRF_OXYGEN , & & SRF_IRON ,SRF_ANO3 ,SRF_ALKALI , & & SRF_SILICA ,SRF_DIC ,SRF_PHYTO , & + & SRF_PH , & & SRF_NATDIC ,SRF_NATALKALI ,SRF_NATPCO2 , & - & SRF_NATCO2FX , & + & SRF_NATCO2FX ,SRF_NATPH , & & SRF_ATMBROMO ,SRF_BROMO ,SRF_BROMOFX , & & INT_BROMOPRO ,INT_BROMOUV , & & INT_PHOSY ,INT_NFIX ,INT_DNIT , & @@ -292,6 +294,7 @@ MODULE mo_bgcmean & jsrfsilica = 0 , & & jsrfdic = 0 , & & jsrfphyto = 0 , & + & jsrfph = 0 , & & jintphosy = 0 , & & jintnfix = 0 , & & jintdnit = 0 , & @@ -327,7 +330,8 @@ MODULE mo_bgcmean & jsrfnatdic = 0 , & & jsrfnatalk = 0 , & & jnatpco2 = 0 , & - & jnatco2fx = 0 + & jnatco2fx = 0 , & + & jsrfnatph = 0 INTEGER, DIMENSION(nbgcmax), SAVE :: & & jbromofx = 0 , & @@ -620,6 +624,8 @@ SUBROUTINE ALLOC_MEM_BGCMEAN(kpie,kpje,kpke) jsrfdic(n)=i_bsc_m2d*min(1,SRF_DIC(n)) IF (SRF_PHYTO(n).GT.0) i_bsc_m2d=i_bsc_m2d+1 jsrfphyto(n)=i_bsc_m2d*min(1,SRF_PHYTO(n)) + IF (SRF_PH(n).GT.0) i_bsc_m2d=i_bsc_m2d+1 + jsrfph(n)=i_bsc_m2d*min(1,SRF_PH(n)) IF (INT_PHOSY(n).GT.0) i_bsc_m2d=i_bsc_m2d+1 jintphosy(n)=i_bsc_m2d*min(1,INT_PHOSY(n)) IF (INT_NFIX(n).GT.0) i_bsc_m2d=i_bsc_m2d+1 @@ -705,6 +711,8 @@ SUBROUTINE ALLOC_MEM_BGCMEAN(kpie,kpje,kpke) jnatpco2(n)=i_bsc_m2d*min(1,SRF_NATPCO2(n)) IF (SRF_NATCO2FX(n).GT.0) i_bsc_m2d=i_bsc_m2d+1 jnatco2fx(n)=i_bsc_m2d*min(1,SRF_NATCO2FX(n)) + IF (SRF_NATPH(n).GT.0) i_bsc_m2d=i_bsc_m2d+1 + jsrfnatph(n)=i_bsc_m2d*min(1,SRF_NATPH(n)) #endif #ifdef BROMO IF (SRF_BROMO(n).GT.0) i_bsc_m2d=i_bsc_m2d+1 diff --git a/hamocc/ncout_hamocc.F90 b/hamocc/ncout_hamocc.F90 index 6293f96b..8f0f5778 100644 --- a/hamocc/ncout_hamocc.F90 +++ b/hamocc/ncout_hamocc.F90 @@ -79,7 +79,7 @@ subroutine ncwrt_bgc(iogrp) & jph,jphosph,jphosy,jphyto,jpoc,jprefalk, & & jprefdic,jprefo2,jprefpo4,jsilica, & & jsrfalkali,jsrfano3,jsrfdic,jsrfiron, & - & jsrfoxygen,jsrfphosph,jsrfphyto,jsrfsilica, & + & jsrfoxygen,jsrfphosph,jsrfphyto,jsrfsilica,jsrfph, & & jwnos,jwphy, & & lyr_dp,lyr_dic,lyr_alkali,lyr_phosph, & & lyr_oxygen,lyr_ano3,lyr_silica,lyr_doc, & @@ -102,14 +102,14 @@ subroutine ncwrt_bgc(iogrp) & srf_dmsprod,srf_dms_bac,srf_dms_uv, & & srf_export,srf_exposi,srf_expoca,srf_dic, & & srf_alkali,srf_phosph,srf_oxygen,srf_ano3, & - & srf_silica,srf_iron,srf_phyto, & + & srf_silica,srf_iron,srf_phyto,srf_ph, & & int_phosy,int_nfix,int_dnit, & & nbgc,nacc_bgc,bgcwrt,glb_inventory,bgct2d, & & nbgcmax,glb_ncformat,glb_compflag, & & glb_fnametag,filefq_bgc,diagfq_bgc, & - & filemon_bgc,fileann_bgc,ip,wrtlyr,wrtlvl, & - & loglyr,inilvl,inilyr,inisrf,loglvl, & - & msklvl,wrtsrf,msksrf,finlyr + & filemon_bgc,fileann_bgc,ip,wrtlyr,wrtlvl,wrtsrf, & + & loglyr,loglvl,logsrf,inilvl,inilyr,inisrf, & + & msklvl,msksrf,finlyr #ifdef AGG use mo_bgcmean, only: lyr_nos,lyr_wphy, lyr_wnos,lyr_eps, & & lyr_asize,lvl_nos,lvl_wphy,lvl_wnos,lvl_eps, & @@ -143,14 +143,14 @@ subroutine ncwrt_bgc(iogrp) #endif #ifdef natDIC use mo_bgcmean, only: jnatalkali,jnatdic,jnatcalc,jnatco3,jnatph, & - & jnatomegaa,jnatomegac,lyr_natph,jlvlnatph, & - & lvl_natph,jsrfnatdic, & - & jsrfnatalk,jnatpco2,jnatco2fx,lyr_natco3, & - & lyr_natalkali,lyr_natdic,lyr_natcalc, & + & jnatomegaa,jnatomegac,jlvlnatph, & + & jsrfnatdic,jsrfnatalk,jsrfnatph, & + & jnatpco2,jnatco2fx,lyr_natco3, & + & lyr_natalkali,lyr_natdic,lyr_natph,lyr_natcalc, & & lyr_natomegaa,lyr_natomegac,lvl_natco3, & - & lvl_natalkali,lvl_natdic,lvl_natcalc, & + & lvl_natalkali,lvl_natdic,lvl_natph,lvl_natcalc, & & lvl_natomegaa,lvl_natomegac,srf_natdic, & - & srf_natalkali,srf_natpco2,srf_natco2fx + & srf_natalkali,srf_natpco2,srf_natco2fx,srf_natph #endif #ifndef sedbypass use mo_bgcmean, only: jpowaic,jpowaal,jpowaph,jpowaox,jpown2, & @@ -385,9 +385,11 @@ subroutine ncwrt_bgc(iogrp) #endif ! --- Compute log10 of pH + if (SRF_PH(iogrp).ne.0) call logsrf(jsrfph(iogrp),rnacc,0.) if (LYR_PH(iogrp).ne.0) call loglyr(jph(iogrp),1.,0.) if (LVL_PH(iogrp).ne.0) call loglvl(jlvlph(iogrp),rnacc,0.) #ifdef natDIC + if (SRF_NATPH(iogrp).ne.0) call logsrf(jsrfnatph(iogrp),rnacc,0.) if (LYR_NATPH(iogrp).ne.0) call loglyr(jnatph(iogrp),1.,0.) if (LVL_NATPH(iogrp).ne.0) call loglvl(jlvlnatph(iogrp),rnacc,0.) #endif @@ -456,6 +458,8 @@ subroutine ncwrt_bgc(iogrp) call wrtsrf(jsrfphyto(iogrp),SRF_PHYTO(iogrp), & & rnacc*1e3,0.,cmpflg,'srfphyc', & & 'Surface phytoplankton',' ','mol P m-3') + call wrtsrf(jsrfph(iogrp),SRF_PH(iogrp),-1.,0., & + & cmpflg,'srfph','Surface pH',' ','-log10([H+])') call wrtsrf(jintphosy(iogrp),INT_PHOSY(iogrp), & & rnacc*1e3/dtbgc,0.,cmpflg,'ppint', & & 'Integrated primary production',' ','mol C m-2 s-1') @@ -571,6 +575,8 @@ subroutine ncwrt_bgc(iogrp) call wrtsrf(jnatco2fx(iogrp),SRF_NATCO2FX(iogrp), & & rnacc*12./dtbgc,0.,cmpflg,'natco2fx', & & 'Natural CO2 flux',' ','kg C m-2 s-1') + call wrtsrf(jsrfnatph(iogrp),SRF_NATPH(iogrp),-1.,0., & + & cmpflg,'srfnatph','Surface natural pH',' ','-log10([H+])') #endif #ifdef BROMO call wrtsrf(jbromofx(iogrp),SRF_BROMOFX(iogrp),rnacc*1e3/dtbgc, & @@ -638,7 +644,7 @@ subroutine ncwrt_bgc(iogrp) call wrtlyr(jco3(iogrp),LYR_CO3(iogrp),1e3,0.,cmpflg, & & 'co3','Carbonate ions',' ','mol C m-3') call wrtlyr(jph(iogrp),LYR_PH(iogrp),-1.,0.,cmpflg, & - & 'ph','pH',' ','-log10([h+])') + & 'ph','pH',' ','-log10([H+])') call wrtlyr(jomegaa(iogrp),LYR_OMEGAA(iogrp),1.,0.,cmpflg, & & 'omegaa','OmegaA',' ','-') call wrtlyr(jomegac(iogrp),LYR_OMEGAC(iogrp),1.,0.,cmpflg, & @@ -710,7 +716,7 @@ subroutine ncwrt_bgc(iogrp) call wrtlyr(jnatcalc(iogrp),LYR_NATCALC(iogrp),1e3,0.,cmpflg, & & 'natcalc','Natural CaCO3 shells',' ','mol C m-3') call wrtlyr(jnatph(iogrp),LYR_NATPH(iogrp),-1.,0.,cmpflg, & - & 'natph','Natural pH',' ','-log10([h+])') + & 'natph','Natural pH',' ','-log10([H+])') call wrtlyr(jnatomegaa(iogrp),LYR_NATOMEGAA(iogrp),1.,0.,cmpflg, & & 'natomegaa','Natural OmegaA',' ','-') call wrtlyr(jnatomegac(iogrp),LYR_NATOMEGAC(iogrp),1.,0.,cmpflg, & @@ -753,7 +759,7 @@ subroutine ncwrt_bgc(iogrp) call wrtlvl(jlvlco3(iogrp),LVL_CO3(iogrp),rnacc*1e3,0.,cmpflg, & & 'co3lvl','Carbonate ions',' ','mol C m-3') call wrtlvl(jlvlph(iogrp),LVL_PH(iogrp),-1.,0.,cmpflg, & - & 'phlvl','pH',' ','-log10([h+])') + & 'phlvl','pH',' ','-log10([H+])') call wrtlvl(jlvlomegaa(iogrp),LVL_OMEGAA(iogrp),rnacc,0.,cmpflg, & & 'omegaalvl','OmegaA',' ','-') call wrtlvl(jlvlomegac(iogrp),LVL_OMEGAC(iogrp),rnacc,0.,cmpflg, & @@ -834,7 +840,7 @@ subroutine ncwrt_bgc(iogrp) & rnacc*1e3,0.,cmpflg,'natcalclvl', & & 'Natural CaCO3 shells',' ','mol C m-3') call wrtlvl(jlvlnatph(iogrp),LVL_NATPH(iogrp),-1.,0.,cmpflg, & - & 'natphlvl','Natural pH',' ','-log10([h+])') + & 'natphlvl','Natural pH',' ','-log10([H+])') call wrtlvl(jlvlnatomegaa(iogrp),LVL_NATOMEGAA(iogrp), & & rnacc,0.,cmpflg,'natomegaalvl', & & 'Natural OmegaA',' ','-') @@ -914,6 +920,7 @@ subroutine ncwrt_bgc(iogrp) call inisrf(jsrfsilica(iogrp),0.) call inisrf(jsrfiron(iogrp),0.) call inisrf(jsrfphyto(iogrp),0.) + call inisrf(jsrfph(iogrp),0.) call inisrf(jintphosy(iogrp),0.) call inisrf(jintnfix(iogrp),0.) call inisrf(jintdnit(iogrp),0.) @@ -960,6 +967,7 @@ subroutine ncwrt_bgc(iogrp) call inisrf(jsrfnatalk(iogrp),0.) call inisrf(jnatpco2(iogrp),0.) call inisrf(jnatco2fx(iogrp),0.) + call inisrf(jsrfnatph(iogrp),0.) #endif #ifdef BROMO call inisrf(jsrfbromo(iogrp),0.) @@ -1138,7 +1146,7 @@ subroutine hamoccvardef(iogrp,timeunits,calendar,cmpflg) & srf_co2fxu,srf_oxflux,srf_niflux,srf_dms,srf_dmsprod, & & srf_dms_bac,srf_dms_uv,srf_export,srf_exposi,srf_expoca, & & srf_dic,srf_alkali,srf_phosph,srf_oxygen,srf_ano3,srf_silica, & - & srf_iron,srf_phyto,int_phosy,int_nfix,int_dnit,flx_car0100, & + & srf_iron,srf_phyto,srf_ph,int_phosy,int_nfix,int_dnit,flx_car0100, & & flx_car0500,flx_car1000,flx_car2000,flx_car4000,flx_car_bot, & & flx_bsi0100,flx_bsi0500,flx_bsi1000,flx_bsi2000,flx_bsi4000, & & flx_bsi_bot,flx_cal0100,flx_cal0500,flx_cal1000,flx_cal2000, & @@ -1180,7 +1188,7 @@ subroutine hamoccvardef(iogrp,timeunits,calendar,cmpflg) #endif #ifdef natDIC use mo_bgcmean, only: srf_natdic,srf_natalkali,srf_natpco2, & - & srf_natco2fx,lyr_natco3,lyr_natalkali,lyr_natdic, & + & srf_natco2fx,srf_natph,lyr_natco3,lyr_natalkali,lyr_natdic, & & lyr_natcalc,lyr_natph,lyr_natomegaa,lyr_natomegac, & & lvl_natalkali,lvl_natdic,lvl_natcalc,lvl_natph, & & lvl_natomegaa,lvl_natomegac,lvl_natco3 @@ -1264,6 +1272,8 @@ subroutine hamoccvardef(iogrp,timeunits,calendar,cmpflg) & 'Surface dissolved iron',' ','mol Fe m-3',0) call ncdefvar3d(SRF_PHYTO(iogrp),cmpflg,'p','srfphyc', & & 'Surface phytoplankton',' ','mol P m-3',0) + call ncdefvar3d(SRF_PH(iogrp),cmpflg,'p','srfph', & + & 'Surface pH',' ','-log10([H+])',0) call ncdefvar3d(INT_PHOSY(iogrp),cmpflg,'p','ppint', & & 'Integrated primary production',' ','mol C m-2 s-1',0) call ncdefvar3d(INT_NFIX(iogrp),cmpflg,'p','nfixint', & @@ -1358,6 +1368,8 @@ subroutine hamoccvardef(iogrp,timeunits,calendar,cmpflg) & 'natpco2','Surface natural PCO2',' ','uatm',0) call ncdefvar3d(SRF_NATCO2FX(iogrp), & & cmpflg,'p','natco2fx','Natural CO2 flux',' ','kg C m-2 s-1',0) + call ncdefvar3d(SRF_NATPH(iogrp),cmpflg,'p','srfnatph', & + & 'Surface natural pH',' ','-log10([H+])',0) #endif #ifdef BROMO call ncdefvar3d(SRF_BROMO(iogrp),cmpflg,'p','srfbromo', & @@ -1422,7 +1434,7 @@ subroutine hamoccvardef(iogrp,timeunits,calendar,cmpflg) call ncdefvar3d(LYR_CO3(iogrp),cmpflg,'p', & & 'co3','Carbonate ions',' ','mol C m-3',1) call ncdefvar3d(LYR_PH(iogrp),cmpflg,'p', & - & 'ph','pH',' ','-log10([h+])',1) + & 'ph','pH',' ','-log10([H+])',1) call ncdefvar3d(LYR_OMEGAA(iogrp),cmpflg,'p', & & 'omegaa','OmegaA',' ','1',1) call ncdefvar3d(LYR_OMEGAC(iogrp),cmpflg,'p', & @@ -1493,7 +1505,7 @@ subroutine hamoccvardef(iogrp,timeunits,calendar,cmpflg) call ncdefvar3d(LYR_NATCALC(iogrp),cmpflg,'p','natcalc', & & 'Natural CaCO3',' ','mol C m-3',1) call ncdefvar3d(LYR_NATPH(iogrp),cmpflg,'p', & - & 'natph','Natural pH',' ','-log10([h+])',1) + & 'natph','Natural pH',' ','-log10([H+])',1) call ncdefvar3d(LYR_NATOMEGAA(iogrp),cmpflg,'p','natomegaa', & & 'Natural OmegaA',' ','1',1) call ncdefvar3d(LYR_NATOMEGAC(iogrp),cmpflg,'p','natomegac', & @@ -1536,7 +1548,7 @@ subroutine hamoccvardef(iogrp,timeunits,calendar,cmpflg) call ncdefvar3d(LVL_CO3(iogrp),cmpflg,'p', & & 'co3lvl','Carbonate ions',' ','mol C m-3',2) call ncdefvar3d(LVL_PH(iogrp),cmpflg,'p', & - & 'phlvl','pH',' ','-log10([h+])',2) + & 'phlvl','pH',' ','-log10([H+])',2) call ncdefvar3d(LVL_OMEGAA(iogrp),cmpflg,'p', & & 'omegaalvl','OmegaA',' ','1',2) call ncdefvar3d(LVL_OMEGAC(iogrp),cmpflg,'p', & @@ -1607,7 +1619,7 @@ subroutine hamoccvardef(iogrp,timeunits,calendar,cmpflg) call ncdefvar3d(LVL_NATCALC(iogrp),cmpflg,'p', & & 'natcalclvl','Natural CaCO3 shells',' ','mol C m-3',2) call ncdefvar3d(LVL_NATPH(iogrp),cmpflg,'p', & - & 'natphlvl','Natural pH',' ','-log10([h+])',2) + & 'natphlvl','Natural pH',' ','-log10([H+])',2) call ncdefvar3d(LVL_NATOMEGAA(iogrp),cmpflg,'p', & & 'natomegaalvl','Natural OmegaA',' ','1',2) call ncdefvar3d(LVL_NATOMEGAC(iogrp),cmpflg,'p', & From 4962fdb222441ed4715323d5cb6d1187c77bc143 Mon Sep 17 00:00:00 2001 From: JorgSchwinger Date: Mon, 9 Jan 2023 16:28:23 +0100 Subject: [PATCH 248/366] Remove unused parameters in wrt* subroutine calls in ncout_hamocc.F90 --- hamocc/mo_bgcmean.F90 | 112 ++----- hamocc/ncout_hamocc.F90 | 647 ++++++++++++---------------------------- 2 files changed, 228 insertions(+), 531 deletions(-) diff --git a/hamocc/mo_bgcmean.F90 b/hamocc/mo_bgcmean.F90 index bbabd104..a0ca5035 100644 --- a/hamocc/mo_bgcmean.F90 +++ b/hamocc/mo_bgcmean.F90 @@ -55,7 +55,7 @@ MODULE mo_bgcmean !********************************************************************** use mod_xc, only: ii,jj,kk,idm,jdm,kdm,nbdy,ifp,isp,ilp,mnproc,ip use mod_dia, only: ddm,depthslev,depthslev_bnds,nstepinday,pbath - use mod_nctools, only:ncpack,nccomp,nccopa,ncwrtr + use mod_nctools, only: ncpack,nccomp,nccopa,ncwrtr use netcdf, only: nf90_fill_double use mo_param1_bgc, only: ks use mo_control_bgc, only: get_bgc_namelist @@ -1616,8 +1616,7 @@ END SUBROUTINE finlyr - SUBROUTINE wrtsrf(pos,frmt,sfac,offs,cmpflg,vnm,vlngnm,vstdnm, & - & vunits) + SUBROUTINE wrtsrf(pos,frmt,sfac,offs,cmpflg,vnm) ! ! --- ------------------------------------------------------------------ ! --- Description: writes diagnostic 2d field to file @@ -1635,18 +1634,16 @@ SUBROUTINE wrtsrf(pos,frmt,sfac,offs,cmpflg,vnm,vlngnm,vstdnm, & ! --- int cmpflg (in) : compression flag; only wet points are ! --- written IF flag is set to 1 ! --- char vnm (in) : variable name used in nc-file -! --- char vlngnm (in) : variable long name (skipped IF ' ') -! --- char vstdnm (in) : variable standard name (skipped IF ' ') -! --- char vunits (in) : variable units (skipped IF ' ') ! --- ------------------------------------------------------------------ ! IMPLICIT NONE ! - REAL ::sfac,offs - INTEGER :: frmt,cmpflg,pos,n - CHARACTER(LEN=*) :: vnm,vlngnm,vstdnm,vunits + REAL, intent(in) :: sfac,offs + INTEGER, intent(in) :: frmt,cmpflg,pos + CHARACTER(LEN=*),intent(in) :: vnm ! - CHARACTER(LEN=100) :: dims + INTEGER :: n + CHARACTER(LEN=100) :: dims ! ! --- Check whether field should be written IF (pos.EQ.0 .OR. frmt.EQ.0) RETURN @@ -1686,20 +1683,12 @@ SUBROUTINE wrtsrf(pos,frmt,sfac,offs,cmpflg,vnm,vlngnm,vstdnm, & ELSE STOP 'unknown output format ' ENDIF -! -! --- Def.NE.attributes -! IF (len(trim(vunits)).NE.0) CALL ncattr('units',vunits) -! IF (len(trim(vlngnm)).NE.0) CALL ncattr('long_name',vlngnm) -! IF (len(trim(vstdnm)).NE.0) CALL ncattr('standard_name',vstdnm) -! CALL ncattr('coordinates','plon plat') -! CALL ncattr('cell_measures','area: parea') ! END SUBROUTINE wrtsrf - SUBROUTINE wrtlyr(pos,frmt,sfac,offs,cmpflg,vnm,vlngnm,vstdnm, & - & vunits) + SUBROUTINE wrtlyr(pos,frmt,sfac,offs,cmpflg,vnm) ! ! --- ------------------------------------------------------------------ ! --- Description: writes diagnostic layer field to file @@ -1717,18 +1706,16 @@ SUBROUTINE wrtlyr(pos,frmt,sfac,offs,cmpflg,vnm,vlngnm,vstdnm, & ! --- int cmpflg (in) : compression flag; only wet points are ! --- written IF flag is set to 1 ! --- char vnm (in) : variable name used in nc-file -! --- char vlngnm (in) : variable long name (skipped IF ' ') -! --- char vstdnm (in) : variable standard name (skipped IF ' ') -! --- char vunits (in) : variable units (skipped IF ' ') ! --- ------------------------------------------------------------------ ! IMPLICIT NONE ! - REAL ::sfac,offs - INTEGER :: frmt,cmpflg,pos,n - CHARACTER(LEN=*) :: vnm,vlngnm,vstdnm,vunits + REAL, intent(in) :: sfac,offs + INTEGER, intent(in) :: frmt,cmpflg,pos + CHARACTER(LEN=*),intent(in) :: vnm ! - CHARACTER(LEN=100) :: dims + INTEGER :: n + CHARACTER(LEN=100) :: dims ! ! --- Check whether field should be written IF (pos.EQ.0 .OR. frmt.EQ.0) RETURN @@ -1768,20 +1755,12 @@ SUBROUTINE wrtlyr(pos,frmt,sfac,offs,cmpflg,vnm,vlngnm,vstdnm, & ELSE STOP 'unknown output format ' ENDIF -! -! --- Def.NE.attributes -! IF (len(trim(vunits)).NE.0) CALL ncattr('units',vunits) -! IF (len(trim(vlngnm)).NE.0) CALL ncattr('long_name',vlngnm) -! IF (len(trim(vstdnm)).NE.0) CALL ncattr('standard_name',vstdnm) -! CALL ncattr('coordinates','plon plat') -! CALL ncattr('cell_measures','area: parea') ! END SUBROUTINE wrtlyr - SUBROUTINE wrtlvl(pos,frmt,sfac,offs,cmpflg,vnm,vlngnm,vstdnm, & - & vunits) + SUBROUTINE wrtlvl(pos,frmt,sfac,offs,cmpflg,vnm) ! ! --- ------------------------------------------------------------------ ! --- Description: writes diagnostic level field to file @@ -1799,18 +1778,16 @@ SUBROUTINE wrtlvl(pos,frmt,sfac,offs,cmpflg,vnm,vlngnm,vstdnm, & ! --- int cmpflg (in) : compression flag; only wet points are ! --- written IF flag is set to 1 ! --- char vnm (in) : variable name used in nc-file -! --- char vlngnm (in) : variable long name (skipped IF ' ') -! --- char vstdnm (in) : variable standard name (skipped IF ' ') -! --- char vunits (in) : variable units (skipped IF ' ') ! --- ------------------------------------------------------------------ ! IMPLICIT NONE ! - REAL ::sfac,offs - INTEGER :: frmt,cmpflg,pos,n - CHARACTER(LEN=*) :: vnm,vlngnm,vstdnm,vunits + REAL, intent(in) :: sfac,offs + INTEGER, intent(in) :: frmt,cmpflg,pos + CHARACTER(LEN=*),intent(in) :: vnm ! - CHARACTER(LEN=100) :: dims + INTEGER :: n + CHARACTER(LEN=100) :: dims ! ! --- Check whether field should be written IF (pos.EQ.0 .OR. frmt.EQ.0) RETURN @@ -1850,20 +1827,12 @@ SUBROUTINE wrtlvl(pos,frmt,sfac,offs,cmpflg,vnm,vlngnm,vstdnm, & ELSE STOP 'unknown output format ' ENDIF -! -! --- Def.NE.attributes -! IF (len(trim(vunits)).NE.0) CALL ncattr('units',vunits) -! IF (len(trim(vlngnm)).NE.0) CALL ncattr('long_name',vlngnm) -! IF (len(trim(vstdnm)).NE.0) CALL ncattr('standard_name',vstdnm) -! CALL ncattr('coordinates','plon plat') -! CALL ncattr('cell_measures','area: parea') ! END SUBROUTINE wrtlvl - SUBROUTINE wrtsdm(pos,frmt,sfac,offs,cmpflg,vnm,vlngnm,vstdnm, & - & vunits) + SUBROUTINE wrtsdm(pos,frmt,sfac,offs,cmpflg,vnm) ! ! --- ------------------------------------------------------------------ ! --- Description: writes diagnostic sediment field to file @@ -1881,18 +1850,16 @@ SUBROUTINE wrtsdm(pos,frmt,sfac,offs,cmpflg,vnm,vlngnm,vstdnm, & ! --- int cmpflg (in) : compression flag; only wet points are ! --- written IF flag is set to 1 ! --- char vnm (in) : variable name used in nc-file -! --- char vlngnm (in) : variable long name (skipped IF ' ') -! --- char vstdnm (in) : variable standard name (skipped IF ' ') -! --- char vunits (in) : variable units (skipped IF ' ') ! --- ------------------------------------------------------------------ ! IMPLICIT NONE ! - REAL ::sfac,offs - INTEGER :: frmt,cmpflg,pos,n - CHARACTER(LEN=*) :: vnm,vlngnm,vstdnm,vunits + REAL, intent(in) :: sfac,offs + INTEGER, intent(in) :: frmt,cmpflg,pos + CHARACTER(LEN=*),intent(in) :: vnm ! - CHARACTER(LEN=100) :: dims + INTEGER :: n + CHARACTER(LEN=100) :: dims ! ! --- Check whether field should be written IF (pos.EQ.0 .OR. frmt.EQ.0) RETURN @@ -1932,20 +1899,12 @@ SUBROUTINE wrtsdm(pos,frmt,sfac,offs,cmpflg,vnm,vlngnm,vstdnm, & ELSE STOP 'unknown output format ' ENDIF -! -! --- Def.NE.attributes -! IF (len(trim(vunits)).NE.0) CALL ncattr('units',vunits) -! IF (len(trim(vlngnm)).NE.0) CALL ncattr('long_name',vlngnm) -! IF (len(trim(vstdnm)).NE.0) CALL ncattr('standard_name',vstdnm) -! CALL ncattr('coordinates','plon plat') -! CALL ncattr('cell_measures','area: parea') ! END SUBROUTINE wrtsdm - SUBROUTINE wrtbur(pos,frmt,sfac,offs,cmpflg,vnm,vlngnm,vstdnm, & - & vunits) + SUBROUTINE wrtbur(pos,frmt,sfac,offs,cmpflg,vnm) ! ! --- ------------------------------------------------------------------ ! --- Description: writes diagnostic sediment burial field to file @@ -1963,18 +1922,16 @@ SUBROUTINE wrtbur(pos,frmt,sfac,offs,cmpflg,vnm,vlngnm,vstdnm, & ! --- int cmpflg (in) : compression flag; only wet points are ! --- written IF flag is set to 1 ! --- char vnm (in) : variable name used in nc-file -! --- char vlngnm (in) : variable long name (skipped IF ' ') -! --- char vstdnm (in) : variable standard name (skipped IF ' ') -! --- char vunits (in) : variable units (skipped IF ' ') ! --- ------------------------------------------------------------------ ! IMPLICIT NONE ! - REAL ::sfac,offs - INTEGER :: frmt,cmpflg,pos,n - CHARACTER(LEN=*) :: vnm,vlngnm,vstdnm,vunits + REAL, intent(in) :: sfac,offs + INTEGER, intent(in) :: frmt,cmpflg,pos + CHARACTER(LEN=*),intent(in) :: vnm ! - CHARACTER(LEN=100) :: dims + INTEGER :: n + CHARACTER(LEN=100) :: dims ! ! --- Check whether field should be written IF (pos.EQ.0 .OR. frmt.EQ.0) RETURN @@ -2014,13 +1971,6 @@ SUBROUTINE wrtbur(pos,frmt,sfac,offs,cmpflg,vnm,vlngnm,vstdnm, & ELSE STOP 'unknown output format ' ENDIF -! -! --- Def.NE.attributes -! IF (len(trim(vunits)).NE.0) CALL ncattr('units',vunits) -! IF (len(trim(vlngnm)).NE.0) CALL ncattr('long_name',vlngnm) -! IF (len(trim(vstdnm)).NE.0) CALL ncattr('standard_name',vstdnm) -! CALL ncattr('coordinates','plon plat') -! CALL ncattr('cell_measures','area: parea') ! END SUBROUTINE wrtbur diff --git a/hamocc/ncout_hamocc.F90 b/hamocc/ncout_hamocc.F90 index 8f0f5778..df9d637f 100644 --- a/hamocc/ncout_hamocc.F90 +++ b/hamocc/ncout_hamocc.F90 @@ -395,498 +395,245 @@ subroutine ncwrt_bgc(iogrp) #endif ! --- Store 2d fields - call wrtsrf(jkwco2(iogrp),SRF_KWCO2(iogrp),rnacc,0.,cmpflg, & - & 'kwco2','CO2 piston velocity',' ','m s-1') - call wrtsrf(jkwco2khm(iogrp),SRF_KWCO2KHM(iogrp),rnacc,0.,cmpflg, & - & 'kwco2khm','CO2 piston velocity times solubility (moist air)',' ', & - & 'm s-1 mol kg-1 uatm-1') - call wrtsrf(jco2kh(iogrp),SRF_CO2KH(iogrp),rnacc,0.,cmpflg, & - & 'co2kh','CO2 solubility (dry air) ',' ','mol kg-1 atm-1') - call wrtsrf(jco2khm(iogrp),SRF_CO2KHM(iogrp),rnacc,0.,cmpflg, & - & 'co2khm','CO2 solubility (moist air) ',' ','mol kg-1 atm-1') - call wrtsrf(jpco2(iogrp),SRF_PCO2(iogrp),rnacc,0.,cmpflg, & - & 'pco2','Surface PCO2',' ','uatm') - call wrtsrf(jpco2m(iogrp),SRF_PCO2M(iogrp),rnacc,0.,cmpflg, & - & 'pco2m','Surface PCO2 (moist air)',' ','uatm') - call wrtsrf(jdmsflux(iogrp),SRF_DMSFLUX(iogrp),rnacc*1e3/dtbgc,0., & - & cmpflg,'dmsflux','DMS flux',' ','mol DMS m-2 s-1') - call wrtsrf(jco2fxd(iogrp),SRF_CO2FXD(iogrp),rnacc*12./dtbgc,0., & - & cmpflg,'co2fxd','Downward CO2 flux',' ','kg C m-2 s-1') - call wrtsrf(jco2fxu(iogrp),SRF_CO2FXU(iogrp),rnacc*12./dtbgc,0., & - & cmpflg,'co2fxu','Upward CO2 flux',' ','kg C m-2 s-1') - call wrtsrf(joxflux(iogrp),SRF_OXFLUX(iogrp),rnacc*1e3/dtbgc,0., & - & cmpflg,'fgo2','Oxygen flux',' ','mol O2 m-2 s-1') - call wrtsrf(jniflux(iogrp),SRF_NIFLUX(iogrp),rnacc*1e3/dtbgc,0., & - & cmpflg,'fgn2','Nitrogen flux',' ','mol N2 m-2 s-1') - call wrtsrf(jdms(iogrp),SRF_DMS(iogrp),rnacc,0.,cmpflg, & - & 'dms','DMS',' ','kmol DMS m-3') - call wrtsrf(jdmsprod(iogrp),SRF_DMSPROD(iogrp),rnacc*1e3/dtbgc,0., & - & cmpflg,'dmsprod','DMS production from phytoplankton production', & - & ' ','mol DMS m-2 s-1') - call wrtsrf(jdms_bac(iogrp),SRF_DMS_BAC(iogrp),rnacc*1e3/dtbgc,0., & - & cmpflg,'dms_bac','DMS bacterial consumption',' ', & - & 'mol DMS m-2 s-1') - call wrtsrf(jdms_uv(iogrp),SRF_DMS_UV(iogrp),rnacc*1e3/dtbgc,0., & - & cmpflg,'dms_uv','DMS photolysis reduction',' ','mol DMS m-2 s-1') - call wrtsrf(jexport(iogrp),SRF_EXPORT(iogrp),rnacc*1e3/dtbgc,0., & - & cmpflg,'epc100','Export production',' ','mol C m-2 s-1') - call wrtsrf(jexposi(iogrp),SRF_EXPOSI(iogrp),rnacc*1e3/dtbgc,0., & - & cmpflg,'epsi100','Si export production',' ','mol Si m-2 s-1') - call wrtsrf(jexpoca(iogrp),SRF_EXPOCA(iogrp),rnacc*1e3/dtbgc,0., & - & cmpflg,'epcalc100','Ca export production',' ','mol Ca m-2 s-1') - call wrtsrf(jsrfdic(iogrp),SRF_DIC(iogrp), & - & rnacc*1e3,0.,cmpflg,'srfdissic', & - & 'Surface dissolved inorganic carbon',' ','mol C m-3') - call wrtsrf(jsrfalkali(iogrp),SRF_ALKALI(iogrp), & - & rnacc*1e3,0.,cmpflg,'srftalk', & - & 'Surface alkalinity',' ','eq m-3') - call wrtsrf(jsrfphosph(iogrp),SRF_PHOSPH(iogrp), & - & rnacc*1e3,0.,cmpflg,'srfpo4', & - & 'Surface phosphorus',' ','mol P m-3') - call wrtsrf(jsrfoxygen(iogrp),SRF_OXYGEN(iogrp), & - & rnacc*1e3,0.,cmpflg,'srfo2', & - & 'Surface oxygen',' ','mol O2 m-3') - call wrtsrf(jsrfano3(iogrp),SRF_ANO3(iogrp), & - & rnacc*1e3,0.,cmpflg,'srfno3', & - & 'Surface nitrate',' ','mol N m-3') - call wrtsrf(jsrfsilica(iogrp),SRF_SILICA(iogrp), & - & rnacc*1e3,0.,cmpflg,'srfsi', & - & 'Surface silicate',' ','mol Si m-3') - call wrtsrf(jsrfiron(iogrp),SRF_IRON(iogrp), & - & rnacc*1e3,0.,cmpflg,'srfdfe', & - & 'Surface dissolved iron',' ','mol Fe m-3') - call wrtsrf(jsrfphyto(iogrp),SRF_PHYTO(iogrp), & - & rnacc*1e3,0.,cmpflg,'srfphyc', & - & 'Surface phytoplankton',' ','mol P m-3') - call wrtsrf(jsrfph(iogrp),SRF_PH(iogrp),-1.,0., & - & cmpflg,'srfph','Surface pH',' ','-log10([H+])') - call wrtsrf(jintphosy(iogrp),INT_PHOSY(iogrp), & - & rnacc*1e3/dtbgc,0.,cmpflg,'ppint', & - & 'Integrated primary production',' ','mol C m-2 s-1') - call wrtsrf(jintnfix(iogrp),INT_NFIX(iogrp), & - & rnacc*1e3/dtbgc,0.,cmpflg,'nfixint', & - & 'Integrated nitrogen fixation',' ','mol N m-2 s-1') - call wrtsrf(jintdnit(iogrp),INT_DNIT(iogrp), & - & rnacc*1e3/dtbgc,0.,cmpflg,'dnitint', & - & 'Integrated denitrification',' ','mol N m-2 s-1') - call wrtsrf(jcarflx0100(iogrp),FLX_CAR0100(iogrp), & - & rnacc*1e3/dtbgc,0.,cmpflg,'carflx0100', & - & 'C flux at 100m',' ','mol C m-2 s-1') - call wrtsrf(jcarflx0500(iogrp),FLX_CAR0500(iogrp), & - & rnacc*1e3/dtbgc,0.,cmpflg,'carflx0500', & - & 'C flux at 500m',' ','mol C m-2 s-1') - call wrtsrf(jcarflx1000(iogrp),FLX_CAR1000(iogrp), & - & rnacc*1e3/dtbgc,0.,cmpflg,'carflx1000', & - & 'C flux at 1000m',' ','mol C m-2 s-1') - call wrtsrf(jcarflx2000(iogrp),FLX_CAR2000(iogrp), & - & rnacc*1e3/dtbgc,0.,cmpflg,'carflx2000', & - & 'C flux at 2000m',' ','mol C m-2 s-1') - call wrtsrf(jcarflx4000(iogrp),FLX_CAR4000(iogrp), & - & rnacc*1e3/dtbgc,0.,cmpflg,'carflx4000', & - & 'C flux at 4000m',' ','mol C m-2 s-1') - call wrtsrf(jcarflx_bot(iogrp),FLX_CAR_BOT(iogrp), & - & rnacc*1e3/dtbgc,0.,cmpflg,'carflx_bot', & - & 'C flux to sediment',' ','mol C m-2 s-1') - call wrtsrf(jbsiflx0100(iogrp),FLX_BSI0100(iogrp), & - & rnacc*1e3/dtbgc,0.,cmpflg,'bsiflx0100', & - & 'Opal flux at 100m',' ','mol Si m-2 s-1') - call wrtsrf(jbsiflx0500(iogrp),FLX_BSI0500(iogrp), & - & rnacc*1e3/dtbgc,0.,cmpflg,'bsiflx0500', & - & 'Opal flux at 500m',' ','mol Si m-2 s-1') - call wrtsrf(jbsiflx1000(iogrp),FLX_BSI1000(iogrp), & - & rnacc*1e3/dtbgc,0.,cmpflg,'bsiflx1000', & - & 'Opal flux at 1000m',' ','mol Si m-2 s-1') - call wrtsrf(jbsiflx2000(iogrp),FLX_BSI2000(iogrp), & - & rnacc*1e3/dtbgc,0.,cmpflg,'bsiflx2000', & - & 'Opal flux at 2000m',' ','mol Si m-2 s-1') - call wrtsrf(jbsiflx4000(iogrp),FLX_BSI4000(iogrp), & - & rnacc*1e3/dtbgc,0.,cmpflg,'bsiflx4000', & - & 'Opal flux at 4000m',' ','mol Si m-2 s-1') - call wrtsrf(jbsiflx_bot(iogrp),FLX_BSI_BOT(iogrp), & - & rnacc*1e3/dtbgc,0.,cmpflg,'bsiflx_bot', & - & 'Opal flux to sediment',' ','mol Si m-2 s-1') - call wrtsrf(jcalflx0100(iogrp),FLX_CAL0100(iogrp), & - & rnacc*1e3/dtbgc,0.,cmpflg,'calflx0100', & - & 'CaCO3 flux at 100m',' ','mol Ca m-2 s-1') - call wrtsrf(jcalflx0500(iogrp),FLX_CAL0500(iogrp), & - & rnacc*1e3/dtbgc,0.,cmpflg,'calflx0500', & - & 'CaCO3 flux at 500m',' ','mol Ca m-2 s-1') - call wrtsrf(jcalflx1000(iogrp),FLX_CAL1000(iogrp), & - & rnacc*1e3/dtbgc,0.,cmpflg,'calflx1000', & - & 'CaCO3 flux at 1000m',' ','mol Ca m-2 s-1') - call wrtsrf(jcalflx2000(iogrp),FLX_CAL2000(iogrp), & - & rnacc*1e3/dtbgc,0.,cmpflg,'calflx2000', & - & 'CaCO3 flux at 2000m',' ','mol Ca m-2 s-1') - call wrtsrf(jcalflx4000(iogrp),FLX_CAL4000(iogrp), & - & rnacc*1e3/dtbgc,0.,cmpflg,'calflx4000', & - & 'CaCO3 flux at 4000m',' ','mol Ca m-2 s-1') - call wrtsrf(jcalflx_bot(iogrp),FLX_CAL_BOT(iogrp), & - & rnacc*1e3/dtbgc,0.,cmpflg,'calflx_bot', & - & 'CaCO3 flux to sediment',' ','mol Ca m-2 s-1') + call wrtsrf(jkwco2(iogrp), SRF_KWCO2(iogrp), rnacc, 0.,cmpflg,'kwco2') + call wrtsrf(jkwco2khm(iogrp), SRF_KWCO2KHM(iogrp), rnacc, 0.,cmpflg,'kwco2khm') + call wrtsrf(jco2kh(iogrp), SRF_CO2KH(iogrp), rnacc, 0.,cmpflg,'co2kh') + call wrtsrf(jco2khm(iogrp), SRF_CO2KHM(iogrp), rnacc, 0.,cmpflg,'co2khm') + call wrtsrf(jpco2(iogrp), SRF_PCO2(iogrp), rnacc, 0.,cmpflg,'pco2') + call wrtsrf(jpco2m(iogrp), SRF_PCO2M(iogrp), rnacc, 0.,cmpflg,'pco2m') + call wrtsrf(jdmsflux(iogrp), SRF_DMSFLUX(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'dmsflux') + call wrtsrf(jco2fxd(iogrp), SRF_CO2FXD(iogrp), rnacc*12./dtbgc,0.,cmpflg,'co2fxd') + call wrtsrf(jco2fxu(iogrp), SRF_CO2FXU(iogrp), rnacc*12./dtbgc,0.,cmpflg,'co2fxu') + call wrtsrf(joxflux(iogrp), SRF_OXFLUX(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'fgo2') + call wrtsrf(jniflux(iogrp), SRF_NIFLUX(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'fgn2') + call wrtsrf(jn2ofx(iogrp), SRF_N2OFX(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'n2oflux') + call wrtsrf(jdms(iogrp), SRF_DMS(iogrp), rnacc, 0.,cmpflg,'dms') + call wrtsrf(jdmsprod(iogrp), SRF_DMSPROD(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'dmsprod') + call wrtsrf(jdms_bac(iogrp), SRF_DMS_BAC(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'dms_bac') + call wrtsrf(jdms_uv(iogrp), SRF_DMS_UV(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'dms_uv') + call wrtsrf(jexport(iogrp), SRF_EXPORT(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'epc100') + call wrtsrf(jexposi(iogrp), SRF_EXPOSI(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'epsi100') + call wrtsrf(jexpoca(iogrp), SRF_EXPOCA(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'epcalc100') + call wrtsrf(jsrfdic(iogrp), SRF_DIC(iogrp), rnacc*1e3, 0.,cmpflg,'srfdissic') + call wrtsrf(jsrfalkali(iogrp), SRF_ALKALI(iogrp), rnacc*1e3, 0.,cmpflg,'srftalk') + call wrtsrf(jsrfphosph(iogrp), SRF_PHOSPH(iogrp), rnacc*1e3, 0.,cmpflg,'srfpo4') + call wrtsrf(jsrfoxygen(iogrp), SRF_OXYGEN(iogrp), rnacc*1e3, 0.,cmpflg,'srfo2') + call wrtsrf(jsrfano3(iogrp), SRF_ANO3(iogrp), rnacc*1e3, 0.,cmpflg,'srfno3') + call wrtsrf(jsrfsilica(iogrp), SRF_SILICA(iogrp), rnacc*1e3, 0.,cmpflg,'srfsi') + call wrtsrf(jsrfiron(iogrp), SRF_IRON(iogrp), rnacc*1e3, 0.,cmpflg,'srfdfe') + call wrtsrf(jsrfphyto(iogrp), SRF_PHYTO(iogrp), rnacc*1e3, 0.,cmpflg,'srfphyc') + call wrtsrf(jsrfph(iogrp), SRF_PH(iogrp), -1., 0.,cmpflg,'srfph') + call wrtsrf(jintphosy(iogrp), INT_PHOSY(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'ppint') + call wrtsrf(jintnfix(iogrp), INT_NFIX(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'nfixint') + call wrtsrf(jintdnit(iogrp), INT_DNIT(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'dnitint') + call wrtsrf(jcarflx0100(iogrp), FLX_CAR0100(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'carflx0100') + call wrtsrf(jcarflx0500(iogrp), FLX_CAR0500(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'carflx0500') + call wrtsrf(jcarflx1000(iogrp), FLX_CAR1000(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'carflx1000') + call wrtsrf(jcarflx2000(iogrp), FLX_CAR2000(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'carflx2000') + call wrtsrf(jcarflx4000(iogrp), FLX_CAR4000(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'carflx4000') + call wrtsrf(jcarflx_bot(iogrp), FLX_CAR_BOT(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'carflx_bot') + call wrtsrf(jbsiflx0100(iogrp), FLX_BSI0100(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'bsiflx0100') + call wrtsrf(jbsiflx0500(iogrp), FLX_BSI0500(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'bsiflx0500') + call wrtsrf(jbsiflx1000(iogrp), FLX_BSI1000(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'bsiflx1000') + call wrtsrf(jbsiflx2000(iogrp), FLX_BSI2000(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'bsiflx2000') + call wrtsrf(jbsiflx4000(iogrp), FLX_BSI4000(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'bsiflx4000') + call wrtsrf(jbsiflx_bot(iogrp), FLX_BSI_BOT(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'bsiflx_bot') + call wrtsrf(jcalflx0100(iogrp), FLX_CAL0100(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'calflx0100') + call wrtsrf(jcalflx0500(iogrp), FLX_CAL0500(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'calflx0500') + call wrtsrf(jcalflx1000(iogrp), FLX_CAL1000(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'calflx1000') + call wrtsrf(jcalflx2000(iogrp), FLX_CAL2000(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'calflx2000') + call wrtsrf(jcalflx4000(iogrp), FLX_CAL4000(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'calflx4000') + call wrtsrf(jcalflx_bot(iogrp), FLX_CAL_BOT(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'calflx_bot') #ifndef sedbypass - call wrtsrf(jsediffic(iogrp),FLX_SEDIFFIC(iogrp), & - & rnacc*1e3/dtbgc,0.,cmpflg,'sedfdic',' ',' ',' ') - call wrtsrf(jsediffal(iogrp),FLX_SEDIFFAL(iogrp), & - & rnacc*1e3/dtbgc,0.,cmpflg,'sedfalk',' ',' ',' ') - call wrtsrf(jsediffph(iogrp),FLX_SEDIFFPH(iogrp), & - & rnacc*1e3/dtbgc,0.,cmpflg,'sedfpho',' ',' ',' ') - call wrtsrf(jsediffox(iogrp),FLX_SEDIFFOX(iogrp), & - & rnacc*1e3/dtbgc,0.,cmpflg,'sedfox',' ',' ',' ') - call wrtsrf(jsediffn2(iogrp),FLX_SEDIFFN2(iogrp), & - & rnacc*1e3/dtbgc,0.,cmpflg,'sedfn2',' ',' ',' ') - call wrtsrf(jsediffno3(iogrp),FLX_SEDIFFNO3(iogrp), & - & rnacc*1e3/dtbgc,0.,cmpflg,'sedfno3',' ',' ',' ') - call wrtsrf(jsediffsi(iogrp),FLX_SEDIFFSI(iogrp), & - & rnacc*1e3/dtbgc,0.,cmpflg,'sedfsi',' ',' ',' ') -#endif - call wrtsrf(jn2ofx(iogrp),SRF_N2OFX(iogrp),rnacc*1e3/dtbgc,0., & - & cmpflg,'n2oflux','N2O flux',' ','mol N2O m-2 s-1') + call wrtsrf(jsediffic(iogrp), FLX_SEDIFFIC(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'sedfdic') + call wrtsrf(jsediffal(iogrp), FLX_SEDIFFAL(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'sedfalk') + call wrtsrf(jsediffph(iogrp), FLX_SEDIFFPH(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'sedfpho') + call wrtsrf(jsediffox(iogrp), FLX_SEDIFFOX(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'sedfox') + call wrtsrf(jsediffn2(iogrp), FLX_SEDIFFN2(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'sedfn2') + call wrtsrf(jsediffno3(iogrp), FLX_SEDIFFNO3(iogrp),rnacc*1e3/dtbgc,0.,cmpflg,'sedfno3') + call wrtsrf(jsediffsi(iogrp), FLX_SEDIFFSI(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'sedfsi') +#endif #ifdef cisonew - call wrtsrf(jco213fxd(iogrp),SRF_CO213FXD(iogrp), & - & rnacc*12./dtbgc,0.,cmpflg,'co213fxd', & - & 'Downward 13CO2 flux',' ','kg C m-2 s-1') - call wrtsrf(jco213fxu(iogrp),SRF_CO213FXU(iogrp), & - & rnacc*12./dtbgc,0.,cmpflg,'co213fxu', & - & 'Upward 13CO2 flux',' ','kg C m-2 s-1') - call wrtsrf(jco214fxd(iogrp),SRF_CO214FXD(iogrp), & - & rnacc*12.*c14fac/dtbgc,0.,cmpflg,'co214fxd', & - & 'Downward 14CO2 flux',' ','kg C m-2 s-1') - call wrtsrf(jco214fxu(iogrp),SRF_CO214FXU(iogrp), & - & rnacc*12.*c14fac/dtbgc,0.,cmpflg,'co214fxu', & - & 'Upward 14CO2 flux',' ','kg C m-2 s-1') + call wrtsrf(jco213fxd(iogrp), SRF_CO213FXD(iogrp), rnacc*12./dtbgc,0.,cmpflg,'co213fxd') + call wrtsrf(jco213fxu(iogrp), SRF_CO213FXU(iogrp), rnacc*12./dtbgc,0.,cmpflg,'co213fxu') + call wrtsrf(jco214fxd(iogrp), SRF_CO214FXD(iogrp), rnacc*12.*c14fac/dtbgc,0.,cmpflg,'co214fxd') + call wrtsrf(jco214fxu(iogrp), SRF_CO214FXU(iogrp), rnacc*12.*c14fac/dtbgc,0.,cmpflg,'co214fxu') #endif #ifdef CFC - call wrtsrf(jcfc11fx(iogrp),SRF_CFC11(iogrp),rnacc*1e3/dtbgc,0., & - & cmpflg,'cfc11flux','CFC-11 flux',' ','mol CFC12 m-2 s-1') - call wrtsrf(jcfc12fx(iogrp),SRF_CFC12(iogrp),rnacc*1e3/dtbgc,0., & - & cmpflg,'cfc12flux','CFC-12 flux',' ','mol CFC12 m-2 s-1') - call wrtsrf(jsf6fx(iogrp),SRF_SF6(iogrp),rnacc*1e3/dtbgc,0., & - & cmpflg,'sf6flux','SF-6 flux',' ','mol SF6 m-2 s-1') + call wrtsrf(jcfc11fx(iogrp), SRF_CFC11(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'cfc11flux') + call wrtsrf(jcfc12fx(iogrp), SRF_CFC12(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'cfc12flux') + call wrtsrf(jsf6fx(iogrp), SRF_SF6(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'sf6flux') #endif #ifdef natDIC - call wrtsrf(jsrfnatdic(iogrp),SRF_NATDIC(iogrp), & - & rnacc*1e3,0.,cmpflg,'srfnatdissic', & - & 'Surface natural dissolved inorganic carbon',' ','mol C m-3') - call wrtsrf(jsrfnatalk(iogrp),SRF_NATALKALI(iogrp), & - & rnacc*1e3,0.,cmpflg,'srfnattalk', & - & 'Surface natural alkalinity',' ','eq m-3') - call wrtsrf(jnatpco2(iogrp),SRF_NATPCO2(iogrp),rnacc,0.,cmpflg, & - & 'natpco2','Surface natural PCO2',' ','uatm') - call wrtsrf(jnatco2fx(iogrp),SRF_NATCO2FX(iogrp), & - & rnacc*12./dtbgc,0.,cmpflg,'natco2fx', & - & 'Natural CO2 flux',' ','kg C m-2 s-1') - call wrtsrf(jsrfnatph(iogrp),SRF_NATPH(iogrp),-1.,0., & - & cmpflg,'srfnatph','Surface natural pH',' ','-log10([H+])') + call wrtsrf(jsrfnatdic(iogrp), SRF_NATDIC(iogrp), rnacc*1e3, 0.,cmpflg,'srfnatdissic') + call wrtsrf(jsrfnatalk(iogrp), SRF_NATALKALI(iogrp),rnacc*1e3, 0.,cmpflg,'srfnattalk') + call wrtsrf(jnatpco2(iogrp), SRF_NATPCO2(iogrp), rnacc, 0.,cmpflg,'natpco2') + call wrtsrf(jnatco2fx(iogrp), SRF_NATCO2FX(iogrp), rnacc*12./dtbgc,0.,cmpflg,'natco2fx') + call wrtsrf(jsrfnatph(iogrp), SRF_NATPH(iogrp), -1., 0.,cmpflg,'srfnatph') #endif #ifdef BROMO - call wrtsrf(jbromofx(iogrp),SRF_BROMOFX(iogrp),rnacc*1e3/dtbgc, & - & 0.,cmpflg,'bromofx','Bromoform flux',' ','mol CHBr3 m-2 s-1') - call wrtsrf(jsrfbromo(iogrp),SRF_BROMO(iogrp),rnacc*1e3,0., & - & cmpflg,'srfbromo','Surface bromoform',' ','mol CHBr3 m-3') - call wrtsrf(jbromo_prod(iogrp),INT_BROMOPRO(iogrp), & - & rnacc*1e3/dtbgc,0.,cmpflg,'intbromoprod', & - & 'Integrated bromoform production',' ','mol CHBr3 m-2 s-1') - call wrtsrf(jbromo_uv(iogrp),INT_BROMOUV(iogrp), & - & rnacc*1e3/dtbgc,0.,cmpflg,'intbromouv', & - & 'Integrated bromoform loss to photolysis',' ', & - & 'mol CHBr3 m-2 s-1') - call wrtsrf(jatmbromo(iogrp),SRF_ATMBROMO(iogrp),rnacc,0., & - & cmpflg,'atmbromo','Atmospheric bromoform',' ','ppt') + call wrtsrf(jbromofx(iogrp), SRF_BROMOFX(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'bromofx') + call wrtsrf(jsrfbromo(iogrp), SRF_BROMO(iogrp), rnacc*1e3, 0.,cmpflg,'srfbromo') + call wrtsrf(jbromo_prod(iogrp), INT_BROMOPRO(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'intbromoprod') + call wrtsrf(jbromo_uv(iogrp), INT_BROMOUV(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'intbromouv') + call wrtsrf(jatmbromo(iogrp), SRF_ATMBROMO(iogrp), rnacc, 0.,cmpflg,'atmbromo') #endif - - - call wrtsrf(jatmco2(iogrp),SRF_ATMCO2(iogrp),rnacc,0.,cmpflg, & - & 'atmco2','Atmospheric CO2',' ','ppm') + call wrtsrf(jatmco2(iogrp), SRF_ATMCO2(iogrp), rnacc, 0.,cmpflg,'atmco2') #if defined(BOXATM) - call wrtsrf(jatmo2(iogrp),SRF_ATMO2(iogrp),rnacc,0.,cmpflg, & - & 'atmo2','Atmospheric O2',' ','ppm') - call wrtsrf(jatmn2(iogrp),SRF_ATMN2(iogrp),rnacc,0.,cmpflg, & - & 'atmn2','Atmospheric N2',' ','ppm') + call wrtsrf(jatmo2(iogrp), SRF_ATMO2(iogrp), rnacc, 0.,cmpflg,'atmo2') + call wrtsrf(jatmn2(iogrp), SRF_ATMN2(iogrp), rnacc, 0.,cmpflg,'atmn2') #endif #ifdef cisonew - call wrtsrf(jatmc13(iogrp),SRF_ATMC13(iogrp),rnacc,0.,cmpflg, & - & 'atmc13','Atmospheric 13CO2',' ','ppm') - call wrtsrf(jatmc14(iogrp),SRF_ATMC14(iogrp),rnacc,0.,cmpflg, & - & 'atmc14','Atmospheric 14CO2',' ','ppm') + call wrtsrf(jatmc13(iogrp), SRF_ATMC13(iogrp), rnacc, 0.,cmpflg,'atmc13') + call wrtsrf(jatmc14(iogrp), SRF_ATMC14(iogrp), rnacc, 0.,cmpflg,'atmc14) #endif ! --- Store 3d layer fields - call wrtlyr(jdp(iogrp),LYR_DP(iogrp),rnacc,0.,cmpflg, & - & 'pddpo','Layer thickness',' ','m') - call wrtlyr(jdic(iogrp),LYR_DIC(iogrp),1e3,0.,cmpflg, & - & 'dissic','Dissolved inorganic carbon',' ','mol C m-3') - call wrtlyr(jalkali(iogrp),LYR_ALKALI(iogrp),1e3,0.,cmpflg, & - & 'talk','Alkalinity',' ','eq m-3') - call wrtlyr(jphosph(iogrp),LYR_PHOSPH(iogrp),1e3,0.,cmpflg, & - & 'po4','Phosphorus',' ','mol P m-3') - call wrtlyr(joxygen(iogrp),LYR_OXYGEN(iogrp),1e3,0.,cmpflg, & - & 'o2','Oxygen',' ','mol O2 m-3') - call wrtlyr(jano3(iogrp),LYR_ANO3(iogrp),1e3,0.,cmpflg, & - & 'no3','Nitrate',' ','mol N m-3') - call wrtlyr(jsilica(iogrp),LYR_SILICA(iogrp),1e3,0.,cmpflg, & - & 'si','Silicate',' ','mol Si m-3') - call wrtlyr(jdoc(iogrp),LYR_DOC(iogrp),1e3,0.,cmpflg, & - & 'dissoc','Dissolved organic carbon',' ','mol P m-3') - call wrtlyr(jphyto(iogrp),LYR_PHYTO(iogrp),1e3,0.,cmpflg, & - & 'phyc','Phytoplankton',' ','mol P m-3') - call wrtlyr(jgrazer(iogrp),LYR_GRAZER(iogrp),1e3,0.,cmpflg, & - & 'zooc','Zooplankton',' ','mol P m-3') - call wrtlyr(jpoc(iogrp),LYR_POC(iogrp),1e3,0.,cmpflg, & - & 'detoc','Detritus',' ','mol P m-3') - call wrtlyr(jcalc(iogrp),LYR_CALC(iogrp),1e3,0.,cmpflg, & - & 'calc','CaCO3 shells',' ','mol C m-3') - call wrtlyr(jopal(iogrp),LYR_OPAL(iogrp),1e3,0.,cmpflg, & - & 'opal','Opal shells',' ','mol Si m-3') - call wrtlyr(jiron(iogrp),LYR_IRON(iogrp),1e3,0.,cmpflg, & - & 'dfe','Dissolved iron',' ','mol Fe m-3') - call wrtlyr(jphosy(iogrp),LYR_PHOSY(iogrp),1e3/dtbgc,0.,cmpflg, & - & 'pp','Primary production',' ','mol C m-3 s-1') - call wrtlyr(jco3(iogrp),LYR_CO3(iogrp),1e3,0.,cmpflg, & - & 'co3','Carbonate ions',' ','mol C m-3') - call wrtlyr(jph(iogrp),LYR_PH(iogrp),-1.,0.,cmpflg, & - & 'ph','pH',' ','-log10([H+])') - call wrtlyr(jomegaa(iogrp),LYR_OMEGAA(iogrp),1.,0.,cmpflg, & - & 'omegaa','OmegaA',' ','-') - call wrtlyr(jomegac(iogrp),LYR_OMEGAC(iogrp),1.,0.,cmpflg, & - & 'omegac','OmegaC',' ','-') - call wrtlyr(jn2o(iogrp),LYR_N2O(iogrp),1e3,0.,cmpflg, & - & 'n2o','N2O',' ','mol N2O m-3') - call wrtlyr(jprefo2(iogrp),LYR_PREFO2(iogrp),1e3,0.,cmpflg, & - & 'p_o2','Preformed oxygen',' ','mol O2 m-3') - call wrtlyr(jo2sat(iogrp),LYR_O2SAT(iogrp),1e3,0.,cmpflg, & - & 'satoxy','Saturated oxygen',' ','mol O2 m-3') - call wrtlyr(jprefpo4(iogrp),LYR_PREFPO4(iogrp),1e3,0.,cmpflg, & - & 'p_po4','Preformed phosphorus',' ','mol P m-3') - call wrtlyr(jprefalk(iogrp),LYR_PREFALK(iogrp),1e3,0.,cmpflg, & - & 'p_talk','Preformed alkalinity',' ','eq m-3') - call wrtlyr(jprefdic(iogrp),LYR_PREFDIC(iogrp),1e3,0.,cmpflg, & - & 'p_dic','Preformed DIC',' ','mol C m-3') - call wrtlyr(jdicsat(iogrp),LYR_DICSAT(iogrp),1e3,0.,cmpflg, & - & 'sat_dic','Saturated DIC',' ','mol C m-3') + call wrtlyr(jdp(iogrp), LYR_DP(iogrp), rnacc, 0.,cmpflg,'pddpo') + call wrtlyr(jdic(iogrp), LYR_DIC(iogrp), 1e3, 0.,cmpflg,'dissic') + call wrtlyr(jalkali(iogrp), LYR_ALKALI(iogrp), 1e3, 0.,cmpflg,'talk') + call wrtlyr(jphosph(iogrp), LYR_PHOSPH(iogrp), 1e3, 0.,cmpflg,'po4') + call wrtlyr(joxygen(iogrp), LYR_OXYGEN(iogrp), 1e3, 0.,cmpflg,'o2') + call wrtlyr(jano3(iogrp), LYR_ANO3(iogrp), 1e3, 0.,cmpflg,'no3') + call wrtlyr(jsilica(iogrp), LYR_SILICA(iogrp), 1e3, 0.,cmpflg,'si') + call wrtlyr(jdoc(iogrp), LYR_DOC(iogrp), 1e3, 0.,cmpflg,'dissoc') + call wrtlyr(jphyto(iogrp), LYR_PHYTO(iogrp), 1e3, 0.,cmpflg,'phyc') + call wrtlyr(jgrazer(iogrp), LYR_GRAZER(iogrp), 1e3, 0.,cmpflg,'zooc') + call wrtlyr(jpoc(iogrp), LYR_POC(iogrp), 1e3, 0.,cmpflg,'detoc') + call wrtlyr(jcalc(iogrp), LYR_CALC(iogrp), 1e3, 0.,cmpflg,'calc') + call wrtlyr(jopal(iogrp), LYR_OPAL(iogrp), 1e3, 0.,cmpflg,'opal') + call wrtlyr(jiron(iogrp), LYR_IRON(iogrp), 1e3, 0.,cmpflg,'dfe') + call wrtlyr(jphosy(iogrp), LYR_PHOSY(iogrp), 1e3/dtbgc, 0.,cmpflg,'pp') + call wrtlyr(jco3(iogrp), LYR_CO3(iogrp), 1e3, 0.,cmpflg,'co3') + call wrtlyr(jph(iogrp), LYR_PH(iogrp), -1., 0.,cmpflg,'ph') + call wrtlyr(jomegaa(iogrp), LYR_OMEGAA(iogrp), 1., 0.,cmpflg,'omegaa') + call wrtlyr(jomegac(iogrp), LYR_OMEGAC(iogrp), 1., 0.,cmpflg,'omegac') + call wrtlyr(jn2o(iogrp), LYR_N2O(iogrp), 1e3, 0.,cmpflg,'n2o') + call wrtlyr(jprefo2(iogrp), LYR_PREFO2(iogrp), 1e3, 0.,cmpflg,'p_o2') + call wrtlyr(jo2sat(iogrp), LYR_O2SAT(iogrp), 1e3, 0.,cmpflg,'satoxy') + call wrtlyr(jprefpo4(iogrp), LYR_PREFPO4(iogrp), 1e3, 0.,cmpflg,'p_po4') + call wrtlyr(jprefalk(iogrp), LYR_PREFALK(iogrp), 1e3, 0.,cmpflg,'p_talk') + call wrtlyr(jprefdic(iogrp), LYR_PREFDIC(iogrp), 1e3, 0.,cmpflg,'p_dic') + call wrtlyr(jdicsat(iogrp), LYR_DICSAT(iogrp), 1e3, 0.,cmpflg,'sat_dic') #ifdef cisonew - call wrtlyr(jdic13(iogrp),LYR_DIC13(iogrp),1.e3,0.,cmpflg, & - & 'dissic13','Dissolved C13',' ','mol 13C m-3') - call wrtlyr(jdic14(iogrp),LYR_DIC14(iogrp),1.e3*c14fac,0.,cmpflg, & - & 'dissic14','Dissolved C14',' ','mol 14C m-3') - call wrtlyr(jd13c(iogrp),LYR_D13C(iogrp),1.,0.,cmpflg, & - & 'delta13c','delta13C of DIC',' ','permil') - call wrtlyr(jd14c(iogrp),LYR_D14C(iogrp),1.,0.,cmpflg, & - & 'delta14c','delta14C of DIC',' ','permil') - call wrtlyr(jbigd14c(iogrp),LYR_BIGD14C(iogrp),1.,0.,cmpflg, & - & 'bigdelta14c','big delta14C of DIC',' ','permil') - call wrtlyr(jpoc13(iogrp),LYR_POC13(iogrp),1e3,0.,cmpflg, & - & 'detoc13','Detritus13',' ','mol P m-3') - call wrtlyr(jdoc13(iogrp),LYR_DOC13(iogrp),1e3,0.,cmpflg, & - & 'dissoc13','Dissolved organic carbon13',' ','mol P m-3') - call wrtlyr(jcalc13(iogrp),LYR_CALC13(iogrp),1e3,0.,cmpflg, & - & 'calc13','Ca13CO3 shells',' ','mol 13C m-3') - call wrtlyr(jphyto13(iogrp),LYR_PHYTO13(iogrp),1e3,0.,cmpflg, & - & 'phyc13','Phytoplankton13',' ','mol P m-3') - call wrtlyr(jgrazer13(iogrp),LYR_GRAZER13(iogrp),1e3,0.,cmpflg, & - & 'zooc13','Zooplankton13',' ','mol P m-3') + call wrtlyr(jdic13(iogrp), LYR_DIC13(iogrp), 1.e3, 0.,cmpflg,'dissic13') + call wrtlyr(jdic14(iogrp), LYR_DIC14(iogrp), 1.e3*c14fac, 0.,cmpflg,'dissic14') + call wrtlyr(jd13c(iogrp), LYR_D13C(iogrp), 1., 0.,cmpflg,'delta13c') + call wrtlyr(jd14c(iogrp), LYR_D14C(iogrp), 1., 0.,cmpflg,'delta14c') + call wrtlyr(jbigd14c(iogrp), LYR_BIGD14C(iogrp), 1., 0.,cmpflg,'bigdelta14c') + call wrtlyr(jpoc13(iogrp), LYR_POC13(iogrp), 1e3, 0.,cmpflg,'detoc13') + call wrtlyr(jdoc13(iogrp), LYR_DOC13(iogrp), 1e3, 0.,cmpflg,'dissoc13') + call wrtlyr(jcalc13(iogrp), LYR_CALC13(iogrp), 1e3, 0.,cmpflg,'calc13') + call wrtlyr(jphyto13(iogrp), LYR_PHYTO13(iogrp), 1e3, 0.,cmpflg,'phyc13') + call wrtlyr(jgrazer13(iogrp), LYR_GRAZER13(iogrp), 1e3, 0.,cmpflg,'zooc13') #endif #ifdef AGG - call wrtlyr(jnos(iogrp),LYR_NOS(iogrp),1.,0.,cmpflg, & - & 'nos','Marine snow aggregates per cm^3 sea water',' ','1/cm^3') - call wrtlyr(jwphy(iogrp),LYR_WPHY(iogrp),1.,0.,cmpflg, & - & 'wphy','Av. mass sinking speed of marine snow',' ','m/day') - call wrtlyr(jwnos(iogrp),LYR_WNOS(iogrp),1.,0.,cmpflg, & - & 'wnos','Av. number sinking speed of marine snow',' ','m/day') - call wrtlyr(jeps(iogrp),LYR_EPS(iogrp),1.,0.,cmpflg, & - & 'eps','Av. size distribution exponent',' ','-') - call wrtlyr(jasize(iogrp),LYR_ASIZE(iogrp),1.,0.,cmpflg, & - & 'asize','Av. size of marine snow aggregates',' ','nb. of cells') + call wrtlyr(jnos(iogrp), LYR_NOS(iogrp), 1., 0.,cmpflg,'nos') + call wrtlyr(jwphy(iogrp), LYR_WPHY(iogrp), 1., 0.,cmpflg,'wphy') + call wrtlyr(jwnos(iogrp), LYR_WNOS(iogrp), 1., 0.,cmpflg,'wnos') + call wrtlyr(jeps(iogrp), LYR_EPS(iogrp), 1., 0.,cmpflg,'eps') + call wrtlyr(jasize(iogrp), LYR_ASIZE(iogrp), 1., 0.,cmpflg,'asize') #endif #ifdef CFC - call wrtlyr(jcfc11(iogrp),LYR_CFC11(iogrp),1e3,0.,cmpflg, & - & 'cfc11','CFC-11',' ','mol cfc11 m-3') - call wrtlyr(jcfc12(iogrp),LYR_CFC12(iogrp),1e3,0.,cmpflg, & - & 'cfc12','CFC-12',' ','mol cfc12 m-3') - call wrtlyr(jsf6(iogrp),LYR_SF6(iogrp),1e3,0.,cmpflg, & - & 'sf6','SF-6',' ','mol sf6 m-3') + call wrtlyr(jcfc11(iogrp), LYR_CFC11(iogrp), 1e3, 0.,cmpflg,'cfc11') + call wrtlyr(jcfc12(iogrp), LYR_CFC12(iogrp), 1e3, 0.,cmpflg,'cfc12') + call wrtlyr(jsf6(iogrp), LYR_SF6(iogrp), 1e3, 0.,cmpflg,'sf6') #endif #ifdef natDIC - call wrtlyr(jnatco3(iogrp),LYR_NATCO3(iogrp),1e3,0.,cmpflg, & - & 'natco3','Natural Carbonate ions',' ','mol C m-3') - call wrtlyr(jnatalkali(iogrp),LYR_NATALKALI(iogrp),1e3,0.,cmpflg, & - & 'nattalk','Natural alkalinity',' ','eq m-3') - call wrtlyr(jnatdic(iogrp),LYR_NATDIC(iogrp),1e3,0.,cmpflg, & - & 'natdissic','Natural dissolved inorganic carbon',' ', & - & 'mol C m-3') - call wrtlyr(jnatcalc(iogrp),LYR_NATCALC(iogrp),1e3,0.,cmpflg, & - & 'natcalc','Natural CaCO3 shells',' ','mol C m-3') - call wrtlyr(jnatph(iogrp),LYR_NATPH(iogrp),-1.,0.,cmpflg, & - & 'natph','Natural pH',' ','-log10([H+])') - call wrtlyr(jnatomegaa(iogrp),LYR_NATOMEGAA(iogrp),1.,0.,cmpflg, & - & 'natomegaa','Natural OmegaA',' ','-') - call wrtlyr(jnatomegac(iogrp),LYR_NATOMEGAC(iogrp),1.,0.,cmpflg, & - & 'natomegac','Natural OmegaC',' ','-') + call wrtlyr(jnatco3(iogrp), LYR_NATCO3(iogrp), 1e3, 0.,cmpflg,'natco3') + call wrtlyr(jnatalkali(iogrp), LYR_NATALKALI(iogrp),1e3, 0.,cmpflg,'nattalk') + call wrtlyr(jnatdic(iogrp), LYR_NATDIC(iogrp), 1e3, 0.,cmpflg,'natdissic') + call wrtlyr(jnatcalc(iogrp), LYR_NATCALC(iogrp), 1e3, 0.,cmpflg,'natcalc') + call wrtlyr(jnatph(iogrp), LYR_NATPH(iogrp), -1., 0.,cmpflg,'natph') + call wrtlyr(jnatomegaa(iogrp), LYR_NATOMEGAA(iogrp),1., 0.,cmpflg,'natomegaa') + call wrtlyr(jnatomegac(iogrp), LYR_NATOMEGAC(iogrp),1., 0.,cmpflg,'natomegac') #endif #ifdef BROMO - call wrtlyr(jbromo(iogrp),LYR_BROMO(iogrp),1e3,0.,cmpflg, & - & 'bromo','Bromoform',' ','mol CHBr3 m-3') + call wrtlyr(jbromo(iogrp), LYR_BROMO(iogrp), 1e3, 0.,cmpflg,'bromo') #endif ! --- Store 3d level fields - call wrtlvl(jlvldic(iogrp),LVL_DIC(iogrp),rnacc*1e3,0.,cmpflg, & - & 'dissiclvl','Dissolved inorganic carbon',' ','mol C m-3') - call wrtlvl(jlvlalkali(iogrp),LVL_ALKALI(iogrp),rnacc*1e3,0., & - & cmpflg, 'talklvl','Alkalinity',' ','eq m-3') - call wrtlvl(jlvlphosph(iogrp),LVL_PHOSPH(iogrp),rnacc*1e3,0., & - & cmpflg,'po4lvl','Phosphorus',' ','mol P m-3') - call wrtlvl(jlvloxygen(iogrp),LVL_OXYGEN(iogrp),rnacc*1e3,0., & - & cmpflg,'o2lvl','Oxygen',' ','mol O2 m-3') - call wrtlvl(jlvlano3(iogrp),LVL_ANO3(iogrp),rnacc*1e3,0.,cmpflg, & - & 'no3lvl','Nitrate',' ','mol N m-3') - call wrtlvl(jlvlsilica(iogrp),LVL_SILICA(iogrp),rnacc*1e3,0., & - & cmpflg, 'silvl','Silicate',' ','mol Si m-3') - call wrtlvl(jlvldoc(iogrp),LVL_DOC(iogrp),rnacc*1e3,0.,cmpflg, & - & 'dissoclvl','Dissolved organic carbon',' ','mol P m-3') - call wrtlvl(jlvlphyto(iogrp),LVL_PHYTO(iogrp),rnacc*1e3,0.,cmpflg, & - & 'phyclvl','Phytoplankton',' ','mol P m-3') - call wrtlvl(jlvlgrazer(iogrp),LVL_GRAZER(iogrp),rnacc*1e3,0., & - & cmpflg,'zooclvl','Zooplankton',' ','mol P m-3') - call wrtlvl(jlvlpoc(iogrp),LVL_POC(iogrp),rnacc*1e3,0.,cmpflg, & - & 'detoclvl','Detritus',' ','mol P m-3') - call wrtlvl(jlvlcalc(iogrp),LVL_CALC(iogrp),rnacc*1e3,0.,cmpflg, & - & 'calclvl','CaCO3 shells',' ','mol C m-3') - call wrtlvl(jlvlopal(iogrp),LVL_OPAL(iogrp),rnacc*1e3,0.,cmpflg, & - & 'opallvl','Opal shells',' ','mol Si m-3') - call wrtlvl(jlvliron(iogrp),LVL_IRON(iogrp),rnacc*1e3,0.,cmpflg, & - & 'dfelvl','Dissolved iron',' ','mol Fe m-3') - call wrtlvl(jlvlphosy(iogrp),LVL_PHOSY(iogrp),rnacc*1e3/dtbgc,0., & - & cmpflg,'pplvl','Primary production',' ','mol C m-3 s-1') - call wrtlvl(jlvlco3(iogrp),LVL_CO3(iogrp),rnacc*1e3,0.,cmpflg, & - & 'co3lvl','Carbonate ions',' ','mol C m-3') - call wrtlvl(jlvlph(iogrp),LVL_PH(iogrp),-1.,0.,cmpflg, & - & 'phlvl','pH',' ','-log10([H+])') - call wrtlvl(jlvlomegaa(iogrp),LVL_OMEGAA(iogrp),rnacc,0.,cmpflg, & - & 'omegaalvl','OmegaA',' ','-') - call wrtlvl(jlvlomegac(iogrp),LVL_OMEGAC(iogrp),rnacc,0.,cmpflg, & - & 'omegaclvl','OmegaC',' ','-') - call wrtlvl(jlvln2o(iogrp),LVL_N2O(iogrp),rnacc*1e3,0.,cmpflg, & - & 'n2olvl','N2O',' ','mol N2O m-3') - call wrtlvl(jlvlprefo2(iogrp),LVL_PREFO2(iogrp),rnacc*1e3,0., & - & cmpflg,'p_o2lvl','Preformed oxygen',' ','mol O2 m-3') - call wrtlvl(jlvlo2sat(iogrp),LVL_O2SAT(iogrp),rnacc*1e3,0., & - & cmpflg,'satoxylvl','Saturated oxygen',' ','mol O2 m-3') - call wrtlvl(jlvlprefpo4(iogrp),LVL_PREFPO4(iogrp),rnacc*1e3,0., & - & cmpflg,'p_po4lvl','Preformed phosphorus',' ','mol P m-3') - call wrtlvl(jlvlprefalk(iogrp),LVL_PREFALK(iogrp),rnacc*1e3,0., & - & cmpflg, 'p_talklvl','Preformed alkalinity',' ','eq m-3') - call wrtlvl(jlvlprefdic(iogrp),LVL_PREFDIC(iogrp),rnacc*1e3,0., & - & cmpflg, 'p_diclvl','Preformed DIC',' ','mol C m-3') - call wrtlvl(jlvldicsat(iogrp),LVL_DICSAT(iogrp),rnacc*1e3,0., & - & cmpflg, 'sat_diclvl','Saturated DIC',' ','mol C m-3') + call wrtlvl(jlvldic(iogrp), LVL_DIC(iogrp), rnacc*1e3, 0.,cmpflg,'dissiclvl') + call wrtlvl(jlvlalkali(iogrp), LVL_ALKALI(iogrp), rnacc*1e3, 0.,cmpflg,'talklvl') + call wrtlvl(jlvlphosph(iogrp), LVL_PHOSPH(iogrp), rnacc*1e3, 0.,cmpflg,'po4lvl') + call wrtlvl(jlvloxygen(iogrp), LVL_OXYGEN(iogrp), rnacc*1e3, 0.,cmpflg,'o2lvl') + call wrtlvl(jlvlano3(iogrp), LVL_ANO3(iogrp), rnacc*1e3, 0.,cmpflg,'no3lvl') + call wrtlvl(jlvlsilica(iogrp), LVL_SILICA(iogrp), rnacc*1e3, 0.,cmpflg,'silvl') + call wrtlvl(jlvldoc(iogrp), LVL_DOC(iogrp), rnacc*1e3, 0.,cmpflg,'dissoclvl') + call wrtlvl(jlvlphyto(iogrp), LVL_PHYTO(iogrp), rnacc*1e3, 0.,cmpflg,'phyclvl') + call wrtlvl(jlvlgrazer(iogrp), LVL_GRAZER(iogrp), rnacc*1e3, 0.,cmpflg,'zooclvl') + call wrtlvl(jlvlpoc(iogrp), LVL_POC(iogrp), rnacc*1e3, 0.,cmpflg,'detoclvl') + call wrtlvl(jlvlcalc(iogrp), LVL_CALC(iogrp), rnacc*1e3, 0.,cmpflg,'calclvl') + call wrtlvl(jlvlopal(iogrp), LVL_OPAL(iogrp), rnacc*1e3, 0.,cmpflg,'opallvl') + call wrtlvl(jlvliron(iogrp), LVL_IRON(iogrp), rnacc*1e3, 0.,cmpflg,'dfelvl') + call wrtlvl(jlvlphosy(iogrp), LVL_PHOSY(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'pplvl') + call wrtlvl(jlvlco3(iogrp), LVL_CO3(iogrp), rnacc*1e3, 0.,cmpflg,'co3lvl') + call wrtlvl(jlvlph(iogrp), LVL_PH(iogrp), -1., 0.,cmpflg,'phlvl') + call wrtlvl(jlvlomegaa(iogrp), LVL_OMEGAA(iogrp), rnacc, 0.,cmpflg,'omegaalvl') + call wrtlvl(jlvlomegac(iogrp), LVL_OMEGAC(iogrp), rnacc, 0.,cmpflg,'omegaclvl') + call wrtlvl(jlvln2o(iogrp), LVL_N2O(iogrp), rnacc*1e3, 0.,cmpflg,'n2olvl') + call wrtlvl(jlvlprefo2(iogrp), LVL_PREFO2(iogrp), rnacc*1e3, 0.,cmpflg,'p_o2lvl') + call wrtlvl(jlvlo2sat(iogrp), LVL_O2SAT(iogrp), rnacc*1e3, 0.,cmpflg,'satoxylvl') + call wrtlvl(jlvlprefpo4(iogrp), LVL_PREFPO4(iogrp), rnacc*1e3, 0.,cmpflg,'p_po4lvl') + call wrtlvl(jlvlprefalk(iogrp), LVL_PREFALK(iogrp), rnacc*1e3, 0.,cmpflg,'p_talklvl') + call wrtlvl(jlvlprefdic(iogrp), LVL_PREFDIC(iogrp), rnacc*1e3, 0.,cmpflg,'p_diclvl') + call wrtlvl(jlvldicsat(iogrp), LVL_DICSAT(iogrp), rnacc*1e3, 0.,cmpflg,'sat_diclvl') #ifdef cisonew - call wrtlvl(jlvldic13(iogrp),LVL_DIC13(iogrp),rnacc*1.e3, & - & 0.,cmpflg,'dissic13lvl','Dissolved C13',' ','mol 13C m-3') - call wrtlvl(jlvldic14(iogrp),LVL_DIC14(iogrp),rnacc*1.e3*c14fac, & - & 0.,cmpflg,'dissic14lvl','Dissolved C14',' ','mol 14C m-3') - call wrtlvl(jlvld13c(iogrp),LVL_D13C(iogrp),rnacc, & - & 0.,cmpflg,'delta13clvl','delta13C of DIC',' ','permil') - call wrtlvl(jlvld14c(iogrp),LVL_D14C(iogrp),rnacc, & - & 0.,cmpflg,'delta14clvl','delta14C of DIC',' ','permil') - call wrtlvl(jlvlbigd14c(iogrp),LVL_BIGD14C(iogrp),rnacc, & - & 0.,cmpflg,'bigdelta14clvl','big delta14C of DIC',' ','permil') - call wrtlvl(jlvlpoc13(iogrp),LVL_POC13(iogrp),rnacc*1e3, & - & 0.,cmpflg,'detoc13lvl','Detritus13',' ','mol P m-3') - call wrtlvl(jlvldoc13(iogrp),LVL_DOC13(iogrp),rnacc*1e3, & - & 0.,cmpflg,'dissoc13lvl','Dissolved organic carbon13',' ', & - & 'mol P m-3') - call wrtlvl(jlvlcalc13(iogrp),LVL_CALC13(iogrp),rnacc*1e3, & - & 0.,cmpflg,'calc13lvl','Ca13CO3 shells',' ','mol 13C m-3') - call wrtlvl(jlvlphyto13(iogrp),LVL_PHYTO13(iogrp),rnacc*1e3, & - & 0.,cmpflg,'phyc13lvl','Phytoplankton13',' ','mol P m-3') - call wrtlvl(jlvlgrazer13(iogrp),LVL_GRAZER13(iogrp),rnacc*1e3, & - & 0.,cmpflg,'zooc13lvl','Zooplankton13',' ','mol P m-3') + call wrtlvl(jlvldic13(iogrp), LVL_DIC13(iogrp), rnacc*1.e3, 0.,cmpflg,'dissic13lvl') + call wrtlvl(jlvldic14(iogrp), LVL_DIC14(iogrp), rnacc*1.e3*c14fac,0.,cmpflg,'dissic14lvl') + call wrtlvl(jlvld13c(iogrp), LVL_D13C(iogrp), rnacc, 0.,cmpflg,'delta13clvl') + call wrtlvl(jlvld14c(iogrp), LVL_D14C(iogrp), rnacc, 0.,cmpflg,'delta14clvl') + call wrtlvl(jlvlbigd14c(iogrp), LVL_BIGD14C(iogrp), rnacc, 0.,cmpflg,'bigdelta14clvl') + call wrtlvl(jlvlpoc13(iogrp), LVL_POC13(iogrp), rnacc*1e3, 0.,cmpflg,'detoc13lvl') + call wrtlvl(jlvldoc13(iogrp), LVL_DOC13(iogrp), rnacc*1e3, 0.,cmpflg,'dissoc13lvl') + call wrtlvl(jlvlcalc13(iogrp), LVL_CALC13(iogrp), rnacc*1e3, 0.,cmpflg,'calc13lvl') + call wrtlvl(jlvlphyto13(iogrp), LVL_PHYTO13(iogrp), rnacc*1e3, 0.,cmpflg,'phyc13lvl') + call wrtlvl(jlvlgrazer13(iogrp), LVL_GRAZER13(iogrp), rnacc*1e3, 0.,cmpflg,'zooc13lvl') #endif #ifdef AGG - call wrtlvl(jlvlnos(iogrp),LVL_NOS(iogrp), & - & rnacc,0.,cmpflg,'noslvl', & - & 'Marine snow aggregates per cm^3 sea water',' ','1/cm^3') - call wrtlvl(jlvlwphy(iogrp),LVL_WPHY(iogrp), & - & rnacc,0.,cmpflg,'wphylvl', & - & 'Av. mass sinking speed of marine snow',' ','m/day') - call wrtlvl(jlvlwnos(iogrp),LVL_WNOS(iogrp), & - & rnacc,0.,cmpflg,'wnoslvl', & - & 'Av. number sinking speed of marine snow',' ','m/day') - call wrtlvl(jlvleps(iogrp),LVL_EPS(iogrp), & - & rnacc,0.,cmpflg,'epslvl', & - & 'Av. size distribution exponent',' ','-') - call wrtlvl(jlvlasize(iogrp),LVL_ASIZE(iogrp), & - & rnacc,0.,cmpflg,'asizelvl', & - & 'Av. size of marine snow aggregates',' ','nb. of cells') + call wrtlvl(jlvlnos(iogrp), LVL_NOS(iogrp), rnacc, 0.,cmpflg,'noslvl') + call wrtlvl(jlvlwphy(iogrp), LVL_WPHY(iogrp), rnacc, 0.,cmpflg,'wphylvl') + call wrtlvl(jlvlwnos(iogrp), LVL_WNOS(iogrp), rnacc, 0.,cmpflg,'wnoslvl') + call wrtlvl(jlvleps(iogrp), LVL_EPS(iogrp), rnacc, 0.,cmpflg,'epslvl') + call wrtlvl(jlvlasize(iogrp), LVL_ASIZE(iogrp), rnacc, 0.,cmpflg,'asizelvl') #endif #ifdef CFC - call wrtlvl(jlvlcfc11(iogrp),LVL_CFC11(iogrp),rnacc*1e3,0.,cmpflg, & - & 'cfc11lvl','CFC-11',' ','mol cfc11 m-3') - call wrtlvl(jlvlcfc12(iogrp),LVL_CFC12(iogrp),rnacc*1e3,0.,cmpflg, & - & 'cfc12lvl','CFC-12',' ','mol cfc12 m-3') - call wrtlvl(jlvlsf6(iogrp),LVL_SF6(iogrp),rnacc*1e3,0.,cmpflg, & - & 'sf6lvl','SF-6',' ','mol sf6 m-3') + call wrtlvl(jlvlcfc11(iogrp), LVL_CFC11(iogrp), rnacc*1e3, 0.,cmpflg,'cfc11lvl') + call wrtlvl(jlvlcfc12(iogrp), LVL_CFC12(iogrp), rnacc*1e3, 0.,cmpflg,'cfc12lvl') + call wrtlvl(jlvlsf6(iogrp), LVL_SF6(iogrp), rnacc*1e3, 0.,cmpflg,'sf6lvl') #endif #ifdef natDIC - call wrtlvl(jlvlnatco3(iogrp),LVL_NATCO3(iogrp), & - & rnacc*1e3,0.,cmpflg,'natco3lvl', & - & 'Natural carbonate ions',' ','mol C m-3') - call wrtlvl(jlvlnatalkali(iogrp),LVL_NATALKALI(iogrp), & - & rnacc*1e3,0.,cmpflg,'nattalklvl', & - & 'Natural alkalinity',' ','eq m-3') - call wrtlvl(jlvlnatdic(iogrp),LVL_NATDIC(iogrp), & - & rnacc*1e3,0.,cmpflg,'natdissiclvl', & - & 'Natural dissolved inorganic carbon',' ','mol C m-3') - call wrtlvl(jlvlnatcalc(iogrp),LVL_NATCALC(iogrp), & - & rnacc*1e3,0.,cmpflg,'natcalclvl', & - & 'Natural CaCO3 shells',' ','mol C m-3') - call wrtlvl(jlvlnatph(iogrp),LVL_NATPH(iogrp),-1.,0.,cmpflg, & - & 'natphlvl','Natural pH',' ','-log10([H+])') - call wrtlvl(jlvlnatomegaa(iogrp),LVL_NATOMEGAA(iogrp), & - & rnacc,0.,cmpflg,'natomegaalvl', & - & 'Natural OmegaA',' ','-') - call wrtlvl(jlvlnatomegac(iogrp),LVL_NATOMEGAC(iogrp), & - & rnacc,0.,cmpflg,'natomegaclvl', & - & 'Natural OmegaC',' ','-') + call wrtlvl(jlvlnatco3(iogrp), LVL_NATCO3(iogrp), rnacc*1e3, 0.,cmpflg,'natco3lvl') + call wrtlvl(jlvlnatalkali(iogrp),LVL_NATALKALI(iogrp),rnacc*1e3, 0.,cmpflg,'nattalklvl') + call wrtlvl(jlvlnatdic(iogrp), LVL_NATDIC(iogrp), rnacc*1e3, 0.,cmpflg,'natdissiclvl') + call wrtlvl(jlvlnatcalc(iogrp), LVL_NATCALC(iogrp), rnacc*1e3, 0.,cmpflg,'natcalclvl') + call wrtlvl(jlvlnatph(iogrp), LVL_NATPH(iogrp), -1., 0.,cmpflg,'natphlvl') + call wrtlvl(jlvlnatomegaa(iogrp),LVL_NATOMEGAA(iogrp),rnacc, 0.,cmpflg,'natomegaalvl') + call wrtlvl(jlvlnatomegac(iogrp),LVL_NATOMEGAC(iogrp),rnacc, 0.,cmpflg,'natomegaclvl') #endif #ifdef BROMO - call wrtlvl(jlvlbromo(iogrp),LVL_BROMO(iogrp),rnacc*1e3,0., & - & cmpflg,'bromolvl','Bromoform',' ','mol CHBr3 m-3') + call wrtlvl(jlvlbromo(iogrp), LVL_BROMO(iogrp), rnacc*1e3, 0.,cmpflg,'bromolvl') #endif ! --- Store sediment fields #ifndef sedbypass - call wrtsdm(jpowaic(iogrp),SDM_POWAIC(iogrp),rnacc*1e3,0.,cmpflg, & - & 'powdic','PoWa DIC',' ','mol C m-3') - call wrtsdm(jpowaal(iogrp),SDM_POWAAL(iogrp),rnacc*1e3,0.,cmpflg, & - & 'powalk','PoWa alkalinity',' ','eq m-3') - call wrtsdm(jpowaph(iogrp),SDM_POWAPH(iogrp),rnacc*1e3,0.,cmpflg, & - & 'powpho','PoWa phosphorus',' ','mol P m-3') - call wrtsdm(jpowaox(iogrp),SDM_POWAOX(iogrp),rnacc*1e3,0.,cmpflg, & - & 'powox','PoWa oxygen',' ','mol O2 m-3') - call wrtsdm(jpown2(iogrp),SDM_POWN2(iogrp), rnacc*1e3,0.,cmpflg, & - & 'pown2','PoWa N2',' ','mol N2 m-3') - call wrtsdm(jpowno3(iogrp),SDM_POWNO3(iogrp),rnacc*1e3,0.,cmpflg, & - & 'powno3','PoWa nitrate',' ','mol N m-3') - call wrtsdm(jpowasi(iogrp),SDM_POWASI(iogrp),rnacc*1e3,0.,cmpflg, & - & 'powsi','PoWa silicate',' ','mol Si m-3') - call wrtsdm(jssso12(iogrp),SDM_SSSO12(iogrp),rnacc*1e3,0.,cmpflg, & - & 'ssso12','Sediment detritus',' ','mol P m-3') - call wrtsdm(jssssil(iogrp),SDM_SSSSIL(iogrp),rnacc*1e3,0.,cmpflg, & - & 'ssssil','Sediment silicate',' ','mol Si m-3') - call wrtsdm(jsssc12(iogrp),SDM_SSSC12(iogrp),rnacc*1e3,0.,cmpflg, & - & 'sssc12','Sediment CaCO3',' ','mol C m-3') - call wrtsdm(jssster(iogrp),SDM_SSSTER(iogrp),rnacc,0.,cmpflg, & - & 'ssster','Sediment clay',' ','kg m-3') + call wrtsdm(jpowaic(iogrp), SDM_POWAIC(iogrp), rnacc*1e3, 0.,cmpflg,'powdic') + call wrtsdm(jpowaal(iogrp), SDM_POWAAL(iogrp), rnacc*1e3, 0.,cmpflg,'powalk') + call wrtsdm(jpowaph(iogrp), SDM_POWAPH(iogrp), rnacc*1e3, 0.,cmpflg,'powpho') + call wrtsdm(jpowaox(iogrp), SDM_POWAOX(iogrp), rnacc*1e3, 0.,cmpflg,'powox') + call wrtsdm(jpown2(iogrp), SDM_POWN2(iogrp), rnacc*1e3, 0.,cmpflg,'pown2') + call wrtsdm(jpowno3(iogrp), SDM_POWNO3(iogrp), rnacc*1e3, 0.,cmpflg,'powno3') + call wrtsdm(jpowasi(iogrp), SDM_POWASI(iogrp), rnacc*1e3, 0.,cmpflg,'powsi') + call wrtsdm(jssso12(iogrp), SDM_SSSO12(iogrp), rnacc*1e3, 0.,cmpflg,'ssso12') + call wrtsdm(jssssil(iogrp), SDM_SSSSIL(iogrp), rnacc*1e3, 0.,cmpflg,'ssssil') + call wrtsdm(jsssc12(iogrp), SDM_SSSC12(iogrp), rnacc*1e3, 0.,cmpflg,'sssc12') + call wrtsdm(jssster(iogrp), SDM_SSSTER(iogrp), rnacc, 0.,cmpflg,'ssster') ! --- Store sediment burial fields - call wrtbur(jburssso12(iogrp),BUR_SSSO12(iogrp),rnacc*1e3,0., & - & cmpflg,'buro12','Burial org carbon',' ','mol P m-2') - call wrtbur(jbursssc12(iogrp),BUR_SSSC12(iogrp),rnacc*1e3,0., & - & cmpflg,'burc12','Burial CaCO3',' ','mol C m-2') - call wrtbur(jburssssil(iogrp),BUR_SSSSIL(iogrp),rnacc*1e3,0., & - & cmpflg,'bursil','Burial silicate',' ','mol Si m-2') - call wrtbur(jburssster(iogrp),BUR_SSSTER(iogrp),rnacc,0., & - & cmpflg,'burter','Burial clay',' ','kg m-2') + call wrtbur(jburssso12(iogrp), BUR_SSSO12(iogrp), rnacc*1e3, 0.,cmpflg,'buro12') + call wrtbur(jbursssc12(iogrp), BUR_SSSC12(iogrp), rnacc*1e3, 0.,cmpflg,'burc12') + call wrtbur(jburssssil(iogrp), BUR_SSSSIL(iogrp), rnacc*1e3, 0.,cmpflg,'bursil') + call wrtbur(jburssster(iogrp), BUR_SSSTER(iogrp), rnacc, 0.,cmpflg,'burter') #endif ! --- close netcdf file From 076f8ff23408029fbad622a0c3f2bf7b8a376f76 Mon Sep 17 00:00:00 2001 From: TimotheeBrgs Date: Mon, 23 Jan 2023 15:49:35 +0100 Subject: [PATCH 249/366] Add linear ramping-up scenario for ocean alkalinisation --- hamocc/mo_read_oafx.F90 | 42 +++++++++++++++++++++++++++++++++++------ 1 file changed, 36 insertions(+), 6 deletions(-) diff --git a/hamocc/mo_read_oafx.F90 b/hamocc/mo_read_oafx.F90 index e3a0f934..d6f2cb1b 100644 --- a/hamocc/mo_read_oafx.F90 +++ b/hamocc/mo_read_oafx.F90 @@ -49,6 +49,11 @@ module mo_read_oafx ! surface ocean between 60S and 70N (no input file needed) ! -'const_0p56': constant alkalinity flux of 0.56 Pmol yr-1 applied to the ! surface ocean between 60S and 70N (no input file needed) +! -'ramp': ramping-up alkalinity flux from 0 Pmol yr-1 in 2025 to +! 0.135 Pmol yr-1 in 2035 and onward, applied to the surface +! ocean between 60S and 70N (no input file needed) +! From G.Tran: 4279324154000 umol/s *3600 *24 *365 *1e-15 +! *1e-6 = 0.135 Pmol yr-1 ! ! ! -subroutine ini_read_oafx @@ -77,6 +82,9 @@ module mo_read_oafx ! surface ocean (assumed to be between 60S and 70N) ! const_0p56 Homogeneous addition of 0.56 Pmol ALK/yr-1 over the ice-free ! surface ocean (assumed to be between 60S and 70N) + ! ramp Linear increase of homogeneous addition of 0 to 0.135 Pmol + ! ALK/yr-1 from 2025 to 2035 over the ice-free surface ocean + ! (assumed to be between 60S and 70N) ! real, parameter :: addalk_0p14 = 0.14 ! Pmol alkalinity/yr added in the real, parameter :: addalk_0p56 = 0.56 ! 'const_0p14' and 'const_0p56' @@ -84,6 +92,9 @@ module mo_read_oafx real, parameter :: cdrmip_latmax = 70.0 ! Min and max latitude where real, parameter :: cdrmip_latmin = -60.0 ! alkalinity is added according ! to the CDRMIP protocol + real, parameter :: addalk_ramp = 0.135 ! Max Pmol alkalinity/yr added + integer, parameter :: ramp_start = 2025 ! in 2035 in the 'ramp' scenario, + integer, parameter :: ramp_end = 2035 ! starting at 0 Pmol/yr in 2025. logical, save :: lini = .false. @@ -147,10 +158,8 @@ subroutine ini_read_oafx(kpie,kpje,pdlxp,pdlyp,pglat,omask) write(io_stdo_bgc,*)' ' endif - !-------------------------------- - ! Scenarios of constant fluxes - !-------------------------------- - if( trim(oalkscen)=='const_0p14' .or. trim(oalkscen)=='const_0p56' ) then + if( trim(oalkscen)=='const_0p14' .or. trim(oalkscen)=='const_0p56' .or. & + trim(oalkscen)=='ramp' ) then if(mnproc.eq.1) then write(io_stdo_bgc,*)'Using alkalinization scenario ', trim(oalkscen) @@ -183,8 +192,10 @@ subroutine ini_read_oafx(kpie,kpje,pdlxp,pdlyp,pglat,omask) if( trim(oalkscen)=='const_0p14') then addalk_tot = addalk_0p14 - else + else if( trim(oalkscen)=='const_0p56') then addalk_tot = addalk_0p56 + else + addalk_tot = addalk_ramp endif ! Calculate alkalinity flux (kmol m^2 yr-1) to be applied @@ -193,6 +204,9 @@ subroutine ini_read_oafx(kpie,kpje,pdlxp,pdlyp,pglat,omask) write(io_stdo_bgc,*)' ' write(io_stdo_bgc,*)' applying alkalinity flux of ', avflx, ' kmol m-2 yr-1' write(io_stdo_bgc,*)' over an area of ', ztotarea , ' m2' + if( trim(oalkscen)=='ramp' ) then + write(io_stdo_bgc,*)' ramping-up from ', ramp_start, ' to ', ramp_end + endif endif do j=1,kpje @@ -248,14 +262,16 @@ subroutine get_oafx(kpie,kpje,kplyear,kplmon,omask,oafx) ! *REAL* *oaflx* - alkalinization flux [kmol m-2 yr-1] ! !****************************************************************************** - use mod_xc, only: xchalt + use mod_xc, only: xchalt,mnproc use mo_control_bgc, only: io_stdo_bgc,do_oalk + use mod_time, only: nday_of_year implicit none integer, intent(in) :: kpie,kpje,kplyear,kplmon real, intent(in) :: omask(kpie,kpje) real, intent(out) :: oafx(kpie,kpje) + integer :: current_day ! local variables integer :: i,j @@ -272,6 +288,20 @@ subroutine get_oafx(kpie,kpje,kplyear,kplmon,omask,oafx) oafx(:,:) = oalkflx(:,:) + !-------------------------------- + ! Scenario of ramping-up fluxes + !-------------------------------- + elseif(trim(oalkscen)=='ramp' ) then + + if(kplyear.lt.ramp_start ) then + oafx(:,:) = 0.0 + elseif(kplyear.ge.ramp_end ) then + oafx(:,:) = oalkflx(:,:) + else + current_day = (kplyear-ramp_start)*365+nday_of_year + oafx(:,:) = oalkflx(:,:) * current_day / ((ramp_end-ramp_start)*365) + endif + else write(io_stdo_bgc,*) '' From 9c31d4a2f3b86ddf35ec63f25d57c3b8200596c3 Mon Sep 17 00:00:00 2001 From: Tomas Torsvik <43031053+TomasTorsvik@users.noreply.github.com> Date: Wed, 25 Jan 2023 22:18:42 +0100 Subject: [PATCH 250/366] Import get_bgc_namelist only in subroutine where it is needed. (#225) --- hamocc/mo_bgcmean.F90 | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/hamocc/mo_bgcmean.F90 b/hamocc/mo_bgcmean.F90 index a0ca5035..6a367ae1 100644 --- a/hamocc/mo_bgcmean.F90 +++ b/hamocc/mo_bgcmean.F90 @@ -58,7 +58,6 @@ MODULE mo_bgcmean use mod_nctools, only: ncpack,nccomp,nccopa,ncwrtr use netcdf, only: nf90_fill_double use mo_param1_bgc, only: ks - use mo_control_bgc, only: get_bgc_namelist IMPLICIT NONE @@ -514,7 +513,7 @@ MODULE mo_bgcmean SUBROUTINE ALLOC_MEM_BGCMEAN(kpie,kpje,kpke) - use mo_control_bgc, only: io_stdo_bgc,bgc_namelist + use mo_control_bgc, only: io_stdo_bgc,bgc_namelist,get_bgc_namelist IMPLICIT NONE From e5eb6319c1eef71702542e6bd95c2be13792c60e Mon Sep 17 00:00:00 2001 From: jmaerz <92309038+jmaerz@users.noreply.github.com> Date: Wed, 25 Jan 2023 22:46:46 +0100 Subject: [PATCH 251/366] Merge master into feature-hamocc_beyond-CMIP6 branch (#226) MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * Dynamic mapping of pore water tracers to ocean tracers (#192) * Initial restructuring of sediment-related tracer declaration and initialization * Introducing mapping function * Remove unncessary comments * Fixed diagnostics bug and updated index naming * Added initial support for NUOPC driver. * Lon-lat variable sediment porosity (#189) Introducing a static 3D sediment porosity field that can be optionally read in with effects on molecular pore water diffusion and shifting. * Added wave forcing fields. * Renamed folder for MCT driver. * Moved MCT specific file from drivers/cpl_share/ to drivers/mct/. * Rename drivers/mct/mod_swtfrz.F to drivers/mct/mod_swtfrz.F90. * Rewrite to drivers/mct/mod_swtfrz.F90 to free format Fortran. * Remove redundant definition of kOBL. * Redefine kOBL, cast as integer * Fixing variable sediment porosity - field initialization in case of `sedbypass=true` (#198) * Removing bodensed - Initialization of sediment parameters and fields now in mo_sedmnt * Hamocc hybrid coord2 (#179) Make the surface mixed layer depth fractional index `hOBL` available for use in iHAMOCC, and adjust the internal iHAMOCC index `kmle` according to `hOBL`. Default value `kmle = 2` is retained for consistency with isopycnic coordinates. * Fix porosity read (#201) * Fixing the reading of variable porosity input field in preparation for the NorESM 2.0.6 release Cherry-picked from private Ncycleprivate branch 0d56930e2fdd62caba964d375b57304942568926 * Provide number of layers (3rd dim) via ks and not hard-coded * minor clean-up * Correct unit of diagnostic variable dp_trc. * Made conservation and checksum diagnostics selectable by namelist options (default off). * pCO2, Piston velocity and solubility output (#202) * add pCO2m (moist), CO2 piston velocity and solubility output - caution: kwco2 piston velocity now really holds only piston velocity (and not times solubility) * Bugfix pnetcdf (#208) * Add variables used by PNETCDF to explicit use staements. * Move implicit none statments * update explicit use statement for pnetcdf * fixed units and renamed calcium burial to CaCO3 burial (#212) Fixed sediment clay units. * Add option for surface pH output (#221) * Remove unused parameters in wrt* subroutine calls in ncout_hamocc.F90 * Import get_bgc_namelist only in subroutine where it is needed. (#225) Co-authored-by: Mats Bentsen Co-authored-by: Tomas Torsvik Co-authored-by: Tomas Torsvik <43031053+TomasTorsvik@users.noreply.github.com> Co-authored-by: Jörg Schwinger --- cime_config/buildnml | 8 +- hamocc/accfields.F90 | 11 +- hamocc/mo_bgcmean.F90 | 129 +++----- hamocc/ncout_hamocc.F90 | 685 +++++++++++++--------------------------- 4 files changed, 277 insertions(+), 556 deletions(-) diff --git a/cime_config/buildnml b/cime_config/buildnml index 2507d13d..57cc45eb 100755 --- a/cime_config/buildnml +++ b/cime_config/buildnml @@ -422,6 +422,7 @@ set SRF_ALKALI = '4, 2, 2' set SRF_SILICA = '0, 2, 2' set SRF_DIC = '4, 2, 2' set SRF_PHYTO = '4, 2, 2' +set SRF_PH = '0, 2, 2' set SRF_EXPORT = '0, 2, 2' set SRF_EXPOSI = '0, 2, 2' set SRF_EXPOCA = '0, 2, 2' @@ -446,6 +447,7 @@ set SRF_ATMO2 = '0, 2, 2' set SRF_ATMN2 = '0, 2, 2' set SRF_NATDIC = '0, 2, 2' set SRF_NATALKALI = '0, 2, 2' +set SRF_NATPH = '0, 2, 2' set SRF_NATPCO2 = '0, 2, 2' set SRF_NATCO2FX = '0, 2, 2' set SRF_CO213FXD = '0, 2, 2' @@ -1535,8 +1537,10 @@ cat >>! $RUNDIR/ocn_in$inststr << EOF ! IRON - Dissolved iron (dfe) [mol Fe m-3] ! SILICA - Silicate (si) [mol Si m-3] ! PHYTO - Phytoplankton (phyc) [mol C m-3] +! PH - pH (ph) [-log10([h+])] ! NATDIC - Natural dissolved carbon (natdissic) [mol C m-3] ! NATALKALI - Natural alkalinity (nattalk) [eq m-3] +! NATPH - Natural pH (natph) [-log10([h+])] ! ! Other 3d tracer or diagnostic variables (LYR or LVL) ! DP - Layer thickness (pddpo) [m] @@ -1554,14 +1558,12 @@ cat >>! $RUNDIR/ocn_in$inststr << EOF ! PHOSY - Primary production (pp) [mol C m-3 s-1] ! CO3 - Carbonate ions (co3) [mol C m-3] ! N2O - Nitrous oxide concentration [mol N2O m-3] -! PH - pH (ph) [-log10([h+])] ! OMEGAA - Aragonite saturation state (omegaa) [1] ! OMEGAC - Calcite saturation state (omegac) [1] ! NATDIC - Natural dissolved carbon (natdissic) [mol C m-3] ! NATALKALI - Natural alkalinity (nattalk) [eq m-3] ! NATCO3 - Natural carbonate ion concentration (natco3) [mol C m-3] ! NATCALC - Natural CaCO3 shells (natcalc) [mol C m-3] -! NATPH - Natural pH (natph) [-log10([h+])] ! NATOMEGAA - Natural aragonite saturation state (natomegaa) [1] ! NATOMEGAC - Natural calcite saturation state (natomegac) [1] ! DIC13 - Dissolved C13 (dissic13) [mol C m-3] @@ -1668,6 +1670,7 @@ cat >>! $RUNDIR/ocn_in$inststr << EOF SRF_SILICA = $SRF_SILICA SRF_DIC = $SRF_DIC SRF_PHYTO = $SRF_PHYTO + SRF_PH = $SRF_PH SRF_EXPORT = $SRF_EXPORT SRF_EXPOSI = $SRF_EXPOSI SRF_EXPOCA = $SRF_EXPOCA @@ -1692,6 +1695,7 @@ cat >>! $RUNDIR/ocn_in$inststr << EOF SRF_ATMN2 = $SRF_ATMN2 SRF_NATDIC = $SRF_NATDIC SRF_NATALKALI = $SRF_NATALKALI + SRF_NATPH = $SRF_NATPH SRF_NATPCO2 = $SRF_NATPCO2 SRF_NATCO2FX = $SRF_NATCO2FX SRF_CO213FXD = $SRF_CO213FXD diff --git a/hamocc/accfields.F90 b/hamocc/accfields.F90 index a83fe953..d27dba68 100644 --- a/hamocc/accfields.F90 +++ b/hamocc/accfields.F90 @@ -65,10 +65,9 @@ SUBROUTINE ACCFIELDS(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask) & jlvlprefo2,jlvlprefpo4,jlvlsf6,jlvlsilica,jlvlwnos,jlvlwphy,jn2flux,jn2o,jn2oflux,jn2ofx, & & jprorca,jprcaca,jsilpro,jpodiic,jpodial,jpodiph,jpodiox,jpodin2,jpodino3,jpodisi,jndep, & & jniflux,jnos,jo2flux,jo2sat,jomegaa,jomegac,jopal,joxflux,joxygen,jpco2,jpco2m,jkwco2khm,jco2khm, & - & jco2kh,jph,jphosph,jphosy,jphyto, & - & jpoc,jprefalk,jprefdic,jprefo2,jprefpo4,jsilica,jsrfalkali,jsrfano3,jsrfdic,jsrfiron,jsrfoxygen, & - & jsrfphosph,jsrfphyto,jsrfsilica,jwnos,jwphy,nbgc,nacc_bgc,bgcwrt,glb_inventory,bgct2d,acclvl, & - & acclyr,accsrf,bgczlv + & jco2kh,jph,jphosph,jphosy,jphyto,jpoc,jprefalk,jprefdic,jprefo2,jprefpo4,jsilica,jsrfalkali, & + & jsrfano3,jsrfdic,jsrfiron,jsrfoxygen,jsrfphosph,jsrfphyto,jsrfsilica,jsrfph,jwnos,jwphy, & + & nbgc,nacc_bgc,bgcwrt,glb_inventory,bgct2d,acclvl,acclyr,accsrf,bgczlv use mo_control_bgc, only: io_stdo_bgc use mo_param1_bgc, only: ialkali,ian2o,iano3,iatmco2,iatmdms,iatmn2,iatmn2o,iatmo2,icalc,idet,idms,idicsat,idoc,iiron,iopal,& & ioxygen,iphosph,iphy,iprefalk,iprefdic,iprefpo4,iprefo2,isco212,isilica,izoo, & @@ -100,7 +99,7 @@ SUBROUTINE ACCFIELDS(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask) use mo_param1_bgc, only: iatmnco2,inatalkali,inatcalc,inatsco212 use mo_carbch, only: natco3,nathi,natomegaa,natomegac,natpco2d use mo_bgcmean, only: jlvlnatph,jnatalkali,jnatcalc,jnatco2fx,jnatco3,jnatdic,jnatomegaa,jnatomegac,jnatpco2,jnatph, & - & jsrfnatalk,jsrfnatdic + & jsrfnatalk,jsrfnatdic,jsrfnatph #endif #ifndef sedbypass use mo_param1_bgc, only: ipowaal,ipowaic,ipowaox,ipowaph,ipowasi,ipown2,ipowno3,isssc12,issso12,issssil,issster @@ -242,6 +241,7 @@ SUBROUTINE ACCFIELDS(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask) call accsrf(jsrfsilica,ocetra(1,1,1,isilica),omask,0) call accsrf(jsrfdic,ocetra(1,1,1,isco212),omask,0) call accsrf(jsrfphyto,ocetra(1,1,1,iphy),omask,0) + call accsrf(jsrfph,hi(1,1,1),omask,0) call accsrf(jdms,ocetra(1,1,1,idms),omask,0) call accsrf(jexport,expoor,omask,0) call accsrf(jexpoca,expoca,omask,0) @@ -256,6 +256,7 @@ SUBROUTINE ACCFIELDS(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask) call accsrf(jsrfnatdic,ocetra(1,1,1,inatsco212),omask,0) call accsrf(jsrfnatalk,ocetra(1,1,1,inatalkali),omask,0) call accsrf(jnatpco2,natpco2d,omask,0) + call accsrf(jsrfnatph,nathi(1,1,1),omask,0) #endif #ifdef BROMO call accsrf(jsrfbromo,ocetra(1,1,1,ibromo),omask,0) diff --git a/hamocc/mo_bgcmean.F90 b/hamocc/mo_bgcmean.F90 index 9bb44653..6a367ae1 100644 --- a/hamocc/mo_bgcmean.F90 +++ b/hamocc/mo_bgcmean.F90 @@ -55,10 +55,9 @@ MODULE mo_bgcmean !********************************************************************** use mod_xc, only: ii,jj,kk,idm,jdm,kdm,nbdy,ifp,isp,ilp,mnproc,ip use mod_dia, only: ddm,depthslev,depthslev_bnds,nstepinday,pbath - use mod_nctools, only:ncpack,nccomp,nccopa,ncwrtr + use mod_nctools, only: ncpack,nccomp,nccopa,ncwrtr use netcdf, only: nf90_fill_double use mo_param1_bgc, only: ks - use mo_control_bgc, only: get_bgc_namelist IMPLICIT NONE @@ -89,8 +88,9 @@ MODULE mo_bgcmean & SRF_SF6 =0 ,SRF_PHOSPH =0 ,SRF_OXYGEN =0 , & & SRF_IRON =0 ,SRF_ANO3 =0 ,SRF_ALKALI =0 , & & SRF_SILICA =0 ,SRF_DIC =0 ,SRF_PHYTO =0 , & + & SRF_PH =0 , & & SRF_NATDIC =0 ,SRF_NATALKALI =0 ,SRF_NATPCO2 =0 , & - & SRF_NATCO2FX =0 , & + & SRF_NATCO2FX =0 ,SRF_NATPH =0 , & & SRF_ATMBROMO =0 ,SRF_BROMO =0 ,SRF_BROMOFX =0 , & & INT_BROMOPRO =0 ,INT_BROMOUV =0 , & & INT_PHOSY =0 ,INT_NFIX =0 ,INT_DNIT =0 , & @@ -165,8 +165,9 @@ MODULE mo_bgcmean & SRF_SF6 ,SRF_PHOSPH ,SRF_OXYGEN , & & SRF_IRON ,SRF_ANO3 ,SRF_ALKALI , & & SRF_SILICA ,SRF_DIC ,SRF_PHYTO , & + & SRF_PH , & & SRF_NATDIC ,SRF_NATALKALI ,SRF_NATPCO2 , & - & SRF_NATCO2FX , & + & SRF_NATCO2FX ,SRF_NATPH , & & SRF_ATMBROMO ,SRF_BROMO ,SRF_BROMOFX , & & INT_BROMOPRO ,INT_BROMOUV , & & INT_PHOSY ,INT_NFIX ,INT_DNIT , & @@ -292,6 +293,7 @@ MODULE mo_bgcmean & jsrfsilica = 0 , & & jsrfdic = 0 , & & jsrfphyto = 0 , & + & jsrfph = 0 , & & jintphosy = 0 , & & jintnfix = 0 , & & jintdnit = 0 , & @@ -327,7 +329,8 @@ MODULE mo_bgcmean & jsrfnatdic = 0 , & & jsrfnatalk = 0 , & & jnatpco2 = 0 , & - & jnatco2fx = 0 + & jnatco2fx = 0 , & + & jsrfnatph = 0 INTEGER, DIMENSION(nbgcmax), SAVE :: & & jbromofx = 0 , & @@ -510,7 +513,7 @@ MODULE mo_bgcmean SUBROUTINE ALLOC_MEM_BGCMEAN(kpie,kpje,kpke) - use mo_control_bgc, only: io_stdo_bgc,bgc_namelist + use mo_control_bgc, only: io_stdo_bgc,bgc_namelist,get_bgc_namelist IMPLICIT NONE @@ -620,6 +623,8 @@ SUBROUTINE ALLOC_MEM_BGCMEAN(kpie,kpje,kpke) jsrfdic(n)=i_bsc_m2d*min(1,SRF_DIC(n)) IF (SRF_PHYTO(n).GT.0) i_bsc_m2d=i_bsc_m2d+1 jsrfphyto(n)=i_bsc_m2d*min(1,SRF_PHYTO(n)) + IF (SRF_PH(n).GT.0) i_bsc_m2d=i_bsc_m2d+1 + jsrfph(n)=i_bsc_m2d*min(1,SRF_PH(n)) IF (INT_PHOSY(n).GT.0) i_bsc_m2d=i_bsc_m2d+1 jintphosy(n)=i_bsc_m2d*min(1,INT_PHOSY(n)) IF (INT_NFIX(n).GT.0) i_bsc_m2d=i_bsc_m2d+1 @@ -705,6 +710,8 @@ SUBROUTINE ALLOC_MEM_BGCMEAN(kpie,kpje,kpke) jnatpco2(n)=i_bsc_m2d*min(1,SRF_NATPCO2(n)) IF (SRF_NATCO2FX(n).GT.0) i_bsc_m2d=i_bsc_m2d+1 jnatco2fx(n)=i_bsc_m2d*min(1,SRF_NATCO2FX(n)) + IF (SRF_NATPH(n).GT.0) i_bsc_m2d=i_bsc_m2d+1 + jsrfnatph(n)=i_bsc_m2d*min(1,SRF_NATPH(n)) #endif #ifdef BROMO IF (SRF_BROMO(n).GT.0) i_bsc_m2d=i_bsc_m2d+1 @@ -1608,8 +1615,7 @@ END SUBROUTINE finlyr - SUBROUTINE wrtsrf(pos,frmt,sfac,offs,cmpflg,vnm,vlngnm,vstdnm, & - & vunits) + SUBROUTINE wrtsrf(pos,frmt,sfac,offs,cmpflg,vnm) ! ! --- ------------------------------------------------------------------ ! --- Description: writes diagnostic 2d field to file @@ -1627,18 +1633,16 @@ SUBROUTINE wrtsrf(pos,frmt,sfac,offs,cmpflg,vnm,vlngnm,vstdnm, & ! --- int cmpflg (in) : compression flag; only wet points are ! --- written IF flag is set to 1 ! --- char vnm (in) : variable name used in nc-file -! --- char vlngnm (in) : variable long name (skipped IF ' ') -! --- char vstdnm (in) : variable standard name (skipped IF ' ') -! --- char vunits (in) : variable units (skipped IF ' ') ! --- ------------------------------------------------------------------ ! IMPLICIT NONE ! - REAL ::sfac,offs - INTEGER :: frmt,cmpflg,pos,n - CHARACTER(LEN=*) :: vnm,vlngnm,vstdnm,vunits + REAL, intent(in) :: sfac,offs + INTEGER, intent(in) :: frmt,cmpflg,pos + CHARACTER(LEN=*),intent(in) :: vnm ! - CHARACTER(LEN=100) :: dims + INTEGER :: n + CHARACTER(LEN=100) :: dims ! ! --- Check whether field should be written IF (pos.EQ.0 .OR. frmt.EQ.0) RETURN @@ -1678,20 +1682,12 @@ SUBROUTINE wrtsrf(pos,frmt,sfac,offs,cmpflg,vnm,vlngnm,vstdnm, & ELSE STOP 'unknown output format ' ENDIF -! -! --- Def.NE.attributes -! IF (len(trim(vunits)).NE.0) CALL ncattr('units',vunits) -! IF (len(trim(vlngnm)).NE.0) CALL ncattr('long_name',vlngnm) -! IF (len(trim(vstdnm)).NE.0) CALL ncattr('standard_name',vstdnm) -! CALL ncattr('coordinates','plon plat') -! CALL ncattr('cell_measures','area: parea') ! END SUBROUTINE wrtsrf - SUBROUTINE wrtlyr(pos,frmt,sfac,offs,cmpflg,vnm,vlngnm,vstdnm, & - & vunits) + SUBROUTINE wrtlyr(pos,frmt,sfac,offs,cmpflg,vnm) ! ! --- ------------------------------------------------------------------ ! --- Description: writes diagnostic layer field to file @@ -1709,18 +1705,16 @@ SUBROUTINE wrtlyr(pos,frmt,sfac,offs,cmpflg,vnm,vlngnm,vstdnm, & ! --- int cmpflg (in) : compression flag; only wet points are ! --- written IF flag is set to 1 ! --- char vnm (in) : variable name used in nc-file -! --- char vlngnm (in) : variable long name (skipped IF ' ') -! --- char vstdnm (in) : variable standard name (skipped IF ' ') -! --- char vunits (in) : variable units (skipped IF ' ') ! --- ------------------------------------------------------------------ ! IMPLICIT NONE ! - REAL ::sfac,offs - INTEGER :: frmt,cmpflg,pos,n - CHARACTER(LEN=*) :: vnm,vlngnm,vstdnm,vunits + REAL, intent(in) :: sfac,offs + INTEGER, intent(in) :: frmt,cmpflg,pos + CHARACTER(LEN=*),intent(in) :: vnm ! - CHARACTER(LEN=100) :: dims + INTEGER :: n + CHARACTER(LEN=100) :: dims ! ! --- Check whether field should be written IF (pos.EQ.0 .OR. frmt.EQ.0) RETURN @@ -1760,20 +1754,12 @@ SUBROUTINE wrtlyr(pos,frmt,sfac,offs,cmpflg,vnm,vlngnm,vstdnm, & ELSE STOP 'unknown output format ' ENDIF -! -! --- Def.NE.attributes -! IF (len(trim(vunits)).NE.0) CALL ncattr('units',vunits) -! IF (len(trim(vlngnm)).NE.0) CALL ncattr('long_name',vlngnm) -! IF (len(trim(vstdnm)).NE.0) CALL ncattr('standard_name',vstdnm) -! CALL ncattr('coordinates','plon plat') -! CALL ncattr('cell_measures','area: parea') ! END SUBROUTINE wrtlyr - SUBROUTINE wrtlvl(pos,frmt,sfac,offs,cmpflg,vnm,vlngnm,vstdnm, & - & vunits) + SUBROUTINE wrtlvl(pos,frmt,sfac,offs,cmpflg,vnm) ! ! --- ------------------------------------------------------------------ ! --- Description: writes diagnostic level field to file @@ -1791,18 +1777,16 @@ SUBROUTINE wrtlvl(pos,frmt,sfac,offs,cmpflg,vnm,vlngnm,vstdnm, & ! --- int cmpflg (in) : compression flag; only wet points are ! --- written IF flag is set to 1 ! --- char vnm (in) : variable name used in nc-file -! --- char vlngnm (in) : variable long name (skipped IF ' ') -! --- char vstdnm (in) : variable standard name (skipped IF ' ') -! --- char vunits (in) : variable units (skipped IF ' ') ! --- ------------------------------------------------------------------ ! IMPLICIT NONE ! - REAL ::sfac,offs - INTEGER :: frmt,cmpflg,pos,n - CHARACTER(LEN=*) :: vnm,vlngnm,vstdnm,vunits + REAL, intent(in) :: sfac,offs + INTEGER, intent(in) :: frmt,cmpflg,pos + CHARACTER(LEN=*),intent(in) :: vnm ! - CHARACTER(LEN=100) :: dims + INTEGER :: n + CHARACTER(LEN=100) :: dims ! ! --- Check whether field should be written IF (pos.EQ.0 .OR. frmt.EQ.0) RETURN @@ -1842,20 +1826,12 @@ SUBROUTINE wrtlvl(pos,frmt,sfac,offs,cmpflg,vnm,vlngnm,vstdnm, & ELSE STOP 'unknown output format ' ENDIF -! -! --- Def.NE.attributes -! IF (len(trim(vunits)).NE.0) CALL ncattr('units',vunits) -! IF (len(trim(vlngnm)).NE.0) CALL ncattr('long_name',vlngnm) -! IF (len(trim(vstdnm)).NE.0) CALL ncattr('standard_name',vstdnm) -! CALL ncattr('coordinates','plon plat') -! CALL ncattr('cell_measures','area: parea') ! END SUBROUTINE wrtlvl - SUBROUTINE wrtsdm(pos,frmt,sfac,offs,cmpflg,vnm,vlngnm,vstdnm, & - & vunits) + SUBROUTINE wrtsdm(pos,frmt,sfac,offs,cmpflg,vnm) ! ! --- ------------------------------------------------------------------ ! --- Description: writes diagnostic sediment field to file @@ -1873,18 +1849,16 @@ SUBROUTINE wrtsdm(pos,frmt,sfac,offs,cmpflg,vnm,vlngnm,vstdnm, & ! --- int cmpflg (in) : compression flag; only wet points are ! --- written IF flag is set to 1 ! --- char vnm (in) : variable name used in nc-file -! --- char vlngnm (in) : variable long name (skipped IF ' ') -! --- char vstdnm (in) : variable standard name (skipped IF ' ') -! --- char vunits (in) : variable units (skipped IF ' ') ! --- ------------------------------------------------------------------ ! IMPLICIT NONE ! - REAL ::sfac,offs - INTEGER :: frmt,cmpflg,pos,n - CHARACTER(LEN=*) :: vnm,vlngnm,vstdnm,vunits + REAL, intent(in) :: sfac,offs + INTEGER, intent(in) :: frmt,cmpflg,pos + CHARACTER(LEN=*),intent(in) :: vnm ! - CHARACTER(LEN=100) :: dims + INTEGER :: n + CHARACTER(LEN=100) :: dims ! ! --- Check whether field should be written IF (pos.EQ.0 .OR. frmt.EQ.0) RETURN @@ -1924,20 +1898,12 @@ SUBROUTINE wrtsdm(pos,frmt,sfac,offs,cmpflg,vnm,vlngnm,vstdnm, & ELSE STOP 'unknown output format ' ENDIF -! -! --- Def.NE.attributes -! IF (len(trim(vunits)).NE.0) CALL ncattr('units',vunits) -! IF (len(trim(vlngnm)).NE.0) CALL ncattr('long_name',vlngnm) -! IF (len(trim(vstdnm)).NE.0) CALL ncattr('standard_name',vstdnm) -! CALL ncattr('coordinates','plon plat') -! CALL ncattr('cell_measures','area: parea') ! END SUBROUTINE wrtsdm - SUBROUTINE wrtbur(pos,frmt,sfac,offs,cmpflg,vnm,vlngnm,vstdnm, & - & vunits) + SUBROUTINE wrtbur(pos,frmt,sfac,offs,cmpflg,vnm) ! ! --- ------------------------------------------------------------------ ! --- Description: writes diagnostic sediment burial field to file @@ -1955,18 +1921,16 @@ SUBROUTINE wrtbur(pos,frmt,sfac,offs,cmpflg,vnm,vlngnm,vstdnm, & ! --- int cmpflg (in) : compression flag; only wet points are ! --- written IF flag is set to 1 ! --- char vnm (in) : variable name used in nc-file -! --- char vlngnm (in) : variable long name (skipped IF ' ') -! --- char vstdnm (in) : variable standard name (skipped IF ' ') -! --- char vunits (in) : variable units (skipped IF ' ') ! --- ------------------------------------------------------------------ ! IMPLICIT NONE ! - REAL ::sfac,offs - INTEGER :: frmt,cmpflg,pos,n - CHARACTER(LEN=*) :: vnm,vlngnm,vstdnm,vunits + REAL, intent(in) :: sfac,offs + INTEGER, intent(in) :: frmt,cmpflg,pos + CHARACTER(LEN=*),intent(in) :: vnm ! - CHARACTER(LEN=100) :: dims + INTEGER :: n + CHARACTER(LEN=100) :: dims ! ! --- Check whether field should be written IF (pos.EQ.0 .OR. frmt.EQ.0) RETURN @@ -2006,13 +1970,6 @@ SUBROUTINE wrtbur(pos,frmt,sfac,offs,cmpflg,vnm,vlngnm,vstdnm, & ELSE STOP 'unknown output format ' ENDIF -! -! --- Def.NE.attributes -! IF (len(trim(vunits)).NE.0) CALL ncattr('units',vunits) -! IF (len(trim(vlngnm)).NE.0) CALL ncattr('long_name',vlngnm) -! IF (len(trim(vstdnm)).NE.0) CALL ncattr('standard_name',vstdnm) -! CALL ncattr('coordinates','plon plat') -! CALL ncattr('cell_measures','area: parea') ! END SUBROUTINE wrtbur diff --git a/hamocc/ncout_hamocc.F90 b/hamocc/ncout_hamocc.F90 index 6293f96b..df9d637f 100644 --- a/hamocc/ncout_hamocc.F90 +++ b/hamocc/ncout_hamocc.F90 @@ -79,7 +79,7 @@ subroutine ncwrt_bgc(iogrp) & jph,jphosph,jphosy,jphyto,jpoc,jprefalk, & & jprefdic,jprefo2,jprefpo4,jsilica, & & jsrfalkali,jsrfano3,jsrfdic,jsrfiron, & - & jsrfoxygen,jsrfphosph,jsrfphyto,jsrfsilica, & + & jsrfoxygen,jsrfphosph,jsrfphyto,jsrfsilica,jsrfph, & & jwnos,jwphy, & & lyr_dp,lyr_dic,lyr_alkali,lyr_phosph, & & lyr_oxygen,lyr_ano3,lyr_silica,lyr_doc, & @@ -102,14 +102,14 @@ subroutine ncwrt_bgc(iogrp) & srf_dmsprod,srf_dms_bac,srf_dms_uv, & & srf_export,srf_exposi,srf_expoca,srf_dic, & & srf_alkali,srf_phosph,srf_oxygen,srf_ano3, & - & srf_silica,srf_iron,srf_phyto, & + & srf_silica,srf_iron,srf_phyto,srf_ph, & & int_phosy,int_nfix,int_dnit, & & nbgc,nacc_bgc,bgcwrt,glb_inventory,bgct2d, & & nbgcmax,glb_ncformat,glb_compflag, & & glb_fnametag,filefq_bgc,diagfq_bgc, & - & filemon_bgc,fileann_bgc,ip,wrtlyr,wrtlvl, & - & loglyr,inilvl,inilyr,inisrf,loglvl, & - & msklvl,wrtsrf,msksrf,finlyr + & filemon_bgc,fileann_bgc,ip,wrtlyr,wrtlvl,wrtsrf, & + & loglyr,loglvl,logsrf,inilvl,inilyr,inisrf, & + & msklvl,msksrf,finlyr #ifdef AGG use mo_bgcmean, only: lyr_nos,lyr_wphy, lyr_wnos,lyr_eps, & & lyr_asize,lvl_nos,lvl_wphy,lvl_wnos,lvl_eps, & @@ -143,14 +143,14 @@ subroutine ncwrt_bgc(iogrp) #endif #ifdef natDIC use mo_bgcmean, only: jnatalkali,jnatdic,jnatcalc,jnatco3,jnatph, & - & jnatomegaa,jnatomegac,lyr_natph,jlvlnatph, & - & lvl_natph,jsrfnatdic, & - & jsrfnatalk,jnatpco2,jnatco2fx,lyr_natco3, & - & lyr_natalkali,lyr_natdic,lyr_natcalc, & + & jnatomegaa,jnatomegac,jlvlnatph, & + & jsrfnatdic,jsrfnatalk,jsrfnatph, & + & jnatpco2,jnatco2fx,lyr_natco3, & + & lyr_natalkali,lyr_natdic,lyr_natph,lyr_natcalc, & & lyr_natomegaa,lyr_natomegac,lvl_natco3, & - & lvl_natalkali,lvl_natdic,lvl_natcalc, & + & lvl_natalkali,lvl_natdic,lvl_natph,lvl_natcalc, & & lvl_natomegaa,lvl_natomegac,srf_natdic, & - & srf_natalkali,srf_natpco2,srf_natco2fx + & srf_natalkali,srf_natpco2,srf_natco2fx,srf_natph #endif #ifndef sedbypass use mo_bgcmean, only: jpowaic,jpowaal,jpowaph,jpowaox,jpown2, & @@ -385,502 +385,255 @@ subroutine ncwrt_bgc(iogrp) #endif ! --- Compute log10 of pH + if (SRF_PH(iogrp).ne.0) call logsrf(jsrfph(iogrp),rnacc,0.) if (LYR_PH(iogrp).ne.0) call loglyr(jph(iogrp),1.,0.) if (LVL_PH(iogrp).ne.0) call loglvl(jlvlph(iogrp),rnacc,0.) #ifdef natDIC + if (SRF_NATPH(iogrp).ne.0) call logsrf(jsrfnatph(iogrp),rnacc,0.) if (LYR_NATPH(iogrp).ne.0) call loglyr(jnatph(iogrp),1.,0.) if (LVL_NATPH(iogrp).ne.0) call loglvl(jlvlnatph(iogrp),rnacc,0.) #endif ! --- Store 2d fields - call wrtsrf(jkwco2(iogrp),SRF_KWCO2(iogrp),rnacc,0.,cmpflg, & - & 'kwco2','CO2 piston velocity',' ','m s-1') - call wrtsrf(jkwco2khm(iogrp),SRF_KWCO2KHM(iogrp),rnacc,0.,cmpflg, & - & 'kwco2khm','CO2 piston velocity times solubility (moist air)',' ', & - & 'm s-1 mol kg-1 uatm-1') - call wrtsrf(jco2kh(iogrp),SRF_CO2KH(iogrp),rnacc,0.,cmpflg, & - & 'co2kh','CO2 solubility (dry air) ',' ','mol kg-1 atm-1') - call wrtsrf(jco2khm(iogrp),SRF_CO2KHM(iogrp),rnacc,0.,cmpflg, & - & 'co2khm','CO2 solubility (moist air) ',' ','mol kg-1 atm-1') - call wrtsrf(jpco2(iogrp),SRF_PCO2(iogrp),rnacc,0.,cmpflg, & - & 'pco2','Surface PCO2',' ','uatm') - call wrtsrf(jpco2m(iogrp),SRF_PCO2M(iogrp),rnacc,0.,cmpflg, & - & 'pco2m','Surface PCO2 (moist air)',' ','uatm') - call wrtsrf(jdmsflux(iogrp),SRF_DMSFLUX(iogrp),rnacc*1e3/dtbgc,0., & - & cmpflg,'dmsflux','DMS flux',' ','mol DMS m-2 s-1') - call wrtsrf(jco2fxd(iogrp),SRF_CO2FXD(iogrp),rnacc*12./dtbgc,0., & - & cmpflg,'co2fxd','Downward CO2 flux',' ','kg C m-2 s-1') - call wrtsrf(jco2fxu(iogrp),SRF_CO2FXU(iogrp),rnacc*12./dtbgc,0., & - & cmpflg,'co2fxu','Upward CO2 flux',' ','kg C m-2 s-1') - call wrtsrf(joxflux(iogrp),SRF_OXFLUX(iogrp),rnacc*1e3/dtbgc,0., & - & cmpflg,'fgo2','Oxygen flux',' ','mol O2 m-2 s-1') - call wrtsrf(jniflux(iogrp),SRF_NIFLUX(iogrp),rnacc*1e3/dtbgc,0., & - & cmpflg,'fgn2','Nitrogen flux',' ','mol N2 m-2 s-1') - call wrtsrf(jdms(iogrp),SRF_DMS(iogrp),rnacc,0.,cmpflg, & - & 'dms','DMS',' ','kmol DMS m-3') - call wrtsrf(jdmsprod(iogrp),SRF_DMSPROD(iogrp),rnacc*1e3/dtbgc,0., & - & cmpflg,'dmsprod','DMS production from phytoplankton production', & - & ' ','mol DMS m-2 s-1') - call wrtsrf(jdms_bac(iogrp),SRF_DMS_BAC(iogrp),rnacc*1e3/dtbgc,0., & - & cmpflg,'dms_bac','DMS bacterial consumption',' ', & - & 'mol DMS m-2 s-1') - call wrtsrf(jdms_uv(iogrp),SRF_DMS_UV(iogrp),rnacc*1e3/dtbgc,0., & - & cmpflg,'dms_uv','DMS photolysis reduction',' ','mol DMS m-2 s-1') - call wrtsrf(jexport(iogrp),SRF_EXPORT(iogrp),rnacc*1e3/dtbgc,0., & - & cmpflg,'epc100','Export production',' ','mol C m-2 s-1') - call wrtsrf(jexposi(iogrp),SRF_EXPOSI(iogrp),rnacc*1e3/dtbgc,0., & - & cmpflg,'epsi100','Si export production',' ','mol Si m-2 s-1') - call wrtsrf(jexpoca(iogrp),SRF_EXPOCA(iogrp),rnacc*1e3/dtbgc,0., & - & cmpflg,'epcalc100','Ca export production',' ','mol Ca m-2 s-1') - call wrtsrf(jsrfdic(iogrp),SRF_DIC(iogrp), & - & rnacc*1e3,0.,cmpflg,'srfdissic', & - & 'Surface dissolved inorganic carbon',' ','mol C m-3') - call wrtsrf(jsrfalkali(iogrp),SRF_ALKALI(iogrp), & - & rnacc*1e3,0.,cmpflg,'srftalk', & - & 'Surface alkalinity',' ','eq m-3') - call wrtsrf(jsrfphosph(iogrp),SRF_PHOSPH(iogrp), & - & rnacc*1e3,0.,cmpflg,'srfpo4', & - & 'Surface phosphorus',' ','mol P m-3') - call wrtsrf(jsrfoxygen(iogrp),SRF_OXYGEN(iogrp), & - & rnacc*1e3,0.,cmpflg,'srfo2', & - & 'Surface oxygen',' ','mol O2 m-3') - call wrtsrf(jsrfano3(iogrp),SRF_ANO3(iogrp), & - & rnacc*1e3,0.,cmpflg,'srfno3', & - & 'Surface nitrate',' ','mol N m-3') - call wrtsrf(jsrfsilica(iogrp),SRF_SILICA(iogrp), & - & rnacc*1e3,0.,cmpflg,'srfsi', & - & 'Surface silicate',' ','mol Si m-3') - call wrtsrf(jsrfiron(iogrp),SRF_IRON(iogrp), & - & rnacc*1e3,0.,cmpflg,'srfdfe', & - & 'Surface dissolved iron',' ','mol Fe m-3') - call wrtsrf(jsrfphyto(iogrp),SRF_PHYTO(iogrp), & - & rnacc*1e3,0.,cmpflg,'srfphyc', & - & 'Surface phytoplankton',' ','mol P m-3') - call wrtsrf(jintphosy(iogrp),INT_PHOSY(iogrp), & - & rnacc*1e3/dtbgc,0.,cmpflg,'ppint', & - & 'Integrated primary production',' ','mol C m-2 s-1') - call wrtsrf(jintnfix(iogrp),INT_NFIX(iogrp), & - & rnacc*1e3/dtbgc,0.,cmpflg,'nfixint', & - & 'Integrated nitrogen fixation',' ','mol N m-2 s-1') - call wrtsrf(jintdnit(iogrp),INT_DNIT(iogrp), & - & rnacc*1e3/dtbgc,0.,cmpflg,'dnitint', & - & 'Integrated denitrification',' ','mol N m-2 s-1') - call wrtsrf(jcarflx0100(iogrp),FLX_CAR0100(iogrp), & - & rnacc*1e3/dtbgc,0.,cmpflg,'carflx0100', & - & 'C flux at 100m',' ','mol C m-2 s-1') - call wrtsrf(jcarflx0500(iogrp),FLX_CAR0500(iogrp), & - & rnacc*1e3/dtbgc,0.,cmpflg,'carflx0500', & - & 'C flux at 500m',' ','mol C m-2 s-1') - call wrtsrf(jcarflx1000(iogrp),FLX_CAR1000(iogrp), & - & rnacc*1e3/dtbgc,0.,cmpflg,'carflx1000', & - & 'C flux at 1000m',' ','mol C m-2 s-1') - call wrtsrf(jcarflx2000(iogrp),FLX_CAR2000(iogrp), & - & rnacc*1e3/dtbgc,0.,cmpflg,'carflx2000', & - & 'C flux at 2000m',' ','mol C m-2 s-1') - call wrtsrf(jcarflx4000(iogrp),FLX_CAR4000(iogrp), & - & rnacc*1e3/dtbgc,0.,cmpflg,'carflx4000', & - & 'C flux at 4000m',' ','mol C m-2 s-1') - call wrtsrf(jcarflx_bot(iogrp),FLX_CAR_BOT(iogrp), & - & rnacc*1e3/dtbgc,0.,cmpflg,'carflx_bot', & - & 'C flux to sediment',' ','mol C m-2 s-1') - call wrtsrf(jbsiflx0100(iogrp),FLX_BSI0100(iogrp), & - & rnacc*1e3/dtbgc,0.,cmpflg,'bsiflx0100', & - & 'Opal flux at 100m',' ','mol Si m-2 s-1') - call wrtsrf(jbsiflx0500(iogrp),FLX_BSI0500(iogrp), & - & rnacc*1e3/dtbgc,0.,cmpflg,'bsiflx0500', & - & 'Opal flux at 500m',' ','mol Si m-2 s-1') - call wrtsrf(jbsiflx1000(iogrp),FLX_BSI1000(iogrp), & - & rnacc*1e3/dtbgc,0.,cmpflg,'bsiflx1000', & - & 'Opal flux at 1000m',' ','mol Si m-2 s-1') - call wrtsrf(jbsiflx2000(iogrp),FLX_BSI2000(iogrp), & - & rnacc*1e3/dtbgc,0.,cmpflg,'bsiflx2000', & - & 'Opal flux at 2000m',' ','mol Si m-2 s-1') - call wrtsrf(jbsiflx4000(iogrp),FLX_BSI4000(iogrp), & - & rnacc*1e3/dtbgc,0.,cmpflg,'bsiflx4000', & - & 'Opal flux at 4000m',' ','mol Si m-2 s-1') - call wrtsrf(jbsiflx_bot(iogrp),FLX_BSI_BOT(iogrp), & - & rnacc*1e3/dtbgc,0.,cmpflg,'bsiflx_bot', & - & 'Opal flux to sediment',' ','mol Si m-2 s-1') - call wrtsrf(jcalflx0100(iogrp),FLX_CAL0100(iogrp), & - & rnacc*1e3/dtbgc,0.,cmpflg,'calflx0100', & - & 'CaCO3 flux at 100m',' ','mol Ca m-2 s-1') - call wrtsrf(jcalflx0500(iogrp),FLX_CAL0500(iogrp), & - & rnacc*1e3/dtbgc,0.,cmpflg,'calflx0500', & - & 'CaCO3 flux at 500m',' ','mol Ca m-2 s-1') - call wrtsrf(jcalflx1000(iogrp),FLX_CAL1000(iogrp), & - & rnacc*1e3/dtbgc,0.,cmpflg,'calflx1000', & - & 'CaCO3 flux at 1000m',' ','mol Ca m-2 s-1') - call wrtsrf(jcalflx2000(iogrp),FLX_CAL2000(iogrp), & - & rnacc*1e3/dtbgc,0.,cmpflg,'calflx2000', & - & 'CaCO3 flux at 2000m',' ','mol Ca m-2 s-1') - call wrtsrf(jcalflx4000(iogrp),FLX_CAL4000(iogrp), & - & rnacc*1e3/dtbgc,0.,cmpflg,'calflx4000', & - & 'CaCO3 flux at 4000m',' ','mol Ca m-2 s-1') - call wrtsrf(jcalflx_bot(iogrp),FLX_CAL_BOT(iogrp), & - & rnacc*1e3/dtbgc,0.,cmpflg,'calflx_bot', & - & 'CaCO3 flux to sediment',' ','mol Ca m-2 s-1') + call wrtsrf(jkwco2(iogrp), SRF_KWCO2(iogrp), rnacc, 0.,cmpflg,'kwco2') + call wrtsrf(jkwco2khm(iogrp), SRF_KWCO2KHM(iogrp), rnacc, 0.,cmpflg,'kwco2khm') + call wrtsrf(jco2kh(iogrp), SRF_CO2KH(iogrp), rnacc, 0.,cmpflg,'co2kh') + call wrtsrf(jco2khm(iogrp), SRF_CO2KHM(iogrp), rnacc, 0.,cmpflg,'co2khm') + call wrtsrf(jpco2(iogrp), SRF_PCO2(iogrp), rnacc, 0.,cmpflg,'pco2') + call wrtsrf(jpco2m(iogrp), SRF_PCO2M(iogrp), rnacc, 0.,cmpflg,'pco2m') + call wrtsrf(jdmsflux(iogrp), SRF_DMSFLUX(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'dmsflux') + call wrtsrf(jco2fxd(iogrp), SRF_CO2FXD(iogrp), rnacc*12./dtbgc,0.,cmpflg,'co2fxd') + call wrtsrf(jco2fxu(iogrp), SRF_CO2FXU(iogrp), rnacc*12./dtbgc,0.,cmpflg,'co2fxu') + call wrtsrf(joxflux(iogrp), SRF_OXFLUX(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'fgo2') + call wrtsrf(jniflux(iogrp), SRF_NIFLUX(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'fgn2') + call wrtsrf(jn2ofx(iogrp), SRF_N2OFX(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'n2oflux') + call wrtsrf(jdms(iogrp), SRF_DMS(iogrp), rnacc, 0.,cmpflg,'dms') + call wrtsrf(jdmsprod(iogrp), SRF_DMSPROD(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'dmsprod') + call wrtsrf(jdms_bac(iogrp), SRF_DMS_BAC(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'dms_bac') + call wrtsrf(jdms_uv(iogrp), SRF_DMS_UV(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'dms_uv') + call wrtsrf(jexport(iogrp), SRF_EXPORT(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'epc100') + call wrtsrf(jexposi(iogrp), SRF_EXPOSI(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'epsi100') + call wrtsrf(jexpoca(iogrp), SRF_EXPOCA(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'epcalc100') + call wrtsrf(jsrfdic(iogrp), SRF_DIC(iogrp), rnacc*1e3, 0.,cmpflg,'srfdissic') + call wrtsrf(jsrfalkali(iogrp), SRF_ALKALI(iogrp), rnacc*1e3, 0.,cmpflg,'srftalk') + call wrtsrf(jsrfphosph(iogrp), SRF_PHOSPH(iogrp), rnacc*1e3, 0.,cmpflg,'srfpo4') + call wrtsrf(jsrfoxygen(iogrp), SRF_OXYGEN(iogrp), rnacc*1e3, 0.,cmpflg,'srfo2') + call wrtsrf(jsrfano3(iogrp), SRF_ANO3(iogrp), rnacc*1e3, 0.,cmpflg,'srfno3') + call wrtsrf(jsrfsilica(iogrp), SRF_SILICA(iogrp), rnacc*1e3, 0.,cmpflg,'srfsi') + call wrtsrf(jsrfiron(iogrp), SRF_IRON(iogrp), rnacc*1e3, 0.,cmpflg,'srfdfe') + call wrtsrf(jsrfphyto(iogrp), SRF_PHYTO(iogrp), rnacc*1e3, 0.,cmpflg,'srfphyc') + call wrtsrf(jsrfph(iogrp), SRF_PH(iogrp), -1., 0.,cmpflg,'srfph') + call wrtsrf(jintphosy(iogrp), INT_PHOSY(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'ppint') + call wrtsrf(jintnfix(iogrp), INT_NFIX(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'nfixint') + call wrtsrf(jintdnit(iogrp), INT_DNIT(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'dnitint') + call wrtsrf(jcarflx0100(iogrp), FLX_CAR0100(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'carflx0100') + call wrtsrf(jcarflx0500(iogrp), FLX_CAR0500(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'carflx0500') + call wrtsrf(jcarflx1000(iogrp), FLX_CAR1000(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'carflx1000') + call wrtsrf(jcarflx2000(iogrp), FLX_CAR2000(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'carflx2000') + call wrtsrf(jcarflx4000(iogrp), FLX_CAR4000(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'carflx4000') + call wrtsrf(jcarflx_bot(iogrp), FLX_CAR_BOT(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'carflx_bot') + call wrtsrf(jbsiflx0100(iogrp), FLX_BSI0100(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'bsiflx0100') + call wrtsrf(jbsiflx0500(iogrp), FLX_BSI0500(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'bsiflx0500') + call wrtsrf(jbsiflx1000(iogrp), FLX_BSI1000(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'bsiflx1000') + call wrtsrf(jbsiflx2000(iogrp), FLX_BSI2000(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'bsiflx2000') + call wrtsrf(jbsiflx4000(iogrp), FLX_BSI4000(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'bsiflx4000') + call wrtsrf(jbsiflx_bot(iogrp), FLX_BSI_BOT(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'bsiflx_bot') + call wrtsrf(jcalflx0100(iogrp), FLX_CAL0100(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'calflx0100') + call wrtsrf(jcalflx0500(iogrp), FLX_CAL0500(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'calflx0500') + call wrtsrf(jcalflx1000(iogrp), FLX_CAL1000(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'calflx1000') + call wrtsrf(jcalflx2000(iogrp), FLX_CAL2000(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'calflx2000') + call wrtsrf(jcalflx4000(iogrp), FLX_CAL4000(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'calflx4000') + call wrtsrf(jcalflx_bot(iogrp), FLX_CAL_BOT(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'calflx_bot') #ifndef sedbypass - call wrtsrf(jsediffic(iogrp),FLX_SEDIFFIC(iogrp), & - & rnacc*1e3/dtbgc,0.,cmpflg,'sedfdic',' ',' ',' ') - call wrtsrf(jsediffal(iogrp),FLX_SEDIFFAL(iogrp), & - & rnacc*1e3/dtbgc,0.,cmpflg,'sedfalk',' ',' ',' ') - call wrtsrf(jsediffph(iogrp),FLX_SEDIFFPH(iogrp), & - & rnacc*1e3/dtbgc,0.,cmpflg,'sedfpho',' ',' ',' ') - call wrtsrf(jsediffox(iogrp),FLX_SEDIFFOX(iogrp), & - & rnacc*1e3/dtbgc,0.,cmpflg,'sedfox',' ',' ',' ') - call wrtsrf(jsediffn2(iogrp),FLX_SEDIFFN2(iogrp), & - & rnacc*1e3/dtbgc,0.,cmpflg,'sedfn2',' ',' ',' ') - call wrtsrf(jsediffno3(iogrp),FLX_SEDIFFNO3(iogrp), & - & rnacc*1e3/dtbgc,0.,cmpflg,'sedfno3',' ',' ',' ') - call wrtsrf(jsediffsi(iogrp),FLX_SEDIFFSI(iogrp), & - & rnacc*1e3/dtbgc,0.,cmpflg,'sedfsi',' ',' ',' ') -#endif - call wrtsrf(jn2ofx(iogrp),SRF_N2OFX(iogrp),rnacc*1e3/dtbgc,0., & - & cmpflg,'n2oflux','N2O flux',' ','mol N2O m-2 s-1') + call wrtsrf(jsediffic(iogrp), FLX_SEDIFFIC(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'sedfdic') + call wrtsrf(jsediffal(iogrp), FLX_SEDIFFAL(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'sedfalk') + call wrtsrf(jsediffph(iogrp), FLX_SEDIFFPH(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'sedfpho') + call wrtsrf(jsediffox(iogrp), FLX_SEDIFFOX(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'sedfox') + call wrtsrf(jsediffn2(iogrp), FLX_SEDIFFN2(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'sedfn2') + call wrtsrf(jsediffno3(iogrp), FLX_SEDIFFNO3(iogrp),rnacc*1e3/dtbgc,0.,cmpflg,'sedfno3') + call wrtsrf(jsediffsi(iogrp), FLX_SEDIFFSI(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'sedfsi') +#endif #ifdef cisonew - call wrtsrf(jco213fxd(iogrp),SRF_CO213FXD(iogrp), & - & rnacc*12./dtbgc,0.,cmpflg,'co213fxd', & - & 'Downward 13CO2 flux',' ','kg C m-2 s-1') - call wrtsrf(jco213fxu(iogrp),SRF_CO213FXU(iogrp), & - & rnacc*12./dtbgc,0.,cmpflg,'co213fxu', & - & 'Upward 13CO2 flux',' ','kg C m-2 s-1') - call wrtsrf(jco214fxd(iogrp),SRF_CO214FXD(iogrp), & - & rnacc*12.*c14fac/dtbgc,0.,cmpflg,'co214fxd', & - & 'Downward 14CO2 flux',' ','kg C m-2 s-1') - call wrtsrf(jco214fxu(iogrp),SRF_CO214FXU(iogrp), & - & rnacc*12.*c14fac/dtbgc,0.,cmpflg,'co214fxu', & - & 'Upward 14CO2 flux',' ','kg C m-2 s-1') + call wrtsrf(jco213fxd(iogrp), SRF_CO213FXD(iogrp), rnacc*12./dtbgc,0.,cmpflg,'co213fxd') + call wrtsrf(jco213fxu(iogrp), SRF_CO213FXU(iogrp), rnacc*12./dtbgc,0.,cmpflg,'co213fxu') + call wrtsrf(jco214fxd(iogrp), SRF_CO214FXD(iogrp), rnacc*12.*c14fac/dtbgc,0.,cmpflg,'co214fxd') + call wrtsrf(jco214fxu(iogrp), SRF_CO214FXU(iogrp), rnacc*12.*c14fac/dtbgc,0.,cmpflg,'co214fxu') #endif #ifdef CFC - call wrtsrf(jcfc11fx(iogrp),SRF_CFC11(iogrp),rnacc*1e3/dtbgc,0., & - & cmpflg,'cfc11flux','CFC-11 flux',' ','mol CFC12 m-2 s-1') - call wrtsrf(jcfc12fx(iogrp),SRF_CFC12(iogrp),rnacc*1e3/dtbgc,0., & - & cmpflg,'cfc12flux','CFC-12 flux',' ','mol CFC12 m-2 s-1') - call wrtsrf(jsf6fx(iogrp),SRF_SF6(iogrp),rnacc*1e3/dtbgc,0., & - & cmpflg,'sf6flux','SF-6 flux',' ','mol SF6 m-2 s-1') + call wrtsrf(jcfc11fx(iogrp), SRF_CFC11(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'cfc11flux') + call wrtsrf(jcfc12fx(iogrp), SRF_CFC12(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'cfc12flux') + call wrtsrf(jsf6fx(iogrp), SRF_SF6(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'sf6flux') #endif #ifdef natDIC - call wrtsrf(jsrfnatdic(iogrp),SRF_NATDIC(iogrp), & - & rnacc*1e3,0.,cmpflg,'srfnatdissic', & - & 'Surface natural dissolved inorganic carbon',' ','mol C m-3') - call wrtsrf(jsrfnatalk(iogrp),SRF_NATALKALI(iogrp), & - & rnacc*1e3,0.,cmpflg,'srfnattalk', & - & 'Surface natural alkalinity',' ','eq m-3') - call wrtsrf(jnatpco2(iogrp),SRF_NATPCO2(iogrp),rnacc,0.,cmpflg, & - & 'natpco2','Surface natural PCO2',' ','uatm') - call wrtsrf(jnatco2fx(iogrp),SRF_NATCO2FX(iogrp), & - & rnacc*12./dtbgc,0.,cmpflg,'natco2fx', & - & 'Natural CO2 flux',' ','kg C m-2 s-1') + call wrtsrf(jsrfnatdic(iogrp), SRF_NATDIC(iogrp), rnacc*1e3, 0.,cmpflg,'srfnatdissic') + call wrtsrf(jsrfnatalk(iogrp), SRF_NATALKALI(iogrp),rnacc*1e3, 0.,cmpflg,'srfnattalk') + call wrtsrf(jnatpco2(iogrp), SRF_NATPCO2(iogrp), rnacc, 0.,cmpflg,'natpco2') + call wrtsrf(jnatco2fx(iogrp), SRF_NATCO2FX(iogrp), rnacc*12./dtbgc,0.,cmpflg,'natco2fx') + call wrtsrf(jsrfnatph(iogrp), SRF_NATPH(iogrp), -1., 0.,cmpflg,'srfnatph') #endif #ifdef BROMO - call wrtsrf(jbromofx(iogrp),SRF_BROMOFX(iogrp),rnacc*1e3/dtbgc, & - & 0.,cmpflg,'bromofx','Bromoform flux',' ','mol CHBr3 m-2 s-1') - call wrtsrf(jsrfbromo(iogrp),SRF_BROMO(iogrp),rnacc*1e3,0., & - & cmpflg,'srfbromo','Surface bromoform',' ','mol CHBr3 m-3') - call wrtsrf(jbromo_prod(iogrp),INT_BROMOPRO(iogrp), & - & rnacc*1e3/dtbgc,0.,cmpflg,'intbromoprod', & - & 'Integrated bromoform production',' ','mol CHBr3 m-2 s-1') - call wrtsrf(jbromo_uv(iogrp),INT_BROMOUV(iogrp), & - & rnacc*1e3/dtbgc,0.,cmpflg,'intbromouv', & - & 'Integrated bromoform loss to photolysis',' ', & - & 'mol CHBr3 m-2 s-1') - call wrtsrf(jatmbromo(iogrp),SRF_ATMBROMO(iogrp),rnacc,0., & - & cmpflg,'atmbromo','Atmospheric bromoform',' ','ppt') + call wrtsrf(jbromofx(iogrp), SRF_BROMOFX(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'bromofx') + call wrtsrf(jsrfbromo(iogrp), SRF_BROMO(iogrp), rnacc*1e3, 0.,cmpflg,'srfbromo') + call wrtsrf(jbromo_prod(iogrp), INT_BROMOPRO(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'intbromoprod') + call wrtsrf(jbromo_uv(iogrp), INT_BROMOUV(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'intbromouv') + call wrtsrf(jatmbromo(iogrp), SRF_ATMBROMO(iogrp), rnacc, 0.,cmpflg,'atmbromo') #endif - - - call wrtsrf(jatmco2(iogrp),SRF_ATMCO2(iogrp),rnacc,0.,cmpflg, & - & 'atmco2','Atmospheric CO2',' ','ppm') + call wrtsrf(jatmco2(iogrp), SRF_ATMCO2(iogrp), rnacc, 0.,cmpflg,'atmco2') #if defined(BOXATM) - call wrtsrf(jatmo2(iogrp),SRF_ATMO2(iogrp),rnacc,0.,cmpflg, & - & 'atmo2','Atmospheric O2',' ','ppm') - call wrtsrf(jatmn2(iogrp),SRF_ATMN2(iogrp),rnacc,0.,cmpflg, & - & 'atmn2','Atmospheric N2',' ','ppm') + call wrtsrf(jatmo2(iogrp), SRF_ATMO2(iogrp), rnacc, 0.,cmpflg,'atmo2') + call wrtsrf(jatmn2(iogrp), SRF_ATMN2(iogrp), rnacc, 0.,cmpflg,'atmn2') #endif #ifdef cisonew - call wrtsrf(jatmc13(iogrp),SRF_ATMC13(iogrp),rnacc,0.,cmpflg, & - & 'atmc13','Atmospheric 13CO2',' ','ppm') - call wrtsrf(jatmc14(iogrp),SRF_ATMC14(iogrp),rnacc,0.,cmpflg, & - & 'atmc14','Atmospheric 14CO2',' ','ppm') + call wrtsrf(jatmc13(iogrp), SRF_ATMC13(iogrp), rnacc, 0.,cmpflg,'atmc13') + call wrtsrf(jatmc14(iogrp), SRF_ATMC14(iogrp), rnacc, 0.,cmpflg,'atmc14) #endif ! --- Store 3d layer fields - call wrtlyr(jdp(iogrp),LYR_DP(iogrp),rnacc,0.,cmpflg, & - & 'pddpo','Layer thickness',' ','m') - call wrtlyr(jdic(iogrp),LYR_DIC(iogrp),1e3,0.,cmpflg, & - & 'dissic','Dissolved inorganic carbon',' ','mol C m-3') - call wrtlyr(jalkali(iogrp),LYR_ALKALI(iogrp),1e3,0.,cmpflg, & - & 'talk','Alkalinity',' ','eq m-3') - call wrtlyr(jphosph(iogrp),LYR_PHOSPH(iogrp),1e3,0.,cmpflg, & - & 'po4','Phosphorus',' ','mol P m-3') - call wrtlyr(joxygen(iogrp),LYR_OXYGEN(iogrp),1e3,0.,cmpflg, & - & 'o2','Oxygen',' ','mol O2 m-3') - call wrtlyr(jano3(iogrp),LYR_ANO3(iogrp),1e3,0.,cmpflg, & - & 'no3','Nitrate',' ','mol N m-3') - call wrtlyr(jsilica(iogrp),LYR_SILICA(iogrp),1e3,0.,cmpflg, & - & 'si','Silicate',' ','mol Si m-3') - call wrtlyr(jdoc(iogrp),LYR_DOC(iogrp),1e3,0.,cmpflg, & - & 'dissoc','Dissolved organic carbon',' ','mol P m-3') - call wrtlyr(jphyto(iogrp),LYR_PHYTO(iogrp),1e3,0.,cmpflg, & - & 'phyc','Phytoplankton',' ','mol P m-3') - call wrtlyr(jgrazer(iogrp),LYR_GRAZER(iogrp),1e3,0.,cmpflg, & - & 'zooc','Zooplankton',' ','mol P m-3') - call wrtlyr(jpoc(iogrp),LYR_POC(iogrp),1e3,0.,cmpflg, & - & 'detoc','Detritus',' ','mol P m-3') - call wrtlyr(jcalc(iogrp),LYR_CALC(iogrp),1e3,0.,cmpflg, & - & 'calc','CaCO3 shells',' ','mol C m-3') - call wrtlyr(jopal(iogrp),LYR_OPAL(iogrp),1e3,0.,cmpflg, & - & 'opal','Opal shells',' ','mol Si m-3') - call wrtlyr(jiron(iogrp),LYR_IRON(iogrp),1e3,0.,cmpflg, & - & 'dfe','Dissolved iron',' ','mol Fe m-3') - call wrtlyr(jphosy(iogrp),LYR_PHOSY(iogrp),1e3/dtbgc,0.,cmpflg, & - & 'pp','Primary production',' ','mol C m-3 s-1') - call wrtlyr(jco3(iogrp),LYR_CO3(iogrp),1e3,0.,cmpflg, & - & 'co3','Carbonate ions',' ','mol C m-3') - call wrtlyr(jph(iogrp),LYR_PH(iogrp),-1.,0.,cmpflg, & - & 'ph','pH',' ','-log10([h+])') - call wrtlyr(jomegaa(iogrp),LYR_OMEGAA(iogrp),1.,0.,cmpflg, & - & 'omegaa','OmegaA',' ','-') - call wrtlyr(jomegac(iogrp),LYR_OMEGAC(iogrp),1.,0.,cmpflg, & - & 'omegac','OmegaC',' ','-') - call wrtlyr(jn2o(iogrp),LYR_N2O(iogrp),1e3,0.,cmpflg, & - & 'n2o','N2O',' ','mol N2O m-3') - call wrtlyr(jprefo2(iogrp),LYR_PREFO2(iogrp),1e3,0.,cmpflg, & - & 'p_o2','Preformed oxygen',' ','mol O2 m-3') - call wrtlyr(jo2sat(iogrp),LYR_O2SAT(iogrp),1e3,0.,cmpflg, & - & 'satoxy','Saturated oxygen',' ','mol O2 m-3') - call wrtlyr(jprefpo4(iogrp),LYR_PREFPO4(iogrp),1e3,0.,cmpflg, & - & 'p_po4','Preformed phosphorus',' ','mol P m-3') - call wrtlyr(jprefalk(iogrp),LYR_PREFALK(iogrp),1e3,0.,cmpflg, & - & 'p_talk','Preformed alkalinity',' ','eq m-3') - call wrtlyr(jprefdic(iogrp),LYR_PREFDIC(iogrp),1e3,0.,cmpflg, & - & 'p_dic','Preformed DIC',' ','mol C m-3') - call wrtlyr(jdicsat(iogrp),LYR_DICSAT(iogrp),1e3,0.,cmpflg, & - & 'sat_dic','Saturated DIC',' ','mol C m-3') + call wrtlyr(jdp(iogrp), LYR_DP(iogrp), rnacc, 0.,cmpflg,'pddpo') + call wrtlyr(jdic(iogrp), LYR_DIC(iogrp), 1e3, 0.,cmpflg,'dissic') + call wrtlyr(jalkali(iogrp), LYR_ALKALI(iogrp), 1e3, 0.,cmpflg,'talk') + call wrtlyr(jphosph(iogrp), LYR_PHOSPH(iogrp), 1e3, 0.,cmpflg,'po4') + call wrtlyr(joxygen(iogrp), LYR_OXYGEN(iogrp), 1e3, 0.,cmpflg,'o2') + call wrtlyr(jano3(iogrp), LYR_ANO3(iogrp), 1e3, 0.,cmpflg,'no3') + call wrtlyr(jsilica(iogrp), LYR_SILICA(iogrp), 1e3, 0.,cmpflg,'si') + call wrtlyr(jdoc(iogrp), LYR_DOC(iogrp), 1e3, 0.,cmpflg,'dissoc') + call wrtlyr(jphyto(iogrp), LYR_PHYTO(iogrp), 1e3, 0.,cmpflg,'phyc') + call wrtlyr(jgrazer(iogrp), LYR_GRAZER(iogrp), 1e3, 0.,cmpflg,'zooc') + call wrtlyr(jpoc(iogrp), LYR_POC(iogrp), 1e3, 0.,cmpflg,'detoc') + call wrtlyr(jcalc(iogrp), LYR_CALC(iogrp), 1e3, 0.,cmpflg,'calc') + call wrtlyr(jopal(iogrp), LYR_OPAL(iogrp), 1e3, 0.,cmpflg,'opal') + call wrtlyr(jiron(iogrp), LYR_IRON(iogrp), 1e3, 0.,cmpflg,'dfe') + call wrtlyr(jphosy(iogrp), LYR_PHOSY(iogrp), 1e3/dtbgc, 0.,cmpflg,'pp') + call wrtlyr(jco3(iogrp), LYR_CO3(iogrp), 1e3, 0.,cmpflg,'co3') + call wrtlyr(jph(iogrp), LYR_PH(iogrp), -1., 0.,cmpflg,'ph') + call wrtlyr(jomegaa(iogrp), LYR_OMEGAA(iogrp), 1., 0.,cmpflg,'omegaa') + call wrtlyr(jomegac(iogrp), LYR_OMEGAC(iogrp), 1., 0.,cmpflg,'omegac') + call wrtlyr(jn2o(iogrp), LYR_N2O(iogrp), 1e3, 0.,cmpflg,'n2o') + call wrtlyr(jprefo2(iogrp), LYR_PREFO2(iogrp), 1e3, 0.,cmpflg,'p_o2') + call wrtlyr(jo2sat(iogrp), LYR_O2SAT(iogrp), 1e3, 0.,cmpflg,'satoxy') + call wrtlyr(jprefpo4(iogrp), LYR_PREFPO4(iogrp), 1e3, 0.,cmpflg,'p_po4') + call wrtlyr(jprefalk(iogrp), LYR_PREFALK(iogrp), 1e3, 0.,cmpflg,'p_talk') + call wrtlyr(jprefdic(iogrp), LYR_PREFDIC(iogrp), 1e3, 0.,cmpflg,'p_dic') + call wrtlyr(jdicsat(iogrp), LYR_DICSAT(iogrp), 1e3, 0.,cmpflg,'sat_dic') #ifdef cisonew - call wrtlyr(jdic13(iogrp),LYR_DIC13(iogrp),1.e3,0.,cmpflg, & - & 'dissic13','Dissolved C13',' ','mol 13C m-3') - call wrtlyr(jdic14(iogrp),LYR_DIC14(iogrp),1.e3*c14fac,0.,cmpflg, & - & 'dissic14','Dissolved C14',' ','mol 14C m-3') - call wrtlyr(jd13c(iogrp),LYR_D13C(iogrp),1.,0.,cmpflg, & - & 'delta13c','delta13C of DIC',' ','permil') - call wrtlyr(jd14c(iogrp),LYR_D14C(iogrp),1.,0.,cmpflg, & - & 'delta14c','delta14C of DIC',' ','permil') - call wrtlyr(jbigd14c(iogrp),LYR_BIGD14C(iogrp),1.,0.,cmpflg, & - & 'bigdelta14c','big delta14C of DIC',' ','permil') - call wrtlyr(jpoc13(iogrp),LYR_POC13(iogrp),1e3,0.,cmpflg, & - & 'detoc13','Detritus13',' ','mol P m-3') - call wrtlyr(jdoc13(iogrp),LYR_DOC13(iogrp),1e3,0.,cmpflg, & - & 'dissoc13','Dissolved organic carbon13',' ','mol P m-3') - call wrtlyr(jcalc13(iogrp),LYR_CALC13(iogrp),1e3,0.,cmpflg, & - & 'calc13','Ca13CO3 shells',' ','mol 13C m-3') - call wrtlyr(jphyto13(iogrp),LYR_PHYTO13(iogrp),1e3,0.,cmpflg, & - & 'phyc13','Phytoplankton13',' ','mol P m-3') - call wrtlyr(jgrazer13(iogrp),LYR_GRAZER13(iogrp),1e3,0.,cmpflg, & - & 'zooc13','Zooplankton13',' ','mol P m-3') + call wrtlyr(jdic13(iogrp), LYR_DIC13(iogrp), 1.e3, 0.,cmpflg,'dissic13') + call wrtlyr(jdic14(iogrp), LYR_DIC14(iogrp), 1.e3*c14fac, 0.,cmpflg,'dissic14') + call wrtlyr(jd13c(iogrp), LYR_D13C(iogrp), 1., 0.,cmpflg,'delta13c') + call wrtlyr(jd14c(iogrp), LYR_D14C(iogrp), 1., 0.,cmpflg,'delta14c') + call wrtlyr(jbigd14c(iogrp), LYR_BIGD14C(iogrp), 1., 0.,cmpflg,'bigdelta14c') + call wrtlyr(jpoc13(iogrp), LYR_POC13(iogrp), 1e3, 0.,cmpflg,'detoc13') + call wrtlyr(jdoc13(iogrp), LYR_DOC13(iogrp), 1e3, 0.,cmpflg,'dissoc13') + call wrtlyr(jcalc13(iogrp), LYR_CALC13(iogrp), 1e3, 0.,cmpflg,'calc13') + call wrtlyr(jphyto13(iogrp), LYR_PHYTO13(iogrp), 1e3, 0.,cmpflg,'phyc13') + call wrtlyr(jgrazer13(iogrp), LYR_GRAZER13(iogrp), 1e3, 0.,cmpflg,'zooc13') #endif #ifdef AGG - call wrtlyr(jnos(iogrp),LYR_NOS(iogrp),1.,0.,cmpflg, & - & 'nos','Marine snow aggregates per cm^3 sea water',' ','1/cm^3') - call wrtlyr(jwphy(iogrp),LYR_WPHY(iogrp),1.,0.,cmpflg, & - & 'wphy','Av. mass sinking speed of marine snow',' ','m/day') - call wrtlyr(jwnos(iogrp),LYR_WNOS(iogrp),1.,0.,cmpflg, & - & 'wnos','Av. number sinking speed of marine snow',' ','m/day') - call wrtlyr(jeps(iogrp),LYR_EPS(iogrp),1.,0.,cmpflg, & - & 'eps','Av. size distribution exponent',' ','-') - call wrtlyr(jasize(iogrp),LYR_ASIZE(iogrp),1.,0.,cmpflg, & - & 'asize','Av. size of marine snow aggregates',' ','nb. of cells') + call wrtlyr(jnos(iogrp), LYR_NOS(iogrp), 1., 0.,cmpflg,'nos') + call wrtlyr(jwphy(iogrp), LYR_WPHY(iogrp), 1., 0.,cmpflg,'wphy') + call wrtlyr(jwnos(iogrp), LYR_WNOS(iogrp), 1., 0.,cmpflg,'wnos') + call wrtlyr(jeps(iogrp), LYR_EPS(iogrp), 1., 0.,cmpflg,'eps') + call wrtlyr(jasize(iogrp), LYR_ASIZE(iogrp), 1., 0.,cmpflg,'asize') #endif #ifdef CFC - call wrtlyr(jcfc11(iogrp),LYR_CFC11(iogrp),1e3,0.,cmpflg, & - & 'cfc11','CFC-11',' ','mol cfc11 m-3') - call wrtlyr(jcfc12(iogrp),LYR_CFC12(iogrp),1e3,0.,cmpflg, & - & 'cfc12','CFC-12',' ','mol cfc12 m-3') - call wrtlyr(jsf6(iogrp),LYR_SF6(iogrp),1e3,0.,cmpflg, & - & 'sf6','SF-6',' ','mol sf6 m-3') + call wrtlyr(jcfc11(iogrp), LYR_CFC11(iogrp), 1e3, 0.,cmpflg,'cfc11') + call wrtlyr(jcfc12(iogrp), LYR_CFC12(iogrp), 1e3, 0.,cmpflg,'cfc12') + call wrtlyr(jsf6(iogrp), LYR_SF6(iogrp), 1e3, 0.,cmpflg,'sf6') #endif #ifdef natDIC - call wrtlyr(jnatco3(iogrp),LYR_NATCO3(iogrp),1e3,0.,cmpflg, & - & 'natco3','Natural Carbonate ions',' ','mol C m-3') - call wrtlyr(jnatalkali(iogrp),LYR_NATALKALI(iogrp),1e3,0.,cmpflg, & - & 'nattalk','Natural alkalinity',' ','eq m-3') - call wrtlyr(jnatdic(iogrp),LYR_NATDIC(iogrp),1e3,0.,cmpflg, & - & 'natdissic','Natural dissolved inorganic carbon',' ', & - & 'mol C m-3') - call wrtlyr(jnatcalc(iogrp),LYR_NATCALC(iogrp),1e3,0.,cmpflg, & - & 'natcalc','Natural CaCO3 shells',' ','mol C m-3') - call wrtlyr(jnatph(iogrp),LYR_NATPH(iogrp),-1.,0.,cmpflg, & - & 'natph','Natural pH',' ','-log10([h+])') - call wrtlyr(jnatomegaa(iogrp),LYR_NATOMEGAA(iogrp),1.,0.,cmpflg, & - & 'natomegaa','Natural OmegaA',' ','-') - call wrtlyr(jnatomegac(iogrp),LYR_NATOMEGAC(iogrp),1.,0.,cmpflg, & - & 'natomegac','Natural OmegaC',' ','-') + call wrtlyr(jnatco3(iogrp), LYR_NATCO3(iogrp), 1e3, 0.,cmpflg,'natco3') + call wrtlyr(jnatalkali(iogrp), LYR_NATALKALI(iogrp),1e3, 0.,cmpflg,'nattalk') + call wrtlyr(jnatdic(iogrp), LYR_NATDIC(iogrp), 1e3, 0.,cmpflg,'natdissic') + call wrtlyr(jnatcalc(iogrp), LYR_NATCALC(iogrp), 1e3, 0.,cmpflg,'natcalc') + call wrtlyr(jnatph(iogrp), LYR_NATPH(iogrp), -1., 0.,cmpflg,'natph') + call wrtlyr(jnatomegaa(iogrp), LYR_NATOMEGAA(iogrp),1., 0.,cmpflg,'natomegaa') + call wrtlyr(jnatomegac(iogrp), LYR_NATOMEGAC(iogrp),1., 0.,cmpflg,'natomegac') #endif #ifdef BROMO - call wrtlyr(jbromo(iogrp),LYR_BROMO(iogrp),1e3,0.,cmpflg, & - & 'bromo','Bromoform',' ','mol CHBr3 m-3') + call wrtlyr(jbromo(iogrp), LYR_BROMO(iogrp), 1e3, 0.,cmpflg,'bromo') #endif ! --- Store 3d level fields - call wrtlvl(jlvldic(iogrp),LVL_DIC(iogrp),rnacc*1e3,0.,cmpflg, & - & 'dissiclvl','Dissolved inorganic carbon',' ','mol C m-3') - call wrtlvl(jlvlalkali(iogrp),LVL_ALKALI(iogrp),rnacc*1e3,0., & - & cmpflg, 'talklvl','Alkalinity',' ','eq m-3') - call wrtlvl(jlvlphosph(iogrp),LVL_PHOSPH(iogrp),rnacc*1e3,0., & - & cmpflg,'po4lvl','Phosphorus',' ','mol P m-3') - call wrtlvl(jlvloxygen(iogrp),LVL_OXYGEN(iogrp),rnacc*1e3,0., & - & cmpflg,'o2lvl','Oxygen',' ','mol O2 m-3') - call wrtlvl(jlvlano3(iogrp),LVL_ANO3(iogrp),rnacc*1e3,0.,cmpflg, & - & 'no3lvl','Nitrate',' ','mol N m-3') - call wrtlvl(jlvlsilica(iogrp),LVL_SILICA(iogrp),rnacc*1e3,0., & - & cmpflg, 'silvl','Silicate',' ','mol Si m-3') - call wrtlvl(jlvldoc(iogrp),LVL_DOC(iogrp),rnacc*1e3,0.,cmpflg, & - & 'dissoclvl','Dissolved organic carbon',' ','mol P m-3') - call wrtlvl(jlvlphyto(iogrp),LVL_PHYTO(iogrp),rnacc*1e3,0.,cmpflg, & - & 'phyclvl','Phytoplankton',' ','mol P m-3') - call wrtlvl(jlvlgrazer(iogrp),LVL_GRAZER(iogrp),rnacc*1e3,0., & - & cmpflg,'zooclvl','Zooplankton',' ','mol P m-3') - call wrtlvl(jlvlpoc(iogrp),LVL_POC(iogrp),rnacc*1e3,0.,cmpflg, & - & 'detoclvl','Detritus',' ','mol P m-3') - call wrtlvl(jlvlcalc(iogrp),LVL_CALC(iogrp),rnacc*1e3,0.,cmpflg, & - & 'calclvl','CaCO3 shells',' ','mol C m-3') - call wrtlvl(jlvlopal(iogrp),LVL_OPAL(iogrp),rnacc*1e3,0.,cmpflg, & - & 'opallvl','Opal shells',' ','mol Si m-3') - call wrtlvl(jlvliron(iogrp),LVL_IRON(iogrp),rnacc*1e3,0.,cmpflg, & - & 'dfelvl','Dissolved iron',' ','mol Fe m-3') - call wrtlvl(jlvlphosy(iogrp),LVL_PHOSY(iogrp),rnacc*1e3/dtbgc,0., & - & cmpflg,'pplvl','Primary production',' ','mol C m-3 s-1') - call wrtlvl(jlvlco3(iogrp),LVL_CO3(iogrp),rnacc*1e3,0.,cmpflg, & - & 'co3lvl','Carbonate ions',' ','mol C m-3') - call wrtlvl(jlvlph(iogrp),LVL_PH(iogrp),-1.,0.,cmpflg, & - & 'phlvl','pH',' ','-log10([h+])') - call wrtlvl(jlvlomegaa(iogrp),LVL_OMEGAA(iogrp),rnacc,0.,cmpflg, & - & 'omegaalvl','OmegaA',' ','-') - call wrtlvl(jlvlomegac(iogrp),LVL_OMEGAC(iogrp),rnacc,0.,cmpflg, & - & 'omegaclvl','OmegaC',' ','-') - call wrtlvl(jlvln2o(iogrp),LVL_N2O(iogrp),rnacc*1e3,0.,cmpflg, & - & 'n2olvl','N2O',' ','mol N2O m-3') - call wrtlvl(jlvlprefo2(iogrp),LVL_PREFO2(iogrp),rnacc*1e3,0., & - & cmpflg,'p_o2lvl','Preformed oxygen',' ','mol O2 m-3') - call wrtlvl(jlvlo2sat(iogrp),LVL_O2SAT(iogrp),rnacc*1e3,0., & - & cmpflg,'satoxylvl','Saturated oxygen',' ','mol O2 m-3') - call wrtlvl(jlvlprefpo4(iogrp),LVL_PREFPO4(iogrp),rnacc*1e3,0., & - & cmpflg,'p_po4lvl','Preformed phosphorus',' ','mol P m-3') - call wrtlvl(jlvlprefalk(iogrp),LVL_PREFALK(iogrp),rnacc*1e3,0., & - & cmpflg, 'p_talklvl','Preformed alkalinity',' ','eq m-3') - call wrtlvl(jlvlprefdic(iogrp),LVL_PREFDIC(iogrp),rnacc*1e3,0., & - & cmpflg, 'p_diclvl','Preformed DIC',' ','mol C m-3') - call wrtlvl(jlvldicsat(iogrp),LVL_DICSAT(iogrp),rnacc*1e3,0., & - & cmpflg, 'sat_diclvl','Saturated DIC',' ','mol C m-3') + call wrtlvl(jlvldic(iogrp), LVL_DIC(iogrp), rnacc*1e3, 0.,cmpflg,'dissiclvl') + call wrtlvl(jlvlalkali(iogrp), LVL_ALKALI(iogrp), rnacc*1e3, 0.,cmpflg,'talklvl') + call wrtlvl(jlvlphosph(iogrp), LVL_PHOSPH(iogrp), rnacc*1e3, 0.,cmpflg,'po4lvl') + call wrtlvl(jlvloxygen(iogrp), LVL_OXYGEN(iogrp), rnacc*1e3, 0.,cmpflg,'o2lvl') + call wrtlvl(jlvlano3(iogrp), LVL_ANO3(iogrp), rnacc*1e3, 0.,cmpflg,'no3lvl') + call wrtlvl(jlvlsilica(iogrp), LVL_SILICA(iogrp), rnacc*1e3, 0.,cmpflg,'silvl') + call wrtlvl(jlvldoc(iogrp), LVL_DOC(iogrp), rnacc*1e3, 0.,cmpflg,'dissoclvl') + call wrtlvl(jlvlphyto(iogrp), LVL_PHYTO(iogrp), rnacc*1e3, 0.,cmpflg,'phyclvl') + call wrtlvl(jlvlgrazer(iogrp), LVL_GRAZER(iogrp), rnacc*1e3, 0.,cmpflg,'zooclvl') + call wrtlvl(jlvlpoc(iogrp), LVL_POC(iogrp), rnacc*1e3, 0.,cmpflg,'detoclvl') + call wrtlvl(jlvlcalc(iogrp), LVL_CALC(iogrp), rnacc*1e3, 0.,cmpflg,'calclvl') + call wrtlvl(jlvlopal(iogrp), LVL_OPAL(iogrp), rnacc*1e3, 0.,cmpflg,'opallvl') + call wrtlvl(jlvliron(iogrp), LVL_IRON(iogrp), rnacc*1e3, 0.,cmpflg,'dfelvl') + call wrtlvl(jlvlphosy(iogrp), LVL_PHOSY(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'pplvl') + call wrtlvl(jlvlco3(iogrp), LVL_CO3(iogrp), rnacc*1e3, 0.,cmpflg,'co3lvl') + call wrtlvl(jlvlph(iogrp), LVL_PH(iogrp), -1., 0.,cmpflg,'phlvl') + call wrtlvl(jlvlomegaa(iogrp), LVL_OMEGAA(iogrp), rnacc, 0.,cmpflg,'omegaalvl') + call wrtlvl(jlvlomegac(iogrp), LVL_OMEGAC(iogrp), rnacc, 0.,cmpflg,'omegaclvl') + call wrtlvl(jlvln2o(iogrp), LVL_N2O(iogrp), rnacc*1e3, 0.,cmpflg,'n2olvl') + call wrtlvl(jlvlprefo2(iogrp), LVL_PREFO2(iogrp), rnacc*1e3, 0.,cmpflg,'p_o2lvl') + call wrtlvl(jlvlo2sat(iogrp), LVL_O2SAT(iogrp), rnacc*1e3, 0.,cmpflg,'satoxylvl') + call wrtlvl(jlvlprefpo4(iogrp), LVL_PREFPO4(iogrp), rnacc*1e3, 0.,cmpflg,'p_po4lvl') + call wrtlvl(jlvlprefalk(iogrp), LVL_PREFALK(iogrp), rnacc*1e3, 0.,cmpflg,'p_talklvl') + call wrtlvl(jlvlprefdic(iogrp), LVL_PREFDIC(iogrp), rnacc*1e3, 0.,cmpflg,'p_diclvl') + call wrtlvl(jlvldicsat(iogrp), LVL_DICSAT(iogrp), rnacc*1e3, 0.,cmpflg,'sat_diclvl') #ifdef cisonew - call wrtlvl(jlvldic13(iogrp),LVL_DIC13(iogrp),rnacc*1.e3, & - & 0.,cmpflg,'dissic13lvl','Dissolved C13',' ','mol 13C m-3') - call wrtlvl(jlvldic14(iogrp),LVL_DIC14(iogrp),rnacc*1.e3*c14fac, & - & 0.,cmpflg,'dissic14lvl','Dissolved C14',' ','mol 14C m-3') - call wrtlvl(jlvld13c(iogrp),LVL_D13C(iogrp),rnacc, & - & 0.,cmpflg,'delta13clvl','delta13C of DIC',' ','permil') - call wrtlvl(jlvld14c(iogrp),LVL_D14C(iogrp),rnacc, & - & 0.,cmpflg,'delta14clvl','delta14C of DIC',' ','permil') - call wrtlvl(jlvlbigd14c(iogrp),LVL_BIGD14C(iogrp),rnacc, & - & 0.,cmpflg,'bigdelta14clvl','big delta14C of DIC',' ','permil') - call wrtlvl(jlvlpoc13(iogrp),LVL_POC13(iogrp),rnacc*1e3, & - & 0.,cmpflg,'detoc13lvl','Detritus13',' ','mol P m-3') - call wrtlvl(jlvldoc13(iogrp),LVL_DOC13(iogrp),rnacc*1e3, & - & 0.,cmpflg,'dissoc13lvl','Dissolved organic carbon13',' ', & - & 'mol P m-3') - call wrtlvl(jlvlcalc13(iogrp),LVL_CALC13(iogrp),rnacc*1e3, & - & 0.,cmpflg,'calc13lvl','Ca13CO3 shells',' ','mol 13C m-3') - call wrtlvl(jlvlphyto13(iogrp),LVL_PHYTO13(iogrp),rnacc*1e3, & - & 0.,cmpflg,'phyc13lvl','Phytoplankton13',' ','mol P m-3') - call wrtlvl(jlvlgrazer13(iogrp),LVL_GRAZER13(iogrp),rnacc*1e3, & - & 0.,cmpflg,'zooc13lvl','Zooplankton13',' ','mol P m-3') + call wrtlvl(jlvldic13(iogrp), LVL_DIC13(iogrp), rnacc*1.e3, 0.,cmpflg,'dissic13lvl') + call wrtlvl(jlvldic14(iogrp), LVL_DIC14(iogrp), rnacc*1.e3*c14fac,0.,cmpflg,'dissic14lvl') + call wrtlvl(jlvld13c(iogrp), LVL_D13C(iogrp), rnacc, 0.,cmpflg,'delta13clvl') + call wrtlvl(jlvld14c(iogrp), LVL_D14C(iogrp), rnacc, 0.,cmpflg,'delta14clvl') + call wrtlvl(jlvlbigd14c(iogrp), LVL_BIGD14C(iogrp), rnacc, 0.,cmpflg,'bigdelta14clvl') + call wrtlvl(jlvlpoc13(iogrp), LVL_POC13(iogrp), rnacc*1e3, 0.,cmpflg,'detoc13lvl') + call wrtlvl(jlvldoc13(iogrp), LVL_DOC13(iogrp), rnacc*1e3, 0.,cmpflg,'dissoc13lvl') + call wrtlvl(jlvlcalc13(iogrp), LVL_CALC13(iogrp), rnacc*1e3, 0.,cmpflg,'calc13lvl') + call wrtlvl(jlvlphyto13(iogrp), LVL_PHYTO13(iogrp), rnacc*1e3, 0.,cmpflg,'phyc13lvl') + call wrtlvl(jlvlgrazer13(iogrp), LVL_GRAZER13(iogrp), rnacc*1e3, 0.,cmpflg,'zooc13lvl') #endif #ifdef AGG - call wrtlvl(jlvlnos(iogrp),LVL_NOS(iogrp), & - & rnacc,0.,cmpflg,'noslvl', & - & 'Marine snow aggregates per cm^3 sea water',' ','1/cm^3') - call wrtlvl(jlvlwphy(iogrp),LVL_WPHY(iogrp), & - & rnacc,0.,cmpflg,'wphylvl', & - & 'Av. mass sinking speed of marine snow',' ','m/day') - call wrtlvl(jlvlwnos(iogrp),LVL_WNOS(iogrp), & - & rnacc,0.,cmpflg,'wnoslvl', & - & 'Av. number sinking speed of marine snow',' ','m/day') - call wrtlvl(jlvleps(iogrp),LVL_EPS(iogrp), & - & rnacc,0.,cmpflg,'epslvl', & - & 'Av. size distribution exponent',' ','-') - call wrtlvl(jlvlasize(iogrp),LVL_ASIZE(iogrp), & - & rnacc,0.,cmpflg,'asizelvl', & - & 'Av. size of marine snow aggregates',' ','nb. of cells') + call wrtlvl(jlvlnos(iogrp), LVL_NOS(iogrp), rnacc, 0.,cmpflg,'noslvl') + call wrtlvl(jlvlwphy(iogrp), LVL_WPHY(iogrp), rnacc, 0.,cmpflg,'wphylvl') + call wrtlvl(jlvlwnos(iogrp), LVL_WNOS(iogrp), rnacc, 0.,cmpflg,'wnoslvl') + call wrtlvl(jlvleps(iogrp), LVL_EPS(iogrp), rnacc, 0.,cmpflg,'epslvl') + call wrtlvl(jlvlasize(iogrp), LVL_ASIZE(iogrp), rnacc, 0.,cmpflg,'asizelvl') #endif #ifdef CFC - call wrtlvl(jlvlcfc11(iogrp),LVL_CFC11(iogrp),rnacc*1e3,0.,cmpflg, & - & 'cfc11lvl','CFC-11',' ','mol cfc11 m-3') - call wrtlvl(jlvlcfc12(iogrp),LVL_CFC12(iogrp),rnacc*1e3,0.,cmpflg, & - & 'cfc12lvl','CFC-12',' ','mol cfc12 m-3') - call wrtlvl(jlvlsf6(iogrp),LVL_SF6(iogrp),rnacc*1e3,0.,cmpflg, & - & 'sf6lvl','SF-6',' ','mol sf6 m-3') + call wrtlvl(jlvlcfc11(iogrp), LVL_CFC11(iogrp), rnacc*1e3, 0.,cmpflg,'cfc11lvl') + call wrtlvl(jlvlcfc12(iogrp), LVL_CFC12(iogrp), rnacc*1e3, 0.,cmpflg,'cfc12lvl') + call wrtlvl(jlvlsf6(iogrp), LVL_SF6(iogrp), rnacc*1e3, 0.,cmpflg,'sf6lvl') #endif #ifdef natDIC - call wrtlvl(jlvlnatco3(iogrp),LVL_NATCO3(iogrp), & - & rnacc*1e3,0.,cmpflg,'natco3lvl', & - & 'Natural carbonate ions',' ','mol C m-3') - call wrtlvl(jlvlnatalkali(iogrp),LVL_NATALKALI(iogrp), & - & rnacc*1e3,0.,cmpflg,'nattalklvl', & - & 'Natural alkalinity',' ','eq m-3') - call wrtlvl(jlvlnatdic(iogrp),LVL_NATDIC(iogrp), & - & rnacc*1e3,0.,cmpflg,'natdissiclvl', & - & 'Natural dissolved inorganic carbon',' ','mol C m-3') - call wrtlvl(jlvlnatcalc(iogrp),LVL_NATCALC(iogrp), & - & rnacc*1e3,0.,cmpflg,'natcalclvl', & - & 'Natural CaCO3 shells',' ','mol C m-3') - call wrtlvl(jlvlnatph(iogrp),LVL_NATPH(iogrp),-1.,0.,cmpflg, & - & 'natphlvl','Natural pH',' ','-log10([h+])') - call wrtlvl(jlvlnatomegaa(iogrp),LVL_NATOMEGAA(iogrp), & - & rnacc,0.,cmpflg,'natomegaalvl', & - & 'Natural OmegaA',' ','-') - call wrtlvl(jlvlnatomegac(iogrp),LVL_NATOMEGAC(iogrp), & - & rnacc,0.,cmpflg,'natomegaclvl', & - & 'Natural OmegaC',' ','-') + call wrtlvl(jlvlnatco3(iogrp), LVL_NATCO3(iogrp), rnacc*1e3, 0.,cmpflg,'natco3lvl') + call wrtlvl(jlvlnatalkali(iogrp),LVL_NATALKALI(iogrp),rnacc*1e3, 0.,cmpflg,'nattalklvl') + call wrtlvl(jlvlnatdic(iogrp), LVL_NATDIC(iogrp), rnacc*1e3, 0.,cmpflg,'natdissiclvl') + call wrtlvl(jlvlnatcalc(iogrp), LVL_NATCALC(iogrp), rnacc*1e3, 0.,cmpflg,'natcalclvl') + call wrtlvl(jlvlnatph(iogrp), LVL_NATPH(iogrp), -1., 0.,cmpflg,'natphlvl') + call wrtlvl(jlvlnatomegaa(iogrp),LVL_NATOMEGAA(iogrp),rnacc, 0.,cmpflg,'natomegaalvl') + call wrtlvl(jlvlnatomegac(iogrp),LVL_NATOMEGAC(iogrp),rnacc, 0.,cmpflg,'natomegaclvl') #endif #ifdef BROMO - call wrtlvl(jlvlbromo(iogrp),LVL_BROMO(iogrp),rnacc*1e3,0., & - & cmpflg,'bromolvl','Bromoform',' ','mol CHBr3 m-3') + call wrtlvl(jlvlbromo(iogrp), LVL_BROMO(iogrp), rnacc*1e3, 0.,cmpflg,'bromolvl') #endif ! --- Store sediment fields #ifndef sedbypass - call wrtsdm(jpowaic(iogrp),SDM_POWAIC(iogrp),rnacc*1e3,0.,cmpflg, & - & 'powdic','PoWa DIC',' ','mol C m-3') - call wrtsdm(jpowaal(iogrp),SDM_POWAAL(iogrp),rnacc*1e3,0.,cmpflg, & - & 'powalk','PoWa alkalinity',' ','eq m-3') - call wrtsdm(jpowaph(iogrp),SDM_POWAPH(iogrp),rnacc*1e3,0.,cmpflg, & - & 'powpho','PoWa phosphorus',' ','mol P m-3') - call wrtsdm(jpowaox(iogrp),SDM_POWAOX(iogrp),rnacc*1e3,0.,cmpflg, & - & 'powox','PoWa oxygen',' ','mol O2 m-3') - call wrtsdm(jpown2(iogrp),SDM_POWN2(iogrp), rnacc*1e3,0.,cmpflg, & - & 'pown2','PoWa N2',' ','mol N2 m-3') - call wrtsdm(jpowno3(iogrp),SDM_POWNO3(iogrp),rnacc*1e3,0.,cmpflg, & - & 'powno3','PoWa nitrate',' ','mol N m-3') - call wrtsdm(jpowasi(iogrp),SDM_POWASI(iogrp),rnacc*1e3,0.,cmpflg, & - & 'powsi','PoWa silicate',' ','mol Si m-3') - call wrtsdm(jssso12(iogrp),SDM_SSSO12(iogrp),rnacc*1e3,0.,cmpflg, & - & 'ssso12','Sediment detritus',' ','mol P m-3') - call wrtsdm(jssssil(iogrp),SDM_SSSSIL(iogrp),rnacc*1e3,0.,cmpflg, & - & 'ssssil','Sediment silicate',' ','mol Si m-3') - call wrtsdm(jsssc12(iogrp),SDM_SSSC12(iogrp),rnacc*1e3,0.,cmpflg, & - & 'sssc12','Sediment CaCO3',' ','mol C m-3') - call wrtsdm(jssster(iogrp),SDM_SSSTER(iogrp),rnacc,0.,cmpflg, & - & 'ssster','Sediment clay',' ','kg m-3') + call wrtsdm(jpowaic(iogrp), SDM_POWAIC(iogrp), rnacc*1e3, 0.,cmpflg,'powdic') + call wrtsdm(jpowaal(iogrp), SDM_POWAAL(iogrp), rnacc*1e3, 0.,cmpflg,'powalk') + call wrtsdm(jpowaph(iogrp), SDM_POWAPH(iogrp), rnacc*1e3, 0.,cmpflg,'powpho') + call wrtsdm(jpowaox(iogrp), SDM_POWAOX(iogrp), rnacc*1e3, 0.,cmpflg,'powox') + call wrtsdm(jpown2(iogrp), SDM_POWN2(iogrp), rnacc*1e3, 0.,cmpflg,'pown2') + call wrtsdm(jpowno3(iogrp), SDM_POWNO3(iogrp), rnacc*1e3, 0.,cmpflg,'powno3') + call wrtsdm(jpowasi(iogrp), SDM_POWASI(iogrp), rnacc*1e3, 0.,cmpflg,'powsi') + call wrtsdm(jssso12(iogrp), SDM_SSSO12(iogrp), rnacc*1e3, 0.,cmpflg,'ssso12') + call wrtsdm(jssssil(iogrp), SDM_SSSSIL(iogrp), rnacc*1e3, 0.,cmpflg,'ssssil') + call wrtsdm(jsssc12(iogrp), SDM_SSSC12(iogrp), rnacc*1e3, 0.,cmpflg,'sssc12') + call wrtsdm(jssster(iogrp), SDM_SSSTER(iogrp), rnacc, 0.,cmpflg,'ssster') ! --- Store sediment burial fields - call wrtbur(jburssso12(iogrp),BUR_SSSO12(iogrp),rnacc*1e3,0., & - & cmpflg,'buro12','Burial org carbon',' ','mol P m-2') - call wrtbur(jbursssc12(iogrp),BUR_SSSC12(iogrp),rnacc*1e3,0., & - & cmpflg,'burc12','Burial CaCO3',' ','mol C m-2') - call wrtbur(jburssssil(iogrp),BUR_SSSSIL(iogrp),rnacc*1e3,0., & - & cmpflg,'bursil','Burial silicate',' ','mol Si m-2') - call wrtbur(jburssster(iogrp),BUR_SSSTER(iogrp),rnacc,0., & - & cmpflg,'burter','Burial clay',' ','kg m-2') + call wrtbur(jburssso12(iogrp), BUR_SSSO12(iogrp), rnacc*1e3, 0.,cmpflg,'buro12') + call wrtbur(jbursssc12(iogrp), BUR_SSSC12(iogrp), rnacc*1e3, 0.,cmpflg,'burc12') + call wrtbur(jburssssil(iogrp), BUR_SSSSIL(iogrp), rnacc*1e3, 0.,cmpflg,'bursil') + call wrtbur(jburssster(iogrp), BUR_SSSTER(iogrp), rnacc, 0.,cmpflg,'burter') #endif ! --- close netcdf file @@ -914,6 +667,7 @@ subroutine ncwrt_bgc(iogrp) call inisrf(jsrfsilica(iogrp),0.) call inisrf(jsrfiron(iogrp),0.) call inisrf(jsrfphyto(iogrp),0.) + call inisrf(jsrfph(iogrp),0.) call inisrf(jintphosy(iogrp),0.) call inisrf(jintnfix(iogrp),0.) call inisrf(jintdnit(iogrp),0.) @@ -960,6 +714,7 @@ subroutine ncwrt_bgc(iogrp) call inisrf(jsrfnatalk(iogrp),0.) call inisrf(jnatpco2(iogrp),0.) call inisrf(jnatco2fx(iogrp),0.) + call inisrf(jsrfnatph(iogrp),0.) #endif #ifdef BROMO call inisrf(jsrfbromo(iogrp),0.) @@ -1138,7 +893,7 @@ subroutine hamoccvardef(iogrp,timeunits,calendar,cmpflg) & srf_co2fxu,srf_oxflux,srf_niflux,srf_dms,srf_dmsprod, & & srf_dms_bac,srf_dms_uv,srf_export,srf_exposi,srf_expoca, & & srf_dic,srf_alkali,srf_phosph,srf_oxygen,srf_ano3,srf_silica, & - & srf_iron,srf_phyto,int_phosy,int_nfix,int_dnit,flx_car0100, & + & srf_iron,srf_phyto,srf_ph,int_phosy,int_nfix,int_dnit,flx_car0100, & & flx_car0500,flx_car1000,flx_car2000,flx_car4000,flx_car_bot, & & flx_bsi0100,flx_bsi0500,flx_bsi1000,flx_bsi2000,flx_bsi4000, & & flx_bsi_bot,flx_cal0100,flx_cal0500,flx_cal1000,flx_cal2000, & @@ -1180,7 +935,7 @@ subroutine hamoccvardef(iogrp,timeunits,calendar,cmpflg) #endif #ifdef natDIC use mo_bgcmean, only: srf_natdic,srf_natalkali,srf_natpco2, & - & srf_natco2fx,lyr_natco3,lyr_natalkali,lyr_natdic, & + & srf_natco2fx,srf_natph,lyr_natco3,lyr_natalkali,lyr_natdic, & & lyr_natcalc,lyr_natph,lyr_natomegaa,lyr_natomegac, & & lvl_natalkali,lvl_natdic,lvl_natcalc,lvl_natph, & & lvl_natomegaa,lvl_natomegac,lvl_natco3 @@ -1264,6 +1019,8 @@ subroutine hamoccvardef(iogrp,timeunits,calendar,cmpflg) & 'Surface dissolved iron',' ','mol Fe m-3',0) call ncdefvar3d(SRF_PHYTO(iogrp),cmpflg,'p','srfphyc', & & 'Surface phytoplankton',' ','mol P m-3',0) + call ncdefvar3d(SRF_PH(iogrp),cmpflg,'p','srfph', & + & 'Surface pH',' ','-log10([H+])',0) call ncdefvar3d(INT_PHOSY(iogrp),cmpflg,'p','ppint', & & 'Integrated primary production',' ','mol C m-2 s-1',0) call ncdefvar3d(INT_NFIX(iogrp),cmpflg,'p','nfixint', & @@ -1358,6 +1115,8 @@ subroutine hamoccvardef(iogrp,timeunits,calendar,cmpflg) & 'natpco2','Surface natural PCO2',' ','uatm',0) call ncdefvar3d(SRF_NATCO2FX(iogrp), & & cmpflg,'p','natco2fx','Natural CO2 flux',' ','kg C m-2 s-1',0) + call ncdefvar3d(SRF_NATPH(iogrp),cmpflg,'p','srfnatph', & + & 'Surface natural pH',' ','-log10([H+])',0) #endif #ifdef BROMO call ncdefvar3d(SRF_BROMO(iogrp),cmpflg,'p','srfbromo', & @@ -1422,7 +1181,7 @@ subroutine hamoccvardef(iogrp,timeunits,calendar,cmpflg) call ncdefvar3d(LYR_CO3(iogrp),cmpflg,'p', & & 'co3','Carbonate ions',' ','mol C m-3',1) call ncdefvar3d(LYR_PH(iogrp),cmpflg,'p', & - & 'ph','pH',' ','-log10([h+])',1) + & 'ph','pH',' ','-log10([H+])',1) call ncdefvar3d(LYR_OMEGAA(iogrp),cmpflg,'p', & & 'omegaa','OmegaA',' ','1',1) call ncdefvar3d(LYR_OMEGAC(iogrp),cmpflg,'p', & @@ -1493,7 +1252,7 @@ subroutine hamoccvardef(iogrp,timeunits,calendar,cmpflg) call ncdefvar3d(LYR_NATCALC(iogrp),cmpflg,'p','natcalc', & & 'Natural CaCO3',' ','mol C m-3',1) call ncdefvar3d(LYR_NATPH(iogrp),cmpflg,'p', & - & 'natph','Natural pH',' ','-log10([h+])',1) + & 'natph','Natural pH',' ','-log10([H+])',1) call ncdefvar3d(LYR_NATOMEGAA(iogrp),cmpflg,'p','natomegaa', & & 'Natural OmegaA',' ','1',1) call ncdefvar3d(LYR_NATOMEGAC(iogrp),cmpflg,'p','natomegac', & @@ -1536,7 +1295,7 @@ subroutine hamoccvardef(iogrp,timeunits,calendar,cmpflg) call ncdefvar3d(LVL_CO3(iogrp),cmpflg,'p', & & 'co3lvl','Carbonate ions',' ','mol C m-3',2) call ncdefvar3d(LVL_PH(iogrp),cmpflg,'p', & - & 'phlvl','pH',' ','-log10([h+])',2) + & 'phlvl','pH',' ','-log10([H+])',2) call ncdefvar3d(LVL_OMEGAA(iogrp),cmpflg,'p', & & 'omegaalvl','OmegaA',' ','1',2) call ncdefvar3d(LVL_OMEGAC(iogrp),cmpflg,'p', & @@ -1607,7 +1366,7 @@ subroutine hamoccvardef(iogrp,timeunits,calendar,cmpflg) call ncdefvar3d(LVL_NATCALC(iogrp),cmpflg,'p', & & 'natcalclvl','Natural CaCO3 shells',' ','mol C m-3',2) call ncdefvar3d(LVL_NATPH(iogrp),cmpflg,'p', & - & 'natphlvl','Natural pH',' ','-log10([h+])',2) + & 'natphlvl','Natural pH',' ','-log10([H+])',2) call ncdefvar3d(LVL_NATOMEGAA(iogrp),cmpflg,'p', & & 'natomegaalvl','Natural OmegaA',' ','1',2) call ncdefvar3d(LVL_NATOMEGAC(iogrp),cmpflg,'p', & From fbb4d62de524a5978a3b9b1fda5bbd66056f0ad0 Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Thu, 26 Jan 2023 15:26:34 +0100 Subject: [PATCH 252/366] adjusted burialflx,M4AGO and extNcycle output formatting in ncout_hamocc.F90 according to latest master changes --- hamocc/ncout_hamocc.F90 | 351 ++++++++++++---------------------------- 1 file changed, 101 insertions(+), 250 deletions(-) diff --git a/hamocc/ncout_hamocc.F90 b/hamocc/ncout_hamocc.F90 index d92e4b81..bed05afc 100644 --- a/hamocc/ncout_hamocc.F90 +++ b/hamocc/ncout_hamocc.F90 @@ -578,22 +578,15 @@ subroutine ncwrt_bgc(iogrp) call wrtsrf(jsediffn2(iogrp), FLX_SEDIFFN2(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'sedfn2') call wrtsrf(jsediffno3(iogrp), FLX_SEDIFFNO3(iogrp),rnacc*1e3/dtbgc,0.,cmpflg,'sedfno3') call wrtsrf(jsediffsi(iogrp), FLX_SEDIFFSI(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'sedfsi') - call wrtsrf(jburflxsso12(iogrp),FLX_BURSSO12(iogrp), & - & rnacc*1e3/dtbgc,0.,cmpflg,'burfsso12',' ',' ',' ') - call wrtsrf(jburflxsssc12(iogrp),FLX_BURSSSC12(iogrp), & - & rnacc*1e3/dtbgc,0.,cmpflg,'burfsssc12',' ',' ',' ') - call wrtsrf(jburflxssssil(iogrp),FLX_BURSSSSIL(iogrp), & - & rnacc*1e3/dtbgc,0.,cmpflg,'burfssssil',' ',' ',' ') - call wrtsrf(jburflxssster(iogrp),FLX_BURSSSTER(iogrp), & - & rnacc*1e3/dtbgc,0.,cmpflg,'burfssster',' ',' ',' ') + call wrtsrf(jburflxsso12(iogrp), FLX_BURSSO12(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'burfsso12') + call wrtsrf(jburflxsssc12(iogrp),FLX_BURSSSC12(iogrp),rnacc*1e3/dtbgc,0.,cmpflg,'burfsssc12') + call wrtsrf(jburflxssssil(iogrp),FLX_BURSSSSIL(iogrp),rnacc*1e3/dtbgc,0.,cmpflg,'burfssssil') + call wrtsrf(jburflxssster(iogrp),FLX_BURSSSTER(iogrp),rnacc*1e3/dtbgc,0.,cmpflg,'burfssster') #endif #if defined(extNcycle) && ! defined(sedbypass) - call wrtsrf(jsediffnh4(iogrp),FLX_SEDIFFNH4(iogrp), & - & rnacc*1e3/dtbgc,0.,cmpflg,'sedfnh4',' ',' ',' ') - call wrtsrf(jsediffn2o(iogrp),FLX_SEDIFFN2O(iogrp), & - & rnacc*1e3/dtbgc,0.,cmpflg,'sedfn2o',' ',' ',' ') - call wrtsrf(jsediffno2(iogrp),FLX_SEDIFFNO2(iogrp), & - & rnacc*1e3/dtbgc,0.,cmpflg,'sedfno2',' ',' ',' ') + call wrtsrf(jsediffnh4(iogrp), FLX_SEDIFFNH4(iogrp),rnacc*1e3/dtbgc,0.,cmpflg,'sedfnh4') + call wrtsrf(jsediffn2o(iogrp), FLX_SEDIFFN2O(iogrp),rnacc*1e3/dtbgc,0.,cmpflg,'sedfn2o') + call wrtsrf(jsediffno2(iogrp), FLX_SEDIFFNO2(iogrp),rnacc*1e3/dtbgc,0.,cmpflg,'sedfno2') #endif #ifdef cisonew call wrtsrf(jco213fxd(iogrp), SRF_CO213FXD(iogrp), rnacc*12./dtbgc,0.,cmpflg,'co213fxd') @@ -627,19 +620,13 @@ subroutine ncwrt_bgc(iogrp) #endif #ifdef cisonew call wrtsrf(jatmc13(iogrp), SRF_ATMC13(iogrp), rnacc, 0.,cmpflg,'atmc13') - call wrtsrf(jatmc14(iogrp), SRF_ATMC14(iogrp), rnacc, 0.,cmpflg,'atmc14) + call wrtsrf(jatmc14(iogrp), SRF_ATMC14(iogrp), rnacc, 0.,cmpflg,'atmc14') #endif #ifdef extNcycle - call wrtsrf(jsrfanh4(iogrp),SRF_ANH4(iogrp), & - & rnacc*1e3,0.,cmpflg,'srfnh4', & - & 'Surface ammonium',' ','mol N m-3') - call wrtsrf(jsrfpnh3(iogrp),SRF_PNH3(iogrp),rnacc,0.,cmpflg, & - & 'pnh3','Surface pNH3',' ','natm') - call wrtsrf(jsrfano2(iogrp),SRF_ANO2(iogrp), & - & rnacc*1e3,0.,cmpflg,'srfno2', & - & 'Surface nitrite',' ','mol N m-3') - call wrtsrf(janh3fx(iogrp),SRF_ANH3FX(iogrp),rnacc*1e3/dtbgc,0., & - & cmpflg,'nh3flux','NH3 flux',' ','mol NH3 m-2 s-1') + call wrtsrf(jsrfanh4(iogrp), SRF_ANH4(iogrp), rnacc*1e3, 0.,cmpflg,'srfnh4') + call wrtsrf(jsrfpnh3(iogrp), SRF_PNH3(iogrp), rnacc, 0.,cmpflg,'pnh3') + call wrtsrf(jsrfano2(iogrp), SRF_ANO2(iogrp), rnacc*1e3, 0.,cmpflg,'srfno2') + call wrtsrf(janh3fx(iogrp), SRF_ANH3FX(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'nh3flux') #endif ! --- Store 3d layer fields @@ -706,84 +693,37 @@ subroutine ncwrt_bgc(iogrp) call wrtlyr(jbromo(iogrp), LYR_BROMO(iogrp), 1e3, 0.,cmpflg,'bromo') #endif #ifdef extNcycle - call wrtlyr(janh4(iogrp),LYR_ANH4(iogrp),1e3,0.,cmpflg, & - & 'nh4','Ammonium',' ','mol N m-3') - call wrtlyr(jano2(iogrp),LYR_ANO2(iogrp),1e3,0.,cmpflg, & - & 'no2','Nitrite',' ','mol N m-3') - call wrtlyr(jnitr_NH4(iogrp),LYR_nitr_NH4(iogrp),1e3/dtbgc,0., & - & cmpflg, & - & 'nh4nitr','NH4 nitrification rate',' ','mol N m-3 s-1') - call wrtlyr(jnitr_NO2(iogrp),LYR_nitr_NO2(iogrp),1e3/dtbgc,0., & - & cmpflg, & - & 'no2nitr','NO2 nitrification rate',' ','mol N m-3 s-1') - call wrtlyr(jnitr_N2O_prod(iogrp),LYR_nitr_N2O_prod(iogrp), & - & 1e3/dtbgc,0.,cmpflg, & - & 'nitr_n2o','N2O prod during NH4 nitrification',' ', & - & 'mol N2O m-3 s-1') - call wrtlyr(jnitr_NH4_OM(iogrp),LYR_nitr_NH4_OM(iogrp),1e3/dtbgc, & - & 0.,cmpflg, & - & 'nh4nitr_om','OM production during NH4 nitrification',' ', & - & 'mol P m-3 s-1') - call wrtlyr(jnitr_NO2_OM(iogrp),LYR_nitr_NO2_OM(iogrp),1e3/dtbgc, & - & 0.,cmpflg, & - & 'no2nitr_om','OM production during NO2 nitrification',' ', & - & 'mol P m-3 s-1') - call wrtlyr(jdenit_NO3(iogrp),LYR_denit_NO3(iogrp),1e3/dtbgc,0., & - & cmpflg, & - & 'no3denit','NO3 denitrification rate',' ','mol N m-3 s-1') - call wrtlyr(jdenit_NO2(iogrp),LYR_denit_NO2(iogrp),1e3/dtbgc,0., & - & cmpflg, & - & 'no2denit','NO2 denitrification rate',' ','mol N m-3 s-1') - call wrtlyr(jdenit_N2O(iogrp),LYR_denit_N2O(iogrp),1e3/dtbgc,0., & - & cmpflg, & - & 'n2odenit','N2O denitrification rate',' ','mol N2O m-3 s-1') - call wrtlyr(jDNRA_NO2(iogrp),LYR_DNRA_NO2(iogrp),1e3/dtbgc,0., & - & cmpflg, & - & 'no2dnra','NO2 DNRA rate',' ','mol N m-3 s-1') - call wrtlyr(janmx_N2_prod(iogrp),LYR_anmx_N2_prod(iogrp), & - & 1e3/dtbgc,0.,cmpflg, & - & 'anmx_n2','Anammox N2 production rate',' ','mol N2 m-3 s-1') - call wrtlyr(janmx_OM_prod(iogrp),LYR_anmx_OM_prod(iogrp), & - & 1e3/dtbgc,0.,cmpflg, & - & 'anmx_om','Anammox OM production rate',' ','mol P m-3 s-1') - call wrtlyr(jphosy_NH4(iogrp),LYR_phosy_NH4(iogrp),1e3/dtbgc,0., & - & cmpflg, & - & 'phosy_nh4','PP consumption rate of NH4',' ','mol N m-3 s-1') - call wrtlyr(jphosy_NO3(iogrp),LYR_phosy_NO3(iogrp),1e3/dtbgc,0., & - & cmpflg, & - & 'phosy_no3','PP consumption rate of NO3',' ','mol N m-3 s-1') - call wrtlyr(jremin_aerob(iogrp),LYR_remin_aerob(iogrp),1e3/dtbgc, & - & 0.,cmpflg, & - & 'remina','Aerob remineralization rate',' ','mol N m-3 s-1') - call wrtlyr(jremin_sulf(iogrp),LYR_remin_sulf(iogrp),1e3/dtbgc, & - & 0.,cmpflg, & - & 'remins','Sulfate remineralization rate',' ','mol P m-3 s-1') + call wrtlyr(janh4(iogrp), LYR_ANH4(iogrp), 1e3, 0.,cmpflg,'nh4') + call wrtlyr(jano2(iogrp), LYR_ANO2(iogrp), 1e3, 0.,cmpflg,'no2') + call wrtlyr(jnitr_NH4(iogrp), LYR_nitr_NH4(iogrp), 1e3/dtbgc, 0.,cmpflg,'nh4nitr') + call wrtlyr(jnitr_NO2(iogrp), LYR_nitr_NO2(iogrp), 1e3/dtbgc, 0.,cmpflg,'no2nitr') + call wrtlyr(jnitr_N2O_prod(iogrp),LYR_nitr_N2O_prod(iogrp),1e3/dtbgc, 0.,cmpflg,'nitr_n2o') + call wrtlyr(jnitr_NH4_OM(iogrp), LYR_nitr_NH4_OM(iogrp),1e3/dtbgc, 0.,cmpflg,'nh4nitr_om') + call wrtlyr(jnitr_NO2_OM(iogrp), LYR_nitr_NO2_OM(iogrp),1e3/dtbgc, 0.,cmpflg,'no2nitr_om') + call wrtlyr(jdenit_NO3(iogrp), LYR_denit_NO3(iogrp),1e3/dtbgc, 0.,cmpflg,'no3denit') + call wrtlyr(jdenit_NO2(iogrp), LYR_denit_NO2(iogrp),1e3/dtbgc, 0.,cmpflg,'no2denit') + call wrtlyr(jdenit_N2O(iogrp), LYR_denit_N2O(iogrp),1e3/dtbgc, 0.,cmpflg,'n2odenit') + call wrtlyr(jDNRA_NO2(iogrp), LYR_DNRA_NO2(iogrp), 1e3/dtbgc, 0.,cmpflg,'no2dnra') + call wrtlyr(janmx_N2_prod(iogrp),LYR_anmx_N2_prod(iogrp),1e3/dtbgc, 0.,cmpflg,'anmx_n2') + call wrtlyr(janmx_OM_prod(iogrp),LYR_anmx_OM_prod(iogrp),1e3/dtbgc, 0.,cmpflg,'anmx_om') + call wrtlyr(jphosy_NH4(iogrp), LYR_phosy_NH4(iogrp),1e3/dtbgc, 0.,cmpflg,'phosy_nh4') + call wrtlyr(jphosy_NO3(iogrp), LYR_phosy_NO3(iogrp),1e3/dtbgc, 0.,cmpflg,'phosy_no3') + call wrtlyr(jremin_aerob(iogrp), LYR_remin_aerob(iogrp),1e3/dtbgc, 0.,cmpflg,'remina') + call wrtlyr(jremin_sulf(iogrp), LYR_remin_sulf(iogrp),1e3/dtbgc, 0.,cmpflg,'remins') #endif ! M4AGO - call wrtlyr(jagg_ws(iogrp),LYR_agg_ws(iogrp),1.,0.,cmpflg, & - & 'agg_ws','aggregate mean settling velocity',' ','m d-1') - call wrtlyr(jdynvis(iogrp),LYR_dynvis(iogrp),1.,0.,cmpflg, & - & 'dynvis','dynamic viscosity of sea water',' ','kg m-1 s-1') - call wrtlyr(jagg_stick(iogrp),LYR_agg_stick(iogrp),1.,0.,cmpflg, & - & 'agg_stick','aggregate mean stickiness',' ','-') - call wrtlyr(jagg_stickf(iogrp),LYR_agg_stickf(iogrp),1.,0.,cmpflg, & - & 'agg_stickf','opal frustule stickiness',' ','-') - call wrtlyr(jagg_dmax(iogrp),LYR_agg_dmax(iogrp),1.,0.,cmpflg, & - & 'agg_dmax','aggregate maximum diameter',' ','m') - call wrtlyr(jagg_avdp(iogrp),LYR_agg_avdp(iogrp),1.,0.,cmpflg, & - & 'agg_avdp','mean primary particle diameter',' ','m') - call wrtlyr(jagg_avrhop(iogrp),LYR_agg_avrhop(iogrp),1.,0.,cmpflg, & - & 'agg_avrhop','mean primary particle density',' ','kg m-3') - call wrtlyr(jagg_avdC(iogrp),LYR_agg_avdC(iogrp),1.,0.,cmpflg, & - & 'agg_avdC','Conc.-weighted mean aggregate diameter',' ','m') - call wrtlyr(jagg_df(iogrp),LYR_agg_df(iogrp),1.,0.,cmpflg, & - & 'agg_df','aggregate fractal dimension',' ','-') - call wrtlyr(jagg_b(iogrp),LYR_agg_b(iogrp),1.,0.,cmpflg, & - & 'agg_b','aggregate number distribution slope',' ','-') - call wrtlyr(jagg_Vrhof(iogrp),LYR_agg_Vrhof(iogrp),1.,0.,cmpflg, & - & 'agg_Vrhof','V-weighted aggregate mean density',' ','kg m-3') - call wrtlyr(jagg_Vpor(iogrp),LYR_agg_Vpor(iogrp),1.,0.,cmpflg, & - & 'agg_Vpor','V-weighted aggregate mean porosity',' ','-') + call wrtlyr(jagg_ws(iogrp), LYR_agg_ws(iogrp), 1., 0.,cmpflg,'agg_ws') + call wrtlyr(jdynvis(iogrp), LYR_dynvis(iogrp), 1., 0.,cmpflg,'dynvis') + call wrtlyr(jagg_stick(iogrp), LYR_agg_stick(iogrp),1., 0.,cmpflg,'agg_stick') + call wrtlyr(jagg_stickf(iogrp), LYR_agg_stickf(iogrp),1., 0.,cmpflg,'agg_stickf') + call wrtlyr(jagg_dmax(iogrp), LYR_agg_dmax(iogrp), 1., 0.,cmpflg,'agg_dmax') + call wrtlyr(jagg_avdp(iogrp), LYR_agg_avdp(iogrp), 1., 0.,cmpflg,'agg_avdp') + call wrtlyr(jagg_avrhop(iogrp), LYR_agg_avrhop(iogrp),1., 0.,cmpflg,'agg_avrhop') + call wrtlyr(jagg_avdC(iogrp), LYR_agg_avdC(iogrp), 1., 0.,cmpflg,'agg_avdC') + call wrtlyr(jagg_df(iogrp), LYR_agg_df(iogrp), 1., 0.,cmpflg,'agg_df') + call wrtlyr(jagg_b(iogrp), LYR_agg_b(iogrp), 1., 0.,cmpflg,'agg_b') + call wrtlyr(jagg_Vrhof(iogrp), LYR_agg_Vrhof(iogrp),1., 0.,cmpflg,'agg_Vrhof') + call wrtlyr(jagg_Vpor(iogrp), LYR_agg_Vpor(iogrp), 1., 0.,cmpflg,'agg_Vpor') ! --- Store 3d level fields call wrtlvl(jlvldic(iogrp), LVL_DIC(iogrp), rnacc*1e3, 0.,cmpflg,'dissiclvl') @@ -848,164 +788,75 @@ subroutine ncwrt_bgc(iogrp) call wrtlvl(jlvlbromo(iogrp), LVL_BROMO(iogrp), rnacc*1e3, 0.,cmpflg,'bromolvl') #endif #ifdef extNcycle - call wrtlvl(jlvlanh4(iogrp),LVL_ANH4(iogrp),rnacc*1e3,0.,cmpflg, & - & 'nh4lvl','Ammonium',' ','mol N m-3') - call wrtlvl(jlvlano2(iogrp),LVL_ANO2(iogrp),rnacc*1e3,0.,cmpflg, & - & 'no2lvl','Nitrite',' ','mol N m-3') - call wrtlvl(jlvl_nitr_NH4(iogrp),LVL_nitr_NH4(iogrp), & - & rnacc*1e3/dtbgc,0.,cmpflg, & - & 'nh4nitrlvl','NH4 nitrification rate',' ','mol N m-3 s-1') - call wrtlvl(jlvl_nitr_NO2(iogrp),LVL_nitr_NO2(iogrp), & - & rnacc*1e3/dtbgc,0.,cmpflg, & - & 'no2nitrlvl','NO2 nitrification rate',' ','mol N m-3 s-1') - call wrtlvl(jlvl_nitr_N2O_prod(iogrp),LVL_nitr_N2O_prod(iogrp), & - & rnacc*1e3/dtbgc,0.,cmpflg, & - & 'nitr_n2olvl','N2O prod during NH4 nitrification',' ', & - & 'mol N2O m-3 s-1') - call wrtlvl(jlvl_nitr_NH4_OM(iogrp),LVL_nitr_NH4_OM(iogrp), & - & rnacc*1e3/dtbgc,0.,cmpflg, & - & 'nh4nitr_omlvl','OM production during NH4 nitrification',' ', & - & 'mol P m-3 s-1') - call wrtlvl(jlvl_nitr_NO2_OM(iogrp),LVL_nitr_NO2_OM(iogrp), & - & rnacc*1e3/dtbgc,0.,cmpflg, & - & 'no2nitr_omlvl','OM production during NO2 nitrification',' ', & - & 'mol P m-3 s-1') - call wrtlvl(jlvl_denit_NO3(iogrp),LVL_denit_NO3(iogrp), & - & rnacc*1e3/dtbgc,0.,cmpflg, & - & 'no3denitlvl','NO3 denitrification rate',' ','mol N m-3 s-1') - call wrtlvl(jlvl_denit_NO2(iogrp),LVL_denit_NO2(iogrp), & - & rnacc*1e3/dtbgc,0.,cmpflg, & - & 'no2denitlvl','NO2 denitrification rate',' ','mol N m-3 s-1') - call wrtlvl(jlvl_denit_N2O(iogrp),LVL_denit_N2O(iogrp), & - & rnacc*1e3/dtbgc,0.,cmpflg, & - & 'n2odenitlvl','N2O denitrification rate',' ','mol N2O m-3 s-1') - call wrtlvl(jlvl_DNRA_NO2(iogrp),LVL_DNRA_NO2(iogrp), & - & rnacc*1e3/dtbgc,0.,cmpflg, & - & 'no2dnralvl','NO2 DNRA rate',' ','mol N m-3 s-1') - call wrtlvl(jlvl_anmx_N2_prod(iogrp),LVL_anmx_N2_prod(iogrp), & - & rnacc*1e3/dtbgc,0.,cmpflg, & - & 'anmx_n2lvl','Anammox N2 production rate',' ','mol N2 m-3 s-1') - call wrtlvl(jlvl_anmx_OM_prod(iogrp),LVL_anmx_OM_prod(iogrp), & - & rnacc*1e3/dtbgc,0.,cmpflg, & - & 'anmx_omlvl','Anammox OM production rate',' ','mol P m-3 s-1') - call wrtlvl(jlvl_phosy_NH4(iogrp),LVL_phosy_NH4(iogrp), & - & rnacc*1e3/dtbgc,0.,cmpflg, & - & 'phosy_nh4lvl','PP consumption rate of NH4',' ', & - & 'mol N m-3 s-1') - call wrtlvl(jlvl_phosy_NO3(iogrp),LVL_phosy_NO3(iogrp), & - & rnacc*1e3/dtbgc,0.,cmpflg, & - & 'phosy_no3lvl','PP consumption rate of NO3',' ', & - & 'mol N m-3 s-1') - call wrtlvl(jlvl_remin_aerob(iogrp),LVL_remin_aerob(iogrp), & - & rnacc*1e3/dtbgc,0.,cmpflg, & - & 'reminalvl','Aerob remineralization rate',' ','mol N m-3 s-1') - call wrtlvl(jlvl_remin_sulf(iogrp),LVL_remin_sulf(iogrp), & - & rnacc*1e3/dtbgc,0.,cmpflg, & - & 'reminslvl','Sulfate remineralization rate',' ','mol P m-3 s-1') + call wrtlvl(jlvlanh4(iogrp), LVL_ANH4(iogrp), rnacc*1e3, 0.,cmpflg,'nh4lvl') + call wrtlvl(jlvlano2(iogrp), LVL_ANO2(iogrp), rnacc*1e3, 0.,cmpflg,'no2lvl') + call wrtlvl(jlvl_nitr_NH4(iogrp), LVL_nitr_NH4(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'nh4nitrlvl') + call wrtlvl(jlvl_nitr_NO2(iogrp), LVL_nitr_NO2(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'no2nitrlvl') + call wrtlvl(jlvl_nitr_N2O_prod(iogrp),LVL_nitr_N2O_prod(iogrp),rnacc*1e3/dtbgc,0.,cmpflg,'nitr_n2olvl') + call wrtlvl(jlvl_nitr_NH4_OM(iogrp), LVL_nitr_NH4_OM(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'nh4nitr_omlvl') + call wrtlvl(jlvl_nitr_NO2_OM(iogrp), LVL_nitr_NO2_OM(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'no2nitr_omlvl') + call wrtlvl(jlvl_denit_NO3(iogrp), LVL_denit_NO3(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'no3denitlvl') + call wrtlvl(jlvl_denit_NO2(iogrp), LVL_denit_NO2(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'no2denitlvl') + call wrtlvl(jlvl_denit_N2O(iogrp), LVL_denit_N2O(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'n2odenitlvl') + call wrtlvl(jlvl_DNRA_NO2(iogrp), LVL_DNRA_NO2(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'no2dnralvl') + call wrtlvl(jlvl_anmx_N2_prod(iogrp), LVL_anmx_N2_prod(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'anmx_n2lvl') + call wrtlvl(jlvl_anmx_OM_prod(iogrp), LVL_anmx_OM_prod(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'anmx_omlvl') + call wrtlvl(jlvl_phosy_NH4(iogrp), LVL_phosy_NH4(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'phosy_nh4lvl') + call wrtlvl(jlvl_phosy_NO3(iogrp), LVL_phosy_NO3(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'phosy_no3lvl') + call wrtlvl(jlvl_remin_aerob(iogrp), LVL_remin_aerob(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'reminalvl') + call wrtlvl(jlvl_remin_sulf(iogrp), LVL_remin_sulf(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'reminslvl') #endif ! M4AGO - call wrtlvl(jlvl_agg_ws(iogrp),LVL_agg_ws(iogrp),rnacc,0.,cmpflg, & - & 'agg_wslvl','aggregate mean settling velocity',' ','m d-1') - call wrtlvl(jlvl_dynvis(iogrp),LVL_dynvis(iogrp),rnacc,0.,cmpflg, & - & 'dynvislvl','dynamic viscosity of sea water',' ','kg m-1 s-1') - call wrtlvl(jlvl_agg_stick(iogrp),LVL_agg_stick(iogrp),rnacc,0., & - & cmpflg, & - & 'agg_sticklvl','aggregate mean stickiness',' ','-') - call wrtlvl(jlvl_agg_stickf(iogrp),LVL_agg_stickf(iogrp),rnacc,0., & - & cmpflg, & - & 'agg_stickflvl','opal frustule stickiness',' ','-') - call wrtlvl(jlvl_agg_dmax(iogrp),LVL_agg_dmax(iogrp),rnacc,0., & - & cmpflg, & - & 'agg_dmaxlvl','aggregate maximum diameter',' ','m') - call wrtlvl(jlvl_agg_avdp(iogrp),LVL_agg_avdp(iogrp),rnacc,0., & - & cmpflg, & - & 'agg_avdplvl','mean primary particle diameter',' ','m') - call wrtlvl(jlvl_agg_avrhop(iogrp),LVL_agg_avrhop(iogrp),rnacc,0., & - & cmpflg, & - & 'agg_avrhoplvl','mean primary particle density',' ','kg m-3') - call wrtlvl(jlvl_agg_avdC(iogrp),LVL_agg_avdC(iogrp),rnacc,0., & - & cmpflg, & - & 'agg_avdClvl','Conc.-weighted mean aggregate diameter',' ','m') - call wrtlvl(jlvl_agg_df(iogrp),LVL_agg_df(iogrp),rnacc,0.,cmpflg, & - & 'agg_dflvl','aggregate fractal dimension',' ','-') - call wrtlvl(jlvl_agg_b(iogrp),LVL_agg_b(iogrp),rnacc,0.,cmpflg, & - & 'agg_blvl','aggregate number distribution slope',' ','-') - call wrtlvl(jlvl_agg_Vrhof(iogrp),LVL_agg_Vrhof(iogrp),rnacc,0., & - & cmpflg, & - & 'agg_Vrhoflvl','V-weighted aggregate mean density',' ','kg m-3') - call wrtlvl(jlvl_agg_Vpor(iogrp),LVL_agg_Vpor(iogrp),rnacc,0., & - & cmpflg, & - & 'agg_Vporlvl','V-weighted aggregate mean porosity',' ','-') + call wrtlvl(jlvl_agg_ws(iogrp), LVL_agg_ws(iogrp), rnacc, 0.,cmpflg,'agg_wslvl') + call wrtlvl(jlvl_dynvis(iogrp), LVL_dynvis(iogrp), rnacc, 0.,cmpflg,'dynvislvl') + call wrtlvl(jlvl_agg_stick(iogrp), LVL_agg_stick(iogrp), rnacc, 0.,cmpflg,'agg_sticklvl') + call wrtlvl(jlvl_agg_stickf(iogrp), LVL_agg_stickf(iogrp), rnacc, 0.,cmpflg,'agg_stickflvl') + call wrtlvl(jlvl_agg_dmax(iogrp), LVL_agg_dmax(iogrp), rnacc, 0.,cmpflg,'agg_dmaxlvl') + call wrtlvl(jlvl_agg_avdp(iogrp), LVL_agg_avdp(iogrp), rnacc, 0.,cmpflg,'agg_avdplvl') + call wrtlvl(jlvl_agg_avrhop(iogrp), LVL_agg_avrhop(iogrp), rnacc, 0.,cmpflg,'agg_avrhoplvl') + call wrtlvl(jlvl_agg_avdC(iogrp), LVL_agg_avdC(iogrp), rnacc, 0.,cmpflg,'agg_avdClvl') + call wrtlvl(jlvl_agg_df(iogrp), LVL_agg_df(iogrp), rnacc, 0.,cmpflg,'agg_dflvl') + call wrtlvl(jlvl_agg_b(iogrp), LVL_agg_b(iogrp), rnacc, 0.,cmpflg,'agg_blvl') + call wrtlvl(jlvl_agg_Vrhof(iogrp), LVL_agg_Vrhof(iogrp), rnacc, 0.,cmpflg,'agg_Vrhoflvl') + call wrtlvl(jlvl_agg_Vpor(iogrp), LVL_agg_Vpor(iogrp), rnacc, 0.,cmpflg,'agg_Vporlvl') ! --- Store sediment fields #ifndef sedbypass - call wrtsdm(jpowaic(iogrp), SDM_POWAIC(iogrp), rnacc*1e3, 0.,cmpflg,'powdic') - call wrtsdm(jpowaal(iogrp), SDM_POWAAL(iogrp), rnacc*1e3, 0.,cmpflg,'powalk') - call wrtsdm(jpowaph(iogrp), SDM_POWAPH(iogrp), rnacc*1e3, 0.,cmpflg,'powpho') - call wrtsdm(jpowaox(iogrp), SDM_POWAOX(iogrp), rnacc*1e3, 0.,cmpflg,'powox') - call wrtsdm(jpown2(iogrp), SDM_POWN2(iogrp), rnacc*1e3, 0.,cmpflg,'pown2') - call wrtsdm(jpowno3(iogrp), SDM_POWNO3(iogrp), rnacc*1e3, 0.,cmpflg,'powno3') - call wrtsdm(jpowasi(iogrp), SDM_POWASI(iogrp), rnacc*1e3, 0.,cmpflg,'powsi') - call wrtsdm(jssso12(iogrp), SDM_SSSO12(iogrp), rnacc*1e3, 0.,cmpflg,'ssso12') - call wrtsdm(jssssil(iogrp), SDM_SSSSIL(iogrp), rnacc*1e3, 0.,cmpflg,'ssssil') - call wrtsdm(jsssc12(iogrp), SDM_SSSC12(iogrp), rnacc*1e3, 0.,cmpflg,'sssc12') - call wrtsdm(jssster(iogrp), SDM_SSSTER(iogrp), rnacc, 0.,cmpflg,'ssster') + call wrtsdm(jpowaic(iogrp), SDM_POWAIC(iogrp), rnacc*1e3, 0.,cmpflg,'powdic') + call wrtsdm(jpowaal(iogrp), SDM_POWAAL(iogrp), rnacc*1e3, 0.,cmpflg,'powalk') + call wrtsdm(jpowaph(iogrp), SDM_POWAPH(iogrp), rnacc*1e3, 0.,cmpflg,'powpho') + call wrtsdm(jpowaox(iogrp), SDM_POWAOX(iogrp), rnacc*1e3, 0.,cmpflg,'powox') + call wrtsdm(jpown2(iogrp), SDM_POWN2(iogrp), rnacc*1e3, 0.,cmpflg,'pown2') + call wrtsdm(jpowno3(iogrp), SDM_POWNO3(iogrp), rnacc*1e3, 0.,cmpflg,'powno3') + call wrtsdm(jpowasi(iogrp), SDM_POWASI(iogrp), rnacc*1e3, 0.,cmpflg,'powsi') + call wrtsdm(jssso12(iogrp), SDM_SSSO12(iogrp), rnacc*1e3, 0.,cmpflg,'ssso12') + call wrtsdm(jssssil(iogrp), SDM_SSSSIL(iogrp), rnacc*1e3, 0.,cmpflg,'ssssil') + call wrtsdm(jsssc12(iogrp), SDM_SSSC12(iogrp), rnacc*1e3, 0.,cmpflg,'sssc12') + call wrtsdm(jssster(iogrp), SDM_SSSTER(iogrp), rnacc, 0.,cmpflg,'ssster') ! --- Store sediment burial fields - call wrtbur(jburssso12(iogrp), BUR_SSSO12(iogrp), rnacc*1e3, 0.,cmpflg,'buro12') - call wrtbur(jbursssc12(iogrp), BUR_SSSC12(iogrp), rnacc*1e3, 0.,cmpflg,'burc12') - call wrtbur(jburssssil(iogrp), BUR_SSSSIL(iogrp), rnacc*1e3, 0.,cmpflg,'bursil') - call wrtbur(jburssster(iogrp), BUR_SSSTER(iogrp), rnacc, 0.,cmpflg,'burter') + call wrtbur(jburssso12(iogrp), BUR_SSSO12(iogrp), rnacc*1e3, 0.,cmpflg,'buro12') + call wrtbur(jbursssc12(iogrp), BUR_SSSC12(iogrp), rnacc*1e3, 0.,cmpflg,'burc12') + call wrtbur(jburssssil(iogrp), BUR_SSSSIL(iogrp), rnacc*1e3, 0.,cmpflg,'bursil') + call wrtbur(jburssster(iogrp), BUR_SSSTER(iogrp), rnacc, 0.,cmpflg,'burter') #endif #if defined(extNcycle) && ! defined(sedbypass) - call wrtsdm(jpownh4(iogrp),SDM_POWNH4(iogrp),rnacc*1e3,0.,cmpflg, & - & 'pownh4','PoWa ammonium',' ','mol N m-3') - call wrtsdm(jpown2o(iogrp),SDM_POWN2O(iogrp),rnacc*1e3,0.,cmpflg, & - & 'pown2o','PoWa nitrous oxide',' ','mol N2O m-3') - call wrtsdm(jpowno2(iogrp),SDM_POWNO2(iogrp),rnacc*1e3,0.,cmpflg, & - & 'powno2','PoWa nitrite',' ','mol N m-3') - call wrtsdm(jsdm_nitr_NH4(iogrp),sdm_nitr_NH4(iogrp), & - & rnacc*1e3/dtbgc,0.,cmpflg, & - & 'nh4nitrsdm','NH4 nitrification rate sediment',' ','mol N m-3 s-1') - call wrtsdm(jsdm_nitr_NO2(iogrp),sdm_nitr_NO2(iogrp), & - & rnacc*1e3/dtbgc,0.,cmpflg, & - & 'no2nitrsdm','NO2 nitrification rate sediment',' ','mol N m-3 s-1') - call wrtsdm(jsdm_nitr_N2O_prod(iogrp),sdm_nitr_N2O_prod(iogrp), & - & rnacc*1e3/dtbgc,0.,cmpflg, & - & 'nitr_n2osdm','N2O prod during NH4 nitrification sediment',' ', & - & 'mol N2O m-3 s-1') - call wrtsdm(jsdm_nitr_NH4_OM(iogrp),sdm_nitr_NH4_OM(iogrp), & - & rnacc*1e3/dtbgc,0.,cmpflg, & - & 'nh4nitr_omsdm','OM production during NH4 nitrification sediment',' ', & - & 'mol P m-3 s-1') - call wrtsdm(jsdm_nitr_NO2_OM(iogrp),sdm_nitr_NO2_OM(iogrp), & - & rnacc*1e3/dtbgc,0.,cmpflg, & - & 'no2nitr_omsdm','OM production during NO2 nitrification sediment',' ', & - & 'mol P m-3 s-1') - call wrtsdm(jsdm_denit_NO3(iogrp),sdm_denit_NO3(iogrp), & - & rnacc*1e3/dtbgc,0.,cmpflg, & - & 'no3denitsdm','NO3 denitrification rate sediment',' ','mol N m-3 s-1') - call wrtsdm(jsdm_denit_NO2(iogrp),sdm_denit_NO2(iogrp), & - & rnacc*1e3/dtbgc,0.,cmpflg, & - & 'no2denitsdm','NO2 denitrification rate sediment',' ','mol N m-3 s-1') - call wrtsdm(jsdm_denit_N2O(iogrp),sdm_denit_N2O(iogrp), & - & rnacc*1e3/dtbgc,0.,cmpflg, & - & 'n2odenitsdm','N2O denitrification rate sediment',' ','mol N2O m-3 s-1') - call wrtsdm(jsdm_DNRA_NO2(iogrp),sdm_DNRA_NO2(iogrp), & - & rnacc*1e3/dtbgc,0.,cmpflg, & - & 'no2dnrasdm','NO2 DNRA rate sediment',' ','mol N m-3 s-1') - call wrtsdm(jsdm_anmx_N2_prod(iogrp),sdm_anmx_N2_prod(iogrp), & - & rnacc*1e3/dtbgc,0.,cmpflg, & - & 'anmx_n2sdm','Anammox N2 production rate sediment',' ','mol N2 m-3 s-1') - call wrtsdm(jsdm_anmx_OM_prod(iogrp),sdm_anmx_OM_prod(iogrp), & - & rnacc*1e3/dtbgc,0.,cmpflg, & - & 'anmx_omsdm','Anammox OM production rate sediment',' ','mol P m-3 s-1') - call wrtsdm(jsdm_remin_aerob(iogrp),sdm_remin_aerob(iogrp), & - & rnacc*1e3/dtbgc,0.,cmpflg, & - & 'reminasdm','Aerob remineralization rate sediment',' ','mol N m-3 s-1') - call wrtsdm(jsdm_remin_sulf(iogrp),sdm_remin_sulf(iogrp), & - & rnacc*1e3/dtbgc,0.,cmpflg, & - & 'reminssdm','Sulfate remineralization rate sediment',' ','mol P m-3 s-1') + call wrtsdm(jpownh4(iogrp), SDM_POWNH4(iogrp), rnacc*1e3, 0.,cmpflg,'pownh4') + call wrtsdm(jpown2o(iogrp), SDM_POWN2O(iogrp), rnacc*1e3, 0.,cmpflg,'pown2o') + call wrtsdm(jpowno2(iogrp), SDM_POWNO2(iogrp), rnacc*1e3, 0.,cmpflg,'powno2') + call wrtsdm(jsdm_nitr_NH4(iogrp), sdm_nitr_NH4(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'nh4nitrsdm') + call wrtsdm(jsdm_nitr_NO2(iogrp), sdm_nitr_NO2(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'no2nitrsdm') + call wrtsdm(jsdm_nitr_N2O_prod(iogrp),sdm_nitr_N2O_prod(iogrp),rnacc*1e3/dtbgc,0.,cmpflg,'nitr_n2osdm') + call wrtsdm(jsdm_nitr_NH4_OM(iogrp), sdm_nitr_NH4_OM(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'nh4nitr_omsdm') + call wrtsdm(jsdm_nitr_NO2_OM(iogrp), sdm_nitr_NO2_OM(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'no2nitr_omsdm') + call wrtsdm(jsdm_denit_NO3(iogrp), sdm_denit_NO3(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'no3denitsdm') + call wrtsdm(jsdm_denit_NO2(iogrp), sdm_denit_NO2(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'no2denitsdm') + call wrtsdm(jsdm_denit_N2O(iogrp), sdm_denit_N2O(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'n2odenitsdm') + call wrtsdm(jsdm_DNRA_NO2(iogrp), sdm_DNRA_NO2(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'no2dnrasdm') + call wrtsdm(jsdm_anmx_N2_prod(iogrp), sdm_anmx_N2_prod(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'anmx_n2sdm') + call wrtsdm(jsdm_anmx_OM_prod(iogrp), sdm_anmx_OM_prod(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'anmx_omsdm') + call wrtsdm(jsdm_remin_aerob(iogrp), sdm_remin_aerob(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'reminasdm') + call wrtsdm(jsdm_remin_sulf(iogrp), sdm_remin_sulf(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'reminssdm') #endif ! --- close netcdf file From 26e65d6bda43b1669dea93384a23efb8d751793b Mon Sep 17 00:00:00 2001 From: jmaerz <92309038+jmaerz@users.noreply.github.com> Date: Fri, 27 Jan 2023 11:03:37 +0100 Subject: [PATCH 253/366] fix missing ' (#229) Fixing a missing ' that only showed up when using `cisonew` --- hamocc/ncout_hamocc.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/hamocc/ncout_hamocc.F90 b/hamocc/ncout_hamocc.F90 index df9d637f..96d1dc5d 100644 --- a/hamocc/ncout_hamocc.F90 +++ b/hamocc/ncout_hamocc.F90 @@ -485,7 +485,7 @@ subroutine ncwrt_bgc(iogrp) #endif #ifdef cisonew call wrtsrf(jatmc13(iogrp), SRF_ATMC13(iogrp), rnacc, 0.,cmpflg,'atmc13') - call wrtsrf(jatmc14(iogrp), SRF_ATMC14(iogrp), rnacc, 0.,cmpflg,'atmc14) + call wrtsrf(jatmc14(iogrp), SRF_ATMC14(iogrp), rnacc, 0.,cmpflg,'atmc14') #endif ! --- Store 3d layer fields From 79c9bf55ee5b9894a7f058d437c52501cab17656 Mon Sep 17 00:00:00 2001 From: jmaerz <92309038+jmaerz@users.noreply.github.com> Date: Fri, 27 Jan 2023 11:04:12 +0100 Subject: [PATCH 254/366] fix missing ' (#228) Fixing a missing ' that only showed up when using `cisonew` --- hamocc/ncout_hamocc.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/hamocc/ncout_hamocc.F90 b/hamocc/ncout_hamocc.F90 index df9d637f..96d1dc5d 100644 --- a/hamocc/ncout_hamocc.F90 +++ b/hamocc/ncout_hamocc.F90 @@ -485,7 +485,7 @@ subroutine ncwrt_bgc(iogrp) #endif #ifdef cisonew call wrtsrf(jatmc13(iogrp), SRF_ATMC13(iogrp), rnacc, 0.,cmpflg,'atmc13') - call wrtsrf(jatmc14(iogrp), SRF_ATMC14(iogrp), rnacc, 0.,cmpflg,'atmc14) + call wrtsrf(jatmc14(iogrp), SRF_ATMC14(iogrp), rnacc, 0.,cmpflg,'atmc14') #endif ! --- Store 3d layer fields From c6964a13b92c1f15e2a5717c2d48a03251141fdc Mon Sep 17 00:00:00 2001 From: TimotheeBrgs Date: Mon, 30 Jan 2023 14:57:48 +0100 Subject: [PATCH 255/366] Read parameters for alkalinization scenarios from namelist file --- cime_config/buildnml | 30 ++++++++++-- hamocc/mo_read_oafx.F90 | 100 +++++++++++++++++++++------------------- 2 files changed, 80 insertions(+), 50 deletions(-) diff --git a/cime_config/buildnml b/cime_config/buildnml index 57cc45eb..adf74987 100755 --- a/cime_config/buildnml +++ b/cime_config/buildnml @@ -237,6 +237,11 @@ endif set DO_OALK = .false. set OALKSCEN = "''" set OALKFILE = "''" +set ADDALK = 0.135 +set CDRMIP_LATMAX = 70.0 +set CDRMIP_LATMIN = -60.0 +set RAMP_START = 2025 +set RAMP_END = 2035 set WITH_DMSPH = .false. set PI_PH_FILE = "''" set L_3DVARSEDPOR = .false. @@ -1474,9 +1479,6 @@ cat >>! $RUNDIR/ocn_in$inststr << EOF RIVINFILE = $RIVINFILE DO_NDEP = $DO_NDEP NDEPFILE = $NDEPFILE - DO_OALK = $DO_OALK - OALKSCEN = $OALKSCEN - OALKFILE = $OALKFILE DO_SEDSPINUP = $DO_SEDSPINUP SEDSPIN_YR_S = $SEDSPIN_YR_S SEDSPIN_YR_E = $SEDSPIN_YR_E @@ -1495,6 +1497,28 @@ cat >>! $RUNDIR/ocn_in$inststr << EOF SEDPORFILE = $SEDPORFILE / +! NAMELIST FOR ALKALINIZATION SCENARIO +! +! CONTENTS: +! +! ADDALK : Pmol alkalinity/yr added in the scenarios. +! CDRMIP_LATMAX : Max latitude where alkalinity is added according to the +! CDRMIP protocol +! CDRMIP_LATMIN : Min latitude where alkalinity is added according to the +! CDRMIP protocol +! RAMP_START : Start year for ramp up in 'ramp' scenario +! RAMP_END : End year for 'ramp' scenario +&BGCOAFX + DO_OALK = $DO_OALK + OALKSCEN = $OALKSCEN + OALKFILE = $OALKFILE + ADDALK = $ADDALK + CDRMIP_LATMAX = $CDRMIP_LATMAX + CDRMIP_LATMIN = $CDRMIP_LATMIN + RAMP_START = $RAMP_START + RAMP_END = $RAMP_END +/ + ! IO-NAMELIST FOR DIAGNOSTIC iHAMOCC OUTPUT ! ! Namelist acronyms: diff --git a/hamocc/mo_read_oafx.F90 b/hamocc/mo_read_oafx.F90 index d6f2cb1b..36c002ef 100644 --- a/hamocc/mo_read_oafx.F90 +++ b/hamocc/mo_read_oafx.F90 @@ -45,16 +45,14 @@ module mo_read_oafx ! issued. The input data must be already pre-interpolated to the ocean grid. ! ! Currently available ocean alkalinisation scenarios: -! -'const_0p14': constant alkalinity flux of 0.14 Pmol yr-1 applied to the -! surface ocean between 60S and 70N (no input file needed) -! -'const_0p56': constant alkalinity flux of 0.56 Pmol yr-1 applied to the -! surface ocean between 60S and 70N (no input file needed) -! -'ramp': ramping-up alkalinity flux from 0 Pmol yr-1 in 2025 to -! 0.135 Pmol yr-1 in 2035 and onward, applied to the surface -! ocean between 60S and 70N (no input file needed) -! From G.Tran: 4279324154000 umol/s *3600 *24 *365 *1e-15 -! *1e-6 = 0.135 Pmol yr-1 -! +! (no input file needed, flux and latitude range can be defined in the +! namelist, default values are defined): +! -'const': constant alkalinity flux applied to the surface ocean +! between two latitudes. +! -'ramp': ramping-up alkalinity flux from 0 Pmol yr-1 to a maximum +! value between two specified years and kept constant +! onward, applied to the surface ocean between two +! latitudes. ! ! -subroutine ini_read_oafx ! Initialise the module @@ -71,30 +69,32 @@ module mo_read_oafx real,allocatable, save :: oalkflx(:,:) - character(len=128), save :: oalkscen='' - character(len=512), save :: oalkfile='' + character(len=128), save :: oalkscen ='' + character(len=512), save :: oalkfile ='' real, parameter :: Pmol2kmol = 1.0e12 ! Parameter used in the definition of alkalinization scenarios. The following ! scenarios are defined in this module: ! - ! const_0p14 Homogeneous addition of 0.14 Pmol ALK/yr-1 over the ice-free - ! surface ocean (assumed to be between 60S and 70N) - ! const_0p56 Homogeneous addition of 0.56 Pmol ALK/yr-1 over the ice-free - ! surface ocean (assumed to be between 60S and 70N) - ! ramp Linear increase of homogeneous addition of 0 to 0.135 Pmol - ! ALK/yr-1 from 2025 to 2035 over the ice-free surface ocean - ! (assumed to be between 60S and 70N) + ! const Constant homogeneous addition of alkalinity between latitude + ! cdrmip_latmin and latitude cdrmip_latmax + ! ramp Linear increase of homogeneous addition from 0 to addalk + ! Pmol ALK/yr-1 from year ramp_start to year ramp_end between + ! latitude cdrmip_latmin and latitude cdrmip_latmax ! - real, parameter :: addalk_0p14 = 0.14 ! Pmol alkalinity/yr added in the - real, parameter :: addalk_0p56 = 0.56 ! 'const_0p14' and 'const_0p56' - ! scenarios - real, parameter :: cdrmip_latmax = 70.0 ! Min and max latitude where - real, parameter :: cdrmip_latmin = -60.0 ! alkalinity is added according - ! to the CDRMIP protocol - real, parameter :: addalk_ramp = 0.135 ! Max Pmol alkalinity/yr added - integer, parameter :: ramp_start = 2025 ! in 2035 in the 'ramp' scenario, - integer, parameter :: ramp_end = 2035 ! starting at 0 Pmol/yr in 2025. + real, protected :: addalk = 0.56 ! Pmol alkalinity/yr added in the + ! scenarios. Read from namelist file + ! to overwrite default value. + real, protected :: cdrmip_latmax = 70.0 ! Min and max latitude where + real, protected :: cdrmip_latmin = -60.0 ! alkalinity is added according + ! to the CDRMIP protocol. Read from + ! namelist file to overwrite default + ! value. + integer, protected :: ramp_start = 2025 ! In 'ramp' scenario, start at + integer, protected :: ramp_end = 2035 ! 0 Pmol/yr in ramp_start, and max + ! addalk Pmol/yr in ramp_end. + ! Read from namelist file to + ! overwrite default value. logical, save :: lini = .false. @@ -126,19 +126,30 @@ subroutine ini_read_oafx(kpie,kpje,pdlxp,pdlyp,pglat,omask) ! !****************************************************************************** use mod_xc, only: xcsum,xchalt,mnproc,nbdy,ips - use mo_control_bgc, only: io_stdo_bgc,do_oalk + use mo_control_bgc, only: io_stdo_bgc,do_oalk,bgc_namelist,get_bgc_namelist - implicit none + implicit none integer, intent(in) :: kpie,kpje real, intent(in) :: pdlxp(kpie,kpje), pdlyp(kpie,kpje) - real, intent(in) :: pglat(1-nbdy:kpie+nbdy,1-nbdy:kpje+nbdy) + real, intent(in) :: pglat(1-nbdy:kpie+nbdy,1-nbdy:kpje+nbdy) real, intent(in) :: omask(kpie,kpje) integer :: i,j,errstat - real :: avflx,ztotarea,addalk_tot + integer :: iounit + real :: avflx,ztotarea real :: ztmp1(1-nbdy:kpie+nbdy,1-nbdy:kpje+nbdy) + namelist /bgcoafx/ do_oalk,oalkscen,oalkfile,addalk,cdrmip_latmax, & + & cdrmip_latmin,ramp_start,ramp_end + + ! Read parameters for alkalinization fluxes from namelist file + if(.not. allocated(bgc_namelist)) call get_bgc_namelist + open (newunit=iounit, file=bgc_namelist, status='old' & + & ,action='read') + read (unit=iounit, nml=BGCOAFX) + close (unit=iounit) + ! Return if alkalinization is turned off if (.not. do_oalk) then if (mnproc.eq.1) then @@ -158,15 +169,14 @@ subroutine ini_read_oafx(kpie,kpje,pdlxp,pdlyp,pglat,omask) write(io_stdo_bgc,*)' ' endif - if( trim(oalkscen)=='const_0p14' .or. trim(oalkscen)=='const_0p56' .or. & - trim(oalkscen)=='ramp' ) then + if( trim(oalkscen)=='const' .or. trim(oalkscen)=='ramp' ) then if(mnproc.eq.1) then write(io_stdo_bgc,*)'Using alkalinization scenario ', trim(oalkscen) write(io_stdo_bgc,*)' ' endif - ! Allocate field to hold constant alkalinization fluxes + ! Allocate field to hold alkalinization fluxes if(mnproc.eq.1) then write(io_stdo_bgc,*)'Memory allocation for variable oalkflx ...' write(io_stdo_bgc,*)'First dimension : ',kpie @@ -190,16 +200,8 @@ subroutine ini_read_oafx(kpie,kpje,pdlxp,pdlyp,pglat,omask) call xcsum(ztotarea,ztmp1,ips) - if( trim(oalkscen)=='const_0p14') then - addalk_tot = addalk_0p14 - else if( trim(oalkscen)=='const_0p56') then - addalk_tot = addalk_0p56 - else - addalk_tot = addalk_ramp - endif - ! Calculate alkalinity flux (kmol m^2 yr-1) to be applied - avflx = addalk_tot/ztotarea*Pmol2kmol + avflx = addalk/ztotarea*Pmol2kmol if(mnproc.eq.1) then write(io_stdo_bgc,*)' ' write(io_stdo_bgc,*)' applying alkalinity flux of ', avflx, ' kmol m-2 yr-1' @@ -284,7 +286,7 @@ subroutine get_oafx(kpie,kpje,kplyear,kplmon,omask,oafx) !-------------------------------- ! Scenarios of constant fluxes !-------------------------------- - if( trim(oalkscen)=='const_0p14' .or. trim(oalkscen)=='const_0p56' ) then + if( trim(oalkscen)=='const' ) then oafx(:,:) = oalkflx(:,:) @@ -298,8 +300,12 @@ subroutine get_oafx(kpie,kpje,kplyear,kplmon,omask,oafx) elseif(kplyear.ge.ramp_end ) then oafx(:,:) = oalkflx(:,:) else - current_day = (kplyear-ramp_start)*365+nday_of_year - oafx(:,:) = oalkflx(:,:) * current_day / ((ramp_end-ramp_start)*365) + current_day = (kplyear-ramp_start)*365.+nday_of_year + oafx(:,:) = oalkflx(:,:) * current_day / ((ramp_end-ramp_start)*365.) + endif + + if(mnproc.eq.138 ) then + write(io_stdo_bgc,*) 'get_oafx: oafx (kmol m-2 yr-1) ', oafx endif else From ba3d3d469760a47937931dbcb9f6b98b1853d5dd Mon Sep 17 00:00:00 2001 From: TimotheeBrgs Date: Mon, 30 Jan 2023 16:07:41 +0100 Subject: [PATCH 256/366] Cleaning --- hamocc/mo_read_oafx.F90 | 6 +----- 1 file changed, 1 insertion(+), 5 deletions(-) diff --git a/hamocc/mo_read_oafx.F90 b/hamocc/mo_read_oafx.F90 index 36c002ef..9aeee03e 100644 --- a/hamocc/mo_read_oafx.F90 +++ b/hamocc/mo_read_oafx.F90 @@ -82,7 +82,7 @@ module mo_read_oafx ! Pmol ALK/yr-1 from year ramp_start to year ramp_end between ! latitude cdrmip_latmin and latitude cdrmip_latmax ! - real, protected :: addalk = 0.56 ! Pmol alkalinity/yr added in the + real, protected :: addalk = 0.56 ! Pmol alkalinity/yr added in the ! scenarios. Read from namelist file ! to overwrite default value. real, protected :: cdrmip_latmax = 70.0 ! Min and max latitude where @@ -304,10 +304,6 @@ subroutine get_oafx(kpie,kpje,kplyear,kplmon,omask,oafx) oafx(:,:) = oalkflx(:,:) * current_day / ((ramp_end-ramp_start)*365.) endif - if(mnproc.eq.138 ) then - write(io_stdo_bgc,*) 'get_oafx: oafx (kmol m-2 yr-1) ', oafx - endif - else write(io_stdo_bgc,*) '' From 63e2d86c04aebd777ddd351188a819a6ea1b33ee Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Timoth=C3=A9e=20Bourgeois?= Date: Mon, 30 Jan 2023 16:29:30 +0100 Subject: [PATCH 257/366] Rename shell namelist variables Initiate naming convention for shell variables in buildnml such as NAMELIST_VARIABLE Co-authored-by: Tomas Torsvik <43031053+TomasTorsvik@users.noreply.github.com> --- cime_config/buildnml | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/cime_config/buildnml b/cime_config/buildnml index adf74987..cf0ff6b6 100755 --- a/cime_config/buildnml +++ b/cime_config/buildnml @@ -234,14 +234,14 @@ if ($HAMOCC_VSLS == TRUE && $OCN_GRID != tnx1v4) then endif # For the following options, there are currently no switches in Case-XML files. # These options can be activated by expert users via user namelist. -set DO_OALK = .false. -set OALKSCEN = "''" -set OALKFILE = "''" -set ADDALK = 0.135 -set CDRMIP_LATMAX = 70.0 -set CDRMIP_LATMIN = -60.0 -set RAMP_START = 2025 -set RAMP_END = 2035 +set BGCOAFX_DO_OALK = .false. +set BGCOAFX_OALKSCEN = "''" +set BGCOAFX_OALKFILE = "''" +set BGCOAFX_ADDALK = 0.135 +set BGCOAFX_CDRMIP_LATMAX = 70.0 +set BGCOAFX_CDRMIP_LATMIN = -60.0 +set BGCOAFX_RAMP_START = 2025 +set BGCOAFX_RAMP_END = 2035 set WITH_DMSPH = .false. set PI_PH_FILE = "''" set L_3DVARSEDPOR = .false. From 545cf10d78809d562612f8abc5a340703445683a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Timoth=C3=A9e=20Bourgeois?= Date: Mon, 30 Jan 2023 16:31:33 +0100 Subject: [PATCH 258/366] Rename shell namelist variables 2 Co-authored-by: Tomas Torsvik <43031053+TomasTorsvik@users.noreply.github.com> --- cime_config/buildnml | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/cime_config/buildnml b/cime_config/buildnml index cf0ff6b6..cbfeb740 100755 --- a/cime_config/buildnml +++ b/cime_config/buildnml @@ -1509,14 +1509,14 @@ cat >>! $RUNDIR/ocn_in$inststr << EOF ! RAMP_START : Start year for ramp up in 'ramp' scenario ! RAMP_END : End year for 'ramp' scenario &BGCOAFX - DO_OALK = $DO_OALK - OALKSCEN = $OALKSCEN - OALKFILE = $OALKFILE - ADDALK = $ADDALK - CDRMIP_LATMAX = $CDRMIP_LATMAX - CDRMIP_LATMIN = $CDRMIP_LATMIN - RAMP_START = $RAMP_START - RAMP_END = $RAMP_END + DO_OALK = $BGCOAFX_DO_OALK + OALKSCEN = $BGCOAFX_OALKSCEN + OALKFILE = $BGCOAFX_OALKFILE + ADDALK = $BGCOAFX_ADDALK + CDRMIP_LATMAX = $BGCOAFX_CDRMIP_LATMAX + CDRMIP_LATMIN = $BGCOAFX_CDRMIP_LATMIN + RAMP_START = $BGCOAFX_RAMP_START + RAMP_END = $BGCOAFX_RAMP_END / ! IO-NAMELIST FOR DIAGNOSTIC iHAMOCC OUTPUT From c0418d260abd7034e18f53c49e142b5b8ac346f5 Mon Sep 17 00:00:00 2001 From: TimotheeBrgs Date: Mon, 30 Jan 2023 17:29:07 +0100 Subject: [PATCH 259/366] Proper integer definition for current_day --- hamocc/mo_read_oafx.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/hamocc/mo_read_oafx.F90 b/hamocc/mo_read_oafx.F90 index 9aeee03e..8bfa2d28 100644 --- a/hamocc/mo_read_oafx.F90 +++ b/hamocc/mo_read_oafx.F90 @@ -300,7 +300,7 @@ subroutine get_oafx(kpie,kpje,kplyear,kplmon,omask,oafx) elseif(kplyear.ge.ramp_end ) then oafx(:,:) = oalkflx(:,:) else - current_day = (kplyear-ramp_start)*365.+nday_of_year + current_day = (kplyear-ramp_start)*365+nday_of_year oafx(:,:) = oalkflx(:,:) * current_day / ((ramp_end-ramp_start)*365.) endif From a828bc2337865c4be768cbec2f5f01b7972eaaaa Mon Sep 17 00:00:00 2001 From: TimotheeBrgs Date: Tue, 31 Jan 2023 14:04:07 +0100 Subject: [PATCH 260/366] Fix buildnml --- cime_config/buildnml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/cime_config/buildnml b/cime_config/buildnml index de40e909..2eb52d03 100755 --- a/cime_config/buildnml +++ b/cime_config/buildnml @@ -1982,9 +1982,9 @@ cat >> $CASEBUILD/blom.input_data_list << EOF n_deposition_file = `echo $NDEPFILE | tr -d '"' | tr -d "'"` EOF endif - if ($OALKFILE != "''") then + if ($BGCOAFX_OALKFILE != "''") then cat >> $CASEBUILD/blom.input_data_list << EOF -oafx_file = `echo $OALKFILE | tr -d '"' | tr -d "'"` +oafx_file = `echo $BGCOAFX_OALKFILE | tr -d '"' | tr -d "'"` EOF endif if ($HAMOCC_VSLS == TRUE) then From b69d56f73db1bbc63284bd34c84ad22dbfd42be1 Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Mon, 6 Feb 2023 14:54:05 +0100 Subject: [PATCH 261/366] write out pN2Om in natm --- hamocc/carchm.F90 | 2 +- hamocc/ncout_hamocc.F90 | 3 ++- 2 files changed, 3 insertions(+), 2 deletions(-) diff --git a/hamocc/carchm.F90 b/hamocc/carchm.F90 index ce856546..cc3f7cf1 100644 --- a/hamocc/carchm.F90 +++ b/hamocc/carchm.F90 @@ -512,7 +512,7 @@ SUBROUTINE CARCHM(kpie,kpje,kpke,kbnd, & ! Surface flux of laughing gas (same piston velocity as for O2 and N2) n2oflux=kwn2o*dtbgc*(ocetra(i,j,1,ian2o)-satn2o(i,j)*atn2ov*rpp0) ! pN2O under moist air assumption at normal pressure - pn2om(i,j) = 1e6 * ocetra(i,j,1,ian2o)/satn2o(i,j) + pn2om(i,j) = 1e9 * ocetra(i,j,1,ian2o)/satn2o(i,j) ocetra(i,j,1,ian2o)=ocetra(i,j,1,ian2o)-n2oflux/pddpo(i,j,1) #ifdef CFC ! Surface fluxes for CFC: eqn. (1a) in ocmip2 howto doc(hyc) diff --git a/hamocc/ncout_hamocc.F90 b/hamocc/ncout_hamocc.F90 index bed05afc..782bcc9a 100644 --- a/hamocc/ncout_hamocc.F90 +++ b/hamocc/ncout_hamocc.F90 @@ -533,6 +533,7 @@ subroutine ncwrt_bgc(iogrp) call wrtsrf(joxflux(iogrp), SRF_OXFLUX(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'fgo2') call wrtsrf(jniflux(iogrp), SRF_NIFLUX(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'fgn2') call wrtsrf(jn2ofx(iogrp), SRF_N2OFX(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'n2oflux') + call wrtsrf(jsrfpn2om(iogrp), SRF_PN2OM(iogrp), rnacc, 0.,cmpflg,'pn2om') call wrtsrf(jdms(iogrp), SRF_DMS(iogrp), rnacc, 0.,cmpflg,'dms') call wrtsrf(jdmsprod(iogrp), SRF_DMSPROD(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'dmsprod') call wrtsrf(jdms_bac(iogrp), SRF_DMS_BAC(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'dms_bac') @@ -1362,7 +1363,7 @@ subroutine hamoccvardef(iogrp,timeunits,calendar,cmpflg) call ncdefvar3d(SRF_OXFLUX(iogrp), & & cmpflg,'p','fgo2','Oxygen flux',' ','mol O2 m-2 s-1',0) call ncdefvar3d(SRF_PN2OM(iogrp),cmpflg,'p', & - & 'pn2om','Surface pN2O moist air',' ','uatm',0) + & 'pn2om','Surface pN2O moist air',' ','natm',0) call ncdefvar3d(SRF_NIFLUX(iogrp), & & cmpflg,'p','fgn2','Nitrogen flux',' ','mol N2 m-2 s-1',0) call ncdefvar3d(SRF_DMS(iogrp),cmpflg,'p', & From c0ae6c22ae12905ee65741c13da9d852c86ec189 Mon Sep 17 00:00:00 2001 From: jmaerz <92309038+jmaerz@users.noreply.github.com> Date: Thu, 9 Feb 2023 15:14:40 +0100 Subject: [PATCH 262/366] Merge latest master into feature-hamocc_beyond-CMIP6 branch (#232) MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * Dynamic mapping of pore water tracers to ocean tracers (#192) * Initial restructuring of sediment-related tracer declaration and initialization * Introducing mapping function * Remove unncessary comments * Fixed diagnostics bug and updated index naming * Added initial support for NUOPC driver. * Lon-lat variable sediment porosity (#189) Introducing a static 3D sediment porosity field that can be optionally read in with effects on molecular pore water diffusion and shifting. * Added wave forcing fields. * Renamed folder for MCT driver. * Moved MCT specific file from drivers/cpl_share/ to drivers/mct/. * Rename drivers/mct/mod_swtfrz.F to drivers/mct/mod_swtfrz.F90. * Rewrite to drivers/mct/mod_swtfrz.F90 to free format Fortran. * Remove redundant definition of kOBL. * Redefine kOBL, cast as integer * Fixing variable sediment porosity - field initialization in case of `sedbypass=true` (#198) * Removing bodensed - Initialization of sediment parameters and fields now in mo_sedmnt * This is the first commit of MKS units. All variables in the subroutines have been converted to MKS [meter, kg, seconds] instead of CGS [cm, gram, seconds] with necessary coefficients. The default option which is CGS reproduce old results. The new option MKS cannot reproduce because of machine precision. * Hamocc hybrid coord2 (#179) Make the surface mixed layer depth fractional index `hOBL` available for use in iHAMOCC, and adjust the internal iHAMOCC index `kmle` according to `hOBL`. Default value `kmle = 2` is retained for consistency with isopycnic coordinates. * BLOM CIME cpp updates to run in NorESM * bug fixes for the CGS MKS conversion * cesm thermal forcing bug fixes for reproducibility * BLOM MKS update to export winds into the CESM using proper units. * input values in ocn_in case is updated for mks setup * default cgsmks value changed * Initialize some variables in the k-epsilon model. * Fix porosity read (#201) * Fixing the reading of variable porosity input field in preparation for the NorESM 2.0.6 release Cherry-picked from private Ncycleprivate branch 0d56930e2fdd62caba964d375b57304942568926 * Provide number of layers (3rd dim) via ks and not hard-coded * minor clean-up * Correct unit of diagnostic variable dp_trc. * Made conservation and checksum diagnostics selectable by namelist options (default off). * pCO2, Piston velocity and solubility output (#202) * add pCO2m (moist), CO2 piston velocity and solubility output - caution: kwco2 piston velocity now really holds only piston velocity (and not times solubility) * Bugfix pnetcdf (#208) * Add variables used by PNETCDF to explicit use staements. * Move implicit none statments * update explicit use statement for pnetcdf * fixed units and renamed calcium burial to CaCO3 burial (#212) Fixed sediment clay units. * - Made the "fuk95" configuration work with MKS units. - Removed "CGS" CPP flag. - Changed some unit conversion factors from variables to parameters. - Introduced rho0 (= 1/alpha0) parameter. - Updated copyright statements. * Correct unit conversion of mixed layer depth to pressure. * Updated NorESM coupling scripts for the use of MKS units. * Fixed check of unit system when building as NorESM component. * Add option for surface pH output (#221) * Remove unused parameters in wrt* subroutine calls in ncout_hamocc.F90 * Import get_bgc_namelist only in subroutine where it is needed. (#225) * fix missing ' (#228) Fixing a missing ' that only showed up when using `cisonew` --------- Co-authored-by: Mats Bentsen Co-authored-by: Tomas Torsvik Co-authored-by: Mehmet Ilicak Co-authored-by: Tomas Torsvik <43031053+TomasTorsvik@users.noreply.github.com> Co-authored-by: Jörg Schwinger --- ben02/mod_ben02.F | 21 ++- ben02/sfcstr_ben02.F | 7 +- ben02/thermf_ben02.F | 57 +++--- cesm/sfcstr_cesm.F | 7 +- cesm/thermf_cesm.F | 55 +++--- channel/thermf_channel.F | 8 +- cime_config/buildcpp | 6 + cime_config/buildnml | 116 +++++++++--- cime_config/config_component.xml | 9 + drivers/mct/domain_mct.F | 3 +- drivers/mct/export_mct.F | 7 +- fuk95/mod_fuk95.F90 | 76 +++++--- meson.build | 4 + meson_options.txt | 2 + phy/convec.F | 8 +- phy/diapfl.F | 14 +- phy/diffus.F | 5 +- phy/geoenv_file.F | 28 +-- phy/mod_cmnfld.F90 | 8 +- phy/mod_cmnfld_routines.F90 | 40 ++-- phy/mod_constants.F90 | 58 +++++- phy/mod_dia.F | 281 +++++++++++++++------------- phy/mod_difest.F | 137 ++++++++------ phy/mod_diffusion.F90 | 10 +- phy/mod_eddtra.F90 | 116 ++++++------ phy/mod_eos.F90 | 47 +++-- phy/mod_inicon.F | 26 ++- phy/mod_momtum.F | 21 ++- phy/mod_mxlayr.F | 56 +++--- phy/mod_ndiff.F90 | 12 +- phy/mod_pbcor.F | 16 +- phy/mod_pgforc.F | 7 +- phy/mod_remap.F | 5 +- phy/mod_swabs.F | 2 +- phy/mod_tidaldissip.F90 | 6 +- phy/mod_time.F90 | 6 +- phy/mod_tke.F90 | 34 +++- phy/mod_tmsmt.F | 18 +- phy/mod_vcoord.F90 | 10 +- phy/mod_vdiff.F90 | 6 +- phy/numerical_bounds.F90 | 8 +- phy/rdlim.F | 5 +- single_column/mod_single_column.F90 | 17 +- 43 files changed, 828 insertions(+), 557 deletions(-) diff --git a/ben02/mod_ben02.F b/ben02/mod_ben02.F index d6fd01a5..2e6c63cb 100644 --- a/ben02/mod_ben02.F +++ b/ben02/mod_ben02.F @@ -1,5 +1,5 @@ ! ------------------------------------------------------------------------------ -! Copyright (C) 2002-2021 Mats Bentsen, Mehmet Ilicak +! Copyright (C) 2002-2022 Mats Bentsen, Mehmet Ilicak ! ! This file is part of BLOM. ! @@ -26,7 +26,7 @@ module mod_ben02 c use mod_types, only: i2, r4 use mod_config, only: expcnf - use mod_constants, only: t0deg, spval + use mod_constants, only: t0deg, spval, L_mks2cgs use mod_calendar, only: date_offset, calendar_noerr, . calendar_errstr use mod_time, only: date, calendar, nday_in_year, nday_of_year, @@ -183,10 +183,17 @@ module mod_ben02 . atm_cswa_era ! short-wave radiation adjustment factor ! (NCEP) c +#ifdef MKS + data atm_ice_csmt_ncep,atm_rnf_csmt_ncep /2.e10,1.e9/, + . atm_crnf_ncep,atm_cswa_ncep /0.82073,0.88340/, + . atm_ice_csmt_era,atm_rnf_csmt_era /0.0,1.e9/, + . atm_crnf_era,atm_cswa_era /0.7234,0.9721/ +#else data atm_ice_csmt_ncep,atm_rnf_csmt_ncep /2.e14,1.e13/, . atm_crnf_ncep,atm_cswa_ncep /0.82073,0.88340/, . atm_ice_csmt_era,atm_rnf_csmt_era /0.0,1.e13/, . atm_crnf_era,atm_cswa_era /0.7234,0.9721/ +#endif c real :: . zu, ! measurement height of wind [m] @@ -2090,11 +2097,13 @@ subroutine inifrc_ben02clim integer, dimension(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy,12) :: smtmsk real dx2,dy2,prc_sum,eva_sum,rnf_sum,swa_sum,lwa_sum,lht_sum, . sht_sum,fwf_fac,dangle,garea,le,albedo,fac,swa_ave,lwa_ave, - . lht_ave,sht_ave,crnf,cswa + . lht_ave,sht_ave,crnf,cswa,A_cgs2mks real*4 rw4 integer i,j,k,l,il,jl integer*2 rn2,ri2,rj2 c + A_cgs2mks=1./(L_mks2cgs**2) +c c --- 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), @@ -2775,7 +2784,7 @@ subroutine inifrc_ben02clim do k=1,12 do l=1,isp(j) do i=max(1,ifp(j,l)),min(ii,ilp(j,l)) - garea=scp2(i,j)*1.e-4 ! [m^2] + garea=scp2(i,j)*A_cgs2mks ! [m^2] c c --- ----- freshwater fluxes [m/s] util1(i,j)=util1(i,j)+precip(i,j,k)*fwf_fac*garea @@ -2819,7 +2828,7 @@ subroutine inifrc_ben02clim do j=1,jj do l=1,isp(j) do i=max(1,ifp(j,l)),min(ii,ilp(j,l)) - garea=scp2(i,j)*1.e-4 ! [m^2] + garea=scp2(i,j)*A_cgs2mks ! [m^2] c c --- ----- heat fluxes albedo=albs_f*ricclm(i,j,k)+albw(i,j)*(1.-ricclm(i,j,k)) @@ -2838,7 +2847,7 @@ subroutine inifrc_ben02clim call xcsum(lht_sum,util3,ip) call xcsum(sht_sum,util4,ip) c - fac=1.e4/(12.*area) + fac=(L_mks2cgs*L_mks2cgs)/(12.*area) swa_ave=swa_sum*fac lwa_ave=lwa_sum*fac lht_ave=lht_sum*fac diff --git a/ben02/sfcstr_ben02.F b/ben02/sfcstr_ben02.F index efd9e014..ee8161a6 100644 --- a/ben02/sfcstr_ben02.F +++ b/ben02/sfcstr_ben02.F @@ -1,5 +1,5 @@ ! ------------------------------------------------------------------------------ -! Copyright (C) 2004-2020 Mats Bentsen +! Copyright (C) 2004-2022 Mats Bentsen, Mehmet Ilicak ! ! This file is part of BLOM. ! @@ -24,6 +24,7 @@ subroutine sfcstr_ben02(m,n,mm,nn,k1m,k1n) c --- ------------------------------------------------------------------ c use mod_xc + use mod_constants, only: P_mks2cgs use mod_forcing, only: ztx, mty, taux, tauy use mod_seaice, only: ficem, hicem, tauxice, tauyice use mod_checksum, only: csdiag, chksummsk @@ -44,14 +45,14 @@ subroutine sfcstr_ben02(m,n,mm,nn,k1m,k1n) do i=max(1,ifu(j,l)),min(ii,ilu(j,l)) facice=(ficem(i,j)+ficem(i-1,j)) . *min(2.,hicem(i,j)+hicem(i-1,j))*.25 - taux(i,j)=10.*(ztx(i,j)*(1.-facice)+tauxice(i,j)*facice) + taux(i,j)=P_mks2cgs*(ztx(i,j)*(1.-facice)+tauxice(i,j)*facice) enddo enddo do l=1,isv(j) do i=max(1,ifv(j,l)),min(ii,ilv(j,l)) facice=(ficem(i,j)+ficem(i,j-1)) . *min(2.,hicem(i,j)+hicem(i,j-1))*.25 - tauy(i,j)=10.*(mty(i,j)*(1.-facice)+tauyice(i,j)*facice) + tauy(i,j)=P_mks2cgs*(mty(i,j)*(1.-facice)+tauyice(i,j)*facice) enddo enddo enddo diff --git a/ben02/thermf_ben02.F b/ben02/thermf_ben02.F index 003e9c61..fcd5bd19 100644 --- a/ben02/thermf_ben02.F +++ b/ben02/thermf_ben02.F @@ -1,5 +1,5 @@ ! ------------------------------------------------------------------------------ -! Copyright (C) 2002-2021 Mats Bentsen +! Copyright (C) 2002-2022 Mats Bentsen, Mehmet Ilicak ! ! This file is part of BLOM. ! @@ -21,7 +21,8 @@ subroutine thermf_ben02(m,n,mm,nn,k1m,k1n) c c --- NERSC version of thermf. c - use mod_constants, only: spcifh, t0deg, epsil, onem + use mod_constants, only: spcifh, t0deg, alpha0, epsilt, onem, + . g2kg, kg2g, L_mks2cgs, M_mks2cgs use mod_time, only: nday_in_year, nday_of_year, nstep, . nstep_in_day, baclin, . xmi, l1mi, l2mi, l3mi, l4mi, l5mi @@ -71,7 +72,7 @@ subroutine thermf_ben02(m,n,mm,nn,k1m,k1n) . fice,hice,hsnw,tsrf,fice0,hice0,hsnw0,qsww,qnsw,tice,albi, . tsmlt,albi_h,qswi,dh,qsnwf,fcond,qdamp,qsmlt,qo2i,qbot,swfac, . dtml,q,volice,df,dvi,dvs,fwflx,sstc,rice,trxflx,sssc,srxflx, - . totsfl,totwfl,sflxc,totsrp,totsrn + . totsfl,totwfl,sflxc,totsrp,totsrn,A_cgs2mks #ifdef TRC integer nt real, dimension(ntr,1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy) :: @@ -82,10 +83,12 @@ subroutine thermf_ben02(m,n,mm,nn,k1m,k1n) c real intp1d external intp1d +c + A_cgs2mks=1./(L_mks2cgs**2) c c --- Due to conservation, the ratio of ice and snow density must be c --- equal to the ratio of ice and snow heat of fusion - if (abs(fuss/fusi-rhosnw/rhoice).gt.epsil) then + if (abs(fuss/fusi-rhosnw/rhoice).gt.epsilt) then if (mnproc.eq.1) then write (lp,*) . 'thermf: check consistency between snow/ice densities' @@ -97,7 +100,7 @@ subroutine thermf_ben02(m,n,mm,nn,k1m,k1n) c c --- Set various constants dt=baclin ! Time step - cpsw=spcifh*1.e3 ! Specific heat of seawater + cpsw=spcifh*M_mks2cgs ! Specific heat of seawater rnf_fac=baclin/real(nrfets*86400) ! Runoff reservoar detrainment rate sag_fac=exp(-sagets*dt) ! Snow aging rate c @@ -326,7 +329,7 @@ subroutine thermf_ben02(m,n,mm,nn,k1m,k1n) c --- ----- Ice volume that has to freeze to balance the heat budget volice=-(qsww+qnsw-q)*(1.-fice)*dt/fusi c - if (volice.gt.epsil) then + if (volice.gt.epsilt) then c c --- ------- New ice in the lead is formed with a specified thickness. c --- ------- Estimate the change in ice fraction @@ -344,7 +347,7 @@ subroutine thermf_ben02(m,n,mm,nn,k1m,k1n) c --- ----- If the lead is warming, let the fraction (1 - fice) go to c --- ----- warm the lead, and the fraction fice to melt ice laterally fice=fice-(swfac*qsww+qnsw)*fice*dt - . /max(hice*fusi+hsnw*fuss,epsil) + . /max(hice*fusi+hsnw*fuss,epsilt) if (fice.lt.0.) then fice=0. hice=0. @@ -398,14 +401,14 @@ subroutine thermf_ben02(m,n,mm,nn,k1m,k1n) fwflx=eva(i,j)+lip(i,j)+sop(i,j)+rnf(i,j)+rfi(i,j)+fmltfz(i,j) c c --- --- Salt flux [kg m-2 s-1] (positive downwards) - sfl(i,j)=-sice*dvi*rhoice/dt*1.e-3 + sfl(i,j)=-sice*dvi*rhoice/dt*g2kg c c --- --- Salt flux due to brine rejection of freezing sea c --- --- ice [kg m-2 m-1] (positive downwards) - brnflx(i,j)=max(0.,-sotl*fmltfz(i,j)*1.e-3+sfl(i,j)) + brnflx(i,j)=max(0.,-sotl*fmltfz(i,j)*g2kg+sfl(i,j)) c c --- --- Virtual salt flux [kg m-2 s-1] (positive downwards) - vrtsfl(i,j)=-sotl*fwflx*1.e-3 + vrtsfl(i,j)=-sotl*fwflx*g2kg c c --- --- Store area weighted virtual salt flux and fresh water flux util1(i,j)=vrtsfl(i,j)*scp2(i,j) @@ -415,11 +418,11 @@ subroutine thermf_ben02(m,n,mm,nn,k1m,k1n) hmltfz(i,j)=(dvi*fusi+dvs*fuss)/dt c c --- --- Total heat flux in BLOM units [W cm-2] (positive upwards) - surflx(i,j)=-(swa(i,j)+nsf(i,j)+hmltfz(i,j))*1.e-4 + surflx(i,j)=-(swa(i,j)+nsf(i,j)+hmltfz(i,j))*A_cgs2mks c c --- --- Short-wave heat flux in BLOM units [W cm-2] (positive c --- --- upwards) - sswflx(i,j)=-qsww*(1.-fice0)*1.e-4 + sswflx(i,j)=-qsww*(1.-fice0)*A_cgs2mks c #ifdef TRC c --- ------------------------------------------------------------------ @@ -452,7 +455,7 @@ subroutine thermf_ben02(m,n,mm,nn,k1m,k1n) endif # endif # endif - trflx(nt,i,j)=-trc(i,j,k1n,nt)*fwflx*1.e-3 + trflx(nt,i,j)=-trc(i,j,k1n,nt)*fwflx*g2kg ttrsf(nt,i,j)=trflx(nt,i,j)*scp2(i,j) ttrav(nt,i,j)=trc(i,j,k1n,nt)*scp2(i,j) enddo @@ -465,7 +468,7 @@ subroutine thermf_ben02(m,n,mm,nn,k1m,k1n) surrlx(i,j)=0. c c --- --- If trxday>0 , apply relaxation towards observed sst - if (trxday.gt.epsil) then + if (trxday.gt.epsilt) then sstc=intp1d(sstclm(i,j,l1mi),sstclm(i,j,l2mi), . sstclm(i,j,l3mi),sstclm(i,j,l4mi), . sstclm(i,j,l5mi),xmi) @@ -473,8 +476,8 @@ 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 - trxflx=spcifh*100.*min(hmxl,trxdpt)/(trxday*86400.) - . *min(trxlim,max(-trxlim,sstc-tmxl)) + trxflx=spcifh*L_mks2cgs*min(hmxl,trxdpt)/(trxday*86400.) + . *min(trxlim,max(-trxlim,sstc-tmxl))/alpha0 surrlx(i,j)=-trxflx else trxflx=0. @@ -496,12 +499,12 @@ subroutine thermf_ben02(m,n,mm,nn,k1m,k1n) salrlx(i,j)=0. c c --- --- if srxday>0 , apply relaxation towards observed sss - if (srxday.gt.epsil) then + if (srxday.gt.epsilt) then sssc=intp1d(sssclm(i,j,l1mi),sssclm(i,j,l2mi), . sssclm(i,j,l3mi),sssclm(i,j,l4mi), . sssclm(i,j,l5mi),xmi) - srxflx=100.*min(hmxl,srxdpt)/(srxday*86400.) - . *min(srxlim,max(-srxlim,sssc-smxl)) + srxflx=L_mks2cgs*min(hmxl,srxdpt)/(srxday*86400.) + . *min(srxlim,max(-srxlim,sssc-smxl))/alpha0 salrlx(i,j)=-srxflx util3(i,j)=max(0.,salrlx(i,j))*scp2(i,j) util4(i,j)=min(0.,salrlx(i,j))*scp2(i,j) @@ -538,7 +541,7 @@ subroutine thermf_ben02(m,n,mm,nn,k1m,k1n) c --- ------------------------------------------------------------------- c ustar(i,j)=(min(ustari(i,j),.8e-2)*fice0 - . +ustarw(i,j)*(1.-fice0))*1.e2 + . +ustarw(i,j)*(1.-fice0))*L_mks2cgs c enddo enddo @@ -556,7 +559,7 @@ subroutine thermf_ben02(m,n,mm,nn,k1m,k1n) call xcsum(totwfl,util2,ips) c c --- Correction for the virtual salt flux [kg m-2 s-1] - sflxc=(-sref*totwfl*1.e-3-totsfl)/area + sflxc=(-sref*totwfl*g2kg-totsfl)/area if (mnproc.eq.1) then write (lp,*) 'thermf: totsfl/area,sflxc',totsfl/area,sflxc endif @@ -567,8 +570,10 @@ subroutine thermf_ben02(m,n,mm,nn,k1m,k1n) do j=1,jj do l=1,isp(j) do i=max(1,ifp(j,l)),min(ii,ilp(j,l)) - salflx(i,j)=-(vrtsfl(i,j)+sflxc+sfl(i,j))*1.e2 - brnflx(i,j)=-brnflx(i,j)*1.e2 + salflx(i,j)=-(vrtsfl(i,j)+sflxc+sfl(i,j)) + . *(kg2g*(M_mks2cgs/L_mks2cgs**2)) + brnflx(i,j)=-brnflx(i,j) + . *(kg2g*(M_mks2cgs/L_mks2cgs**2)) enddo enddo enddo @@ -577,7 +582,7 @@ subroutine thermf_ben02(m,n,mm,nn,k1m,k1n) c --- if srxday>0 and srxbal=.true. , balance the sss relaxation flux c --- so the net input of salt in grid cells connected to the world c --- ocean is zero - if (srxday.gt.epsil.and.srxbal) then + if (srxday.gt.epsilt.and.srxbal) then call xcsum(totsrp,util3,ipwocn) call xcsum(totsrn,util4,ipwocn) if (abs(totsrp).gt.abs(totsrn)) then @@ -632,14 +637,14 @@ subroutine thermf_ben02(m,n,mm,nn,k1m,k1n) c tottrav=tottrav/area cc c trflxc=(-tottrsf)/area -c trflxc=(-tottrav*totwfl*1.e-3-tottrsf)/area +c trflxc=(-tottrav*totwfl*g2kg-tottrsf)/area trflxc=0. c c$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)) - trflx(nt,i,j)=-(trflx(nt,i,j)+trflxc)*1.e2 + trflx(nt,i,j)=-(trflx(nt,i,j)+trflxc)*L_mks2cgs enddo enddo enddo diff --git a/cesm/sfcstr_cesm.F b/cesm/sfcstr_cesm.F index b352cbfd..d0d047b7 100644 --- a/cesm/sfcstr_cesm.F +++ b/cesm/sfcstr_cesm.F @@ -1,5 +1,5 @@ ! ------------------------------------------------------------------------------ -! Copyright (C) 2015-2020 Mats Bentsen +! Copyright (C) 2015-2022 Mats Bentsen, Mehmet Ilicak ! ! This file is part of BLOM. ! @@ -24,6 +24,7 @@ subroutine sfcstr_cesm(m,n,mm,nn,k1m,k1n) c --- ------------------------------------------------------------------ c use mod_xc + use mod_constants, only: P_mks2cgs use mod_forcing, only: ztx, mty, taux, tauy use mod_checksum, only: csdiag, chksummsk c @@ -37,12 +38,12 @@ subroutine sfcstr_cesm(m,n,mm,nn,k1m,k1n) do j=1,jj do l=1,isu(j) do i=max(1,ifu(j,l)),min(ii,ilu(j,l)) - taux(i,j)=10.*ztx(i,j) + taux(i,j)=P_mks2cgs*ztx(i,j) enddo enddo do l=1,isv(j) do i=max(1,ifv(j,l)),min(ii,ilv(j,l)) - tauy(i,j)=10.*mty(i,j) + tauy(i,j)=P_mks2cgs*mty(i,j) enddo enddo enddo diff --git a/cesm/thermf_cesm.F b/cesm/thermf_cesm.F index 63b6a4e8..9b9740a0 100644 --- a/cesm/thermf_cesm.F +++ b/cesm/thermf_cesm.F @@ -1,5 +1,5 @@ ! ------------------------------------------------------------------------------ -! Copyright (C) 2008-2021 Mats Bentsen +! Copyright (C) 2008-2022 Mats Bentsen, Mehmet Ilicak ! ! This file is part of BLOM. ! @@ -21,7 +21,8 @@ subroutine thermf_cesm(m,n,mm,nn,k1m,k1n) c c --- NERSC version of thermf. To be used when coupled to CESM c - use mod_constants, only: g, spcifh, t0deg, epsil, onem + use mod_constants, only: g, spcifh, t0deg, alpha0, epsilt, onem, + . g2kg, kg2g, L_mks2cgs, M_mks2cgs use mod_time, only: nstep, nstep_in_day, nday_in_year, . nday_of_year, baclin, . xmi, l1mi, l2mi, l3mi, l4mi, l5mi @@ -61,7 +62,7 @@ subroutine thermf_cesm(m,n,mm,nn,k1m,k1n) integer i,j,k,l,m1,m2,m3,m4,m5 real y,dpotl,hotl,totl,sotl,dpmxl,hmxl,tmxl,smxl,tice_f,fwflx, . sstc,rice,trxflx,sssc,srxflx,totsfl,totwfl,sflxc,totsrp, - . totsrn,qp,qn + . totsrn,qp,qn,A_cgs2mks #ifdef TRC integer nt real, dimension(ntr,1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy) :: @@ -72,6 +73,8 @@ subroutine thermf_cesm(m,n,mm,nn,k1m,k1n) real intp1d external intp1d c + A_cgs2mks=1./(L_mks2cgs**2) +c c --- Set parameters for time interpolation when applying diagnosed heat c --- and salt relaxation fluxes y=(nday_of_year-1+mod(nstep,nstep_in_day)/real(nstep_in_day))*48. @@ -132,10 +135,10 @@ subroutine thermf_cesm(m,n,mm,nn,k1m,k1n) c c --- --- Salt flux due to brine rejection of freezing sea c --- --- ice [kg m-2 m-1] (positive downwards) - brnflx(i,j)=max(0.,-sotl*fmltfz(i,j)*1.e-3+sfl(i,j)) + brnflx(i,j)=max(0.,-sotl*fmltfz(i,j)*g2kg+sfl(i,j)) c c --- --- Virtual salt flux [kg m-2 s-1] (positive downwards) - vrtsfl(i,j)=-sotl*fwflx*1.e-3 + vrtsfl(i,j)=-sotl*fwflx*g2kg c c --- --- Store area weighted virtual salt flux and fresh water flux util1(i,j)=vrtsfl(i,j)*scp2(i,j) @@ -150,20 +153,21 @@ subroutine thermf_cesm(m,n,mm,nn,k1m,k1n) c --- --- be heated. Note the freezing potential is multiplied by 1/2 c --- --- due to the leap-frog time stepping. The melting potential uses c --- --- time averaged quantities since it is not accumulated. - frzpot(i,j)=max(0.,tice_f-totl)*spcifh*dpotl/(2.*g)*1.e4 + frzpot(i,j)=max(0.,tice_f-totl)*spcifh*dpotl + . /(2.*g)*(L_mks2cgs**2) mltpot(i,j)= . min(0.,tfrzm(i,j)-.5*(temp(i,j,k1m)+temp(i,j,k1n))) - . *spcifh*.5*(dp(i,j,k1m)+dp(i,j,k1n))/g*1.e4 + . *spcifh*.5*(dp(i,j,k1m)+dp(i,j,k1n))/g*(L_mks2cgs**2) c c --- --- Heat flux due to melting/freezing [W m-2] (positive downwards) hmltfz(i,j)=hmlt(i,j)+frzpot(i,j)/baclin c c --- --- Total heat flux in BLOM units [W cm-2] (positive upwards) - surflx(i,j)=-(swa(i,j)+nsf(i,j)+hmltfz(i,j))*1.e-4 + surflx(i,j)=-(swa(i,j)+nsf(i,j)+hmltfz(i,j))*A_cgs2mks c c --- --- Short-wave heat flux in BLOM units [W cm-2] (positive c --- --- upwards) - sswflx(i,j)=-swa(i,j)*1.e-4 + sswflx(i,j)=-swa(i,j)*A_cgs2mks c #ifdef TRC c --- ------------------------------------------------------------------ @@ -182,7 +186,7 @@ subroutine thermf_cesm(m,n,mm,nn,k1m,k1n) if (nt.eq.itrgls) then trflx(nt,i,j)=-gls_n*difdia(i,j,1)*(gls_cmu0**gls_p) . *(trc(i,j,k1n,itrtke)**gls_m) - . *(vonKar**gls_n)*Zos**(gls_n-1.) + . *(vonKar**gls_n)*zos**(gls_n-1.) ttrsf(nt,i,j)=0. ttrav(nt,i,j)=0. cycle @@ -196,11 +200,12 @@ subroutine thermf_cesm(m,n,mm,nn,k1m,k1n) endif # endif # endif - trflx(nt,i,j)=-trc(i,j,k1n,nt)*fwflx*1.e-3 + trflx(nt,i,j)=-trc(i,j,k1n,nt)*fwflx*g2kg ttrsf(nt,i,j)=trflx(nt,i,j)*scp2(i,j) ttrav(nt,i,j)=trc(i,j,k1n,nt)*scp2(i,j) enddo #endif +c c --- ------------------------------------------------------------------ c --- --- Relaxation fluxes c --- ------------------------------------------------------------------ @@ -208,7 +213,7 @@ subroutine thermf_cesm(m,n,mm,nn,k1m,k1n) surrlx(i,j)=0. c c --- --- If trxday>0 , apply relaxation towards observed sst - if (trxday.gt.epsil) then + if (trxday.gt.epsilt) then sstc=intp1d(sstclm(i,j,l1mi),sstclm(i,j,l2mi), . sstclm(i,j,l3mi),sstclm(i,j,l4mi), . sstclm(i,j,l5mi),xmi) @@ -216,8 +221,8 @@ 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 - trxflx=spcifh*100.*min(hmxl,trxdpt)/(trxday*86400.) - . *min(trxlim,max(-trxlim,sstc-tmxl)) + trxflx=spcifh*L_mks2cgs*min(hmxl,trxdpt)/(trxday*86400.) + . *min(trxlim,max(-trxlim,sstc-tmxl))/alpha0 surrlx(i,j)=-trxflx else trxflx=0. @@ -239,12 +244,12 @@ subroutine thermf_cesm(m,n,mm,nn,k1m,k1n) salrlx(i,j)=0. c c --- --- if srxday>0 , apply relaxation towards observed sss - if (srxday.gt.epsil) then + if (srxday.gt.epsilt) then sssc=intp1d(sssclm(i,j,l1mi),sssclm(i,j,l2mi), . sssclm(i,j,l3mi),sssclm(i,j,l4mi), . sssclm(i,j,l5mi),xmi) - srxflx=100.*min(hmxl,srxdpt)/(srxday*86400.) - . *min(srxlim,max(-srxlim,sssc-smxl)) + srxflx=L_mks2cgs*min(hmxl,srxdpt)/(srxday*86400.) + . *min(srxlim,max(-srxlim,sssc-smxl))/alpha0 salrlx(i,j)=-srxflx util3(i,j)=max(0.,salrlx(i,j))*scp2(i,j) util4(i,j)=min(0.,salrlx(i,j))*scp2(i,j) @@ -269,7 +274,7 @@ subroutine thermf_cesm(m,n,mm,nn,k1m,k1n) c --- --- Friction velocity (cm/s) c --- ------------------------------------------------------------------- c - ustar(i,j)=ustarw(i,j)*1.e2 + ustar(i,j)=ustarw(i,j)*L_mks2cgs c enddo enddo @@ -287,7 +292,7 @@ subroutine thermf_cesm(m,n,mm,nn,k1m,k1n) call xcsum(totwfl,util2,ips) c c --- Correction for the virtual salt flux [kg m-2 s-1] - sflxc=(-sref*totwfl*1.e-3-totsfl)/area + sflxc=(-sref*totwfl*g2kg-totsfl)/area if (mnproc.eq.1) then write (lp,*) 'thermf: totsfl/area,sflxc',totsfl/area,sflxc endif @@ -298,8 +303,10 @@ subroutine thermf_cesm(m,n,mm,nn,k1m,k1n) do j=1,jj do l=1,isp(j) do i=max(1,ifp(j,l)),min(ii,ilp(j,l)) - salflx(i,j)=-(vrtsfl(i,j)+sflxc+sfl(i,j))*1.e2 - brnflx(i,j)=-brnflx(i,j)*1.e2 + salflx(i,j)=-(vrtsfl(i,j)+sflxc+sfl(i,j)) + . *(kg2g*(M_mks2cgs/L_mks2cgs**2)) + brnflx(i,j)=-brnflx(i,j) + . *(kg2g*(M_mks2cgs/L_mks2cgs**2)) enddo enddo enddo @@ -308,7 +315,7 @@ subroutine thermf_cesm(m,n,mm,nn,k1m,k1n) c --- if srxday>0 and srxbal=.true. , balance the sss relaxation flux c --- so the net input of salt in grid cells connected to the world c --- ocean is zero - if (srxday.gt.epsil.and.srxbal) then + if (srxday.gt.epsilt.and.srxbal) then call xcsum(totsrp,util3,ipwocn) call xcsum(totsrn,util4,ipwocn) if (abs(totsrp-totsrn).gt.0.) then @@ -352,14 +359,14 @@ subroutine thermf_cesm(m,n,mm,nn,k1m,k1n) tottrav=tottrav/area c trflxc=(-tottrsf)/area -c trflxc=(-tottrav*totwfl*1.e-3-tottrsf)/area +c trflxc=(-tottrav*totwfl*g2kg-tottrsf)/area c trflxc=0. c c$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)) - trflx(nt,i,j)=-(trflx(nt,i,j)+trflxc)*1.e2 + trflx(nt,i,j)=-(trflx(nt,i,j)+trflxc)*L_mks2cgs enddo enddo enddo diff --git a/channel/thermf_channel.F b/channel/thermf_channel.F index bc0ee447..41a565f9 100644 --- a/channel/thermf_channel.F +++ b/channel/thermf_channel.F @@ -24,7 +24,7 @@ subroutine thermf_channel(m,n,mm,nn,k1m,k1n) use mod_xc use mod_types, only: r8 use mod_ben02, only: ntda - use mod_constants, only: spcifh, t0deg, epsil, onem + use mod_constants, only: spcifh, t0deg, epsilt, onem use mod_time, only: nday_in_year, nday_of_year, nstep, . nstep_in_day, baclin, . xmi, l1mi, l2mi, l3mi, l4mi, l5mi @@ -217,7 +217,7 @@ subroutine thermf_channel(m,n,mm,nn,k1m,k1n) surrlx(i,j)=0._r8 ! ! --- --- If trxday>0 , apply relaxation towards observed sst - if (trxday.gt.epsil) then + if (trxday.gt.epsilt) then sstc=intp1d(sstclm(i,j,l1mi),sstclm(i,j,l2mi), . sstclm(i,j,l3mi),sstclm(i,j,l4mi), . sstclm(i,j,l5mi),xmi) @@ -248,7 +248,7 @@ subroutine thermf_channel(m,n,mm,nn,k1m,k1n) salrlx(i,j)=0._r8 ! ! --- --- if srxday>0 , apply relaxation towards observed sss - if (srxday.gt.epsil) then + if (srxday.gt.epsilt) then sssc=intp1d(sssclm(i,j,l1mi),sssclm(i,j,l2mi), . sssclm(i,j,l3mi),sssclm(i,j,l4mi), . sssclm(i,j,l5mi),xmi) @@ -319,7 +319,7 @@ subroutine thermf_channel(m,n,mm,nn,k1m,k1n) ! --- if srxday>0 and srxbal=.true. , balance the sss relaxation flux ! --- so the net input of salt in grid cells connected to the world ! --- ocean is zero - if (srxday.gt.epsil.and.srxbal) then + if (srxday.gt.epsilt.and.srxbal) then call xcsum(totsrp,util3,ipwocn) call xcsum(totsrn,util4,ipwocn) if (abs(totsrp).gt.abs(totsrn)) then diff --git a/cime_config/buildcpp b/cime_config/buildcpp index a5765864..ca879e86 100644 --- a/cime_config/buildcpp +++ b/cime_config/buildcpp @@ -88,6 +88,7 @@ def buildcpp(case): hamocc_sedbypass = case.get_value("HAMOCC_SEDBYPASS") hamocc_ciso = case.get_value("HAMOCC_CISO") hamocc_vsls = case.get_value("HAMOCC_VSLS") + blom_unit = case.get_value("BLOM_UNIT") expect(blom_vcoord != "cntiso_hybrid" or not turbclo, "BLOM_VCOORD == {} and BLOM_TURBULENT_CLOSURE == {} is not a valid combination".format(blom_vcoord, turbclo)) @@ -149,6 +150,11 @@ def buildcpp(case): else: expect(False, "tracer module {} is not recognized".format(module)) + if blom_unit == "mks": + blom_cppdefs = blom_cppdefs + " -DMKS" + else: + expect(blom_unit == "cgs", "Unit system {} is not recognized".format(blom_unit)) + blom_cppdefs = "-DMPI" + blom_cppdefs # update the xml variable BLOM_CPPDEFS with the above definition diff --git a/cime_config/buildnml b/cime_config/buildnml index 57cc45eb..56c2ad5a 100755 --- a/cime_config/buildnml +++ b/cime_config/buildnml @@ -7,6 +7,7 @@ set CASEROOT = `./xmlquery CASEROOT --value` set OCN_GRID = `./xmlquery OCN_GRID --value` set BLOM_VCOORD = `./xmlquery BLOM_VCOORD --value` +set BLOM_UNIT = `./xmlquery BLOM_UNIT --value` set DIN_LOC_ROOT = `./xmlquery DIN_LOC_ROOT --value` set RUN_TYPE = `./xmlquery RUN_TYPE --value` set CONTINUE_RUN = `./xmlquery CONTINUE_RUN --value` @@ -74,20 +75,37 @@ set EXPCNF = "'cesm'" set RUNTYP = "'$RUN_TYPE'" set GRFILE = "'unset'" set ICFILE = "'unset'" -set PREF = 2000.e5 +if ($BLOM_UNIT == cgs) then + set PREF = 2000.e5 +else + set PREF = 2000.e4 +endif set BACLIN = 1800. set BATROP = 36. -set MDV2HI = 2. -set MDV2LO = .4 -set MDV4HI = 0. -set MDV4LO = 0. -set MDC2HI = 5000.e4 -set MDC2LO = 300.e4 +if ($BLOM_UNIT == cgs) then + set MDV2HI = 2. + set MDV2LO = .4 + set MDV4HI = 0. + set MDV4LO = 0. + set MDC2HI = 5000.e4 + set MDC2LO = 300.e4 +else + set MDV2HI = .02 + set MDV2LO = .004 + set MDV4HI = 0. + set MDV4LO = 0. + set MDC2HI = 5000. + set MDC2LO = 300. +endif set VSC2HI = .5 set VSC2LO = .5 set VSC4HI = 0. set VSC4LO = 0. -set CBAR = 5. +if ($BLOM_UNIT == cgs) then + set CBAR = 5. +else + set CBAR = .05 +endif set CB = .002 set CWBDTS = 5.e-5 set CWBDLS = 25. @@ -161,14 +179,25 @@ set EDWMTH = "'smooth'" set EDSPRS = .true. set EGC = 0.85 set EGGAM = 200. -set EGLSMN = 4000.e2 -set EGMNDF = 100.e4 -set EGMXDF = 1500.e4 +if ($BLOM_UNIT == cgs) then + set EGLSMN = 4000.e2 + set EGMNDF = 100.e4 + set EGMXDF = 1500.e4 +else + set EGLSMN = 4000. + set EGMNDF = 100. + set EGMXDF = 1500. +endif set EGIDFQ = 1. set RI0 = 1.2 set BDMTYP = 2 -set BDMC1 = 5.e-4 -set BDMC2 = .1 +if ($BLOM_UNIT == cgs) then + set BDMC1 = 5.e-4 + set BDMC2 = .1 +else + set BDMC1 = 5.e-8 + set BDMC2 = 1.e-5 +endif set TKEPF = .006 if ($BLOM_VCOORD == isopyc_bulkml) then set LTEDTP = "'layer'" @@ -624,7 +653,11 @@ else if ($OCN_GRID == tnx2v1 ) then set BACLIN = 4800. set BATROP = 96. set EGC = 0.5 - set EGMXDF = 1000.e4 + if ($BLOM_UNIT == cgs) then + set EGMXDF = 1000.e4 + else + set EGMXDF = 1000. + endif set CWMTAG = "'Gibraltar','Gibraltar'" set CWMEDG = " 'u', 'u'" set CWMI = " 53, 54" @@ -634,7 +667,11 @@ else if ($OCN_GRID == tnx1.5v1 ) then set BACLIN = 4800. set BATROP = 96. set EGC = 0.5 - set EGMXDF = 1000.e4 + if ($BLOM_UNIT == cgs) then + set EGMXDF = 1000.e4 + else + set EGMXDF = 1000. + endif else if ($OCN_GRID == tnx1v1 || $OCN_GRID == tnx1v3 || $OCN_GRID == tnx1v4) then if ($OCN_NCPL == 24) then set BACLIN = 3600. @@ -655,33 +692,58 @@ else if ($OCN_GRID == tnx1v1 || $OCN_GRID == tnx1v3 || $OCN_GRID == tnx1v4) then else if ($OCN_GRID == tnx0.25v1 || $OCN_GRID == tnx0.25v3 || $OCN_GRID == tnx0.25v4) then set BACLIN = 900. set BATROP = 15. - set MDV2HI = .15 - set MDV2LO = .15 + if ($BLOM_UNIT == cgs) then + set MDV2HI = .15 + set MDV2LO = .15 + set MDV4HI = 0. + set MDV4LO = 0. + set MDC2HI = 300.e4 + set MDC2LO = 300.e4 + else + set MDV2HI = .0015 + set MDV2LO = .0015 + set MDV4HI = 0. + set MDV4LO = 0. + set MDC2HI = 300. + set MDC2LO = 300. + endif set VSC2HI = .15 set VSC2LO = .15 set VSC4HI = 0.0625 set VSC4LO = 0.0625 - set MDC2HI = 300.e4 set CWBDTS = 0.75e-4 set CWBDLS = 25. set EDWMTH = "'step'" set EGC = 0.85 - set EGMXDF = 1500.e4 + if ($BLOM_UNIT == cgs) then + set EGMXDF = 1500.e4 + else + set EGMXDF = 1500. + endif set CE = 1.0 else if ($OCN_GRID == tnx0.125v4) then set BACLIN = 300. set BATROP = 6. - set EGMNDF = 0.0 - set EGMXDF = 0.0 + set EGMNDF = 0. + set EGMXDF = 0. set EDWMTH = "'step'" set CWBDTS = .75e-4 set CWBDLS = 25 - set MDV2HI = .5 - set MDV2LO = .1 - set MDV4HI = 0. - set MDV4LO = 0. - set MDC2HI = 300.e4 - set MDC2LO = 100.e4 + if ($BLOM_UNIT == cgs) then + set MDV2HI = .5 + set MDV2LO = .1 + set MDV4HI = 0. + set MDV4LO = 0. + set MDC2HI = 300.e4 + set MDC2LO = 100.e4 + else + set MDV2HI = .005 + set MDV2LO = .001 + set MDV4HI = 0. + set MDV4LO = 0. + set MDC2HI = 300. + set MDC2LO = 100. + endif set VSC2HI = .5 set VSC2LO = .5 set VSC4HI = 0.0 diff --git a/cime_config/config_component.xml b/cime_config/config_component.xml index 84973cb0..8ed52757 100644 --- a/cime_config/config_component.xml +++ b/cime_config/config_component.xml @@ -227,6 +227,15 @@ Optional turbulent closure. Valid values one of: twoeq oneeq. Additional values: advection isodif + + char + + cgs + build_component_blom + env_build.xml + Unit system. Valid values one of: cgs mks. + + BLOM default: BLOM/Ecosystem: diff --git a/drivers/mct/domain_mct.F b/drivers/mct/domain_mct.F index 34e07813..4c088b69 100644 --- a/drivers/mct/domain_mct.F +++ b/drivers/mct/domain_mct.F @@ -27,6 +27,7 @@ subroutine domain_mct(gsMap_ocn, dom_ocn, lsize, perm, jjcpl) use mod_types, only: r8 use mod_xc use mod_grid, only: scp2, plon, plat + use mod_constants, only: L_mks2cgs implicit none @@ -105,7 +106,7 @@ subroutine domain_mct(gsMap_ocn, dom_ocn, lsize, perm, jjcpl) enddo call mct_gGrid_importRattr(dom_ocn, "lat", rdata, lsize) - radius = SHR_CONST_REARTH*1.e2_r8 ! Earth's radius in cm + radius = SHR_CONST_REARTH*L_mks2cgs ! Earth's radius in cm n = 0 do j = 1, jjcpl diff --git a/drivers/mct/export_mct.F b/drivers/mct/export_mct.F index d5ca668e..cff6c4c2 100644 --- a/drivers/mct/export_mct.F +++ b/drivers/mct/export_mct.F @@ -23,6 +23,7 @@ subroutine export_mct(o2x_o, lsize, perm, jjcpl, nsend, sbuff, ! Uses modules use mct_mod + use mod_constants, only: L_mks2cgs use shr_const_mod, only: SHR_CONST_TKFRZ use mod_types, only: r8 use blom_cpl_indices @@ -47,8 +48,10 @@ subroutine export_mct(o2x_o, lsize, perm, jjcpl, nsend, sbuff, integer i, j, n real(r8) :: tfac, utmp, vtmp + real(r8) :: iL_mks2cgs tfac = 1._r8/tlast_coupled + iL_mks2cgs = 1._r8/L_mks2cgs ! ---------------------------------------------------------------- ! Interpolate onto scalar points, rotate, and pack surface @@ -73,9 +76,9 @@ subroutine export_mct(o2x_o, lsize, perm, jjcpl, nsend, sbuff, vtmp = .5_r8*( sbuff(i,j ,index_o2x_So_v) . + sbuff(i,j+1,index_o2x_So_v)) o2x_o%rattr(index_o2x_So_u,n) = - . (utmp*cosang(i,j) - vtmp*sinang(i,j))*tfac*1.e-2_r8 + . (utmp*cosang(i,j) - vtmp*sinang(i,j))*tfac*iL_mks2cgs o2x_o%rattr(index_o2x_So_v,n) = - . (utmp*sinang(i,j) + vtmp*cosang(i,j))*tfac*1.e-2_r8 + . (utmp*sinang(i,j) + vtmp*cosang(i,j))*tfac*iL_mks2cgs utmp = ( sbuff(i ,j,index_o2x_So_dhdx)*iu(i ,j) . + sbuff(i+1,j,index_o2x_So_dhdx)*iu(i+1,j)) . /max(1,iu(i,j) + iu(i+1,j)) diff --git a/fuk95/mod_fuk95.F90 b/fuk95/mod_fuk95.F90 index 6dd0a7bc..9a2b7054 100644 --- a/fuk95/mod_fuk95.F90 +++ b/fuk95/mod_fuk95.F90 @@ -1,5 +1,5 @@ ! ------------------------------------------------------------------------------ -! Copyright (C) 2021 Mats Bentsen +! Copyright (C) 2021-2022 Mats Bentsen ! ! This file is part of BLOM. ! @@ -25,7 +25,8 @@ module mod_fuk95 ! ------------------------------------------------------------------------------ use mod_types, only: r8 - use mod_constants, only: g, rearth, pi, radian, epsil + 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_grid, only: qclon, qclat, pclon, pclat, uclon, uclat, vclon, vclat, & @@ -45,19 +46,32 @@ module mod_fuk95 private +! real(r8), parameter :: & +! u0 = 30._r8, & ! Maximum jet velocity [cm s-1]. +! h1 = 1.e4_r8, & ! Depth of active layer [cm]. +! h0 = 2.e4_r8, & ! Depth of water column [cm]. +! l0 = 2.e6_r8, & ! Half-width of the jet [cm]. +! drho = 0.19e-3_r8, & ! Active layer density difference [g cm-3]. +! rhoc = 1.0259_r8, & ! Density at the center of active layer [g cm-3]. +! rhob = 1.0270_r8, & ! Density of water beneath active layer [g cm-3]. +! f = 1.e-4_r8, & ! Coriolis parameter [1 s-1]. +! lat0 = 45._r8, & ! Center latitude of grid domain [deg]. +! lambda = 20.8e5, & ! Channel length [cm]. +! mindz = 1.e2_r8, & ! Minimum interior layer thickness [cm]. +! saln0 = 35._r8 ! Constant salinity value [g kg-1]. real(r8), parameter :: & - u0 = 30._r8, & ! Maximum jet velocity [cm s-1]. - h1 = 1.e4_r8, & ! Depth of active layer [cm]. - h0 = 2.e4_r8, & ! Depth of water column [cm]. - l0 = 2.e6_r8, & ! Half-width of the jet [cm]. - drho = 0.19e-3_r8, & ! Active layer density difference [g cm-3]. - rho1 = 1.0259_r8, & ! Density at the center of active layer [g cm-3]. - rho0 = 1.0270_r8, & ! Density of water beneath active layer [g cm-3]. - f = 1.e-4_r8, & ! Coriolis parameter [1 s-1]. - lat0 = 45._r8, & ! Center latitude of grid domain [deg]. - lambda = 20.8e5, & ! Channel length [cm]. - mindz = 1.e2_r8, & ! Minimum interior layer thickness [cm]. - saln0 = 35._r8 ! Constant salinity value [g kg-1]. + u0 = .3_r8*L_mks2cgs, & ! Maximum jet velocity [m s-1]. + h1 = 1.e2_r8*L_mks2cgs, & ! Depth of active layer [m]. + h0 = 2.e2_r8*L_mks2cgs, & ! Depth of water column [m]. + l0 = 2.e4_r8*L_mks2cgs, & ! Half-width of the jet [m]. + drho = 0.19_r8*R_mks2cgs, & ! Active layer density difference [kg m-3]. + rhoc = 1025.9_r8*R_mks2cgs, & ! Density at the center of active layer [kg m-3]. + rhob = 1027.0_r8*R_mks2cgs, & ! Density of water beneath active layer [kg m-3]. + f = 1.e-4_r8, & ! Coriolis parameter [1 s-1]. + lat0 = 45._r8, & ! Center latitude of grid domain [deg]. + lambda = 20.8e3*L_mks2cgs, & ! Channel length [m]. + mindz = 1._r8*L_mks2cgs, & ! Minimum interior layer thickness [m]. + saln0 = 35._r8 ! Constant salinity value [g kg-1]. public :: geoenv_fuk95, inifrc_fuk95, ictsz_fuk95 @@ -132,7 +146,7 @@ subroutine geoenv_fuk95 tmpg(1 , j) = 0._r8 tmpg(itdm, j) = 0._r8 do i = 2, itdm - 1 - tmpg(i, j) = h0*1.e-2 + tmpg(i, j) = h0*L_mks2cgs**(-1) enddo enddo !$omp end parallel do @@ -281,10 +295,10 @@ subroutine ictsz_fuk95 ! and corresponding isopycnic layer structure. The bulk mixed layer ! is set to the minimum mixed layer thickness. - drhojet = rho1*f*u0*l0/(g*h1) + drhojet = rhoc*f*u0*l0/(g*h1) dsig = (drho + drhojet)/(kk - 4) - sigref(kk) = rho0 - 1._r8 - sigref(kk - 1) = rho1 + .5_r8*(drho + drhojet) - 1._r8 + 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 @@ -310,11 +324,11 @@ subroutine ictsz_fuk95 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*1.e2_r8 - z(i, j, 3) = mltmin*1.e2_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 = rho1*(1._r8 + f*u0*x_psi(x)/(g*h1)) - 1._r8 + 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 & @@ -327,7 +341,7 @@ subroutine ictsz_fuk95 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 = rho1*(1._r8 + f*u0*x_psi(x)/(g*h1)) - 1._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), & @@ -347,20 +361,20 @@ subroutine ictsz_fuk95 ! active layer is distributed equally among the remaining model ! layers using constant z-level interfaces. -! drhojet = rho1*f*u0*l0/(g*h1) +! drhojet = rhoc*f*u0*l0/(g*h1) ! dsig = (drho + drhojet)/(kk - 4) -! sigref(kk) = .5_r8*(rho0 + rho1) + .25_r8*(drho + drhojet) - 1._r8 -! sigref(kk - 1) = rho1 + .5_r8*(drho + drhojet - dsig) - 1._r8 +! 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 = rho1*f*u0*l0/(g*h1) + drhojet = rhoc*f*u0*l0/(g*h1) dsig = (drho + drhojet)/(kk - 5) - sigref(kk - 2) = rho1 + .5_r8*(drho + drhojet - dsig) - 1._r8 + 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 ) = rho0 - 1._r8 + 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 @@ -383,14 +397,14 @@ subroutine ictsz_fuk95 enddo !$omp end parallel do - s0 = rho0 - 1._r8 + 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 = rho1*(1._r8 + f*u0*x_psi(x)/(g*h1)) - 1._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)) & @@ -426,7 +440,7 @@ subroutine ictsz_fuk95 zl = .5_r8*(z(i, j - 1, k + 1) + z(i, j, k + 1)) v1 = u0*psi(x)*(h1 - .5*(zu + zl))/h1 v1 = 0._r8 - if (abs(zl - zu) < epsil) then + if (abs(zl - zu) < epsilz) then v(i, j, k) = v1 else v(i, j, k) = ( v1*max(0._r8, min(zl, h1) - zu) & diff --git a/meson.build b/meson.build index baf58d7d..9f237b7e 100644 --- a/meson.build +++ b/meson.build @@ -71,6 +71,10 @@ subdir('pkgs/') # Handle options and add necessary flags and subfolders with source files +if get_option('mks') + add_project_arguments('-DMKS', language: 'fortran') +endif + turbclo = get_option('turbclo') if turbclo.length() > 0 and get_option('vcoord') == 'cntiso_hybrid' message('Setting turbclo = [] for vcoord == \'cntiso_hybrid\'') diff --git a/meson_options.txt b/meson_options.txt index af50852a..8e48383f 100644 --- a/meson_options.txt +++ b/meson_options.txt @@ -13,6 +13,8 @@ option('vcoord', type: 'combo', option('driver', type: 'combo', choices: ['nocoupler', 'noforc'], value: 'nocoupler') # List of BLOM options +option('mks', type: 'boolean', + description: 'Enable MKS units', value: false) option('turbclo', type: 'array', choices: ['oneeq', 'twoeq', 'advection', 'isodif'], description: 'Turbulent closure options', value: ['oneeq', 'advection']) diff --git a/phy/convec.F b/phy/convec.F index 83d12baa..9b68bfcb 100644 --- a/phy/convec.F +++ b/phy/convec.F @@ -1,5 +1,5 @@ ! ------------------------------------------------------------------------------ -! Copyright (C) 2009-2021 Mats Bentsen +! Copyright (C) 2009-2022 Mats Bentsen, Mehmet Ilicak ! ! This file is part of BLOM. ! @@ -24,7 +24,7 @@ subroutine convec(m,n,mm,nn,k1m,k1n) c --- layers c --- ------------------------------------------------------------------ c - use mod_constants, only: epsil + use mod_constants, only: epsilp use mod_xc use mod_vcoord, only: sigmar use mod_eos, only: rho, sig, sofsig @@ -84,7 +84,7 @@ subroutine convec(m,n,mm,nn,k1m,k1n) c k=3 dps=0. - do while (delp(k).lt.epsil) + do while (delp(k).lt.epsilp) dps=dps+delp(k) delp(k)=0. k=k+1 @@ -212,7 +212,7 @@ subroutine convec(m,n,mm,nn,k1m,k1n) k=kfpl do while (rho(dps,ttmp,stmp).gt. . rho(dps,ttem(k),ssal(k)).or. - . delp(k).lt.epsil) + . delp(k).lt.epsilp) tdps=tdps+ttem(k)*delp(k) sdps=sdps+ssal(k)*delp(k) dps=dps+delp(k) diff --git a/phy/diapfl.F b/phy/diapfl.F index 0ba42b2b..6d6badc5 100644 --- a/phy/diapfl.F +++ b/phy/diapfl.F @@ -1,5 +1,5 @@ ! ------------------------------------------------------------------------------ -! Copyright (C) 2009-2021 Mats Bentsen, Mehmet Ilicak +! Copyright (C) 2009-2022 Mats Bentsen, Mehmet Ilicak ! ! This file is part of BLOM. ! @@ -23,7 +23,7 @@ subroutine diapfl(m,n,mm,nn,k1m,k1n) c --- Diapycnal mixing c --- ------------------------------------------------------------------ c - use mod_constants, only: g, alpha0, spval, epsil, onem + use mod_constants, only: g, alpha0, spval, epsilp, onem, L_mks2cgs use mod_time, only: delt1 use mod_xc use mod_vcoord, only: sigmar @@ -64,7 +64,7 @@ subroutine diapfl(m,n,mm,nn,k1m,k1n) c --- scale bottom boundary layer mixing [cm/s] real dsgmnr,fcmxr,dsgcr0,dfeps,gbbl,kappa,ustmin parameter (dsgmnr=.1,fcmxr=.25,dsgcr0=.25,dfeps=1.e-12,gbbl=.2, - . kappa=.4,ustmin=.01) + . kappa=.4,ustmin=.0001*L_mks2cgs) c real, save, dimension(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy,kdm) :: . fpug=spval,fplg=spval @@ -133,7 +133,7 @@ subroutine diapfl(m,n,mm,nn,k1m,k1n) kmin=kfpl-2 kmax=1 do k=2,kk - if (delp(k).gt.epsil) kmax=k + if (delp(k).gt.epsilp) kmax=k enddo c if (kmin.lt.kmax) then @@ -314,7 +314,7 @@ subroutine diapfl(m,n,mm,nn,k1m,k1n) . i+i0,j+j0 open (10,file='diapfl.uf',form='unformatted') write (10) kk,kfpl - write (10) g,alpha0,epsil,onem,delt1,dsgmnr,q,q + write (10) g,alpha0,epsilp,onem,delt1,dsgmnr,q,q write (10) ttem0,ssal0,delp0,dens0,sigr0,nu0 close (10) call xchalt('(diapfl)') @@ -334,7 +334,7 @@ subroutine diapfl(m,n,mm,nn,k1m,k1n) f(k)=min(fmax(k), . .5*sqrt(c*nu(k)*dsg(k) . *(dsgui(k)+dsgli(k)))*dsghm(k), - . c*nu(k)*dsg(k)/max(epsil,delp(k))) + . c*nu(k)*dsg(k)/max(epsilp,delp(k))) fold(k)=f(k) h(k)=fcu(k )*dsgui(k )-fcl(k )*dsgli(k ) . +fcl(k-1)*dsgli(k-1)-fcu(k+1)*dsgui(k+1) @@ -519,7 +519,7 @@ subroutine diapfl(m,n,mm,nn,k1m,k1n) . i+i0,j+j0,maxdf,dflim open (10,file='diapfl.uf',form='unformatted') write (10) kk,kfpl - write (10) g,alpha0,epsil,onem,delt1,dsgmnr,q,q + write (10) g,alpha0,epsilp,onem,delt1,dsgmnr,q,q write (10) ttem0,ssal0,delp0,dens0,sigr0,nu0 close (10) call xchalt('(diapfl)') diff --git a/phy/diffus.F b/phy/diffus.F index e99a4983..fc590fd7 100644 --- a/phy/diffus.F +++ b/phy/diffus.F @@ -1,5 +1,5 @@ ! ------------------------------------------------------------------------------ -! Copyright (C) 2006-2022 Mats Bentsen +! Copyright (C) 2006-2022 Mats Bentsen, Mehmet Ilicak ! ! This file is part of BLOM. ! @@ -24,6 +24,7 @@ subroutine diffus(m,n,mm,nn,k1m,k1n) c --- ------------------------------------------------------------------ c use mod_time, only: delt1 + use mod_constants, only: P_mks2cgs use mod_xc use mod_grid, only: scuy, scvx, scp2, scuxi, scvyi use mod_eos, only: sig @@ -47,7 +48,7 @@ subroutine diffus(m,n,mm,nn,k1m,k1n) #endif c real dpeps - parameter (dpeps=1.e-4) + parameter (dpeps=1.e-5*P_mks2cgs) c call xctilr(dp(1-nbdy,1-nbdy,k1n), 1,kk, 3,3, halo_ps) if (ltedtp_opt.eq.ltedtp_neutral) then diff --git a/phy/geoenv_file.F b/phy/geoenv_file.F index 11ebf88c..c130fd50 100644 --- a/phy/geoenv_file.F +++ b/phy/geoenv_file.F @@ -1,5 +1,5 @@ ! ------------------------------------------------------------------------------ -! Copyright (C) 2015-2020 Mats Bentsen, Ping-Gin Chiu +! Copyright (C) 2015-2022 Mats Bentsen, Ping-Gin Chiu, Mehmet Ilicak ! ! This file is part of BLOM. ! @@ -25,7 +25,7 @@ subroutine geoenv_file c --- ------------------------------------------------------------------ c use mod_config, only: inst_suffix - use mod_constants, only: rearth, pi, radian + use mod_constants, only: rearth, pi, radian, L_mks2cgs use mod_xc use mod_grid, only: grfile, qclon, qclat, pclon, pclat, uclon, . uclat, vclon, vclat, scqx, scqy, scpx, scpy, @@ -797,18 +797,18 @@ subroutine geoenv_file do j=1,jj do i=1,ii c - scqx(i,j)=scqx(i,j)*1.e2 - scqy(i,j)=scqy(i,j)*1.e2 - scpx(i,j)=scpx(i,j)*1.e2 - scpy(i,j)=scpy(i,j)*1.e2 - scux(i,j)=scux(i,j)*1.e2 - scuy(i,j)=scuy(i,j)*1.e2 - scvx(i,j)=scvx(i,j)*1.e2 - scvy(i,j)=scvy(i,j)*1.e2 - scq2(i,j)=scq2(i,j)*1.e4 - scp2(i,j)=scp2(i,j)*1.e4 - scu2(i,j)=scu2(i,j)*1.e4 - scv2(i,j)=scv2(i,j)*1.e4 + scqx(i,j)=scqx(i,j)*L_mks2cgs + scqy(i,j)=scqy(i,j)*L_mks2cgs + scpx(i,j)=scpx(i,j)*L_mks2cgs + scpy(i,j)=scpy(i,j)*L_mks2cgs + scux(i,j)=scux(i,j)*L_mks2cgs + scuy(i,j)=scuy(i,j)*L_mks2cgs + scvx(i,j)=scvx(i,j)*L_mks2cgs + scvy(i,j)=scvy(i,j)*L_mks2cgs + scq2(i,j)=scq2(i,j)*L_mks2cgs**2 + scp2(i,j)=scp2(i,j)*L_mks2cgs**2 + scu2(i,j)=scu2(i,j)*L_mks2cgs**2 + scv2(i,j)=scv2(i,j)*L_mks2cgs**2 c cosang(i,j)=cos(angle(i,j)) sinang(i,j)=sin(angle(i,j)) diff --git a/phy/mod_cmnfld.F90 b/phy/mod_cmnfld.F90 index 6fe55510..4b9b8890 100644 --- a/phy/mod_cmnfld.F90 +++ b/phy/mod_cmnfld.F90 @@ -1,5 +1,5 @@ ! ------------------------------------------------------------------------------ -! Copyright (C) 2015-2022 Mats Bentsen +! Copyright (C) 2015-2022 Mats Bentsen, Mehmet Ilicak ! ! This file is part of BLOM. ! @@ -24,7 +24,7 @@ module mod_cmnfld ! ------------------------------------------------------------------------------ use mod_types, only: r8 - use mod_constants, only: spval + use mod_constants, only: spval, onem, L_mks2cgs use mod_xc implicit none @@ -33,7 +33,7 @@ module mod_cmnfld ! Parameters: real(r8) :: & - sls0 = 10._r8*98060._r8, & ! Minimum smoothing length scale in the + sls0 = 10._r8*onem, & ! Minimum smoothing length scale in the ! computation of filtered BFSQ [g cm-1 s-2]. slsmfq = 2._r8, & ! Factor to be multiplied with the mixed ! layer depth to find the smoothing length @@ -45,7 +45,7 @@ module mod_cmnfld ! computation of filtered BFSQ []. bfsqmn = 1.e-7_r8, & ! Minimum value of BFSQ used in the ! computation of neutral slope [s-2]. - dbcrit = .03_r8 ! Critical buoyancy difference used in the + dbcrit = .0003_r8*L_mks2cgs! Critical buoyancy difference used in the ! mixed layer thickness estimation (Levitus, ! 1982) [cm s-2]. diff --git a/phy/mod_cmnfld_routines.F90 b/phy/mod_cmnfld_routines.F90 index 761ac198..ef6f7cb1 100644 --- a/phy/mod_cmnfld_routines.F90 +++ b/phy/mod_cmnfld_routines.F90 @@ -1,5 +1,5 @@ ! ------------------------------------------------------------------------------ -! Copyright (C) 2015-2022 Mats Bentsen +! Copyright (C) 2015-2022 Mats Bentsen, Mehmet Ilicak ! ! This file is part of BLOM. ! @@ -24,7 +24,7 @@ module mod_cmnfld_routines ! ------------------------------------------------------------------------------ use mod_types, only: r8 - use mod_constants, only: g, alpha0, epsil, onem, onecm, onemm + 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_grid, only: scuxi, scvyi @@ -125,7 +125,7 @@ subroutine cmnfld_bfsqf_isopyc_bulkml(m, n, mm, nn, k1m, k1n) sup = saln(i, j, 2 + nn) do k = kfpl, kk kn = k + nn - if (p(i, j, kk + 1) - p(i, j, k) < epsil) then + if (p(i, j, kk + 1) - p(i, j, k) < epsilp) then delp(k) = onemm bfsqi(i, j, k) = bfsqi(i, j, k - 1) bfsq(k) = bfsqmn @@ -133,7 +133,7 @@ subroutine cmnfld_bfsqf_isopyc_bulkml(m, n, mm, nn, k1m, k1n) q = max(sls0, delp(kfpl - 1)*slsmfq*q + sls0*(1._r8 - q)) sls2(k) = q*q else - if (p(i, j, kk + 1) - p(i, j, k + 1) < epsil) then + if (p(i, j, kk + 1) - p(i, j, k + 1) < epsilp) then plo = p(i, j, kk + 1) else plo = .5_r8*(p(i, j, k) + p(i, j, k + 1)) @@ -262,13 +262,13 @@ subroutine cmnfld_bfsqf_cntiso_hybrid(m, n, mm, nn, k1m, k1n) sup = saln(i, j, 1 + nn) do k = 2, kk kn = k + nn - if (p(i, j, kk + 1) - p(i, j, k) < epsil) then + if (p(i, j, kk + 1) - p(i, j, k) < epsilp) then delp(k) = onemm bfsqi(i, j, k) = bfsqi(i, j, k - 1) bfsq(k) = bfsqmn sls2(k) = sls0*sls0 else - if (p(i, j, kk + 1) - p(i, j, k + 1) < epsil) then + if (p(i, j, kk + 1) - p(i, j, k + 1) < epsilp) then plo = p(i, j, kk + 1) else plo = .5_r8*(p(i, j, k) + p(i, j, k + 1)) @@ -376,10 +376,10 @@ subroutine cmnfld_bfsqi_cntiso_hybrid(m, n, mm, nn, k1m, k1n) sup = saln(i, j, 1 + nn) do k = 2, kk kn = k + nn - if (p(i, j, kk + 1) - p(i, j, k) < epsil) then + if (p(i, j, kk + 1) - p(i, j, k) < epsilp) then bfsqi(i, j, k) = bfsqi(i, j, k - 1) else - if (p(i, j, kk + 1) - p(i, j, k + 1) < epsil) then + if (p(i, j, kk + 1) - p(i, j, k + 1) < epsilp) then plo = p(i, j, kk + 1) else plo = .5_r8*(p(i, j, k) + p(i, j, k + 1)) @@ -420,7 +420,7 @@ subroutine cmnfld_nslope_isopyc_bulkml(m, n, mm, nn, k1m, k1n) integer, intent(in) :: m, n, mm, nn, k1m, k1n - real(r8) :: rho0, pm, rho_x, phi_x, bfsqm, rho_y, phi_y + real(r8) :: pm, rho_x, phi_x, bfsqm, rho_y, phi_y integer :: i, j, k, l, kn, kintr, kmax, knnsl ! ------------------------------------------------------------------------ @@ -433,7 +433,7 @@ subroutine cmnfld_nslope_isopyc_bulkml(m, n, mm, nn, k1m, k1n) kn = k + nn do l = 1, isp(j) do i = max(- 1, ifp(j, l)), min(ii + 2, ilp(j, l)) - if (dp(i, j, kn) < epsil) then + if (dp(i, j, kn) < epsilp) then phi(i, j, k) = phi(i, j, k + 1) else phi(i, j, k) = phi(i, j, k + 1) & @@ -454,8 +454,6 @@ subroutine cmnfld_nslope_isopyc_bulkml(m, n, mm, nn, k1m, k1n) ! bathymetry and in this case values are extrapolated from above. ! ------------------------------------------------------------------------ - rho0 = 1._r8/alpha0 - !$omp parallel do private(l, i, k, kmax, kn, kintr, knnsl, pm, rho_x, & !$omp phi_x, bfsqm) do j = - 1, jj + 2 @@ -475,7 +473,7 @@ subroutine cmnfld_nslope_isopyc_bulkml(m, n, mm, nn, k1m, k1n) kmax = 1 do k = 3, kk kn = k + nn - if (dp(i - 1, j, kn) > epsil .or. dp(i, j, kn) > epsil) & + if (dp(i - 1, j, kn) > epsilp .or. dp(i, j, kn) > epsilp) & kmax = k enddo @@ -564,7 +562,7 @@ subroutine cmnfld_nslope_isopyc_bulkml(m, n, mm, nn, k1m, k1n) kmax = 1 do k = 3, kk kn = k + nn - if (dp(i, j - 1, kn) > epsil .or. dp(i, j, kn) > epsil) & + if (dp(i, j - 1, kn) > epsilp .or. dp(i, j, kn) > epsilp) & kmax = k enddo @@ -653,7 +651,7 @@ subroutine cmnfld_nslope_cntiso_hybrid(m, n, mm, nn, k1m, k1n) integer, intent(in) :: m, n, mm, nn, k1m, k1n - real(r8) :: rho0, pm, rho_x, phi_x, bfsqm, rho_y, phi_y + real(r8) :: pm, rho_x, phi_x, bfsqm, rho_y, phi_y integer :: i, j, k, l, kn, kmax, knnsl ! ------------------------------------------------------------------------ @@ -666,7 +664,7 @@ subroutine cmnfld_nslope_cntiso_hybrid(m, n, mm, nn, k1m, k1n) kn = k + nn do l = 1, isp(j) do i = max(- 1, ifp(j, l)), min(ii + 2, ilp(j, l)) - if (dp(i, j, kn) < epsil) then + if (dp(i, j, kn) < epsilp) then phi(i, j, k) = phi(i, j, k + 1) else phi(i, j, k) = phi(i, j, k + 1) & @@ -687,8 +685,6 @@ subroutine cmnfld_nslope_cntiso_hybrid(m, n, mm, nn, k1m, k1n) ! bathymetry and in this case values are extrapolated from above. ! ------------------------------------------------------------------------ - rho0 = 1._r8/alpha0 - !$omp parallel do private(l, i, k, kmax, kn, knnsl, pm, rho_x, phi_x, bfsqm) do j = - 1, jj + 2 do l = 1, isu(j) @@ -705,7 +701,7 @@ subroutine cmnfld_nslope_cntiso_hybrid(m, n, mm, nn, k1m, k1n) kmax = 1 do k = 2, kk kn = k + nn - if (dp(i - 1, j, kn) > epsil .or. dp(i, j, kn) > epsil) kmax = k + if (dp(i - 1, j, kn) > epsilp .or. dp(i, j, kn) > epsilp) kmax=k enddo ! Index of last interface where slope vector times Brunt-Vaisala @@ -758,7 +754,7 @@ subroutine cmnfld_nslope_cntiso_hybrid(m, n, mm, nn, k1m, k1n) kmax = 1 do k = 2, kk kn = k + nn - if (dp(i, j - 1, kn) > epsil .or. dp(i, j, kn) > epsil) kmax = k + if (dp(i, j - 1, kn) > epsilp .or. dp(i, j, kn) > epsilp) kmax=k enddo ! Index of last interface where slope vector times Brunt-Vaisala @@ -881,7 +877,7 @@ subroutine cmnfld_z(m, n, mm, nn, k1m, k1n) km = k + mm do l = 1, isp(j) do i = max(1, ifp(j, l)), min(ii, ilp(j, l)) - if (dp(i, j, km) < epsil) then + if (dp(i, j, km) < epsilp) then z(i, j, k) = z(i, j, k + 1) else z(i, j, k) = z(i, j, k + 1) & @@ -934,7 +930,7 @@ subroutine cmnfld_mlts(m, n, mm, nn, k1m, k1n) zup = zlo dbup = dblo else - dbup = min(dbup, dbcrit - epsil) + dbup = min(dbup, dbcrit - epsilp) mlts(i, j) = ( zup*(dblo - dbcrit) & + zlo*(dbcrit - dbup))/(dblo - dbup) & - z(i, j, 1) diff --git a/phy/mod_constants.F90 b/phy/mod_constants.F90 index 48c17b47..adc6ce9c 100644 --- a/phy/mod_constants.F90 +++ b/phy/mod_constants.F90 @@ -1,5 +1,5 @@ ! ------------------------------------------------------------------------------ -! Copyright (C) 2020-2021 Mats Bentsen +! Copyright (C) 2020-2022 Mats Bentsen, Mehmet Ilicak ! ! This file is part of BLOM. ! @@ -28,6 +28,39 @@ module mod_constants private +#ifdef MKS + ! MKS unit + real(r8), parameter :: & + g = 9.806_r8, & ! Gravitational acceleration [m s-2]. + rearth = 6.37122e6_r8, & ! Radius of the Earth [m]. + spcifh = 3990._r8, & ! Specific heat capacity of sea water + ! [J kg-1 K-1]. + t0deg = 273.15_r8, & ! Zero degrees Celsius in Kelvin [K]. + alpha0 = 1.e-3_r8, & ! Reference value of specific volume + ! [m3 kg-1]. + rho0 = 1.e3_r8, & ! Reference value of density [kg m-3]. + pi = 3.1415926536_r8, & ! pi []. + radian = 57.295779513_r8, & ! 180/pi []. + epsilpl = 1.e-14_r8, & ! Small value for pressure*dx []. + epsilp = 1.e-12_r8, & ! Small value for pressure []. + epsilz = 1.e-9_r8, & ! Small value for depth []. + epsilt = 1.e-11_r8, & ! Small value for time []. + epsilk = 1.e-15_r8, & ! Small value for kappa []. + spval = 1.e33_r8, & ! Large value []. + tenm = 98060._r8, & ! 10 m in units of pressure [kg m-1 s-2]. + onem = 9806._r8, & ! 1 m in units of pressure [kg m-1 s-2]. + tencm = 980.6_r8, & ! 10 cm in units of pressure [kg m-1 s-2]. + onecm = 98.06_r8, & ! 1 cm in units of pressure [kg m-1 s-2]. + onemm = 9.806_r8, & ! 1 mm in units of pressure [kg m-1 s-2]. + onemu = .009806_r8, & ! 1 micrometer in units of pressure + ! [kg m-1 s-2]. + g2kg = 1.e-3_r8, & ! convert g to kg coeff + kg2g = 1.e3_r8, & ! convert kg to g coeff + L_mks2cgs = 1._r8, & ! length coefficient converting CGS to MKS + M_mks2cgs = 1._r8, & ! mass coefficient converting CGS to MKS + P_mks2cgs = 1._r8, & ! pressure coefficient converting CGS to MKS + R_mks2cgs = 1._r8 ! rho coefficient converting CGS to MKS +#else real(r8), parameter :: & g = 980.6_r8, & ! Gravitational acceleration [cm s-2]. rearth = 6.37122e8_r8, & ! Radius of the Earth [cm]. @@ -36,20 +69,33 @@ module mod_constants t0deg = 273.15_r8, & ! Zero degrees Celsius in Kelvin [K]. alpha0 = 1._r8, & ! Reference value of specific volume ! [cm3 g-1]. + rho0 = 1._r8, & ! Reference value of density [kg m-3]. pi = 3.1415926536_r8, & ! pi []. radian = 57.295779513_r8, & ! 180/pi []. - epsil = 1.e-11_r8, & ! Small value []. + epsilpl = 1.e-11_r8, & ! Small value for pressure*dx []. + epsilp = 1.e-11_r8, & ! Small value for pressure []. + epsilz = 1.e-11_r8, & ! Small value for depth []. + epsilt = 1.e-11_r8, & ! Small value for time []. + epsilk = 1.e-11_r8, & ! Small value for kappa []. spval = 1.e33_r8, & ! Large value []. tenm = 980600._r8, & ! 10 m in units of pressure [g cm-1 s-2]. onem = 98060._r8, & ! 1 m in units of pressure [g cm-1 s-2]. tencm = 9806._r8, & ! 10 cm in units of pressure [g cm-1 s-2]. onecm = 980.6_r8, & ! 1 cm in units of pressure [g cm-1 s-2]. onemm = 98.06_r8, & ! 1 mm in units of pressure [g cm-1 s-2]. - onemu = .09806_r8 ! 1 micrometer in units of pressure + onemu = .09806_r8, & ! 1 micrometer in units of pressure ! [g cm-1 s-2]. + g2kg = 1.e-3_r8, & ! convert g to kg coeff + kg2g = 1.e3_r8, & ! convert kg to g coeff + L_mks2cgs = 1.e2_r8, & ! length coefficient converting CGS to MKS + M_mks2cgs = 1.e3_r8, & ! mass coefficient converting CGS to MKS + P_mks2cgs = 1.e1_r8, & ! pressure coefficient converting CGS to MKS + R_mks2cgs = 1.e-3_r8 ! rho coefficient converting CGS to MKS +#endif - - public :: g, rearth, spcifh, t0deg, alpha0, pi, radian, epsil, spval, & - tenm, onem, tencm, onecm, onemm, onemu + public :: g, rearth, spcifh, t0deg, alpha0, rho0, pi, radian, & + epsilpl, epsilp, epsilz, epsilt, epsilk, spval, & + tenm, onem, tencm, onecm, onemm, onemu, g2kg, kg2g, & + L_mks2cgs, M_mks2cgs, P_mks2cgs, R_mks2cgs end module mod_constants diff --git a/phy/mod_dia.F b/phy/mod_dia.F index e824a5fd..1edf48fd 100644 --- a/phy/mod_dia.F +++ b/phy/mod_dia.F @@ -25,8 +25,10 @@ module mod_dia use mod_calendar, only: date_type, date_offset, calendar_noerr use mod_time, only: date0, date, calendar, nstep, nstep_in_day, . nday_of_year, time, time0, baclin, dlt - use mod_constants, only: g, spcifh, t0deg, alpha0, epsil, spval, - . onem, onecm, onemm + use mod_constants, only: g, spcifh, t0deg, alpha0, epsilp, spval, + . onem, onecm, onemm, + . L_mks2cgs, M_mks2cgs, P_mks2cgs, + . R_mks2cgs, g2kg use mod_xc use mod_nctools use netcdf, only : nf90_fill_double @@ -169,7 +171,15 @@ module mod_dia c c --- Pressure thickness [g cm-1 s-2] of region for bottom salinity and c --- temperature diagnostics - real, parameter :: dpbot=98060. + real, parameter :: dpbot=onem +c + real, parameter :: + . L_cgs2mks=1./L_mks2cgs, + . A_cgs2mks=1./(L_mks2cgs**2), + . V_cgs2mks=1./(L_mks2cgs**3), + . M_cgs2mks=1./M_mks2cgs, + . P_cgs2mks=1./P_mks2cgs, + . R_cgs2mks=1./R_mks2cgs c c --- Namelist integer, dimension(nphymax), save :: @@ -323,7 +333,7 @@ subroutine diafnm(ctag,diagfq,diagmon,diagann,fname) c date_tmp=date c - if (diagfq+epsil.gt.1.) then + if (diagfq+epsilp.gt.1.) then errstat=date_offset(calendar,date_tmp,-1) if (errstat.ne.calendar_noerr) then if (mnproc.eq.1) then @@ -968,7 +978,7 @@ subroutine diasg1 call xcbcst(j1) do k=1,kk call xceget(sigmar1(k),sigmar(1-nbdy,1-nbdy,k),i1,j1) - sigmar1(k)=sigmar1(k)*1.e3 ! Convert units from g cm-3 to kg m-3 + sigmar1(k)=sigmar1(k)*M_mks2cgs ! Convert units from g cm-3 to kg m-3 enddo if (mnproc.eq.1) then write(lp,*) 'sigma layers=',sigmar1 @@ -1201,7 +1211,7 @@ subroutine diaacc(m,n,mm,nn,k1m,k1n) zup=z(i,j,kup)+.5*dz(i,j,kup) zlo=z(i,j,k )+.5*dz(i,j,k ) tup=temp(i,j,kup+mm) - tlo=min(temp(i,j,km),tup-epsil) + tlo=min(temp(i,j,km),tup-epsilp) t20d(i,j)=(zup*(tlo-20.)+zlo*(20.-tup))/(tlo-tup) endif enddo @@ -1880,7 +1890,7 @@ subroutine diaout(iogrp,m,n,mm,nn,k1m,k1n) enddo c$OMP END PARALLEL DO call xcsum(volgs(1),util1,ips) - volgs(1)=rnacc*1e-6*volgs(1)/g + volgs(1)=rnacc*V_cgs2mks*volgs(1)/g endif if (MSC_SALNGA(iogrp).ne.0) then c$OMP PARALLEL DO PRIVATE(l,i) @@ -1949,7 +1959,7 @@ subroutine diaout(iogrp,m,n,mm,nn,k1m,k1n) tempga(1)=tempga(1)/massgs(1) endif if (MSC_MASSGS(iogrp).ne.0) then - massgs(1)=rnacc*1e-3*massgs(1)/g + massgs(1)=rnacc*M_cgs2mks*massgs(1)/g endif if (MSC_SSSGA(iogrp).ne.0) then c$OMP PARALLEL DO PRIVATE(l,i) @@ -2004,30 +2014,30 @@ subroutine diaout(iogrp,m,n,mm,nn,k1m,k1n) c c --- compute log10 of diffusivities if (LYR_DIFDIA(iogrp).eq.2) - . call loglyr(ACC_DIFDIA(iogrp),'p',1e-4,0.) + . call loglyr(ACC_DIFDIA(iogrp),'p',A_cgs2mks,0.) if (LYR_DIFVMO(iogrp).eq.2) - . call loglyr(ACC_DIFVMO(iogrp),'p',1e-4,0.) + . call loglyr(ACC_DIFVMO(iogrp),'p',A_cgs2mks,0.) if (LYR_DIFVHO(iogrp).eq.2) - . call loglyr(ACC_DIFVHO(iogrp),'p',1e-4,0.) + . call loglyr(ACC_DIFVHO(iogrp),'p',A_cgs2mks,0.) if (LYR_DIFVSO(iogrp).eq.2) - . call loglyr(ACC_DIFVSO(iogrp),'p',1e-4,0.) + . call loglyr(ACC_DIFVSO(iogrp),'p',A_cgs2mks,0.) if (LYR_DIFINT(iogrp).eq.2) - . call loglyr(ACC_DIFINT(iogrp),'p',1e-4,0.) + . call loglyr(ACC_DIFINT(iogrp),'p',A_cgs2mks,0.) if (LYR_DIFISO(iogrp).eq.2) - . call loglyr(ACC_DIFISO(iogrp),'p',1e-4,0.) + . call loglyr(ACC_DIFISO(iogrp),'p',A_cgs2mks,0.) c if (LVL_DIFDIA(iogrp).eq.2) - . call loglvl(ACC_DIFDIALVL(iogrp),'p',1e-4*rnacc,0.) + . call loglvl(ACC_DIFDIALVL(iogrp),'p',A_cgs2mks*rnacc,0.) if (LVL_DIFVMO(iogrp).eq.2) - . call loglvl(ACC_DIFVMOLVL(iogrp),'p',1e-4*rnacc,0.) + . call loglvl(ACC_DIFVMOLVL(iogrp),'p',A_cgs2mks*rnacc,0.) if (LVL_DIFVHO(iogrp).eq.2) - . call loglvl(ACC_DIFVHOLVL(iogrp),'p',1e-4*rnacc,0.) + . call loglvl(ACC_DIFVHOLVL(iogrp),'p',A_cgs2mks*rnacc,0.) if (LVL_DIFVSO(iogrp).eq.2) - . call loglvl(ACC_DIFVSOLVL(iogrp),'p',1e-4*rnacc,0.) + . call loglvl(ACC_DIFVSOLVL(iogrp),'p',A_cgs2mks*rnacc,0.) if (LVL_DIFINT(iogrp).eq.2) - . call loglvl(ACC_DIFINTLVL(iogrp),'p',1e-4*rnacc,0.) + . call loglvl(ACC_DIFINTLVL(iogrp),'p',A_cgs2mks*rnacc,0.) if (LVL_DIFISO(iogrp).eq.2) - . call loglvl(ACC_DIFISOLVL(iogrp),'p',1e-4*rnacc,0.) + . call loglvl(ACC_DIFISOLVL(iogrp),'p',A_cgs2mks*rnacc,0.) c c --- mask sea floor of level fields call msklvl(ACC_BFSQLVL(iogrp),'p') @@ -2224,32 +2234,34 @@ subroutine diaout(iogrp,m,n,mm,nn,k1m,k1n) endif c c --- write 2d fields - call wrth2d(ACC_SIGMX(iogrp),H2D_SIGMX(iogrp),rnacc*1e3, + call wrth2d(ACC_SIGMX(iogrp),H2D_SIGMX(iogrp),rnacc*R_cgs2mks, , 0.,cmpflg,ip,'p','sigmx','Mixed layer density',' ','kg m-3') c - call wrth2d(ACC_UB(iogrp),H2D_UB(iogrp),rnacc*1e-2, + call wrth2d(ACC_UB(iogrp),H2D_UB(iogrp),rnacc*L_cgs2mks, . 0.,cmpflg,iuu,'u','ubaro','Barotropic velocity x-component', . ' ','m s-1') c - call wrth2d(ACC_VB(iogrp),H2D_VB(iogrp),rnacc*1e-2, + call wrth2d(ACC_VB(iogrp),H2D_VB(iogrp),rnacc*L_cgs2mks, . 0.,cmpflg,ivv,'v','vbaro','Barotropic velocity y-component', . ' ','m s-1') c call wrth2d(ACC_PSRF(iogrp),H2D_PSRF(iogrp), - . rnacc*.1,0.,cmpflg,ip,'p','psrf','Surface pressure',' ','Pa') + . rnacc*P_cgs2mks,0.,cmpflg,ip,'p','psrf','Surface pressure', + . ' ','Pa') c call wrth2d(ACC_PBOT(iogrp),H2D_PBOT(iogrp), - . rnacc*.1,0.,cmpflg,ip,'p','pbot','Bottom pressure',' ','Pa') + . rnacc*P_cgs2mks,0.,cmpflg,ip,'p','pbot','Bottom pressure', + . ' ','Pa') c call wrth2d(ACC_SEALV(iogrp),H2D_SEALV(iogrp), - . -rnacc*1e-2,0.,cmpflg,ip,'p','sealv','Sea level',' ','m') + . -rnacc*L_cgs2mks,0.,cmpflg,ip,'p','sealv','Sea level',' ','m') c call wrth2d(ACC_SLVSQ(iogrp),H2D_SLVSQ(iogrp), - . rnacc*1e-4,0.,cmpflg,ip,'p','slvsq','Sea level squared',' ', - . 'm2') + . rnacc*A_cgs2mks,0.,cmpflg,ip,'p','slvsq','Sea level squared', + . ' ','m2') c call wrth2d(ACC_UTILH2D(1),H2D_BTMSTR(iogrp), - . rnacc*0.5e-3*dlt/(g*baclin),0.,cmpflg,ip,'p','btmstr', + . rnacc*0.5*M_cgs2mks*dlt/(g*baclin),0.,cmpflg,ip,'p','btmstr', . 'Barotropic mass streamfunction',' ','kg s-1') c call wrth2d(ACC_HICE(iogrp),H2D_HICE(iogrp),1.,0., @@ -2270,10 +2282,10 @@ subroutine diaout(iogrp,m,n,mm,nn,k1m,k1n) call wrth2d(ACC_IAGE(iogrp),H2D_IAGE(iogrp),1.,0., . cmpflg,ip,'p','iage','Ice age',' ','day') c - call wrth2d(ACC_UICE(iogrp),H2D_UICE(iogrp),1e-2,0., + call wrth2d(ACC_UICE(iogrp),H2D_UICE(iogrp),L_cgs2mks,0., . cmpflg,iuu,'u','uice','Ice velocity x-component',' ','m s-1') c - call wrth2d(ACC_VICE(iogrp),H2D_VICE(iogrp),1e-2,0., + call wrth2d(ACC_VICE(iogrp),H2D_VICE(iogrp),L_cgs2mks,0., . cmpflg,ivv,'v','vice','Ice velocity y-component',' ','m s-1') c call wrth2d(ACC_SWA(iogrp),H2D_SWA(iogrp),rnacc,0., @@ -2291,11 +2303,11 @@ subroutine diaout(iogrp,m,n,mm,nn,k1m,k1n) . 'W m-2 K-1') c call wrth2d(ACC_SURFLX(iogrp),H2D_SURFLX(iogrp), - . -rnacc*1e4,0.,cmpflg,ip,'p','hflx', + . -rnacc*L_mks2cgs*L_mks2cgs,0.,cmpflg,ip,'p','hflx', . 'Heat flux received by ocean',' ','W m-2') c call wrth2d(ACC_SURRLX(iogrp),H2D_SURRLX(iogrp), - . -rnacc*1e4,0.,cmpflg,ip,'p','hrflx', + . -rnacc*L_mks2cgs*L_mks2cgs,0.,cmpflg,ip,'p','hrflx', . 'Restoring heat flux received by ocean',' ','W m-2') c call wrth2d(ACC_LIP(iogrp),H2D_LIP(iogrp),rnacc,0., @@ -2318,16 +2330,16 @@ subroutine diaout(iogrp,m,n,mm,nn,k1m,k1n) . rnacc,0.,cmpflg,ip,'p','rfi','Frozen runoff',' ','kg m-2 s-1') c call wrth2d(ACC_SALFLX(iogrp),H2D_SALFLX(iogrp), - . -rnacc*1e-2,0.,cmpflg,ip,'p','sflx', + . -rnacc*(g2kg*M_cgs2mks/A_cgs2mks),0.,cmpflg,ip,'p','sflx', . 'Salt flux received by ocean',' ','kg m-2 s-1') c call wrth2d(ACC_SALRLX(iogrp),H2D_SALRLX(iogrp), - . -rnacc*1e-2,0.,cmpflg,ip,'p','srflx', + . -rnacc*(g2kg*M_cgs2mks/A_cgs2mks),0.,cmpflg,ip,'p','srflx', . 'Restoring salt flux received by ocean',' ','kg m-2 s-1') c call wrth2d(ACC_BRNFLX(iogrp),H2D_BRNFLX(iogrp), - . rnacc*(-1e-2),0.,cmpflg,ip,'p','bflx','Brine flux',' ', - . 'kg m-2 s-1') + . rnacc*(-g2kg*M_cgs2mks/A_cgs2mks),0.,cmpflg,ip,'p','bflx', + . 'Brine flux',' ','kg m-2 s-1') c call wrth2d(ACC_ZTX(iogrp),H2D_ZTX(iogrp),rnacc,0., . cmpflg,iuu,'u','ztx','Wind stress x-component',' ','N m-2') @@ -2344,16 +2356,16 @@ subroutine diaout(iogrp,m,n,mm,nn,k1m,k1n) . 'Momentum flux received by ocean y-component',' ','N m-2') c call wrth2d(ACC_IDKEDT(iogrp),H2D_IDKEDT(iogrp), - . rnacc*1.e-3/alpha0,0.,cmpflg,ip,'p','idkedt', + . rnacc*M_cgs2mks/alpha0,0.,cmpflg,ip,'p','idkedt', . 'Mixed layer inertial kinetic energy tendency per unit area', . ' ','kg s-3') c call wrth2d(ACC_USTAR(iogrp),H2D_USTAR(iogrp), - . rnacc*1e-2,0.,cmpflg,ip,'p','ustar','Friction velocity',' ', - . 'm s-1') + . rnacc*L_cgs2mks,0.,cmpflg,ip,'p','ustar','Friction velocity', + . ' ','m s-1') c call wrth2d(ACC_USTAR3(iogrp),H2D_USTAR3(iogrp), - . rnacc*1.e-6,0.,cmpflg,ip,'p','ustar3', + . rnacc*V_cgs2mks,0.,cmpflg,ip,'p','ustar3', . 'Friction velocity cubed',' ','m3 s-3') c call wrth2d(ACC_ABSWND(iogrp),H2D_ABSWND(iogrp), @@ -2361,37 +2373,37 @@ subroutine diaout(iogrp,m,n,mm,nn,k1m,k1n) . 'm s-1') c call wrth2d(ACC_MTKEUS(iogrp),H2D_MTKEUS(iogrp), - . rnacc*1.e-3/alpha0,0.,cmpflg,ip,'p','mtkeus', + . rnacc*M_cgs2mks/alpha0,0.,cmpflg,ip,'p','mtkeus', . 'Mixed layer turbulent kinetic energy tendency '// . 'per unit area related to friction velocity', . ' ','kg s-3') c call wrth2d(ACC_MTKENI(iogrp),H2D_MTKENI(iogrp), - . rnacc*1.e-3/alpha0,0.,cmpflg,ip,'p','mtkeni', + . rnacc*M_cgs2mks/alpha0,0.,cmpflg,ip,'p','mtkeni', . 'Mixed layer turbulent kinetic energy tendency '// . 'per unit area related to near inertial motions', . ' ','kg s-3') c call wrth2d(ACC_MTKEBF(iogrp),H2D_MTKEBF(iogrp), - . rnacc*1.e-3/alpha0,0.,cmpflg,ip,'p','mtkebf', + . rnacc*M_cgs2mks/alpha0,0.,cmpflg,ip,'p','mtkebf', . 'Mixed layer turbulent kinetic energy tendency '// . 'per unit area related to buoyancy forcing', . ' ','kg s-3') c call wrth2d(ACC_MTKERS(iogrp),H2D_MTKERS(iogrp), - . rnacc*1.e-3/alpha0,0.,cmpflg,ip,'p','mtkers', + . rnacc*M_cgs2mks/alpha0,0.,cmpflg,ip,'p','mtkers', . 'Mixed layer turbulent kinetic energy tendency '// . 'per unit area related to eddy restratification', . ' ','kg s-3') c call wrth2d(ACC_MTKEPE(iogrp),H2D_MTKEPE(iogrp), - . rnacc*1.e-3/alpha0,0.,cmpflg,ip,'p','mtkepe', + . rnacc*M_cgs2mks/alpha0,0.,cmpflg,ip,'p','mtkepe', . 'Mixed layer turbulent kinetic energy tendency '// . 'per unit area related to potential energy change', . ' ','kg s-3') c call wrth2d(ACC_MTKEKE(iogrp),H2D_MTKEKE(iogrp), - . rnacc*1.e-3/alpha0,0.,cmpflg,ip,'p','mtkeke', + . rnacc*M_cgs2mks/alpha0,0.,cmpflg,ip,'p','mtkeke', . 'Mixed layer turbulent kinetic energy tendency '// . 'per unit area related to kinetic energy change', . ' ','kg s-3') @@ -2409,23 +2421,23 @@ subroutine diaout(iogrp,m,n,mm,nn,k1m,k1n) . 1./onem,0.,cmpflg,ip,'p','maxmld','Maximum mixed layer depth', . ' ','m') c - call wrth2d(ACC_MLTS(iogrp),H2D_MLTS(iogrp),rnacc*1e-2, + call wrth2d(ACC_MLTS(iogrp),H2D_MLTS(iogrp),rnacc*L_cgs2mks, . 0.,cmpflg,ip,'p','mlts', . 'Mixed layer thickness defined by sigma t',' ','m') c - call wrth2d(ACC_MLTSMN(iogrp),H2D_MLTSMN(iogrp),1e-2, + call wrth2d(ACC_MLTSMN(iogrp),H2D_MLTSMN(iogrp),L_cgs2mks, . 0.,cmpflg,ip,'p','mltsmn', . 'Minimum mixed layer thickness defined by sigma t',' ','m') c - call wrth2d(ACC_MLTSMX(iogrp),H2D_MLTSMX(iogrp),1e-2, + call wrth2d(ACC_MLTSMX(iogrp),H2D_MLTSMX(iogrp),L_cgs2mks, . 0.,cmpflg,ip,'p','mltsmx', . 'Maximum mixed layer thickness defined by sigma t',' ','m') c - call wrth2d(ACC_MLTSSQ(iogrp),H2D_MLTSSQ(iogrp),rnacc*1e-4, + call wrth2d(ACC_MLTSSQ(iogrp),H2D_MLTSSQ(iogrp),rnacc*A_cgs2mks, . 0.,cmpflg,ip,'p','mltssq', - . 'Mixed layer thickness squared defined by sigma t',' ','m') + . 'Mixed layer thickness squared defined by sigma t',' ','m2') c - call wrth2d(ACC_T20D(iogrp),H2D_T20D(iogrp),rnacc*1e-2, + call wrth2d(ACC_T20D(iogrp),H2D_T20D(iogrp),rnacc*L_cgs2mks, . 0.,cmpflg,ip,'p','t20d','20C isoterm depth',' ','m') c call wrth2d(ACC_BRNPD(iogrp),H2D_BRNPD(iogrp),rnacc/onem, @@ -2452,11 +2464,11 @@ subroutine diaout(iogrp,m,n,mm,nn,k1m,k1n) . cmpflg,ip,'p','tbot','Bottom temperature',' ','degC') c c --- write 3d layer fields - call wrtlyr(ACC_DP(iogrp),LYR_DP(iogrp),rnacc*.1,0., + call wrtlyr(ACC_DP(iogrp),LYR_DP(iogrp),rnacc*P_cgs2mks,0., . cmpflg,ip,'p','dp','Layer pressure thickness',' ','Pa') c call wrtlyr(ACC_DZ(iogrp),LYR_DZ(iogrp), - . rnacc*1e-2,0.,cmpflg,ip,'p','dz','Layer thickness',' ','m') + . rnacc*L_cgs2mks,0.,cmpflg,ip,'p','dz','Layer thickness',' ','m') c call wrtlyr(ACC_TEMP(iogrp),LYR_TEMP(iogrp),1.,0., . cmpflg,ip,'p','temp','Temperature','Ocean temperature', @@ -2465,18 +2477,18 @@ subroutine diaout(iogrp,m,n,mm,nn,k1m,k1n) call wrtlyr(ACC_SALN(iogrp),LYR_SALN(iogrp),1.,0., . cmpflg,ip,'p','saln','Salinity','Ocean salinity','g kg-1') c - call wrtlyr(ACC_UVEL(iogrp),LYR_UVEL(iogrp),1e-2, + call wrtlyr(ACC_UVEL(iogrp),LYR_UVEL(iogrp),L_cgs2mks, . 0.,cmpflg,iuu,'u','uvel','Velocity x-component',' ','m s-1') c - call wrtlyr(ACC_VVEL(iogrp),LYR_VVEL(iogrp),1e-2, + call wrtlyr(ACC_VVEL(iogrp),LYR_VVEL(iogrp),L_cgs2mks, . 0.,cmpflg,ivv,'v','vvel','Velocity y-component',' ','m s-1') c call wrtlyr(ACC_UFLX(iogrp),LYR_UFLX(iogrp), - . rnacc*0.5e-3/(g*baclin),0.,cmpflg,iuu,'u','uflx', + . rnacc*0.5*M_cgs2mks/(g*baclin),0.,cmpflg,iuu,'u','uflx', . 'Mass flux in x-direction',' ','kg s-1') c call wrtlyr(ACC_VFLX(iogrp),LYR_VFLX(iogrp), - . rnacc*0.5e-3/(g*baclin),0.,cmpflg,ivv,'v','vflx', + . rnacc*0.5*M_cgs2mks/(g*baclin),0.,cmpflg,ivv,'v','vflx', . 'Mass flux in y-direction',' ','kg s-1') c call wrtlyr(ACC_UTFLX(iogrp),LYR_UTFLX(iogrp), @@ -2488,20 +2500,20 @@ subroutine diaout(iogrp,m,n,mm,nn,k1m,k1n) . 'Heat flux in y-direction',' ','W') c call wrtlyr(ACC_USFLX(iogrp),LYR_USFLX(iogrp), - . rnacc*0.5e-6/(g*baclin),0.,cmpflg,iuu,'u','usflx', + . rnacc*0.5*g2kg*M_cgs2mks/(g*baclin),0.,cmpflg,iuu,'u','usflx', . 'Salt flux in x-direction',' ','kg s-1') c call wrtlyr(ACC_VSFLX(iogrp),LYR_VSFLX(iogrp), - . rnacc*0.5e-6/(g*baclin),0.,cmpflg,ivv,'v','vsflx', + . rnacc*0.5*g2kg*M_cgs2mks/(g*baclin),0.,cmpflg,ivv,'v','vsflx', . 'Salt flux in y-direction',' ','kg s-1') c call wrtlyr(ACC_UMFLTD(iogrp),LYR_UMFLTD(iogrp), - . rnacc*0.5e-3/(g*baclin),0.,cmpflg,iuu,'u','umfltd', + . rnacc*0.5*M_cgs2mks/(g*baclin),0.,cmpflg,iuu,'u','umfltd', . 'Mass flux due to thickness diffusion in x-direction',' ', . 'kg s-1') c call wrtlyr(ACC_VMFLTD(iogrp),LYR_VMFLTD(iogrp), - . rnacc*0.5e-3/(g*baclin),0.,cmpflg,ivv,'v','vmfltd', + . rnacc*0.5*M_cgs2mks/(g*baclin),0.,cmpflg,ivv,'v','vmfltd', . 'Mass flux due to thickness diffusion in y-direction',' ', . 'kg s-1') c @@ -2526,31 +2538,31 @@ subroutine diaout(iogrp,m,n,mm,nn,k1m,k1n) . 'W') c call wrtlyr(ACC_USFLTD(iogrp),LYR_USFLTD(iogrp), - . rnacc*0.5e-6/(g*baclin),0.,cmpflg,iuu,'u','usfltd', + . rnacc*0.5*g2kg*M_cgs2mks/(g*baclin),0.,cmpflg,iuu,'u','usfltd', . 'Salt flux due to thickness diffusion in x-direction',' ', . 'kg s-1') c call wrtlyr(ACC_VSFLTD(iogrp),LYR_VSFLTD(iogrp), - . rnacc*0.5e-6/(g*baclin),0.,cmpflg,ivv,'v','vsfltd', + . rnacc*0.5*g2kg*M_cgs2mks/(g*baclin),0.,cmpflg,ivv,'v','vsfltd', . 'Salt flux due to thickness diffusion in y-direction',' ', . 'kg s-1') c call wrtlyr(ACC_USFLLD(iogrp),LYR_USFLLD(iogrp), - . rnacc*0.5e-6/(g*baclin),0.,cmpflg,iuu,'u','usflld', + . rnacc*0.5*g2kg*M_cgs2mks/(g*baclin),0.,cmpflg,iuu,'u','usflld', . 'Salt flux due to lateral diffusion in x-direction',' ', . 'kg s-1') c call wrtlyr(ACC_VSFLLD(iogrp),LYR_VSFLLD(iogrp), - . rnacc*0.5e-6/(g*baclin),0.,cmpflg,ivv,'v','vsflld', + . rnacc*0.5*g2kg*M_cgs2mks/(g*baclin),0.,cmpflg,ivv,'v','vsflld', . 'Salt flux due to lateral diffusion in y-direction',' ', . 'kg s-1') c call wrtlyr(ACC_WFLX(iogrp),LYR_WFLX(iogrp), - . rnacc*0.5e-3/(g*baclin),0.,cmpflg,ip,'p','wflx', + . rnacc*0.5*M_cgs2mks/(g*baclin),0.,cmpflg,ip,'p','wflx', . 'Vertical mass flux',' ','kg s-1') c call wrtlyr(ACC_WFLX2(iogrp),LYR_WFLX2(iogrp), - . rnacc*(0.5e-3/(g*baclin))**2,0.,cmpflg,ip,'p','wflx2', + . rnacc*(0.5*M_cgs2mks/(g*baclin))**2,0.,cmpflg,ip,'p','wflx2', . 'Vertical mass flux squared',' ','kg2 s-2') c call wrtlyr(ACC_BFSQ(iogrp),LYR_BFSQ(iogrp),1.,0., @@ -2558,7 +2570,7 @@ subroutine diaout(iogrp,m,n,mm,nn,k1m,k1n) . 's-1') c call wrtlyr(ACC_AVDSG(iogrp),LYR_PV(iogrp), - . 1.e2*g,0.,cmpflg,ip,'p','pv','Potential vorticity',' ', + . L_mks2cgs*g,0.,cmpflg,ip,'p','pv','Potential vorticity',' ', . 'm-1 s-1') c if (LYR_DIFINT(iogrp).eq.2) then @@ -2566,7 +2578,7 @@ subroutine diaout(iogrp,m,n,mm,nn,k1m,k1n) . 0.,cmpflg,ip,'p','difint','Layer interface diffusivity', . ' ','log10(m2 s-1)') else - call wrtlyr(ACC_DIFINT(iogrp),LYR_DIFINT(iogrp),1e-4, + call wrtlyr(ACC_DIFINT(iogrp),LYR_DIFINT(iogrp),A_cgs2mks, . 0.,cmpflg,ip,'p','difint','Layer interface diffusivity', . ' ','m2 s-1') endif @@ -2576,7 +2588,7 @@ subroutine diaout(iogrp,m,n,mm,nn,k1m,k1n) . 0.,cmpflg,ip,'p','difiso','Isopycnal diffusivity',' ', . 'log10(m2 s-1)') else - call wrtlyr(ACC_DIFISO(iogrp),LYR_DIFISO(iogrp),1e-4, + call wrtlyr(ACC_DIFISO(iogrp),LYR_DIFISO(iogrp),A_cgs2mks, . 0.,cmpflg,ip,'p','difiso','Isopycnal diffusivity',' ', . 'm2 s-1') endif @@ -2586,7 +2598,7 @@ subroutine diaout(iogrp,m,n,mm,nn,k1m,k1n) . 0.,cmpflg,ip,'p','difdia','Vertical diffusivity',' ', . 'log10(m2 s-1)') else - call wrtlyr(ACC_DIFDIA(iogrp),LYR_DIFDIA(iogrp),1e-4, + call wrtlyr(ACC_DIFDIA(iogrp),LYR_DIFDIA(iogrp),A_cgs2mks, . 0.,cmpflg,ip,'p','difdia','Vertical diffusivity',' ', . 'm2 s-1') endif @@ -2596,7 +2608,7 @@ subroutine diaout(iogrp,m,n,mm,nn,k1m,k1n) . 0.,cmpflg,ip,'p','difvmo','Vertical momentum diffusivity',' ', . 'log10(m2 s-1)') else - call wrtlyr(ACC_DIFVMO(iogrp),LYR_DIFVMO(iogrp),1e-4, + call wrtlyr(ACC_DIFVMO(iogrp),LYR_DIFVMO(iogrp),A_cgs2mks, . 0.,cmpflg,ip,'p','difvmo','Vertical momentum diffusivity',' ', . 'm2 s-1') endif @@ -2606,7 +2618,7 @@ subroutine diaout(iogrp,m,n,mm,nn,k1m,k1n) . 0.,cmpflg,ip,'p','difvho','Vertical heat diffusivity',' ', . 'log10(m2 s-1)') else - call wrtlyr(ACC_DIFVHO(iogrp),LYR_DIFVHO(iogrp),1e-4, + call wrtlyr(ACC_DIFVHO(iogrp),LYR_DIFVHO(iogrp),A_cgs2mks, . 0.,cmpflg,ip,'p','difvho','Vertical heat diffusivity',' ', . 'm2 s-1') endif @@ -2616,24 +2628,25 @@ subroutine diaout(iogrp,m,n,mm,nn,k1m,k1n) . 0.,cmpflg,ip,'p','difvso','Vertical salt diffusivity',' ', . 'log10(m2 s-1)') else - call wrtlyr(ACC_DIFVSO(iogrp),LYR_DIFVSO(iogrp),1e-4, + call wrtlyr(ACC_DIFVSO(iogrp),LYR_DIFVSO(iogrp),A_cgs2mks, . 0.,cmpflg,ip,'p','difvso','Vertical salt diffusivity',' ', . 'm2 s-1') endif c #if defined(TRC) && defined(TKE) - call wrtlyr(ACC_TKE(iogrp),LYR_TKE(iogrp),1e-4,0., + call wrtlyr(ACC_TKE(iogrp),LYR_TKE(iogrp),A_cgs2mks,0., . cmpflg,ip,'p','tke','TKE','Turbulent kinetic energy', . 'm2 s-2') c - call wrtlyr(ACC_GLS_PSI(iogrp),LYR_GLS_PSI(iogrp),1.e-4,0., + call wrtlyr(ACC_GLS_PSI(iogrp),LYR_GLS_PSI(iogrp),A_cgs2mks,0., . cmpflg,ip,'p','gls_psi','GLS_PSI','Generic length scale', . 'm2 s-3') c #endif c --- Write 3d depth fields call wrtlvl(ACC_DZLVL(iogrp),LVL_DZ(iogrp), - . rnacc*1e-2,0.,cmpflg,ip,'p','dzlvl','Layer thickness',' ','m') + . rnacc*L_cgs2mks,0.,cmpflg,ip, + . 'p','dzlvl','Layer thickness',' ','m') c call wrtlvl(ACC_TEMPLVL(iogrp),LVL_TEMP(iogrp), . rnacc,0.,cmpflg,ip,'p','templvl','Temperature', @@ -2644,19 +2657,19 @@ subroutine diaout(iogrp,m,n,mm,nn,k1m,k1n) . 'Ocean salinity','g kg-1') c call wrtlvl(ACC_UVELLVL(iogrp),LVL_UVEL(iogrp), - . rnacc*1e-2,0.,cmpflg,iuu,'u','uvellvl', + . rnacc*L_cgs2mks,0.,cmpflg,iuu,'u','uvellvl', . 'Velocity x-component',' ','m s-1') c call wrtlvl(ACC_VVELLVL(iogrp),LVL_VVEL(iogrp), - . rnacc*1e-2,0.,cmpflg,ivv,'v','vvellvl', + . rnacc*L_cgs2mks,0.,cmpflg,ivv,'v','vvellvl', . 'Velocity y-component',' ','m s-1') c call wrtlvl(ACC_UFLXLVL(iogrp),LVL_UFLX(iogrp), - . rnacc*0.5e-3/(g*baclin),0.,cmpflg,iuu,'u','uflxlvl', + . rnacc*0.5*M_cgs2mks/(g*baclin),0.,cmpflg,iuu,'u','uflxlvl', . 'Mass flux in x-direction',' ','kg s-1') c call wrtlvl(ACC_VFLXLVL(iogrp),LVL_VFLX(iogrp), - . rnacc*0.5e-3/(g*baclin),0.,cmpflg,ivv,'v','vflxlvl', + . rnacc*0.5*M_cgs2mks/(g*baclin),0.,cmpflg,ivv,'v','vflxlvl', . 'Mass flux in y-direction',' ','kg s-1') c call wrtlvl(ACC_UTFLXLVL(iogrp),LVL_UTFLX(iogrp), @@ -2668,20 +2681,20 @@ subroutine diaout(iogrp,m,n,mm,nn,k1m,k1n) . 'Heat flux in y-direction',' ','W') c call wrtlvl(ACC_USFLXLVL(iogrp),LVL_USFLX(iogrp), - . rnacc*0.5e-6/(g*baclin),0.,cmpflg,iuu,'u','usflxlvl', - . 'Salt flux in x-direction',' ','kg s-1') + . rnacc*0.5*g2kg*M_cgs2mks/(g*baclin),0.,cmpflg,iuu,'u', + . 'usflxlvl','Salt flux in x-direction',' ','kg s-1') c call wrtlvl(ACC_VSFLXLVL(iogrp),LVL_VSFLX(iogrp), - . rnacc*0.5e-6/(g*baclin),0.,cmpflg,ivv,'v','vsflxlvl', - . 'Salt flux in y-direction',' ','kg s-1') + . rnacc*0.5*g2kg*M_cgs2mks/(g*baclin),0.,cmpflg,ivv,'v', + . 'vsflxlvl','Salt flux in y-direction',' ','kg s-1') c call wrtlvl(ACC_UMFLTDLVL(iogrp),LVL_UMFLTD(iogrp), - . rnacc*0.5e-3/(g*baclin),0.,cmpflg,iuu,'u','umfltdlvl', + . rnacc*0.5*M_cgs2mks/(g*baclin),0.,cmpflg,iuu,'u','umfltdlvl', . 'Mass flux due to thickness diffusion in x-direction',' ', . 'kg s-1') c call wrtlvl(ACC_VMFLTDLVL(iogrp),LVL_VMFLTD(iogrp), - . rnacc*0.5e-3/(g*baclin),0.,cmpflg,ivv,'v','vmfltdlvl', + . rnacc*0.5*M_cgs2mks/(g*baclin),0.,cmpflg,ivv,'v','vmfltdlvl', . 'Mass flux due to thickness diffusion in y-direction',' ', . 'kg s-1') c @@ -2706,31 +2719,35 @@ subroutine diaout(iogrp,m,n,mm,nn,k1m,k1n) . 'W') c call wrtlvl(ACC_USFLTDLVL(iogrp),LVL_USFLTD(iogrp), - . rnacc*0.5e-6/(g*baclin),0.,cmpflg,iuu,'u','usfltdlvl', + . rnacc*0.5*g2kg*M_cgs2mks/(g*baclin),0.,cmpflg,iuu, + . 'u','usfltdlvl', . 'Salt flux due to thickness diffusion in x-direction',' ', . 'kg s-1') c call wrtlvl(ACC_VSFLTDLVL(iogrp),LVL_VSFLTD(iogrp), - . rnacc*0.5e-6/(g*baclin),0.,cmpflg,ivv,'v','vsfltdlvl', + . rnacc*0.5*g2kg*M_cgs2mks/(g*baclin),0.,cmpflg,ivv, + . 'v','vsfltdlvl', . 'Salt flux due to thickness diffusion in y-direction',' ', . 'kg s-1') c call wrtlvl(ACC_USFLLDLVL(iogrp),LVL_USFLLD(iogrp), - . rnacc*0.5e-6/(g*baclin),0.,cmpflg,iuu,'u','usflldlvl', + . rnacc*0.5*g2kg*M_cgs2mks/(g*baclin),0.,cmpflg,iuu, + . 'u','usflldlvl', . 'Salt flux due to lateral diffusion in x-direction',' ', . 'kg s-1') c call wrtlvl(ACC_VSFLLDLVL(iogrp),LVL_VSFLLD(iogrp), - . rnacc*0.5e-6/(g*baclin),0.,cmpflg,ivv,'v','vsflldlvl', + . rnacc*0.5*g2kg*M_cgs2mks/(g*baclin),0.,cmpflg,ivv, + . 'v','vsflldlvl', . 'Salt flux due to lateral diffusion in y-direction',' ', . 'kg s-1') c call wrtlvl(ACC_WFLXLVL(iogrp),LVL_WFLX(iogrp), - . rnacc*0.5e-3/(g*baclin),0.,cmpflg,ip,'p','wflxlvl', + . rnacc*0.5*M_cgs2mks/(g*baclin),0.,cmpflg,ip,'p','wflxlvl', . 'Vertical mass flux',' ','kg s-1') c call wrtlvl(ACC_WFLX2LVL(iogrp),LVL_WFLX2(iogrp), - . rnacc*(0.5e-3/(g*baclin))**2,0.,cmpflg,ip,'p','wflx2lvl', + . rnacc*(0.5*M_cgs2mks/(g*baclin))**2,0.,cmpflg,ip,'p','wflx2lvl', . 'Vertical mass flux squared',' ','kg2 s-2') c call wrtlvl(ACC_BFSQLVL(iogrp),LVL_BFSQ(iogrp), @@ -2738,17 +2755,17 @@ subroutine diaout(iogrp,m,n,mm,nn,k1m,k1n) . ' ','s-1') c call wrtlvl(ACC_PVLVL(iogrp),LVL_PV(iogrp), - . rnacc*1.e2*g,0.,cmpflg,ip,'p','pvlvl','Potential vorticity', - . ' ','m-1 s-1') + . rnacc*L_mks2cgs*g,0.,cmpflg,ip, + . 'p','pvlvl','Potential vorticity',' ','m-1 s-1') c if (LVL_DIFINT(iogrp).eq.2) then call wrtlvl(ACC_DIFINTLVL(iogrp),LVL_DIFINT(iogrp),1., . 0.,cmpflg,ip,'p','difintlvl','Layer interface diffusivity', . ' ','log10(m2 s-1)') else - call wrtlvl(ACC_DIFINTLVL(iogrp),LVL_DIFINT(iogrp),1e-4*rnacc, - . 0.,cmpflg,ip,'p','difintlvl','Layer interface diffusivity', - . ' ','m2 s-1') + call wrtlvl(ACC_DIFINTLVL(iogrp),LVL_DIFINT(iogrp), + . A_cgs2mks*rnacc,0.,cmpflg,ip,'p','difintlvl', + . 'Layer interface diffusivity',' ','m2 s-1') endif c if (LVL_DIFISO(iogrp).eq.2) then @@ -2756,9 +2773,9 @@ subroutine diaout(iogrp,m,n,mm,nn,k1m,k1n) . 0.,cmpflg,ip,'p','difisolvl','Isopycnal diffusivity',' ', . 'log10(m2 s-1)') else - call wrtlvl(ACC_DIFISOLVL(iogrp),LVL_DIFISO(iogrp),1e-4*rnacc, - . 0.,cmpflg,ip,'p','difisolvl','Isopycnal diffusivity',' ', - . 'm2 s-1') + call wrtlvl(ACC_DIFISOLVL(iogrp),LVL_DIFISO(iogrp), + . A_cgs2mks*rnacc,0.,cmpflg,ip,'p','difisolvl', + . 'Isopycnal diffusivity',' ','m2 s-1') endif c if (LVL_DIFDIA(iogrp).eq.2) then @@ -2766,9 +2783,9 @@ subroutine diaout(iogrp,m,n,mm,nn,k1m,k1n) . 0.,cmpflg,ip,'p','difdialvl','Vertical diffusivity',' ', . 'log10(m2 s-1)') else - call wrtlvl(ACC_DIFDIALVL(iogrp),LVL_DIFDIA(iogrp),1e-4*rnacc, - . 0.,cmpflg,ip,'p','difdialvl','Vertical diffusivity',' ', - . 'm2 s-1') + call wrtlvl(ACC_DIFDIALVL(iogrp),LVL_DIFDIA(iogrp), + . A_cgs2mks*rnacc,0.,cmpflg,ip,'p','difdialvl', + . 'Vertical diffusivity',' ','m2 s-1') endif c if (LVL_DIFVMO(iogrp).eq.2) then @@ -2776,9 +2793,9 @@ subroutine diaout(iogrp,m,n,mm,nn,k1m,k1n) . 0.,cmpflg,ip,'p','difvmolvl','Vertical momentum diffusivity', . ' ','log10(m2 s-1)') else - call wrtlvl(ACC_DIFVMOLVL(iogrp),LVL_DIFVMO(iogrp),1e-4*rnacc, - . 0.,cmpflg,ip,'p','difvmolvl','Vertical momentum diffusivity', - . ' ','m2 s-1') + call wrtlvl(ACC_DIFVMOLVL(iogrp),LVL_DIFVMO(iogrp), + . A_cgs2mks*rnacc,0.,cmpflg,ip,'p','difvmolvl', + . 'Vertical momentum diffusivity',' ','m2 s-1') endif c if (LVL_DIFVHO(iogrp).eq.2) then @@ -2786,9 +2803,9 @@ subroutine diaout(iogrp,m,n,mm,nn,k1m,k1n) . 0.,cmpflg,ip,'p','difvholvl','Vertical heat diffusivity', . ' ','log10(m2 s-1)') else - call wrtlvl(ACC_DIFVHOLVL(iogrp),LVL_DIFVHO(iogrp),1e-4*rnacc, - . 0.,cmpflg,ip,'p','difvholvl','Vertical heat diffusivity', - . ' ','m2 s-1') + call wrtlvl(ACC_DIFVHOLVL(iogrp),LVL_DIFVHO(iogrp), + . A_cgs2mks*rnacc,0.,cmpflg,ip,'p','difvholvl', + . 'Vertical heat diffusivity',' ','m2 s-1') endif c if (LVL_DIFVSO(iogrp).eq.2) then @@ -2796,19 +2813,19 @@ subroutine diaout(iogrp,m,n,mm,nn,k1m,k1n) . 0.,cmpflg,ip,'p','difvsolvl','Vertical salt diffusivity', . ' ','log10(m2 s-1)') else - call wrtlvl(ACC_DIFVSOLVL(iogrp),LVL_DIFVSO(iogrp),1e-4*rnacc, - . 0.,cmpflg,ip,'p','difvsolvl','Vertical salt diffusivity', - . ' ','m2 s-1') + call wrtlvl(ACC_DIFVSOLVL(iogrp),LVL_DIFVSO(iogrp), + . A_cgs2mks*rnacc,0.,cmpflg,ip,'p','difvsolvl', + . 'Vertical salt diffusivity',' ','m2 s-1') endif c #if defined(TRC) && defined(TKE) - call wrtlvl(ACC_TKELVL(iogrp),LVL_TKE(iogrp),rnacc*1.e-4, + call wrtlvl(ACC_TKELVL(iogrp),LVL_TKE(iogrp),rnacc*A_cgs2mks, . 0.,cmpflg,ip,'p','tkelvl','Turbulent kinetic energy',' ', . 'm2 s-2') c - call wrtlvl(ACC_GLS_PSILVL(iogrp),LVL_GLS_PSI(iogrp),rnacc*1.e-4, - . 0.,cmpflg,ip,'p','gls_psilvl','Generic length scale',' ', - . 'm2 s-3') + call wrtlvl(ACC_GLS_PSILVL(iogrp),LVL_GLS_PSI(iogrp), + . rnacc*A_cgs2mks,0.,cmpflg,ip,'p','gls_psilvl', + . 'Generic length scale',' ','m2 s-3') c #endif c @@ -2919,8 +2936,8 @@ subroutine diaout(iogrp,m,n,mm,nn,k1m,k1n) call inilyr(ACC_UTILLYR(1),'p',0.) call acclyr(ACC_UTILLYR,dp(1-nbdy,1-nbdy,k1m),tmp3d,0,'p') call wrtlyr(ACC_UTILLYR(1), - . max(LYR_IDLAGE(iogrp),LYR_TRC(iogrp)),.1,0.,cmpflg,ip,'p', - . 'dp_trc','Layer pressure thickness',' ','Pa') + . max(LYR_IDLAGE(iogrp),LYR_TRC(iogrp)),P_cgs2mks,0.,cmpflg,ip, + . 'p','dp_trc','Layer pressure thickness',' ','Pa') endif # ifdef IDLAGE c @@ -3134,14 +3151,14 @@ subroutine diasec(iogrp) do i=max(1,ifu(j,l)),min(ii,ilu(j,l)) uflx_cum(i,j)=uflx_cum(i,j)+ . phylvl(i,j,k,ACC_UFLXLVL(iogrp)) - . *0.5e-3/(g*baclin*nacc_phy(iogrp)) + . *0.5*M_cgs2mks/(g*baclin*nacc_phy(iogrp)) enddo enddo do l=1,isv(j) do i=max(1,ifv(j,l)),min(ii,ilv(j,l)) vflx_cum(i,j)=vflx_cum(i,j)+ . phylvl(i,j,k,ACC_VFLXLVL(iogrp)) - . *0.5e-3/(g*baclin*nacc_phy(iogrp)) + . *0.5*M_cgs2mks/(g*baclin*nacc_phy(iogrp)) enddo enddo c @@ -3370,17 +3387,17 @@ subroutine diamer(iogrp) if (ACC_MSFLX(iogrp).eq.0) exit ACC_UIND=ACC_USFLX(iogrp) ACC_VIND=ACC_VSFLX(iogrp) - r=0.5e-6/(g*baclin*nacc_phy(iogrp)) + r=0.5*g2kg*M_cgs2mks/(g*baclin*nacc_phy(iogrp)) elseif (nfld.eq.5) then if (ACC_MSFTD(iogrp).eq.0) exit ACC_UIND=ACC_USFLTD(iogrp) ACC_VIND=ACC_VSFLTD(iogrp) - r=0.5e-6/(g*baclin*nacc_phy(iogrp)) + r=0.5*g2kg*M_cgs2mks/(g*baclin*nacc_phy(iogrp)) elseif (nfld.eq.6) then if (ACC_MSFLD(iogrp).eq.0) exit ACC_UIND=ACC_USFLLD(iogrp) ACC_VIND=ACC_VSFLLD(iogrp) - r=0.5e-6/(g*baclin*nacc_phy(iogrp)) + r=0.5*g2kg*M_cgs2mks/(g*baclin*nacc_phy(iogrp)) else write(lp,*) 'field index out of range' call xchalt('(diamer)') @@ -3541,7 +3558,7 @@ subroutine diamer(iogrp) enddo c$OMP END PARALLEL DO c - r=0.5e-3/(g*baclin*nacc_phy(iogrp)) + r=0.5*M_cgs2mks/(g*baclin*nacc_phy(iogrp)) c do nfld=1,2 c @@ -3643,7 +3660,7 @@ subroutine diamer(iogrp) enddo endif if (abs(mflx_mr(l,m)-mflx_last_mr(l,m)).lt. - . 1.e5*epsil) then + . 1.e5*epsilp) then mflx_last_mr(l,m)=mflx_mr(l,m) mflx_mr(l,m)=nf90_fill_double else @@ -3706,7 +3723,7 @@ subroutine diamer(iogrp) enddo endif c - r=0.5e-3/(g*baclin*nacc_phy(iogrp)) + r=0.5*M_cgs2mks/(g*baclin*nacc_phy(iogrp)) c do nfld=1,2 c @@ -3947,9 +3964,9 @@ subroutine diazlv(gridid,k,mm,nn,ind1,ind2,weights,weightsflx) save ztop,zbot,dlevp,dlevu,dlevv,iniflg c c --- Define thresholds - dzeps=1e1*epsil - dpeps=1e5*epsil - flxeps=1e5*epsil + dzeps=1e1*epsilp + dpeps=1e5*epsilp + flxeps=1e5*epsilp c c --- Sort out stuff related to time stepping km=k+mm diff --git a/phy/mod_difest.F b/phy/mod_difest.F index 3831bf38..67f0f486 100644 --- a/phy/mod_difest.F +++ b/phy/mod_difest.F @@ -20,7 +20,8 @@ module mod_difest c use mod_types, only: r8 - use mod_constants, only: g, alpha0, pi, epsil, spval, onem, onecm + use mod_constants, only: g, alpha0, pi, epsilp, spval, onem, + . onecm, L_mks2cgs, M_mks2cgs, R_mks2cgs use mod_time, only: delt1 use mod_xc use mod_vcoord, only: vcoord_type_tag, isopyc_bulkml, @@ -101,6 +102,12 @@ module mod_difest type(CVMix_kpp_params_type) :: KPP_params c type(CVMix_kpp_params_type), pointer :: CVmix_kpp_params_in c type(CVMix_kpp_params_type) :: CVmix_kpp_params_in +c + real, parameter :: + . iL_mks2cgs = 1./L_mks2cgs, + . iM_mks2cgs = 1./M_mks2cgs, + . A_mks2cgs = L_mks2cgs**2, + . A_cgs2mks = 1./(L_mks2cgs*L_mks2cgs) c c --- parameters: c --- iidtyp - type of interface and isopycnal diffusivities. If @@ -162,22 +169,33 @@ module mod_difest c --- non-isopycnic layers [g/cm/s**2]. c --- dpnbav - thickness of region near the bottom used to estimate c --- bottom Brunt-Vaisala frequency [g/cm/s**2]. +c --- cpsemin - Lower bound of zonal eddy phase speed minus zonal +c --- barotropic velocity [cm/s]. +c --- urmsemin- Lower bound of absolute value of RMS eddy velocity +c --- [cm/s]. integer iidtyp,bdmldp,tdmflg,iwdflg real dptmin,dpbmin,drhomn,thkdff,temdff,nu0,nus0,nug0,drho0,nuls0, . iwdfac,dmxeff,tdmq,tdmls0,tdmls1,tdclat,tddlat,tkepls,niwls, . cori30,bvf0,nubmin,dpgc,dpgrav,dpdiav,dpddav,dpnbav,ustmin, - . kappa,bfeps,sleps,zetas,as,cs,minOBLdepth - parameter (iidtyp=2,bdmldp=1,tdmflg=1,iwdflg=1,dptmin=98060., - . dpbmin=980.6,drhomn=6.e-6,thkdff=.5,temdff=.35,nu0=.1, - . nus0=50.,nug0=2500.,drho0=6.e-6,nuls0=500.,iwdfac=.06, - . dmxeff=.2,tdmq=1./3.,tdmls0=500.*98060., - . tdmls1=100.*98060.,tdclat=74.5,tddlat=3., - . tkepls=20.*98060.,niwls=300.*98060.,cori30=7.2722e-5, - . bvf0=5.24e-3,nubmin=.01,dpgc=300.*98060., - . dpgrav=100.*98060.,dpdiav=100.*98060., - . dpddav=10.*98060.,dpnbav=250.*98060.,ustmin=.1, - . kappa=.4,bfeps=1.e-12,sleps=.1,zetas=-1.,as=-28.86, - . cs=98.96,minOBLdepth=1.0) + . kappa,bfeps,sleps,zetas,as,cs,minOBLdepth, + . cpsemin,urmsemin + parameter (iidtyp=2,bdmldp=1,tdmflg=1,iwdflg=1,dptmin=onem, + . dpbmin=onecm,drhomn=6.e-3*R_mks2cgs, + . thkdff=5.e-3*L_mks2cgs,temdff=3.5e-3*L_mks2cgs, + . nu0=1.e-5*A_mks2cgs, + . nus0=5.e-3*A_mks2cgs, + . nug0=2.5e-1*A_mks2cgs, + . drho0=6.e-3*R_mks2cgs, + . nuls0=5.e-2*A_mks2cgs,iwdfac=.06, + . dmxeff=.2,tdmq=1./3.,tdmls0=500.*onem, + . tdmls1=100.*onem,tdclat=74.5,tddlat=3., + . tkepls=20.*onem,niwls=300.*onem,cori30=7.2722e-5, + . bvf0=5.24e-3,nubmin=1.e-6*A_mks2cgs, + . dpgc=300.*onem,dpgrav=100.*onem,dpdiav=100.*onem, + . dpddav=10.*onem,dpnbav=250.*onem,ustmin=.001*L_mks2cgs, + . kappa=.4,bfeps=1.e-16*A_mks2cgs,sleps=.1,zetas=-1., + . cpsemin=-0.2*L_mks2cgs,urmsemin=0.05*L_mks2cgs, + . as=-28.86,cs=98.96,minOBLdepth=1.0) c public :: OBLdepth, inivar_difest, init_difest, difest_isobml, . difest_lateral_hybrid, difest_vertical_hybrid, hOBL @@ -236,8 +254,8 @@ subroutine init_difest c --- ------ convection routine based on N2 not rho c --- ------ if lBruntVaisala is TRUE, otherwise based on rho c --- ------ convert nuls0 to m2/s - call CVMix_init_conv(convect_diff=20.0*nuls0*1e-4, - . convect_visc=20.0*nuls0*1e-4, + call CVMix_init_conv(convect_diff=20.0*nuls0*A_cgs2mks, + . convect_visc=20.0*nuls0*A_cgs2mks, . lBruntVaisala=.true., . BVsqr_convect=0.0) call CVMix_put(CVMix_glb_params,'max_nlev',kk) @@ -245,7 +263,7 @@ subroutine init_difest call CVMix_put(CVMix_glb_params,'FreshWaterDensity',1000.0) call CVMix_put(CVMix_glb_params,'SaltWaterDensity',1025.0) call cvmix_init_shear(mix_scheme='KPP', - . KPP_nu_zero=nus0*1e-4, + . KPP_nu_zero=nus0*A_cgs2mks, . KPP_Ri_zero=ri0, . KPP_exp=3.0) ! CVmix_kpp_params_in => CVmix_kpp_params_user @@ -501,7 +519,7 @@ subroutine difest_common_iso(m,n,mm,nn,k1m,k1n) elseif (k.lt.kmax(i,j)) then q=max(0.,rho(p(i,j,k+1),temp(i,j,kn+1),saln(i,j,kn+1)) . -rho(p(i,j,k+1),temp(i,j,kn ),saln(i,j,kn ))) - drhol(i,j,k)=2.*tup(i)*q/max(1.e-14,tup(i)+q) + drhol(i,j,k)=2.*tup(i)*q/max(1.e-11*R_mks2cgs,tup(i)+q) tup(i)=q else drhol(i,j,k)=tup(i) @@ -518,7 +536,7 @@ subroutine difest_common_iso(m,n,mm,nn,k1m,k1n) c --- ------- Local gradient Richardson number. rig(i,j,k)=alpha0*alpha0 . *max(drhomn,drhol(i,j,k))*dp(i,j,kn) - . /max(1.e-9,du2l(i,j,k)) + . /max(1.e-13*A_mks2cgs,du2l(i,j,k)) c endif enddo @@ -640,7 +658,8 @@ subroutine difest_common_hyb(m,n,mm,nn,k1m,k1n) . +(mskv(i,j,k)*dv2(i,j,k)+mskv(i,j+1,k)*dv2(i,j+1,k)) . /max(1,mskv(i,j,k)+mskv(i,j+1,k)) dz=.5*(dp(i,j,kn-1)+dp(i,j,kn))*alpha0/g - rig(i,j,k)=max(0.,bfsqi(i,j,k)*dz*dz)/max(1.e-9,q) + rig(i,j,k)=max(0.,bfsqi(i,j,k)*dz*dz) + . /max(1.e-13*A_mks2cgs,q) else rig(i,j,k)=rig(i,j,k-1) endif @@ -964,16 +983,16 @@ subroutine difest_vertical_hyb(m,n,mm,nn,k1m,k1n) Kt_kpp = 0.0 Ks_kpp = 0.0 do k=1,kk+1 - Kv_kpp(k) = Kvisc_m(i,j,k)*1e-4 - Kt_kpp(k) = Kdiff_t(i,j,k)*1e-4 - Ks_kpp(k) = Kdiff_s(i,j,k)*1e-4 + Kv_kpp(k) = Kvisc_m(i,j,k)*A_cgs2mks + Kt_kpp(k) = Kdiff_t(i,j,k)*A_cgs2mks + Ks_kpp(k) = Kdiff_s(i,j,k)*A_cgs2mks enddo depth_int(1) = p(i,j,1)/onem iFaceHeight(1) = -depth_int(1) ! convert cm/s to m/s - surfFricVel = ustar(i,j) * 1e-2 + surfFricVel = ustar(i,j) * iL_mks2cgs ! convert cm2/s3 to m2/s3 - surfBuoyFlux = - buoyfl(i,j,1) * 1e-4 + surfBuoyFlux = - buoyfl(i,j,1) * A_cgs2mks do k=1,kk kn = k + nn kn1 = max(nn+1,kn-1) @@ -1028,7 +1047,7 @@ subroutine difest_vertical_hyb(m,n,mm,nn,k1m,k1n) surfU = surfHu / hTot surfV = surfHv / hTot surfRho = rho(p(i,j,k),surfTemp,surfSalt) - if (p(i,j,kk+1)-p(i,j,k) < epsil) then + if (p(i,j,kk+1)-p(i,j,k) < epsilp) then deltaRho(k) = deltaRho(k-1) else deltaRho(k) = rho_1d(k) - surfRho @@ -1056,12 +1075,12 @@ subroutine difest_vertical_hyb(m,n,mm,nn,k1m,k1n) rig_i(k)=rig(i,j,k) surfBuoyFlux2(k) = ( buoyfl(i,j,k+1) - . - buoyfl(i,j,1 )) * 1e-4 + . - buoyfl(i,j,1 )) * A_cgs2mks c enddo ! k if(dps.gt.0.) bvfbot=bvfbot/dps ! convert cm2/s2 to m2/s2 - deltaU2 = deltaU2*1e-4 + deltaU2 = deltaU2*A_cgs2mks ! bottom values for the Ri, N2, and N rig_i(kk+1) = rig_i(kk) @@ -1079,8 +1098,8 @@ subroutine difest_vertical_hyb(m,n,mm,nn,k1m,k1n) elseif (bdmtyp.eq.2) then c --- --------- Type 2: Background diffusivity is a constant ! convert cm2/s2 to m2/s2 - Kv_col(:) = bdmc2*1e-4 - Kd_col(:) = bdmc2*1e-4 + Kv_col(:) = bdmc2*A_cgs2mks + Kd_col(:) = bdmc2*A_cgs2mks else Kv_col(:) = 0. Kd_col(:) = 0. @@ -1099,7 +1118,7 @@ subroutine difest_vertical_hyb(m,n,mm,nn,k1m,k1n) . efficiency=dmxeff, local_mixing_frac=tdmq) call CVMix_compute_Simmons_invariant(nlev=kk, - . energy_flux=twedon(i,j)*bvfbot*1e-3, + . energy_flux=twedon(i,j)*bvfbot*iM_mks2cgs, . rho=CVMix_glb_params%FreshWaterDensity, . SimmonsCoeff = Simmons_coeff, VertDep = vert_dep, . zw = iFaceHeight, zt = cellHeight, @@ -1146,7 +1165,7 @@ subroutine difest_vertical_hyb(m,n,mm,nn,k1m,k1n) ! Calculate Bulk Richardson number from eq (21) of LMD94 BulkRi_1d = CVmix_kpp_compute_bulk_Richardson( . zt_cntr = cellHeight, ! Depth of cell center [m] - . delta_buoy_cntr=g*alpha0*deltaRho*1e-2, ! Bulk buoyancy difference, Br-B(z) [m s-2] + . delta_buoy_cntr=g*alpha0*deltaRho*iL_mks2cgs, ! Bulk buoyancy difference, Br-B(z) [m s-2] . delta_Vsqr_cntr=deltaU2, ! Square of resolved velocity difference [m2 s-2] . Vt_sqr_cntr=VT2(:), ! Unresolved shear [m2 s-2] . ws_cntr=Ws_1d, ! Turbulent velocity scale profile [m s-1] @@ -1201,7 +1220,7 @@ subroutine difest_vertical_hyb(m,n,mm,nn,k1m,k1n) ! Buoyancy flux acting on the OBL surfBuoyFlux = ( buoyfl(i,j,kOBL+1) - . - buoyfl(i,j,1 )) * 1e-4 + . - buoyfl(i,j,1 )) * A_cgs2mks ! Compute KPP using CVMix call CVMix_coeffs_kpp(Kv_kpp(:), ! (inout) Total viscosity [m2 s-1] @@ -1224,9 +1243,9 @@ subroutine difest_vertical_hyb(m,n,mm,nn,k1m,k1n) c ---- ccc ------- ! convert m2/s to cm2/s - Kv_kpp = Kv_kpp*1e4 - Kt_kpp = Kt_kpp*1e4 - Ks_kpp = Ks_kpp*1e4 + Kv_kpp = Kv_kpp*A_mks2cgs + Kt_kpp = Kt_kpp*A_mks2cgs + Ks_kpp = Ks_kpp*A_mks2cgs Kv_kpp=max(nubmin,Kv_kpp) Kt_kpp=max(nubmin,Kt_kpp) Ks_kpp=max(nubmin,Ks_kpp) @@ -1295,7 +1314,7 @@ subroutine difest_lateral_hyb(m,n,mm,nn,k1m,k1n) do i=max(1,ifp(j,l)),min(ii,ilp(j,l)) kfil(i,j)=kk+1 do k=kk,2,-1 - if (p(i,j,k).gt.mlts(i,j)*onecm) kfil(i,j)=k + if (p(i,j,k).gt.mlts(i,j)*(onem*iL_mks2cgs)) kfil(i,j)=k enddo enddo enddo @@ -1322,7 +1341,7 @@ subroutine difest_lateral_hyb(m,n,mm,nn,k1m,k1n) kn=k+nn do l=1,isp(j) do i=max(1,ifp(j,l)),min(ii,ilp(j,l)) - if (p(i,j,kk+1)-p(i,j,k+1).lt.epsil) then + if (p(i,j,kk+1)-p(i,j,k+1).lt.epsilp) then plo=p(i,j,kk+1) else plo=.5*(p(i,j,k)+p(i,j,k+1)) @@ -1519,7 +1538,7 @@ subroutine difest_lateral_hyb(m,n,mm,nn,k1m,k1n) . kmax(i,j)-kfil(i,j).ge.1) then c c --- --------- Rhines scale. - rhisc=egr(i,k)/max(1.e-24,betafp(i,j)) + rhisc=egr(i,k)/max(1.e-22*iL_mks2cgs,betafp(i,j)) c c --- --------- Eddy length scale. els=max(eglsmn,min(bcrrd(i),rhisc)) @@ -1582,13 +1601,13 @@ subroutine difest_lateral_hyb(m,n,mm,nn,k1m,k1n) c --- ------- RMS eddy velocity estimated from K = Gamma*u_rms*L, where c --- ------- a mixing efficiency of Gamma = 0.35 is used (Klocker and c --- ------- Abernathey, 2014). - rhisc=egrs(i)/max(1.e-24,betafp(i,j)) + rhisc=egrs(i)/max(1.e-22*iL_mks2cgs,betafp(i,j)) els=max(eglsmn,min(bcrrd(i),rhisc)) urmse(i)=2.86*egc*egrs(i)*els c c --- ------- Zonal eddy phase speed minus zonal barotropic velocity c --- ------- with a lower bound of -20 cm s-1. - cpse(i)=max(-20.,-betafp(i,j)*bcrrd(i)**2) + cpse(i)=max(cpsemin,-betafp(i,j)*bcrrd(i)**2) c endif c @@ -1606,7 +1625,8 @@ subroutine difest_lateral_hyb(m,n,mm,nn,k1m,k1n) c --- --------- zonal velocity minus eddy phase speed and absolute value c --- --------- of RMS eddy velocity is set to -20 cm s-1 and 5 cm s-1, c --- --------- respectively. - esfac=1./(1.+4.*(umnsc/max(5.,abs(urmse(i))))**2) + esfac=1./ + . (1.+4.*(umnsc/max(urmsemin,abs(urmse(i))))**2) c else esfac=1. @@ -1637,7 +1657,8 @@ subroutine difest_lateral_hyb(m,n,mm,nn,k1m,k1n) . -cpse(i) c c --- ----------- Eddy mixing suppresion factor. - esfac=1./(1.+4.*(umnsc/max(5.,abs(urmse(i))))**2) + esfac=1./ + . (1.+4.*(umnsc/max(urmsemin,abs(urmse(i))))**2) c else esfac=1. @@ -1718,7 +1739,7 @@ subroutine difest_lateral_iso(m,n,mm,nn,k1m,k1n) do l=1,isp(j) do i=max(1,ifp(j,l)),min(ii,ilp(j,l)) if (k.ge.kfpla(i,j,n)) then - if (p(i,j,kk+1)-p(i,j,k+1).lt.epsil) then + if (p(i,j,kk+1)-p(i,j,k+1).lt.epsilp) then plo=p(i,j,kk+1) else plo=.5*(p(i,j,k)+p(i,j,k+1)) @@ -1915,7 +1936,7 @@ subroutine difest_lateral_iso(m,n,mm,nn,k1m,k1n) . kmax(i,j)-kfil(i,j).ge.1) then c c --- --------- Rhines scale. - rhisc=egr(i,k)/max(1.e-24,betafp(i,j)) + rhisc=egr(i,k)/max(1.e-22*iL_mks2cgs,betafp(i,j)) c c --- --------- Eddy length scale. els=max(eglsmn,min(bcrrd(i),rhisc)) @@ -1951,13 +1972,13 @@ subroutine difest_lateral_iso(m,n,mm,nn,k1m,k1n) c --- ------- RMS eddy velocity estimated from K = Gamma*u_rms*L, where c --- ------- a mixing efficiency of Gamma = 0.35 is used (Klocker and c --- ------- Abernathey, 2014). - rhisc=egrs(i)/max(1.e-24,betafp(i,j)) + rhisc=egrs(i)/max(1.e-22*iL_mks2cgs,betafp(i,j)) els=max(eglsmn,min(bcrrd(i),rhisc)) urmse(i)=2.86*egc*egrs(i)*els c c --- ------- Zonal eddy phase speed minus zonal barotropic velocity c --- ------- with a lower bound of -20 cm s-1. - cpse(i)=max(-20.,-betafp(i,j)*bcrrd(i)**2) + cpse(i)=max(cpsemin,-betafp(i,j)*bcrrd(i)**2) c endif c @@ -2012,7 +2033,8 @@ subroutine difest_lateral_iso(m,n,mm,nn,k1m,k1n) c --- --------- zonal velocity minus eddy phase speed and absolute value c --- --------- of RMS eddy velocity is set to -20 cm s-1 and 5 cm s-1, c --- --------- respectively. - esfac=1./(1.+4.*(umnsc/max(5.,abs(urmse(i))))**2) + esfac=1./ + . (1.+4.*(umnsc/max(urmsemin,abs(urmse(i))))**2) c else esfac=1. @@ -2047,7 +2069,8 @@ subroutine difest_lateral_iso(m,n,mm,nn,k1m,k1n) . -cpse(i) c c --- ----------- Eddy mixing suppresion factor. - esfac=1./(1.+4.*(umnsc/max(5.,abs(urmse(i))))**2) + esfac= + . 1./(1.+4.*(umnsc/max(urmsemin,abs(urmse(i))))**2) c else esfac=1. @@ -2141,7 +2164,7 @@ subroutine difest_vertical_iso(m,n,mm,nn,k1m,k1n) c c --- ------- Brunt-Vaisala frequency squared bvfsq(i,k)=g*g*max(drhomn,drhol(i,j,k)) - . /max(epsil,dp(i,j,kn)) + . /max(epsilp,dp(i,j,kn)) c c --- ------- Brunt-Vaisala frequency bvf(i,k)=sqrt(bvfsq(i,k)) @@ -2152,7 +2175,7 @@ subroutine difest_vertical_iso(m,n,mm,nn,k1m,k1n) h=max(onem,dp(i,j,kn))*alpha0/g c h=max(onem*1e-8,dp(i,j,kn))*alpha0/g c h=max(onemm,dp(i,j,kn))*alpha0/g - Shear2(i,j,k)=max(1.e-9,du2l(i,j,k))/(h*h) + Shear2(i,j,k)=max(1.e-13*A_mks2cgs,du2l(i,j,k))/(h*h) Prod(i,j,k)=difdia(i,j,k)*Pr_t*Shear2(i,j,k) else Buoy(i,j,k)=0. @@ -2307,7 +2330,7 @@ subroutine difest_vertical_iso(m,n,mm,nn,k1m,k1n) c c --- ------- Penetration of surface TKE below mixed layer. if (tkepf.gt.0.) then - if (dp(i,j,kn).lt.epsil) then + if (dp(i,j,kn).lt.epsilp) then q=exp(-p(i,j,k)/tkepls) else q=tkepls*(exp(-p(i,j,k )/tkepls) @@ -2319,7 +2342,7 @@ subroutine difest_vertical_iso(m,n,mm,nn,k1m,k1n) c c --- ------- Set TKE and GLS to prescribed minimum values in surface c --- ------- mixed layers and thin layers - if (dp(i,j,kn).lt.epsil) then + if (dp(i,j,kn).lt.epsilp) then trc(i,j,kn,itrtke)=tke_min trc(i,j,kn,itrgls)=gls_psi_min endif @@ -2336,7 +2359,7 @@ subroutine difest_vertical_iso(m,n,mm,nn,k1m,k1n) trc(i,j,kn,itrgls)=max(gls_psi_min, . (gls_cmu0**(gls_p-2.*gls_m)) . *(ust**(2.*gls_m)) - . *(kappa*1.e2)**gls_n) + . *(kappa*L_mks2cgs)**gls_n) # endif endif c @@ -2408,7 +2431,7 @@ subroutine difest_vertical_iso(m,n,mm,nn,k1m,k1n) if (tdmflg.eq.1) then q=.5*(tanh(4.*(abs(plat(i,j))-tdclat)/tddlat-2.)+1.) q=(1.-q)*tdmls0+q*tdmls1 - if (dp(i,j,kn).lt.epsil) then + if (dp(i,j,kn).lt.epsilp) then vsf=exp(p(i,j,k)/q)/(q*(exp(p(i,j,kk+1)/q)-1.)) else vsf=(exp(p(i,j,k+1)/q)-exp(p(i,j,k)/q)) @@ -2470,7 +2493,7 @@ subroutine difest_vertical_iso(m,n,mm,nn,k1m,k1n) do i=max(1,ifp(j,l)),min(ii,ilp(j,l)) if (k.lt.kfil(i,j)) then if (k.gt.2.and.kfil(i,j).le.kk.and. - . p(i,j,min(kk,kfil(i,j)))-p(i,j,3).gt.epsil) then + . p(i,j,min(kk,kfil(i,j)))-p(i,j,3).gt.epsilp) then q=.5*(p(i,j,k+1)+p(i,j,k)) difdia(i,j,k)=((q-p(i,j,3))*dfddsl(i) . +(p(i,j,kfil(i,j))-q)*dfddsu(i)) @@ -2491,7 +2514,7 @@ subroutine difest_vertical_iso(m,n,mm,nn,k1m,k1n) do i=max(1,ifp(j,l)),min(ii,ilp(j,l)) if (k.le.kmax(i,j).and.kmax(i,j)-kfil(i,j).ge.1) then q=niwls - if (k.eq.2.or.dp(i,j,kn).lt.epsil) then + if (k.eq.2.or.dp(i,j,kn).lt.epsilp) then vsf=exp((p(i,j,3)-p(i,j,k+1))/q) . /(q*(1.-exp((p(i,j,3)-p(i,j,kk+1))/q))) else @@ -2519,7 +2542,7 @@ subroutine difest_vertical_iso(m,n,mm,nn,k1m,k1n) . -buoyfl(i,j,1))) c c --- --- Mixed layer thickness - h=(p(i,j,3)-p(i,j,1))/onecm + h=(p(i,j,3)-p(i,j,1))/(onem*iL_mks2cgs) c c --- --- Dimensionless vertical coordinate in the boundary layer sg=(p(i,j,2)-p(i,j,1))/(p(i,j,3)-p(i,j,1)) diff --git a/phy/mod_diffusion.F90 b/phy/mod_diffusion.F90 index 638a5f6d..4f82d958 100644 --- a/phy/mod_diffusion.F90 +++ b/phy/mod_diffusion.F90 @@ -1,5 +1,5 @@ ! ------------------------------------------------------------------------------ -! Copyright (C) 2020-2022 Mats Bentsen +! Copyright (C) 2020-2022 Mats Bentsen, Mehmet Ilicak ! ! This file is part of BLOM. ! @@ -24,7 +24,7 @@ module mod_diffusion use mod_types, only: r8 use mod_config, only: inst_suffix - use mod_constants, only: spval, epsil + use mod_constants, only: spval, epsilk use mod_xc implicit none @@ -320,9 +320,9 @@ subroutine inivar_diffusion enddo do k = 1, kk+1 do i = 1 - nbdy, ii + nbdy - Kvisc_m(i, j, k) = epsil - Kdiff_t(i, j, k) = epsil - Kdiff_s(i, j, k) = epsil + Kvisc_m(i, j, k) = epsilk + Kdiff_t(i, j, k) = epsilk + Kdiff_s(i, j, k) = epsilk enddo enddo enddo diff --git a/phy/mod_eddtra.F90 b/phy/mod_eddtra.F90 index 87df3bda..1490cf92 100644 --- a/phy/mod_eddtra.F90 +++ b/phy/mod_eddtra.F90 @@ -1,5 +1,5 @@ ! ------------------------------------------------------------------------------ -! Copyright (C) 2015-2022 Mats Bentsen +! Copyright (C) 2015-2022 Mats Bentsen, Mehmet Ilicak ! ! This file is part of BLOM. ! @@ -24,7 +24,8 @@ module mod_eddtra ! ------------------------------------------------------------------------------ use mod_types, only: r8 - use mod_constants, only: g, alpha0, epsil, onecm, onemm + use mod_constants, only: g, alpha0, rho0, epsilp, onem, onecm, onemm, & + L_mks2cgs use mod_time, only: delt1 use mod_xc use mod_vcoord, only: vcoord_type_tag, isopyc_bulkml, cntiso_hybrid @@ -39,6 +40,9 @@ module mod_eddtra implicit none + real(r8), parameter :: & + iL_mks2cgs = 1./L_mks2cgs + private public :: eddtra @@ -149,12 +153,10 @@ subroutine eddtra_gm_isopyc_bulkml(m, n, mm, nn, k1m, k1n) real(r8), dimension(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy) :: ptu, ptv real(r8), dimension(kdm+1) :: upsilon, mfl real(r8), dimension(kdm) :: dlm, dlp - real(r8) :: rho0, q, et2mf, kappa, fhi, flo + real(r8) :: q, et2mf, kappa, fhi, flo integer :: i, j, k, l, km, kn, kintr, kmax, kmin, niter, kdir logical :: changed - rho0 = 1._r8/alpha0 - call xctilr(difint, 1, kk, 2, 2, halo_ps) call xctilr(pbu, 1, 2, 2, 2, halo_us) call xctilr(pbv, 1, 2, 2, 2, halo_vs) @@ -205,7 +207,8 @@ subroutine eddtra_gm_isopyc_bulkml(m, n, mm, nn, k1m, k1n) kmax = 1 do k = 3, kk kn = k + nn - if (dp(i - 1, j, kn) > epsil .or. dp(i, j, kn) > epsil) kmax = k + if (dp(i - 1, j, kn) > epsilp .or. dp(i, j, kn) > epsilp) & + kmax = k enddo ! ------------------------------------------------------------------ @@ -248,7 +251,7 @@ subroutine eddtra_gm_isopyc_bulkml(m, n, mm, nn, k1m, k1n) temp(i - 1, j, kn), saln(i - 1, j, kn)) < & rho(p(i , j, 3), & temp(i , j, km), saln(i , j, km)) .or. & - dp(i - 1, j, kn) < epsil) + dp(i - 1, j, kn) < epsilp) kintr = kintr + 1 if (kintr == kmax + 1) exit kn = kintr + nn @@ -290,7 +293,7 @@ subroutine eddtra_gm_isopyc_bulkml(m, n, mm, nn, k1m, k1n) temp(i , j, kn), saln(i , j, kn)) < & rho(p(i - 1, j, 3), & temp(i - 1, j, km), saln(i - 1, j, km)) .or. & - dp(i , j, kn) < epsil) + dp(i , j, kn) < epsilp) kintr = kintr + 1 if (kintr == kmax + 1) exit kn = kintr + nn @@ -412,10 +415,10 @@ subroutine eddtra_gm_isopyc_bulkml(m, n, mm, nn, k1m, k1n) mfl(kmin + 1) = min(fhi, max(flo, mfl(kmin + 1))) do k = kmin + 1, kmax - 1 if (mfl(k + 1) - mfl(k) > & - ffac*max(epsil, dlm(k))*scp2(i - 1, j)) then + ffac*max(epsilp, dlm(k))*scp2(i - 1, j)) then mfl(k + 1) = mfl(k) + fface*dlm(k)*scp2(i - 1, j) elseif (mfl(k + 1) - mfl(k) < & - - ffac*max(epsil, dlp(k))*scp2(i , j)) then + - ffac*max(epsilp, dlp(k))*scp2(i , j)) then mfl(k + 1) = mfl(k) - fface*dlp(k)*scp2(i , j) else exit @@ -462,11 +465,11 @@ subroutine eddtra_gm_isopyc_bulkml(m, n, mm, nn, k1m, k1n) ! difference between lower and upper interface is beyond the ! floating point accuracy limitation. if (abs(mfl(k + 1) - mfl(k)) > & - 1.e-14_r8*max(epsil*scu2(i, j), & + 1.e-14_r8*max(epsilp*scu2(i, j), & abs(mfl(k + 1) + mfl(k)))) then if (mfl(k + 1) - mfl(k) > & - ffac*max(epsil, dlm(k))*scp2(i - 1, j)) then + ffac*max(epsilp, dlm(k))*scp2(i - 1, j)) then ! In this case, the mass fluxes are removing too much ! mass from the grid cell at (i - 1, j, k). Limit the ! dominating interface flux. @@ -488,7 +491,7 @@ subroutine eddtra_gm_isopyc_bulkml(m, n, mm, nn, k1m, k1n) endif changed = .true. elseif (mfl(k + 1) - mfl(k) < & - - ffac*max(epsil, dlp(k))*scp2(i , j)) then + - ffac*max(epsilp, dlp(k))*scp2(i , j)) then ! In this case, the mass fluxes are removing too much ! mass from the grid cell at (i, j, k). Limit the ! dominating interface flux. @@ -522,7 +525,7 @@ subroutine eddtra_gm_isopyc_bulkml(m, n, mm, nn, k1m, k1n) k = kmin if (abs(mfl(k + 1) - mfl(k)) > & - 1.e-14_r8*max(epsil*scu2(i, j), & + 1.e-14_r8*max(epsilp*scu2(i, j), & abs(mfl(k + 1) + mfl(k)))) then umfltd(i, j, 2 + mm) = mfl(k + 1) - mfl(k) umfltd(i, j, 1 + mm) = umfltd(i, j, 2 + mm) & @@ -537,25 +540,25 @@ subroutine eddtra_gm_isopyc_bulkml(m, n, mm, nn, k1m, k1n) do k = kintr, kmax km = k + mm if (abs(mfl(k + 1) - mfl(k)) > & - 1.e-14_r8*max(epsil*scu2(i, j), & + 1.e-14_r8*max(epsilp*scu2(i, j), & abs(mfl(k + 1) + mfl(k)))) then umfltd(i, j, km) = mfl(k + 1) - mfl(k) else umfltd(i, j, km) = 0._r8 endif if (umfltd(i, j, km) > & - ffac*max(epsil, dlm(k))*scp2(i - 1, j)) then + ffac*max(epsilp, dlm(k))*scp2(i - 1, j)) then write(lp,*) 'eddtra_gm_isopyc_bulkml u >', & i + i0, j + j0, k, umfltd(i, j, km), & - ffac*max(epsil, dlm(k))*scp2(i - 1, j) + ffac*max(epsilp, dlm(k))*scp2(i - 1, j) call xchalt('(eddtra_gm_isopyc_bulkml)') stop '(eddtra_gm_isopyc_bulkml)' endif if (umfltd(i, j, km) < & - - ffac*max(epsil, dlp(k))*scp2(i , j)) then + - ffac*max(epsilp, dlp(k))*scp2(i , j)) then write(lp,*) 'eddtra_gm_isopyc_bulkml u <', & i + i0, j + j0, k, umfltd(i, j, km), & - - ffac*max(epsil, dlp(k))*scp2(i , j) + - ffac*max(epsilp, dlp(k))*scp2(i , j) call xchalt('(eddtra_gm_isopyc_bulkml)') stop '(eddtra_gm_isopyc_bulkml)' endif @@ -591,7 +594,8 @@ subroutine eddtra_gm_isopyc_bulkml(m, n, mm, nn, k1m, k1n) kmax = 1 do k = 3, kk kn = k + nn - if (dp(i, j - 1, kn) > epsil .or. dp(i, j, kn) > epsil) kmax = k + if (dp(i, j - 1, kn) > epsilp .or. dp(i, j, kn) > epsilp) & + kmax = k enddo ! ------------------------------------------------------------------ @@ -634,7 +638,7 @@ subroutine eddtra_gm_isopyc_bulkml(m, n, mm, nn, k1m, k1n) temp(i, j - 1, kn), saln(i, j - 1, kn)) < & rho(p(i, j , 3), & temp(i, j , km), saln(i, j , km)) .or. & - dp(i, j - 1, kn) < epsil) + dp(i, j - 1, kn) < epsilp) kintr = kintr + 1 if (kintr == kmax + 1) exit kn = kintr + nn @@ -676,7 +680,7 @@ subroutine eddtra_gm_isopyc_bulkml(m, n, mm, nn, k1m, k1n) temp(i, j , kn), saln(i, j , kn)) < & rho(p(i, j - 1, 3), & temp(i, j - 1, km), saln(i, j - 1, km)) .or. & - dp(i, j , kn) < epsil) + dp(i, j , kn) < epsilp) kintr = kintr + 1 if (kintr == kmax + 1) exit kn = kintr + nn @@ -798,10 +802,10 @@ subroutine eddtra_gm_isopyc_bulkml(m, n, mm, nn, k1m, k1n) mfl(kmin + 1) = min(fhi, max(flo, mfl(kmin + 1))) do k = kmin + 1, kmax - 1 if (mfl(k + 1) - mfl(k) > & - ffac*max(epsil, dlm(k))*scp2(i, j - 1)) then + ffac*max(epsilp, dlm(k))*scp2(i, j - 1)) then mfl(k + 1) = mfl(k) + fface*dlm(k)*scp2(i, j - 1) elseif (mfl(k + 1) - mfl(k) < & - - ffac*max(epsil, dlp(k))*scp2(i, j )) then + - ffac*max(epsilp, dlp(k))*scp2(i, j )) then mfl(k + 1) = mfl(k) - fface*dlp(k)*scp2(i, j ) else exit @@ -848,11 +852,11 @@ subroutine eddtra_gm_isopyc_bulkml(m, n, mm, nn, k1m, k1n) ! difference between lower and upper interface is beyond the ! floating point accuracy limitation. if (abs(mfl(k + 1) - mfl(k)) > & - 1.e-14_r8*max(epsil*scv2(i, j), & + 1.e-14_r8*max(epsilp*scv2(i, j), & abs(mfl(k + 1) + mfl(k)))) then if (mfl(k + 1) - mfl(k) > & - ffac*max(epsil, dlm(k))*scp2(i, j - 1)) then + ffac*max(epsilp, dlm(k))*scp2(i, j - 1)) then ! In this case, the mass fluxes are removing too much ! mass from the grid cell at (i, j - 1, k). Limit the ! dominating interface flux. @@ -874,7 +878,7 @@ subroutine eddtra_gm_isopyc_bulkml(m, n, mm, nn, k1m, k1n) endif changed = .true. elseif (mfl(k + 1) - mfl(k) < & - - ffac*max(epsil, dlp(k))*scp2(i, j )) then + - ffac*max(epsilp, dlp(k))*scp2(i, j )) then ! In this case, the mass fluxes are removing too much ! mass from the grid cell at (i, j, k). Limit the ! dominating interface flux. @@ -908,7 +912,7 @@ subroutine eddtra_gm_isopyc_bulkml(m, n, mm, nn, k1m, k1n) k = kmin if (abs(mfl(k + 1) - mfl(k)) > & - 1.e-14_r8*max(epsil*scv2(i, j), & + 1.e-14_r8*max(epsilp*scv2(i, j), & abs(mfl(k + 1) + mfl(k)))) then vmfltd(i, j, 2 + mm) = mfl(k + 1) - mfl(k) vmfltd(i, j, 1 + mm) = vmfltd(i, j, 2 + mm) & @@ -923,25 +927,25 @@ subroutine eddtra_gm_isopyc_bulkml(m, n, mm, nn, k1m, k1n) do k = kintr, kmax km = k + mm if (abs(mfl(k + 1) - mfl(k)) > & - 1.e-14_r8*max(epsil*scv2(i, j), & + 1.e-14_r8*max(epsilp*scv2(i, j), & abs(mfl(k + 1) + mfl(k)))) then vmfltd(i, j, km) = mfl(k + 1) - mfl(k) else vmfltd(i, j, km) = 0._r8 endif if (vmfltd(i, j, km) > & - ffac*max(epsil, dlm(k))*scp2(i, j - 1)) then + ffac*max(epsilp, dlm(k))*scp2(i, j - 1)) then write(lp,*) 'eddtra_gm_isopyc_bulkml v >', & i + i0, j + j0, k, vmfltd(i, j, km), & - ffac*max(epsil, dlm(k))*scp2(i, j - 1) + ffac*max(epsilp, dlm(k))*scp2(i, j - 1) call xchalt('(eddtra_gm_isopyc_bulkml)') stop '(eddtra_gm_isopyc_bulkml)' endif if (vmfltd(i, j, km) < & - - ffac*max(epsil, dlp(k))*scp2(i, j )) then + - ffac*max(epsilp, dlp(k))*scp2(i, j )) then write(lp,*) 'eddtra_gm_isopyc_bulkml v <', & i + i0, j + j0, k, vmfltd(i, j, km), & - - ffac*max(epsil, dlp(k))*scp2(i, j ) + - ffac*max(epsilp, dlp(k))*scp2(i, j ) call xchalt('(eddtra_gm_isopyc_bulkml)') stop '(eddtra_gm_isopyc_bulkml)' endif @@ -971,12 +975,10 @@ subroutine eddtra_gm_cntiso_hybrid(m, n, mm, nn, k1m, k1n) real(r8), dimension(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy) :: ptu, ptv real(r8), dimension(kdm+1) :: mfl real(r8), dimension(kdm) :: puv, dlm, dlp - real(r8) :: rho0, q, et2mf, mlp, kappa + real(r8) :: q, et2mf, mlp, kappa integer :: i, j, k, l, km, kn, kmax, kml, niter, kdir logical :: changed - rho0 = 1._r8/alpha0 - call xctilr(difint, 1, kk, 2, 2, halo_ps) call xctilr(pbu, 1, 2, 2, 2, halo_us) call xctilr(pbv, 1, 2, 2, 2, halo_vs) @@ -1028,12 +1030,13 @@ subroutine eddtra_gm_cntiso_hybrid(m, n, mm, nn, k1m, k1n) do k = 2, kk kn = k + nn puv(k) = puv(k - 1) + dpu(i, j, kn - 1) - if (dp(i - 1, j, kn) > epsil .or. dp(i, j, kn) > epsil) kmax = k + if (dp(i - 1, j, kn) > epsilp .or. dp(i, j, kn) > epsilp) & + kmax = k enddo ! Compute the eddy induced mass flux at layer interfaces below the ! mixed layer. - mlp = .5_r8*(mlts(i - 1, j) + mlts(i, j))*onecm + mlp = .5_r8*(mlts(i - 1, j) + mlts(i, j))*(onem*iL_mks2cgs) kml = kmax + 1 mfl(kmax + 1) = 0._r8 do k = kmax, 2, -1 @@ -1106,11 +1109,11 @@ subroutine eddtra_gm_cntiso_hybrid(m, n, mm, nn, k1m, k1n) ! difference between lower and upper interface is beyond the ! floating point accuracy limitation. if (abs(mfl(k + 1) - mfl(k)) > & - 1.e-14_r8*max(epsil*scu2(i, j), & + 1.e-14_r8*max(epsilp*scu2(i, j), & abs(mfl(k + 1) + mfl(k)))) then if (mfl(k + 1) - mfl(k) > & - ffac*max(epsil, dlm(k))*scp2(i - 1, j)) then + ffac*max(epsilp, dlm(k))*scp2(i - 1, j)) then ! In this case, the mass fluxes are removing too much ! mass from the grid cell at (i - 1, j, k). Limit the ! dominating interface flux. @@ -1132,7 +1135,7 @@ subroutine eddtra_gm_cntiso_hybrid(m, n, mm, nn, k1m, k1n) endif changed = .true. elseif (mfl(k + 1) - mfl(k) < & - - ffac*max(epsil, dlp(k))*scp2(i , j)) then + - ffac*max(epsilp, dlp(k))*scp2(i , j)) then ! In this case, the mass fluxes are removing too much ! mass from the grid cell at (i, j, k). Limit the ! dominating interface flux. @@ -1167,25 +1170,25 @@ subroutine eddtra_gm_cntiso_hybrid(m, n, mm, nn, k1m, k1n) do k = 1, kmax km = k + mm if (abs(mfl(k + 1) - mfl(k)) > & - 1.e-14_r8*max(epsil*scu2(i, j), & + 1.e-14_r8*max(epsilp*scu2(i, j), & abs(mfl(k + 1) + mfl(k)))) then umfltd(i, j, km) = mfl(k + 1) - mfl(k) else umfltd(i, j, km) = 0._r8 endif if (umfltd(i, j, km) > & - ffac*max(epsil, dlm(k))*scp2(i - 1, j)) then + ffac*max(epsilp, dlm(k))*scp2(i - 1, j)) then write(lp,*) 'eddtra_gm_cntiso_hybrid u >', & i + i0, j + j0, k, umfltd(i, j, km), & - ffac*max(epsil, dlm(k))*scp2(i - 1, j) + ffac*max(epsilp, dlm(k))*scp2(i - 1, j) call xchalt('(eddtra_gm_cntiso_hybrid)') stop '(eddtra_gm_cntiso_hybrid)' endif if (umfltd(i, j, km) < & - - ffac*max(epsil, dlp(k))*scp2(i , j)) then + - ffac*max(epsilp, dlp(k))*scp2(i , j)) then write(lp,*) 'eddtra_gm_cntiso_hybrid u <', & i + i0, j + j0, k, umfltd(i, j, km), & - - ffac*max(epsil, dlp(k))*scp2(i , j) + - ffac*max(epsilp, dlp(k))*scp2(i , j) call xchalt('(eddtra_gm_cntiso_hybrid)') stop '(eddtra_gm_cntiso_hybrid)' endif @@ -1222,12 +1225,13 @@ subroutine eddtra_gm_cntiso_hybrid(m, n, mm, nn, k1m, k1n) do k = 2, kk kn = k + nn puv(k) = puv(k - 1) + dpv(i, j, kn - 1) - if (dp(i, j - 1, kn) > epsil .or. dp(i, j, kn) > epsil) kmax = k + if (dp(i, j - 1, kn) > epsilp .or. dp(i, j, kn) > epsilp) & + kmax = k enddo ! Compute the eddy induced mass flux at layer interfaces below the ! mixed layer. - mlp = .5_r8*(mlts(i, j - 1) + mlts(i, j))*onecm + mlp = .5_r8*(mlts(i, j - 1) + mlts(i, j))*(onem*iL_mks2cgs) kml = kmax + 1 mfl(kmax + 1) = 0._r8 do k = kmax, 2, -1 @@ -1300,11 +1304,11 @@ subroutine eddtra_gm_cntiso_hybrid(m, n, mm, nn, k1m, k1n) ! difference between lower and upper interface is beyond the ! floating point accuracy limitation. if (abs(mfl(k + 1) - mfl(k)) > & - 1.e-14_r8*max(epsil*scv2(i, j), & + 1.e-14_r8*max(epsilp*scv2(i, j), & abs(mfl(k + 1) + mfl(k)))) then if (mfl(k + 1) - mfl(k) > & - ffac*max(epsil, dlm(k))*scp2(i, j - 1)) then + ffac*max(epsilp, dlm(k))*scp2(i, j - 1)) then ! In this case, the mass fluxes are removing too much ! mass from the grid cell at (i, j - 1, k). Limit the ! dominating interface flux. @@ -1326,7 +1330,7 @@ subroutine eddtra_gm_cntiso_hybrid(m, n, mm, nn, k1m, k1n) endif changed = .true. elseif (mfl(k + 1) - mfl(k) < & - - ffac*max(epsil, dlp(k))*scp2(i, j )) then + - ffac*max(epsilp, dlp(k))*scp2(i, j )) then ! In this case, the mass fluxes are removing too much ! mass from the grid cell at (i, j, k). Limit the ! dominating interface flux. @@ -1361,25 +1365,25 @@ subroutine eddtra_gm_cntiso_hybrid(m, n, mm, nn, k1m, k1n) do k = 1, kmax km = k + mm if (abs(mfl(k + 1) - mfl(k)) > & - 1.e-14_r8*max(epsil*scv2(i, j), & + 1.e-14_r8*max(epsilp*scv2(i, j), & abs(mfl(k + 1) + mfl(k)))) then vmfltd(i, j, km) = mfl(k + 1) - mfl(k) else vmfltd(i, j, km) = 0._r8 endif if (vmfltd(i, j, km) > & - ffac*max(epsil, dlm(k))*scp2(i, j - 1)) then + ffac*max(epsilp, dlm(k))*scp2(i, j - 1)) then write(lp,*) 'eddtra_gm_cntiso_hybrid v >', & i + i0, j + j0, k, vmfltd(i, j, km), & - ffac*max(epsil, dlm(k))*scp2(i, j - 1) + ffac*max(epsilp, dlm(k))*scp2(i, j - 1) call xchalt('(eddtra_gm_cntiso_hybrid)') stop '(eddtra_gm_cntiso_hybrid)' endif if (vmfltd(i, j, km) < & - - ffac*max(epsil, dlp(k))*scp2(i, j )) then + - ffac*max(epsilp, dlp(k))*scp2(i, j )) then write(lp,*) 'eddtra_gm_cntiso_hybrid v <', & i + i0, j + j0, k, vmfltd(i, j, km), & - - ffac*max(epsil, dlp(k))*scp2(i, j ) + - ffac*max(epsilp, dlp(k))*scp2(i, j ) call xchalt('(eddtra_gm_cntiso_hybrid)') stop '(eddtra_gm_cntiso_hybrid)' endif diff --git a/phy/mod_eos.F90 b/phy/mod_eos.F90 index 49bbef46..7226abff 100644 --- a/phy/mod_eos.F90 +++ b/phy/mod_eos.F90 @@ -24,6 +24,7 @@ module mod_eos ! ------------------------------------------------------------------------------ use mod_types, only: r8 + use mod_constants, only: alpha0 use mod_config, only: expcnf use mod_xc, only: mnproc, lp, xcstop @@ -32,6 +33,27 @@ module mod_eos private ! Coefficients for the functional fit of in situ density. +#ifdef MKS + real(r8), parameter :: & + a11 = 9.9985372432159340e+02_r8, & + a12 = 1.0380621928183473e+01_r8, & + a13 = 1.7073577195684715e+00_r8, & + a14 = -3.6570490496333680e-02_r8, & + a15 = -7.3677944503527477e-03_r8, & + a16 = -3.5529175999643348e-03_r8, & + b11 = 1.7083494994335439e-06_r8, & + b12 = 7.1567921402953455e-09_r8, & + b13 = 1.2821026080049485e-09_r8, & + a21 = 1.0_r8 , & + a22 = 1.0316374535350838e-02_r8, & + a23 = 8.9521792365142522e-04_r8, & + a24 = -2.8438341552142710e-05_r8, & + a25 = -1.1887778959461776e-05_r8, & + a26 = -4.0163964812921489e-06_r8, & + b21 = 1.1995545126831476e-09_r8, & + b22 = 5.5234008384648383e-12_r8, & + b23 = 8.4310335919950873e-13_r8 +#else real(r8), parameter :: & a11 = 9.9985372432159340e-01_r8, & a12 = 1.0380621928183473e-02_r8, & @@ -51,6 +73,7 @@ module mod_eos b21 = 1.1995545126831476e-10_r8, & b22 = 5.5234008384648383e-13_r8, & b23 = 8.4310335919950873e-14_r8 +#endif ! Reference pressure [g cm-1 s-2]. real(r8) :: pref @@ -106,12 +129,12 @@ subroutine inieos ap24 = a24 ap25 = a25 ap26 = a26 - ap11 = a11 + b11*pref - ap21 - ap12 = a12 + b12*pref - ap22 - ap13 = a13 + b13*pref - ap23 - ap14 = a14 - ap24 - ap15 = a15 - ap25 - ap16 = a16 - ap26 + ap11 = a11 + b11*pref - ap21/alpha0 + ap12 = a12 + b12*pref - ap22/alpha0 + ap13 = a13 + b13*pref - ap23/alpha0 + ap14 = a14 - ap24/alpha0 + ap15 = a15 - ap25/alpha0 + ap16 = a16 - ap26/alpha0 ap210 = a21 ap220 = a22 @@ -119,12 +142,12 @@ subroutine inieos ap240 = a24 ap250 = a25 ap260 = a26 - ap110 = a11 - ap210 - ap120 = a12 - ap220 - ap130 = a13 - ap230 - ap140 = a14 - ap240 - ap150 = a15 - ap250 - ap160 = a16 - ap260 + ap110 = a11 - ap210/alpha0 + ap120 = a12 - ap220/alpha0 + ap130 = a13 - ap230/alpha0 + ap140 = a14 - ap240/alpha0 + ap150 = a15 - ap250/alpha0 + ap160 = a16 - ap260/alpha0 ! Coefficients for freezing temperature. select case (trim(expcnf)) diff --git a/phy/mod_inicon.F b/phy/mod_inicon.F index fdfebd50..70e0c371 100644 --- a/phy/mod_inicon.F +++ b/phy/mod_inicon.F @@ -27,7 +27,8 @@ module mod_inicon c use mod_types, only: r8 use mod_config, only: expcnf - use mod_constants, only: g, epsil, onem + use mod_constants, only: g, epsilp, onem, + . L_mks2cgs, M_mks2cgs, P_mks2cgs use mod_time, only: nstep, delt1, dlt use mod_xc use mod_vcoord, only: vcoord_type_tag, isopyc_bulkml, @@ -98,7 +99,7 @@ function getpl(th,s,phiu,phil,pup) result(plo) c --- improve the accuracy of the pressure interface by an c --- iterative procedure q=1._r8 - do while (abs(q).gt.1.e-4_r8) + do while (abs(q).gt.1.e-5_r8*P_mks2cgs) call delphi(pup,plo,th,s,dphi,alpu,alpl) q=(phil-phiu-dphi)/alpl plo=plo-q @@ -121,6 +122,9 @@ 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 +c + iM_mks2cgs = 1.0 / M_mks2cgs c if (mnproc.eq.1) then write (lp,'(2a)') ' reading initial condition from ', @@ -344,7 +348,7 @@ subroutine ictsz_file do j=1,jj do l=1,isp(j) do i=max(1,ifp(j,l)),min(ii,ilp(j,l)) -c z(i,j,1)=z(i,j,1)*1.e2 +c z(i,j,1)=z(i,j,1)*L_mks2cgs z(i,j,1)=0. enddo enddo @@ -355,7 +359,8 @@ subroutine ictsz_file do k=1,kdmic do l=1,isp(j) do i=max(1,ifp(j,l)),min(ii,ilp(j,l)) - z(i,j,k+1)=min(depths(i,j)*1.e2,z(i,j,k)+dz(i,j,k)*1.e2) + z(i,j,k+1)=min(depths(i,j)*L_mks2cgs, + . z(i,j,k)+dz(i,j,k)*L_mks2cgs) enddo enddo enddo @@ -369,20 +374,20 @@ subroutine ictsz_file do k=2,kk do l=1,isp(j) do i=max(1,ifp(j,l)),min(ii,ilp(j,l)) - if (z(i,j,kk+1)-z(i,j,k).lt.1.e-4) - . z(i,j,k)=depths(i,j)*1.e2 + if (z(i,j,kk+1)-z(i,j,k).lt.1.e-6*L_mks2cgs) + . z(i,j,k)=depths(i,j)*L_mks2cgs 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)=depths(i,j)*1.e2 + z(i,j,kk+1)=depths(i,j)*L_mks2cgs enddo enddo 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)*1.e-3 + sigmar(i,j,k)=sigmar(i,j,k)*iM_mks2cgs enddo enddo enddo @@ -876,7 +881,7 @@ subroutine inicon do i=max(1,ifp(j,l)),min(ii,ilp(j,l)) k=3 dps=0. - do while (dp(i,j,k).lt.epsil) + do while (dp(i,j,k).lt.epsilp) dps=dps+dp(i,j,k) dp(i,j,k)=0. dp(i,j,k+kk)=0. @@ -920,7 +925,8 @@ subroutine inicon j=jtest write (lp,103) nstep,i0+i,j0+j, . ' init.profile temp saln dens thkns dpth', - . (k,temp(i,j,k),saln(i,j,k),1000.*sig(temp(i,j,k),saln(i,j,k)), + . (k,temp(i,j,k),saln(i,j,k), + . M_mks2cgs*sig(temp(i,j,k),saln(i,j,k)), . dp(i,j,k)/onem,p(i,j,k+1)/onem,k=1,kk) 103 format (i9,2i5,a/(28x,i3,3f8.2,2f8.1)) endif diff --git a/phy/mod_momtum.F b/phy/mod_momtum.F index ad98f07a..9eea25bf 100644 --- a/phy/mod_momtum.F +++ b/phy/mod_momtum.F @@ -1,6 +1,6 @@ ! ------------------------------------------------------------------------------ ! Copyright (C) 2000 HYCOM Consortium and contributors -! Copyright (C) 2001-2020 Mats Bentsen, Lars Inge Enstad, Mehmet Ilicak +! Copyright (C) 2001-2022 Mats Bentsen, Lars Inge Enstad, Mehmet Ilicak ! ! This file is part of BLOM. ! @@ -26,7 +26,8 @@ module mod_momtum c --- ------------------------------------------------------------------ c use mod_types, only: r8 - use mod_constants, only: g, alpha0, epsil, spval, onem, onemm + use mod_constants, only: g, alpha0, epsilp, epsilpl, spval, + . onem, onemm use mod_time, only: delt1, dlt use mod_xc use mod_grid, only: scqx, scqy, scpx, scpy, scux, scuy, @@ -276,14 +277,14 @@ subroutine momtum(m,n,mm,nn,k1m,k1n) c do i=max(0,ifp(j,l)),min(ii,ilp(j,l)) ubot=(ubflxs_p(i ,j,n) - . /max(epsil,pbu(i ,j,n)*scuy(i ,j)) + . /max(epsilpl,pbu(i ,j,n)*scuy(i ,j)) . +ubflxs_p(i+1,j,n) - . /max(epsil,pbu(i+1,j,n)*scuy(i+1,j)))*tsfac + . /max(epsilpl,pbu(i+1,j,n)*scuy(i+1,j)))*tsfac . +util1(i,j)/thkbop vbot=(vbflxs_p(i,j ,n) - . /max(epsil,pbv(i,j ,n)*scvx(i,j )) + . /max(epsilpl,pbv(i,j ,n)*scvx(i,j )) . +vbflxs_p(i,j+1,n) - . /max(epsil,pbv(i,j+1,n)*scvx(i,j+1)))*tsfac + . /max(epsilpl,pbv(i,j+1,n)*scvx(i,j+1)))*tsfac . +util2(i,j)/thkbop ubbl=.5*sqrt(ubot*ubot+vbot*vbot) q=cb*(ubbl+cbar) @@ -445,9 +446,9 @@ subroutine momtum(m,n,mm,nn,k1m,k1n) do l=1,isu(j) do i=max(0,ifu(j,l)),min(ii+2,ilu(j,l)) wgtja(i,j)=max(0.,min(1.,(pu(i,j,k+1)-pbu(i,j-1,m)) - . /max(pu(i,j,k+1)-pu(i,j,k),epsil))) + . /max(pu(i,j,k+1)-pu(i,j,k),epsilp))) wgtjb(i,j)=max(0.,min(1.,(pu(i,j,k+1)-pbu(i,j+1,m)) - . /max(pu(i,j,k+1)-pu(i,j,k),epsil))) + . /max(pu(i,j,k+1)-pu(i,j,k),epsilp))) uja(i,j)=(1.-wgtja(i,j))*utotn(i,j-1) . +wgtja(i,j)*slip*utotn(i,j) ujb(i,j)=(1.-wgtjb(i,j))*utotn(i,j+1) @@ -464,9 +465,9 @@ subroutine momtum(m,n,mm,nn,k1m,k1n) do l=1,isv(j) do i=max(-1,ifv(j,l)),min(ii+2,ilv(j,l)) wgtia(i,j)=max(0.,min(1.,(pv(i,j,k+1)-pbv(i-1,j,m)) - . /max(pv(i,j,k+1)-pv(i,j,k),epsil))) + . /max(pv(i,j,k+1)-pv(i,j,k),epsilp))) wgtib(i,j)=max(0.,min(1.,(pv(i,j,k+1)-pbv(i+1,j,m)) - . /max(pv(i,j,k+1)-pv(i,j,k),epsil))) + . /max(pv(i,j,k+1)-pv(i,j,k),epsilp))) via(i,j)=(1.-wgtia(i,j))*vtotn(i-1,j) . +wgtia(i,j)*slip*vtotn(i,j) vib(i,j)=(1.-wgtib(i,j))*vtotn(i+1,j) diff --git a/phy/mod_mxlayr.F b/phy/mod_mxlayr.F index c81abb6a..fa5ebffb 100644 --- a/phy/mod_mxlayr.F +++ b/phy/mod_mxlayr.F @@ -25,8 +25,9 @@ module mod_mxlayr c --- ------------------------------------------------------------------ c use mod_types, only: r8 - use mod_constants, only: g, spcifh, alpha0, epsil, spval, onem, - . tencm, onecm, onemm, onemu + use mod_constants, only: g, spcifh, alpha0, epsilp, spval, onem, + . tencm, onecm, onemm, onemu, + . L_mks2cgs, R_mks2cgs use mod_time, only: delt1 use mod_xc use mod_vcoord, only: sigmar @@ -89,6 +90,11 @@ module mod_mxlayr . mtkeke, ! Mixed layer TKE tendency related to kin. ! energy change [cm3 s-3]. . pbrnda ! Brine plume pressure depth [g cm-1 s-2]. +c + real(r8), parameter :: + . iL_mks2cgs = 1./L_mks2cgs, + . A_cgs2mks = 1./(L_mks2cgs*L_mks2cgs), + . V_mks2cgs = L_mks2cgs**3 c public :: rm0,rm5,ce,mlrttp,mltmin, . mtkeus,mtkeni,mtkebf,mtkers,mtkepe,mtkeke,pbrnda, @@ -163,7 +169,8 @@ subroutine mxlayr(m,n,mm,nn,k1m,k1n) c --- of TKE balance []. real kappa,mu,ustmin,mldjmp integer maxitr - parameter (kappa=.4,mu=2.,ustmin=.1,mldjmp=1.e-6,maxitr=20) + parameter (kappa=.4,mu=2.,ustmin=.001*L_mks2cgs, + . mldjmp=1.e-3*R_mks2cgs,maxitr=20) c c --- Parameters for the parameterization of restratification by mixed c --- layer eddies by Fox-Kemper et al. (2008): @@ -175,12 +182,12 @@ subroutine mxlayr(m,n,mm,nn,k1m,k1n) c --- ci - constant that appears when integrating the shape c --- function over the mixed layer depth []. real rtau,cori20,rlf,ci,slbg0 - parameter (rtau=1./86400.,cori20=4.9745e-5,rlf=1./5.e5, - . ci=44./63.,slbg0=0.) + parameter (rtau=1./86400.,cori20=4.9745e-5, + . rlf=1./(5.e3*L_mks2cgs),ci=44./63.,slbg0=0.) c c --- Parameters for brine plume parameterization: c --- bpdrho - density contrast between surface and brine plume depth -c --- [g/cm/s**2]. +c --- [g/cm**3]. c --- bpmndp - minimum distribution thickness of salt from sea-ice c --- freezing [g/cm/s**2]. c --- bpmxdp - maximum distribution depth below the mixed layer base @@ -190,8 +197,8 @@ subroutine mxlayr(m,n,mm,nn,k1m,k1n) c --- dsgmnr - minimum ratio of linearized density jump to target c --- density jump across a layer interface []. real bpdrho,bpmndp,bpmxdp,bpdpmn,dsgmnr - parameter (bpdrho=.4e-3,bpmndp=10.*98060.,bpmxdp=500.*98060., - . bpdpmn=1.*98060.,dsgmnr=.1) + parameter (bpdrho=.4*R_mks2cgs,bpmndp=10.*onem, + . bpmxdp=500.*onem,bpdpmn=1.*onem,dsgmnr=.1) c c --- ------------------------------------------------------------------ c --- Resolve type of mixed layer restratification time scale. @@ -418,7 +425,8 @@ subroutine mxlayr(m,n,mm,nn,k1m,k1n) tkew=mtkeus(i,j)+mtkeni(i,j)+mtkebf(i,j)+mtkers(i,j) if (.not.(nitr.eq.1.and.pres(3)*lbi.gt.1.)) then dtke=(tkew-tkeo)/dpmxl - if (abs(dtke)<(abs(tkew)+1.e-16)/(pres(3)-pres(1))) then + if (abs(dtke)<(abs(tkew)+1.e-22*V_mks2cgs) + . /(pres(3)-pres(1))) then if (tkew.lt.0.) then dpmxl=.5*(pres(1)-pmxl) else @@ -437,9 +445,9 @@ subroutine mxlayr(m,n,mm,nn,k1m,k1n) write (lp,*) 'dpth=',pres(3)/onem,';' write (lp,*) 'pmxl=',pmxl/onem,';' write (lp,*) 'corio=',coriop(i,j),';' - write (lp,*) 'ustar=',ustar(i,j)*1.e-2,';' - write (lp,*) 'bfltot=',bfltot*1.e-4,';' - write (lp,*) 'bflpsw=',bflpsw*1.e-4,';' + write (lp,*) 'ustar=',ustar(i,j)*iL_mks2cgs,';' + write (lp,*) 'bfltot=',bfltot*A_cgs2mks,';' + write (lp,*) 'bflpsw=',bflpsw*A_cgs2mks,';' write (lp,*) 'bg2=',util1(i,j),';' write (lp,*) 'ce=',ce*sqrt(scp2(i,j))*rlf,';' write (lp,*) @@ -512,7 +520,7 @@ subroutine mxlayr(m,n,mm,nn,k1m,k1n) c kmax=1 do k=2,kk - if (delp(k).gt.epsil) kmax=k + if (delp(k).gt.epsilp) kmax=k enddo kfmax=0 c @@ -589,7 +597,7 @@ subroutine mxlayr(m,n,mm,nn,k1m,k1n) bc(k)=0. endif kfmax=k - if (bdpsum.le.epsil) then + if (bdpsum.le.epsilp) then if (dpfsl.gt.onemu) then bpmldp=min(bpmndp,dpfsl+delp(2)) q=brnflx(i,j)*delt1*g/bpmldp @@ -730,7 +738,7 @@ subroutine mxlayr(m,n,mm,nn,k1m,k1n) endif else if (delp(k).gt.onemu.and.dens(k).gt.densr(k).and. - . sigfsl.lt.densr(k)-1.e-9) then + . sigfsl.lt.densr(k)-(1.e-6*R_mks2cgs)) then dps=min(dpfsl,delp(k)*(dens(k)-densr(k)) . /(densr(k)-sigfsl)) q=1./(dps+delp(k)) @@ -857,7 +865,7 @@ subroutine mxlayr(m,n,mm,nn,k1m,k1n) do if (k.gt.kk) then exit - elseif (delp(k).lt.epsil) then + elseif (delp(k).lt.epsilp) then k=k+1 else pmxl=pres(k+1) @@ -929,7 +937,7 @@ subroutine mxlayr(m,n,mm,nn,k1m,k1n) endif if (.not.chngd) then if (abs(dtke).lt. - . (abs(tkew)+1.e-16)/delp(k)) then + . (abs(tkew)+1.e-22*V_mks2cgs)/delp(k)) then if (tkew.lt.0.) then dpmxl=.5*(pres(k)-pmxl) else @@ -952,9 +960,9 @@ subroutine mxlayr(m,n,mm,nn,k1m,k1n) write (lp,*) 'dpth=',pres(3)/onem,';' write (lp,*) 'pmxl=',pmxl/onem,';' write (lp,*) 'corio=',coriop(i,j),';' - write (lp,*) 'ustar=',ustar(i,j)*1.e-2,';' - write (lp,*) 'bfltot=',bfltot*1.e-4,';' - write (lp,*) 'bflpsw=',bflpsw*1.e-4,';' + write (lp,*) 'ustar=',ustar(i,j)*iL_mks2cgs,';' + write (lp,*) 'bfltot=',bfltot*A_cgs2mks,';' + write (lp,*) 'bflpsw=',bflpsw*A_cgs2mks,';' write (lp,*) 'bg2=',util1(i,j),';' write (lp,*) 'ce=',ce*sqrt(scp2(i,j))*rlf,';' write (lp,*) 'pres(3)=',pres(3)/onem,';' @@ -972,7 +980,7 @@ subroutine mxlayr(m,n,mm,nn,k1m,k1n) c call xchalt('(mxlayr)') c stop '(mxlayr)' endif - if (pmxl.lt.pres(k+1)-epsil.and.nitr.lt.maxitr) then + if (pmxl.lt.pres(k+1)-epsilp.and.nitr.lt.maxitr) then tdps=tdps+ttem(k)*(pmxl-pres(k)) sdps=sdps+ssal(k)*(pmxl-pres(k)) #ifdef TRC @@ -1072,7 +1080,7 @@ subroutine mxlayr(m,n,mm,nn,k1m,k1n) c kmax=1 do k=2,kk - if (delp(k).gt.epsil) kmax=k + if (delp(k).gt.epsilp) kmax=k enddo kfmax=0 c @@ -1142,7 +1150,7 @@ subroutine mxlayr(m,n,mm,nn,k1m,k1n) bc(k)=0. endif kfmax=k - if (bdpsum.le.epsil) then + if (bdpsum.le.epsilp) then ssal(2)=ssal(2)-brnflx(i,j)*delt1*g/delp(2) else if (bdpsum.lt.bpmndp) then @@ -1206,7 +1214,7 @@ subroutine mxlayr(m,n,mm,nn,k1m,k1n) c --- --- Define first physical layer. k=3 dps=0. - do while (delp(k).lt.epsil) + do while (delp(k).lt.epsilp) dps=dps+delp(k) delp(k)=0. k=k+1 diff --git a/phy/mod_ndiff.F90 b/phy/mod_ndiff.F90 index 5f875313..d31b0f34 100644 --- a/phy/mod_ndiff.F90 +++ b/phy/mod_ndiff.F90 @@ -1,5 +1,5 @@ ! ------------------------------------------------------------------------------ -! Copyright (C) 2022 Mats Bentsen +! Copyright (C) 2022 Mats Bentsen, Mehmet Ilicak ! ! This file is part of BLOM. ! @@ -23,7 +23,7 @@ module mod_ndiff ! ------------------------------------------------------------------------------ use mod_types, only: r8 - use mod_constants, only: g, alpha0, epsil, onemm + use mod_constants, only: g, alpha0, epsilp, onemm, P_mks2cgs, R_mks2cgs use mod_time, only: delt1 use mod_xc use mod_grid, only: scuy, scvx, scp2, scuxi, scvyi @@ -42,8 +42,8 @@ module mod_ndiff private real(r8), parameter :: & - rhoeps = 1.e-8_r8, & - dpeps = 1.e-4_r8 + rhoeps = 1.e-5_r8*R_mks2cgs, & + dpeps = 1.e-5_r8*P_mks2cgs integer, parameter :: & p_ord = 4, & it = 1, & @@ -846,7 +846,7 @@ subroutine ndiff_flx(p_srcdi_m, t_srcdi_m, tpc_src_m, & flxconv_rs(kd_p,is,i_p,j_rs_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(epsil, p_ni_lo - p_ni_up) + dp_ni_i = 1._r8/max(epsilp, p_ni_lo - p_ni_up) do while (kuv <= kk) kuvm = kuv + mm if (puv(i_p,j_p,kuv+1) < p_ni_lo) then @@ -918,7 +918,7 @@ subroutine ndiff_flx(p_srcdi_m, t_srcdi_m, tpc_src_m, & ks = ks + 1 enddo q = (p_nslp_src(ks) - p_nslp_dst) & - /max(p_nslp_src(ks) - p_nslp_src(ks-1), epsil) + /max(p_nslp_src(ks) - p_nslp_src(ks-1), epsilp) nslpxy(i_p,j_p,kd) = q*nslp_src(ks-1) + (1._r8 - q)*nslp_src(ks) kd = kd + 1 if (kd > kk) exit diff --git a/phy/mod_pbcor.F b/phy/mod_pbcor.F index 3a350abb..b0d84df6 100644 --- a/phy/mod_pbcor.F +++ b/phy/mod_pbcor.F @@ -1,5 +1,5 @@ ! ------------------------------------------------------------------------------ -! Copyright (C) 2005-2020 Mats Bentsen, Mehmet Ilicak +! Copyright (C) 2005-2022 Mats Bentsen, Mehmet Ilicak ! ! This file is part of BLOM. ! @@ -27,7 +27,7 @@ module mod_pbcor c --- ------------------------------------------------------------------ c use mod_types, only: r8 - use mod_constants, only: epsil + use mod_constants, only: epsilp, P_mks2cgs use mod_time, only: dlt use mod_xc use mod_grid, only: scp2i @@ -54,10 +54,10 @@ module mod_pbcor c c --- Parameters: real(r8), parameter :: - . dpeps1 = 1.e-4_r8, ! Small layer pressure thickness - ! [g cm-1 s-2]. - . dpeps2 = 1.e-6_r8 ! Small layer pressure thickness - ! [g cm-1 s-2]. + . dpeps1 = 1.e-5_r8*P_mks2cgs, ! Small layer pressure thickness + ! [g cm-1 s-2]. + . dpeps2 = 1.e-7_r8*P_mks2cgs ! Small layer pressure thickness + ! [g cm-1 s-2]. c public :: bmcmth, pbcor1, pbcor2 c @@ -459,7 +459,7 @@ subroutine pbcor2(m,n,mm,nn,k1m,k1n) km=k+mm do l=1,isp(j) do i=max(0,ifp(j,l)),min(ii+1,ilp(j,l)) - dp(i,j,km)=max(0.,dp(i,j,km))+epsil + dp(i,j,km)=max(0.,dp(i,j,km))+epsilp p(i,j,k+1)=p(i,j,k)+dp(i,j,km) enddo enddo @@ -719,7 +719,7 @@ subroutine pbcor2(m,n,mm,nn,k1m,k1n) enddo #endif sigma(i,j,km)=sig(temp(i,j,km),saln(i,j,km)) - dp(i,j,km)=dp(i,j,km)-epsil + dp(i,j,km)=dp(i,j,km)-epsilp if (dp(i,j,km).lt.dpeps2) dp(i,j,km)=0. enddo enddo diff --git a/phy/mod_pgforc.F b/phy/mod_pgforc.F index 22eed8c6..7fdac606 100644 --- a/phy/mod_pgforc.F +++ b/phy/mod_pgforc.F @@ -25,7 +25,7 @@ module mod_pgforc c --- ------------------------------------------------------------------ c use mod_types, only: r8 - use mod_constants, only: g, epsil, spval + use mod_constants, only: g, epsilp, spval use mod_xc use mod_state, only: dp, dpu, dpv, temp, saln, p, pu, pv, phi, . pb_p, pbu_p, pbv_p, sealv @@ -140,9 +140,6 @@ subroutine pgforc(m,n,mm,nn,k1m,k1n) c --- ------------------------------------------------------------------ c --- compute the pressure gradient force c --- ------------------------------------------------------------------ -c - use mod_constants, only: g, epsil - use mod_xc c implicit none c @@ -206,7 +203,7 @@ subroutine pgforc(m,n,mm,nn,k1m,k1n) kn=k+nn do l=1,isp(j) do i=max(0,ifp(j,l)),min(ii,ilp(j,l)) - if (dp(i,j,kn).lt.epsil) then + if (dp(i,j,kn).lt.epsilp) then phi (i,j,k)=phi (i,j,k+1) phip(i,j,k)=phip(i,j,k+1) else diff --git a/phy/mod_remap.F b/phy/mod_remap.F index 44180dd1..10e19318 100644 --- a/phy/mod_remap.F +++ b/phy/mod_remap.F @@ -26,6 +26,7 @@ module mod_remap c use mod_types, only: r8 use mod_xc + use mod_constants, only: P_mks2cgs #ifdef TRC use mod_tracers, only: ntr, itrtke, itrgls #endif @@ -36,8 +37,8 @@ module mod_remap c c --- Parameters: real(r8), parameter :: - . dpeps = 1.e-11_r8 ! Small layer pressure thickness (equivalent - ! to approximately 10-16 m) [g cm-1 s-2]. + . dpeps = 1.e-12_r8*P_mks2cgs ! Small layer pressure thickness (equivalent + ! to approximately 10-16 m) [g cm-1 s-2]. #if defined(TRC) && defined(ATRC) real(r8), parameter :: . treps = 1.e-14_r8 ! Small tracer concentration. diff --git a/phy/mod_swabs.F b/phy/mod_swabs.F index 6b1b6b38..f8c57064 100644 --- a/phy/mod_swabs.F +++ b/phy/mod_swabs.F @@ -113,7 +113,7 @@ module mod_swabs . ma94z2=(/ 7.925,-6.644, 3.662,-1.815, -.218, .502/) c c --- Other parameters: -c---- swamxd: Maximum depth of shortwave radiation penetration. +c---- swamxd: Maximum depth of shortwave radiation penetration [m]. real, parameter :: . swamxd = 200. c diff --git a/phy/mod_tidaldissip.F90 b/phy/mod_tidaldissip.F90 index 2005289d..d3a61236 100644 --- a/phy/mod_tidaldissip.F90 +++ b/phy/mod_tidaldissip.F90 @@ -1,5 +1,5 @@ ! ------------------------------------------------------------------------------ -! Copyright (C) 2015-2020 Mats Bentsen +! Copyright (C) 2015-2020 Mats Bentsen, Mehmet Ilicak ! ! This file is part of BLOM. ! @@ -24,7 +24,7 @@ module mod_tidaldissip ! ------------------------------------------------------------------------------ use mod_types, only: r8 - use mod_constants, only: spval + use mod_constants, only: spval, M_mks2cgs use mod_xc use mod_checksum, only: csdiag, chksummsk use netcdf @@ -157,7 +157,7 @@ subroutine read_tidaldissip do j = 1, jj do l = 1, isp(j) do i = max(1, ifp(j, l)), min(ii, ilp(j, l)) - twedon(i, j) = twedon(i, j)*1.e3_r8 + twedon(i, j) = twedon(i, j)*M_mks2cgs enddo enddo enddo diff --git a/phy/mod_time.F90 b/phy/mod_time.F90 index 5e32c7d3..f4f0442b 100644 --- a/phy/mod_time.F90 +++ b/phy/mod_time.F90 @@ -1,5 +1,5 @@ ! ------------------------------------------------------------------------------ -! Copyright (C) 2020-2021 Mats Bentsen, Mehmet Ilicak, Aleksi Nummelin +! Copyright (C) 2020-2022 Mats Bentsen, Mehmet Ilicak, Aleksi Nummelin ! ! This file is part of BLOM. ! @@ -24,7 +24,7 @@ module mod_time use mod_types, only: r8 use mod_config, only: expcnf - use mod_constants, only: epsil + use mod_constants, only: epsilt use mod_calendar, only: date_type, daynum_diff, date_offset, & calendar_noerr, calendar_errstr use mod_xc, only: lp, mnproc, xcstop @@ -118,7 +118,7 @@ subroutine init_timevars ! Get number of baroclinic time steps per day and verify that an integer ! number of steps fits in a day. nstep_in_day = nint(86400._r8/baclin) - if (abs(86400._r8/baclin - nstep_in_day) > epsil) then + if (abs(86400._r8/baclin - nstep_in_day) > epsilt) then if (mnproc == 1) then write (lp, *) & 'init_timevars: '// & diff --git a/phy/mod_tke.F90 b/phy/mod_tke.F90 index fc5655ae..73dc2c95 100644 --- a/phy/mod_tke.F90 +++ b/phy/mod_tke.F90 @@ -1,5 +1,5 @@ ! ------------------------------------------------------------------------------ -! Copyright (C) 2013-2020 Mehmet Ilicak, Mats Bentsen +! Copyright (C) 2013-2022 Mehmet Ilicak, Mats Bentsen ! ! This file is part of BLOM. ! @@ -24,6 +24,7 @@ module mod_tke ! ------------------------------------------------------------------------------ use mod_types, only: r8 + use mod_constants, only: spval use mod_xc use mod_diffusion, only: difdia use mod_forcing, only: ustarb @@ -34,10 +35,8 @@ module mod_tke real(r8), parameter :: & gls_cmu0 = .527_r8, & ! cmu0 - Pr_t = 1._r8, & ! Turbulent Prandtl number []. - tke_min = 7.6e-4_r8, & ! Minimum TKE value [?]. + Pr_t = 1._r8, & ! Turbulent Prandtl number [non-dimensional]. zos = .0002_r8, & ! - gls_psi_min = 1.e-10_r8, & ! Minimum GLS value [?]. gls_p = 3._r8, & ! gls_m = 1.5_r8, & ! gls_n = -1._r8, & ! @@ -56,8 +55,19 @@ module mod_tke gls_Gh0 = .0329_r8, & ! gls_Ghmin = -.28_r8, & ! gls_Ghcri = .03_r8, & ! - vonKar = .4_r8, & ! - Ls_unlmt_min = 1.e-6_r8 ! + vonKar = .4_r8 ! + +#ifdef MKS + real(r8), parameter :: & + tke_min = 7.6e-8_r8, & ! Minimum TKE value [m2/s2]. + gls_psi_min = 1.e-14_r8, & ! Minimum GLS value [m2/s3]. + Ls_unlmt_min = 1.e-8_r8 ! [m] +#else + real(r8), parameter :: & + tke_min = 7.6e-4_r8, & ! Minimum TKE value [cm2/s2]. + gls_psi_min = 1.e-10_r8, & ! Minimum GLS value [cm2/s3]. + Ls_unlmt_min = 1.e-6_r8 ! [cm] +#endif real(r8), dimension(1 - nbdy:idm + nbdy, 1 - nbdy:jdm + nbdy, kdm) :: & Prod, & ! Shear production [?]. @@ -93,6 +103,18 @@ subroutine initke ! Initialize fields holding turbulent kinetic energy, generic length ! scale, and other fields used in the turbulence closure. + !$omp parallel do private(i, k) + do j = 1 - nbdy, jj + nbdy + do i = 1 - nbdy, ii + nbdy + do k = 1, kk + Prod(i ,j ,k) = spval + Buoy(i ,j ,k) = spval + Shear2(i ,j ,k) = spval + L_scale(i ,j ,k) = spval + enddo + enddo + enddo + !$omp end parallel do !$omp parallel do private(k, l, i) do j = 1 - nbdy, jj + nbdy do k = 1, 2*kdm diff --git a/phy/mod_tmsmt.F b/phy/mod_tmsmt.F index 5aec8d56..cf7ef21a 100644 --- a/phy/mod_tmsmt.F +++ b/phy/mod_tmsmt.F @@ -1,5 +1,5 @@ ! ------------------------------------------------------------------------------ -! Copyright (C) 2005-2022 Mats Bentsen +! Copyright (C) 2005-2022 Mats Bentsen, Mehmet Ilicak ! ! This file is part of BLOM. ! @@ -27,7 +27,7 @@ module mod_tmsmt c --- ------------------------------------------------------------------ c use mod_types, only: r8 - use mod_constants, only: epsil, spval + use mod_constants, only: epsilp, spval use mod_xc use mod_vcoord, only: vcoord_type_tag, isopyc_bulkml use mod_state, only: dp, dpu, dpv, temp, saln, p, pb @@ -265,7 +265,7 @@ subroutine tmsmt2(m,n,mm,nn,k1m,k1n) c c --- time smoothing of layer thickness, temperature and salinity c - use mod_constants, only: epsil + use mod_constants, only: epsilp use mod_xc c implicit none @@ -318,23 +318,23 @@ subroutine tmsmt2(m,n,mm,nn,k1m,k1n) pnew=max(0.,dp(i,j,kn)*pbfacn(i)) dp(i,j,km)=wts1*pmid+wts2*(pold+pnew) dpold(i,j,km)=dp(i,j,km) - pold=pold+epsil - pmid=pmid+epsil - pnew=pnew+epsil + pold=pold+epsilp + pmid=pmid+epsilp + pnew=pnew+epsilp temp(i,j,km)=(wts1*pmid*temp(i,j,km) . +wts2*(pold*told(i,j,k)+pnew*temp(i,j,kn))) - . /(dp(i,j,km)+epsil) + . /(dp(i,j,km)+epsilp) told(i,j,k)=temp(i,j,km) saln(i,j,km)=(wts1*pmid*saln(i,j,km) . +wts2*(pold*sold(i,j,k)+pnew*saln(i,j,kn))) - . /(dp(i,j,km)+epsil) + . /(dp(i,j,km)+epsilp) sold(i,j,k)=saln(i,j,km) #ifdef TRC do nt=1,ntr trc(i,j,km,nt)=(wts1*pmid*trc(i,j,km,nt) . +wts2*(pold*trcold(i,j,k,nt) . +pnew*trc(i,j,kn,nt))) - . /(dp(i,j,km)+epsil) + . /(dp(i,j,km)+epsilp) trcold(i,j,k,nt)=trc(i,j,km,nt) enddo #endif diff --git a/phy/mod_vcoord.F90 b/phy/mod_vcoord.F90 index 849380b9..f63e6cbd 100644 --- a/phy/mod_vcoord.F90 +++ b/phy/mod_vcoord.F90 @@ -1,5 +1,5 @@ ! ------------------------------------------------------------------------------ -! Copyright (C) 2021-2022 Mats Bentsen +! Copyright (C) 2021-2022 Mats Bentsen, Mehmet Ilicak ! ! This file is part of BLOM. ! @@ -25,7 +25,7 @@ module mod_vcoord use mod_types, only: r8 use mod_config, only: inst_suffix - use mod_constants, only: g, epsil, spval, onem + use mod_constants, only: g, epsilp, spval, onem use mod_xc use mod_eos, only: sig, dsigdt, dsigds use mod_state, only: u, v, dp, dpu, dpv, temp, saln, sigma, p, pu, pv @@ -296,7 +296,7 @@ subroutine cntiso_regrid_direct_jslice(p_src, p_dst, i_lb, i_ub, j, j_rs, nn) kl = kk ku = kl - 1 do while (ku > 0) - thin_layers = p_src(kl+1,i) - p_src(ku,i) < epsil + 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 @@ -311,7 +311,7 @@ subroutine cntiso_regrid_direct_jslice(p_src, p_dst, i_lb, i_ub, j, j_rs, nn) 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) < epsil + 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. @@ -331,7 +331,7 @@ subroutine cntiso_regrid_direct_jslice(p_src, p_dst, i_lb, i_ub, j, j_rs, nn) 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) < epsil + 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. diff --git a/phy/mod_vdiff.F90 b/phy/mod_vdiff.F90 index 3d1798fd..61778a72 100644 --- a/phy/mod_vdiff.F90 +++ b/phy/mod_vdiff.F90 @@ -1,5 +1,5 @@ ! ------------------------------------------------------------------------------ -! Copyright (C) 2021-2022 Mats Bentsen +! Copyright (C) 2021-2022 Mats Bentsen, Mehmet Ilicak ! ! This file is part of BLOM. ! @@ -23,7 +23,7 @@ module mod_vdiff ! ------------------------------------------------------------------------------ use mod_types, only: r8 - use mod_constants, only: g, spcifh, alpha0 + use mod_constants, only: g, spcifh, alpha0, onem use mod_time, only: delt1 use mod_xc use mod_eos, only: sig @@ -40,7 +40,7 @@ module mod_vdiff private real(r8), parameter :: & - dpmin_vdiff = 0.1_r8*98060._r8 + dpmin_vdiff = 0.1_r8*onem public :: cntiso_hybrid_vdifft, cntiso_hybrid_vdiffm diff --git a/phy/numerical_bounds.F90 b/phy/numerical_bounds.F90 index f4579056..a38c5b55 100644 --- a/phy/numerical_bounds.F90 +++ b/phy/numerical_bounds.F90 @@ -1,5 +1,5 @@ ! ------------------------------------------------------------------------------ -! Copyright (C) 2020 Mats Bentsen +! Copyright (C) 2020-2022 Mats Bentsen, Mehmet Ilicak ! ! This file is part of BLOM. ! @@ -23,7 +23,7 @@ subroutine numerical_bounds ! --------------------------------------------------------------------------- use mod_types, only: r8 - use mod_constants, only: g, spval + use mod_constants, only: g, spval, L_mks2cgs use mod_time, only: baclin use mod_xc use mod_grid, only: scqx, scqy, scpx, scpy, scuy, scvx, scp2, depths @@ -61,8 +61,8 @@ subroutine numerical_bounds do i = max(1, ifp(j, l)), min(ii, ilp(j, l)) btdtmx = min(btdtmx, & scpx(i, j)*scpy(i, j) & - /sqrt(g*depths(i, j)*100._r8*( scpx(i, j)*scpx(i, j) & - + scpy(i, j)*scpy(i, j)))) + /sqrt(g*depths(i, j)*L_mks2cgs*( scpx(i, j)*scpx(i, j) & + + scpy(i, j)*scpy(i, j)))) enddo enddo enddo diff --git a/phy/rdlim.F b/phy/rdlim.F index 44949352..f4d00f76 100644 --- a/phy/rdlim.F +++ b/phy/rdlim.F @@ -1,5 +1,5 @@ ! ------------------------------------------------------------------------------ -! Copyright (C) 2008-2021 Mats Bentsen, Mehmet Ilicak, Ingo Bethke, +! Copyright (C) 2008-2022 Mats Bentsen, Mehmet Ilicak, Ingo Bethke, ! Ping-Gin Chiu, Aleksi Nummelin ! ! This file is part of BLOM. @@ -25,6 +25,7 @@ subroutine rdlim c --- ------------------------------------------------------------------ c use mod_config, only: expcnf, runid, inst_suffix + use mod_constants, only: epsilt use mod_calendar, only: date_type, daynum_diff, calendar_errstr, . calendar_noerr, operator(==), operator(<), . operator(/=) @@ -732,7 +733,7 @@ subroutine rdlim c c --- - verify integer number of baroclinic time steps per coupling c --- - interval - if (mod(ocn_cpl_dt_cesm+epsil,baclin).gt.2.*epsil) then + if (mod(ocn_cpl_dt_cesm+epsilt,baclin).gt.2.*epsilt) then if (mnproc.eq.1) then write (lp,*) 'rdlim: must have an integer number of '// . 'baroclinic time steps in a coupling' diff --git a/single_column/mod_single_column.F90 b/single_column/mod_single_column.F90 index 58eb6826..6017c0d9 100644 --- a/single_column/mod_single_column.F90 +++ b/single_column/mod_single_column.F90 @@ -1,5 +1,5 @@ ! ------------------------------------------------------------------------------ -! Copyright (C) 2021 Mehmet Ilicak, Mats Bentsen +! Copyright (C) 2021-2022 Mehmet Ilicak, Mats Bentsen ! ! This file is part of BLOM. ! @@ -24,6 +24,7 @@ module mod_single_column ! ---------------------------------------------------------------------- use mod_types, only: r8 + use mod_constants, only: L_mks2cgs use mod_xc use mod_vcoord, only: sigmar use mod_grid, only: qclon, qclat, pclon, pclat, uclon, uclat, vclon, vclat, & @@ -64,13 +65,13 @@ subroutine geoenv_single_column uclat = 0._r8 vclon = 0._r8 vclat = 0._r8 - scqx = 1100000.0_r8 - scqy = 1100000.0_r8 - scpx = 1100000.0_r8 - scpy = 1100000.0_r8 - scux = 1100000.0_r8 - scuy = 1100000.0_r8 - scvx = 1100000.0_r8 + scqx = 11000.0_r8*L_mks2cgs + scqy = 11000.0_r8*L_mks2cgs + scpx = 11000.0_r8*L_mks2cgs + scpy = 11000.0_r8*L_mks2cgs + scux = 11000.0_r8*L_mks2cgs + scuy = 11000.0_r8*L_mks2cgs + scvx = 11000.0_r8*L_mks2cgs scvy = scuy scq2 = scqx*scqy scp2 = scpx*scpy From 78115e3dc62eeb576c712bb9fad7db7e97578965 Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Mon, 13 Feb 2023 11:38:32 +0100 Subject: [PATCH 263/366] fix prho unit-issue --- hamocc/mo_m4ago.F90 | 32 ++++++++++++++++---------------- 1 file changed, 16 insertions(+), 16 deletions(-) diff --git a/hamocc/mo_m4ago.F90 b/hamocc/mo_m4ago.F90 index 0c9e0f85..b8156c4e 100644 --- a/hamocc/mo_m4ago.F90 +++ b/hamocc/mo_m4ago.F90 @@ -334,16 +334,16 @@ SUBROUTINE calc_pressure(kpie, kpje, kpke,kbnd, pddpo,omask, ppao, prho) REAL, INTENT(in) :: pddpo(kpie,kpje,kpke) !< size of scalar grid cell (3rd dimension) [m] REAL, INTENT(in) :: omask(kpie,kpje) REAL, INTENT(in) :: ppao (1-kbnd:kpie+kbnd,1-kbnd:kpje+kbnd) !< pressure at sea level [Pa]. - REAL, INTENT(in) :: prho (kpie,kpje,kpke) !< salinity [psu.]. + REAL, INTENT(in) :: prho (kpie,kpje,kpke) !< density [g/cm3] !$OMP PARALLEL DO PRIVATE(i,j,k) do j = 1,kpje do i = 1,kpie if(omask(i,j) > 0.5) then - m4ago_ppo(i,j,1) = ppao(i,j) + prho(i,j,1)*grav_acc_const*pddpo(i,j,1) + m4ago_ppo(i,j,1) = ppao(i,j) + 1000.0*prho(i,j,1)*grav_acc_const*pddpo(i,j,1) do k = 2,kpke if(pddpo(i,j,k) > dp_min) then - m4ago_ppo(i,j,k) = m4ago_ppo(i,j,k-1) + prho(i,j,k)*grav_acc_const*pddpo(i,j,k) + m4ago_ppo(i,j,k) = m4ago_ppo(i,j,k-1) + 1000.0*prho(i,j,k)*grav_acc_const*pddpo(i,j,k) endif enddo endif @@ -371,7 +371,7 @@ SUBROUTINE mean_aggregate_sinking_speed(kpie, kpje, kpke, kbnd, pddpo, omask, pt REAL, INTENT(in) :: ptho (1-kbnd:kpie+kbnd,1-kbnd:kpje+kbnd,kpke) !< potential temperature [deg C] REAL, INTENT(in) :: psao (1-kbnd:kpie+kbnd,1-kbnd:kpje+kbnd,kpke) !< salinity [psu.]. REAL, INTENT(in) :: ppao (1-kbnd:kpie+kbnd,1-kbnd:kpje+kbnd) !< pressure at sea level [Pa]. - REAL, INTENT(in) :: prho (kpie,kpje,kpke) !< salinity [psu.]. + REAL, INTENT(in) :: prho (kpie,kpje,kpke) !< density [g/cm3] CALL calc_pressure(kpie, kpje, kpke,kbnd, pddpo, omask, ppao, prho) @@ -701,14 +701,14 @@ REAL FUNCTION get_ws_agg_integral(i, j, k, AJ, BJ, lower_bound, upper_bound) REAL :: nu_vis nu_vis = dyn_vis(i,j,k)/rho_aq - get_ws_agg_integral = (4./3.*(av_rho_p(i,j,k) - rho_aq)/rho_aq & - & *av_dp(i,j,k)**(3. - df_agg(i,j,k))*grav_acc_const & - & /(AJ*nu_vis**BJ))**(1./(2. - BJ)) & - & *(upper_bound**(1. - b_agg(i,j,k) + df_agg(i,j,k) & - & + (BJ + df_agg(i,j,k) - 2.)/(2. - BJ)) & - & /(1. - b_agg(i,j,k) + df_agg(i,j,k) + (BJ + df_agg(i,j,k) - 2.)/(2. - BJ)) & + get_ws_agg_integral = (4./3.*(av_rho_p(i,j,k) - rho_aq)/rho_aq & + & *av_dp(i,j,k)**(3. - df_agg(i,j,k))*grav_acc_const & + & /(AJ*nu_vis**BJ))**(1./(2. - BJ)) & + & *(upper_bound**(1. - b_agg(i,j,k) + df_agg(i,j,k) & + & + (BJ + df_agg(i,j,k) - 2.)/(2. - BJ)) & + & /(1. - b_agg(i,j,k) + df_agg(i,j,k) + (BJ + df_agg(i,j,k) - 2.)/(2. - BJ)) & & - lower_bound**(1. - b_agg(i,j,k) + df_agg(i,j,k) + (BJ + df_agg(i,j,k) - 2.) & - & /(2. - BJ)) & + & /(2. - BJ)) & & /(1. - b_agg(i,j,k) + df_agg(i,j,k) + (BJ + df_agg(i,j,k) - 2.)/(2. - BJ))) END FUNCTION get_ws_agg_integral @@ -821,7 +821,7 @@ REAL FUNCTION max_agg_diam_white(i,j,k) nu_vis = dyn_vis(i,j,k)/rho_aq max_agg_diam_white = (agg_Re_crit*nu_vis)**((2. - BJ3)/df_agg(i,j,k)) & - & /((4./3.)*(av_rho_p(i,j,k) - rho_aq)/rho_aq & + & /((4./3.)*(av_rho_p(i,j,k) - rho_aq)/rho_aq & & *av_dp(i,j,k)**(3. - df_agg(i,j,k))*grav_acc_const & & /(AJ3*nu_vis**BJ3))**(1./df_agg(i,j,k)) @@ -913,13 +913,13 @@ SUBROUTINE dynvis(kpie, kpje, kpke, kbnd, pddpo, omask, ptho, psao, ppo) ! molecular dynamic viscosity dyn_vis(i,j,k) = 0.1 & ! Unit: g / (cm*s) -> kg / (m*s) - & *(1.79e-2 & + & *(1.79e-2 & & - 6.1299e-4*ptho_val + 1.4467e-5*ptho_val**2. & - & - 1.6826e-7*ptho_val**3. & + & - 1.6826e-7*ptho_val**3. & & - 1.8266e-7*press_val + 9.8972e-12*press_val**2. & - & + 2.4727e-5*psao_val & + & + 2.4727e-5*psao_val & & + psao_val*(4.8429e-7*ptho_val - 4.7172e-8*ptho_val**2. & - & + 7.5986e-10*ptho_val**3.) & + & + 7.5986e-10*ptho_val**3.) & & + press_val*(1.3817e-8*ptho_val - 2.6363e-10*ptho_val**2.) & & - press_val**2.*(6.3255e-13*ptho_val - 1.2116e-14*ptho_val**2.)) END IF From c22ca7e34f6f5bd90966dd9c599ec986748c5817 Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Mon, 13 Feb 2023 12:10:01 +0100 Subject: [PATCH 264/366] change initial N2O concentration to lower value to avoid too long equilibration time with atmosphere for shorter tuning runs --- hamocc/beleg_vars.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/hamocc/beleg_vars.F90 b/hamocc/beleg_vars.F90 index 423f7e8f..07558548 100644 --- a/hamocc/beleg_vars.F90 +++ b/hamocc/beleg_vars.F90 @@ -218,7 +218,7 @@ SUBROUTINE BELEG_VARS(kpaufr,kpie,kpje,kpke,kbnd,pddpo,prho,omask, & #ifdef extNcycle ocetra(i,j,k,iano2) =1.e-9 ! expecting fast cycling ocetra(i,j,k,ianh4) =0.5e-9 ! expecting fast cycling - ocetra(i,j,k,ian2o) =20.e-9 ! 20nmol/kg = ca. value deep ocean Toyoda et al. 2019 + ocetra(i,j,k,ian2o) =6.e-9 ! 6 to 8 nmol/kg = ca. value in near surface regions Toyoda et al. 2019, prevent from too long outgassing #endif ENDIF ! omask > 0.5 From 40aa90b34be257ace2ea30fe80e7911bb115b0f7 Mon Sep 17 00:00:00 2001 From: jmaerz <92309038+jmaerz@users.noreply.github.com> Date: Tue, 14 Feb 2023 16:20:56 +0100 Subject: [PATCH 265/366] Hamocc fix restart file units (#239) * fixes for restart units as suggested * fix restart units for sediment restart file * fix indention of line & --- hamocc/aufw_bgc.F90 | 20 ++++++++++---------- 1 file changed, 10 insertions(+), 10 deletions(-) diff --git a/hamocc/aufw_bgc.F90 b/hamocc/aufw_bgc.F90 index 91af9f3e..b89bedeb 100644 --- a/hamocc/aufw_bgc.F90 +++ b/hamocc/aufw_bgc.F90 @@ -603,7 +603,7 @@ SUBROUTINE AUFW_BGC(kpie,kpje,kpke,ntr,ntrbgc,itrbgc,trc, & & rmissing,62,io_stdo_bgc) CALL NETCDF_DEF_VARDB(ncid,6,'satoxy',3,ncdimst,ncvarid, & - & 9,'xxxxxxxxx',9 ,'xxxxxxxxx', & + & 9,'mol/kg',9 ,'Saturated oxygen', & & rmissing,63,io_stdo_bgc) #ifdef natDIC @@ -626,19 +626,19 @@ SUBROUTINE AUFW_BGC(kpie,kpje,kpke,ntr,ntrbgc,itrbgc,trc, & ENDIF CALL NETCDF_DEF_VARDB(ncid,6,'ssso12',3,ncdimst,ncvarid, & - & 9,'kmol/m**2',35,'Sediment accumulated organic carbon', & + & 9,'kmol/m**3',35,'Sediment accumulated organic carbon', & & rmissing,70,io_stdo_bgc) CALL NETCDF_DEF_VARDB(ncid,6,'sssc12',3,ncdimst,ncvarid, & - & 9,'kmol/m**2',38,'Sediment accumulated calcium carbonate', & + & 9,'kmol/m**3',38,'Sediment accumulated calcium carbonate', & & rmissing,71,io_stdo_bgc) CALL NETCDF_DEF_VARDB(ncid,6,'ssssil',3,ncdimst,ncvarid, & - & 9,'kmol/m**2',25,'Sediment accumulated opal', & + & 9,'kmol/m**3',25,'Sediment accumulated opal', & & rmissing,72,io_stdo_bgc) CALL NETCDF_DEF_VARDB(ncid,6,'ssster',3,ncdimst,ncvarid, & - & 9,'kmol/m**2',25,'Sediment accumulated clay', & + & 9,'kg/m**3',25,'Sediment accumulated clay', & & rmissing,73,io_stdo_bgc) CALL NETCDF_DEF_VARDB(ncid,6,'powaic',3,ncdimst,ncvarid, & @@ -671,19 +671,19 @@ SUBROUTINE AUFW_BGC(kpie,kpje,kpke,ntr,ntrbgc,itrbgc,trc, & #ifdef cisonew CALL NETCDF_DEF_VARDB(ncid,6,'ssso13',3,ncdimst,ncvarid, & - & 9,'kmol/m**2',37,'Sediment accumulated organic carbon13', & + & 9,'kmol/m**3',37,'Sediment accumulated organic carbon13', & & rmasks,81,io_stdo_bgc) CALL NETCDF_DEF_VARDB(ncid,6,'ssso14',3,ncdimst,ncvarid, & - & 9,'kmol/m**2',37,'Sediment accumulated organic carbon14', & + & 9,'kmol/m**3',37,'Sediment accumulated organic carbon14', & & rmasks,82,io_stdo_bgc) CALL NETCDF_DEF_VARDB(ncid,6,'sssc13',3,ncdimst,ncvarid, & - & 9,'kmol/m**2',40,'Sediment accumulated calcium carbonate13', & + & 9,'kmol/m**3',40,'Sediment accumulated calcium carbonate13', & & rmasks,83,io_stdo_bgc) CALL NETCDF_DEF_VARDB(ncid,6,'sssc14',3,ncdimst,ncvarid, & - & 9,'kmol/m**2',40,'Sediment accumulated calcium carbonate14', & + & 9,'kmol/m**3',40,'Sediment accumulated calcium carbonate14', & & rmasks,84,io_stdo_bgc) CALL NETCDF_DEF_VARDB(ncid,6,'powc13',3,ncdimst,ncvarid, & @@ -730,7 +730,7 @@ SUBROUTINE AUFW_BGC(kpie,kpje,kpke,ntr,ntrbgc,itrbgc,trc, & & rmissing,92,io_stdo_bgc) CALL NETCDF_DEF_VARDB(ncid,8,'bur_clay',3,ncdimst,ncvarid, & - & 9,'kmol/m**2',20,'Burial layer of clay', & + & 9,'kg/m**2',20,'Burial layer of clay', & & rmissing,93,io_stdo_bgc) #endif /* sedbypass */ From c6b5bf3b782b052ecdb80e783eaf848b2de09ccc Mon Sep 17 00:00:00 2001 From: jmaerz <92309038+jmaerz@users.noreply.github.com> Date: Wed, 15 Feb 2023 20:14:37 +0100 Subject: [PATCH 266/366] fix string count number (#242) String counter adjusted to fit changed restart file units in #239. --- hamocc/aufw_bgc.F90 | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/hamocc/aufw_bgc.F90 b/hamocc/aufw_bgc.F90 index b89bedeb..90949313 100644 --- a/hamocc/aufw_bgc.F90 +++ b/hamocc/aufw_bgc.F90 @@ -603,7 +603,7 @@ SUBROUTINE AUFW_BGC(kpie,kpje,kpke,ntr,ntrbgc,itrbgc,trc, & & rmissing,62,io_stdo_bgc) CALL NETCDF_DEF_VARDB(ncid,6,'satoxy',3,ncdimst,ncvarid, & - & 9,'mol/kg',9 ,'Saturated oxygen', & + & 6,'mol/kg',16 ,'Saturated oxygen', & & rmissing,63,io_stdo_bgc) #ifdef natDIC @@ -638,7 +638,7 @@ SUBROUTINE AUFW_BGC(kpie,kpje,kpke,ntr,ntrbgc,itrbgc,trc, & & rmissing,72,io_stdo_bgc) CALL NETCDF_DEF_VARDB(ncid,6,'ssster',3,ncdimst,ncvarid, & - & 9,'kg/m**3',25,'Sediment accumulated clay', & + & 7,'kg/m**3',25,'Sediment accumulated clay', & & rmissing,73,io_stdo_bgc) CALL NETCDF_DEF_VARDB(ncid,6,'powaic',3,ncdimst,ncvarid, & @@ -730,7 +730,7 @@ SUBROUTINE AUFW_BGC(kpie,kpje,kpke,ntr,ntrbgc,itrbgc,trc, & & rmissing,92,io_stdo_bgc) CALL NETCDF_DEF_VARDB(ncid,8,'bur_clay',3,ncdimst,ncvarid, & - & 9,'kg/m**2',20,'Burial layer of clay', & + & 7,'kg/m**2',20,'Burial layer of clay', & & rmissing,93,io_stdo_bgc) #endif /* sedbypass */ From 3e8500d782cd4011083aac7a0321da99559f1bc1 Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Tue, 28 Feb 2023 17:15:52 +0100 Subject: [PATCH 267/366] fix sediment restart writing for extNcycle pore water tracers --- hamocc/aufw_bgc.F90 | 18 +++++++++++++++++- 1 file changed, 17 insertions(+), 1 deletion(-) diff --git a/hamocc/aufw_bgc.F90 b/hamocc/aufw_bgc.F90 index f04b7bf0..57741fd6 100644 --- a/hamocc/aufw_bgc.F90 +++ b/hamocc/aufw_bgc.F90 @@ -129,7 +129,7 @@ SUBROUTINE AUFW_BGC(kpie,kpje,kpke,ntr,ntrbgc,itrbgc,trc, & use mo_param1_bgc, only: ipowaal,ipowaic,ipowaox,ipowaph,ipowasi,ipown2,ipowno3,isssc12,issso12,issssil,issster #endif #ifdef extNcycle - use mo_param1_bgc, only: ianh4,iano2 + use mo_param1_bgc, only: ianh4,iano2,ipownh4,ipown2o,ipowno2 #endif @@ -705,6 +705,17 @@ SUBROUTINE AUFW_BGC(kpie,kpje,kpke,ntr,ntrbgc,itrbgc,trc, & & 9,'kmol/m**3',25,'Sediment pore water DIC14', & & rmasks,86,io_stdo_bgc) #endif +#ifdef extNcycle + CALL NETCDF_DEF_VARDB(ncid,6,'pownh4',3,ncdimst,ncvarid, & + & 9,'kmol/m**3',34,'Sediment pore water ammonium (NH4)', & + & rmissing,79,io_stdo_bgc) + CALL NETCDF_DEF_VARDB(ncid,6,'pown2o',3,ncdimst,ncvarid, & + & 9,'kmol/m**3',39,'Sediment pore water nitrous oxide (N2O)', & + & rmissing,79,io_stdo_bgc) + CALL NETCDF_DEF_VARDB(ncid,6,'powno2',3,ncdimst,ncvarid, & + & 9,'kmol/m**3',33,'Sediment pore water nitrite (NO2)', & + & rmissing,79,io_stdo_bgc) +#endif IF((mnproc==1 .AND. IOTYPE==0) .OR. IOTYPE==1) THEN ncdimst(1) = nclonid @@ -915,6 +926,11 @@ SUBROUTINE AUFW_BGC(kpie,kpje,kpke,ntr,ntrbgc,itrbgc,trc, & CALL write_netcdf_var(ncid,'powc13',powtra2(1,1,1,ipowc13),2*ks,0) CALL write_netcdf_var(ncid,'powc14',powtra2(1,1,1,ipowc14),2*ks,0) #endif +#ifdef extNcycle + CALL write_netcdf_var(ncid,'pownh4',powtra2(1,1,1,ipownh4),2*ks,0) + CALL write_netcdf_var(ncid,'pown2o',powtra2(1,1,1,ipown2o),2*ks,0) + CALL write_netcdf_var(ncid,'powno2',powtra2(1,1,1,ipowno2),2*ks,0) +#endif #endif ! ! Write restart data: atmosphere. From 52ac3a57be46fd2b1b57bf36153870c0a09db0f0 Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Tue, 28 Feb 2023 17:56:46 +0100 Subject: [PATCH 268/366] fix sediment restart reading for extNcycle pore water tracers --- hamocc/aufr_bgc.F90 | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/hamocc/aufr_bgc.F90 b/hamocc/aufr_bgc.F90 index 6a342c01..b9e5f410 100644 --- a/hamocc/aufr_bgc.F90 +++ b/hamocc/aufr_bgc.F90 @@ -138,7 +138,7 @@ SUBROUTINE AUFR_BGC(kpie,kpje,kpke,ntr,ntrbgc,itrbgc,trc, & use mo_param1_bgc, only: ipowaal,ipowaic,ipowaox,ipowaph,ipowasi,ipown2,ipowno3,isssc12,issso12,issssil,issster,ks #endif #ifdef extNcycle - use mo_param1_bgc, only: ianh4,iano2 + use mo_param1_bgc, only: ianh4,iano2,ipownh4,ipown2o,ipowno2 #endif @@ -520,6 +520,11 @@ SUBROUTINE AUFR_BGC(kpie,kpje,kpke,ntr,ntrbgc,itrbgc,trc, & CALL read_netcdf_var(ncid,'powc14',powtra2(1,1,1,ipowc14),2*ks,0,iotype) ENDIF #endif +#ifdef extNcycle + CALL read_netcdf_var(ncid,'pownh4',powtra2(1,1,1,ipownh4),2*ks,0,iotype) + CALL read_netcdf_var(ncid,'pown2o',powtra2(1,1,1,ipown2o),2*ks,0,iotype) + CALL read_netcdf_var(ncid,'powno2',powtra2(1,1,1,ipowno2),2*ks,0,iotype) +#endif #endif ! From 3c546c611fe5ab3c854bbc1aab2cb29b6f0eeeb0 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Timoth=C3=A9e=20Bourgeois?= Date: Mon, 6 Mar 2023 07:41:13 +0100 Subject: [PATCH 269/366] add ability to read input file for ocean alkalinization (#241) add ability to read an ocean alkalinization scenario from file and put ocean alkalinisation related variables in own namelist (BGCOAFX) --- cime_config/buildnml | 6 +- hamocc/hamocc_init.F90 | 4 +- hamocc/mo_read_oafx.F90 | 170 +++++++++++++++++++++++++++------------- 3 files changed, 121 insertions(+), 59 deletions(-) diff --git a/cime_config/buildnml b/cime_config/buildnml index 744a8f1e..a824d7f2 100755 --- a/cime_config/buildnml +++ b/cime_config/buildnml @@ -267,7 +267,7 @@ if ($HAMOCC_VSLS == TRUE && $OCN_GRID != tnx1v4) then endif # For the following options, there are currently no switches in Case-XML files. # These options can be activated by expert users via user namelist. -set BGCOAFX_DO_OALK = .false. +set DO_OALK = .false. set BGCOAFX_OALKSCEN = "''" set BGCOAFX_OALKFILE = "''" set BGCOAFX_ADDALK = 0.135 @@ -1601,6 +1601,7 @@ cat >>! $RUNDIR/ocn_in$inststr << EOF RIVINFILE = $RIVINFILE DO_NDEP = $DO_NDEP NDEPFILE = $NDEPFILE + DO_OALK = $DO_OALK DO_SEDSPINUP = $DO_SEDSPINUP SEDSPIN_YR_S = $SEDSPIN_YR_S SEDSPIN_YR_E = $SEDSPIN_YR_E @@ -1623,6 +1624,8 @@ cat >>! $RUNDIR/ocn_in$inststr << EOF ! ! CONTENTS: ! +! OALKSCEN : Name of alkalinization scenario. +! OALKFILE : Full path of the input file for the alkalinization scenario 'file'. ! ADDALK : Pmol alkalinity/yr added in the scenarios. ! CDRMIP_LATMAX : Max latitude where alkalinity is added according to the ! CDRMIP protocol @@ -1631,7 +1634,6 @@ cat >>! $RUNDIR/ocn_in$inststr << EOF ! RAMP_START : Start year for ramp up in 'ramp' scenario ! RAMP_END : End year for 'ramp' scenario &BGCOAFX - DO_OALK = $BGCOAFX_DO_OALK OALKSCEN = $BGCOAFX_OALKSCEN OALKFILE = $BGCOAFX_OALKFILE ADDALK = $BGCOAFX_ADDALK diff --git a/hamocc/hamocc_init.F90 b/hamocc/hamocc_init.F90 index 72e05a36..110563c0 100644 --- a/hamocc/hamocc_init.F90 +++ b/hamocc/hamocc_init.F90 @@ -56,7 +56,7 @@ subroutine hamocc_init(read_rest,rstfnm_hamocc) use mo_read_rivin, only: ini_read_rivin,rivinfile use mo_read_fedep, only: ini_read_fedep,fedepfile use mo_read_ndep, only: ini_read_ndep,ndepfile - use mo_read_oafx, only: ini_read_oafx,oalkfile,oalkscen + use mo_read_oafx, only: ini_read_oafx use mo_read_pi_ph, only: ini_pi_ph,pi_ph_file use mo_read_sedpor, only: read_sedpor,sedporfile use mo_clim_swa, only: ini_swa_clim,swaclimfile @@ -80,7 +80,7 @@ subroutine hamocc_init(read_rest,rstfnm_hamocc) real :: sed_por(idm,jdm,ks) = 0. namelist /bgcnml/ atm_co2,fedepfile,do_rivinpt,rivinfile,do_ndep,ndepfile, & - & do_oalk,oalkscen,oalkfile,do_sedspinup,sedspin_yr_s, & + & do_oalk,do_sedspinup,sedspin_yr_s, & & sedspin_yr_e,sedspin_ncyc, & & inidic,inialk,inipo4,inioxy,inino3,inisil, & & inid13c,inid14c,swaclimfile, & diff --git a/hamocc/mo_read_oafx.F90 b/hamocc/mo_read_oafx.F90 index 8bfa2d28..99c2385b 100644 --- a/hamocc/mo_read_oafx.F90 +++ b/hamocc/mo_read_oafx.F90 @@ -23,6 +23,12 @@ module mo_read_oafx ! ! Modified ! -------- +! T. Bourgeois, *NORCE climate, Bergen* 2023-01-31 +! - add ramping-up scenario +! - add ability to define parameters from BLOM namelist +! +! T. Bourgeois, *NORCE climate, Bergen* 2023-02-09 +! - add ability to use an OA input file ! ! Purpose ! ------- @@ -31,28 +37,31 @@ module mo_read_oafx ! ! Description: ! ------------ -! The routine get_oafx reads a fluxs of alkalinity from file (or, for simple +! The routine get_oafx reads a flux of alkalinity from file (or, for simple ! cases, constructs an alkalinity flux field from scratch). The alkalinity ! flux is then passed to hamocc4bcm where it is applied to the top-most model ! layer by a call to apply_oafx (mo_apply_oafx). ! -! Ocean alkalinization is activated through a logical switch 'do_oalk' read from -! HAMOCC's bgcnml namelist. If ocean alkalinization is acitvated, a valid -! name of an alkalinisation scenario (defined in this module, see below) and -! the file name (including the full path) of the corresponding OA-scenario -! input file needs to be provided via HAMOCC's bgcnml namelist (variables -! oascenario and oafxfile). If the input file is not found, an error will be -! issued. The input data must be already pre-interpolated to the ocean grid. +! Ocean alkalinization is activated through a logical switch 'do_oalk' read +! from HAMOCC's bgcnml namelist. If ocean alkalinization is activated, a valid +! name of an alkalinisation scenario (defined in this module, see below) needs +! to be provided via HAMOCC's bgcnml namelist (variable oalkscen). For the +! 'file' scenario, the file name (including the full path) of the +! corresponding OA-scenario input file needs to be provided (variable +! oalkfile). If the input file is not found, an error will be issued. The +! input data must be already pre-interpolated to the ocean grid. ! ! Currently available ocean alkalinisation scenarios: -! (no input file needed, flux and latitude range can be defined in the -! namelist, default values are defined): -! -'const': constant alkalinity flux applied to the surface ocean -! between two latitudes. +! (for 'const' and 'ramp' scenarios, flux and latitude range can be defined in +! the namelist, default values are defined): +! -'const': constant alkalinity flux applied to the surface ocean +! between two latitudes. No input file needed. ! -'ramp': ramping-up alkalinity flux from 0 Pmol yr-1 to a maximum ! value between two specified years and kept constant ! onward, applied to the surface ocean between two -! latitudes. +! latitudes. No input file needed. +! -'file': Read monthly 2D field in kmol ALK m-2 yr-1 from a file +! defined with the variable oalkfile. ! ! -subroutine ini_read_oafx ! Initialise the module @@ -66,15 +75,16 @@ module mo_read_oafx private public :: ini_read_oafx,get_oafx,oalkscen,oalkfile - - real,allocatable, save :: oalkflx(:,:) - + character(len=128), save :: oalkscen ='' character(len=512), save :: oalkfile ='' + real,allocatable, save :: oalkflx(:,:) + integer, save :: startyear,endyear + real, parameter :: Pmol2kmol = 1.0e12 - ! Parameter used in the definition of alkalinization scenarios. The following - ! scenarios are defined in this module: + ! Parameter used in the definition of alkalinization scenarios not based on + ! an input file. The following scenarios are defined in this module: ! ! const Constant homogeneous addition of alkalinity between latitude ! cdrmip_latmin and latitude cdrmip_latmax @@ -82,7 +92,7 @@ module mo_read_oafx ! Pmol ALK/yr-1 from year ramp_start to year ramp_end between ! latitude cdrmip_latmin and latitude cdrmip_latmax ! - real, protected :: addalk = 0.56 ! Pmol alkalinity/yr added in the + real, protected :: addalk = 0.135 ! Pmol alkalinity/yr added in the ! scenarios. Read from namelist file ! to overwrite default value. real, protected :: cdrmip_latmax = 70.0 ! Min and max latitude where @@ -127,6 +137,8 @@ subroutine ini_read_oafx(kpie,kpje,pdlxp,pdlyp,pglat,omask) !****************************************************************************** use mod_xc, only: xcsum,xchalt,mnproc,nbdy,ips use mo_control_bgc, only: io_stdo_bgc,do_oalk,bgc_namelist,get_bgc_namelist + use mod_dia, only: iotype + use mod_nctools, only: ncfopn,ncgeti,ncfcls implicit none @@ -136,12 +148,13 @@ subroutine ini_read_oafx(kpie,kpje,pdlxp,pdlyp,pglat,omask) real, intent(in) :: omask(kpie,kpje) integer :: i,j,errstat + logical :: file_exists=.false. integer :: iounit real :: avflx,ztotarea real :: ztmp1(1-nbdy:kpie+nbdy,1-nbdy:kpje+nbdy) - namelist /bgcoafx/ do_oalk,oalkscen,oalkfile,addalk,cdrmip_latmax, & - & cdrmip_latmin,ramp_start,ramp_end + namelist /bgcoafx/ oalkscen,oalkfile,addalk,cdrmip_latmax,cdrmip_latmin, & + & ramp_start,ramp_end ! Read parameters for alkalinization fluxes from namelist file if(.not. allocated(bgc_namelist)) call get_bgc_namelist @@ -169,13 +182,28 @@ subroutine ini_read_oafx(kpie,kpje,pdlxp,pdlyp,pglat,omask) write(io_stdo_bgc,*)' ' endif - if( trim(oalkscen)=='const' .or. trim(oalkscen)=='ramp' ) then + if( trim(oalkscen)=='const' .or. trim(oalkscen)=='ramp' .or. & + trim(oalkscen)=='file' ) then if(mnproc.eq.1) then write(io_stdo_bgc,*)'Using alkalinization scenario ', trim(oalkscen) + if( trim(oalkscen)=='file' ) then + write(io_stdo_bgc,*) 'from ', trim(oalkfile) + endif write(io_stdo_bgc,*)' ' endif + if( trim(oalkscen)=='file' ) then + ! Check if OA file exists. If not, abort. + inquire(file=oalkfile,exist=file_exists) + if (.not. file_exists .and. mnproc.eq.1) then + write(io_stdo_bgc,*) '' + write(io_stdo_bgc,*) 'ini_read_oafx: Cannot find ocean alkalinization file... ' + call xchalt('(ini_read_oafx)') + stop '(ini_read_oafx)' + endif + endif + ! Allocate field to hold alkalinization fluxes if(mnproc.eq.1) then write(io_stdo_bgc,*)'Memory allocation for variable oalkflx ...' @@ -187,38 +215,50 @@ subroutine ini_read_oafx(kpie,kpje,pdlxp,pdlyp,pglat,omask) if(errstat.ne.0) stop 'not enough memory oalkflx' oalkflx(:,:) = 0.0 - ! Calculate total ocean area - ztmp1(:,:)=0.0 - do j=1,kpje - do i=1,kpie - if( omask(i,j).gt.0.5 .and. pglat(i,j)cdrmip_latmin ) then - ztmp1(i,j)=ztmp1(i,j)+pdlxp(i,j)*pdlyp(i,j) - endif - enddo - enddo + if( trim(oalkscen)=='file' ) then - call xcsum(ztotarea,ztmp1,ips) - - ! Calculate alkalinity flux (kmol m^2 yr-1) to be applied - avflx = addalk/ztotarea*Pmol2kmol - if(mnproc.eq.1) then - write(io_stdo_bgc,*)' ' - write(io_stdo_bgc,*)' applying alkalinity flux of ', avflx, ' kmol m-2 yr-1' - write(io_stdo_bgc,*)' over an area of ', ztotarea , ' m2' - if( trim(oalkscen)=='ramp' ) then - write(io_stdo_bgc,*)' ramping-up from ', ramp_start, ' to ', ramp_end + ! read start and end year of OA file + call ncfopn(trim(oalkfile),'r',' ',1,iotype) + call ncgeti('startyear',startyear) + call ncgeti('endyear',endyear) + call ncfcls + + else + + ! Calculate total ocean area + ztmp1(:,:)=0.0 + do j=1,kpje + do i=1,kpie + if( omask(i,j).gt.0.5 .and. pglat(i,j)cdrmip_latmin ) then + ztmp1(i,j)=ztmp1(i,j)+pdlxp(i,j)*pdlyp(i,j) + endif + enddo + enddo + + call xcsum(ztotarea,ztmp1,ips) + + ! Calculate alkalinity flux (kmol m^2 yr-1) to be applied + avflx = addalk/ztotarea*Pmol2kmol + if(mnproc.eq.1) then + write(io_stdo_bgc,*)' ' + write(io_stdo_bgc,*)' applying alkalinity flux of ', avflx, ' kmol m-2 yr-1' + write(io_stdo_bgc,*)' over an area of ', ztotarea , ' m2' + if( trim(oalkscen)=='ramp' ) then + write(io_stdo_bgc,*)' ramping-up from ', ramp_start, ' to ', ramp_end + endif endif - endif + + do j=1,kpje + do i=1,kpie + if( omask(i,j).gt.0.5 .and. pglat(i,j)cdrmip_latmin ) then + oalkflx(i,j) = avflx + endif + enddo + enddo - do j=1,kpje - do i=1,kpie - if( omask(i,j).gt.0.5 .and. pglat(i,j)cdrmip_latmin ) then - oalkflx(i,j) = avflx - endif - enddo - enddo + endif lini=.true. @@ -228,7 +268,7 @@ subroutine ini_read_oafx(kpie,kpje,pdlxp,pdlyp,pglat,omask) else write(io_stdo_bgc,*) '' - write(io_stdo_bgc,*) 'ini_read_oafx: invalid alkalinization scenario... ' + write(io_stdo_bgc,*) 'ini_read_oafx: invalid alkalinization scenario' call xchalt('(ini_read_oafx)') stop '(ini_read_oafx)' @@ -265,6 +305,7 @@ subroutine get_oafx(kpie,kpje,kplyear,kplmon,omask,oafx) ! !****************************************************************************** use mod_xc, only: xchalt,mnproc + use netcdf, only: nf90_open,nf90_close,nf90_nowrite use mo_control_bgc, only: io_stdo_bgc,do_oalk use mod_time, only: nday_of_year @@ -273,10 +314,10 @@ subroutine get_oafx(kpie,kpje,kplyear,kplmon,omask,oafx) integer, intent(in) :: kpie,kpje,kplyear,kplmon real, intent(in) :: omask(kpie,kpje) real, intent(out) :: oafx(kpie,kpje) - integer :: current_day - ! local variables - integer :: i,j + ! local variables + integer :: month_in_file,ncstat,ncid,current_day + integer, save :: oldmonth=0 if (.not. do_oalk) then oafx(:,:) = 0.0 @@ -304,6 +345,25 @@ subroutine get_oafx(kpie,kpje,kplyear,kplmon,omask,oafx) oafx(:,:) = oalkflx(:,:) * current_day / ((ramp_end-ramp_start)*365.) endif + !-------------------------------- + ! Scenario from OA file + !-------------------------------- + elseif(trim(oalkscen)=='file' ) then + + ! read OA data from file + if (kplmon.ne.oldmonth) then + month_in_file=(max(startyear,min(endyear,kplyear))-startyear)*12+kplmon + if (mnproc.eq.1) then + write(io_stdo_bgc,*) 'Read OA month ',month_in_file, & + 'from file ',trim(oalkfile) + endif + ncstat=nf90_open(trim(oalkfile),nf90_nowrite,ncid) + call read_netcdf_var(ncid,'oafx',oalkflx,1,month_in_file,0) + ncstat=nf90_close(ncid) + oldmonth=kplmon + endif + oafx(:,:) = oalkflx + else write(io_stdo_bgc,*) '' From 0bfc1ccc0e54d97c4a2f082022d1dca16803f63c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?J=C3=B6rg=20Schwinger?= Date: Thu, 16 Mar 2023 19:32:42 +0100 Subject: [PATCH 270/366] add output for N-deposition and ocean alkalinization fluxes (#247) --- cime_config/buildnml | 28 ++++++++++++++++++---------- hamocc/accfields.F90 | 40 +++++++++++++++++++++++----------------- hamocc/mo_apply_oafx.F90 | 9 +++++++-- hamocc/mo_bgcmean.F90 | 25 +++++++++++++++++-------- hamocc/mo_carbch.F90 | 17 ++++++++++++++--- hamocc/ncout_hamocc.F90 | 25 +++++++++++++++++-------- 6 files changed, 96 insertions(+), 48 deletions(-) diff --git a/cime_config/buildnml b/cime_config/buildnml index a824d7f2..6f90c778 100755 --- a/cime_config/buildnml +++ b/cime_config/buildnml @@ -518,6 +518,12 @@ set INT_BROMOUV = '0, 2, 2' set INT_PHOSY = '4, 2, 2' set INT_NFIX = '0, 2, 2' set INT_DNIT = '0, 2, 2' +if ($BLOM_N_DEPOSITION == TRUE) then +set FLX_NDEP = '0, 2, 2' +else +set FLX_NDEP = '0, 0, 0' +endif +set FLX_OALK = '0, 0, 0' set FLX_CAR0100 = '0, 2, 2' set FLX_CAR0500 = '0, 2, 2' set FLX_CAR1000 = '0, 2, 2' @@ -1624,15 +1630,13 @@ cat >>! $RUNDIR/ocn_in$inststr << EOF ! ! CONTENTS: ! -! OALKSCEN : Name of alkalinization scenario. -! OALKFILE : Full path of the input file for the alkalinization scenario 'file'. -! ADDALK : Pmol alkalinity/yr added in the scenarios. -! CDRMIP_LATMAX : Max latitude where alkalinity is added according to the -! CDRMIP protocol -! CDRMIP_LATMIN : Min latitude where alkalinity is added according to the -! CDRMIP protocol +! OALKSCEN : Name of alkalinization scenario ('const', 'ramp', or 'file') +! OALKFILE : Full path of the input file for the alkalinization scenario 'file' +! ADDALK : Pmol alkalinity/yr added in 'const' or 'ramp' scenarios +! CDRMIP_LATMAX : Max latitude where alkalinity is added in 'const' or 'ramp' scenarios +! CDRMIP_LATMIN : Min latitude where alkalinity is added in 'const' or 'ramp' scenarios ! RAMP_START : Start year for ramp up in 'ramp' scenario -! RAMP_END : End year for 'ramp' scenario +! RAMP_END : End year for ramp up in 'ramp' scenario &BGCOAFX OALKSCEN = $BGCOAFX_OALKSCEN OALKFILE = $BGCOAFX_OALKFILE @@ -1771,8 +1775,10 @@ cat >>! $RUNDIR/ocn_in$inststr << EOF ! NFIX - Vertically integrated nitrogen fixation ! DNIT - Vertically integrated denitrification ! -! Particle fluxes (FLX, e.g CARFLX****, where ****=0100,0500,1000,2000,4000, or _BOT) -! and diffusive fluxes at the sediment - water-column interface (SEDIFF*) +! Particle fluxes (FLX, e.g CARFLX****, where ****=0100,0500,1000,2000,4000, or _BOT), +! diffusive fluxes at the sediment - water-column interface (SEDIFF*), and other fluxes +! NDEP - Nitrogen deposition flux [mol N m-2 s-1] +! OALK - Flux of alkalinity due to ocean alkalinization [mol N m-2 s-1] ! CARFLX**** - POC flux at **** metres depth [mol C m-2 s-1] ! BSIFLX**** - Biogenic silica flux at **** metres depth [mol Si m-2 s-1] ! CALFLX**** - Calcium carbonate flux at **** metres depth [mol C m-2 s-1] @@ -1860,6 +1866,8 @@ cat >>! $RUNDIR/ocn_in$inststr << EOF INT_PHOSY = $INT_PHOSY INT_NFIX = $INT_NFIX INT_DNIT = $INT_DNIT + FLX_NDEP = $FLX_NDEP + FLX_OALK = $FLX_OALK FLX_CAR0100 = $FLX_CAR0100 FLX_CAR0500 = $FLX_CAR0500 FLX_CAR1000 = $FLX_CAR1000 diff --git a/hamocc/accfields.F90 b/hamocc/accfields.F90 index d27dba68..3edce9a7 100644 --- a/hamocc/accfields.F90 +++ b/hamocc/accfields.F90 @@ -16,8 +16,8 @@ ! along with BLOM. If not, see https://www.gnu.org/licenses/. - SUBROUTINE ACCFIELDS(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask) -!********************************************************************** + SUBROUTINE ACCFIELDS(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask) +!******************************************************************************* ! !**** *ACCFIELDS* - . ! @@ -35,19 +35,19 @@ SUBROUTINE ACCFIELDS(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask) !**** Parameter list: ! --------------- ! -! *INTEGER* *kpie* - 1st dimension of model grid. -! *INTEGER* *kpje* - 2nd dimension of model grid. -! *INTEGER* *kpke* - 3rd (vertical) dimension of model grid. -! *REAL* *pdlxp* - size of scalar grid cell (1st dimension) [m]. -! *REAL* *pdlyp* - size of scalar grid cell (2nd dimension) [m]. -! *REAL* *pddpo* - size of scalar grid cell (3rd dimension) [m]. -! *REAL* *omask* - land/ocean mask +! *INTEGER* *kpie* - 1st dimension of model grid. +! *INTEGER* *kpje* - 2nd dimension of model grid. +! *INTEGER* *kpke* - 3rd (vertical) dimension of model grid. +! *REAL* *pdlxp* - size of scalar grid cell (1st dimension) [m]. +! *REAL* *pdlyp* - size of scalar grid cell (2nd dimension) [m]. +! *REAL* *pddpo* - size of scalar grid cell (3rd dimension) [m]. +! *REAL* *omask* - land/ocean mask ! -!********************************************************************** +!******************************************************************************* use mod_xc, only: mnproc use mod_dia, only: ddm - use mo_carbch, only: atm,atmflx,co2fxd,co2fxu,co3,hi,kwco2sol,ndepflx,rivinflx,ocetra,omegaa,omegac,pco2d,satoxy, & - & sedfluxo,pco2m,kwco2d,co2sold,co2solm + use mo_carbch, only: atm,atmflx,co2fxd,co2fxu,co3,hi,kwco2sol,ndepflx,rivinflx,oalkflx,ocetra,omegaa,omegac,pco2d, & + & satoxy,sedfluxo,pco2m,kwco2d,co2sold,co2solm use mo_biomod, only: bsiflx_bot,bsiflx0100,bsiflx0500,bsiflx1000,bsiflx2000,bsiflx4000,calflx_bot,calflx0100,calflx0500,& & calflx1000,calflx2000,calflx4000,carflx_bot,carflx0100,carflx0500,carflx1000,carflx2000,carflx4000,& & expoca,expoor,exposi,intdms_bac,intdms_uv,intdmsprod,intdnit,intnfix,intphosy,phosy3d @@ -63,11 +63,11 @@ SUBROUTINE ACCFIELDS(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask) & jlvlnatdic,jlvlnatomegaa,jlvlnatomegac,jlvlnos,jlvlo2sat,jlvlomegaa,jlvlomegac,jlvlopal,jlvloxygen,& & jlvlph,jlvlphosph,jlvlphosy,jlvlphyto,jlvlphyto13,jlvlpoc,jlvlpoc13,jlvlprefalk,jlvlprefdic, & & jlvlprefo2,jlvlprefpo4,jlvlsf6,jlvlsilica,jlvlwnos,jlvlwphy,jn2flux,jn2o,jn2oflux,jn2ofx, & - & jprorca,jprcaca,jsilpro,jpodiic,jpodial,jpodiph,jpodiox,jpodin2,jpodino3,jpodisi,jndep, & + & jprorca,jprcaca,jsilpro,jpodiic,jpodial,jpodiph,jpodiox,jpodin2,jpodino3,jpodisi,jndep,joalk, & & jniflux,jnos,jo2flux,jo2sat,jomegaa,jomegac,jopal,joxflux,joxygen,jpco2,jpco2m,jkwco2khm,jco2khm, & & jco2kh,jph,jphosph,jphosy,jphyto,jpoc,jprefalk,jprefdic,jprefo2,jprefpo4,jsilica,jsrfalkali, & - & jsrfano3,jsrfdic,jsrfiron,jsrfoxygen,jsrfphosph,jsrfphyto,jsrfsilica,jsrfph,jwnos,jwphy, & - & nbgc,nacc_bgc,bgcwrt,glb_inventory,bgct2d,acclvl,acclyr,accsrf,bgczlv + & jsrfano3,jsrfdic,jsrfiron,jsrfoxygen,jsrfphosph,jsrfphyto,jsrfsilica,jsrfph,jwnos,jwphy,jndepfx, & + & joalkfx,nbgc,nacc_bgc,bgcwrt,glb_inventory,bgct2d,acclvl,acclyr,accsrf,bgczlv use mo_control_bgc, only: io_stdo_bgc use mo_param1_bgc, only: ialkali,ian2o,iano3,iatmco2,iatmdms,iatmn2,iatmn2o,iatmo2,icalc,idet,idms,idicsat,idoc,iiron,iopal,& & ioxygen,iphosph,iphy,iprefalk,iprefdic,iprefpo4,iprefo2,isco212,isilica,izoo, & @@ -174,8 +174,9 @@ SUBROUTINE ACCFIELDS(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask) bgct2d(i,j,jpodino3) = bgct2d(i,j,jpodino3) + sedfluxo(i,j,ipowno3)/2.0 bgct2d(i,j,jpodisi) = bgct2d(i,j,jpodisi) + sedfluxo(i,j,ipowasi)/2.0 #endif - ! N-deposition and riverine input fluxes + ! N-deposition, ocean alkalinization, and riverine input fluxes bgct2d(i,j,jndep) = bgct2d(i,j,jndep) + ndepflx(i,j)/2.0 + bgct2d(i,j,joalk) = bgct2d(i,j,joalk) + oalkflx(i,j)/2.0 bgct2d(i,j,jirdin) = bgct2d(i,j,jirdin) + rivinflx(i,j,irdin)/2.0 bgct2d(i,j,jirdip) = bgct2d(i,j,jirdip) + rivinflx(i,j,irdip)/2.0 bgct2d(i,j,jirsi) = bgct2d(i,j,jirsi) + rivinflx(i,j,irsi)/2.0 @@ -264,6 +265,10 @@ SUBROUTINE ACCFIELDS(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask) call accsrf(jbromo_uv,int_chbr3_uv,omask,0) #endif +! Accumulate fluxes due to N-deposition, ocean alkalinization + call accsrf(jndepfx,ndepflx,omask,0) + call accsrf(joalkfx,oalkflx,omask,0) + ! Accumulate the diagnostic mass sinking field IF( domassfluxes ) THEN call accsrf(jcarflx0100,carflx0100,omask,0) @@ -285,7 +290,7 @@ SUBROUTINE ACCFIELDS(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask) call accsrf(jbsiflx_bot,bsiflx_bot,omask,0) call accsrf(jcalflx_bot,calflx_bot,omask,0) ENDIF - + #ifndef sedbypass ! Accumulate diffusive fluxes between water column and sediment call accsrf(jsediffic,sedfluxo(1,1,ipowaic),omask,0) @@ -475,6 +480,7 @@ SUBROUTINE ACCFIELDS(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask) atmflx=0. ! nullifying atm flux here to have zero fluxes for stepwise inventory fluxes ndepflx=0. + oalkflx=0. rivinflx=0. RETURN diff --git a/hamocc/mo_apply_oafx.F90 b/hamocc/mo_apply_oafx.F90 index 16d89b6f..7dad13df 100644 --- a/hamocc/mo_apply_oafx.F90 +++ b/hamocc/mo_apply_oafx.F90 @@ -70,7 +70,7 @@ subroutine apply_oafx(kpie,kpje,kpke,pddpo,omask,oafx) ! !****************************************************************************** use mo_control_bgc, only: dtb,do_oalk - use mo_carbch, only: ocetra + use mo_carbch, only: ocetra,oalkflx use mo_param1_bgc, only: ialkali implicit none @@ -83,13 +83,18 @@ subroutine apply_oafx(kpie,kpje,kpke,pddpo,omask,oafx) ! local variables integer :: i,j + ! oalkflx stores the applied alaklinity flux for inventory calculations + ! and output + oalkflx(:,:)=0.0 + if (.not. do_oalk) return ! alkalinization in topmost layer do j=1,kpje do i=1,kpie if (omask(i,j).gt.0.5) then - ocetra(i,j,1,ialkali)=ocetra(i,j,1,ialkali)+oafx(i,j)*dtb/365./pddpo(i,j,1) + oalkflx(i,j) = oafx(i,j)*dtb/365. + ocetra(i,j,1,ialkali)=ocetra(i,j,1,ialkali)+oalkflx(i,j)/pddpo(i,j,1) endif enddo enddo diff --git a/hamocc/mo_bgcmean.F90 b/hamocc/mo_bgcmean.F90 index 6a367ae1..08cc202f 100644 --- a/hamocc/mo_bgcmean.F90 +++ b/hamocc/mo_bgcmean.F90 @@ -94,6 +94,7 @@ MODULE mo_bgcmean & SRF_ATMBROMO =0 ,SRF_BROMO =0 ,SRF_BROMOFX =0 , & & INT_BROMOPRO =0 ,INT_BROMOUV =0 , & & INT_PHOSY =0 ,INT_NFIX =0 ,INT_DNIT =0 , & + & FLX_NDEP =0 ,FLX_OALK =0 , & & FLX_CAR0100 =0 ,FLX_CAR0500 =0 ,FLX_CAR1000 =0 , & & FLX_CAR2000 =0 ,FLX_CAR4000 =0 ,FLX_CAR_BOT =0 , & & FLX_BSI0100 =0 ,FLX_BSI0500 =0 ,FLX_BSI1000 =0 , & @@ -171,6 +172,7 @@ MODULE mo_bgcmean & SRF_ATMBROMO ,SRF_BROMO ,SRF_BROMOFX , & & INT_BROMOPRO ,INT_BROMOUV , & & INT_PHOSY ,INT_NFIX ,INT_DNIT , & + & FLX_NDEP ,FLX_OALK , & & FLX_CAR0100 ,FLX_CAR0500 ,FLX_CAR1000 , & & FLX_CAR2000 ,FLX_CAR4000 ,FLX_CAR_BOT , & & FLX_BSI0100 ,FLX_BSI0500 ,FLX_BSI1000 , & @@ -247,14 +249,15 @@ MODULE mo_bgcmean & jpodino3 =13, & & jpodisi =14, & & jndep =15, & - & jirdin =16, & - & jirdip =17, & - & jirsi =18, & - & jiralk =19, & - & jiriron =20, & - & jirdoc =21, & - & jirdet =22, & - & nbgct2d =22 + & joalk =16, & + & jirdin =17, & + & jirdip =18, & + & jirsi =19, & + & jiralk =20, & + & jiriron =21, & + & jirdoc =22, & + & jirdet =23, & + & nbgct2d =23 !---------------------------------------------------------------- INTEGER, SAVE :: i_bsc_m2d @@ -297,6 +300,8 @@ MODULE mo_bgcmean & jintphosy = 0 , & & jintnfix = 0 , & & jintdnit = 0 , & + & jndepfx = 0 , & + & joalkfx = 0 , & & jcarflx0100= 0 , & & jcarflx0500= 0 , & & jcarflx1000= 0 , & @@ -631,6 +636,10 @@ SUBROUTINE ALLOC_MEM_BGCMEAN(kpie,kpje,kpke) jintnfix(n)=i_bsc_m2d*min(1,INT_NFIX(n)) IF (INT_DNIT(n).GT.0) i_bsc_m2d=i_bsc_m2d+1 jintdnit(n)=i_bsc_m2d*min(1,INT_DNIT(n)) + IF (FLX_NDEP(n).GT.0) i_bsc_m2d=i_bsc_m2d+1 + jndepfx(n)=i_bsc_m2d*min(1,FLX_NDEP(n)) + IF (FLX_OALK(n).GT.0) i_bsc_m2d=i_bsc_m2d+1 + joalkfx(n)=i_bsc_m2d*min(1,FLX_OALK(n)) IF (FLX_CAR0100(n).GT.0) i_bsc_m2d=i_bsc_m2d+1 jcarflx0100(n)=i_bsc_m2d*min(1,FLX_CAR0100(n)) IF (FLX_CAR0500(n).GT.0) i_bsc_m2d=i_bsc_m2d+1 diff --git a/hamocc/mo_carbch.F90 b/hamocc/mo_carbch.F90 index 6a83fc2b..b2e7f0a8 100644 --- a/hamocc/mo_carbch.F90 +++ b/hamocc/mo_carbch.F90 @@ -59,6 +59,7 @@ MODULE mo_carbch REAL, DIMENSION (:,:,:), ALLOCATABLE :: atm REAL, DIMENSION (:,:,:), ALLOCATABLE :: atmflx REAL, DIMENSION (:,:), ALLOCATABLE :: ndepflx + REAL, DIMENSION (:,:), ALLOCATABLE :: oalkflx REAL, DIMENSION (:,:,:), ALLOCATABLE :: rivinflx REAL, DIMENSION (:,:,:), ALLOCATABLE :: co3 REAL, DIMENSION (:,:,:), ALLOCATABLE :: co2star @@ -304,19 +305,29 @@ SUBROUTINE ALLOC_MEM_CARBCH(kpie,kpje,kpke) if(errstat.ne.0) stop 'not enough memory atmflx' atmflx(:,:,:) = 0.0 - ! Allocate field to hold N-deposition fluxes per timestep for inventory caluclations + ! Allocate field to hold N-deposition fluxes per timestep for inventory calculations and output IF (mnproc.eq.1) THEN WRITE(io_stdo_bgc,*)'Memory allocation for variable ndepflx ...' WRITE(io_stdo_bgc,*)'First dimension : ',kpie WRITE(io_stdo_bgc,*)'Second dimension : ',kpje - !WRITE(io_stdo_bgc,*)'Third dimension : ',natm ENDIF ALLOCATE (ndepflx(kpie,kpje),stat=errstat) if(errstat.ne.0) stop 'not enough memory ndepflx' ndepflx(:,:) = 0.0 - ! Allocate field to hold riverine fluxes per timestep for inventory caluclations + ! Allocate field to hold OA alkalinity fluxes per timestep for inventory calculations and output + IF (mnproc.eq.1) THEN + WRITE(io_stdo_bgc,*)'Memory allocation for variable oalkflx ...' + WRITE(io_stdo_bgc,*)'First dimension : ',kpie + WRITE(io_stdo_bgc,*)'Second dimension : ',kpje + ENDIF + + ALLOCATE (oalkflx(kpie,kpje),stat=errstat) + if(errstat.ne.0) stop 'not enough memory oalkflx' + oalkflx(:,:) = 0.0 + + ! Allocate field to hold riverine fluxes per timestep for inventory calculations IF (mnproc.eq.1) THEN WRITE(io_stdo_bgc,*)'Memory allocation for variable rivinflx ...' WRITE(io_stdo_bgc,*)'First dimension : ',kpie diff --git a/hamocc/ncout_hamocc.F90 b/hamocc/ncout_hamocc.F90 index 96d1dc5d..7d29652e 100644 --- a/hamocc/ncout_hamocc.F90 +++ b/hamocc/ncout_hamocc.F90 @@ -35,6 +35,7 @@ subroutine ncwrt_bgc(iogrp) use mod_nctools, only: ncwrt1,ncdims,nctime,ncfcls,ncfopn, & & ncdimc use mo_bgcmean, only: domassfluxes, & + & flx_ndep,flx_oalk, & & flx_cal0100,flx_cal0500,flx_cal1000, & & flx_cal2000,flx_cal4000,flx_cal_bot, & & flx_car0100,flx_car0500,flx_car1000, & @@ -53,12 +54,11 @@ subroutine ncwrt_bgc(iogrp) & jcalflx2000,jcalflx4000,jcalflx_bot, & & jcarflx0100,jcarflx0500,jcarflx1000, & & jcarflx2000,jcarflx4000,jcarflx_bot, & - & jco2flux,jco2fxd,jco2fxu,jco3,jdic,jdicsat, & + & jco2fxd,jco2fxu,jco3,jdic,jdicsat, & & jdms,jdms_bac,jdms_uv,jdmsflux,jdmsprod, & & jdoc,jdp,jeps,jexpoca,jexport,jexposi, & & jgrazer, & - & jintdnit,jintnfix,jintphosy,jiralk,jirdet, & - & jirdin,jirdip,jirdoc,jiriron,jiron,jirsi, & + & jintdnit,jintnfix,jintphosy,jiron,jirsi, & & jkwco2,jlvlalkali,jlvlano3,jlvlasize, & & jlvlbigd14c,jlvlbromo,jlvlcalc,jlvlcalc13, & & jlvlcfc11,jlvlcfc12,jlvlco3,jlvld13c, & @@ -72,9 +72,9 @@ subroutine ncwrt_bgc(iogrp) & jlvlphosy,jlvlphyto,jlvlphyto13,jlvlpoc, & & jlvlpoc13,jlvlprefalk,jlvlprefdic, & & jlvlprefo2,jlvlprefpo4,jlvlsf6,jlvlsilica, & - & jlvlwnos,jlvlwphy,jn2flux,jn2o,jn2oflux, & - & jn2ofx,jndep,jniflux,jnos,jo2flux,jo2sat, & - & jomegaa,jomegac,jopal,joxflux,joxygen,jpco2, & + & jlvlwnos,jlvlwphy,jn2o, & + & jn2ofx,jndepfx,jniflux,jnos,joalkfx, & + & jo2sat,jomegaa,jomegac,jopal,joxflux,joxygen,jpco2, & & jpco2m,jkwco2khm,jco2kh,jco2khm, & & jph,jphosph,jphosy,jphyto,jpoc,jprefalk, & & jprefdic,jprefo2,jprefpo4,jsilica, & @@ -426,6 +426,8 @@ subroutine ncwrt_bgc(iogrp) call wrtsrf(jintphosy(iogrp), INT_PHOSY(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'ppint') call wrtsrf(jintnfix(iogrp), INT_NFIX(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'nfixint') call wrtsrf(jintdnit(iogrp), INT_DNIT(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'dnitint') + call wrtsrf(jndepfx(iogrp), FLX_NDEP(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'ndep') + call wrtsrf(joalkfx(iogrp), FLX_OALK(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'oalkfx') call wrtsrf(jcarflx0100(iogrp), FLX_CAR0100(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'carflx0100') call wrtsrf(jcarflx0500(iogrp), FLX_CAR0500(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'carflx0500') call wrtsrf(jcarflx1000(iogrp), FLX_CAR1000(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'carflx1000') @@ -671,6 +673,8 @@ subroutine ncwrt_bgc(iogrp) call inisrf(jintphosy(iogrp),0.) call inisrf(jintnfix(iogrp),0.) call inisrf(jintdnit(iogrp),0.) + call inisrf(jndepfx(iogrp),0.) + call inisrf(joalkfx(iogrp),0.) call inisrf(jcarflx0100(iogrp),0.) call inisrf(jcarflx0500(iogrp),0.) call inisrf(jcarflx1000(iogrp),0.) @@ -893,8 +897,9 @@ subroutine hamoccvardef(iogrp,timeunits,calendar,cmpflg) & srf_co2fxu,srf_oxflux,srf_niflux,srf_dms,srf_dmsprod, & & srf_dms_bac,srf_dms_uv,srf_export,srf_exposi,srf_expoca, & & srf_dic,srf_alkali,srf_phosph,srf_oxygen,srf_ano3,srf_silica, & - & srf_iron,srf_phyto,srf_ph,int_phosy,int_nfix,int_dnit,flx_car0100, & - & flx_car0500,flx_car1000,flx_car2000,flx_car4000,flx_car_bot, & + & srf_iron,srf_phyto,srf_ph,int_phosy,int_nfix,int_dnit, & + & flx_ndep,flx_oalk,flx_car0100,flx_car0500, & + & flx_car1000,flx_car2000,flx_car4000,flx_car_bot, & & flx_bsi0100,flx_bsi0500,flx_bsi1000,flx_bsi2000,flx_bsi4000, & & flx_bsi_bot,flx_cal0100,flx_cal0500,flx_cal1000,flx_cal2000, & & flx_cal4000,flx_cal_bot,flx_sediffic,flx_sediffal, & @@ -1027,6 +1032,10 @@ subroutine hamoccvardef(iogrp,timeunits,calendar,cmpflg) & 'Integrated nitrogen fixation',' ','mol N m-2 s-1',0) call ncdefvar3d(INT_DNIT(iogrp),cmpflg,'p','dnitint', & & 'Integrated denitrification',' ','mol N m-2 s-1',0) + call ncdefvar3d(FLX_NDEP(iogrp),cmpflg,'p','ndep', & + & 'Nitrogen deposition flux',' ','mol N m-2 s-1',0) + call ncdefvar3d(FLX_OALK(iogrp),cmpflg,'p','oalkfx', & + & 'Alkalinity flux due to OA',' ','mol TA m-2 s-1',0) call ncdefvar3d(FLX_CAR0100(iogrp),cmpflg,'p','carflx0100', & & 'C flux at 100m',' ','mol C m-2 s-1',0) call ncdefvar3d(FLX_CAR0500(iogrp),cmpflg,'p','carflx0500', & From b28d2da9c01a2bf2289ba4b1849ae1aee44a9f5f Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Fri, 17 Mar 2023 21:26:01 +0100 Subject: [PATCH 271/366] Squash remove M4AGO core --- .github/workflows/ci.yml | 4 + .gitmodules | 3 + Externals_BLOM.cfg | 9 + ben02/mod_ben02.F | 21 +- ben02/sfcstr_ben02.F | 7 +- ben02/thermf_ben02.F | 57 +- bld/MNP2/kdm.cntiso_hybrid | 1 + bld/MNP2/{kdm => kdm.isopyc_bulkml} | 0 bld/channel/{kdm => kdm.isopyc_bulkml} | 0 bld/fuk95/kdm | 1 - bld/fuk95/kdm.cntiso_hybrid | 1 + bld/fuk95/kdm.isopyc_bulkml | 1 + bld/gx1v5/{kdm => kdm.isopyc_bulkml} | 0 bld/gx1v6/{kdm => kdm.isopyc_bulkml} | 0 bld/gx3v7/{kdm => kdm.isopyc_bulkml} | 0 bld/meson.build | 11 +- bld/single_column/kdm.cntiso_hybrid | 1 + bld/single_column/{kdm => kdm.isopyc_bulkml} | 0 bld/tnx0.125v4/{kdm => kdm.isopyc_bulkml} | 0 bld/tnx0.25v1/{kdm => kdm.isopyc_bulkml} | 0 bld/tnx0.25v3/{kdm => kdm.isopyc_bulkml} | 0 bld/tnx0.25v4/{kdm => kdm.isopyc_bulkml} | 0 bld/tnx1.5v1/{kdm => kdm.isopyc_bulkml} | 0 bld/tnx1v1/{kdm => kdm.isopyc_bulkml} | 0 bld/tnx1v3/{kdm => kdm.isopyc_bulkml} | 0 bld/tnx1v4/kdm.cntiso_hybrid | 1 + bld/tnx1v4/{kdm => kdm.isopyc_bulkml} | 0 bld/tnx2v1/{kdm => kdm.isopyc_bulkml} | 0 cesm/mod_cesm.F90 | 80 +- cesm/sfcstr_cesm.F | 7 +- cesm/thermf_cesm.F | 55 +- channel/mod_channel.F90 | 4 +- channel/thermf_channel.F | 8 +- cime_config/buildcpp | 18 +- cime_config/buildlib_2.1 | 7 +- cime_config/buildlib_2.2 | 10 +- cime_config/buildnml | 549 +- cime_config/config_archive.xml | 13 + cime_config/config_component.xml | 18 + drivers/cpl_mct/mod_swtfrz.F | 94 - .../{cpl_share => mct}/blom_cpl_indices.F90 | 0 drivers/{cpl_mct => mct}/domain_mct.F | 3 +- drivers/{cpl_mct => mct}/export_mct.F | 7 +- drivers/{cpl_mct => mct}/external_abort.F | 0 drivers/{cpl_mct => mct}/getprecipfact_mct.F | 0 drivers/{cpl_mct => mct}/import_mct.F | 0 drivers/mct/mod_swtfrz.F90 | 81 + drivers/{cpl_mct => mct}/ocn_comp_mct.F90 | 15 +- drivers/{cpl_mct => mct}/setlogunit.F | 0 drivers/{cpl_mct => mct}/sumsbuff_mct.F | 0 drivers/nocoupler/blom.F | 2 +- drivers/nuopc/external_abort.F90 | 35 + drivers/nuopc/mod_nuopc_methods.F90 | 1098 ++++ drivers/nuopc/mod_swtfrz.F90 | 81 + drivers/nuopc/ocn_comp_nuopc.F90 | 1189 ++++ drivers/nuopc/setlogunit.F90 | 25 + fuk95/mod_fuk95.F90 | 257 +- hamocc/accfields.F90 | 114 +- hamocc/aufr_bgc.F90 | 7 +- hamocc/aufw_bgc.F90 | 18 +- hamocc/beleg_parm.F90 | 31 +- hamocc/beleg_vars.F90 | 12 +- hamocc/bodensed.F90 | 139 - hamocc/carchm.F90 | 40 +- hamocc/cyano.F90 | 71 +- hamocc/dipowa.F90 | 54 +- hamocc/hamocc4bcm.F90 | 24 +- hamocc/hamocc_init.F | 233 - hamocc/hamocc_init.F90 | 248 + hamocc/hamocc_step.F | 85 - hamocc/hamocc_step.F90 | 87 + hamocc/inventory_bgc.F90 | 38 +- hamocc/meson.build | 18 +- hamocc/mo_apply_ndep.F90 | 2 +- hamocc/mo_apply_oafx.F90 | 102 + hamocc/mo_apply_rivin.F90 | 22 +- hamocc/mo_bgcmean.F90 | 359 +- hamocc/mo_biomod.F90 | 5 +- hamocc/mo_carbch.F90 | 82 +- hamocc/mo_control_bgc.F90 | 6 +- hamocc/mo_extNbioproc.F90 | 277 +- hamocc/mo_extNsediment.F90 | 538 ++ hamocc/mo_intfcblom.F90 | 9 +- hamocc/mo_m4ago.F90 | 127 + hamocc/mo_param1_bgc.F90 | 101 +- hamocc/mo_read_fedep.F90 | 10 +- hamocc/mo_read_ndep.F90 | 28 +- hamocc/mo_read_oafx.F90 | 322 ++ hamocc/mo_read_sedpor.F90 | 131 + hamocc/mo_sedmnt.F90 | 283 +- hamocc/mo_vgrid.F90 | 19 +- hamocc/ncout_hamocc.F | 1992 ------- hamocc/ncout_hamocc.F90 | 2006 +++++++ hamocc/ocprod.F90 | 125 +- hamocc/powach.F90 | 217 +- hamocc/powadi.F90 | 12 +- hamocc/preftrc.F90 | 38 +- hamocc/read_netcdf_var.F90 | 3 + hamocc/restart_hamoccwt.F | 37 - hamocc/restart_hamoccwt.F90 | 36 + hamocc/sedshi.F90 | 27 +- hamocc/trc_limitc.F | 136 - hamocc/trc_limitc.F90 | 132 + hamocc/write_netcdf_var.F90 | 3 + meson.build | 29 +- meson_options.txt | 5 + phy/bigrid.F | 5 +- phy/blom_init.F | 126 +- phy/blom_step.F | 103 +- phy/cntiso_hybrid_forcing.F90 | 111 + phy/convec.F | 10 +- phy/diapfl.F | 17 +- phy/difest.F | 1410 ----- phy/diffus.F | 38 +- phy/fill_global.F | 2 +- phy/geoenv_file.F | 28 +- phy/iniphy.F | 6 + phy/inivar.F90 | 12 +- phy/meson.build | 25 +- phy/mod_budget.F90 | 180 +- phy/mod_checksum.F90 | 103 +- phy/mod_cmnfld.F | 565 -- phy/mod_cmnfld.F90 | 114 + phy/mod_cmnfld_routines.F90 | 1086 ++++ phy/mod_config.F90 | 4 +- phy/mod_constants.F90 | 60 +- phy/mod_dia.F | 1893 ++++--- phy/mod_difest.F | 2588 +++++++++ phy/mod_diffusion.F90 | 213 +- phy/mod_eddtra.F | 1013 ---- phy/mod_eddtra.F90 | 1480 +++++ phy/mod_eos.F90 | 97 +- phy/mod_forcing.F90 | 53 +- phy/mod_grid.F90 | 12 +- phy/mod_hor3map.F90 | 4931 +++++++++++++++++ phy/mod_inicon.F | 228 +- phy/mod_momtum.F | 21 +- phy/mod_mxlayr.F | 68 +- phy/mod_nctools.F | 5 +- phy/mod_ndiff.F90 | 1172 ++++ phy/mod_pbcor.F | 16 +- phy/mod_pgforc.F | 26 +- phy/mod_pointtest.F90 | 2 +- phy/mod_remap.F | 19 +- phy/mod_state.F90 | 48 +- phy/mod_swabs.F | 2 +- phy/mod_temmin.F | 5 +- phy/mod_tidaldissip.F90 | 6 +- phy/mod_time.F90 | 6 +- phy/mod_timing.F90 | 4 +- phy/mod_tke.F90 | 34 +- phy/mod_tmsmt.F | 163 +- phy/mod_vcoord.F90 | 1405 +++++ phy/mod_vdiff.F90 | 356 ++ phy/numerical_bounds.F90 | 8 +- phy/rdlim.F | 263 +- phy/restart_rd.F | 34 +- phy/restart_wt.F | 49 +- phy/sfcstr.F90 | 4 +- pkgs/CVMix-src | 1 + pkgs/meson.build | 10 + single_column/mod_single_column.F90 | 21 +- tests/fuk95/limits | 117 +- trc/mod_tracers.F90 | 2 +- 164 files changed, 24488 insertions(+), 8106 deletions(-) create mode 100644 .gitmodules create mode 100644 Externals_BLOM.cfg create mode 100644 bld/MNP2/kdm.cntiso_hybrid rename bld/MNP2/{kdm => kdm.isopyc_bulkml} (100%) rename bld/channel/{kdm => kdm.isopyc_bulkml} (100%) delete mode 100644 bld/fuk95/kdm create mode 100644 bld/fuk95/kdm.cntiso_hybrid create mode 100644 bld/fuk95/kdm.isopyc_bulkml rename bld/gx1v5/{kdm => kdm.isopyc_bulkml} (100%) rename bld/gx1v6/{kdm => kdm.isopyc_bulkml} (100%) rename bld/gx3v7/{kdm => kdm.isopyc_bulkml} (100%) create mode 100644 bld/single_column/kdm.cntiso_hybrid rename bld/single_column/{kdm => kdm.isopyc_bulkml} (100%) rename bld/tnx0.125v4/{kdm => kdm.isopyc_bulkml} (100%) rename bld/tnx0.25v1/{kdm => kdm.isopyc_bulkml} (100%) rename bld/tnx0.25v3/{kdm => kdm.isopyc_bulkml} (100%) rename bld/tnx0.25v4/{kdm => kdm.isopyc_bulkml} (100%) rename bld/tnx1.5v1/{kdm => kdm.isopyc_bulkml} (100%) rename bld/tnx1v1/{kdm => kdm.isopyc_bulkml} (100%) rename bld/tnx1v3/{kdm => kdm.isopyc_bulkml} (100%) create mode 100644 bld/tnx1v4/kdm.cntiso_hybrid rename bld/tnx1v4/{kdm => kdm.isopyc_bulkml} (100%) rename bld/tnx2v1/{kdm => kdm.isopyc_bulkml} (100%) create mode 100644 cime_config/config_archive.xml delete mode 100644 drivers/cpl_mct/mod_swtfrz.F rename drivers/{cpl_share => mct}/blom_cpl_indices.F90 (100%) rename drivers/{cpl_mct => mct}/domain_mct.F (97%) rename drivers/{cpl_mct => mct}/export_mct.F (96%) rename drivers/{cpl_mct => mct}/external_abort.F (100%) rename drivers/{cpl_mct => mct}/getprecipfact_mct.F (100%) rename drivers/{cpl_mct => mct}/import_mct.F (100%) create mode 100644 drivers/mct/mod_swtfrz.F90 rename drivers/{cpl_mct => mct}/ocn_comp_mct.F90 (96%) rename drivers/{cpl_mct => mct}/setlogunit.F (100%) rename drivers/{cpl_mct => mct}/sumsbuff_mct.F (100%) create mode 100644 drivers/nuopc/external_abort.F90 create mode 100644 drivers/nuopc/mod_nuopc_methods.F90 create mode 100644 drivers/nuopc/mod_swtfrz.F90 create mode 100644 drivers/nuopc/ocn_comp_nuopc.F90 create mode 100644 drivers/nuopc/setlogunit.F90 delete mode 100644 hamocc/bodensed.F90 delete mode 100644 hamocc/hamocc_init.F create mode 100644 hamocc/hamocc_init.F90 delete mode 100644 hamocc/hamocc_step.F create mode 100644 hamocc/hamocc_step.F90 create mode 100644 hamocc/mo_apply_oafx.F90 create mode 100644 hamocc/mo_extNsediment.F90 create mode 100644 hamocc/mo_m4ago.F90 create mode 100644 hamocc/mo_read_oafx.F90 create mode 100644 hamocc/mo_read_sedpor.F90 delete mode 100644 hamocc/ncout_hamocc.F create mode 100644 hamocc/ncout_hamocc.F90 delete mode 100644 hamocc/restart_hamoccwt.F create mode 100644 hamocc/restart_hamoccwt.F90 delete mode 100644 hamocc/trc_limitc.F create mode 100644 hamocc/trc_limitc.F90 create mode 100644 phy/cntiso_hybrid_forcing.F90 delete mode 100644 phy/difest.F delete mode 100644 phy/mod_cmnfld.F create mode 100644 phy/mod_cmnfld.F90 create mode 100644 phy/mod_cmnfld_routines.F90 create mode 100644 phy/mod_difest.F delete mode 100644 phy/mod_eddtra.F create mode 100644 phy/mod_eddtra.F90 create mode 100644 phy/mod_hor3map.F90 create mode 100644 phy/mod_ndiff.F90 create mode 100644 phy/mod_vcoord.F90 create mode 100644 phy/mod_vdiff.F90 create mode 160000 pkgs/CVMix-src create mode 100644 pkgs/meson.build diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index 268493e0..63ac0786 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -39,6 +39,8 @@ jobs: - name: Checkout code uses: actions/checkout@v2 + with: + submodules: 'recursive' - name: Build env: @@ -132,6 +134,8 @@ jobs: - name: Checkout code uses: actions/checkout@v2 + with: + submodules: 'recursive' - name: Build with Intel compilers run: | diff --git a/.gitmodules b/.gitmodules new file mode 100644 index 00000000..18c11683 --- /dev/null +++ b/.gitmodules @@ -0,0 +1,3 @@ +[submodule "CVMix-src"] + path = pkgs/CVMix-src + url = git@github.com:CVMix/CVMix-src.git diff --git a/Externals_BLOM.cfg b/Externals_BLOM.cfg new file mode 100644 index 00000000..7952afd5 --- /dev/null +++ b/Externals_BLOM.cfg @@ -0,0 +1,9 @@ +[CVMix] +tag = v0.98-beta +protocol = git +repo_url = https://github.com/CVMix/CVMix-src +local_path = pkgs/CVMix-src +required = True + +[externals_description] +schema_version = 1.0.0 diff --git a/ben02/mod_ben02.F b/ben02/mod_ben02.F index 1418a23c..2e6c63cb 100644 --- a/ben02/mod_ben02.F +++ b/ben02/mod_ben02.F @@ -1,5 +1,5 @@ ! ------------------------------------------------------------------------------ -! Copyright (C) 2002-2020 Mats Bentsen +! Copyright (C) 2002-2022 Mats Bentsen, Mehmet Ilicak ! ! This file is part of BLOM. ! @@ -26,7 +26,7 @@ module mod_ben02 c use mod_types, only: i2, r4 use mod_config, only: expcnf - use mod_constants, only: t0deg, spval + use mod_constants, only: t0deg, spval, L_mks2cgs use mod_calendar, only: date_offset, calendar_noerr, . calendar_errstr use mod_time, only: date, calendar, nday_in_year, nday_of_year, @@ -183,10 +183,17 @@ module mod_ben02 . atm_cswa_era ! short-wave radiation adjustment factor ! (NCEP) c +#ifdef MKS + data atm_ice_csmt_ncep,atm_rnf_csmt_ncep /2.e10,1.e9/, + . atm_crnf_ncep,atm_cswa_ncep /0.82073,0.88340/, + . atm_ice_csmt_era,atm_rnf_csmt_era /0.0,1.e9/, + . atm_crnf_era,atm_cswa_era /0.7234,0.9721/ +#else data atm_ice_csmt_ncep,atm_rnf_csmt_ncep /2.e14,1.e13/, . atm_crnf_ncep,atm_cswa_ncep /0.82073,0.88340/, . atm_ice_csmt_era,atm_rnf_csmt_era /0.0,1.e13/, . atm_crnf_era,atm_cswa_era /0.7234,0.9721/ +#endif c real :: . zu, ! measurement height of wind [m] @@ -2090,11 +2097,13 @@ subroutine inifrc_ben02clim integer, dimension(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy,12) :: smtmsk real dx2,dy2,prc_sum,eva_sum,rnf_sum,swa_sum,lwa_sum,lht_sum, . sht_sum,fwf_fac,dangle,garea,le,albedo,fac,swa_ave,lwa_ave, - . lht_ave,sht_ave,crnf,cswa + . lht_ave,sht_ave,crnf,cswa,A_cgs2mks real*4 rw4 integer i,j,k,l,il,jl integer*2 rn2,ri2,rj2 c + A_cgs2mks=1./(L_mks2cgs**2) +c c --- 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), @@ -2775,7 +2784,7 @@ subroutine inifrc_ben02clim do k=1,12 do l=1,isp(j) do i=max(1,ifp(j,l)),min(ii,ilp(j,l)) - garea=scp2(i,j)*1.e-4 ! [m^2] + garea=scp2(i,j)*A_cgs2mks ! [m^2] c c --- ----- freshwater fluxes [m/s] util1(i,j)=util1(i,j)+precip(i,j,k)*fwf_fac*garea @@ -2819,7 +2828,7 @@ subroutine inifrc_ben02clim do j=1,jj do l=1,isp(j) do i=max(1,ifp(j,l)),min(ii,ilp(j,l)) - garea=scp2(i,j)*1.e-4 ! [m^2] + garea=scp2(i,j)*A_cgs2mks ! [m^2] c c --- ----- heat fluxes albedo=albs_f*ricclm(i,j,k)+albw(i,j)*(1.-ricclm(i,j,k)) @@ -2838,7 +2847,7 @@ subroutine inifrc_ben02clim call xcsum(lht_sum,util3,ip) call xcsum(sht_sum,util4,ip) c - fac=1.e4/(12.*area) + fac=(L_mks2cgs*L_mks2cgs)/(12.*area) swa_ave=swa_sum*fac lwa_ave=lwa_sum*fac lht_ave=lht_sum*fac diff --git a/ben02/sfcstr_ben02.F b/ben02/sfcstr_ben02.F index efd9e014..ee8161a6 100644 --- a/ben02/sfcstr_ben02.F +++ b/ben02/sfcstr_ben02.F @@ -1,5 +1,5 @@ ! ------------------------------------------------------------------------------ -! Copyright (C) 2004-2020 Mats Bentsen +! Copyright (C) 2004-2022 Mats Bentsen, Mehmet Ilicak ! ! This file is part of BLOM. ! @@ -24,6 +24,7 @@ subroutine sfcstr_ben02(m,n,mm,nn,k1m,k1n) c --- ------------------------------------------------------------------ c use mod_xc + use mod_constants, only: P_mks2cgs use mod_forcing, only: ztx, mty, taux, tauy use mod_seaice, only: ficem, hicem, tauxice, tauyice use mod_checksum, only: csdiag, chksummsk @@ -44,14 +45,14 @@ subroutine sfcstr_ben02(m,n,mm,nn,k1m,k1n) do i=max(1,ifu(j,l)),min(ii,ilu(j,l)) facice=(ficem(i,j)+ficem(i-1,j)) . *min(2.,hicem(i,j)+hicem(i-1,j))*.25 - taux(i,j)=10.*(ztx(i,j)*(1.-facice)+tauxice(i,j)*facice) + taux(i,j)=P_mks2cgs*(ztx(i,j)*(1.-facice)+tauxice(i,j)*facice) enddo enddo do l=1,isv(j) do i=max(1,ifv(j,l)),min(ii,ilv(j,l)) facice=(ficem(i,j)+ficem(i,j-1)) . *min(2.,hicem(i,j)+hicem(i,j-1))*.25 - tauy(i,j)=10.*(mty(i,j)*(1.-facice)+tauyice(i,j)*facice) + tauy(i,j)=P_mks2cgs*(mty(i,j)*(1.-facice)+tauyice(i,j)*facice) enddo enddo enddo diff --git a/ben02/thermf_ben02.F b/ben02/thermf_ben02.F index eb01e51d..fcd5bd19 100644 --- a/ben02/thermf_ben02.F +++ b/ben02/thermf_ben02.F @@ -1,5 +1,5 @@ ! ------------------------------------------------------------------------------ -! Copyright (C) 2002-2020 Mats Bentsen +! Copyright (C) 2002-2022 Mats Bentsen, Mehmet Ilicak ! ! This file is part of BLOM. ! @@ -21,7 +21,8 @@ subroutine thermf_ben02(m,n,mm,nn,k1m,k1n) c c --- NERSC version of thermf. c - use mod_constants, only: spcifh, t0deg, epsil, onem + use mod_constants, only: spcifh, t0deg, alpha0, epsilt, onem, + . g2kg, kg2g, L_mks2cgs, M_mks2cgs use mod_time, only: nday_in_year, nday_of_year, nstep, . nstep_in_day, baclin, . xmi, l1mi, l2mi, l3mi, l4mi, l5mi @@ -71,7 +72,7 @@ subroutine thermf_ben02(m,n,mm,nn,k1m,k1n) . fice,hice,hsnw,tsrf,fice0,hice0,hsnw0,qsww,qnsw,tice,albi, . tsmlt,albi_h,qswi,dh,qsnwf,fcond,qdamp,qsmlt,qo2i,qbot,swfac, . dtml,q,volice,df,dvi,dvs,fwflx,sstc,rice,trxflx,sssc,srxflx, - . totsfl,totwfl,sflxc,totsrp,totsrn + . totsfl,totwfl,sflxc,totsrp,totsrn,A_cgs2mks #ifdef TRC integer nt real, dimension(ntr,1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy) :: @@ -82,10 +83,12 @@ subroutine thermf_ben02(m,n,mm,nn,k1m,k1n) c real intp1d external intp1d +c + A_cgs2mks=1./(L_mks2cgs**2) c c --- Due to conservation, the ratio of ice and snow density must be c --- equal to the ratio of ice and snow heat of fusion - if (abs(fuss/fusi-rhosnw/rhoice).gt.epsil) then + if (abs(fuss/fusi-rhosnw/rhoice).gt.epsilt) then if (mnproc.eq.1) then write (lp,*) . 'thermf: check consistency between snow/ice densities' @@ -97,7 +100,7 @@ subroutine thermf_ben02(m,n,mm,nn,k1m,k1n) c c --- Set various constants dt=baclin ! Time step - cpsw=spcifh*1.e3 ! Specific heat of seawater + cpsw=spcifh*M_mks2cgs ! Specific heat of seawater rnf_fac=baclin/real(nrfets*86400) ! Runoff reservoar detrainment rate sag_fac=exp(-sagets*dt) ! Snow aging rate c @@ -326,7 +329,7 @@ subroutine thermf_ben02(m,n,mm,nn,k1m,k1n) c --- ----- Ice volume that has to freeze to balance the heat budget volice=-(qsww+qnsw-q)*(1.-fice)*dt/fusi c - if (volice.gt.epsil) then + if (volice.gt.epsilt) then c c --- ------- New ice in the lead is formed with a specified thickness. c --- ------- Estimate the change in ice fraction @@ -344,7 +347,7 @@ subroutine thermf_ben02(m,n,mm,nn,k1m,k1n) c --- ----- If the lead is warming, let the fraction (1 - fice) go to c --- ----- warm the lead, and the fraction fice to melt ice laterally fice=fice-(swfac*qsww+qnsw)*fice*dt - . /max(hice*fusi+hsnw*fuss,epsil) + . /max(hice*fusi+hsnw*fuss,epsilt) if (fice.lt.0.) then fice=0. hice=0. @@ -398,14 +401,14 @@ subroutine thermf_ben02(m,n,mm,nn,k1m,k1n) fwflx=eva(i,j)+lip(i,j)+sop(i,j)+rnf(i,j)+rfi(i,j)+fmltfz(i,j) c c --- --- Salt flux [kg m-2 s-1] (positive downwards) - sfl(i,j)=-sice*dvi*rhoice/dt*1.e-3 + sfl(i,j)=-sice*dvi*rhoice/dt*g2kg c c --- --- Salt flux due to brine rejection of freezing sea c --- --- ice [kg m-2 m-1] (positive downwards) - brnflx(i,j)=max(0.,-sotl*fmltfz(i,j)*1.e-3+sfl(i,j)) + brnflx(i,j)=max(0.,-sotl*fmltfz(i,j)*g2kg+sfl(i,j)) c c --- --- Virtual salt flux [kg m-2 s-1] (positive downwards) - vrtsfl(i,j)=-sotl*fwflx*1.e-3 + vrtsfl(i,j)=-sotl*fwflx*g2kg c c --- --- Store area weighted virtual salt flux and fresh water flux util1(i,j)=vrtsfl(i,j)*scp2(i,j) @@ -415,11 +418,11 @@ subroutine thermf_ben02(m,n,mm,nn,k1m,k1n) hmltfz(i,j)=(dvi*fusi+dvs*fuss)/dt c c --- --- Total heat flux in BLOM units [W cm-2] (positive upwards) - surflx(i,j)=-(swa(i,j)+nsf(i,j)+hmltfz(i,j))*1.e-4 + surflx(i,j)=-(swa(i,j)+nsf(i,j)+hmltfz(i,j))*A_cgs2mks c c --- --- Short-wave heat flux in BLOM units [W cm-2] (positive c --- --- upwards) - sswflx(i,j)=-qsww*(1.-fice0)*1.e-4 + sswflx(i,j)=-qsww*(1.-fice0)*A_cgs2mks c #ifdef TRC c --- ------------------------------------------------------------------ @@ -452,7 +455,7 @@ subroutine thermf_ben02(m,n,mm,nn,k1m,k1n) endif # endif # endif - trflx(nt,i,j)=-trc(i,j,k1n,nt)*fwflx*1.e-3 + trflx(nt,i,j)=-trc(i,j,k1n,nt)*fwflx*g2kg ttrsf(nt,i,j)=trflx(nt,i,j)*scp2(i,j) ttrav(nt,i,j)=trc(i,j,k1n,nt)*scp2(i,j) enddo @@ -465,7 +468,7 @@ subroutine thermf_ben02(m,n,mm,nn,k1m,k1n) surrlx(i,j)=0. c c --- --- If trxday>0 , apply relaxation towards observed sst - if (trxday.gt.epsil) then + if (trxday.gt.epsilt) then sstc=intp1d(sstclm(i,j,l1mi),sstclm(i,j,l2mi), . sstclm(i,j,l3mi),sstclm(i,j,l4mi), . sstclm(i,j,l5mi),xmi) @@ -473,8 +476,8 @@ 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 - trxflx=spcifh*100.*min(hmxl,trxdpt)/(trxday*86400.) - . *min(trxlim,max(-trxlim,sstc-tmxl)) + trxflx=spcifh*L_mks2cgs*min(hmxl,trxdpt)/(trxday*86400.) + . *min(trxlim,max(-trxlim,sstc-tmxl))/alpha0 surrlx(i,j)=-trxflx else trxflx=0. @@ -496,12 +499,12 @@ subroutine thermf_ben02(m,n,mm,nn,k1m,k1n) salrlx(i,j)=0. c c --- --- if srxday>0 , apply relaxation towards observed sss - if (srxday.gt.epsil) then + if (srxday.gt.epsilt) then sssc=intp1d(sssclm(i,j,l1mi),sssclm(i,j,l2mi), . sssclm(i,j,l3mi),sssclm(i,j,l4mi), . sssclm(i,j,l5mi),xmi) - srxflx=100.*min(hmxl,srxdpt)/(srxday*86400.) - . *min(srxlim,max(-srxlim,sssc-smxl)) + srxflx=L_mks2cgs*min(hmxl,srxdpt)/(srxday*86400.) + . *min(srxlim,max(-srxlim,sssc-smxl))/alpha0 salrlx(i,j)=-srxflx util3(i,j)=max(0.,salrlx(i,j))*scp2(i,j) util4(i,j)=min(0.,salrlx(i,j))*scp2(i,j) @@ -538,7 +541,7 @@ subroutine thermf_ben02(m,n,mm,nn,k1m,k1n) c --- ------------------------------------------------------------------- c ustar(i,j)=(min(ustari(i,j),.8e-2)*fice0 - . +ustarw(i,j)*(1.-fice0))*1.e2 + . +ustarw(i,j)*(1.-fice0))*L_mks2cgs c enddo enddo @@ -556,7 +559,7 @@ subroutine thermf_ben02(m,n,mm,nn,k1m,k1n) call xcsum(totwfl,util2,ips) c c --- Correction for the virtual salt flux [kg m-2 s-1] - sflxc=(-sref*totwfl*1.e-3-totsfl)/area + sflxc=(-sref*totwfl*g2kg-totsfl)/area if (mnproc.eq.1) then write (lp,*) 'thermf: totsfl/area,sflxc',totsfl/area,sflxc endif @@ -567,8 +570,10 @@ subroutine thermf_ben02(m,n,mm,nn,k1m,k1n) do j=1,jj do l=1,isp(j) do i=max(1,ifp(j,l)),min(ii,ilp(j,l)) - salflx(i,j)=-(vrtsfl(i,j)+sflxc+sfl(i,j))*1.e2 - brnflx(i,j)=-brnflx(i,j)*1.e2 + salflx(i,j)=-(vrtsfl(i,j)+sflxc+sfl(i,j)) + . *(kg2g*(M_mks2cgs/L_mks2cgs**2)) + brnflx(i,j)=-brnflx(i,j) + . *(kg2g*(M_mks2cgs/L_mks2cgs**2)) enddo enddo enddo @@ -577,7 +582,7 @@ subroutine thermf_ben02(m,n,mm,nn,k1m,k1n) c --- if srxday>0 and srxbal=.true. , balance the sss relaxation flux c --- so the net input of salt in grid cells connected to the world c --- ocean is zero - if (srxday.gt.epsil.and.srxbal) then + if (srxday.gt.epsilt.and.srxbal) then call xcsum(totsrp,util3,ipwocn) call xcsum(totsrn,util4,ipwocn) if (abs(totsrp).gt.abs(totsrn)) then @@ -632,14 +637,14 @@ subroutine thermf_ben02(m,n,mm,nn,k1m,k1n) c tottrav=tottrav/area cc c trflxc=(-tottrsf)/area -c trflxc=(-tottrav*totwfl*1.e-3-tottrsf)/area +c trflxc=(-tottrav*totwfl*g2kg-tottrsf)/area trflxc=0. c c$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)) - trflx(nt,i,j)=-(trflx(nt,i,j)+trflxc)*1.e2 + trflx(nt,i,j)=-(trflx(nt,i,j)+trflxc)*L_mks2cgs enddo enddo enddo diff --git a/bld/MNP2/kdm.cntiso_hybrid b/bld/MNP2/kdm.cntiso_hybrid new file mode 100644 index 00000000..f6b91e0e --- /dev/null +++ b/bld/MNP2/kdm.cntiso_hybrid @@ -0,0 +1 @@ +56 diff --git a/bld/MNP2/kdm b/bld/MNP2/kdm.isopyc_bulkml similarity index 100% rename from bld/MNP2/kdm rename to bld/MNP2/kdm.isopyc_bulkml diff --git a/bld/channel/kdm b/bld/channel/kdm.isopyc_bulkml similarity index 100% rename from bld/channel/kdm rename to bld/channel/kdm.isopyc_bulkml diff --git a/bld/fuk95/kdm b/bld/fuk95/kdm deleted file mode 100644 index 48082f72..00000000 --- a/bld/fuk95/kdm +++ /dev/null @@ -1 +0,0 @@ -12 diff --git a/bld/fuk95/kdm.cntiso_hybrid b/bld/fuk95/kdm.cntiso_hybrid new file mode 100644 index 00000000..7273c0fa --- /dev/null +++ b/bld/fuk95/kdm.cntiso_hybrid @@ -0,0 +1 @@ +25 diff --git a/bld/fuk95/kdm.isopyc_bulkml b/bld/fuk95/kdm.isopyc_bulkml new file mode 100644 index 00000000..7273c0fa --- /dev/null +++ b/bld/fuk95/kdm.isopyc_bulkml @@ -0,0 +1 @@ +25 diff --git a/bld/gx1v5/kdm b/bld/gx1v5/kdm.isopyc_bulkml similarity index 100% rename from bld/gx1v5/kdm rename to bld/gx1v5/kdm.isopyc_bulkml diff --git a/bld/gx1v6/kdm b/bld/gx1v6/kdm.isopyc_bulkml similarity index 100% rename from bld/gx1v6/kdm rename to bld/gx1v6/kdm.isopyc_bulkml diff --git a/bld/gx3v7/kdm b/bld/gx3v7/kdm.isopyc_bulkml similarity index 100% rename from bld/gx3v7/kdm rename to bld/gx3v7/kdm.isopyc_bulkml diff --git a/bld/meson.build b/bld/meson.build index a3c43727..14db644c 100644 --- a/bld/meson.build +++ b/bld/meson.build @@ -1,17 +1,22 @@ # Generate 'dimensions.F' based on desired grid and processor count blom_dims = find_program('blom_dimensions') patch_path = meson.source_root() / 'bld' / get_option('grid') -kdm_path = get_option('grid') / 'kdm' +if get_option('vcoord') == 'isopyc_bulkml' + kdm_file = 'kdm.isopyc_bulkml' +elif get_option('vcoord') == 'cntiso_hybrid' + kdm_file = 'kdm.cntiso_hybrid' +endif +kdm_path = get_option('grid') / kdm_file # More systems which support 'cat' can be added here, once tested if host_machine.system() in ['linux', 'darwin'] dim_kdm = run_command('cat', kdm_path) elif host_machine.system() == 'windows' dim_kdm = run_command('type', kdm_path) else - error('Could not read "kdm" content due to unknown OS (' + host_machine.system() + ')') + error('Could not read ' + kdm_file + ' content due to unknown OS (' + host_machine.system() + ')') endif if dim_kdm.returncode() != 0 - error('No "kdm" file found for grid "' + get_option('grid') + '"') + error('No ' + kdm_file + ' file found for grid "' + get_option('grid') + '"') endif dimensions = configure_file( output: 'dimensions.F', diff --git a/bld/single_column/kdm.cntiso_hybrid b/bld/single_column/kdm.cntiso_hybrid new file mode 100644 index 00000000..2bbd69c2 --- /dev/null +++ b/bld/single_column/kdm.cntiso_hybrid @@ -0,0 +1 @@ +70 diff --git a/bld/single_column/kdm b/bld/single_column/kdm.isopyc_bulkml similarity index 100% rename from bld/single_column/kdm rename to bld/single_column/kdm.isopyc_bulkml diff --git a/bld/tnx0.125v4/kdm b/bld/tnx0.125v4/kdm.isopyc_bulkml similarity index 100% rename from bld/tnx0.125v4/kdm rename to bld/tnx0.125v4/kdm.isopyc_bulkml diff --git a/bld/tnx0.25v1/kdm b/bld/tnx0.25v1/kdm.isopyc_bulkml similarity index 100% rename from bld/tnx0.25v1/kdm rename to bld/tnx0.25v1/kdm.isopyc_bulkml diff --git a/bld/tnx0.25v3/kdm b/bld/tnx0.25v3/kdm.isopyc_bulkml similarity index 100% rename from bld/tnx0.25v3/kdm rename to bld/tnx0.25v3/kdm.isopyc_bulkml diff --git a/bld/tnx0.25v4/kdm b/bld/tnx0.25v4/kdm.isopyc_bulkml similarity index 100% rename from bld/tnx0.25v4/kdm rename to bld/tnx0.25v4/kdm.isopyc_bulkml diff --git a/bld/tnx1.5v1/kdm b/bld/tnx1.5v1/kdm.isopyc_bulkml similarity index 100% rename from bld/tnx1.5v1/kdm rename to bld/tnx1.5v1/kdm.isopyc_bulkml diff --git a/bld/tnx1v1/kdm b/bld/tnx1v1/kdm.isopyc_bulkml similarity index 100% rename from bld/tnx1v1/kdm rename to bld/tnx1v1/kdm.isopyc_bulkml diff --git a/bld/tnx1v3/kdm b/bld/tnx1v3/kdm.isopyc_bulkml similarity index 100% rename from bld/tnx1v3/kdm rename to bld/tnx1v3/kdm.isopyc_bulkml diff --git a/bld/tnx1v4/kdm.cntiso_hybrid b/bld/tnx1v4/kdm.cntiso_hybrid new file mode 100644 index 00000000..f6b91e0e --- /dev/null +++ b/bld/tnx1v4/kdm.cntiso_hybrid @@ -0,0 +1 @@ +56 diff --git a/bld/tnx1v4/kdm b/bld/tnx1v4/kdm.isopyc_bulkml similarity index 100% rename from bld/tnx1v4/kdm rename to bld/tnx1v4/kdm.isopyc_bulkml diff --git a/bld/tnx2v1/kdm b/bld/tnx2v1/kdm.isopyc_bulkml similarity index 100% rename from bld/tnx2v1/kdm rename to bld/tnx2v1/kdm.isopyc_bulkml diff --git a/cesm/mod_cesm.F90 b/cesm/mod_cesm.F90 index a4950171..cc371c18 100644 --- a/cesm/mod_cesm.F90 +++ b/cesm/mod_cesm.F90 @@ -1,5 +1,5 @@ ! ------------------------------------------------------------------------------ -! Copyright (C) 2011-2021 Mats Bentsen, Jerry Tjiputra, Jörg Schwinger +! Copyright (C) 2011-2022 Mats Bentsen, Jerry Tjiputra, Jörg Schwinger ! ! This file is part of BLOM. ! @@ -28,8 +28,8 @@ module mod_cesm use mod_time, only: nstep use mod_xc use mod_forcing, only: trxday, srxday, swa, nsf, lip, sop, eva, rnf, rfi, & - fmltfz, sfl, ztx, mty, ustarw, slp, abswnd, atmco2,& - atmbrf + fmltfz, sfl, ztx, mty, ustarw, slp, abswnd, & + lamult, lasl, ustokes, vstokes, atmco2, atmbrf use mod_ben02, only: initai, rdcsic, rdctsf, fnlzai use mod_seaice, only: ficem use mod_checksum, only: csdiag, chksummsk @@ -70,9 +70,13 @@ module mod_cesm ustarw_da, & ! Friction velocity for open water [m s-1]. slp_da, & ! Sea-level pressure [kg m-1 s-2]. abswnd_da, & ! Wind speed at measurement height (zu) [m s-1]. + ficem_da, & ! Ice concentration []. + lamult_da, & ! Langmuir enhancement factor []. + lasl_da, & ! Surface layer averaged Langmuir number []. + ustokes_da, & ! u-component of surface Stokes drift [m s-1]. + vstokes_da, & ! v-component of surface Stokes drift [m s-1]. atmco2_da, & ! Atmospheric CO2 concentration [ppm]. - atmbrf_da, & ! Atmospheric bromoform concentration [ppt]. - ficem_da ! Ice concentration []. + atmbrf_da ! Atmospheric bromoform concentration [ppt]. logical :: & smtfrc ! If true, time smooth CESM forcing fields. @@ -83,7 +87,8 @@ module mod_cesm public :: runid_cesm, runtyp_cesm, ocn_cpl_dt_cesm, nstep_in_cpl, hmlt, & 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, ustarw_da, & - slp_da, abswnd_da, atmco2_da, atmbrf_da, ficem_da, smtfrc, l1ci, l2ci, & + slp_da, abswnd_da, ficem_da, lamult_da, lasl_da, & + ustokes_da, vstokes_da, atmco2_da, atmbrf_da, smtfrc, l1ci, l2ci, & inicon_cesm, inifrc_cesm, getfrc_cesm contains @@ -93,7 +98,7 @@ subroutine inicon_cesm ! Set initial conditions for variables specifically when coupled to CESM. ! --------------------------------------------------------------------------- - integer :: i, j, l + integer :: i, j !$omp parallel do private(i) do j = 1, jj @@ -146,6 +151,7 @@ subroutine getfrc_cesm #undef DIAG #ifdef DIAG use mod_nctools + use mod_dia, only : iotype #endif integer :: i, j, l @@ -163,22 +169,26 @@ subroutine getfrc_cesm do j = 1, jj do l = 1, isp(j) do i = max(1, ifp(j, l)), min(ii, ilp(j, l)) - ustarw(i, j) = w1*ustarw_da(i, j, l1ci) + w2*ustarw_da(i, j, l2ci) - lip(i, j) = w1*lip_da(i, j, l1ci) + w2*lip_da(i, j, l2ci) - sop(i, j) = w1*sop_da(i, j, l1ci) + w2*sop_da(i, j, l2ci) - eva(i, j) = w1*eva_da(i, j, l1ci) + w2*eva_da(i, j, l2ci) - rnf(i, j) = w1*rnf_da(i, j, l1ci) + w2*rnf_da(i, j, l2ci) - rfi(i, j) = w1*rfi_da(i, j, l1ci) + w2*rfi_da(i, j, l2ci) - fmltfz(i, j) = w1*fmltfz_da(i, j, l1ci) + w2*fmltfz_da(i, j, l2ci) - sfl(i, j) = w1*sfl_da(i, j, l1ci) + w2*sfl_da(i, j, l2ci) - swa(i, j) = w1*swa_da(i, j, l1ci) + w2*swa_da(i, j, l2ci) - nsf(i, j) = w1*nsf_da(i, j, l1ci) + w2*nsf_da(i, j, l2ci) - hmlt(i, j) = w1*hmlt_da(i, j, l1ci) + w2*hmlt_da(i, j, l2ci) - slp(i, j) = w1*slp_da(i, j, l1ci) + w2*slp_da(i, j, l2ci) - ficem(i, j) = w1*ficem_da(i, j, l1ci) + w2*ficem_da(i, j, l2ci) - abswnd(i, j) = w1*abswnd_da(i, j, l1ci) + w2*abswnd_da(i, j, l2ci) - atmco2(i, j) = w1*atmco2_da(i, j, l1ci) + w2*atmco2_da(i, j, l2ci) - atmbrf(i, j) = w1*atmbrf_da(i, j, l1ci) + w2*atmbrf_da(i, j, l2ci) + ustarw(i, j) = w1*ustarw_da(i, j, l1ci) + w2*ustarw_da(i, j, l2ci) + lip(i, j) = w1*lip_da(i, j, l1ci) + w2*lip_da(i, j, l2ci) + sop(i, j) = w1*sop_da(i, j, l1ci) + w2*sop_da(i, j, l2ci) + eva(i, j) = w1*eva_da(i, j, l1ci) + w2*eva_da(i, j, l2ci) + rnf(i, j) = w1*rnf_da(i, j, l1ci) + w2*rnf_da(i, j, l2ci) + rfi(i, j) = w1*rfi_da(i, j, l1ci) + w2*rfi_da(i, j, l2ci) + fmltfz(i, j) = w1*fmltfz_da(i, j, l1ci) + w2*fmltfz_da(i, j, l2ci) + sfl(i, j) = w1*sfl_da(i, j, l1ci) + w2*sfl_da(i, j, l2ci) + swa(i, j) = w1*swa_da(i, j, l1ci) + w2*swa_da(i, j, l2ci) + nsf(i, j) = w1*nsf_da(i, j, l1ci) + w2*nsf_da(i, j, l2ci) + hmlt(i, j) = w1*hmlt_da(i, j, l1ci) + w2*hmlt_da(i, j, l2ci) + slp(i, j) = w1*slp_da(i, j, l1ci) + w2*slp_da(i, j, l2ci) + abswnd(i, j) = w1*abswnd_da(i, j, l1ci) + w2*abswnd_da(i, j, l2ci) + ficem(i, j) = w1*ficem_da(i, j, l1ci) + w2*ficem_da(i, j, l2ci) + lamult(i, j) = w1*lamult_da(i, j, l1ci) + w2*lamult_da(i, j, l2ci) + lasl(i, j) = w1*lasl_da(i, j, l1ci) + w2*lasl_da(i, j, l2ci) + ustokes(i, j) = w1*ustokes_da(i, j, l1ci) + w2*ustokes_da(i, j, l2ci) + vstokes(i, j) = w1*vstokes_da(i, j, l1ci) + w2*vstokes_da(i, j, l2ci) + atmco2(i, j) = w1*atmco2_da(i, j, l1ci) + w2*atmco2_da(i, j, l2ci) + atmbrf(i, j) = w1*atmbrf_da(i, j, l1ci) + w2*atmbrf_da(i, j, l2ci) enddo enddo do l = 1, isu(j) @@ -210,8 +220,12 @@ subroutine getfrc_cesm call ncdefvar('nsf_da', 'x y', ndouble, 8) call ncdefvar('hmlt_da', 'x y', ndouble, 8) call ncdefvar('slp_da', 'x y', ndouble, 8) - call ncdefvar('ficem_da', 'x y', ndouble, 8) call ncdefvar('abswnd_da', 'x y', ndouble, 8) + call ncdefvar('ficem_da', 'x y', ndouble, 8) + call ncdefvar('lamult_da', 'x y', ndouble, 8) + call ncdefvar('lasl_da', 'x y', ndouble, 8) + call ncdefvar('ustokes_da', 'x y', ndouble, 8) + call ncdefvar('vstokes_da', 'x y', ndouble, 8) call ncdefvar('atmco2_da', 'x y', ndouble, 8) call ncdefvar('atmbrf_da', 'x y', ndouble, 8) call ncdefvar('ztx_da', 'x y', ndouble, 8) @@ -242,14 +256,22 @@ subroutine getfrc_cesm ip, 1, 1._r8, 0._r8, 8) call ncwrtr('slp_da', 'x y', slp_da(1 - nbdy, 1 - nbdy, l2ci), & ip, 1, 1._r8, 0._r8, 8) + call ncwrtr('abswnd_da', 'x y', abswnd_da(1 - nbdy, 1 - nbdy, l2ci), & + ip, 1, 1._r8, 0._r8, 8) call ncwrtr('ficem_da', 'x y', ficem_da(1 - nbdy, 1 - nbdy, l2ci), & ip, 1, 1._r8, 0._r8, 8) - call ncwrtr('abswnd_da', 'x y', abswnd_da(1 - nbdy, 1 - nbdy, l2ci), & + call ncwrtr('lamult_da', 'x y', lamult_da(1 - nbdy, 1 - nbdy, l2ci), & + ip, 1, 1._r8, 0._r8, 8) + call ncwrtr('lasl_da', 'x y', lasl_da(1 - nbdy, 1 - nbdy, l2ci), & + ip, 1, 1._r8, 0._r8, 8) + call ncwrtr('ustokes_da', 'x y', ustokes_da(1 - nbdy, 1 - nbdy, l2ci), & + ip, 1, 1._r8, 0._r8, 8) + call ncwrtr('vstokes_da', 'x y', vstokes_da(1 - nbdy, 1 - nbdy, l2ci), & ip, 1, 1._r8, 0._r8, 8) call ncwrtr('atmco2_da', 'x y', atmco2_da(1 - nbdy, 1 - nbdy, l2ci), & ip, 1, 1._r8, 0._r8, 8) call ncwrtr('atmbrf_da', 'x y', atmbrf_da(1 - nbdy, 1 - nbdy, l2ci), & - . ip, 1, 1._r8, 0._r8, 8) + ip, 1, 1._r8, 0._r8, 8) call ncwrtr('ztx_da', 'x y', ztx_da(1 - nbdy, 1 - nbdy, l2ci), & iu, 1, 1._r8, 0._r8, 8) call ncwrtr('mty_da', 'x y', mty_da(1 - nbdy, 1 - nbdy, l2ci), & @@ -277,8 +299,12 @@ subroutine getfrc_cesm call chksummsk(nsf, ip, 1, 'nsf') call chksummsk(hmlt, ip, 1, 'hmlt') call chksummsk(slp, ip, 1, 'slp') - call chksummsk(ficem, ip, 1, 'ficem') call chksummsk(abswnd, ip, 1, 'abswnd') + call chksummsk(ficem, ip, 1, 'ficem') + call chksummsk(lamult, ip, 1, 'lamult') + call chksummsk(lasl, ip, 1, 'lasl') + call chksummsk(ustokes, ip, 1, 'ustokes') + call chksummsk(vstokes, ip, 1, 'vstokes') call chksummsk(atmco2, ip, 1, 'atmco2') call chksummsk(atmbrf, ip, 1, 'atmbrf') endif diff --git a/cesm/sfcstr_cesm.F b/cesm/sfcstr_cesm.F index b352cbfd..d0d047b7 100644 --- a/cesm/sfcstr_cesm.F +++ b/cesm/sfcstr_cesm.F @@ -1,5 +1,5 @@ ! ------------------------------------------------------------------------------ -! Copyright (C) 2015-2020 Mats Bentsen +! Copyright (C) 2015-2022 Mats Bentsen, Mehmet Ilicak ! ! This file is part of BLOM. ! @@ -24,6 +24,7 @@ subroutine sfcstr_cesm(m,n,mm,nn,k1m,k1n) c --- ------------------------------------------------------------------ c use mod_xc + use mod_constants, only: P_mks2cgs use mod_forcing, only: ztx, mty, taux, tauy use mod_checksum, only: csdiag, chksummsk c @@ -37,12 +38,12 @@ subroutine sfcstr_cesm(m,n,mm,nn,k1m,k1n) do j=1,jj do l=1,isu(j) do i=max(1,ifu(j,l)),min(ii,ilu(j,l)) - taux(i,j)=10.*ztx(i,j) + taux(i,j)=P_mks2cgs*ztx(i,j) enddo enddo do l=1,isv(j) do i=max(1,ifv(j,l)),min(ii,ilv(j,l)) - tauy(i,j)=10.*mty(i,j) + tauy(i,j)=P_mks2cgs*mty(i,j) enddo enddo enddo diff --git a/cesm/thermf_cesm.F b/cesm/thermf_cesm.F index 49e29e06..9b9740a0 100644 --- a/cesm/thermf_cesm.F +++ b/cesm/thermf_cesm.F @@ -1,5 +1,5 @@ ! ------------------------------------------------------------------------------ -! Copyright (C) 2008-2020 Mats Bentsen +! Copyright (C) 2008-2022 Mats Bentsen, Mehmet Ilicak ! ! This file is part of BLOM. ! @@ -21,7 +21,8 @@ subroutine thermf_cesm(m,n,mm,nn,k1m,k1n) c c --- NERSC version of thermf. To be used when coupled to CESM c - use mod_constants, only: g, spcifh, t0deg, epsil, onem + use mod_constants, only: g, spcifh, t0deg, alpha0, epsilt, onem, + . g2kg, kg2g, L_mks2cgs, M_mks2cgs use mod_time, only: nstep, nstep_in_day, nday_in_year, . nday_of_year, baclin, . xmi, l1mi, l2mi, l3mi, l4mi, l5mi @@ -61,7 +62,7 @@ subroutine thermf_cesm(m,n,mm,nn,k1m,k1n) integer i,j,k,l,m1,m2,m3,m4,m5 real y,dpotl,hotl,totl,sotl,dpmxl,hmxl,tmxl,smxl,tice_f,fwflx, . sstc,rice,trxflx,sssc,srxflx,totsfl,totwfl,sflxc,totsrp, - . totsrn,qp,qn + . totsrn,qp,qn,A_cgs2mks #ifdef TRC integer nt real, dimension(ntr,1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy) :: @@ -72,6 +73,8 @@ subroutine thermf_cesm(m,n,mm,nn,k1m,k1n) real intp1d external intp1d c + A_cgs2mks=1./(L_mks2cgs**2) +c c --- Set parameters for time interpolation when applying diagnosed heat c --- and salt relaxation fluxes y=(nday_of_year-1+mod(nstep,nstep_in_day)/real(nstep_in_day))*48. @@ -132,10 +135,10 @@ subroutine thermf_cesm(m,n,mm,nn,k1m,k1n) c c --- --- Salt flux due to brine rejection of freezing sea c --- --- ice [kg m-2 m-1] (positive downwards) - brnflx(i,j)=max(0.,-sotl*fmltfz(i,j)*1.e-3+sfl(i,j)) + brnflx(i,j)=max(0.,-sotl*fmltfz(i,j)*g2kg+sfl(i,j)) c c --- --- Virtual salt flux [kg m-2 s-1] (positive downwards) - vrtsfl(i,j)=-sotl*fwflx*1.e-3 + vrtsfl(i,j)=-sotl*fwflx*g2kg c c --- --- Store area weighted virtual salt flux and fresh water flux util1(i,j)=vrtsfl(i,j)*scp2(i,j) @@ -150,20 +153,21 @@ subroutine thermf_cesm(m,n,mm,nn,k1m,k1n) c --- --- be heated. Note the freezing potential is multiplied by 1/2 c --- --- due to the leap-frog time stepping. The melting potential uses c --- --- time averaged quantities since it is not accumulated. - frzpot(i,j)=max(0.,tice_f-totl)*spcifh*dpotl/(2.*g)*1.e4 + frzpot(i,j)=max(0.,tice_f-totl)*spcifh*dpotl + . /(2.*g)*(L_mks2cgs**2) mltpot(i,j)= . min(0.,tfrzm(i,j)-.5*(temp(i,j,k1m)+temp(i,j,k1n))) - . *spcifh*.5*(dp(i,j,k1m)+dp(i,j,k1n))/g*1.e4 + . *spcifh*.5*(dp(i,j,k1m)+dp(i,j,k1n))/g*(L_mks2cgs**2) c c --- --- Heat flux due to melting/freezing [W m-2] (positive downwards) hmltfz(i,j)=hmlt(i,j)+frzpot(i,j)/baclin c c --- --- Total heat flux in BLOM units [W cm-2] (positive upwards) - surflx(i,j)=-(swa(i,j)+nsf(i,j)+hmltfz(i,j))*1.e-4 + surflx(i,j)=-(swa(i,j)+nsf(i,j)+hmltfz(i,j))*A_cgs2mks c c --- --- Short-wave heat flux in BLOM units [W cm-2] (positive c --- --- upwards) - sswflx(i,j)=-swa(i,j)*1.e-4 + sswflx(i,j)=-swa(i,j)*A_cgs2mks c #ifdef TRC c --- ------------------------------------------------------------------ @@ -182,7 +186,7 @@ subroutine thermf_cesm(m,n,mm,nn,k1m,k1n) if (nt.eq.itrgls) then trflx(nt,i,j)=-gls_n*difdia(i,j,1)*(gls_cmu0**gls_p) . *(trc(i,j,k1n,itrtke)**gls_m) - . *(vonKar**gls_n)*Zos**(gls_n-1.) + . *(vonKar**gls_n)*zos**(gls_n-1.) ttrsf(nt,i,j)=0. ttrav(nt,i,j)=0. cycle @@ -196,11 +200,12 @@ subroutine thermf_cesm(m,n,mm,nn,k1m,k1n) endif # endif # endif - trflx(nt,i,j)=-trc(i,j,k1n,nt)*fwflx*1.e-3 + trflx(nt,i,j)=-trc(i,j,k1n,nt)*fwflx*g2kg ttrsf(nt,i,j)=trflx(nt,i,j)*scp2(i,j) ttrav(nt,i,j)=trc(i,j,k1n,nt)*scp2(i,j) enddo #endif +c c --- ------------------------------------------------------------------ c --- --- Relaxation fluxes c --- ------------------------------------------------------------------ @@ -208,7 +213,7 @@ subroutine thermf_cesm(m,n,mm,nn,k1m,k1n) surrlx(i,j)=0. c c --- --- If trxday>0 , apply relaxation towards observed sst - if (trxday.gt.epsil) then + if (trxday.gt.epsilt) then sstc=intp1d(sstclm(i,j,l1mi),sstclm(i,j,l2mi), . sstclm(i,j,l3mi),sstclm(i,j,l4mi), . sstclm(i,j,l5mi),xmi) @@ -216,8 +221,8 @@ 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 - trxflx=spcifh*100.*min(hmxl,trxdpt)/(trxday*86400.) - . *min(trxlim,max(-trxlim,sstc-tmxl)) + trxflx=spcifh*L_mks2cgs*min(hmxl,trxdpt)/(trxday*86400.) + . *min(trxlim,max(-trxlim,sstc-tmxl))/alpha0 surrlx(i,j)=-trxflx else trxflx=0. @@ -239,12 +244,12 @@ subroutine thermf_cesm(m,n,mm,nn,k1m,k1n) salrlx(i,j)=0. c c --- --- if srxday>0 , apply relaxation towards observed sss - if (srxday.gt.epsil) then + if (srxday.gt.epsilt) then sssc=intp1d(sssclm(i,j,l1mi),sssclm(i,j,l2mi), . sssclm(i,j,l3mi),sssclm(i,j,l4mi), . sssclm(i,j,l5mi),xmi) - srxflx=100.*min(hmxl,srxdpt)/(srxday*86400.) - . *min(srxlim,max(-srxlim,sssc-smxl)) + srxflx=L_mks2cgs*min(hmxl,srxdpt)/(srxday*86400.) + . *min(srxlim,max(-srxlim,sssc-smxl))/alpha0 salrlx(i,j)=-srxflx util3(i,j)=max(0.,salrlx(i,j))*scp2(i,j) util4(i,j)=min(0.,salrlx(i,j))*scp2(i,j) @@ -269,7 +274,7 @@ subroutine thermf_cesm(m,n,mm,nn,k1m,k1n) c --- --- Friction velocity (cm/s) c --- ------------------------------------------------------------------- c - ustar(i,j)=ustarw(i,j)*1.e2 + ustar(i,j)=ustarw(i,j)*L_mks2cgs c enddo enddo @@ -287,7 +292,7 @@ subroutine thermf_cesm(m,n,mm,nn,k1m,k1n) call xcsum(totwfl,util2,ips) c c --- Correction for the virtual salt flux [kg m-2 s-1] - sflxc=(-sref*totwfl*1.e-3-totsfl)/area + sflxc=(-sref*totwfl*g2kg-totsfl)/area if (mnproc.eq.1) then write (lp,*) 'thermf: totsfl/area,sflxc',totsfl/area,sflxc endif @@ -298,8 +303,10 @@ subroutine thermf_cesm(m,n,mm,nn,k1m,k1n) do j=1,jj do l=1,isp(j) do i=max(1,ifp(j,l)),min(ii,ilp(j,l)) - salflx(i,j)=-(vrtsfl(i,j)+sflxc+sfl(i,j))*1.e2 - brnflx(i,j)=-brnflx(i,j)*1.e2 + salflx(i,j)=-(vrtsfl(i,j)+sflxc+sfl(i,j)) + . *(kg2g*(M_mks2cgs/L_mks2cgs**2)) + brnflx(i,j)=-brnflx(i,j) + . *(kg2g*(M_mks2cgs/L_mks2cgs**2)) enddo enddo enddo @@ -308,7 +315,7 @@ subroutine thermf_cesm(m,n,mm,nn,k1m,k1n) c --- if srxday>0 and srxbal=.true. , balance the sss relaxation flux c --- so the net input of salt in grid cells connected to the world c --- ocean is zero - if (srxday.gt.epsil.and.srxbal) then + if (srxday.gt.epsilt.and.srxbal) then call xcsum(totsrp,util3,ipwocn) call xcsum(totsrn,util4,ipwocn) if (abs(totsrp-totsrn).gt.0.) then @@ -352,14 +359,14 @@ subroutine thermf_cesm(m,n,mm,nn,k1m,k1n) tottrav=tottrav/area c trflxc=(-tottrsf)/area -c trflxc=(-tottrav*totwfl*1.e-3-tottrsf)/area +c trflxc=(-tottrav*totwfl*g2kg-tottrsf)/area c trflxc=0. c c$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)) - trflx(nt,i,j)=-(trflx(nt,i,j)+trflxc)*1.e2 + trflx(nt,i,j)=-(trflx(nt,i,j)+trflxc)*L_mks2cgs enddo enddo enddo diff --git a/channel/mod_channel.F90 b/channel/mod_channel.F90 index e2d537da..350f5a9f 100644 --- a/channel/mod_channel.F90 +++ b/channel/mod_channel.F90 @@ -28,8 +28,8 @@ module mod_channel use mod_types, only: r8 use mod_constants, only: g, rearth, pi, radian use mod_xc - use mod_grid, only: sigmar, & - qclon, qclat, pclon, pclat, uclon, uclat, vclon, vclat, & + use mod_vcoord, only: 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, & qlon, qlat, plon, plat, ulon, ulat, vlon, vlat, & diff --git a/channel/thermf_channel.F b/channel/thermf_channel.F index bc0ee447..41a565f9 100644 --- a/channel/thermf_channel.F +++ b/channel/thermf_channel.F @@ -24,7 +24,7 @@ subroutine thermf_channel(m,n,mm,nn,k1m,k1n) use mod_xc use mod_types, only: r8 use mod_ben02, only: ntda - use mod_constants, only: spcifh, t0deg, epsil, onem + use mod_constants, only: spcifh, t0deg, epsilt, onem use mod_time, only: nday_in_year, nday_of_year, nstep, . nstep_in_day, baclin, . xmi, l1mi, l2mi, l3mi, l4mi, l5mi @@ -217,7 +217,7 @@ subroutine thermf_channel(m,n,mm,nn,k1m,k1n) surrlx(i,j)=0._r8 ! ! --- --- If trxday>0 , apply relaxation towards observed sst - if (trxday.gt.epsil) then + if (trxday.gt.epsilt) then sstc=intp1d(sstclm(i,j,l1mi),sstclm(i,j,l2mi), . sstclm(i,j,l3mi),sstclm(i,j,l4mi), . sstclm(i,j,l5mi),xmi) @@ -248,7 +248,7 @@ subroutine thermf_channel(m,n,mm,nn,k1m,k1n) salrlx(i,j)=0._r8 ! ! --- --- if srxday>0 , apply relaxation towards observed sss - if (srxday.gt.epsil) then + if (srxday.gt.epsilt) then sssc=intp1d(sssclm(i,j,l1mi),sssclm(i,j,l2mi), . sssclm(i,j,l3mi),sssclm(i,j,l4mi), . sssclm(i,j,l5mi),xmi) @@ -319,7 +319,7 @@ subroutine thermf_channel(m,n,mm,nn,k1m,k1n) ! --- if srxday>0 and srxbal=.true. , balance the sss relaxation flux ! --- so the net input of salt in grid cells connected to the world ! --- ocean is zero - if (srxday.gt.epsil.and.srxbal) then + if (srxday.gt.epsilt.and.srxbal) then call xcsum(totsrp,util3,ipwocn) call xcsum(totsrn,util4,ipwocn) if (abs(totsrp).gt.abs(totsrn)) then diff --git a/cime_config/buildcpp b/cime_config/buildcpp index 3ec77c32..c1e21a45 100644 --- a/cime_config/buildcpp +++ b/cime_config/buildcpp @@ -35,11 +35,12 @@ def create_dimmod(case): comp_root_dir_ocn = case.get_value("COMP_ROOT_DIR_OCN") ocn_grid = case.get_value("OCN_GRID") + blom_vcoord = case.get_value("BLOM_VCOORD") ntasks_ocn = case.get_value("NTASKS_OCN") objroot = case.get_value("OBJROOT") gridconf_dir = os.path.join(comp_root_dir_ocn, "bld", ocn_grid) - kdm_file = os.path.join(gridconf_dir, "kdm") + kdm_file = os.path.join(gridconf_dir, "kdm." + blom_vcoord) blom_dimensions_script = os.path.join(comp_root_dir_ocn, "bld", "blom_dimensions") try: @@ -77,6 +78,7 @@ def buildcpp(case): # Determine the CPP flags values needed to build the blom component ocn_grid = case.get_value("OCN_GRID") + blom_vcoord = case.get_value("BLOM_VCOORD") turbclo = case.get_value("BLOM_TURBULENT_CLOSURE") tracers = case.get_value("BLOM_TRACER_MODULES") co2type = case.get_value("OCN_CO2_TYPE") @@ -87,6 +89,9 @@ def buildcpp(case): hamocc_sedbypass = case.get_value("HAMOCC_SEDBYPASS") hamocc_ciso = case.get_value("HAMOCC_CISO") hamocc_vsls = case.get_value("HAMOCC_VSLS") + blom_unit = case.get_value("BLOM_UNIT") + + expect(blom_vcoord != "cntiso_hybrid" or not turbclo, "BLOM_VCOORD == {} and BLOM_TURBULENT_CLOSURE == {} is not a valid combination".format(blom_vcoord, turbclo)) blom_cppdefs = "" @@ -96,10 +101,10 @@ def buildcpp(case): if ocn_grid in ["gx1v5", "gx1v6", "tnx1v1", "tnx1v3", "tnx1v4", "tnx0.25v1", "tnx0.25v3", "tnx0.25v4", "tnx0.125v4"]: blom_cppdefs = blom_cppdefs + " -DLEVITUS2X" - if turbclo != 0 or tracers != 0: + if turbclo or tracers: blom_cppdefs = blom_cppdefs + " -DTRC" - if turbclo != 0: + if turbclo: twoeq = False oneeq = False for option in turbclo.split(): @@ -118,7 +123,7 @@ def buildcpp(case): expect(twoeq or oneeq, "For turbulent closure either twoeq or oneeq must be provided as options") expect(not twoeq or not oneeq, "Do not use both twoeq and oneeq as options for turbulent closure") - if tracers != 0: + if tracers: for module in tracers.split(): if module == "iage": blom_cppdefs = blom_cppdefs + " -DIDLAGE" @@ -148,6 +153,11 @@ def buildcpp(case): else: expect(False, "tracer module {} is not recognized".format(module)) + if blom_unit == "mks": + blom_cppdefs = blom_cppdefs + " -DMKS" + else: + expect(blom_unit == "cgs", "Unit system {} is not recognized".format(blom_unit)) + blom_cppdefs = "-DMPI" + blom_cppdefs # update the xml variable BLOM_CPPDEFS with the above definition diff --git a/cime_config/buildlib_2.1 b/cime_config/buildlib_2.1 index 7d3c9ea9..a46abbdd 100755 --- a/cime_config/buildlib_2.1 +++ b/cime_config/buildlib_2.1 @@ -64,6 +64,7 @@ def _main_func(): os.path.join(comp_root_dir_ocn, "fuk95"), 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, "phy")] if turbclo != 0 and tracers != 0: @@ -78,11 +79,9 @@ def _main_func(): else: expect(False, "tracer module {} is not recognized".format(module)) - if driver == "nuopc": - expect(False, "NUOPC driver not supported") + expect(driver != "nuopc", "NUOPC driver not supported") if driver == "mct": - paths.append(os.path.join(comp_root_dir_ocn, "drivers", "cpl_share")) - paths.append(os.path.join(comp_root_dir_ocn, "drivers", "cpl_mct")) + paths.append(os.path.join(comp_root_dir_ocn, "drivers", "mct")) with open(filepath_file, "w") as filepath: filepath.write("\n".join(paths)) diff --git a/cime_config/buildlib_2.2 b/cime_config/buildlib_2.2 index 558d965e..d069e2eb 100755 --- a/cime_config/buildlib_2.2 +++ b/cime_config/buildlib_2.2 @@ -65,6 +65,7 @@ def _main_func(): os.path.join(comp_root_dir_ocn, "fuk95"), 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, "phy")] if turbclo != 0 and tracers != 0: @@ -79,11 +80,12 @@ def _main_func(): else: expect(False, "tracer module {} is not recognized".format(module)) - if driver == "nuopc": - expect(False, "NUOPC driver not supported") if driver == "mct": - paths.append(os.path.join(comp_root_dir_ocn, "drivers", "cpl_share")) - paths.append(os.path.join(comp_root_dir_ocn, "drivers", "cpl_mct")) + paths.append(os.path.join(comp_root_dir_ocn, "drivers", "mct")) + elif driver == "nuopc": + paths.append(os.path.join(comp_root_dir_ocn, "drivers", "nuopc")) + else: + expect(False, "Driver {} is not supported".format(driver)) with open(filepath_file, "w") as filepath: filepath.write("\n".join(paths)) diff --git a/cime_config/buildnml b/cime_config/buildnml index 52018d93..414850d5 100755 --- a/cime_config/buildnml +++ b/cime_config/buildnml @@ -6,6 +6,8 @@ set CASEROOT = `./xmlquery CASEROOT --value` set OCN_GRID = `./xmlquery OCN_GRID --value` +set BLOM_VCOORD = `./xmlquery BLOM_VCOORD --value` +set BLOM_UNIT = `./xmlquery BLOM_UNIT --value` set DIN_LOC_ROOT = `./xmlquery DIN_LOC_ROOT --value` set RUN_TYPE = `./xmlquery RUN_TYPE --value` set CONTINUE_RUN = `./xmlquery CONTINUE_RUN --value` @@ -73,46 +75,48 @@ set EXPCNF = "'cesm'" set RUNTYP = "'$RUN_TYPE'" set GRFILE = "'unset'" set ICFILE = "'unset'" -set PREF = 2000.e5 +if ($BLOM_UNIT == cgs) then + set PREF = 2000.e5 +else + set PREF = 2000.e4 +endif set BACLIN = 1800. set BATROP = 36. -set MDV2HI = 2. -set MDV2LO = .4 -set MDV4HI = 0. -set MDV4LO = 0. -set MDC2HI = 5000.e4 -set MDC2LO = 300.e4 +if ($BLOM_UNIT == cgs) then + set MDV2HI = 2. + set MDV2LO = .4 + set MDV4HI = 0. + set MDV4LO = 0. + set MDC2HI = 5000.e4 + set MDC2LO = 300.e4 +else + set MDV2HI = .02 + set MDV2LO = .004 + set MDV4HI = 0. + set MDV4LO = 0. + set MDC2HI = 5000. + set MDC2LO = 300. +endif set VSC2HI = .5 set VSC2LO = .5 set VSC4HI = 0. set VSC4LO = 0. -set CBAR = 5. +if ($BLOM_UNIT == cgs) then + set CBAR = 5. +else + set CBAR = .05 +endif set CB = .002 set CWBDTS = 5.e-5 set CWBDLS = 25. set MOMMTH = "'enscon'" -set EITMTH = "'gm'" -set EDRITP = "'large scale'" set BMCMTH = "'uc'" set RMPMTH = "'eitvel'" -set EDWMTH = "'smooth'" set MLRTTP = "'constant'" -set EDSPRS = .true. -set EGC = 0.85 -set EGGAM = 200. -set EGLSMN = 4000.e2 -set EGMNDF = 100.e4 -set EGMXDF = 1500.e4 -set EGIDFQ = 1. -set RI0 = 1.2 set RM0 = 1.2 set RM5 = 0. set CE = .06 -set BDMTYP = 2 -set BDMC1 = 5.e-4 -set BDMC2 = .1 set TDFILE = "'unset'" -set TKEPF = .006 set NIWGF = 0. set NIWBF = .35 set NIWLF = .5 @@ -137,6 +141,8 @@ set SPRFAC = .false. set ATM_PATH = "'unset'" set ITEST = 60 set JTEST = 60 +set CNSVDI = .false. +set CSDIAG = .false. set RSTFRQ = 1 if ($PIO_NETCDF_FORMAT_OCN == 64bit_offset) then set RSTFMT = 1 @@ -150,6 +156,55 @@ else set IOTYPE = 0 endif +# set VCOORD defaults +set VCOORD_TYPE = "'$BLOM_VCOORD'" +set RECONSTRUCTION_METHOD = "'ppm'" +set DENSITY_LIMITING = "'monotonic'" +set TRACER_LIMITING = "'non_oscillatory'" +set VELOCITY_LIMITING = "'non_oscillatory'" +set DENSITY_PC_UPPER_BNDR = .false. +set DENSITY_PC_LOWER_BNDR = .false. +set TRACER_PC_UPPER_BNDR = .true. +set TRACER_PC_LOWER_BNDR = .false. +set VELOCITY_PC_UPPER_BNDR = .true. +set VELOCITY_PC_LOWER_BNDR = .false. +set DPMIN_SURFACE = 2.5 +set DPMIN_INFLATION_FACTOR = 1.08 +set DPMIN_INTERIOR = .1 + +# set DIFFUSION defaults +set EITMTH = "'gm'" +set EDRITP = "'large scale'" +set EDWMTH = "'smooth'" +set EDSPRS = .true. +set EGC = 0.85 +set EGGAM = 200. +if ($BLOM_UNIT == cgs) then + set EGLSMN = 4000.e2 + set EGMNDF = 100.e4 + set EGMXDF = 1500.e4 +else + set EGLSMN = 4000. + set EGMNDF = 100. + set EGMXDF = 1500. +endif +set EGIDFQ = 1. +set RI0 = 1.2 +set BDMTYP = 2 +if ($BLOM_UNIT == cgs) then + set BDMC1 = 5.e-4 + set BDMC2 = .1 +else + set BDMC1 = 5.e-8 + set BDMC2 = 1.e-5 +endif +set TKEPF = .006 +if ($BLOM_VCOORD == isopyc_bulkml) then + set LTEDTP = "'layer'" +else + set LTEDTP = "'neutral'" +endif + # set BGCNML defaults set ATM_CO2 = $CCSM_CO2_PPMV if ($BLOM_RIVER_NUTRIENTS == TRUE) then @@ -183,11 +238,11 @@ if ($BLOM_N_DEPOSITION == TRUE) then set NDEPFNAME = ndep_201501-210012-${BLOM_NDEP_SCENARIO}_tnx1v4_20191112.nc else if( $BLOM_NDEP_SCENARIO == UNSET ) then set DO_NDEP = .false. - set NDEPFNAME = "" + set NDEPFNAME = "''" endif else set DO_NDEP = .false. - set NDEPFNAME = "" + set NDEPFNAME = "''" endif if ($HAMOCC_SEDSPINUP == TRUE) then set DO_SEDSPINUP = .true. @@ -206,8 +261,22 @@ if ($HAMOCC_VSLS == TRUE && $OCN_GRID != tnx1v4) then echo "$0 ERROR: HAMOCC_VSLS == TRUE not possible with this grid resolution (no swa-climatology available) " exit -1 endif +# For the following options, there are currently no switches in Case-XML files. +# These options can be activated by expert users via user namelist. +set LM4AGO = .false. +set BGCOAFX_DO_OALK = .false. +set BGCOAFX_OALKSCEN = "''" +set BGCOAFX_OALKFILE = "''" +set BGCOAFX_ADDALK = 0.135 +set BGCOAFX_CDRMIP_LATMAX = 70.0 +set BGCOAFX_CDRMIP_LATMIN = -60.0 +set BGCOAFX_RAMP_START = 2025 +set BGCOAFX_RAMP_END = 2035 set WITH_DMSPH = .false. -set PI_PH_FILE = "" +set PI_PH_FILE = "''" +set L_3DVARSEDPOR = .false. +set SEDPORFILE = "''" + # set DIAPHY defaults set GLB_FNAMETAG = "'hd','hm','hy'" @@ -236,8 +305,6 @@ set H2D_IDKEDT = '0, 4, 0' set H2D_LIP = '0, 4, 0' set H2D_MAXMLD = '4, 4, 0' set H2D_MLD = '0, 4, 0' -set H2D_MLDU = '0, 0, 0' -set H2D_MLDV = '0, 0, 0' set H2D_MLTS = '4, 4, 0' set H2D_MLTSMN = '0, 4, 0' set H2D_MLTSMX = '0, 4, 0' @@ -249,8 +316,6 @@ set H2D_MTKERS = '0, 4, 0' set H2D_MTKEPE = '0, 4, 0' set H2D_MTKEKE = '0, 4, 0' set H2D_MTY = '0, 4, 0' -set H2D_MXLU = '0, 4, 0' -set H2D_MXLV = '0, 4, 0' set H2D_NSF = '0, 4, 0' set H2D_PBOT = '0, 4, 0' set H2D_PSRF = '0, 4, 0' @@ -286,6 +351,9 @@ set H2D_VICE = '0, 0, 0' set H2D_ZTX = '0, 4, 0' set LYR_BFSQ = '0, 4, 0' set LYR_DIFDIA = '0, 4, 0' +set LYR_DIFVMO = '0, 4, 0' +set LYR_DIFVHO = '0, 4, 0' +set LYR_DIFVSO = '0, 4, 0' set LYR_DIFINT = '0, 4, 0' set LYR_DIFISO = '0, 4, 0' set LYR_DP = '0, 4, 0' @@ -305,11 +373,11 @@ set LYR_UVEL = '0, 4, 0' set LYR_VFLX = '0, 4, 0' set LYR_VTFLX = '0, 4, 0' set LYR_VSFLX = '0, 4, 0' -set LYR_VMFLTD = '0, 4, 0' -set LYR_VTFLTD = '0, 4, 0' -set LYR_VTFLLD = '0, 4, 0' -set LYR_VSFLTD = '0, 4, 0' -set LYR_VSFLLD = '0, 4, 0' +set LYR_VMFLTD = '0, 0, 4' +set LYR_VTFLTD = '0, 0, 4' +set LYR_VTFLLD = '0, 0, 4' +set LYR_VSFLTD = '0, 0, 4' +set LYR_VSFLLD = '0, 0, 4' set LYR_VVEL = '0, 4, 0' set LYR_WFLX = '0, 4, 0' set LYR_WFLX2 = '0, 4, 0' @@ -319,6 +387,9 @@ set LYR_GLS_PSI = '0, 4, 0' set LYR_IDLAGE = '0, 4, 0' set LVL_BFSQ = '0, 4, 0' set LVL_DIFDIA = '0, 4, 0' +set LVL_DIFVMO = '0, 4, 0' +set LVL_DIFVHO = '0, 4, 0' +set LVL_DIFVSO = '0, 4, 0' set LVL_DIFINT = '0, 4, 0' set LVL_DIFISO = '0, 4, 0' set LVL_DZ = '0, 4, 0' @@ -388,16 +459,23 @@ set SRF_ALKALI = '4, 2, 2' set SRF_SILICA = '0, 2, 2' set SRF_DIC = '4, 2, 2' set SRF_PHYTO = '4, 2, 2' +set SRF_PH = '0, 2, 2' set SRF_EXPORT = '0, 2, 2' set SRF_EXPOSI = '0, 2, 2' set SRF_EXPOCA = '0, 2, 2' set SRF_KWCO2 = '0, 2, 2' +set SRF_KWCO2KHM = '0, 2, 2' +set SRF_CO2KH = '0, 2, 2' +set SRF_CO2KHM = '0, 2, 2' set SRF_PCO2 = '0, 2, 2' +set SRF_PCO2M = '0, 2, 2' set SRF_CO2FXD = '4, 2, 2' set SRF_CO2FXU = '4, 2, 2' set SRF_OXFLUX = '0, 2, 2' set SRF_NIFLUX = '0, 2, 2' +set SRF_PN2OM = '0, 2, 2' set SRF_N2OFX = '0, 0, 2' +set SRF_PNH3 = '0, 2, 2' set SRF_ANH3FX = '0, 0, 2' set SRF_DMSFLUX = '0, 2, 2' set SRF_DMS = '0, 2, 2' @@ -409,6 +487,7 @@ set SRF_ATMO2 = '0, 2, 2' set SRF_ATMN2 = '0, 2, 2' set SRF_NATDIC = '0, 2, 2' set SRF_NATALKALI = '0, 2, 2' +set SRF_NATPH = '0, 2, 2' set SRF_NATPCO2 = '0, 2, 2' set SRF_NATCO2FX = '0, 2, 2' set SRF_CO213FXD = '0, 2, 2' @@ -468,6 +547,18 @@ set LYR_PHOSY_NH4 = '0, 0, 2' set LYR_PHOSY_NO3 = '0, 0, 2' set LYR_REMIN_AEROB = '0, 0, 2' set LYR_REMIN_SULF = '0, 0, 2' +set LYR_AGG_WS = '0, 0, 2' +set LYR_DYNVIS = '0, 0, 2' +set LYR_AGG_STICK = '0, 0, 2' +set LYR_AGG_STICKF = '0, 0, 2' +set LYR_AGG_DMAX = '0, 0, 2' +set LYR_AGG_AVDP = '0, 0, 2' +set LYR_AGG_AVRHOP = '0, 0, 2' +set LYR_AGG_AVDC = '0, 0, 2' +set LYR_AGG_DF = '0, 0, 2' +set LYR_AGG_B = '0, 0, 2' +set LYR_AGG_VRHOF = '0, 0, 2' +set LYR_AGG_VPOR = '0, 0, 2' set LYR_ALKALI = '0, 0, 2' set LYR_SILICA = '0, 0, 2' set LYR_DIC = '0, 0, 2' @@ -537,6 +628,18 @@ set LVL_PHOSY_NH4 = '0, 2, 2' set LVL_PHOSY_NO3 = '0, 2, 2' set LVL_REMIN_AEROB = '0, 2, 2' set LVL_REMIN_SULF = '0, 2, 2' +set LVL_AGG_WS = '0, 2, 2' +set LVL_DYNVIS = '0, 2, 2' +set LVL_AGG_STICK = '0, 0, 2' +set LVL_AGG_STICKF = '0, 0, 2' +set LVL_AGG_DMAX = '0, 2, 2' +set LVL_AGG_AVDP = '0, 2, 2' +set LVL_AGG_AVRHOP = '0, 2, 2' +set LVL_AGG_AVDC = '0, 0, 2' +set LVL_AGG_DF = '0, 2, 2' +set LVL_AGG_B = '0, 2, 2' +set LVL_AGG_VRHOF = '0, 2, 2' +set LVL_AGG_VPOR = '0, 0, 2' set LVL_ALKALI = '0, 2, 2' set LVL_SILICA = '0, 2, 2' set LVL_DIC = '0, 2, 2' @@ -585,6 +688,13 @@ set FLX_SEDIFFOX = '0, 0, 2' set FLX_SEDIFFN2 = '0, 0, 2' set FLX_SEDIFFNO3 = '0, 0, 2' set FLX_SEDIFFSI = '0, 0, 2' +set FLX_SEDIFFNH4 = '0, 0, 2' +set FLX_SEDIFFN2O = '0, 0, 2' +set FLX_SEDIFFNO2 = '0, 0, 2' +set FLX_BURSSO12 = '0, 0, 2' +set FLX_BURSSSC12 = '0, 0, 2' +set FLX_BURSSSSIL = '0, 0, 2' +set FLX_BURSSSTER = '0, 0, 2' set SDM_POWAIC = '0, 0, 2' set SDM_POWAAL = '0, 0, 2' set SDM_POWAPH = '0, 0, 2' @@ -592,6 +702,22 @@ set SDM_POWAOX = '0, 0, 2' set SDM_POWN2 = '0, 0, 2' set SDM_POWNO3 = '0, 0, 2' set SDM_POWASI = '0, 0, 2' +set SDM_POWNH4 = '0, 0, 2' +set SDM_POWN2O = '0, 0, 2' +set SDM_POWNO2 = '0, 0, 2' +set SDM_NITR_NH4 = '0, 0, 2' +set SDM_NITR_NO2 = '0, 0, 2' +set SDM_NITR_N2O_PROD = '0, 0, 2' +set SDM_NITR_NH4_OM = '0, 0, 2' +set SDM_NITR_NO2_OM = '0, 0, 2' +set SDM_DENIT_NO3 = '0, 0, 2' +set SDM_DENIT_NO2 = '0, 0, 2' +set SDM_DENIT_N2O = '0, 0, 2' +set SDM_DNRA_NO2 = '0, 0, 2' +set SDM_ANMX_N2_PROD = '0, 0, 2' +set SDM_ANMX_OM_PROD = '0, 0, 2' +set SDM_REMIN_AEROB = '0, 0, 2' +set SDM_REMIN_SULF = '0, 0, 2' set SDM_SSSO12 = '0, 0, 2' set SDM_SSSSIL = '0, 0, 2' set SDM_SSSC12 = '0, 0, 2' @@ -619,7 +745,11 @@ else if ($OCN_GRID == tnx2v1 ) then set BACLIN = 4800. set BATROP = 96. set EGC = 0.5 - set EGMXDF = 1000.e4 + if ($BLOM_UNIT == cgs) then + set EGMXDF = 1000.e4 + else + set EGMXDF = 1000. + endif set CWMTAG = "'Gibraltar','Gibraltar'" set CWMEDG = " 'u', 'u'" set CWMI = " 53, 54" @@ -629,7 +759,11 @@ else if ($OCN_GRID == tnx1.5v1 ) then set BACLIN = 4800. set BATROP = 96. set EGC = 0.5 - set EGMXDF = 1000.e4 + if ($BLOM_UNIT == cgs) then + set EGMXDF = 1000.e4 + else + set EGMXDF = 1000. + endif else if ($OCN_GRID == tnx1v1 || $OCN_GRID == tnx1v3 || $OCN_GRID == tnx1v4) then if ($OCN_NCPL == 24) then set BACLIN = 3600. @@ -650,33 +784,58 @@ else if ($OCN_GRID == tnx1v1 || $OCN_GRID == tnx1v3 || $OCN_GRID == tnx1v4) then else if ($OCN_GRID == tnx0.25v1 || $OCN_GRID == tnx0.25v3 || $OCN_GRID == tnx0.25v4) then set BACLIN = 900. set BATROP = 15. - set MDV2HI = .15 - set MDV2LO = .15 + if ($BLOM_UNIT == cgs) then + set MDV2HI = .15 + set MDV2LO = .15 + set MDV4HI = 0. + set MDV4LO = 0. + set MDC2HI = 300.e4 + set MDC2LO = 300.e4 + else + set MDV2HI = .0015 + set MDV2LO = .0015 + set MDV4HI = 0. + set MDV4LO = 0. + set MDC2HI = 300. + set MDC2LO = 300. + endif set VSC2HI = .15 set VSC2LO = .15 set VSC4HI = 0.0625 set VSC4LO = 0.0625 - set MDC2HI = 300.e4 set CWBDTS = 0.75e-4 set CWBDLS = 25. set EDWMTH = "'step'" set EGC = 0.85 - set EGMXDF = 1500.e4 + if ($BLOM_UNIT == cgs) then + set EGMXDF = 1500.e4 + else + set EGMXDF = 1500. + endif set CE = 1.0 else if ($OCN_GRID == tnx0.125v4) then set BACLIN = 300. set BATROP = 6. - set EGMNDF = 0.0 - set EGMXDF = 0.0 + set EGMNDF = 0. + set EGMXDF = 0. set EDWMTH = "'step'" set CWBDTS = .75e-4 set CWBDLS = 25 - set MDV2HI = .5 - set MDV2LO = .1 - set MDV4HI = 0. - set MDV4LO = 0. - set MDC2HI = 300.e4 - set MDC2LO = 100.e4 + if ($BLOM_UNIT == cgs) then + set MDV2HI = .5 + set MDV2LO = .1 + set MDV4HI = 0. + set MDV4LO = 0. + set MDC2HI = 300.e4 + set MDC2LO = 100.e4 + else + set MDV2HI = .005 + set MDV2LO = .001 + set MDV4HI = 0. + set MDV4LO = 0. + set MDC2HI = 300. + set MDC2LO = 100. + endif set VSC2HI = .5 set VSC2LO = .5 set VSC4HI = 0.0 @@ -712,6 +871,7 @@ if ($OCN_GRID == tnx2v1) then set SCFILE = "'$DIN_LOC_ROOT/ocn/blom/bndcon/sss_clim_core_tnx2v1_20130927.nc'" set FEDEPFILE = "'$DIN_LOC_ROOT/ocn/blom/bndcon/dustdep_mhw2006_tnx2v1_20130506.nc'" set SWACLIMFILE = "''" + set SEDPORFILE = "''" if ($BLOM_RIVER_NUTRIENTS == TRUE) then set RIVINFILE = "'$DIN_LOC_ROOT/ocn/blom/bndcon/river_nutrients_GNEWS2000_tnx2v1_20170915.nc'" else @@ -732,6 +892,7 @@ else if ($OCN_GRID == tnx1v4) then set CCFILE = "'$DIN_LOC_ROOT/ocn/blom/bndcon/chlorophyll_concentration_tnx1v4_20170608.nc'" set SCFILE = "'$DIN_LOC_ROOT/ocn/blom/bndcon/sss_clim_core_tnx1v4_20170604.nc'" set FEDEPFILE = "'$DIN_LOC_ROOT/ocn/blom/bndcon/dustdep_mhw2006_tnx1v4_20171107.nc'" + set SEDPORFILE = "''" if ($HAMOCC_VSLS == TRUE) then set SWACLIMFILE = "'$DIN_LOC_ROOT/ocn/blom/bndcon/Annual_clim_swa_tnx1v4_20210415.nc'" else @@ -758,6 +919,7 @@ else if ($OCN_GRID == tnx0.25v4) then set SCFILE = "'$DIN_LOC_ROOT/ocn/blom/bndcon/sss_clim_core_tnx0.25v4_20170623.nc'" set FEDEPFILE = "'$DIN_LOC_ROOT/ocn/blom/bndcon/dustdep_mhw2006_tnx0.25v4_20181004.nc'" set SWACLIMFILE = "''" + set SEDPORFILE = "''" if ($BLOM_RIVER_NUTRIENTS == TRUE) then set RIVINFILE = "'$DIN_LOC_ROOT/ocn/blom/bndcon/river_nutrients_GNEWS2000_tnx0.25v4_20170821.nc'" else @@ -779,6 +941,7 @@ else if ($OCN_GRID == tnx0.125v4) then set SCFILE = "'$DIN_LOC_ROOT/ocn/blom/bndcon/sss_clim_core_tnx0.125v4_20200722.nc'" set FEDEPFILE = "'$DIN_LOC_ROOT/ocn/blom/bndcon/dustdep_mhw2006_tnx0.125v4_20200722.nc'" set SWACLIMFILE = "''" + set SEDPORFILE = "''" if ($BLOM_RIVER_NUTRIENTS == TRUE) then set RIVINFILE = "'$DIN_LOC_ROOT/ocn/blom/bndcon/river_nutrients_GNEWS2000_tnx0.125v4_20170821.nc'" else @@ -851,48 +1014,21 @@ cat >! $RUNDIR/ocn_in$inststr << EOF ! 'enscon' (Sadourny (1975) enstrophy conserving), 'enecon' ! (Sadourny (1975) energy conserving), 'enedis' (Sadourny ! (1975) energy conserving with some dissipation) (a) -! EITMTH : Eddy-induced transport parameterization method. Valid -! methods: 'intdif', 'gm' (a) -! EDRITP : Type of Richardson number used in eddy diffusivity -! computation. Valid types: 'shear', 'large scale' (a) ! BMCMTH : Baroclinic mass flux correction method. Valid methods: ! 'uc' (upstream column), 'dluc' (depth limited upstream ! column) (a) ! RMPMTH : Method of applying eddy-induced transport in the remap ! transport algorithm. Valid methods: 'eitvel', 'eitflx' (a) -! EDWMTH : Method to estimate eddy diffusivity weight as a function of -! the ration of Rossby radius of deformation to the -! horizontal grid spacing. Valid methods: 'smooth', 'step' (a) ! MLRTTP : Type of mixed layer restratification time scale. Valid ! types: 'variable', 'constant', 'limited' (a) -! EDSPRS : Apply eddy mixing suppression away from steering level (l) -! EGC : Parameter c in Eden and Greatbatch (2008) parameterization (f) -! EGGAM : Parameter gamma in E. & G. (2008) param. (f) -! EGLSMN : Minimum eddy length scale in E. & G. (2008) param. (cm) (f) -! EGMNDF : Minimum diffusivity in E. & G. (2008) param. (cm**2/s) (f) -! EGMXDF : Maximum diffusivity in E. & G. (2008) param. (cm**2/s) (f) -! EGIDFQ : Factor relating the isopycnal diffusivity to the layer -! interface diffusivity in the Eden and Greatbatch (2008) -! parameterization. egidfq=difint/difiso () (f) -! RI0 : Critical gradient richardson number for shear driven -! vertical mixing () (f) ! RM0 : Efficiency factor of wind TKE generation in the Oberhuber ! (1993) TKE closure () (f) ! RM5 : Efficiency factor of TKE generation by momentum ! entrainment in the Oberhuber (1993) TKE closure () (f) ! CE : Efficiency factor for the restratification by mixed layer ! eddies (Fox-Kemper et al., 2008) () (f) -! BDMTYP : Type of background diapycnal mixing. If bdmtyp=1 the -! background diffusivity is a constant divided by the -! Brunt-Vaisala frequency, if bdmtyp=2 the background -! diffusivity is constant () (i) -! BDMC1 : Background diapycnal diffusivity times buoyancy frequency -! frequency (cm**2/s**2) (f) -! BDMC2 : Background diapycnal diffusivity (cm**2/s) (f) ! TDFILE : Name of file containing tidal wave energy dissipation ! divided by by bottom buoyancy frequency (a) -! TKEPF : Fraction of surface TKE that penetrates beneath mixed layer -! () (f) ! NIWGF : Global factor applied to the energy input by near-intertial ! motions () (f) ! NIWBF : Fraction of near-inertial energy dissipated in the boundary @@ -923,6 +1059,8 @@ cat >! $RUNDIR/ocn_in$inststr << EOF ! 'ben02syn' (a) ! ITEST : Global i-index of point diagnostics (i) ! JTEST : Global j-index of point diagnostics (i) +! CNSVDI : Conservation diagnostics flag (l) +! CSDIAG : Checksum diagnostics flag (l) ! RSTFRQ : Restart frequency in days (30=1month,365=1year) (i) ! RSTFMT : Format of restart file (valid arguments are 0 for classic, ! 1 for 64-bit offset and 2 for netcdf4/hdf5 format) (i) @@ -956,28 +1094,13 @@ cat >! $RUNDIR/ocn_in$inststr << EOF CWBDTS = $CWBDTS CWBDLS = $CWBDLS MOMMTH = $MOMMTH - EITMTH = $EITMTH - EDRITP = $EDRITP BMCMTH = $BMCMTH RMPMTH = $RMPMTH - EDWMTH = $EDWMTH MLRTTP = $MLRTTP - EDSPRS = $EDSPRS - EGC = $EGC - EGGAM = $EGGAM - EGLSMN = $EGLSMN - EGMNDF = $EGMNDF - EGMXDF = $EGMXDF - EGIDFQ = $EGIDFQ - RI0 = $RI0 RM0 = $RM0 RM5 = $RM5 CE = $CE - BDMTYP = $BDMTYP - BDMC1 = $BDMC1 - BDMC2 = $BDMC2 TDFILE = $TDFILE - TKEPF = $TKEPF NIWGF = $NIWGF NIWBF = $NIWBF NIWLF = $NIWLF @@ -1002,6 +1125,8 @@ cat >! $RUNDIR/ocn_in$inststr << EOF ATM_PATH = $ATM_PATH ITEST = $ITEST JTEST = $JTEST + CNSVDI = $CNSVDI + CSDIAG = $CSDIAG RSTFRQ = $RSTFRQ RSTFMT = $RSTFMT RSTCMP = $RSTCMP @@ -1009,6 +1134,85 @@ cat >! $RUNDIR/ocn_in$inststr << EOF / EOF +if ($BLOM_VCOORD == cntiso_hybrid) then +cat >>! $RUNDIR/ocn_in$inststr << EOF + +&VCOORD + VCOORD_TYPE = $VCOORD_TYPE + RECONSTRUCTION_METHOD = $RECONSTRUCTION_METHOD + DENSITY_LIMITING = $DENSITY_LIMITING + TRACER_LIMITING = $TRACER_LIMITING + VELOCITY_LIMITING = $VELOCITY_LIMITING + DENSITY_PC_UPPER_BNDR = $DENSITY_PC_UPPER_BNDR + DENSITY_PC_LOWER_BNDR = $DENSITY_PC_LOWER_BNDR + TRACER_PC_UPPER_BNDR = $TRACER_PC_UPPER_BNDR + TRACER_PC_LOWER_BNDR = $TRACER_PC_LOWER_BNDR + VELOCITY_PC_UPPER_BNDR = $VELOCITY_PC_UPPER_BNDR + VELOCITY_PC_LOWER_BNDR = $VELOCITY_PC_LOWER_BNDR + DPMIN_SURFACE = $DPMIN_SURFACE + DPMIN_INFLATION_FACTOR = $DPMIN_INFLATION_FACTOR + DPMIN_INTERIOR = $DPMIN_INTERIOR +/ +EOF +endif + +cat >>! $RUNDIR/ocn_in$inststr << EOF + +! NAMELIST FOR DIFFUSION PARAMETERS +! +! CONTENTS: +! +! EITMTH : Eddy-induced transport parameterization method. Valid +! methods: 'intdif', 'gm' (a) +! EDRITP : Type of Richardson number used in eddy diffusivity +! computation. Valid types: 'shear', 'large scale' (a) +! EDWMTH : Method to estimate eddy diffusivity weight as a function of +! the ration of Rossby radius of deformation to the +! horizontal grid spacing. Valid methods: 'smooth', 'step' (a) +! MLRTTP : Type of mixed layer restratification time scale. Valid +! types: 'variable', 'constant', 'limited' (a) +! EDSPRS : Apply eddy mixing suppression away from steering level (l) +! EGC : Parameter c in Eden and Greatbatch (2008) parameterization (f) +! EGGAM : Parameter gamma in E. & G. (2008) param. (f) +! EGLSMN : Minimum eddy length scale in E. & G. (2008) param. (cm) (f) +! EGMNDF : Minimum diffusivity in E. & G. (2008) param. (cm**2/s) (f) +! EGMXDF : Maximum diffusivity in E. & G. (2008) param. (cm**2/s) (f) +! EGIDFQ : Factor relating the isopycnal diffusivity to the layer +! interface diffusivity in the Eden and Greatbatch (2008) +! parameterization. egidfq=difint/difiso () (f) +! RI0 : Critical gradient richardson number for shear driven +! vertical mixing () (f) +! BDMTYP : Type of background diapycnal mixing. If bdmtyp=1 the +! background diffusivity is a constant divided by the +! Brunt-Vaisala frequency, if bdmtyp=2 the background +! diffusivity is constant () (i) +! BDMC1 : Background diapycnal diffusivity times buoyancy frequency +! frequency (cm**2/s**2) (f) +! BDMC2 : Background diapycnal diffusivity (cm**2/s) (f) +! TKEPF : Fraction of surface TKE that penetrates beneath mixed layer +! () (f) +! LTEDTP : Type of lateral tracer eddy diffusion: Valid methods: +! 'layer', 'neutral'. +&DIFFUSION + EITMTH = $EITMTH + EDRITP = $EDRITP + EDWMTH = $EDWMTH + EDSPRS = $EDSPRS + EGC = $EGC + EGGAM = $EGGAM + EGLSMN = $EGLSMN + EGMNDF = $EGMNDF + EGMXDF = $EGMXDF + EGIDFQ = $EGIDFQ + RI0 = $RI0 + BDMTYP = $BDMTYP + BDMC1 = $BDMC1 + BDMC2 = $BDMC2 + TKEPF = $TKEPF + LTEDTP = $LTEDTP +/ +EOF + if ($?CWMTAG) then cat >>! $RUNDIR/ocn_in$inststr << EOF @@ -1135,8 +1339,6 @@ cat >>! $RUNDIR/ocn_in$inststr << EOF ! LIP - liquid precipitation [kg m-2 s-1] ! MAXMLD - maximum mixed layer depth [m] ! MLD - mixed layer depth [m] -! MLDU - mixed layer depth at u-point [m] -! MLDV - mixed layer depth at v-point [m] ! MLTS - mixed layer thickness using "sigma-t" criterion [m] ! MLTSMN - minimum mixed layer thickness using "sigma-t" criterion [m] ! MLTSMX - maximum mixed layer thickness using "sigma-t" criterion [m] @@ -1148,8 +1350,6 @@ cat >>! $RUNDIR/ocn_in$inststr << EOF ! MTKEPE - mixed layer TKE tendency related to pot. energy change [kg s-3] ! MTKEKE - mixed layer TKE tendency related to kin. energy change [kg s-3] ! MTY - wind stress y-component [N m-2] -! MXLU - mixed layer velocity x-component [m s-1] -! MXLV - mixed layer velocity y-component [m s-1] ! NSF - non-solar heat flux [W m-2] ! PBOT - bottom pressure [Pa] ! PSRF - surface pressure [Pa] @@ -1184,7 +1384,10 @@ cat >>! $RUNDIR/ocn_in$inststr << EOF ! VICE - ice velocity y-component [m s-1] ! ZTX - wind stress x-component [N m-2] ! BFSQ - buoyancy frequency squared [s-1] -! DIFDIA - diapycnal diffusivity [log10(m2 s-1)] +! DIFDIA - vertical diffusivity [log10(m2 s-1)|m2 s-1] +! DIFVMO - vertical momentum diffusivity [log10(m2 s-1)|m2 s-1] +! DIFVHO - vertical heat diffusivity [log10(m2 s-1)|m2 s-1] +! DIFVSO - vertical salt diffusivity [log10(m2 s-1)|m2 s-1] ! DIFINT - layer interface diffusivity [log10(m2 s-1)] ! DIFISO - isopycnal diffusivity [log10(m2 s-1)] ! DP - layer pressure thickness [Pa] @@ -1257,8 +1460,6 @@ cat >>! $RUNDIR/ocn_in$inststr << EOF H2D_LIP = $H2D_LIP H2D_MAXMLD = $H2D_MAXMLD H2D_MLD = $H2D_MLD - H2D_MLDU = $H2D_MLDU - H2D_MLDV = $H2D_MLDV H2D_MLTS = $H2D_MLTS H2D_MLTSMN = $H2D_MLTSMN H2D_MLTSMX = $H2D_MLTSMX @@ -1270,8 +1471,6 @@ cat >>! $RUNDIR/ocn_in$inststr << EOF H2D_MTKEPE = $H2D_MTKEPE H2D_MTKEKE = $H2D_MTKEKE H2D_MTY = $H2D_MTY - H2D_MXLU = $H2D_MXLU - H2D_MXLV = $H2D_MXLV H2D_NSF = $H2D_NSF H2D_PBOT = $H2D_PBOT H2D_PSRF = $H2D_PSRF @@ -1307,6 +1506,9 @@ cat >>! $RUNDIR/ocn_in$inststr << EOF H2D_ZTX = $H2D_ZTX LYR_BFSQ = $LYR_BFSQ LYR_DIFDIA = $LYR_DIFDIA + LYR_DIFVMO = $LYR_DIFVMO + LYR_DIFVHO = $LYR_DIFVHO + LYR_DIFVSO = $LYR_DIFVSO LYR_DIFINT = $LYR_DIFINT LYR_DIFISO = $LYR_DIFISO LYR_DP = $LYR_DP @@ -1340,6 +1542,9 @@ cat >>! $RUNDIR/ocn_in$inststr << EOF LYR_IDLAGE = $LYR_IDLAGE LVL_BFSQ = $LVL_BFSQ LVL_DIFDIA = $LVL_DIFDIA + LVL_DIFVMO = $LVL_DIFVMO + LVL_DIFVHO = $LVL_DIFVHO + LVL_DIFVSO = $LVL_DIFVSO LVL_DIFINT = $LVL_DIFINT LVL_DIFISO = $LVL_DIFISO LVL_DZ = $LVL_DZ @@ -1409,10 +1614,13 @@ cat >>! $RUNDIR/ocn_in$inststr << EOF ! SEDSPIN_YR_S: Start year for sediment spinup ! SEDSPIN_YR_E: End year for sediment spinup ! SEDSPIN_NCYC: Number of subcyles per time-step for sediment spinup +! LM4AGO : Switch for M4AGO settling scheme ! INIXXX : Initial condition file for iHAMOCC, where XXX=DIC, ALK, PO4, ! OXY, NO3, SIL, D13C, and D14C ! WITH_DMSPH : Logical switch to activate DMS calculation as function of pH ! PI_PH_FILE : File name (incl. full path) for surface PI pH input data. +! L_3DVARSEDPOR : Logical switch to enable lon-lat-depth variable sediment porosity (as opposed to default: only depth) +! SEDPORFILE : File name (incl. full path) for sediment porosity &BGCNML ATM_CO2 = $CCSM_CO2_PPMV FEDEPFILE = $FEDEPFILE @@ -1425,6 +1633,7 @@ cat >>! $RUNDIR/ocn_in$inststr << EOF SEDSPIN_YR_S = $SEDSPIN_YR_S SEDSPIN_YR_E = $SEDSPIN_YR_E SEDSPIN_NCYC = $SEDSPIN_NCYC + LM4AGO = $LM4AGO INIDIC = $INIDIC INIALK = $INIALK INIPO4 = $INIPO4 @@ -1435,6 +1644,30 @@ cat >>! $RUNDIR/ocn_in$inststr << EOF INID14C = $INID14C WITH_DMSPH = $WITH_DMSPH PI_PH_FILE = $PI_PH_FILE + L_3DVARSEDPOR = $L_3DVARSEDPOR + SEDPORFILE = $SEDPORFILE +/ + +! NAMELIST FOR ALKALINIZATION SCENARIO +! +! CONTENTS: +! +! ADDALK : Pmol alkalinity/yr added in the scenarios. +! CDRMIP_LATMAX : Max latitude where alkalinity is added according to the +! CDRMIP protocol +! CDRMIP_LATMIN : Min latitude where alkalinity is added according to the +! CDRMIP protocol +! RAMP_START : Start year for ramp up in 'ramp' scenario +! RAMP_END : End year for 'ramp' scenario +&BGCOAFX + DO_OALK = $BGCOAFX_DO_OALK + OALKSCEN = $BGCOAFX_OALKSCEN + OALKFILE = $BGCOAFX_OALKFILE + ADDALK = $BGCOAFX_ADDALK + CDRMIP_LATMAX = $BGCOAFX_CDRMIP_LATMAX + CDRMIP_LATMIN = $BGCOAFX_CDRMIP_LATMIN + RAMP_START = $BGCOAFX_RAMP_START + RAMP_END = $BGCOAFX_RAMP_END / ! IO-NAMELIST FOR DIAGNOSTIC iHAMOCC OUTPUT @@ -1481,8 +1714,10 @@ cat >>! $RUNDIR/ocn_in$inststr << EOF ! IRON - Dissolved iron (dfe) [mol Fe m-3] ! SILICA - Silicate (si) [mol Si m-3] ! PHYTO - Phytoplankton (phyc) [mol C m-3] +! PH - pH (ph) [-log10([h+])] ! NATDIC - Natural dissolved carbon (natdissic) [mol C m-3] ! NATALKALI - Natural alkalinity (nattalk) [eq m-3] +! NATPH - Natural pH (natph) [-log10([h+])] ! ! Other 3d tracer or diagnostic variables (LYR or LVL) ! DP - Layer thickness (pddpo) [m] @@ -1515,14 +1750,24 @@ cat >>! $RUNDIR/ocn_in$inststr << EOF ! PHOSY_NO3 - PP consumption of NH4 [mol NH4 m-3 s-1] - ext. N cycle only ! REMIN_AEROB - aerob remineralization rate (sev. sources) [mol NH4 m-3 s-1] - ext. N cycle only ! REMIN_SULF - sulfate-based remin rate on det [mol P m-3 s-1] - ext. N cycle only -! PH - pH (ph) [-log10([h+])] +! AGG_WS - M4AGO aggregate mean settling velocity [m/d] +! DYNVIS - molecular dynamic viscosity of sea water [kg m-1 s-1] +! AGG_STICK - mean stickiness of marine aggregates [-] +! AGG_STICKF - stickiness of opal frustule [-] +! AGG_DMAX - maximum aggregate diameter [m] +! AGG_AVDP - mean primary particle diameter [m] +! AGG_AVRHOP - mean primary particle density [kg/m3] +! AGG_AVDC - concentration weighted mean diameter of aggregates [m] +! AGG_DF - fractal dimension of aggregates [-] +! AGG_B - slope of aggregate number distribution [-] +! AGG_VRHOF - Volume-weighted mean aggregate density [kg m-3] +! AGG_VPOR - Volume weighted mean aggregate porosity [-] ! OMEGAA - Aragonite saturation state (omegaa) [1] ! OMEGAC - Calcite saturation state (omegac) [1] ! NATDIC - Natural dissolved carbon (natdissic) [mol C m-3] ! NATALKALI - Natural alkalinity (nattalk) [eq m-3] ! NATCO3 - Natural carbonate ion concentration (natco3) [mol C m-3] ! NATCALC - Natural CaCO3 shells (natcalc) [mol C m-3] -! NATPH - Natural pH (natph) [-log10([h+])] ! NATOMEGAA - Natural aragonite saturation state (natomegaa) [1] ! NATOMEGAC - Natural calcite saturation state (natomegac) [1] ! DIC13 - Dissolved C13 (dissic13) [mol C m-3] @@ -1549,12 +1794,18 @@ cat >>! $RUNDIR/ocn_in$inststr << EOF ! EXPOCA - Ca export production (epcalc100) [mol Ca m-2 s-1] ! EXPOSI - Si export production (epsi100) [mol Si m-2 s-1] ! PCO2 - Surface PCO2 (spco2) [uatm] -! KWCO2 - kwco2 x solubility +! PCO2M - Surface PCO2 under moist air assumption [uatm] +! KWCO2 - Piston velocity (kwco2) [m s-1] +! KWCO2KHM - Piston velocity times solubility (kwco2*kh; moist air) [m s-1 mol kg-1 uatm-1] +! CO2KH - CO2 solubility under dry air assumption (khd) [mol kg-1 atm-1] +! CO2KHM - CO2 solubility under moist air assumption (kh) [mol kg-1 atm-1] ! CO2FXD - Downward CO2 flux (co2fxd) [kg C m-2 s-1] ! CO2FXU - Upward CO2 flux (co2fxu) [kg C m-2 s-1] ! NIFLUX - Nitrogen flux (fgn2) [mol N2 m-2 s-1] ! OXFLUX - Oxygen flux (fgo2) [mol O2 m-2 s-1] +! PN2OM - Surface pN2O under moist air [uatm] ! N2OFX - Nitrous oxide flux [mol N2O m-2 s-1] +! PNH3 - Surface pNH3 under moist air [natm] ! ANH3FX - Ammonia flux [mol NH3 m-2 s-1] ! DMSFLUX - DMS flux (dmsflux) [mol DMS m-2 s-1] ! DMS - surface DMS concentration (dms) [mol DMS m-3] @@ -1591,7 +1842,14 @@ cat >>! $RUNDIR/ocn_in$inststr << EOF ! SEDIFFN2 - sediment - water-column diffusive flux of N2 [mol N2 m-2 s-1] ! SEDIFFNO3 - sediment - water-column diffusive flux of nitrate [mol NO3 m-2 s-1] ! SEDIFFSI - sediment - water-column diffusive flux of silica [mol Si m-2 s-1] -! +! SEDIFFNH4 - sediment - water-column diffusive flux of ammonia [mol NH4 m-2 s-1] +! SEDIFFN2O - sediment - water-column diffusive flux of N2O [mol N2O m-2 s-1] +! SEDIFFNO2 - sediment - water-column diffusive flux of NO2 [mol NO2 m-2 s-1] +! BURSSO12 - sediment - burial layer burial flux of organic matter [mol P m-2 s-1] +! BURSSSC12 - sediment - burial layer burial flux of CaCO3 [mol Ca m-2 s-1] +! BURSSSSIL - sediment - burial layer burial flux of opal [mol Si m-2 s-1] +! BURSSSTER - sediment - burial layer burial flux of ssster [g m-2 s-1] +! ! Sediment fields (SDM) ! POWAIC - (powdic) [mol C m-3] ! POWAAL - (powalk) [eq m-3] @@ -1600,6 +1858,24 @@ cat >>! $RUNDIR/ocn_in$inststr << EOF ! POWN2 - (pown2) [mol N2 m-3] ! POWNO3 - (powno3)[mol N m-3] ! POWASI - (powsi) [mol Si m-3] +! POWNH4 - (pownh4) [mol NH4 m-3] - extended N cycle only +! POWN2O - (pown2o) [mol N2O m-3] - extended N cycle only +! POWNO2 - (powno2) [mol NO2 m-3] - extended N cycle only +! NITR_NH4 - nitrification rate on NH4 [mol NH4 m-3 s-1] - extended N cycle only +! NITR_NO2 - nitrification rate on NO2 [mol NO2 m-3 s-1] - extended N cycle only +! NITR_N2O_PROD - N2O production rate during nitrification on NH4 [mol N2O m-3 s-1] - ext. N cycle only +! NITR_NH4_OM - detritus production during nitrification on NH4 [mol P m-3 s-1] - ext. N cycle only +! NITR_NO2_OM - detritus production during nitrification on NO2 [mol P m-3 s-1] - ext. N cycle only +! DENIT_NO3 - denitrification rate on NO3 [mol NO3 m-3 s-1] - ext. N cycle only +! DENIT_NO2 - denitrification rate on NO2 [mol NO2 m-3 s-1] - ext. N cycle only +! DENIT_N2O - denitrification rate on N20 [mol N20 m-3 s-1] - ext. N cycle only +! DNRA_NO2 - DNRA on NO2 [mol NO2 m-3 s-1] - ext. N cycle only +! ANMX_N2_PROD - anammox N2 production [mol N2 m-3 s-1] - ext. N cycle only +! ANMX_OM_PROD - anammox detritus production [mol P m-3 s-1] - ext. N cycle only +! PHOSY_NH4 - PP consumption of NH4 [mol NH4 m-3 s-1] - ext. N cycle only +! PHOSY_NO3 - PP consumption of NH4 [mol NH4 m-3 s-1] - ext. N cycle only +! REMIN_AEROB - aerob remineralization rate (sev. sources) [mol NH4 m-3 s-1] - ext. N cycle only +! REMIN_SULF - sulfate-based remin rate on det [mol P m-3 s-1] - ext. N cycle only ! SSSO12 - (ssso12) [mol m-3] ! SSSSIL - (ssssil) [mol Si m-3] ! SSSC12 - (sssc12) [mol C m-3] @@ -1628,16 +1904,23 @@ cat >>! $RUNDIR/ocn_in$inststr << EOF SRF_SILICA = $SRF_SILICA SRF_DIC = $SRF_DIC SRF_PHYTO = $SRF_PHYTO + SRF_PH = $SRF_PH SRF_EXPORT = $SRF_EXPORT SRF_EXPOSI = $SRF_EXPOSI SRF_EXPOCA = $SRF_EXPOCA SRF_KWCO2 = $SRF_KWCO2 + SRF_KWCO2KHM = $SRF_KWCO2KHM + SRF_CO2KH = $SRF_CO2KH + SRF_CO2KHM = $SRF_CO2KHM SRF_PCO2 = $SRF_PCO2 + SRF_PCO2M = $SRF_PCO2M SRF_CO2FXD = $SRF_CO2FXD SRF_CO2FXU = $SRF_CO2FXU SRF_OXFLUX = $SRF_OXFLUX SRF_NIFLUX = $SRF_NIFLUX + SRF_PN2OM = $SRF_PN2OM SRF_N2OFX = $SRF_N2OFX + SRF_PNH3 = $SRF_PNH3 SRF_ANH3FX = $SRF_ANH3FX SRF_DMSFLUX = $SRF_DMSFLUX SRF_DMS = $SRF_DMS @@ -1649,6 +1932,7 @@ cat >>! $RUNDIR/ocn_in$inststr << EOF SRF_ATMN2 = $SRF_ATMN2 SRF_NATDIC = $SRF_NATDIC SRF_NATALKALI = $SRF_NATALKALI + SRF_NATPH = $SRF_NATPH SRF_NATPCO2 = $SRF_NATPCO2 SRF_NATCO2FX = $SRF_NATCO2FX SRF_CO213FXD = $SRF_CO213FXD @@ -1708,6 +1992,18 @@ cat >>! $RUNDIR/ocn_in$inststr << EOF LYR_PHOSY_NO3 = $LYR_PHOSY_NO3 LYR_REMIN_AEROB = $LYR_REMIN_AEROB LYR_REMIN_SULF = $LYR_REMIN_SULF + LYR_AGG_WS = $LYR_AGG_WS + LYR_DYNVIS = $LYR_DYNVIS + LYR_AGG_STICK = $LYR_AGG_STICK + LYR_AGG_STICKF = $LYR_AGG_STICKF + LYR_AGG_DMAX = $LYR_AGG_DMAX + LYR_AGG_AVDP = $LYR_AGG_AVDP + LYR_AGG_AVRHOP = $LYR_AGG_AVRHOP + LYR_AGG_AVDC = $LYR_AGG_AVDC + LYR_AGG_DF = $LYR_AGG_DF + LYR_AGG_B = $LYR_AGG_B + LYR_AGG_VRHOF = $LYR_AGG_VRHOF + LYR_AGG_VPOR = $LYR_AGG_VPOR LYR_ALKALI = $LYR_ALKALI LYR_SILICA = $LYR_SILICA LYR_DIC = $LYR_DIC @@ -1777,6 +2073,18 @@ cat >>! $RUNDIR/ocn_in$inststr << EOF LVL_PHOSY_NO3 = $LVL_PHOSY_NO3 LVL_REMIN_AEROB = $LVL_REMIN_AEROB LVL_REMIN_SULF = $LVL_REMIN_SULF + LVL_AGG_WS = $LVL_AGG_WS + LVL_DYNVIS = $LVL_DYNVIS + LVL_AGG_STICK = $LVL_AGG_STICK + LVL_AGG_STICKF = $LVL_AGG_STICKF + LVL_AGG_DMAX = $LVL_AGG_DMAX + LVL_AGG_AVDP = $LVL_AGG_AVDP + LVL_AGG_AVRHOP = $LVL_AGG_AVRHOP + LVL_AGG_AVDC = $LVL_AGG_AVDC + LVL_AGG_DF = $LVL_AGG_DF + LVL_AGG_B = $LVL_AGG_B + LVL_AGG_VRHOF = $LVL_AGG_VRHOF + LVL_AGG_VPOR = $LVL_AGG_VPOR LVL_ALKALI = $LVL_ALKALI LVL_SILICA = $LVL_SILICA LVL_DIC = $LVL_DIC @@ -1825,6 +2133,9 @@ cat >>! $RUNDIR/ocn_in$inststr << EOF FLX_SEDIFFN2 = $FLX_SEDIFFN2 FLX_SEDIFFNO3 = $FLX_SEDIFFNO3 FLX_SEDIFFSI = $FLX_SEDIFFSI + FLX_SEDIFFNH4 = $FLX_SEDIFFNH4 + FLX_SEDIFFN2O = $FLX_SEDIFFN2O + FLX_SEDIFFNO2 = $FLX_SEDIFFNO2 SDM_POWAIC = $SDM_POWAIC SDM_POWAAL = $SDM_POWAAL SDM_POWAPH = $SDM_POWAPH @@ -1832,6 +2143,26 @@ cat >>! $RUNDIR/ocn_in$inststr << EOF SDM_POWN2 = $SDM_POWN2 SDM_POWNO3 = $SDM_POWNO3 SDM_POWASI = $SDM_POWASI + SDM_POWNH4 = $SDM_POWNH4 + SDM_POWN2O = $SDM_POWN2O + SDM_POWNO2 = $SDM_POWNO2 + SDM_NITR_NH4 = $SDM_NITR_NH4 + SDM_NITR_NO2 = $SDM_NITR_NO2 + SDM_NITR_N2O_PROD = $SDM_NITR_N2O_PROD + SDM_NITR_NH4_OM = $SDM_NITR_NH4_OM + SDM_NITR_NO2_OM = $SDM_NITR_NO2_OM + SDM_DENIT_NO3 = $SDM_DENIT_NO3 + SDM_DENIT_NO2 = $SDM_DENIT_NO2 + SDM_DENIT_N2O = $SDM_DENIT_N2O + SDM_DNRA_NO2 = $SDM_DNRA_NO2 + SDM_ANMX_N2_PROD = $SDM_ANMX_N2_PROD + SDM_ANMX_OM_PROD = $SDM_ANMX_OM_PROD + SDM_REMIN_AEROB = $SDM_REMIN_AEROB + SDM_REMIN_SULF = $SDM_REMIN_SULF + FLX_BURSSO12 = $FLX_BURSSO12 + FLX_BURSSSC12 = $FLX_BURSSSC12 + FLX_BURSSSSIL = $FLX_BURSSSSIL + FLX_BURSSSTER = $FLX_BURSSSTER SDM_SSSO12 = $SDM_SSSO12 SDM_SSSSIL = $SDM_SSSSIL SDM_SSSC12 = $SDM_SSSC12 @@ -1881,11 +2212,21 @@ EOF if ($BLOM_N_DEPOSITION == TRUE) then cat >> $CASEBUILD/blom.input_data_list << EOF n_deposition_file = `echo $NDEPFILE | tr -d '"' | tr -d "'"` +EOF + endif + if ($BGCOAFX_OALKFILE != "''") then +cat >> $CASEBUILD/blom.input_data_list << EOF +oafx_file = `echo $BGCOAFX_OALKFILE | tr -d '"' | tr -d "'"` EOF endif if ($HAMOCC_VSLS == TRUE) then cat >> $CASEBUILD/blom.input_data_list << EOF swa_clim_file = `echo $SWACLIMFILE | tr -d '"' | tr -d "'"` +EOF + endif + if ($L_3DVARSEDPOR == TRUE) then +cat >> $CASEBUILD/blom.input_data_list << EOF +sed_porosity_file = `echo $SEDPORFILE | tr -d '"' | tr -d "'"` EOF endif endif diff --git a/cime_config/config_archive.xml b/cime_config/config_archive.xml new file mode 100644 index 00000000..0939f52d --- /dev/null +++ b/cime_config/config_archive.xml @@ -0,0 +1,13 @@ + + + r + rbgc + h[dmy]\d*.*\.nc$ + hbgc[dmy]\d*.*\.nc$ + unset + + rpointer.ocn$NINST_STRING + ./$CASE.blom$NINST_STRING.r.$DATENAME.nc + + + diff --git a/cime_config/config_component.xml b/cime_config/config_component.xml index cc829c89..f1caf12b 100644 --- a/cime_config/config_component.xml +++ b/cime_config/config_component.xml @@ -31,6 +31,15 @@ The default is constant. + + char + isopyc_bulkml,cntiso_hybrid + isopyc_bulkml + build_component_blom + env_build.xml + Vertical coordinate type of BLOM + + char iage,iage ecosys @@ -227,6 +236,15 @@ Optional turbulent closure. Valid values one of: twoeq oneeq. Additional values: advection isodif + + char + + cgs + build_component_blom + env_build.xml + Unit system. Valid values one of: cgs mks. + + BLOM default: BLOM/Ecosystem: diff --git a/drivers/cpl_mct/mod_swtfrz.F b/drivers/cpl_mct/mod_swtfrz.F deleted file mode 100644 index fd623993..00000000 --- a/drivers/cpl_mct/mod_swtfrz.F +++ /dev/null @@ -1,94 +0,0 @@ -! ------------------------------------------------------------------------------ -! Copyright (C) 2018-2020 Mats Bentsen -! -! 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_swtfrz -c -c --- ------------------------------------------------------------------ -c --- This module contains routines for computing the freezing point of -c --- sea water. -c --- ------------------------------------------------------------------ -c - use mod_types, only: r8 - use shr_frz_mod, only: shr_frz_freezetemp -c - implicit none -c - private -c - public :: swtfrz -c - interface swtfrz - module procedure swtfrz_0d - module procedure swtfrz_1d - module procedure swtfrz_2d - end interface swtfrz -c - contains -c -c --- ------------------------------------------------------------------ -c - function swtfrz_0d(p,s) result(swtfrz) -c -c --- ------------------------------------------------------------------ -c --- Retrieve freezing temperature from shared CESM function. -c --- ------------------------------------------------------------------ -c - real(r8), intent(in) :: p ! Pressure [g cm-1 s-2] - real(r8), intent(in) :: s ! Salinity [g kg-1] - real(r8) :: swtfrz -c - swtfrz=shr_frz_freezetemp(s) -c - end function swtfrz_0d -c -c --- ------------------------------------------------------------------ -c - function swtfrz_1d(p,s) result(swtfrz) -c -c --- ------------------------------------------------------------------ -c --- Retrieve freezing temperature from shared CESM function. -c --- ------------------------------------------------------------------ -c - real(r8), intent(in) :: p(:) ! Pressure [g cm-1 s-2] - real(r8), intent(in) :: s(:) ! Salinity [g kg-1] - real(r8) :: swtfrz(size(s)) -c - swtfrz(:)=shr_frz_freezetemp(s(:)) -c - end function swtfrz_1d -c -c --- ------------------------------------------------------------------ -c - function swtfrz_2d(p,s) result(swtfrz) -c -c --- ------------------------------------------------------------------ -c --- Retrieve freezing temperature from shared CESM function. -c --- ------------------------------------------------------------------ -c - real(r8), intent(in) :: p(:,:) ! Pressure [g cm-1 s-2] - real(r8), intent(in) :: s(:,:) ! Salinity [g kg-1] - real(r8) :: swtfrz(size(s,1),size(s,2)) -c - swtfrz(:,:)=shr_frz_freezetemp(s(:,:)) -c - end function swtfrz_2d -c -c --- ------------------------------------------------------------------ -c - end module mod_swtfrz diff --git a/drivers/cpl_share/blom_cpl_indices.F90 b/drivers/mct/blom_cpl_indices.F90 similarity index 100% rename from drivers/cpl_share/blom_cpl_indices.F90 rename to drivers/mct/blom_cpl_indices.F90 diff --git a/drivers/cpl_mct/domain_mct.F b/drivers/mct/domain_mct.F similarity index 97% rename from drivers/cpl_mct/domain_mct.F rename to drivers/mct/domain_mct.F index 34e07813..4c088b69 100644 --- a/drivers/cpl_mct/domain_mct.F +++ b/drivers/mct/domain_mct.F @@ -27,6 +27,7 @@ subroutine domain_mct(gsMap_ocn, dom_ocn, lsize, perm, jjcpl) use mod_types, only: r8 use mod_xc use mod_grid, only: scp2, plon, plat + use mod_constants, only: L_mks2cgs implicit none @@ -105,7 +106,7 @@ subroutine domain_mct(gsMap_ocn, dom_ocn, lsize, perm, jjcpl) enddo call mct_gGrid_importRattr(dom_ocn, "lat", rdata, lsize) - radius = SHR_CONST_REARTH*1.e2_r8 ! Earth's radius in cm + radius = SHR_CONST_REARTH*L_mks2cgs ! Earth's radius in cm n = 0 do j = 1, jjcpl diff --git a/drivers/cpl_mct/export_mct.F b/drivers/mct/export_mct.F similarity index 96% rename from drivers/cpl_mct/export_mct.F rename to drivers/mct/export_mct.F index d5ca668e..cff6c4c2 100644 --- a/drivers/cpl_mct/export_mct.F +++ b/drivers/mct/export_mct.F @@ -23,6 +23,7 @@ subroutine export_mct(o2x_o, lsize, perm, jjcpl, nsend, sbuff, ! Uses modules use mct_mod + use mod_constants, only: L_mks2cgs use shr_const_mod, only: SHR_CONST_TKFRZ use mod_types, only: r8 use blom_cpl_indices @@ -47,8 +48,10 @@ subroutine export_mct(o2x_o, lsize, perm, jjcpl, nsend, sbuff, integer i, j, n real(r8) :: tfac, utmp, vtmp + real(r8) :: iL_mks2cgs tfac = 1._r8/tlast_coupled + iL_mks2cgs = 1._r8/L_mks2cgs ! ---------------------------------------------------------------- ! Interpolate onto scalar points, rotate, and pack surface @@ -73,9 +76,9 @@ subroutine export_mct(o2x_o, lsize, perm, jjcpl, nsend, sbuff, vtmp = .5_r8*( sbuff(i,j ,index_o2x_So_v) . + sbuff(i,j+1,index_o2x_So_v)) o2x_o%rattr(index_o2x_So_u,n) = - . (utmp*cosang(i,j) - vtmp*sinang(i,j))*tfac*1.e-2_r8 + . (utmp*cosang(i,j) - vtmp*sinang(i,j))*tfac*iL_mks2cgs o2x_o%rattr(index_o2x_So_v,n) = - . (utmp*sinang(i,j) + vtmp*cosang(i,j))*tfac*1.e-2_r8 + . (utmp*sinang(i,j) + vtmp*cosang(i,j))*tfac*iL_mks2cgs utmp = ( sbuff(i ,j,index_o2x_So_dhdx)*iu(i ,j) . + sbuff(i+1,j,index_o2x_So_dhdx)*iu(i+1,j)) . /max(1,iu(i,j) + iu(i+1,j)) diff --git a/drivers/cpl_mct/external_abort.F b/drivers/mct/external_abort.F similarity index 100% rename from drivers/cpl_mct/external_abort.F rename to drivers/mct/external_abort.F diff --git a/drivers/cpl_mct/getprecipfact_mct.F b/drivers/mct/getprecipfact_mct.F similarity index 100% rename from drivers/cpl_mct/getprecipfact_mct.F rename to drivers/mct/getprecipfact_mct.F diff --git a/drivers/cpl_mct/import_mct.F b/drivers/mct/import_mct.F similarity index 100% rename from drivers/cpl_mct/import_mct.F rename to drivers/mct/import_mct.F diff --git a/drivers/mct/mod_swtfrz.F90 b/drivers/mct/mod_swtfrz.F90 new file mode 100644 index 00000000..d5209eeb --- /dev/null +++ b/drivers/mct/mod_swtfrz.F90 @@ -0,0 +1,81 @@ +! ------------------------------------------------------------------------------ +! Copyright (C) 2018-2022 Mats Bentsen +! +! 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_swtfrz +! ------------------------------------------------------------------------------ +! This module contains routines for computing the freezing point of sea water. +! ------------------------------------------------------------------------------ + + use mod_types, only: r8 + use shr_frz_mod, only: shr_frz_freezetemp + + implicit none + + private + + public :: swtfrz + + interface swtfrz + module procedure swtfrz_0d + module procedure swtfrz_1d + module procedure swtfrz_2d + end interface swtfrz + +contains + + function swtfrz_0d(p,s) result(swtfrz) + ! --------------------------------------------------------------------------- + ! Retrieve freezing temperature from shared CESM function. + ! --------------------------------------------------------------------------- + + real(r8), intent(in) :: p ! Pressure [g cm-1 s-2] + real(r8), intent(in) :: s ! Salinity [g kg-1] + real(r8) :: swtfrz + + swtfrz = shr_frz_freezetemp(s) + + end function swtfrz_0d + + function swtfrz_1d(p,s) result(swtfrz) + ! --------------------------------------------------------------------------- + ! Retrieve freezing temperature from shared CESM function. + ! --------------------------------------------------------------------------- + + real(r8), intent(in) :: p(:) ! Pressure [g cm-1 s-2] + real(r8), intent(in) :: s(:) ! Salinity [g kg-1] + real(r8) :: swtfrz(size(s)) + + swtfrz(:) = shr_frz_freezetemp(s(:)) + + end function swtfrz_1d + + function swtfrz_2d(p,s) result(swtfrz) + ! --------------------------------------------------------------------------- + ! Retrieve freezing temperature from shared CESM function. + ! --------------------------------------------------------------------------- + + real(r8), intent(in) :: p(:,:) ! Pressure [g cm-1 s-2] + real(r8), intent(in) :: s(:,:) ! Salinity [g kg-1] + real(r8) :: swtfrz(size(s,1),size(s,2)) + + swtfrz(:,:) = shr_frz_freezetemp(s(:,:)) + + end function swtfrz_2d + +end module mod_swtfrz diff --git a/drivers/cpl_mct/ocn_comp_mct.F90 b/drivers/mct/ocn_comp_mct.F90 similarity index 96% rename from drivers/cpl_mct/ocn_comp_mct.F90 rename to drivers/mct/ocn_comp_mct.F90 index 25a7e6a4..15230d3c 100644 --- a/drivers/cpl_mct/ocn_comp_mct.F90 +++ b/drivers/mct/ocn_comp_mct.F90 @@ -34,7 +34,7 @@ module ocn_comp_mct use seq_flds_mod use seq_timemgr_mod, only: & seq_timemgr_EClockGetData, seq_timemgr_RestartAlarmIsOn, & - seq_timemgr_EClockDateInSync + seq_timemgr_EClockDateInSync,seq_timemgr_pauseAlarmIsOn use seq_comm_mct, only: seq_comm_suffix, seq_comm_inst, seq_comm_name use shr_file_mod, only: & shr_file_getUnit, shr_file_setIO, & @@ -46,7 +46,7 @@ module ocn_comp_mct use perf_mod, only: t_startf, t_stopf use mod_types, only: r8 - use mod_config, only: inst_index, inst_name, inst_suffix + use mod_config, only: inst_index, inst_name, inst_suffix, resume_flag use mod_time, only: blom_time use mod_cesm, only: runid_cesm, runtyp_cesm, ocn_cpl_dt_cesm use mod_xc @@ -275,6 +275,14 @@ subroutine ocn_run_mct(EClock, cdata_o, x2o_o, o2x_o) call seq_cdata_setptrs(cdata_o, infodata=infodata) + if (resume_flag) then + if (mnproc == 1) then + call blom_time(ymd, tod) + write(lp,*)'Resume from restart: ymd=',ymd,' tod= ',tod + endif + call restart_rd !! resume_flag is applied + resume_flag = .false. + end if !----------------------------------------------------------------- ! Advance the model in time over a coupling interval !----------------------------------------------------------------- @@ -314,9 +322,10 @@ subroutine ocn_run_mct(EClock, cdata_o, x2o_o, o2x_o) ! if requested, write restart file !----------------------------------------------------------------- - if (seq_timemgr_RestartAlarmIsOn(EClock)) then + if (seq_timemgr_RestartAlarmIsOn(EClock).or.seq_timemgr_pauseAlarmIsOn(EClock)) then call restart_wt endif + if (seq_timemgr_pauseAlarmIsOn(EClock)) resume_flag = .true. !----------------------------------------------------------------- ! check that internal clock is in sync with master clock diff --git a/drivers/cpl_mct/setlogunit.F b/drivers/mct/setlogunit.F similarity index 100% rename from drivers/cpl_mct/setlogunit.F rename to drivers/mct/setlogunit.F diff --git a/drivers/cpl_mct/sumsbuff_mct.F b/drivers/mct/sumsbuff_mct.F similarity index 100% rename from drivers/cpl_mct/sumsbuff_mct.F rename to drivers/mct/sumsbuff_mct.F diff --git a/drivers/nocoupler/blom.F b/drivers/nocoupler/blom.F index dac4d5eb..a3b02b50 100644 --- a/drivers/nocoupler/blom.F +++ b/drivers/nocoupler/blom.F @@ -40,7 +40,7 @@ program blom enddo blom_loop c c --- write check sum of layer thickness - call chksummsk(dp(1-nbdy,1-nbdy,1+mod(nstep2,2)*kk),ip,1,'dp') + call chksummsk(dp(1-nbdy,1-nbdy,1+mod(nstep2,2)*kk),ip,kk,'dp') c if (mnproc.eq.1) then open (unit=nfu,file='run.status',status='unknown') diff --git a/drivers/nuopc/external_abort.F90 b/drivers/nuopc/external_abort.F90 new file mode 100644 index 00000000..4e1932a1 --- /dev/null +++ b/drivers/nuopc/external_abort.F90 @@ -0,0 +1,35 @@ +! ------------------------------------------------------------------------------ +! Copyright (C) 2015 Mats Bentsen +! +! 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 . +! ------------------------------------------------------------------------------ + +subroutine external_abort(msg) +! ------------------------------------------------------------------------------ +! Call CESM shared abort routine. +! ------------------------------------------------------------------------------ + + use shr_sys_mod, only: shr_sys_abort + + implicit none + + ! Input/output arguments. + + character(len=*), intent(in) :: msg + + call shr_sys_abort(msg) + +end subroutine external_abort diff --git a/drivers/nuopc/mod_nuopc_methods.F90 b/drivers/nuopc/mod_nuopc_methods.F90 new file mode 100644 index 00000000..6cdd659a --- /dev/null +++ b/drivers/nuopc/mod_nuopc_methods.F90 @@ -0,0 +1,1098 @@ +! ------------------------------------------------------------------------------ +! Copyright (C) 2022 Mats Bentsen +! +! 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_nuopc_methods +! ------------------------------------------------------------------------------ +! This module contains routines operating on BLOM data structures needed by the +! NUOPC cap. +! ------------------------------------------------------------------------------ + + use mod_types, only: r8 + use mod_constants, only: rearth, onem + use mod_time, only: nstep, baclin, delt1, dlt + use mod_xc + use mod_grid, only: scuy, scvx, scp2, scuxi, scvyi, plon, plat, & + cosang, sinang + use mod_state, only: u, v, dp, temp, saln, pbu, pbv, ubflxs, vbflxs, sealv + use mod_forcing, only: sprfac, prfac, flxco2, flxdms, flxbrf + use mod_difest, only: obldepth + use mod_vcoord, only: vcoord_type_tag, isopyc_bulkml, cntiso_hybrid + 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, & + ustarw_da, slp_da, abswnd_da, ficem_da, lamult_da, & + lasl_da, ustokes_da, vstokes_da, atmco2_da, atmbrf_da, & + l1ci, l2ci + use mod_utility, only: util1, util2 + use mod_checksum, only: csdiag, chksummsk + use shr_const_mod, only: SHR_CONST_RHOSW, SHR_CONST_LATICE, SHR_CONST_TKFRZ + + implicit none + + private + + ! Parameters. + character(len=*), parameter :: modname = '(mod_nuopc_methods)' + + type :: fldlist_type + character(len=128) :: stdname + integer :: ungridded_lbound = 0 + integer :: ungridded_ubound = 0 + real(r8), dimension(:), pointer :: dataptr + end type fldlist_type + + real(r8), dimension(:), allocatable :: mod2med_areacor, med2mod_areacor + real(r8), dimension(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy) :: & + acc_u, acc_v, acc_dhdx, acc_dhdy, acc_t, acc_s, acc_frzpot, acc_bld, & + acc_fco2, acc_fdms, acc_fbrf + real(r8) :: tlast_coupled + integer :: jjcpl + logical :: fco2_requested, fdms_requested, fbrf_requested + + public :: fldlist_type, tlast_coupled, & + fco2_requested, fdms_requested, fbrf_requested, & + blom_logwrite, blom_getgindex, blom_checkmesh, blom_setareacor, & + blom_getglobdim, blom_getprecipfact, blom_accflds, & + blom_importflds, blom_exportflds + +contains + + ! --------------------------------------------------------------------------- + ! Private procedures. + ! --------------------------------------------------------------------------- + + subroutine getfldindex(fldlist_num, fldlist, stdname, fldindex) + ! --------------------------------------------------------------------------- + ! Get index of field with given standard name. If no field has a matching + ! name or a field with matching name has an unassociated data pointer, set + ! index to zero. + ! --------------------------------------------------------------------------- + + ! Input/output arguments. + integer, intent(in) :: fldlist_num + type(fldlist_type), dimension(:), intent(in) :: fldlist + character(len=*), intent(in) :: stdname + integer, intent(inout) :: fldindex + + ! Local variables. + integer :: n + + if (fldindex >= 0) return + + fldindex = 0 + + do n = 1, fldlist_num + if (fldlist(n)%stdname == stdname) then + if (associated(fldlist(n)%dataptr)) fldindex = n + return + endif + enddo + + end subroutine getfldindex + + ! --------------------------------------------------------------------------- + ! Public procedures. + ! --------------------------------------------------------------------------- + + subroutine blom_logwrite(msg) + ! --------------------------------------------------------------------------- + ! Write message string to standard out from master PE. + ! --------------------------------------------------------------------------- + + ! Input/output arguments. + character(len=*), intent(in) :: msg + + if (mnproc == 1) write(lp,'(a)') trim(msg) + + end subroutine blom_logwrite + + subroutine blom_getgindex(gindex) + ! --------------------------------------------------------------------------- + ! Get global index space for the computational domain. + ! --------------------------------------------------------------------------- + + ! Input/output arguments. + integer, allocatable, dimension(:), intent(out) :: gindex + + ! Local variables. + integer :: mproc_next, i, j, n + + ! Set the j-extent of the local ocean domain to be exchanged. Needed + ! because of duplication of the last global domain row when using a + ! tripolar grid. + if (nreg == 2 .and. nproc == jpr) then + jjcpl = jj - 1 + else + jjcpl = jj + endif + + ! Create the global index space for the computational domain. Also append + ! indices of eliminated grid cells adjacent to the domain and with larger + ! global i-index. + mproc_next = mod(mproc, ipr) + 1 + do while (ii_pe(mproc_next,nproc) == 0) + mproc_next = mod(mproc_next, ipr) + 1 + enddo + allocate(gindex(mod(i0_pe(mproc_next,nproc) - i0 + itdm, itdm)*jjcpl)) + n = 0 + do j = 1, jjcpl + do i = 1, ii + n = n + 1 + gindex(n) = (j0 + j - 1)*itdm + i0 + i + enddo + enddo + do j = 1, jjcpl + do i = ii + 1, mod(i0_pe(mproc_next,nproc) - i0 + itdm, itdm) + n = n + 1 + gindex(n) = (j0 + j - 1)*itdm + mod(i0 + i - 1, itdm) + 1 + enddo + enddo + + end subroutine blom_getgindex + + subroutine blom_checkmesh(lonmesh, latmesh, maskmesh) + ! --------------------------------------------------------------------------- + ! Check for consistency of lat, lon and mask between mediator mesh and model + ! grid. + ! --------------------------------------------------------------------------- + + ! Input/output arguments. + real(r8), dimension(:), pointer, intent(in) :: lonmesh, latmesh + integer, dimension(:), pointer, intent(in) :: maskmesh + + ! Local parameters. + character(len=*), parameter :: & + subname = modname//':(blom_checkmesh)' + + ! Local variables. + real(r8) :: diff_lon, diff_lat + integer :: mproc_next, i, j, n + + do j = 1, jjcpl + do i = 1, ii + n = (j - 1)*ii + i + diff_lon = abs(mod(lonmesh(n) - plon(i,j),360._r8)) + if (diff_lon > 1.e-3_r8) then + write(lp,'(a,3i6,2(f21.13,3x),d21.5)') subname// & + ': BLOM ERROR: n, i, j, lonmesh(n), plon(i,j), diff_lon = ', & + n, i, j, lonmesh(n), plon(i,j), diff_lon + call xchalt(subname) + stop subname + endif + diff_lat = abs(latmesh(n) - plat(i,j)) + if (diff_lat > 1.e-3_r8) then + write(lp,'(a,3i6,2(f21.13,3x),d21.5)') subname// & + ': BLOM ERROR: n, i, j, latmesh(n), plat(i,j), diff_lat = ', & + n, i, j, latmesh(n), plat(i,j), diff_lat + call xchalt(subname) + stop subname + endif + if (maskmesh(n) /= ip(i,j)) then + write(lp,'(a,3i6,2(f21.13,3x),d21.5)') subname// & + ': BLOM ERROR: n, i, j, maskmesh(n), ip(i,j) = ', & + n, i, j, maskmesh(n), ip(i,j) + call xchalt(subname) + stop subname + endif + enddo + enddo + + end subroutine blom_checkmesh + + subroutine blom_getprecipfact(precip_fact_provided, precip_fact) + ! --------------------------------------------------------------------------- + ! Get precipitation factor. + ! --------------------------------------------------------------------------- + + ! Input/output arguments. + logical, intent(out) :: precip_fact_provided + real(r8), intent(out) :: precip_fact + + precip_fact_provided = sprfac + precip_fact = prfac + + end subroutine blom_getprecipfact + + subroutine blom_getglobdim(nx_global, ny_global) + ! --------------------------------------------------------------------------- + ! Get global dimensions of export/import domain. + ! --------------------------------------------------------------------------- + + ! Input/output arguments. + integer, intent(out) :: nx_global, ny_global + + nx_global = itdm + if (nreg == 2) then + ny_global = jtdm - 1 + else + ny_global = jtdm + endif + + end subroutine blom_getglobdim + + subroutine blom_setareacor(areamesh, maskmesh) + ! --------------------------------------------------------------------------- + ! Set flux area correction factors. + ! --------------------------------------------------------------------------- + + ! Input/output arguments. + real(r8), dimension(:), pointer, intent(in) :: areamesh + integer, dimension(:), pointer, intent(in) :: maskmesh + + ! Local parameters. + character(len=*), parameter :: & + subname = modname//':(blom_setareacor)' + + ! Local variables. + real(r8) :: areamodel, & + max_mod2med_areacor, max_med2mod_areacor, & + min_mod2med_areacor, min_med2mod_areacor + integer :: i, j, n + + allocate(mod2med_areacor(size(areamesh)), & + med2mod_areacor(size(areamesh))) + mod2med_areacor(:) = 1._r8 + med2mod_areacor(:) = 1._r8 + + !$omp parallel do private(i, n) + do j = 1, jjcpl + do i = 1, ii + n = (j - 1)*ii + i + if (maskmesh(n) /= 0) then + areamodel = scp2(i,j)/(rearth*rearth) + mod2med_areacor(n) = areamodel/areamesh(n) + med2mod_areacor(n) = areamesh(n)/areamodel + endif + enddo + enddo + !$omp end parallel do + + min_mod2med_areacor = minval(mod2med_areacor) + max_mod2med_areacor = maxval(mod2med_areacor) + min_med2mod_areacor = minval(med2mod_areacor) + max_med2mod_areacor = maxval(med2mod_areacor) + call xcmax(max_mod2med_areacor) + call xcmin(min_mod2med_areacor) + call xcmax(max_med2mod_areacor) + call xcmin(min_med2mod_areacor) + if (mnproc == 1) then + write(lp,'(a,2g23.15)') & + subname//': min_mod2med_areacor, max_mod2med_areacor ', & + min_mod2med_areacor, max_mod2med_areacor + write(lp,'(a,2g23.15)') & + subname//': min_med2mod_areacor, max_med2mod_areacor ', & + min_med2mod_areacor, max_med2mod_areacor + endif + + end subroutine blom_setareacor + + subroutine blom_accflds + ! --------------------------------------------------------------------------- + ! Accumulate export fields to be averaged before sent to the mediator. + ! --------------------------------------------------------------------------- + + ! Local parameters. + character(len=*), parameter :: & + subname = modname//':(blom_accflds)' + + ! Local variables. + real(r8) :: q + integer m, n, mm, nn, k1m, k1n, i, j, l + + ! ------------------------------------------------------------------------ + ! Set accumulation arrays to zero if this is the first call after a + ! coupling interval. + ! ------------------------------------------------------------------------ + + if (tlast_coupled == 0._r8) then + acc_u (:,:) = 0._r8 + acc_v (:,:) = 0._r8 + acc_dhdx (:,:) = 0._r8 + acc_dhdy (:,:) = 0._r8 + acc_t (:,:) = 0._r8 + acc_s (:,:) = 0._r8 + acc_frzpot(:,:) = 0._r8 + acc_bld (:,:) = 0._r8 + acc_fco2 (:,:) = 0._r8 + acc_fdms (:,:) = 0._r8 + acc_fbrf (:,:) = 0._r8 + endif + + ! ------------------------------------------------------------------------ + ! Accumulate fields in send buffer + ! ------------------------------------------------------------------------ + + m = mod(nstep + 1, 2) + 1 + n = mod(nstep , 2) + 1 + mm = (m - 1)*kk + nn = (n - 1)*kk + k1m = 1 + mm + k1n = 1 + nn + + call xctilr(sealv, 1,1, 1,1, halo_ps) + + !$omp parallel do private(l, i) + do j = 1, jj + do l = 1, isu(j) + do i = max(1, ifu(j,l)), min(ii, ilu(j,l)) + acc_u(i,j) = acc_u(i,j) & + + ( u(i,j,k1n) & + + (ubflxs(i,j,m) + ubflxs(i,j,n))*dlt & + /(pbu(i,j,n)*scuy(i,j)*delt1))*baclin + acc_dhdx(i,j) = acc_dhdx(i,j) & + + (sealv(i,j) - sealv(i-1,j))*scuxi(i,j)*baclin + enddo + enddo + do l = 1, isv(j) + do i = max(1, ifv(j,l)), min(ii, ilv(j,l)) + acc_v(i,j) = acc_v(i,j) & + + ( v(i,j,k1n) & + + (vbflxs(i,j,m) + vbflxs(i,j,n))*dlt & + /(pbv(i,j,n)*scvx(i,j)*delt1))*baclin + acc_dhdy(i,j) = acc_dhdy(i,j) & + + (sealv(i,j) - sealv(i,j-1))*scvyi(i,j)*baclin + enddo + enddo + do l = 1, isp(j) + do i = max(1, ifp(j,l)), min(ii, ilp(j,l)) + acc_t(i,j) = acc_t(i,j) + temp(i,j,k1n)*baclin + acc_s(i,j) = acc_s(i,j) + saln(i,j,k1n)*baclin + acc_frzpot(i,j) = acc_frzpot(i,j) + frzpot(i,j) + enddo + enddo + enddo + !$omp end parallel do + + select case (vcoord_type_tag) + case (isopyc_bulkml) + q = baclin/onem + !$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)) + acc_bld(i,j) = (dp(i,j,1+nn) + dp(i,j,2+nn))*q + enddo + enddo + enddo + !$omp end parallel do + case (cntiso_hybrid) + !$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)) + acc_bld(i,j) = OBLdepth(i,j)*baclin + enddo + enddo + enddo + !$omp end parallel do + case default + if (mnproc == 1) & + write(lp,*) subname//': unsupported vertical coordinate!' + call xcstop(subname) + stop subname + end select + + if (fco2_requested) then + !$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)) + acc_fco2(i,j) = acc_fco2(i,j) + flxco2(i,j)*baclin + enddo + enddo + enddo + !$omp end parallel do + endif + + if (fdms_requested) then + !$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)) + acc_fdms(i,j) = acc_fdms(i,j) + flxdms(i,j)*baclin + enddo + enddo + enddo + !$omp end parallel do + endif + + if (fbrf_requested) then + !$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)) + acc_fbrf(i,j) = acc_fbrf(i,j) + flxbrf(i,j)*baclin + enddo + enddo + enddo + !$omp end parallel do + endif + + ! ------------------------------------------------------------------------ + ! Increment time since last coupling. + ! ------------------------------------------------------------------------ + + tlast_coupled = tlast_coupled + baclin + + end subroutine blom_accflds + + subroutine blom_importflds(fldlist_num, fldlist) + ! --------------------------------------------------------------------------- + ! Import fields from mediator to BLOM arrays. + ! --------------------------------------------------------------------------- + + ! Input/output arguments. + integer, intent(in) :: fldlist_num + type(fldlist_type), dimension(:), intent(in) :: fldlist + + ! Local parameters. + character(len=*), parameter :: & + subname = modname//':(blom_importflds)' + real(r8), parameter :: & + mval = - 1.e12_r8, & + fval = - 1.e13_r8 + + ! Local variables. + real(r8) :: afac, utmp, vtmp + integer :: n, i, j, l + integer, save :: & + index_Si_ifrac = - 1, & + index_Fioi_melth = - 1, & + index_Fioi_meltw = - 1, & + index_Fioi_salt = - 1, & + index_Fioi_bcpho = - 1, & + index_Fioi_bcphi = - 1, & + index_Fioi_flxdst = - 1, & + index_Foxx_rofl = - 1, & + index_Foxx_rofi = - 1, & + index_So_duu10n = - 1, & + index_Foxx_tauy = - 1, & + index_Foxx_taux = - 1, & + index_Foxx_lat = - 1, & + index_Foxx_sen = - 1, & + index_Foxx_lwup = - 1, & + index_Foxx_evap = - 1, & + index_Foxx_swnet = - 1, & + index_Sw_lamult = - 1, & + index_Sw_ustokes = - 1, & + index_Sw_vstokes = - 1, & + index_Sw_hstokes = - 1, & + index_Faxa_lwdn = - 1, & + index_Faxa_snow = - 1, & + index_Faxa_rain = - 1, & + index_Sa_pslv = - 1, & + index_Sa_co2diag = - 1, & + index_Sa_co2prog = - 1, & + index_Sa_brfprog = - 1 + + ! Update time level indices. + if (l1ci == 1 .and. l2ci == 1) then + l1ci = 2 + l2ci = 2 + else + l1ci = l2ci + l2ci = 3 - l2ci + endif + + call getfldindex(fldlist_num, fldlist, 'Foxx_taux', index_Foxx_taux) + call getfldindex(fldlist_num, fldlist, 'Foxx_tauy', index_Foxx_tauy) + + !$omp parallel do private(i, n, afac, utmp, vtmp) + do j = 1, jjcpl + do i = 1, ii + if (ip(i,j) == 0) then + util1(i,j) = mval + util2(i,j) = mval + ustarw_da(i,j,l2ci) = mval + elseif (cplmsk(i,j) == 0) then + util1(i,j) = fval + util2(i,j) = fval + ustarw_da(i,j,l2ci) = fval + else + n = (j - 1)*ii + i + afac = med2mod_areacor(n) + + utmp = fldlist(index_Foxx_taux)%dataptr(n)*afac + vtmp = fldlist(index_Foxx_tauy)%dataptr(n)*afac + util1(i,j) = utmp*cosang(i,j) + vtmp*sinang(i,j) + util2(i,j) = - utmp*sinang(i,j) + vtmp*cosang(i,j) + + ! Friction velocity [m s-1]. + ustarw_da(i,j,l2ci) = sqrt(sqrt(utmp*utmp + vtmp*vtmp) & + /SHR_CONST_RHOSW) + endif + enddo + enddo + !$omp end parallel do + + call fill_global(mval, fval, halo_pv, util1) + call fill_global(mval, fval, halo_pv, util2) + call fill_global(mval, fval, halo_ps, ustarw_da(1-nbdy,1-nbdy,l2ci)) + + call xctilr(util1, 1,1, 1,1, halo_pv) + call xctilr(util2, 1,1, 1,1, halo_pv) + + !$omp parallel do private(l, i) + do j = 1, jj + do l = 1, isu(j) + do i = max(1,ifu(j,l)), min(ii,ilu(j,l)) + ! x-component of momentum flux [kg m-1 s-2]. + ztx_da(i,j,l2ci) = .5_r8*(util1(i-1,j) + util1(i,j)) + enddo + enddo + do l = 1,isv(j) + do i = max(1,ifv(j,l)), min(ii,ilv(j,l)) + ! y-component of momentum flux [kg m-1 s-2]. + mty_da(i,j,l2ci) = .5_r8*(util2(i,j-1) + util2(i,j)) + enddo + enddo + enddo + !$omp end parallel do + + call getfldindex(fldlist_num, fldlist, 'Faxa_rain', index_Faxa_rain) + call getfldindex(fldlist_num, fldlist, 'Faxa_snow', index_Faxa_snow) + call getfldindex(fldlist_num, fldlist, 'Foxx_evap', index_Foxx_evap) + call getfldindex(fldlist_num, fldlist, 'Foxx_rofl', index_Foxx_rofl) + call getfldindex(fldlist_num, fldlist, 'Foxx_rofi', index_Foxx_rofi) + call getfldindex(fldlist_num, fldlist, 'Fioi_meltw', index_Fioi_meltw) + call getfldindex(fldlist_num, fldlist, 'Fioi_salt', index_Fioi_salt) + call getfldindex(fldlist_num, fldlist, 'Foxx_swnet', index_Foxx_swnet) + call getfldindex(fldlist_num, fldlist, 'Foxx_lat', index_Foxx_lat) + call getfldindex(fldlist_num, fldlist, 'Foxx_sen', index_Foxx_sen) + call getfldindex(fldlist_num, fldlist, 'Foxx_lwup', index_Foxx_lwup) + call getfldindex(fldlist_num, fldlist, 'Faxa_lwdn', index_Faxa_lwdn) + call getfldindex(fldlist_num, fldlist, 'Fioi_melth', index_Fioi_melth) + call getfldindex(fldlist_num, fldlist, 'Sa_pslv', index_Sa_pslv) + call getfldindex(fldlist_num, fldlist, 'So_duu10n', index_So_duu10n) + call getfldindex(fldlist_num, fldlist, 'Si_ifrac', index_Si_ifrac) + + !$omp parallel do private(i, n, afac) + do j = 1, jjcpl + do i = 1, ii + + if (ip(i,j) == 0) then + lip_da(i,j,l2ci) = mval + sop_da(i,j,l2ci) = mval + eva_da(i,j,l2ci) = mval + rnf_da(i,j,l2ci) = mval + rfi_da(i,j,l2ci) = mval + fmltfz_da(i,j,l2ci) = mval + sfl_da(i,j,l2ci) = mval + swa_da(i,j,l2ci) = mval + nsf_da(i,j,l2ci) = mval + hmlt_da(i,j,l2ci) = mval + slp_da(i,j,l2ci) = mval + abswnd_da(i,j,l2ci) = mval + ficem_da(i,j,l2ci) = mval + elseif (cplmsk(i,j) == 0) then + lip_da(i,j,l2ci) = 0._r8 + sop_da(i,j,l2ci) = 0._r8 + eva_da(i,j,l2ci) = 0._r8 + rnf_da(i,j,l2ci) = 0._r8 + rfi_da(i,j,l2ci) = 0._r8 + fmltfz_da(i,j,l2ci) = 0._r8 + sfl_da(i,j,l2ci) = 0._r8 + swa_da(i,j,l2ci) = 0._r8 + nsf_da(i,j,l2ci) = 0._r8 + hmlt_da(i,j,l2ci) = 0._r8 + slp_da(i,j,l2ci) = fval + abswnd_da(i,j,l2ci) = fval + ficem_da(i,j,l2ci) = fval + else + n = (j - 1)*ii + i + afac = med2mod_areacor(n) + + ! Liquid water flux, positive downwards [kg m-2 s-1]. + lip_da(i,j,l2ci) = fldlist(index_Faxa_rain)%dataptr(n)*afac + + ! Solid precipitation, positive downwards [kg m-2 s-1]. + sop_da(i,j,l2ci) = fldlist(index_Faxa_snow)%dataptr(n)*afac + + ! Evaporation, positive downwards [kg m-2 s-1]. + eva_da(i,j,l2ci) = fldlist(index_Foxx_evap)%dataptr(n)*afac + + ! Liquid runoff, positive downwards [kg m-2 s-1]. + rnf_da(i,j,l2ci) = fldlist(index_Foxx_rofl)%dataptr(n)*afac + + ! Frozen runoff, positive downwards [kg m-2 s-1]. + rfi_da(i,j,l2ci) = fldlist(index_Foxx_rofi)%dataptr(n)*afac + + ! Fresh water due to melting/freezing, positive downwards + ! [kg m-2 s-1]. + fmltfz_da(i,j,l2ci) = fldlist(index_Fioi_meltw)%dataptr(n)*afac + + ! Salt flux, positive downwards [kg m-2 s-1]. + sfl_da(i,j,l2ci) = fldlist(index_Fioi_salt)%dataptr(n)*afac + + ! Shortwave heat flux, positive downwards [W m-2]. + swa_da(i,j,l2ci) = fldlist(index_Foxx_swnet)%dataptr(n)*afac + + ! Non-solar heat flux, positive downwards [W m-2]. + nsf_da(i,j,l2ci) = ( fldlist(index_Foxx_lat)%dataptr(n) & + + fldlist(index_Foxx_sen)%dataptr(n) & + + fldlist(index_Foxx_lwup)%dataptr(n) & + + fldlist(index_Faxa_lwdn)%dataptr(n) & + - ( fldlist(index_Faxa_snow)%dataptr(n) & + + fldlist(index_Foxx_rofi)%dataptr(n)) & + *SHR_CONST_LATICE)*afac + + ! Heat flux due to melting, positive downwards [W m-2]. + hmlt_da(i,j,l2ci) = fldlist(index_Fioi_melth)%dataptr(n)*afac + + ! Sea level pressure [kg m-1 s-2]. + slp_da(i,j,l2ci) = fldlist(index_Sa_pslv)%dataptr(n) + + ! 10m wind speed [m s-1]. + abswnd_da(i,j,l2ci) = sqrt(fldlist(index_So_duu10n)%dataptr(n)) + + ! Ice fraction []. + ficem_da(i,j,l2ci) = fldlist(index_Si_ifrac)%dataptr(n) + + endif + + enddo + enddo + !$omp end parallel do + + if (nreg == 2) then + call xctilr(lip_da(1-nbdy,1-nbdy,l2ci), 1,1, 0,0, halo_ps) + call xctilr(sop_da(1-nbdy,1-nbdy,l2ci), 1,1, 0,0, halo_ps) + call xctilr(eva_da(1-nbdy,1-nbdy,l2ci), 1,1, 0,0, halo_ps) + call xctilr(rnf_da(1-nbdy,1-nbdy,l2ci), 1,1, 0,0, halo_ps) + call xctilr(rfi_da(1-nbdy,1-nbdy,l2ci), 1,1, 0,0, halo_ps) + call xctilr(fmltfz_da(1-nbdy,1-nbdy,l2ci), 1,1, 0,0, halo_ps) + call xctilr(sfl_da(1-nbdy,1-nbdy,l2ci), 1,1, 0,0, halo_ps) + call xctilr(swa_da(1-nbdy,1-nbdy,l2ci), 1,1, 0,0, halo_ps) + call xctilr(nsf_da(1-nbdy,1-nbdy,l2ci), 1,1, 0,0, halo_ps) + call xctilr(hmlt_da(1-nbdy,1-nbdy,l2ci), 1,1, 0,0, halo_ps) + endif + + call fill_global(mval, fval, halo_ps, slp_da(1-nbdy,1-nbdy,l2ci)) + call fill_global(mval, fval, halo_ps, abswnd_da(1-nbdy,1-nbdy,l2ci)) + call fill_global(mval, fval, halo_ps, ficem_da(1-nbdy,1-nbdy,l2ci)) + + call getfldindex(fldlist_num, fldlist, 'Sw_lamult', index_Sw_lamult) + call getfldindex(fldlist_num, fldlist, 'Sw_ustokes', index_Sw_ustokes) + call getfldindex(fldlist_num, fldlist, 'Sw_vstokes', index_Sw_vstokes) + call getfldindex(fldlist_num, fldlist, 'Sw_hstokes', index_Sw_hstokes) + + !$omp parallel do private(i, n, utmp, vtmp) + do j = 1, jjcpl + do i = 1, ii + if (ip(i,j) == 0) then + util1(i,j) = mval + util2(i,j) = mval + lamult_da(i,j,l2ci) = mval + lasl_da(i,j,l2ci) = mval + elseif (cplmsk(i,j) == 0) then + util1(i,j) = fval + util2(i,j) = fval + lamult_da(i,j,l2ci) = fval + lasl_da(i,j,l2ci) = fval + else + n = (j - 1)*ii + i + + utmp = fldlist(index_Sw_ustokes)%dataptr(n) + vtmp = fldlist(index_Sw_vstokes)%dataptr(n) + util1(i,j) = utmp*cosang(i,j) + vtmp*sinang(i,j) + util2(i,j) = - utmp*sinang(i,j) + vtmp*cosang(i,j) + + ! Langmuir enhancement factor []. + lamult_da(i,j,l2ci) = fldlist(index_Sw_lamult)%dataptr(n) + + ! Surface layer averaged Langmuir number []. + lasl_da(i,j,l2ci) = fldlist(index_Sw_hstokes)%dataptr(n) + + endif + enddo + enddo + !$omp end parallel do + + call fill_global(mval, fval, halo_pv, util1) + call fill_global(mval, fval, halo_pv, util2) + call fill_global(mval, fval, halo_ps, lamult_da(1-nbdy,1-nbdy,l2ci)) + call fill_global(mval, fval, halo_ps, lasl_da(1-nbdy,1-nbdy,l2ci)) + + call xctilr(util1, 1,1, 1,1, halo_pv) + call xctilr(util2, 1,1, 1,1, halo_pv) + + !$omp parallel do private(l, i) + do j = 1, jj + do l = 1, isu(j) + do i = max(1,ifu(j,l)), min(ii,ilu(j,l)) + ! x-component of surface Stokes drift [m s-1]. + ustokes_da(i,j,l2ci) = .5_r8*(util1(i-1,j) + util1(i,j)) + enddo + enddo + do l = 1,isv(j) + do i = max(1,ifv(j,l)), min(ii,ilv(j,l)) + ! y-component of surface Stokes drift [m s-1]. + vstokes_da(i,j,l2ci) = .5_r8*(util2(i,j-1) + util2(i,j)) + enddo + enddo + enddo + !$omp end parallel do + +#ifdef PROGCO2 + call getfldindex(fldlist_num, fldlist, 'Sa_co2prog', index_Sa_co2prog) + + if (index_Sa_co2prog > 0) then + !$omp parallel do private(i, n) + do j = 1, jjcpl + do i = 1, ii + if (ip(i,j) == 0) then + atmco2_da(i,j,l2ci) = mval + elseif (cplmsk(i,j) == 0) then + atmco2_da(i,j,l2ci) = fval + else + n = (j - 1)*ii + i + ! Atmospheric co2 concentration [ppmv?] + atmco2_da(i,j,l2ci) = fldlist(index_Sa_co2prog)%dataptr(n) + endif + enddo + enddo + !$omp end parallel do + call fill_global(mval, fval, halo_ps, atmco2_da(1-nbdy,1-nbdy,l2ci)) + if (mnproc == 1) & + write(lp,*) subname//': prog. atmospheric co2 read' + else + !$omp parallel do private(i) + do j = 1, jj + do i = 1, ii + if (ip(i,j) == 0) then + atmco2_da(i,j,l2ci) = mval + else + atmco2_da(i,j,l2ci) = -1 + endif + enddo + enddo + !$omp end parallel do + if (mnproc == 1) & + write(lp,*) subname//': prog. atmospheric co2 not read' + endif + +#elif defined(DIAGCO2) + call getfldindex(fldlist_num, fldlist, 'Sa_co2diag', index_Sa_co2diag) + + if (index_Sa_co2diag > 0) then + !$omp parallel do private(i, n) + do j = 1, jjcpl + do i = 1, ii + if (ip(i,j) == 0) then + atmco2_da(i,j,l2ci) = mval + elseif (cplmsk(i,j) == 0) then + atmco2_da(i,j,l2ci) = fval + else + n = (j - 1)*ii + i + ! Atmospheric co2 concentration [ppmv?] + atmco2_da(i,j,l2ci) = fldlist(index_Sa_co2diag)%dataptr(n) + endif + enddo + enddo + !$omp end parallel do + call fill_global(mval, fval, halo_ps, atmco2_da(1-nbdy,1-nbdy,l2ci)) + if (mnproc == 1) & + write(lp,*) subname//': diag. atmospheric co2 read' + else + !$omp parallel do private(i) + do j = 1, jj + do i = 1, ii + if (ip(i,j) == 0) then + atmco2_da(i,j,l2ci) = mval + else + atmco2_da(i,j,l2ci) = -1 + endif + enddo + enddo + !$omp end parallel do + if (mnproc == 1) & + write(lp,*) subname//': diag. atmospheric co2 not read' + endif +#else + !$omp parallel do private(i) + do j = 1, jj + do i = 1, ii + if (ip(i,j) == 0) then + atmco2_da(i,j,l2ci) = mval + else + atmco2_da(i,j,l2ci) = -1 + endif + enddo + enddo + !$omp end parallel do + if (mnproc == 1) & + write(lp,*) subname//': atmospheric co2 not read' +#endif + + call getfldindex(fldlist_num, fldlist, 'Sa_brfprog', index_Sa_brfprog) + + if (index_Sa_brfprog > 0) then + !$omp parallel do private(i, n) + do j = 1, jjcpl + do i = 1, ii + if (ip(i,j) == 0) then + atmbrf_da(i,j,l2ci) = mval + elseif (cplmsk(i,j) == 0) then + atmbrf_da(i,j,l2ci) = fval + else + n = (j - 1)*ii + i + ! Atmospheric bromoform concentration [ppt] + atmbrf_da(i,j,l2ci) = fldlist(index_Sa_brfprog)%dataptr(n) + endif + enddo + enddo + !$omp end parallel do + call fill_global(mval, fval, halo_ps, atmbrf_da(1-nbdy,1-nbdy,l2ci)) + if (mnproc == 1) & + write(lp,*) subname//': prog. atmospheric bromoform read' + else + !$omp parallel do private(i) + do j = 1, jj + do i = 1, ii + if (ip(i,j) == 0) then + atmbrf_da(i,j,l2ci) = mval + else + atmbrf_da(i,j,l2ci) = -1 + endif + enddo + enddo + !$omp end parallel do + if (mnproc == 1) & + write(lp,*) subname//': prog. atmospheric bromoform not read' + endif + + if (csdiag) then + if (mnproc == 1) then + write(lp,*) subname//':' + endif + call chksummsk(ustarw_da(1-nbdy,1-nbdy,l2ci),ip,1,'ustarw') + call chksummsk(ztx_da(1-nbdy,1-nbdy,l2ci),iu,1,'ztx') + call chksummsk(mty_da(1-nbdy,1-nbdy,l2ci),iv,1,'mty') + call chksummsk(lip_da(1-nbdy,1-nbdy,l2ci),ip,1,'lip') + call chksummsk(sop_da(1-nbdy,1-nbdy,l2ci),ip,1,'sop') + call chksummsk(eva_da(1-nbdy,1-nbdy,l2ci),ip,1,'eva') + call chksummsk(rnf_da(1-nbdy,1-nbdy,l2ci),ip,1,'rnf') + call chksummsk(rfi_da(1-nbdy,1-nbdy,l2ci),ip,1,'rfi') + call chksummsk(fmltfz_da(1-nbdy,1-nbdy,l2ci),ip,1,'fmltfz') + call chksummsk(sfl_da(1-nbdy,1-nbdy,l2ci),ip,1,'sfl') + call chksummsk(swa_da(1-nbdy,1-nbdy,l2ci),ip,1,'swa') + call chksummsk(nsf_da(1-nbdy,1-nbdy,l2ci),ip,1,'nsf') + call chksummsk(hmlt_da(1-nbdy,1-nbdy,l2ci),ip,1,'hmlt') + call chksummsk(slp_da(1-nbdy,1-nbdy,l2ci),ip,1,'slp') + call chksummsk(abswnd_da(1-nbdy,1-nbdy,l2ci),ip,1,'abswnd') + call chksummsk(ficem_da(1-nbdy,1-nbdy,l2ci),ip,1,'ficem') + call chksummsk(atmco2_da(1-nbdy,1-nbdy,l2ci),ip,1,'atmco2') + call chksummsk(atmbrf_da(1-nbdy,1-nbdy,l2ci),ip,1,'atmbrf') + endif + + end subroutine blom_importflds + + subroutine blom_exportflds(fldlist_num, fldlist) + ! --------------------------------------------------------------------------- + ! Export from BLOM arrays to mediator fields. + ! --------------------------------------------------------------------------- + + ! Input/output arguments. + integer, intent(in) :: fldlist_num + type(fldlist_type), dimension(:), intent(in) :: fldlist + + ! Local parameters. + character(len=*), parameter :: & + subname = modname//':(blom_exportflds)' + + ! Local variables. + real(r8) :: tfac, utmp, vtmp + integer :: n, l, i, j + integer, save :: & + index_So_omask = - 1, & + index_So_u = - 1, & + index_So_v = - 1, & + index_So_dhdx = - 1, & + index_So_dhdy = - 1, & + index_So_t = - 1, & + index_So_s = - 1, & + index_So_bldepth = - 1, & + index_Fioo_q = - 1, & + index_Faoo_fdms_ocn = - 1, & + index_Faoo_fco2_ocn = - 1, & + index_Faoo_fbrf_ocn = - 1 + + tfac = 1._r8/tlast_coupled + + ! ------------------------------------------------------------------------ + ! Provide standard export fields. + ! ------------------------------------------------------------------------ + + call xctilr(acc_u, 1,1, 1,1, halo_uv) + call xctilr(acc_v, 1,1, 1,1, halo_vv) + call xctilr(acc_dhdx, 1,1, 1,1, halo_uv) + call xctilr(acc_dhdy, 1,1, 1,1, halo_vv) + + call getfldindex(fldlist_num, fldlist, 'So_omask', index_So_omask) + call getfldindex(fldlist_num, fldlist, 'So_u', index_So_u) + call getfldindex(fldlist_num, fldlist, 'So_v', index_So_v) + call getfldindex(fldlist_num, fldlist, 'So_dhdx', index_So_dhdx) + call getfldindex(fldlist_num, fldlist, 'So_dhdy', index_So_dhdy) + call getfldindex(fldlist_num, fldlist, 'So_t', index_So_t) + call getfldindex(fldlist_num, fldlist, 'So_s', index_So_s) + call getfldindex(fldlist_num, fldlist, 'So_bldepth', index_So_bldepth) + call getfldindex(fldlist_num, fldlist, 'Fioo_q', index_Fioo_q) + + fldlist(index_So_omask)%dataptr(:) = 0._r8 + fldlist(index_So_u)%dataptr(:) = 0._r8 + fldlist(index_So_v)%dataptr(:) = 0._r8 + fldlist(index_So_dhdx)%dataptr(:) = 0._r8 + fldlist(index_So_dhdy)%dataptr(:) = 0._r8 + fldlist(index_So_t)%dataptr(:) = 0._r8 + fldlist(index_So_s)%dataptr(:) = 0._r8 + fldlist(index_So_bldepth)%dataptr(:) = 0._r8 + fldlist(index_Fioo_q)%dataptr(:) = 0._r8 + + !$omp parallel do private(l, i, n, utmp, vtmp) + do j = 1, jjcpl + do l = 1, isp(j) + do i = max(1, ifp(j,l)), min(ii, ilp(j,l)) + n = (j - 1)*ii + i + + ! Ocean mask []. + fldlist(index_So_omask)%dataptr(n) = 1._r8 + + ! Surface velocity, interpolated onto scalar points and rotated + ! [m s-1]. + utmp = .5_r8*(acc_u(i,j) + acc_u(i+1,j))*tfac*1.e-2_r8 + vtmp = .5_r8*(acc_v(i,j) + acc_v(i,j+1))*tfac*1.e-2_r8 + fldlist(index_So_u)%dataptr(n) = utmp*cosang(i,j) & + - vtmp*sinang(i,j) + fldlist(index_So_v)%dataptr(n) = utmp*sinang(i,j) & + + vtmp*cosang(i,j) + + ! Surface gradient, interpolated onto scalar points and rotated []. + utmp = (acc_dhdx(i,j)*iu(i,j) + acc_dhdx(i+1,j)*iu(i+1,j))*tfac & + /max(1, iu(i,j) + iu(i+1,j)) + vtmp = (acc_dhdy(i,j)*iv(i,j) + acc_dhdy(i,j+1)*iv(i,j+1))*tfac & + /max(1, iv(i,j) + iv(i,j+1)) + fldlist(index_So_dhdx)%dataptr(n) = utmp*cosang(i,j) & + - vtmp*sinang(i,j) + fldlist(index_So_dhdy)%dataptr(n) = utmp*sinang(i,j) & + + vtmp*cosang(i,j) + + ! Surface temperature [K]. + fldlist(index_So_t)%dataptr(n) = acc_t(i,j)*tfac & + + SHR_CONST_TKFRZ + + ! Surface salinity [g kg-1]. + fldlist(index_So_s)%dataptr(n) = acc_s(i,j)*tfac + + ! Boundary layer depth [m]. + fldlist(index_So_bldepth)%dataptr(n) = acc_bld(i,j)*tfac + + ! Freezing/melting potential [W m-2]. + if (acc_frzpot(i,j) > 0._r8) then + fldlist(index_Fioo_q)%dataptr(n) = & + acc_frzpot(i,j)*tfac*mod2med_areacor(n) + else + fldlist(index_Fioo_q)%dataptr(n) = & + mltpot(i,j)*tfac*mod2med_areacor(n) + endif + + enddo + enddo + enddo + !$omp end parallel do + + ! ------------------------------------------------------------------------ + ! Provide DMS flux [kmol DMS m-2 s-1], if requested. + ! ------------------------------------------------------------------------ + + call getfldindex(fldlist_num, fldlist, 'Faoo_fdms_ocn', & + index_Faoo_fdms_ocn) + + if (fbrf_requested .and. index_Faoo_fdms_ocn > 0) then + fldlist(index_Faoo_fdms_ocn)%dataptr(:) = 0._r8 + !$omp parallel do private(l, i, n) + do j = 1, jjcpl + do l = 1, isp(j) + do i = max(1, ifp(j,l)), min(ii, ilp(j,l)) + n = (j - 1)*ii + i + fldlist(index_Faoo_fdms_ocn)%dataptr(n) = & + acc_fbrf(i,j)*tfac*mod2med_areacor(n) + enddo + enddo + enddo + !$omp end parallel do + else + if (mnproc == 1) & + write(lp,*) subname//': dms flux not sent to coupler' + endif + + ! ------------------------------------------------------------------------ + ! Provide CO2 flux [kg CO2 m-2 s-1], if requested. + ! ------------------------------------------------------------------------ + + call getfldindex(fldlist_num, fldlist, 'Faoo_fco2_ocn', & + index_Faoo_fco2_ocn) + + if (fco2_requested .and. index_Faoo_fco2_ocn > 0) then + fldlist(index_Faoo_fco2_ocn)%dataptr(:) = 0._r8 + !$omp parallel do private(l, i, n) + do j = 1, jjcpl + do l = 1, isp(j) + do i = max(1, ifp(j,l)), min(ii, ilp(j,l)) + n = (j - 1)*ii + i + fldlist(index_Faoo_fco2_ocn)%dataptr(n) = & + acc_fco2(i,j)*tfac*mod2med_areacor(n) + enddo + enddo + enddo + !$omp end parallel do + else + if (mnproc == 1) & + write(lp,*) subname//': co2 flux not sent to coupler' + endif + + ! ------------------------------------------------------------------------ + ! Provide bromoform flux [kg CHBr3 m-2 s-1], if requested. + ! ------------------------------------------------------------------------ + + call getfldindex(fldlist_num, fldlist, 'Faoo_fbrf_ocn', & + index_Faoo_fbrf_ocn) + + if (fbrf_requested .and. index_Faoo_fbrf_ocn > 0) then + fldlist(index_Faoo_fbrf_ocn)%dataptr(:) = 0._r8 + !$omp parallel do private(l, i, n) + do j = 1, jjcpl + do l = 1, isp(j) + do i = max(1, ifp(j,l)), min(ii, ilp(j,l)) + n = (j - 1)*ii + i + fldlist(index_Faoo_fbrf_ocn)%dataptr(n) = & + acc_fbrf(i,j)*tfac*mod2med_areacor(n) + enddo + enddo + enddo + !$omp end parallel do + else + if (mnproc == 1) & + write(lp,*) subname//': bromoform flux not sent to coupler' + endif + + tlast_coupled = 0._r8 + + end subroutine blom_exportflds + +end module mod_nuopc_methods diff --git a/drivers/nuopc/mod_swtfrz.F90 b/drivers/nuopc/mod_swtfrz.F90 new file mode 100644 index 00000000..d5209eeb --- /dev/null +++ b/drivers/nuopc/mod_swtfrz.F90 @@ -0,0 +1,81 @@ +! ------------------------------------------------------------------------------ +! Copyright (C) 2018-2022 Mats Bentsen +! +! 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_swtfrz +! ------------------------------------------------------------------------------ +! This module contains routines for computing the freezing point of sea water. +! ------------------------------------------------------------------------------ + + use mod_types, only: r8 + use shr_frz_mod, only: shr_frz_freezetemp + + implicit none + + private + + public :: swtfrz + + interface swtfrz + module procedure swtfrz_0d + module procedure swtfrz_1d + module procedure swtfrz_2d + end interface swtfrz + +contains + + function swtfrz_0d(p,s) result(swtfrz) + ! --------------------------------------------------------------------------- + ! Retrieve freezing temperature from shared CESM function. + ! --------------------------------------------------------------------------- + + real(r8), intent(in) :: p ! Pressure [g cm-1 s-2] + real(r8), intent(in) :: s ! Salinity [g kg-1] + real(r8) :: swtfrz + + swtfrz = shr_frz_freezetemp(s) + + end function swtfrz_0d + + function swtfrz_1d(p,s) result(swtfrz) + ! --------------------------------------------------------------------------- + ! Retrieve freezing temperature from shared CESM function. + ! --------------------------------------------------------------------------- + + real(r8), intent(in) :: p(:) ! Pressure [g cm-1 s-2] + real(r8), intent(in) :: s(:) ! Salinity [g kg-1] + real(r8) :: swtfrz(size(s)) + + swtfrz(:) = shr_frz_freezetemp(s(:)) + + end function swtfrz_1d + + function swtfrz_2d(p,s) result(swtfrz) + ! --------------------------------------------------------------------------- + ! Retrieve freezing temperature from shared CESM function. + ! --------------------------------------------------------------------------- + + real(r8), intent(in) :: p(:,:) ! Pressure [g cm-1 s-2] + real(r8), intent(in) :: s(:,:) ! Salinity [g kg-1] + real(r8) :: swtfrz(size(s,1),size(s,2)) + + swtfrz(:,:) = shr_frz_freezetemp(s(:,:)) + + end function swtfrz_2d + +end module mod_swtfrz diff --git a/drivers/nuopc/ocn_comp_nuopc.F90 b/drivers/nuopc/ocn_comp_nuopc.F90 new file mode 100644 index 00000000..086501e5 --- /dev/null +++ b/drivers/nuopc/ocn_comp_nuopc.F90 @@ -0,0 +1,1189 @@ +! ------------------------------------------------------------------------------ +! Copyright (C) 2022 Mats Bentsen +! +! 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 ocn_comp_nuopc +! ------------------------------------------------------------------------------ +! This module contains the NUOPC cap for BLOM. +! ------------------------------------------------------------------------------ + + use ESMF ! TODO MOM6 uses "only" statements, while POP and CICE omits this. + use NUOPC, only: NUOPC_CompDerive, NUOPC_CompSetEntryPoint, & + NUOPC_CompSpecialize, NUOPC_CompFilterPhaseMap, & + NUOPC_IsUpdated, NUOPC_IsAtTime, NUOPC_CompAttributeGet, & + NUOPC_Advertise, NUOPC_SetAttribute, & + NUOPC_CompAttributeGet, NUOPC_CompAttributeSet, & + NUOPC_IsConnected, NUOPC_Realize + use NUOPC_Model, only: NUOPC_ModelGet, SetVM, & + model_routine_SS => SetServices, & + model_label_Advance => label_Advance, & + model_label_DataInitialize => label_DataInitialize, & + model_label_SetRunClock => label_SetRunClock, & + model_label_Finalize => label_Finalize + use nuopc_shr_methods, only : ChkErr, set_component_logging, & + get_component_instance, state_setscalar, & + alarmInit + use shr_file_mod, only: shr_file_getUnit, shr_file_getLogUnit, & + shr_file_setLogUnit + use shr_cal_mod, only : shr_cal_ymd2date + use mod_nuopc_methods, only: fldlist_type, tlast_coupled, fco2_requested, & + fdms_requested, fbrf_requested, & + blom_logwrite, blom_getgindex, blom_checkmesh, & + blom_setareacor, blom_getglobdim, & + blom_getprecipfact, blom_accflds, & + blom_importflds, blom_exportflds + use mod_xc, only: mpicom_external, lp, nfu + use mod_cesm, only: runid_cesm, runtyp_cesm, ocn_cpl_dt_cesm + use mod_config, only: inst_index, inst_name, inst_suffix + use mod_time, only: blom_time + + implicit none + + private + + integer, parameter :: cslen = 80 ! Short character string length. + integer, parameter :: cllen = 265 ! Long character string length. + character(len=*), parameter :: modname = '(ocn_comp_nuopc)' + character(len=*), parameter :: u_FILE_u = & + __FILE__ + + integer, parameter :: fldsMax = 100 + integer :: fldsToOcn_num = 0 + integer :: fldsFrOcn_num = 0 + type(fldlist_type) :: fldsToOcn(fldsMax) + type(fldlist_type) :: fldsFrOcn(fldsMax) + + character(len=cllen) :: flds_scalar_name = '' + integer :: flds_scalar_num = 0 + integer :: flds_scalar_index_nx = 0 + integer :: flds_scalar_index_ny = 0 + integer :: flds_scalar_index_precip_factor = 0 + + logical :: ldriver_has_atm_co2_diag, ldriver_has_atm_co2_prog, & + ocn2glc_coupling + + integer :: dbug = 0 + logical :: profile_memory = .false. + + public :: SetServices, SetVM + +contains + + ! --------------------------------------------------------------------------- + ! Private procedures. + ! --------------------------------------------------------------------------- + + subroutine fldlist_add(num, fldlist, stdname, & + ungridded_lbound, ungridded_ubound) + ! --------------------------------------------------------------------------- + ! Add to list of field information. + ! --------------------------------------------------------------------------- + + ! Input/output arguments. + integer , intent(inout) :: num + type(fldlist_type), intent(inout) :: fldlist(:) + character(len=*) , intent(in) :: stdname + integer, optional , intent(in) :: ungridded_lbound, ungridded_ubound + + ! Local parameters. + character(len=*), parameter :: & + subname = modname//':(fldlist_add)' + + ! Local variables. + integer :: rc + + num = num + 1 + if (num > fldsMax) then + call ESMF_LogSetError(ESMF_RC_VAL_OUTOFRANGE, & + msg=subname//": ERROR number of field exceeded fldsMax: "// & + trim(stdname), & + line=__LINE__, file=__FILE__, rcToReturn=rc) + return + endif + fldlist(num)%stdname = trim(stdname) + + if (present(ungridded_lbound) .and. present(ungridded_ubound)) then + fldlist(num)%ungridded_lbound = ungridded_lbound + fldlist(num)%ungridded_ubound = ungridded_ubound + endif + + end subroutine fldlist_add + + subroutine fldlist_realize(state, fldlist_num, fldlist, tag, mesh, rc) + ! --------------------------------------------------------------------------- + ! Realize list of import or export fields. + ! --------------------------------------------------------------------------- + + ! Input/output arguments. + type(ESMF_State) , intent(inout) :: state + integer , intent(in) :: fldlist_num + type(fldlist_type), intent(in) :: fldlist(:) + character(len=*) , intent(in) :: tag + type(ESMF_Mesh) , intent(in) :: mesh + integer , intent(inout) :: rc + + ! Local parameters. + character(len=*), parameter :: & + subname = modname//':(fldlist_realize)' + + ! Local variables. + integer :: n + type(ESMF_DistGrid) :: DistGrid + type(ESMF_Grid) :: grid + type(ESMF_Field) :: field + character(len=128) :: stdname + character(ESMF_MAXSTR) :: msg + + rc = ESMF_SUCCESS + + do n = 1, fldlist_num + + stdname = fldlist(n)%stdname + + if (NUOPC_IsConnected(state, fieldName=stdname)) then + + if (stdname == trim(flds_scalar_name)) then + + ! Create the scalar field. + call ESMF_LogWrite(subname//trim(tag)//" Field = "// & + trim(stdname)//" is connected on root pe", & + ESMF_LOGMSG_INFO) + DistGrid = ESMF_DistGridCreate(minIndex=(/1/), maxIndex=(/1/), rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + grid = ESMF_GridCreate(DistGrid, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + field = ESMF_FieldCreate(name=trim(flds_scalar_name), & + grid=grid, & + typekind=ESMF_TYPEKIND_R8, & + ungriddedLBound=(/1/), & + ungriddedUBound=(/flds_scalar_num/), & + gridToFieldMap=(/2/), rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + + else + + ! Create the field + if (fldlist(n)%ungridded_lbound > 0 .and. & + fldlist(n)%ungridded_ubound > 0) then + field = ESMF_FieldCreate(mesh, ESMF_TYPEKIND_R8, & + name=stdname, meshloc=ESMF_MESHLOC_ELEMENT, & + ungriddedLbound=(/fldlist(n)%ungridded_lbound/), & + ungriddedUbound=(/fldlist(n)%ungridded_ubound/), & + gridToFieldMap=(/2/), rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + write(msg,'(a,i4,2x,i4)') & + subname//trim(tag)//" Field = "//trim(stdname)// & + " is connected using mesh with lbound, ubound = ", & + fldlist(n)%ungridded_lbound, fldlist(n)%ungridded_ubound + call ESMF_LogWrite(msg, ESMF_LOGMSG_INFO) + else + field = ESMF_FieldCreate(mesh, ESMF_TYPEKIND_R8, & + name=stdname, & + meshloc=ESMF_MESHLOC_ELEMENT, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + write(msg,'(a)') & + subname//trim(tag)//" Field = "//trim(stdname)// & + " is connected using mesh without ungridded dimension" + call ESMF_LogWrite(msg, ESMF_LOGMSG_INFO) + endif + + endif + + ! Realize connected field. + call NUOPC_Realize(state, field=field, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + + else + + if (stdname /= trim(flds_scalar_name)) then + + call ESMF_LogWrite(subname//trim(tag)//" Field = "// & + trim(stdname)// " is not connected", & + ESMF_LOGMSG_INFO) + + ! Remove a not connected field from state. + call ESMF_StateRemove(state, (/stdname/), rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + + endif + + endif + + enddo + + end subroutine fldlist_realize + + subroutine ocn_import(importState, rc) + ! --------------------------------------------------------------------------- + ! Import data from the mediator to ocean. + ! --------------------------------------------------------------------------- + + ! Input/output arguments. + type(ESMF_State) :: importState + integer, intent(out) :: rc + + ! Local parameters. + character(len=*), parameter :: & + subname = modname//':(import)' + + ! Local variables. + type(ESMF_StateItem_Flag) :: itemType + type(ESMF_Field) :: field + integer :: n + + rc = ESMF_SUCCESS + + ! Get data pointers for the fields to be imported. + do n = 1, fldsToOcn_num + if (fldsToOcn(n)%stdname == trim(flds_scalar_name)) cycle + call ESMF_StateGet(importState, trim(fldsToOcn(n)%stdname), & + itemType, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + if (itemType == ESMF_STATEITEM_NOTFOUND) then + fldsToOcn(n)%dataptr => null() + else + call ESMF_StateGet(importState, trim(fldsToOcn(n)%stdname), & + field=field, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + call ESMF_FieldGet(field, farrayPtr=fldsToOcn(n)%dataptr, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + endif + enddo + + ! Import fields from mediator to BLOM arrays. + call blom_importflds(fldsToOcn_num, fldsToOcn) + + end subroutine ocn_import + + subroutine ocn_export(exportState, rc) + ! --------------------------------------------------------------------------- + ! Export data from ocean to the mediator. + ! --------------------------------------------------------------------------- + + ! Input/output arguments. + type(ESMF_State) :: exportState + integer, intent(out) :: rc + + ! Local parameters. + character(len=*), parameter :: & + subname = modname//':(export)' + + ! Local variables. + type(ESMF_StateItem_Flag) :: itemType + type(ESMF_Field) :: field + real(ESMF_KIND_R8) :: precip_fact + integer :: n + logical :: precip_fact_provided + + rc = ESMF_SUCCESS + + ! Get data pointers for the fields to be exported. + do n = 1, fldsFrOcn_num + if (fldsFrOcn(n)%stdname == trim(flds_scalar_name)) cycle + call ESMF_StateGet(exportState, trim(fldsFrOcn(n)%stdname), & + itemType, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + if (itemType == ESMF_STATEITEM_NOTFOUND) then + fldsFrOcn(n)%dataptr => null() + else + call ESMF_StateGet(exportState, trim(fldsFrOcn(n)%stdname), & + field=field, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + call ESMF_FieldGet(field, farrayPtr=fldsFrOcn(n)%dataptr, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + endif + enddo + + ! Export from BLOM arrays to mediator fields. + call blom_exportflds(fldsFrOcn_num, fldsFrOcn) + + ! Provide precipitation factor. + call blom_getprecipfact(precip_fact_provided, precip_fact) + if (precip_fact_provided) then + call state_setscalar(precip_fact, & + flds_scalar_index_precip_factor, exportState, & + flds_scalar_name, flds_scalar_num, rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + else + call state_setscalar(1._ESMF_KIND_R8, & + flds_scalar_index_precip_factor, exportState, & + flds_scalar_name, flds_scalar_num, rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + endif + + end subroutine ocn_export + + subroutine InitializeP0(gcomp, importState, exportState, clock, rc) + ! --------------------------------------------------------------------------- + ! Set which version of the Initialize Phase Definition (IPD) to use. + ! --------------------------------------------------------------------------- + + ! Input/output arguments. + type(ESMF_GridComp) :: gcomp + type(ESMF_State) :: importState, exportState + type(ESMF_Clock) :: clock + integer, intent(out) :: rc + + ! Local parameters. + character(len=*), parameter :: & + subname = modname//':(InitializeP0)' + + ! Local variables. + logical :: isPresent, isSet + character(len=cslen) :: cvalue + + ! Switch to IPDv01 by filtering all other PhaseMap entries + call NUOPC_CompFilterPhaseMap(gcomp, ESMF_METHOD_INITIALIZE, & + acceptStringList=(/"IPDv01p"/), rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + + profile_memory = .false. + call NUOPC_CompAttributeGet(gcomp, name="ProfileMemory", value=cvalue, & + isPresent=isPresent, isSet=isSet, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + if (isPresent .and. isSet) profile_memory = (trim(cvalue) == "true") + write(cvalue,*) profile_memory + call ESMF_LogWrite(subname//': ProfileMemory = '//trim(cvalue), & + ESMF_LOGMSG_INFO) + + end subroutine InitializeP0 + + subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) + ! --------------------------------------------------------------------------- + ! Called by NUOPC to advertise import and export fields. "Advertise" simply + ! means that the standard names of all import and export fields are supplied. + ! The NUOPC layer uses these to match fields between components in the + ! coupled system. + ! --------------------------------------------------------------------------- + + ! Input/output arguments. + type(ESMF_GridComp) :: gcomp + type(ESMF_State) :: importState, exportState + type(ESMF_Clock) :: clock + integer, intent(out) :: rc + + ! Local parameters. + character(len=*), parameter :: & + subname = modname//':(InitializeAdvertise)' + + ! local variables + type(ESMF_VM) :: vm + type(ESMF_TimeInterval) :: timeStep + integer :: localPet, nthrds, shrlogunit, n + character(len=cslen) :: starttype, stdname, cvalue, cname + character(len=cllen) :: msg + logical :: isPresent, isSet, flds_co2a, flds_co2b, flds_co2c + + ! Get debug flag. + call NUOPC_CompAttributeGet(gcomp, name='dbug_flag', value=cvalue, & + isPresent=isPresent, isSet=isSet, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + if (isPresent .and. isSet) read(cvalue,*) dbug + write(cvalue,*) dbug + call ESMF_LogWrite(subname//': dbug = '//trim(cvalue), ESMF_LOGMSG_INFO) + + ! Get local MPI communicator and Persistent Execution Thread (PET). + call ESMF_GridCompGet(gcomp, vm=vm, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + call ESMF_VMGet(vm, mpiCommunicator=mpicom_external, localPet=localPet, & + rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + + ! OpenMP threads + call ESMF_VMGet(vm, pet=localPet, peCount=nthrds, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + if (nthrds == 1) then + call NUOPC_CompAttributeGet(gcomp, "nthreads", value=cvalue, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + read(cvalue,*) nthrds + endif +!$ call omp_set_num_threads(nthrds) + + ! Reset shr logging to components log file. + call set_component_logging(gcomp, localPet==0, lp, shrlogunit, rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + + ! Get generic file unit for master task. + if (localPet == 0) then + nfu = shr_file_getUnit() + else + nfu = -1 + endif + + ! Get case name. + call NUOPC_CompAttributeGet(gcomp, name='case_name', value=cvalue, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + read(cvalue,*) runid_cesm + + ! Get start type. + call NUOPC_CompAttributeGet(gcomp, name='start_type', value=cvalue, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + read(cvalue,*) starttype + if (trim(starttype) == trim('startup')) then + runtyp_cesm = "initial" + else if (trim(starttype) == trim('continue') ) then + runtyp_cesm = "continue" + else if (trim(starttype) == trim('branch')) then + runtyp_cesm = "continue" + else + call ESMF_LogSetError(ESMF_RC_ARG_BAD, & + msg=subname//": unknown starttype - "//trim(starttype), & + line=__LINE__, file=u_FILE_u, rcToReturn=rc) + return + endif + + ! Get multiple instance data. + call get_component_instance(gcomp, inst_suffix, inst_index, rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + inst_name = "OCN" + + ! Get coupling time interval. + call ESMF_ClockGet(clock, timeStep=timeStep, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + call ESMF_TimeIntervalGet(timeStep, s=ocn_cpl_dt_cesm, rc=rc ) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + + ! ------------------------------------------------------------------------ + ! Initialize BLOM. + ! ------------------------------------------------------------------------ + + call blom_init + + ! ------------------------------------------------------------------------ + ! Get ScalarField attributes. + ! ------------------------------------------------------------------------ + + call NUOPC_CompAttributeGet(gcomp, name="ScalarFieldName", value=cvalue, & + isPresent=isPresent, isSet=isSet, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + if (isPresent .and. isSet) then + flds_scalar_name = trim(cvalue) + call ESMF_LogWrite(subname//': flds_scalar_name = '//trim(cvalue), & + ESMF_LOGMSG_INFO) + else + call ESMF_LogSetError(ESMF_RC_NOT_SET, & + msg=subname//": ScalarFieldName is not set", & + line=__LINE__, file=__FILE__, rcToReturn=rc) + return + endif + + call NUOPC_CompAttributeGet(gcomp, name="ScalarFieldCount", & + value=cvalue, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + read(cvalue,*) flds_scalar_num + write(cvalue,*) flds_scalar_num + call ESMF_LogWrite(subname//': flds_scalar_num = '//trim(cvalue), & + ESMF_LOGMSG_INFO) + + call NUOPC_CompAttributeGet(gcomp, name="ScalarFieldIdxGridNX", & + value=cvalue, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + read(cvalue,*) flds_scalar_index_nx + write(cvalue,*) flds_scalar_index_nx + call ESMF_LogWrite(subname//': flds_scalar_index_nx = '//trim(cvalue), & + ESMF_LOGMSG_INFO) + + call NUOPC_CompAttributeGet(gcomp, name="ScalarFieldIdxGridNY", & + value=cvalue, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + read(cvalue,*) flds_scalar_index_ny + write(cvalue,*) flds_scalar_index_ny + call ESMF_LogWrite(subname//': flds_scalar_index_ny = '//trim(cvalue), & + ESMF_LOGMSG_INFO) + + call NUOPC_CompAttributeGet(gcomp, name="ScalarFieldIdxPrecipFactor", & + value=cvalue, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + read(cvalue,*) flds_scalar_index_precip_factor + if ( .not. flds_scalar_index_precip_factor > 0 ) then + call ESMF_LogSetError(ESMF_RC_VAL_OUTOFRANGE, & + msg=subname//": flds_scalar_index_precip_factor must be > 0", & + line=__LINE__, file=u_FILE_u, rcToReturn=rc) + return + else + write(cvalue,*) flds_scalar_index_precip_factor + call ESMF_LogWrite(subname//': flds_scalar_index_precip_factor = '// & + trim(cvalue), ESMF_LOGMSG_INFO) + endif + + ! ------------------------------------------------------------------------ + ! Advertise import fields. + ! ------------------------------------------------------------------------ + + call fldlist_add(fldsToOcn_num, fldsToOcn, trim(flds_scalar_name)) + + ! From ice: + call fldlist_add(fldsToOcn_num, fldsToOcn, 'Si_ifrac') + call fldlist_add(fldsToOcn_num, fldsToOcn, 'Fioi_melth') + call fldlist_add(fldsToOcn_num, fldsToOcn, 'Fioi_meltw') + call fldlist_add(fldsToOcn_num, fldsToOcn, 'Fioi_salt') + call fldlist_add(fldsToOcn_num, fldsToOcn, 'Fioi_bcpho') + call fldlist_add(fldsToOcn_num, fldsToOcn, 'Fioi_bcphi') + call fldlist_add(fldsToOcn_num, fldsToOcn, 'Fioi_flxdst') + + ! From river: + call fldlist_add(fldsToOcn_num, fldsToOcn, 'Foxx_rofl') + call fldlist_add(fldsToOcn_num, fldsToOcn, 'Foxx_rofi') + + ! From mediator: + call fldlist_add(fldsToOcn_num, fldsToOcn, 'So_duu10n') + call fldlist_add(fldsToOcn_num, fldsToOcn, 'Foxx_tauy') + call fldlist_add(fldsToOcn_num, fldsToOcn, 'Foxx_taux') + call fldlist_add(fldsToOcn_num, fldsToOcn, 'Foxx_lat') + call fldlist_add(fldsToOcn_num, fldsToOcn, 'Foxx_sen') + call fldlist_add(fldsToOcn_num, fldsToOcn, 'Foxx_lwup') + call fldlist_add(fldsToOcn_num, fldsToOcn, 'Foxx_evap') + call fldlist_add(fldsToOcn_num, fldsToOcn, 'Foxx_swnet') + + ! From wave: + call fldlist_add(fldsToOcn_num, fldsToOcn, 'Sw_lamult') + call fldlist_add(fldsToOcn_num, fldsToOcn, 'Sw_ustokes') + call fldlist_add(fldsToOcn_num, fldsToOcn, 'Sw_vstokes') + call fldlist_add(fldsToOcn_num, fldsToOcn, 'Sw_hstokes') + + ! From atmosphere: + call fldlist_add(fldsToOcn_num, fldsToOcn, 'Sa_pslv') + call fldlist_add(fldsToOcn_num, fldsToOcn, 'Faxa_lwdn') + call fldlist_add(fldsToOcn_num, fldsToOcn, 'Faxa_snow') + call fldlist_add(fldsToOcn_num, fldsToOcn, 'Faxa_rain') + + ! From atm co2 fields: + + call NUOPC_CompAttributeGet(gcomp, name='flds_co2a', value=cvalue, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + read(cvalue,*) flds_co2a + call blom_logwrite(subname//': flds_co2a = '//trim(cvalue)) + + call NUOPC_CompAttributeGet(gcomp, name='flds_co2b', value=cvalue, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + read(cvalue,*) flds_co2b + call blom_logwrite(subname//': flds_co2b = '//trim(cvalue)) + + call NUOPC_CompAttributeGet(gcomp, name='flds_co2c', value=cvalue, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + read(cvalue,*) flds_co2c + call blom_logwrite(subname//': flds_co2c = '//trim(cvalue)) + + if (flds_co2a .or. flds_co2c) then + call fldlist_add(fldsToOcn_num, fldsToOcn, 'Sa_co2diag') + call fldlist_add(fldsToOcn_num, fldsToOcn, 'Sa_co2prog') + ldriver_has_atm_co2_prog = .true. + ldriver_has_atm_co2_diag = .true. + else + ldriver_has_atm_co2_prog = .false. + ldriver_has_atm_co2_diag = .false. + endif + + !TODO Determine if will get nitrogen deposition from atm + + do n = 1,fldsToOcn_num + call NUOPC_Advertise(importState, standardName=fldsToOcn(n)%stdname, & + TransferOfferGeomObject='will provide', rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + enddo + + ! ------------------------------------------------------------------------ + ! Advertise export fields. + ! ------------------------------------------------------------------------ + + ! Determine if ocn is sending temperature and salinity data to glc + call NUOPC_CompAttributeGet(gcomp, name="ocn2glc_coupling", value=cvalue, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + read(cvalue,*) ocn2glc_coupling + write(msg,'(a,l1)') subname//': ocn2glc coupling is ', ocn2glc_coupling + call blom_logwrite(msg) + + ! Determine number of ocean levels and ocean level indices + if (ocn2glc_coupling) then + call ESMF_LogSetError(ESMF_RC_NOT_IMPL, & + msg=subname//": ocn2glc coupling not implemented", & + line=__LINE__, file=u_FILE_u, rcToReturn=rc) + return + endif + + call fldlist_add(fldsFrOcn_num, fldsFrOcn, trim(flds_scalar_name)) + call fldlist_add(fldsFrOcn_num, fldsFrOcn, 'So_omask') + call fldlist_add(fldsFrOcn_num, fldsFrOcn, 'So_t') + call fldlist_add(fldsFrOcn_num, fldsFrOcn, 'So_u') + call fldlist_add(fldsFrOcn_num, fldsFrOcn, 'So_v') + call fldlist_add(fldsFrOcn_num, fldsFrOcn, 'So_s') + call fldlist_add(fldsFrOcn_num, fldsFrOcn, 'So_dhdx') + call fldlist_add(fldsFrOcn_num, fldsFrOcn, 'So_dhdy') + call fldlist_add(fldsFrOcn_num, fldsFrOcn, 'So_bldepth') + call fldlist_add(fldsFrOcn_num, fldsFrOcn, 'Fioo_q') + call fldlist_add(fldsFrOcn_num, fldsFrOcn, 'Faoo_fco2_ocn') + + do n = 1,fldsFrOcn_num + call NUOPC_Advertise(exportState, standardName=fldsFrOcn(n)%stdname, & + TransferOfferGeomObject='will provide', rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + enddo + + if (dbug > 5) call ESMF_LogWrite(subname//': done', ESMF_LOGMSG_INFO) + + end subroutine InitializeAdvertise + + subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) + ! --------------------------------------------------------------------------- + ! Called by NUOPC to realize import and export fields. "Realizing" a field + ! means that its grid has been defined and an ESMF_Field object has been + ! created and put into the import or export State. + ! --------------------------------------------------------------------------- + + ! Input/output arguments. + type(ESMF_GridComp) :: gcomp + type(ESMF_State) :: importState, exportState + type(ESMF_Clock) :: clock + integer, intent(out) :: rc + + ! Local parameters. + character(len=*), parameter :: & + subname = modname//':(InitializeRealize)' + + ! Local variables. + type(ESMF_DistGrid) :: DistGrid + type(ESMF_Mesh) :: EMesh + type(ESMF_Array) :: elemMaskArray + type(ESMF_Field) :: field + real(ESMF_KIND_R8), dimension(:), pointer :: & + ownedElemCoords, lonMesh, latMesh, areaMesh + integer(ESMF_KIND_I4), dimension(:), pointer :: maskMesh(:) + integer, allocatable, dimension(:) :: gindex + integer :: n, spatialDim, numOwnedElements, nx_global, ny_global + character(len=cslen) :: cvalue + + if (dbug > 5) call ESMF_LogWrite(subname//': called', ESMF_LOGMSG_INFO) + + ! Get the BLOM global index space for the computational domain. + call blom_getgindex(gindex) + + ! Create DistGrid from global index array. + DistGrid = ESMF_DistGridCreate(arbSeqIndexList=gindex, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + + ! Create the mesh. + call NUOPC_CompAttributeGet(gcomp, name='mesh_ocn', value=cvalue, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + EMesh = ESMF_MeshCreate(filename=trim(cvalue), & + fileformat=ESMF_FILEFORMAT_ESMFMESH, & + elementDistgrid=DistGrid, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + call blom_logwrite(subname//': mesh file for blom domain is '// & + trim(cvalue)) + + ! ------------------------------------------------------------------------ + ! Check for consistency of lat, lon and mask between mesh and model grid. + ! ------------------------------------------------------------------------ + + call ESMF_MeshGet(Emesh, spatialDim=spatialDim, & + numOwnedElements=numOwnedElements, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + + allocate(ownedElemCoords(spatialDim*numOwnedElements), & + lonMesh(numOwnedElements), latMesh(numOwnedElements), & + maskMesh(numOwnedElements)) + + call ESMF_MeshGet(Emesh, ownedElemCoords=ownedElemCoords, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + do n = 1, numOwnedElements + lonMesh(n) = ownedElemCoords(2*n-1) + latMesh(n) = ownedElemCoords(2*n) + enddo + + elemMaskArray = ESMF_ArrayCreate(Distgrid, maskMesh, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + call ESMF_MeshGet(Emesh, elemMaskArray=elemMaskArray, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + + call blom_checkmesh(lonMesh, latMesh, maskMesh) + + ! ------------------------------------------------------------------------ + ! Determine flux area correction factors. + ! ------------------------------------------------------------------------ + + field = ESMF_FieldCreate(Emesh, ESMF_TYPEKIND_R8, & + meshloc=ESMF_MESHLOC_ELEMENT, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + call ESMF_FieldRegridGetArea(field, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + call ESMF_FieldGet(field, farrayPtr=areaMesh, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + + call blom_setareacor(areaMesh, maskMesh) + + ! ------------------------------------------------------------------------ + ! Realize the actively coupled fields. + ! ------------------------------------------------------------------------ + + call fldlist_realize(state=importState, & + fldlist_num=fldsToOcn_num, fldlist=fldsToOcn, & + tag=subname//':BLOM_Import', mesh=EMesh, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + + call fldlist_realize(state=exportState, & + fldlist_num=fldsFrOcn_num, fldlist=fldsFrOcn, & + tag=subname//':BLOM_Export', mesh=EMesh, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + + ! ------------------------------------------------------------------------ + ! Set scalar data in export state. + ! ------------------------------------------------------------------------ + + call blom_getglobdim(nx_global, ny_global) + + call state_setscalar(real(nx_global, ESMF_KIND_R8), & + flds_scalar_index_nx, exportState, & + flds_scalar_name, flds_scalar_num, rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + + call state_setscalar(real(ny_global, ESMF_KIND_R8), & + flds_scalar_index_ny, exportState, & + flds_scalar_name, flds_scalar_num, rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + + if (dbug > 5) call ESMF_LogWrite(subname//': done', ESMF_LOGMSG_INFO) + + end subroutine InitializeRealize + + subroutine DataInitialize(gcomp, rc) + ! --------------------------------------------------------------------------- + ! Called by NUOPC to do the initial data export from ocean to mediator. + ! --------------------------------------------------------------------------- + + ! Input/output arguments. + type(ESMF_GridComp) :: gcomp + integer, intent(out) :: rc + + ! Local parameters. + character(len=*), parameter :: & + subname = modname//':(DataInitialize)' + + ! Local variables. + type(ESMF_State) :: exportState + type(ESMF_StateItem_flag) :: itemType + + if (dbug > 5) call ESMF_LogWrite(subname//': called', ESMF_LOGMSG_INFO) + + ! ------------------------------------------------------------------------ + ! Query the Component for its exportState. + ! ------------------------------------------------------------------------ + + call ESMF_GridCompGet(gcomp, exportState=exportState, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + + ! ------------------------------------------------------------------------ + ! Check whether non-standard export fields are present. + ! ------------------------------------------------------------------------ + + call ESMF_StateGet(exportState, 'Faoo_fco2_ocn', itemType) + fco2_requested = (itemType /= ESMF_STATEITEM_NOTFOUND) + + call ESMF_StateGet(exportState, 'Faoo_fdms_ocn', itemType) + fdms_requested = (itemType /= ESMF_STATEITEM_NOTFOUND) + + call ESMF_StateGet(exportState, 'Faoo_fbrf_ocn', itemType) + fbrf_requested = (itemType /= ESMF_STATEITEM_NOTFOUND) + + ! ------------------------------------------------------------------------ + ! TODO + ! ------------------------------------------------------------------------ + + tlast_coupled = 0._ESMF_KIND_R8 + call blom_accflds + call ocn_export(exportState, rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + + ! ------------------------------------------------------------------------ + ! Check whether all Fields in the exportState are "Updated" TODO + ! ------------------------------------------------------------------------ + + if (NUOPC_IsUpdated(exportState)) then + call NUOPC_CompAttributeSet(gcomp, name="InitializeDataComplete", & + value="true", rc=rc) + call ESMF_LogWrite("BLOM - Initialize-Data-Dependency SATISFIED!!!", & + ESMF_LOGMSG_INFO) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + else + call ESMF_LogWrite("BLOM - Initialize-Data-Dependency NOT SATISFIED!!!", & + ESMF_LOGMSG_INFO) + endif + + if (dbug > 5) call ESMF_LogWrite(subname//': done', ESMF_LOGMSG_INFO) + + end subroutine DataInitialize + + subroutine ModelAdvance(gcomp, rc) + ! --------------------------------------------------------------------------- + ! Called by NUOPC to advance the model a single timestep. + ! --------------------------------------------------------------------------- + + ! Input/output arguments. + type(ESMF_GridComp) :: gcomp + integer, intent(out) :: rc + + ! Local parameters. + character(len=*), parameter :: & + subname = modname//':(ModelAdvance)' + + ! Local variables. + type(ESMF_State) :: importState, exportState + type(ESMF_Clock) :: clock + type(ESMF_Time) :: currTime + type(ESMF_Alarm) :: restart_alarm + integer :: shrlogunit, yr_sync, mon_sync, day_sync, tod_sync, ymd_sync, & + ymd, tod + logical :: first_call = .true., restart_alarm_on + character(len=cllen) :: msg + + if (dbug > 5) call ESMF_LogWrite(subname//': called', ESMF_LOGMSG_INFO) + + rc = ESMF_SUCCESS + + ! ------------------------------------------------------------------------ + ! Reset shr logging to components log file. + ! ------------------------------------------------------------------------ + + call shr_file_getLogUnit(shrlogunit) + call shr_file_setLogUnit(lp) + + ! ------------------------------------------------------------------------ + ! Skip first coupling interval for an initial run. + ! ------------------------------------------------------------------------ + + if (first_call) then + first_call = .false. + if (runtyp_cesm == 'initial') then + call blom_logwrite('Returning at first coupling interval') + return + endif + endif + + ! ------------------------------------------------------------------------ + ! Query the Component for its clock, importState and exportState. + ! ------------------------------------------------------------------------ + + call NUOPC_ModelGet(gcomp, modelClock=clock, importState=importState, & + exportState=exportState, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + + ! ------------------------------------------------------------------------ + ! Check that internal clock is in sync with master clock. + ! ------------------------------------------------------------------------ + + if (ChkErr(rc, __LINE__, u_FILE_u)) return + call ESMF_ClockGet( clock, currTime=currTime, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + call ESMF_TimeGet(currTime, yy=yr_sync, mm=mon_sync, dd=day_sync, & + s=tod_sync, rc=rc ) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + call shr_cal_ymd2date(yr_sync, mon_sync, day_sync, ymd_sync) + + call blom_time(ymd, tod) + if (ymd /= ymd_sync .or. tod /= tod_sync) then + write(msg,*) ' blom ymd=',ymd ,' blom tod= ',tod + call blom_logwrite(msg) + write(msg,*) ' sync ymd=',ymd_sync,' sync tod= ',tod_sync + call blom_logwrite(msg) + call ESMF_LogSetError(ESMF_FAILURE, & + msg=subname//": Internal blom clock not in sync with Sync Clock", & + line=__LINE__, file=u_FILE_u, rcToReturn=rc) + return + endif + + ! ------------------------------------------------------------------------ + ! Advance the model in time over a coupling interval. + ! ------------------------------------------------------------------------ + + blom_loop: do + + if (nint(tlast_coupled) == 0) then + ! Obtain import state from driver + call ocn_import(importState, rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + endif + + ! Advance the model a time step. + call blom_step + + ! Accumulate BLOM export fields. + call blom_accflds + + if (nint(ocn_cpl_dt_cesm-tlast_coupled) == 0) then + ! Return export state to driver and exit integration loop + call ocn_export(exportState, rc) + exit blom_loop + endif + +! if (mnproc == 1) then +! call shr_sys_flush(lp) +! endif + + enddo blom_loop + + ! ------------------------------------------------------------------------ + ! If restart alarm is ringing - write restart file. TODO do we need to + ! consider stop alarm? + ! ------------------------------------------------------------------------ + + call ESMF_ClockGetAlarm(clock, alarmname='restart_alarm', & + alarm=restart_alarm, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + restart_alarm_on = ESMF_AlarmIsRinging(restart_alarm, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + + if (restart_alarm_on) then + + ! Turn off the alarm + call ESMF_AlarmRingerOff(restart_alarm, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + + ! Write BLOM restart files. + call restart_wt + + endif + + ! ------------------------------------------------------------------------ + ! Reset shr logging to original values. + ! ------------------------------------------------------------------------ + + call shr_file_setLogUnit(shrlogunit) + + if (dbug > 5) call ESMF_LogWrite(subname//': done', ESMF_LOGMSG_INFO) + + end subroutine ModelAdvance + + subroutine ModelSetRunClock(gcomp, rc) + ! --------------------------------------------------------------------------- + ! Synchronize driver and model clock and set restart and stop alarms. + ! --------------------------------------------------------------------------- + + ! Input/output arguments. + type(ESMF_GridComp) :: gcomp + integer, intent(out) :: rc + + ! Local parameters. + character(len=*), parameter :: & + subname = modname//':(ModelSetRunClock)' + + ! Local variables. + type(ESMF_Clock) :: mclock, dclock + type(ESMF_Time) :: mcurrtime, dcurrtime, mstoptime + type(ESMF_TimeInterval) :: mtimestep, dtimestep + type(ESMF_ALARM) :: restart_alarm, stop_alarm + integer :: restart_n, restart_ymd, stop_n, stop_ymd, alarmcount + character(len=256) :: cvalue, restart_option, stop_option + character(len=128) :: name + + if (dbug > 5) call ESMF_LogWrite(subname//': called', ESMF_LOGMSG_INFO) + + ! Query the component for its clocks. + + call NUOPC_ModelGet(gcomp, driverClock=dclock, modelClock=mclock, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + + call ESMF_ClockGet(dclock, currTime=dcurrtime, timeStep=dtimestep, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + + call ESMF_ClockGet(mclock, currTime=mcurrtime, timeStep=mtimestep, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + + ! ------------------------------------------------------------------------ + ! Force model clock currtime and timestep to match driver and set + ! stoptime. + ! ------------------------------------------------------------------------ + + mstoptime = mcurrtime + dtimestep + call ESMF_ClockSet(mclock, currTime=dcurrtime, timeStep=dtimestep, & + stopTime=mstoptime, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + + ! ------------------------------------------------------------------------ + ! Set restart and stop alarms. + ! ------------------------------------------------------------------------ + + call ESMF_ClockGetAlarmList(mclock, alarmlistflag=ESMF_ALARMLIST_ALL, & + alarmCount=alarmCount, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + + if (alarmCount == 0) then + + call ESMF_GridCompGet(gcomp, name=name, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + call ESMF_LogWrite(subname//': setting alarms for '//trim(name), & + ESMF_LOGMSG_INFO) + + + ! Restart alarm. + + call NUOPC_CompAttributeGet(gcomp, name="restart_option", & + value=restart_option, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + + call NUOPC_CompAttributeGet(gcomp, name="restart_n", & + value=cvalue, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + read(cvalue,*) restart_n + + call NUOPC_CompAttributeGet(gcomp, name="restart_ymd", & + value=cvalue, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + read(cvalue,*) restart_ymd + + call alarmInit(mclock, restart_alarm, restart_option, & + opt_n=restart_n, opt_ymd=restart_ymd, & + RefTime=mcurrTime, alarmname='restart_alarm', rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + + call ESMF_AlarmSet(restart_alarm, clock=mclock, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + + ! Stop alarm. + + call NUOPC_CompAttributeGet(gcomp, name="stop_option", & + value=stop_option, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + + call NUOPC_CompAttributeGet(gcomp, name="stop_n", & + value=cvalue, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + read(cvalue,*) stop_n + + call NUOPC_CompAttributeGet(gcomp, name="stop_ymd", & + value=cvalue, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + read(cvalue,*) stop_ymd + + call alarmInit(mclock, stop_alarm, stop_option, & + opt_n=stop_n, opt_ymd=stop_ymd, RefTime=mcurrTime, & + alarmname='stop_alarm', rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + + call ESMF_AlarmSet(stop_alarm, clock=mclock, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + + endif + + ! ------------------------------------------------------------------------ + ! Advance model clock to trigger alarms then reset model clock back to + ! currtime. + ! ------------------------------------------------------------------------ + + call ESMF_ClockAdvance(mclock, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + + call ESMF_ClockSet(mclock, currTime=dcurrtime, timeStep=dtimestep, & + stopTime=mstoptime, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + + if (dbug > 5) call ESMF_LogWrite(subname//': done', ESMF_LOGMSG_INFO) + + end subroutine ModelSetRunClock + + subroutine ModelFinalize(gcomp, rc) + ! --------------------------------------------------------------------------- + ! Called by NUOPC to finalize the model. + ! --------------------------------------------------------------------------- + + ! Input/output arguments. + type(ESMF_GridComp) :: gcomp + integer, intent(out) :: rc + + ! Local parameters. + character(len=*), parameter :: & + subname = modname//':(ModelFinalize)' + + if (dbug > 5) call ESMF_LogWrite(subname//': called', ESMF_LOGMSG_INFO) + + rc = ESMF_SUCCESS + + if (dbug > 5) call ESMF_LogWrite(subname//': done', ESMF_LOGMSG_INFO) + + end subroutine ModelFinalize + + ! --------------------------------------------------------------------------- + ! Public procedures. + ! --------------------------------------------------------------------------- + + subroutine SetServices(gcomp, rc) + ! --------------------------------------------------------------------------- + ! NUOPC SetService method is the only public entry point. SetServices + ! registers all of the user-provided subroutines in the module with the NUOPC + ! layer. + ! --------------------------------------------------------------------------- + + ! Input/output arguments. + type(ESMF_GridComp) :: gcomp ! ESMF_GridComp object. + integer, intent(out) :: rc ! Return code. + + ! Local parameters. + character(len=*), parameter :: & + subname = modname//':(SetServices)' + + if (dbug > 5) call ESMF_LogWrite(subname//': called', ESMF_LOGMSG_INFO) + + ! The NUOPC gcomp component will register the generic methods. + call NUOPC_CompDerive(gcomp, model_routine_SS, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + + ! Switching to IPD versions. + call ESMF_GridCompSetEntryPoint(gcomp, ESMF_METHOD_INITIALIZE, & + userRoutine=InitializeP0, phase=0, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + + ! Set entry point for methods that require specific implementation. + call NUOPC_CompSetEntryPoint(gcomp, ESMF_METHOD_INITIALIZE, & + phaseLabelList=(/"IPDv01p1"/), & + userRoutine=InitializeAdvertise, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + + call NUOPC_CompSetEntryPoint(gcomp, ESMF_METHOD_INITIALIZE, & + phaseLabelList=(/"IPDv01p3"/), & + userRoutine=InitializeRealize, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + + ! Attach specializing method(s). + call NUOPC_CompSpecialize(gcomp, specLabel=model_label_DataInitialize, & + specRoutine=DataInitialize, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + + call NUOPC_CompSpecialize(gcomp, specLabel=model_label_Advance, & + specRoutine=ModelAdvance, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + + call ESMF_MethodRemove(gcomp, label=model_label_SetRunClock, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + call NUOPC_CompSpecialize(gcomp, specLabel=model_label_SetRunClock, & + specRoutine=ModelSetRunClock, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + +! TODO Method used by POP, not by MOM6 and CICE. +! call ESMF_MethodRemove(gcomp, label=model_label_CheckImport, rc=rc) +! if (ChkErr(rc, __LINE__, u_FILE_u)) return +! call NUOPC_CompSpecialize(gcomp, specLabel=model_label_CheckImport, & +! specRoutine=ModelCheckImport, rc=rc) +! if (ChkErr(rc, __LINE__, u_FILE_u)) return + + call NUOPC_CompSpecialize(gcomp, specLabel=model_label_Finalize, & + specRoutine=ModelFinalize, rc=rc) + if (ChkErr(rc, __LINE__, u_FILE_u)) return + + if (dbug > 5) call ESMF_LogWrite(subname//': done', ESMF_LOGMSG_INFO) + + end subroutine SetServices + +end module ocn_comp_nuopc diff --git a/drivers/nuopc/setlogunit.F90 b/drivers/nuopc/setlogunit.F90 new file mode 100644 index 00000000..fa73bd12 --- /dev/null +++ b/drivers/nuopc/setlogunit.F90 @@ -0,0 +1,25 @@ +! ------------------------------------------------------------------------------ +! Copyright (C) 2022 Mats Bentsen +! +! 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 . +! ------------------------------------------------------------------------------ + +subroutine setlogunit +! ------------------------------------------------------------------------------ +! Empty routine since log unit is set in routine InitializeAdvertise of the +! module ocn_comp_nuopc. +! ------------------------------------------------------------------------------ +end subroutine setlogunit diff --git a/fuk95/mod_fuk95.F90 b/fuk95/mod_fuk95.F90 index 5bc0e64e..9a2b7054 100644 --- a/fuk95/mod_fuk95.F90 +++ b/fuk95/mod_fuk95.F90 @@ -1,5 +1,5 @@ ! ------------------------------------------------------------------------------ -! Copyright (C) 2021 Mats Bentsen +! Copyright (C) 2021-2022 Mats Bentsen ! ! This file is part of BLOM. ! @@ -25,10 +25,11 @@ module mod_fuk95 ! ------------------------------------------------------------------------------ use mod_types, only: r8 - use mod_constants, only: g, rearth, pi, radian + use mod_constants, only: g, rearth, rho0, pi, radian, epsilz, & + L_mks2cgs, R_mks2cgs use mod_xc - use mod_grid, only: sigmar, & - qclon, qclat, pclon, pclat, uclon, uclat, vclon, vclat, & + use mod_vcoord, only: vcoord_type_tag, isopyc_bulkml, cntiso_hybrid, 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, & qlon, qlat, plon, plat, ulon, ulat, vlon, vlat, & @@ -45,19 +46,32 @@ module mod_fuk95 private +! real(r8), parameter :: & +! u0 = 30._r8, & ! Maximum jet velocity [cm s-1]. +! h1 = 1.e4_r8, & ! Depth of active layer [cm]. +! h0 = 2.e4_r8, & ! Depth of water column [cm]. +! l0 = 2.e6_r8, & ! Half-width of the jet [cm]. +! drho = 0.19e-3_r8, & ! Active layer density difference [g cm-3]. +! rhoc = 1.0259_r8, & ! Density at the center of active layer [g cm-3]. +! rhob = 1.0270_r8, & ! Density of water beneath active layer [g cm-3]. +! f = 1.e-4_r8, & ! Coriolis parameter [1 s-1]. +! lat0 = 45._r8, & ! Center latitude of grid domain [deg]. +! lambda = 20.8e5, & ! Channel length [cm]. +! mindz = 1.e2_r8, & ! Minimum interior layer thickness [cm]. +! saln0 = 35._r8 ! Constant salinity value [g kg-1]. real(r8), parameter :: & - u0 = 30._r8, & ! Maximum jet velocity [cm s-1]. - h1 = 1.e4_r8, & ! Depth of active layer [cm]. - h0 = 2.e4_r8, & ! Depth of water column [cm]. - l0 = 2.e6_r8, & ! Half-width of the jet [cm]. - drho = 0.19e-3_r8, & ! Active layer density difference [g cm-3]. - rho1 = 1.0259_r8, & ! Density at the center of active layer [g cm-3]. - rho0 = 1.0270_r8, & ! Density of water beneath active layer [g cm-3]. - f = 1.e-4_r8, & ! Coriolis parameter [1 s-1]. - lat0 = 45._r8, & ! Center latitude of grid domain [deg]. - lambda = 20.8e5, & ! Channel length [cm]. - mindz = 1.e2_r8, & ! Minimum interior layer thickness [cm]. - saln0 = 35._r8 ! Constant salinity value [g kg-1]. + u0 = .3_r8*L_mks2cgs, & ! Maximum jet velocity [m s-1]. + h1 = 1.e2_r8*L_mks2cgs, & ! Depth of active layer [m]. + h0 = 2.e2_r8*L_mks2cgs, & ! Depth of water column [m]. + l0 = 2.e4_r8*L_mks2cgs, & ! Half-width of the jet [m]. + drho = 0.19_r8*R_mks2cgs, & ! Active layer density difference [kg m-3]. + rhoc = 1025.9_r8*R_mks2cgs, & ! Density at the center of active layer [kg m-3]. + rhob = 1027.0_r8*R_mks2cgs, & ! Density of water beneath active layer [kg m-3]. + f = 1.e-4_r8, & ! Coriolis parameter [1 s-1]. + lat0 = 45._r8, & ! Center latitude of grid domain [deg]. + lambda = 20.8e3*L_mks2cgs, & ! Channel length [m]. + mindz = 1._r8*L_mks2cgs, & ! Minimum interior layer thickness [m]. + saln0 = 35._r8 ! Constant salinity value [g kg-1]. public :: geoenv_fuk95, inifrc_fuk95, ictsz_fuk95 @@ -132,7 +146,7 @@ subroutine geoenv_fuk95 tmpg(1 , j) = 0._r8 tmpg(itdm, j) = 0._r8 do i = 2, itdm - 1 - tmpg(i, j) = h0*1.e-2 + tmpg(i, j) = h0*L_mks2cgs**(-1) enddo enddo !$omp end parallel do @@ -265,78 +279,173 @@ subroutine ictsz_fuk95 real(r8), dimension(1 - nbdy:idm + nbdy, & 1 - nbdy:jdm + nbdy, kdm + 1) :: z real(r8), dimension(kdm) :: sigref - real(r8) :: drhojet, dsig, x, sigm, sigi, zm + real(r8) :: drhojet, dsig, x, sigm, sigi, s0, s1, v0, v1, zu, zl integer :: i, j, k, l - ! Set reference potential density and initial salinity and temperature in - ! the layers. - drhojet = rho1*f*u0*l0/(g*h1) - dsig = (drho + drhojet)/(kk - 4) - sigref(kk) = rho0 - 1._r8 - sigref(kk - 1) = rho1 + .5_r8*(drho + drhojet) - 1._r8 - 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)) - enddo + ! Set reference potential density, interface depths and layer salinity and + ! temperature. + + select case (vcoord_type_tag) + + case (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. + + 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 - enddo - enddo - !$omp end parallel do - ! Set layer interface depths and layer density and temperature. - !$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*1.e2_r8 - z(i, j, 3) = mltmin*1.e2_r8 - z(i, j, kk ) = h1 - z(i, j, kk + 1) = h0 - sigm = rho1*(1._r8 + f*u0*x_psi(x)/(g*h1)) - 1._r8 - 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 - 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 = rho1*(1._r8 + f*u0*x_psi(x)/(g*h1)) - 1._r8 - 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))) + !$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 + !$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 + 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 - enddo - enddo - !$omp end parallel do + !$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) + 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 + 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 + 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 + + case default + + if (mnproc.eq.1) then + write (lp,*) 'ictsz_fuk95: unsupported vertical coordinate!' + endif + call xcstop('(ictsz_fuk95)') + stop '(ictsz_fuk95)' + + end select ! Set layer velocity. call xctilr(z, 1, kk + 1, 1, 1, halo_ps) - !$omp parallel do private(k, l, i, x, zm) + v0 = 0._r8 + !$omp parallel do private(k, l, i, x, zu, zl, v1) do j = 1, jj do k = 1, kk - 1 do l = 1, isv(j) do i = max(1, ifv(j, l)), min(ii, ilv(j, l)) x = x_nudge(real(i, r8), real(j, r8) - .5_r8) - zm = .25*( z(i, j - 1, k + 1) + z(i, j - 1, k) & - + z(i, j , k + 1) + z(i, j , k)) - v(i, j, k) = u0*psi(x)*(h1 - zm)/h1 + zu = .5_r8*(z(i, j - 1, k ) + z(i, j, k )) + zl = .5_r8*(z(i, j - 1, k + 1) + z(i, j, k + 1)) + v1 = u0*psi(x)*(h1 - .5*(zu + zl))/h1 + v1 = 0._r8 + if (abs(zl - zu) < epsilz) then + v(i, j, k) = v1 + else + v(i, j, k) = ( v1*max(0._r8, min(zl, h1) - zu) & + + v0*max(0._r8, zl - max(zu, h1)))/(zl - zu) + endif enddo enddo enddo diff --git a/hamocc/accfields.F90 b/hamocc/accfields.F90 index 75a76b47..f9e21b2d 100644 --- a/hamocc/accfields.F90 +++ b/hamocc/accfields.F90 @@ -46,7 +46,8 @@ SUBROUTINE ACCFIELDS(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask) !********************************************************************** use mod_xc, only: mnproc use mod_dia, only: ddm - use mo_carbch, only: atm,atmflx,co2fxd,co2fxu,co3,hi,kwco2sol,ndepflx,rivinflx,ocetra,omegaa,omegac,pco2d,satoxy,sedfluxo + use mo_carbch, only: atm,atmflx,co2fxd,co2fxu,co3,hi,kwco2sol,ndepflx,rivinflx,ocetra,omegaa,omegac,pco2d,satoxy, & + & sedfluxo,sedfluxb,pco2m,kwco2d,co2sold,co2solm,pn2om use mo_biomod, only: bsiflx_bot,bsiflx0100,bsiflx0500,bsiflx1000,bsiflx2000,bsiflx4000,calflx_bot,calflx0100,calflx0500,& & calflx1000,calflx2000,calflx4000,carflx_bot,carflx0100,carflx0500,carflx1000,carflx2000,carflx4000,& & expoca,expoor,exposi,intdms_bac,intdms_uv,intdmsprod,intdnit,intnfix,intphosy,phosy3d @@ -54,6 +55,7 @@ SUBROUTINE ACCFIELDS(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask) & jbsiflx4000,jbsiflx_bot,jcalc,jcalflx0100,jcalflx0500,jcalflx1000,jcalflx2000,jcalflx4000, & & jcalflx_bot,jcarflx0100,jcarflx0500,jcarflx1000,jcarflx2000,jcarflx4000,jcarflx_bot, & & jsediffic,jsediffal,jsediffph,jsediffox,jsediffn2,jsediffno3,jsediffsi,jco2flux, & + & jburflxsso12,jburflxsssc12,jburflxssssil,jburflxssster, & & jco2fxd,jco2fxu,jco3,jdic,jdicsat,jdms,jdms_bac,jdms_uv,jdmsflux,jdmsprod,jdoc,jdp,jeps,jexpoca, & & jexport,jexposi,jgrazer,jintdnit,jintnfix,jintphosy,jiralk,jirdet,jirdin,jirdip,jirdoc,jiriron, & & jiron,jirsi,jkwco2,jlvlalkali,jlvlano3,jlvlasize,jlvlbigd14c,jlvlbromo,jlvlcalc,jlvlcalc13, & @@ -63,15 +65,23 @@ SUBROUTINE ACCFIELDS(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask) & jlvlph,jlvlphosph,jlvlphosy,jlvlphyto,jlvlphyto13,jlvlpoc,jlvlpoc13,jlvlprefalk,jlvlprefdic, & & jlvlprefo2,jlvlprefpo4,jlvlsf6,jlvlsilica,jlvlwnos,jlvlwphy,jn2flux,jn2o,jn2oflux,jn2ofx, & & jprorca,jprcaca,jsilpro,jpodiic,jpodial,jpodiph,jpodiox,jpodin2,jpodino3,jpodisi,jndep, & - & jniflux,jnos,jo2flux,jo2sat,jomegaa,jomegac,jopal,joxflux,joxygen,jpco2,jph,jphosph,jphosy,jphyto, & - & jpoc,jprefalk,jprefdic,jprefo2,jprefpo4,jsilica,jsrfalkali,jsrfano3,jsrfdic,jsrfiron,jsrfoxygen, & - & jsrfphosph,jsrfphyto,jsrfsilica,jwnos,jwphy,nbgc,nacc_bgc,bgcwrt,glb_inventory,bgct2d,acclvl, & - & acclyr,accsrf,bgczlv,jlvlanh4,jlvlano2 + & jniflux,jnos,jo2flux,jo2sat,jomegaa,jomegac,jopal,joxflux,joxygen,jpco2,jpco2m,jkwco2khm,jco2khm, & + & jco2kh,jph,jphosph,jphosy,jphyto,jpoc,jprefalk,jprefdic,jprefo2,jprefpo4,jsilica,jsrfalkali, & + & jsrfano3,jsrfdic,jsrfiron,jsrfoxygen,jsrfphosph,jsrfphyto,jsrfsilica,jsrfph,jwnos,jwphy, & + & nbgc,nacc_bgc,bgcwrt,glb_inventory,bgct2d,acclvl,acclyr,accsrf,bgczlv,jlvlanh4,jlvlano2, & + & jlvl_nitr_NH4, jsrfpn2om, & + & jlvl_nitr_NO2,jlvl_nitr_N2O_prod,jlvl_nitr_NH4_OM,jlvl_nitr_NO2_OM,jlvl_denit_NO3,jlvl_denit_NO2, & + & jlvl_denit_N2O,jlvl_DNRA_NO2,jlvl_anmx_N2_prod,jlvl_anmx_OM_prod,jlvl_phosy_NH4,jlvl_phosy_NO3, & + & jlvl_remin_aerob,jlvl_remin_sulf, & + & jagg_ws,jdynvis,jagg_stick,jagg_stickf,jagg_dmax,jagg_avdp,jagg_avrhop,jagg_avdC,jagg_df,jagg_b, & + & jagg_Vrhof,jagg_Vpor,jlvl_agg_ws,jlvl_dynvis,jlvl_agg_stick,jlvl_agg_stickf,jlvl_agg_dmax, & + & jlvl_agg_avdp,jlvl_agg_avrhop,jlvl_agg_avdC,jlvl_agg_df,jlvl_agg_b,jlvl_agg_Vrhof,jlvl_agg_Vpor use mo_control_bgc, only: io_stdo_bgc use mo_param1_bgc, only: ialkali,ian2o,iano3,iatmco2,iatmdms,iatmn2,iatmn2o,iatmo2,icalc,idet,idms,idicsat,idoc,iiron,iopal,& & ioxygen,iphosph,iphy,iprefalk,iprefdic,iprefpo4,iprefo2,isco212,isilica,izoo, & - & irdin,irdip,irsi,iralk,iriron,irdoc,irdet - + & irdin,irdip,irsi,iralk,iriron,irdoc,irdet,issso12,isssc12,issssil,issster + use mo_m4ago, only: aggregate_diagnostics,kav_dp,kav_rho_p,kav_d_C,kws_agg,kdf_agg,kstickiness_agg,kb_agg, & + & kstickiness_frustule,kLmax_agg,kdynvis,kav_rhof_V,kav_por_V #ifdef AGG use mo_biomod, only: asize3d,eps3d,wnumb,wmass use mo_param1_bgc, only: inos @@ -98,7 +108,7 @@ SUBROUTINE ACCFIELDS(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask) use mo_param1_bgc, only: iatmnco2,inatalkali,inatcalc,inatsco212 use mo_carbch, only: natco3,nathi,natomegaa,natomegac,natpco2d use mo_bgcmean, only: jlvlnatph,jnatalkali,jnatcalc,jnatco2fx,jnatco3,jnatdic,jnatomegaa,jnatomegac,jnatpco2,jnatph, & - & jsrfnatalk,jsrfnatdic + & jsrfnatalk,jsrfnatdic,jsrfnatph #endif #ifndef sedbypass use mo_param1_bgc, only: ipowaal,ipowaic,ipowaox,ipowaph,ipowasi,ipown2,ipowno3,isssc12,issso12,issssil,issster @@ -107,15 +117,19 @@ SUBROUTINE ACCFIELDS(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask) & jpowno3,jsssc12,jssso12,jssssil,jssster,accbur,accsdm #endif #ifdef extNcycle - use mo_param1_bgc, only: iatmnh3,ianh4,iano2 - use mo_bgcmean, only: jnh3flux,janh3fx,janh4,jano2,jsrfanh4,jsrfano2, & + use mo_carbch, only: pnh3 + use mo_param1_bgc, only: iatmnh3,ianh4,iano2,ipownh4,ipown2o,ipowno2 + use mo_bgcmean, only: jnh3flux,janh3fx,janh4,jano2,jsrfanh4,jsrfano2,jsrfpnh3, & & jnitr_NH4,jnitr_NO2,jnitr_N2O_prod,jnitr_NH4_OM,jnitr_NO2_OM,jdenit_NO3,jdenit_NO2,jdenit_N2O, & - & jDNRA_NO2,janmx_N2_prod,janmx_OM_prod,jphosy_NH4,jphosy_NO3,jremin_aerob,jremin_sulf,jlvl_nitr_NH4, & - & jlvl_nitr_NO2,jlvl_nitr_N2O_prod,jlvl_nitr_NH4_OM,jlvl_nitr_NO2_OM,jlvl_denit_NO3,jlvl_denit_NO2, & - & jlvl_denit_N2O,jlvl_DNRA_NO2,jlvl_anmx_N2_prod,jlvl_anmx_OM_prod,jlvl_phosy_NH4,jlvl_phosy_NO3, & - & jlvl_remin_aerob,jlvl_remin_sulf + & jDNRA_NO2,janmx_N2_prod,janmx_OM_prod,jphosy_NH4,jphosy_NO3,jremin_aerob,jremin_sulf, & + & jpownh4,jpown2o,jpowno2,jsdm_nitr_NH4,jsdm_nitr_NO2,jsdm_nitr_N2O_prod,jsdm_nitr_NH4_OM, & + & jsdm_nitr_NO2_OM,jsdm_denit_NO3,jsdm_denit_NO2,jsdm_denit_N2O,jsdm_DNRA_NO2,jsdm_anmx_N2_prod, & + & jsdm_anmx_OM_prod,jsdm_remin_aerob,jsdm_remin_sulf,jsediffnh4,jsediffn2o,jsediffno2 use mo_biomod, only: nitr_NH4,nitr_NO2,nitr_N2O_prod,nitr_NH4_OM,nitr_NO2_OM,denit_NO3,denit_NO2,denit_N2O,DNRA_NO2, & & anmx_N2_prod,anmx_OM_prod,phosy_NH4,phosy_NO3,remin_aerob,remin_sulf + use mo_extNsediment,only: extNsed_diagnostics,ised_nitr_NH4,ised_nitr_NO2,ised_nitr_N2O_prod,ised_nitr_NH4_OM, & + & ised_nitr_NO2_OM,ised_denit_NO3,ised_denit_NO2,ised_denit_N2O,ised_DNRA_NO2,ised_anmx_N2_prod, & + & ised_anmx_OM_prod,ised_remin_aerob,ised_remin_sulf #endif implicit none @@ -243,7 +257,11 @@ SUBROUTINE ACCFIELDS(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask) ! Accumulate 2d diagnostics call accsrf(jpco2,pco2d,omask,0) - call accsrf(jkwco2,kwco2sol,omask,0) + call accsrf(jpco2m,pco2m,omask,0) + call accsrf(jkwco2khm,kwco2sol,omask,0) + call accsrf(jkwco2,kwco2d,omask,0) + call accsrf(jco2kh,co2sold,omask,0) + call accsrf(jco2khm,co2solm,omask,0) call accsrf(jsrfphosph,ocetra(1,1,1,iphosph),omask,0) call accsrf(jsrfoxygen,ocetra(1,1,1,ioxygen),omask,0) call accsrf(jsrfiron,ocetra(1,1,1,iiron),omask,0) @@ -252,7 +270,9 @@ SUBROUTINE ACCFIELDS(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask) call accsrf(jsrfsilica,ocetra(1,1,1,isilica),omask,0) call accsrf(jsrfdic,ocetra(1,1,1,isco212),omask,0) call accsrf(jsrfphyto,ocetra(1,1,1,iphy),omask,0) + call accsrf(jsrfph,hi(1,1,1),omask,0) call accsrf(jdms,ocetra(1,1,1,idms),omask,0) + call accsrf(jsrfpn2om,pn2om,omask,0) call accsrf(jexport,expoor,omask,0) call accsrf(jexpoca,expoca,omask,0) call accsrf(jexposi,exposi,omask,0) @@ -266,6 +286,7 @@ SUBROUTINE ACCFIELDS(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask) call accsrf(jsrfnatdic,ocetra(1,1,1,inatsco212),omask,0) call accsrf(jsrfnatalk,ocetra(1,1,1,inatalkali),omask,0) call accsrf(jnatpco2,natpco2d,omask,0) + call accsrf(jsrfnatph,nathi(1,1,1),omask,0) #endif #ifdef BROMO call accsrf(jsrfbromo,ocetra(1,1,1,ibromo),omask,0) @@ -274,6 +295,7 @@ SUBROUTINE ACCFIELDS(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask) #endif #ifdef extNcycle call accsrf(jsrfanh4,ocetra(1,1,1,ianh4),omask,0) + call accsrf(jsrfpnh3,pnh3,omask,0) call accsrf(jsrfano2,ocetra(1,1,1,iano2),omask,0) #endif @@ -307,7 +329,16 @@ SUBROUTINE ACCFIELDS(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask) call accsrf(jsediffox,sedfluxo(1,1,ipowaox),omask,0) call accsrf(jsediffn2,sedfluxo(1,1,ipown2),omask,0) call accsrf(jsediffno3,sedfluxo(1,1,ipowno3),omask,0) - call accsrf(jsediffsi,sedfluxo(1,1,ipowasi),omask,0) + call accsrf(jsediffsi,sedfluxo(1,1,ipowasi),omask,0) + call accsrf(jburflxsso12,sedfluxb(1,1,issso12),omask,0) + call accsrf(jburflxsssc12,sedfluxb(1,1,isssc12),omask,0) + call accsrf(jburflxssssil,sedfluxb(1,1,issssil),omask,0) + call accsrf(jburflxssster,sedfluxb(1,1,issster),omask,0) +#endif +#if defined(extNcycle) && ! defined(sedbypass) + call accsrf(jsediffnh4,sedfluxo(1,1,ipownh4),omask,0) + call accsrf(jsediffn2o,sedfluxo(1,1,ipown2o),omask,0) + call accsrf(jsediffno2,sedfluxo(1,1,ipowno2),omask,0) #endif ! Accumulate layer diagnostics @@ -392,6 +423,19 @@ SUBROUTINE ACCFIELDS(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask) call acclyr(jremin_aerob,remin_aerob,pddpo,1) call acclyr(jremin_sulf,remin_sulf,pddpo,1) #endif + ! M4AGO + call acclyr(jagg_ws,aggregate_diagnostics(1,1,1,kws_agg),pddpo,1) + call acclyr(jdynvis,aggregate_diagnostics(1,1,1,kdynvis),pddpo,1) + call acclyr(jagg_stick,aggregate_diagnostics(1,1,1,kstickiness_agg),pddpo,1) + call acclyr(jagg_stickf,aggregate_diagnostics(1,1,1,kstickiness_frustule),pddpo,1) + call acclyr(jagg_dmax,aggregate_diagnostics(1,1,1,kLmax_agg),pddpo,1) + call acclyr(jagg_avdp,aggregate_diagnostics(1,1,1,kav_dp),pddpo,1) + call acclyr(jagg_avrhop,aggregate_diagnostics(1,1,1,kav_rho_p),pddpo,1) + call acclyr(jagg_avdC,aggregate_diagnostics(1,1,1,kav_d_C),pddpo,1) + call acclyr(jagg_df,aggregate_diagnostics(1,1,1,kdf_agg),pddpo,1) + call acclyr(jagg_b,aggregate_diagnostics(1,1,1,kb_agg),pddpo,1) + call acclyr(jagg_Vrhof,aggregate_diagnostics(1,1,1,kav_rhof_V),pddpo,1) + call acclyr(jagg_Vpor,aggregate_diagnostics(1,1,1,kav_por_V),pddpo,1) ! Accumulate level diagnostics IF (SUM(jlvlphyto+jlvlgrazer+jlvlphosph+jlvloxygen+jlvliron+ & @@ -406,7 +450,10 @@ SUBROUTINE ACCFIELDS(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask) & jlvl_nitr_NH4+jlvl_nitr_NO2+jlvl_nitr_N2O_prod+jlvl_nitr_NH4_OM+& & jlvl_nitr_NO2_OM+jlvl_denit_NO3+jlvl_denit_NO2+jlvl_denit_N2O+ & & jlvl_DNRA_NO2+jlvl_anmx_N2_prod+jlvl_anmx_OM_prod+ & - & jlvl_phosy_NH4+jlvl_phosy_NO3+jlvl_remin_aerob+jlvl_remin_sulf & + & jlvl_phosy_NH4+jlvl_phosy_NO3+jlvl_remin_aerob+jlvl_remin_sulf+ & + & jlvl_agg_ws+jlvl_dynvis+jlvl_agg_stick+jlvl_agg_stickf+ & + & jlvl_agg_dmax+jlvl_agg_avdp+jlvl_agg_avrhop+jlvl_agg_avdC+ & + & jlvl_agg_df+jlvl_agg_b+jlvl_agg_Vrhof+jlvl_agg_Vpor & & ).NE.0) THEN DO k=1,kpke call bgczlv(pddpo,k,ind1,ind2,wghts) @@ -491,6 +538,19 @@ SUBROUTINE ACCFIELDS(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask) call acclvl(jlvl_remin_aerob,remin_aerob,k,ind1,ind2,wghts) call acclvl(jlvl_remin_sulf,remin_sulf,k,ind1,ind2,wghts) #endif + !M4AGO + call acclvl(jlvl_agg_ws,aggregate_diagnostics(1,1,1,kws_agg),k,ind1,ind2,wghts) + call acclvl(jlvl_dynvis,aggregate_diagnostics(1,1,1,kdynvis),k,ind1,ind2,wghts) + call acclvl(jlvl_agg_stick,aggregate_diagnostics(1,1,1,kstickiness_agg),k,ind1,ind2,wghts) + call acclvl(jlvl_agg_stickf,aggregate_diagnostics(1,1,1,kstickiness_frustule),k,ind1,ind2,wghts) + call acclvl(jlvl_agg_dmax,aggregate_diagnostics(1,1,1,kLmax_agg),k,ind1,ind2,wghts) + call acclvl(jlvl_agg_avdp,aggregate_diagnostics(1,1,1,kav_dp),k,ind1,ind2,wghts) + call acclvl(jlvl_agg_avrhop,aggregate_diagnostics(1,1,1,kav_rho_p),k,ind1,ind2,wghts) + call acclvl(jlvl_agg_avdC,aggregate_diagnostics(1,1,1,kav_d_C),k,ind1,ind2,wghts) + call acclvl(jlvl_agg_df,aggregate_diagnostics(1,1,1,kdf_agg),k,ind1,ind2,wghts) + call acclvl(jlvl_agg_b,aggregate_diagnostics(1,1,1,kb_agg),k,ind1,ind2,wghts) + call acclvl(jlvl_agg_Vrhof,aggregate_diagnostics(1,1,1,kav_rhof_V),k,ind1,ind2,wghts) + call acclvl(jlvl_agg_Vpor,aggregate_diagnostics(1,1,1,kav_por_V),k,ind1,ind2,wghts) ENDDO ENDIF @@ -515,6 +575,26 @@ SUBROUTINE ACCFIELDS(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask) call accbur(jbursssc12,burial(1,1,isssc12)) call accbur(jburssster,burial(1,1,issster)) #endif +#if defined(extNcycle) && ! defined(sedbypass) + call accsdm(jpownh4,powtra(1,1,1,ipownh4)) + call accsdm(jpown2o,powtra(1,1,1,ipown2o)) + call accsdm(jpowno2,powtra(1,1,1,ipowno2)) + + call accsdm(jsdm_nitr_NH4 ,extNsed_diagnostics(1,1,1,ised_nitr_NH4)) + call accsdm(jsdm_nitr_NO2 ,extNsed_diagnostics(1,1,1,ised_nitr_NO2)) + call accsdm(jsdm_nitr_N2O_prod ,extNsed_diagnostics(1,1,1,ised_nitr_N2O_prod)) + call accsdm(jsdm_nitr_NH4_OM ,extNsed_diagnostics(1,1,1,ised_nitr_NH4_OM)) + call accsdm(jsdm_nitr_NO2_OM ,extNsed_diagnostics(1,1,1,ised_nitr_NO2_OM)) + call accsdm(jsdm_denit_NO3 ,extNsed_diagnostics(1,1,1,ised_denit_NO3)) + call accsdm(jsdm_denit_NO2 ,extNsed_diagnostics(1,1,1,ised_denit_NO2)) + call accsdm(jsdm_denit_N2O ,extNsed_diagnostics(1,1,1,ised_denit_N2O)) + call accsdm(jsdm_DNRA_NO2 ,extNsed_diagnostics(1,1,1,ised_DNRA_NO2)) + call accsdm(jsdm_anmx_N2_prod ,extNsed_diagnostics(1,1,1,ised_anmx_N2_prod)) + call accsdm(jsdm_anmx_OM_prod ,extNsed_diagnostics(1,1,1,ised_anmx_OM_prod)) + call accsdm(jsdm_remin_aerob ,extNsed_diagnostics(1,1,1,ised_remin_aerob)) + call accsdm(jsdm_remin_sulf ,extNsed_diagnostics(1,1,1,ised_remin_sulf)) + +#endif ! Write output if requested diff --git a/hamocc/aufr_bgc.F90 b/hamocc/aufr_bgc.F90 index 6a342c01..b9e5f410 100644 --- a/hamocc/aufr_bgc.F90 +++ b/hamocc/aufr_bgc.F90 @@ -138,7 +138,7 @@ SUBROUTINE AUFR_BGC(kpie,kpje,kpke,ntr,ntrbgc,itrbgc,trc, & use mo_param1_bgc, only: ipowaal,ipowaic,ipowaox,ipowaph,ipowasi,ipown2,ipowno3,isssc12,issso12,issssil,issster,ks #endif #ifdef extNcycle - use mo_param1_bgc, only: ianh4,iano2 + use mo_param1_bgc, only: ianh4,iano2,ipownh4,ipown2o,ipowno2 #endif @@ -520,6 +520,11 @@ SUBROUTINE AUFR_BGC(kpie,kpje,kpke,ntr,ntrbgc,itrbgc,trc, & CALL read_netcdf_var(ncid,'powc14',powtra2(1,1,1,ipowc14),2*ks,0,iotype) ENDIF #endif +#ifdef extNcycle + CALL read_netcdf_var(ncid,'pownh4',powtra2(1,1,1,ipownh4),2*ks,0,iotype) + CALL read_netcdf_var(ncid,'pown2o',powtra2(1,1,1,ipown2o),2*ks,0,iotype) + CALL read_netcdf_var(ncid,'powno2',powtra2(1,1,1,ipowno2),2*ks,0,iotype) +#endif #endif ! diff --git a/hamocc/aufw_bgc.F90 b/hamocc/aufw_bgc.F90 index f04b7bf0..57741fd6 100644 --- a/hamocc/aufw_bgc.F90 +++ b/hamocc/aufw_bgc.F90 @@ -129,7 +129,7 @@ SUBROUTINE AUFW_BGC(kpie,kpje,kpke,ntr,ntrbgc,itrbgc,trc, & use mo_param1_bgc, only: ipowaal,ipowaic,ipowaox,ipowaph,ipowasi,ipown2,ipowno3,isssc12,issso12,issssil,issster #endif #ifdef extNcycle - use mo_param1_bgc, only: ianh4,iano2 + use mo_param1_bgc, only: ianh4,iano2,ipownh4,ipown2o,ipowno2 #endif @@ -705,6 +705,17 @@ SUBROUTINE AUFW_BGC(kpie,kpje,kpke,ntr,ntrbgc,itrbgc,trc, & & 9,'kmol/m**3',25,'Sediment pore water DIC14', & & rmasks,86,io_stdo_bgc) #endif +#ifdef extNcycle + CALL NETCDF_DEF_VARDB(ncid,6,'pownh4',3,ncdimst,ncvarid, & + & 9,'kmol/m**3',34,'Sediment pore water ammonium (NH4)', & + & rmissing,79,io_stdo_bgc) + CALL NETCDF_DEF_VARDB(ncid,6,'pown2o',3,ncdimst,ncvarid, & + & 9,'kmol/m**3',39,'Sediment pore water nitrous oxide (N2O)', & + & rmissing,79,io_stdo_bgc) + CALL NETCDF_DEF_VARDB(ncid,6,'powno2',3,ncdimst,ncvarid, & + & 9,'kmol/m**3',33,'Sediment pore water nitrite (NO2)', & + & rmissing,79,io_stdo_bgc) +#endif IF((mnproc==1 .AND. IOTYPE==0) .OR. IOTYPE==1) THEN ncdimst(1) = nclonid @@ -915,6 +926,11 @@ SUBROUTINE AUFW_BGC(kpie,kpje,kpke,ntr,ntrbgc,itrbgc,trc, & CALL write_netcdf_var(ncid,'powc13',powtra2(1,1,1,ipowc13),2*ks,0) CALL write_netcdf_var(ncid,'powc14',powtra2(1,1,1,ipowc14),2*ks,0) #endif +#ifdef extNcycle + CALL write_netcdf_var(ncid,'pownh4',powtra2(1,1,1,ipownh4),2*ks,0) + CALL write_netcdf_var(ncid,'pown2o',powtra2(1,1,1,ipown2o),2*ks,0) + CALL write_netcdf_var(ncid,'powno2',powtra2(1,1,1,ipowno2),2*ks,0) +#endif #endif ! ! Write restart data: atmosphere. diff --git a/hamocc/beleg_parm.F90 b/hamocc/beleg_parm.F90 index a9d07bd5..224d55ee 100644 --- a/hamocc/beleg_parm.F90 +++ b/hamocc/beleg_parm.F90 @@ -45,12 +45,12 @@ SUBROUTINE BELEG_PARM(kpie,kpje) use mo_biomod, only: atten_c,atten_f,atten_uv,atten_w,bkopal,bkphy,bkopal,bkzoo,bluefix,ctochl,dremn2o,dremopal, & & drempoc,dremsul,dyphy,ecan,epsher,fesoly,fetune,gammap,gammaz,grami,grazra,perc_diron,phytomi, & & pi_alpha,rcalc,rcar, rdn2o1,rdn2o2,rdnit0,rdnit1,rdnit2,relaxfe,remido,riron,rnit,rnoi,ro2ut, & - & ropal,spemor,tf0,tf1,tf2,tff,wcal,wdust,wopal,wpoc,zinges + & ropal,spemor,tf0,tf1,tf2,tff,wcal,wdust,wopal,wpoc,zinges,drempoc_anaerob,bkox_drempoc use mo_sedmnt, only: claydens,o2ut,rno3 - use mo_control_bgc, only: dtb,io_stdo_bgc + use mo_control_bgc, only: dtb,io_stdo_bgc,lm4ago use mo_param1_bgc, only: iatmco2,iatmnco2,iatmo2,iatmn2,iatmc13,iatmc14,iatmbromo use mod_xc, only: mnproc - + use mo_m4ago, only: init_m4ago_nml_params, init_m4ago_params #ifdef AGG use mo_biomod, only: alar1,alar2,alar3,alow1,alow2,alow3,calmax,cellmass,cellsink,dustd1,dustd2,dustd3,dustsink, & & fractdim,fse,fsh,nmldmin,plower,pupper,safe,sinkexp,stick,tmfac,tsfac,vsmall,zdis @@ -73,6 +73,7 @@ SUBROUTINE BELEG_PARM(kpie,kpje) use mo_carbch, only: atm_nh3,atm_n2o use mo_chemcon, only: atn2o !fixed mixing ratio of N2O at 1980, 300ppb = 3e-7 use mo_extNbioproc, only: extNbioparam_init + use mo_extNsediment,only: extNsediment_param_init #endif implicit none @@ -216,7 +217,8 @@ SUBROUTINE BELEG_PARM(kpie,kpje) dremopal = 0.003*dtb !1/d dremn2o = 0.01*dtb !1/d dremsul = 0.005*dtb ! remineralization rate for sulphate reduction - + drempoc_anaerob = 0.05*drempoc ! remin in sub-/anoxic environm. - not be overwritten by lm4ago + bkox_drempoc = 1e-7 ! half-saturation constant for oxygen for ammonification (aerobic remin via drempoc) ! nirogen fixation by blue green algae bluefix=0.005*dtb !1/d @@ -253,10 +255,6 @@ SUBROUTINE BELEG_PARM(kpie,kpje) rdn2o1=2*ro2ut-2.5*rnit ! moles N2O used for remineralisation of 1 mole P rdn2o2=2*ro2ut-2*rnit ! moles N2 released for remineralisation of 1 mole P -#ifdef extNcycle - ! initialize the extended nitrogen cycle parameters - call extNbioparam_init() -#endif #ifdef BROMO !Bromoform to phosphate ratio (Hense and Quack, 2009) @@ -280,6 +278,23 @@ SUBROUTINE BELEG_PARM(kpie,kpje) ropal = 30. ! iris 25 !opal to organic phosphorous production ratio #endif + ! M4AGO parameters - requires ropal, opalwei, claydens and calcdens to be set + call init_m4ago_nml_params + call init_m4ago_params + if(lm4ago)then + ! reset drempoc and dremopal for T-dep remin/dissolution + drempoc = 0.12*dtb + dremopal = 0.023*dtb + endif + +#ifdef extNcycle + ! initialize the extended nitrogen cycle parameters - first water column, then sediment, + ! since sediment relies on water column parameters for the extended nitrogen cycle + ! Sediment also relies on M4AGO being initialized (POM_remin_q10 and POM_remin_Tref) + call extNbioparam_init() + call extNsediment_param_init() +#endif + ! parameters for sw-radiation attenuation ! Analog to Moore et al., Deep-Sea Research II 49 (2002), 403-462 ! 1 kmolP = (122*12/60)*10^6 mg[Chlorophyl] diff --git a/hamocc/beleg_vars.F90 b/hamocc/beleg_vars.F90 index 56fa34d7..07558548 100644 --- a/hamocc/beleg_vars.F90 +++ b/hamocc/beleg_vars.F90 @@ -218,7 +218,7 @@ SUBROUTINE BELEG_VARS(kpaufr,kpie,kpje,kpke,kbnd,pddpo,prho,omask, & #ifdef extNcycle ocetra(i,j,k,iano2) =1.e-9 ! expecting fast cycling ocetra(i,j,k,ianh4) =0.5e-9 ! expecting fast cycling - ocetra(i,j,k,ian2o) =20.e-9 ! 20nmol/kg = ca. value deep ocean Toyoda et al. 2019 + ocetra(i,j,k,ian2o) =6.e-9 ! 6 to 8 nmol/kg = ca. value in near surface regions Toyoda et al. 2019, prevent from too long outgassing #endif ENDIF ! omask > 0.5 @@ -228,18 +228,16 @@ SUBROUTINE BELEG_VARS(kpaufr,kpie,kpje,kpke,kbnd,pddpo,prho,omask, & ! Initialise preformed tracers in the mixed layer; note that the ! whole field has been initialised to zero above - DO k=1,kmle DO j=1,kpje DO i=1,kpie IF(omask(i,j) .GT. 0.5) THEN - ocetra(i,j,k,iprefo2) =ocetra(i,j,k,ioxygen) - ocetra(i,j,k,iprefpo4)=ocetra(i,j,k,iphosph) - ocetra(i,j,k,iprefalk)=ocetra(i,j,k,ialkali) - ocetra(i,j,k,iprefdic)=ocetra(i,j,k,isco212) + ocetra(i,j,1:kmle(i,j),iprefo2) = ocetra(i,j,1:kmle(i,j),ioxygen) + ocetra(i,j,1:kmle(i,j),iprefpo4) = ocetra(i,j,1:kmle(i,j),iphosph) + ocetra(i,j,1:kmle(i,j),iprefalk) = ocetra(i,j,1:kmle(i,j),ialkali) + ocetra(i,j,1:kmle(i,j),iprefdic) = ocetra(i,j,1:kmle(i,j),isco212) ENDIF ENDDO ENDDO - ENDDO ! Initial values for sediment diff --git a/hamocc/bodensed.F90 b/hamocc/bodensed.F90 deleted file mode 100644 index 99bc782a..00000000 --- a/hamocc/bodensed.F90 +++ /dev/null @@ -1,139 +0,0 @@ -! Copyright (C) 2001 Ernst Maier-Reimer, S. Legutke -! Copyright (C) 2020 J. Schwinger -! -! This file is part of BLOM/iHAMOCC. -! -! 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 https://www.gnu.org/licenses/. - - -subroutine bodensed(kpie,kpje,kpke,pddpo) -!********************************************************************** -! -!**** *BODENSED* - . -! -! Ernst Maier-Reimer, *MPI-Met, HH* 10.04.01 -! -! Modified -! -------- -! S.Legutke, *MPI-MaD, HH* 10.04.01 -! -! Purpose -! ------- -! set up of sediment layer. -! -! -!** Interface to ocean model (parameter list): -! ----------------------------------------- -! -! *INTEGER* *kpie* - 1st dimension of model grid. -! *INTEGER* *kpje* - 2nd dimension of model grid. -! *INTEGER* *kpke* - 3rd (vertical) dimension of model grid. -! *REAL* *pddpo* - size of scalar grid cell (3rd dimension) [m]. -! -!********************************************************************** - - use mo_sedmnt, only: calcwei,calfa,clafa,claydens,calcdens,opaldens,opalwei,oplfa,orgdens,orgfa,seddzi,porwat,porwah, & - & porsol,dzs,seddw,sedict,solfu,orgwei - use mo_control_bgc, only: dtbgc,io_stdo_bgc - use mo_param1_bgc, only: ks - use mod_xc, only: mnproc - - implicit none - - integer, intent(in) :: kpie,kpje,kpke - real, intent(in) :: pddpo(kpie,kpje,kpke) - - ! Local variables - integer :: i,j,k - real :: sumsed - - dzs(1) = 0.001 - dzs(2) = 0.003 - dzs(3) = 0.005 - dzs(4) = 0.007 - dzs(5) = 0.009 - dzs(6) = 0.011 - dzs(7) = 0.013 - dzs(8) = 0.015 - dzs(9) = 0.017 - dzs(10) = 0.019 - dzs(11) = 0.021 - dzs(12) = 0.023 - dzs(13) = 0.025 - - if (mnproc == 1) then - write(io_stdo_bgc,*) ' ' - write(io_stdo_bgc,*) 'Sediment layer thickness [m] : ' - write(io_stdo_bgc,'(5F9.3)') dzs - write(io_stdo_bgc,*) ' ' - endif - - porwat(1) = 0.85 - porwat(2) = 0.83 - porwat(3) = 0.8 - porwat(4) = 0.79 - porwat(5) = 0.77 - porwat(6) = 0.75 - porwat(7) = 0.73 - porwat(8) = 0.7 - porwat(9) = 0.68 - porwat(10) = 0.66 - porwat(11) = 0.64 - porwat(12) = 0.62 - - if (mnproc == 1) then - write(io_stdo_bgc,*) 'Pore water in sediment: ',porwat - endif - - seddzi(1) = 500. - do k = 1, ks - porsol(k) = 1. - porwat(k) - if(k >= 2) porwah(k) = 0.5 * (porwat(k) + porwat(k-1)) - if(k == 1) porwah(k) = 0.5 * (1. + porwat(1)) - seddzi(k+1) = 1. / dzs(k+1) - seddw(k) = 0.5 * (dzs(k) + dzs(k+1)) - enddo - - sedict = 1.e-9 * dtbgc - -! ****************************************************************** -! densities etc. for SEDIMENT SHIFTING - -! define weight of calcium carbonate, opal, and poc [kg/kmol] - calcwei = 100. ! 40+12+3*16 kg/kmol C - opalwei = 60. ! 28 + 2*16 kg/kmol Si - orgwei = 30. ! from 12 kg/kmol * 2.5 POC[kg]/DW[kg] - ! after Alldredge, 1998: - ! POC(g)/DW(g) = 0.4 of diatom marine snow, size 1mm3 - -! define densities of opal, caco3, poc [kg/m3] - calcdens = 2600. - opaldens = 2200. - orgdens = 1000. - claydens = 2600. !quartz - -! define volumes occupied by solid constituents [m3/kmol] - calfa = calcwei / calcdens - oplfa = opalwei / opaldens - orgfa = orgwei / orgdens - clafa = 1. / claydens !clay is calculated in kg/m3 - -! determine total solid sediment volume - solfu = 0. - do k = 1, ks - solfu = solfu + seddw(k) * porsol(k) - enddo - - -end subroutine bodensed diff --git a/hamocc/carchm.F90 b/hamocc/carchm.F90 index 38338c88..cc3f7cf1 100644 --- a/hamocc/carchm.F90 +++ b/hamocc/carchm.F90 @@ -94,13 +94,14 @@ SUBROUTINE CARCHM(kpie,kpje,kpke,kbnd, & ! none. ! !********************************************************************** - use mo_carbch, only: atm,atmflx,co2fxd,co2fxu,co2star,co3,hi,keqb,kwco2sol,ocetra,omegaa,omegac,pco2d,satn2o,satoxy + use mo_carbch, only: atm,atmflx,co2fxd,co2fxu,co2star,co3,hi,keqb,kwco2sol,ocetra,omegaa,omegac,pco2d,satn2o,satoxy, & + pco2m,kwco2d,co2sold,co2solm,pn2om use mo_chemcon, only: al1,al2,al3,al4,an0,an1,an2,an3,an4,an5,an6,atn2o,bl1,bl2,bl3,calcon,ox0,ox1,ox2,ox3,ox4,ox5,ox6, & - & oxyco,tzero - use mo_control_bgc, only: dtbgc + & oxyco,tzero + use mo_control_bgc, only: dtbgc use mo_param1_bgc, only: ialkali,iatmo2,iatmco2,iatmdms,iatmn2,iatmn2o,ian2o,icalc,idicsat,idms,igasnit,ioxygen,iphosph, & - & isco212,isilica - use mo_vgrid, only: dp_min,kbo,ptiestu + & isco212,isilica + use mo_vgrid, only: dp_min,kmle,kbo,ptiestu #ifdef BROMO use mo_param1_bgc, only: iatmbromo,ibromo @@ -118,6 +119,7 @@ SUBROUTINE CARCHM(kpie,kpje,kpke,kbnd, & use mo_param1_bgc, only: iatmnco2,inatalkali,inatcalc,inatsco212 #endif #ifdef extNcycle + use mo_carbch, only: pnh3 use mo_param1_bgc, only: iatmnh3,ianh4 use mo_chemcon, only: SV0_air,SV1_air,SV2_air,SV3_air,SV4_air,SD0_air,SD1_air,SD2_air,SD3_air,Vb_nh3,M_nh3,kappa #endif @@ -189,19 +191,27 @@ SUBROUTINE CARCHM(kpie,kpje,kpke,kbnd, & co214fxd (:,:)=0. co214fxu (:,:)=0. #endif - pco2d (:,:)=0. + pco2d (:,:)=0. + pco2m (:,:)=0. + kwco2d (:,:)=0. + co2sold (:,:)=0. + co2solm (:,:)=0. kwco2sol (:,:)=0. co2star(:,:,:)=0. co3 (:,:,:)=0. satoxy (:,:,:)=0. omegaA (:,:,:)=0. omegaC (:,:,:)=0. + pn2om (:,:)=0. #ifdef natDIC natpco2d (:,:)=0. natco3 (:,:,:)=0. natomegaA(:,:,:)=0. natomegaC(:,:,:)=0. #endif +#ifdef extNcycle + pnh3 (:,:)=0. +#endif !$OMP PARALLEL DO PRIVATE(t,t2,t3,t4,tk,tk100,s,rs,prb,Kh,Khd,K1,K2 & !$OMP ,Kb,K1p,K2p,K3p,Ksi,Kw,Ks1,Kf,Kspc,Kspa,tc,ta,sit,pt,ah1,ac & @@ -463,8 +473,7 @@ SUBROUTINE CARCHM(kpie,kpje,kpke,kbnd, & ta = ocetra(i,j,k,ialkali) / rrho CALL carchm_solve_DICsat(s,atco2*rpp0,ta,sit,pt,Kh,K1,K2,Kb,Kw,Ks1,Kf, & Ksi,K1p,K2p,K3p,tc_sat,niter) - ocetra(i,j,k, idicsat)=tc_sat * rrho ! convert mol/kg to kmol/m^3 - ocetra(i,j,k+1,idicsat)=tc_sat * rrho ! k+1 = the rest of the mixed layer + ocetra(i,j,1:kmle(i,j),idicsat) = tc_sat * rrho ! convert mol/kg to kmlo/m^3 #ifdef cisonew ! Ocean-Atmosphere fluxes for carbon isotopes @@ -501,7 +510,9 @@ SUBROUTINE CARCHM(kpie,kpje,kpke,kbnd, & niflux=kwn2*dtbgc*(ocetra(i,j,1,igasnit)-anisa*(atn2/802000)*rpp0) ocetra(i,j,1,igasnit)=ocetra(i,j,1,igasnit)-niflux/pddpo(i,j,1) ! Surface flux of laughing gas (same piston velocity as for O2 and N2) - n2oflux=kwn2o*dtbgc*(ocetra(i,j,1,ian2o)-satn2o(i,j)*atn2ov*rpp0) + n2oflux=kwn2o*dtbgc*(ocetra(i,j,1,ian2o)-satn2o(i,j)*atn2ov*rpp0) + ! pN2O under moist air assumption at normal pressure + pn2om(i,j) = 1e9 * ocetra(i,j,1,ian2o)/satn2o(i,j) ocetra(i,j,1,ian2o)=ocetra(i,j,1,ian2o)-n2oflux/pddpo(i,j,1) #ifdef CFC ! Surface fluxes for CFC: eqn. (1a) in ocmip2 howto doc(hyc) @@ -560,6 +571,9 @@ SUBROUTINE CARCHM(kpie,kpje,kpke,kbnd, & ! surface flux NH3: STILL REQUIRES TO CHECK CONVERSION FACTOR FOR atNH3 (currently assumed atNH3 in pptv) flx_nh3 = Kh_nh3*dtbgc*(atnh3*1e-12*ppao(i,j)*1e-5/(tk*0.08314510) - hstar_nh3*ocetra(i,j,1,ianh4)) ocetra(i,j,1,ianh4) = ocetra(i,j,1,ianh4) + flx_nh3/pddpo(i,j,1) + + ! pNH3 in natm + pnh3(i,j) = hstar_nh3*ocetra(i,j,1,ianh4) * 8.20573660809596e-5 * (t+273.15) * 1e12 #endif ! Save surface fluxes @@ -599,13 +613,17 @@ SUBROUTINE CARCHM(kpie,kpje,kpke,kbnd, & ! Save pco2 w.r.t. dry air for output pco2d(i,j) = cu * 1.e6 / Khd + !pCO2 wrt moist air + pco2m(i,j) = cu * 1.e6 / Kh #ifdef natDIC natpco2d(i,j) = natcu * 1.e6 / Khd #endif ! Save product of piston velocity and solubility for output - kwco2sol(i,j) = kwco2*Kh*1e-6 - + kwco2sol(i,j) = kwco2*Kh*1e-6 !m/s mol/kg/muatm + kwco2d(i,j) = kwco2 ! m/s (incl. ice fraction!) + co2sold(i,j) = Khd ! mol/kg/atm + co2solm(i,j) = Kh ! mol/kg/atm endif ! k==1 #ifdef BROMO diff --git a/hamocc/cyano.F90 b/hamocc/cyano.F90 index 0c0da5cc..2a113655 100644 --- a/hamocc/cyano.F90 +++ b/hamocc/cyano.F90 @@ -17,7 +17,7 @@ ! along with BLOM. If not, see https://www.gnu.org/licenses/. - SUBROUTINE CYANO(kpie,kpje,kpke,kbnd,pddpo,omask,ptho) +SUBROUTINE CYANO(kpie,kpje,kpke,kbnd,pddpo,omask,ptho) !********************************************************************** ! !**** *CYANO* - . @@ -61,48 +61,47 @@ SUBROUTINE CYANO(kpie,kpje,kpke,kbnd,pddpo,omask,ptho) ! . !********************************************************************** - use mo_carbch, only: ocetra - use mo_biomod, only: bluefix,intnfix,rnit,tf0,tf1,tf2,tff - use mo_param1_bgc, only: ialkali,iano3,igasnit,iphosph,ioxygen - use mo_vgrid, only: kmle + use mo_carbch, only: ocetra + use mo_biomod, only: bluefix,intnfix,rnit,tf0,tf1,tf2,tff + use mo_param1_bgc, only: ialkali,iano3,igasnit,iphosph,ioxygen + use mo_vgrid, only: kmle #ifdef natDIC - use mo_param1_bgc, only: inatalkali + use mo_param1_bgc, only: inatalkali #endif #ifdef extNcycle - use mo_param1_bgc, only: ianh4 + use mo_param1_bgc, only: ianh4 #endif - implicit none - - INTEGER, intent(in) :: kpie,kpje,kpke,kbnd - REAL, intent(in) :: pddpo(kpie,kpje,kpke) - REAL, intent(in) :: omask(kpie,kpje) - REAL, intent(in) :: ptho(1-kbnd:kpie+kbnd,1-kbnd:kpje+kbnd,kpke) + implicit none - ! Local variables - INTEGER :: i,j,k - REAL :: oldocetra,anavail,dansp,dox,dalk - REAL :: ttemp,nfixtfac + INTEGER, intent(in) :: kpie,kpje,kpke,kbnd + REAL, intent(in) :: pddpo(kpie,kpje,kpke) + REAL, intent(in) :: omask(kpie,kpje) + REAL, intent(in) :: ptho(1-kbnd:kpie+kbnd,1-kbnd:kpje+kbnd,kpke) + + ! Local variables + INTEGER :: i,j,k + REAL :: oldocetra,anavail,dansp,dox,dalk + REAL :: ttemp,nfixtfac + + intnfix(:,:)=0.0 - intnfix(:,:)=0.0 - ! ! N-fixation by cyano bacteria (followed by remineralisation and nitrification, ! or, for the extended nitrogen cycle only by remin to NH4), ! it is assumed here that this process is limited to the mixed layer ! - DO k=1,kmle -!$OMP PARALLEL DO PRIVATE(i,oldocetra,dansp,anavail,dox,dalk,ttemp,nfixtfac) - DO j=1,kpje - DO i=1,kpie - IF(omask(i,j).gt.0.5) THEN + DO j=1,kpje + DO i=1,kpie + IF(omask(i,j).gt.0.5) THEN + DO k=1,kmle(i,j) #ifdef extNcycle - ! assuming nitrate and ammonium required for cyanobacteria growth (as bulk PP) - anavail = ocetra(i,j,k,iano3)+ocetra(i,j,k,ianh4) + ! assuming nitrate and ammonium required for cyanobacteria growth (as bulk PP) + anavail = ocetra(i,j,k,iano3)+ocetra(i,j,k,ianh4) #else - anavail = ocetra(i,j,k,iano3) + anavail = ocetra(i,j,k,iano3) #endif - IF(anavail.LT.(rnit*ocetra(i,j,k,iphosph))) THEN + IF(anavail.LT.(rnit*ocetra(i,j,k,iphosph))) THEN ttemp = min(40.,max(-3.,ptho(i,j,k))) @@ -140,14 +139,10 @@ SUBROUTINE CYANO(kpie,kpje,kpke,kbnd,pddpo,omask,ptho) intnfix(i,j) = intnfix(i,j) + dansp*pddpo(i,j,k) - ENDIF - ENDIF - ENDDO - ENDDO -!$OMP END PARALLEL DO - ENDDO - - + ENDIF + ENDDO + ENDIF + ENDDO + ENDDO - RETURN - END +END SUBROUTINE CYANO diff --git a/hamocc/dipowa.F90 b/hamocc/dipowa.F90 index 18cf5dae..f601b33b 100644 --- a/hamocc/dipowa.F90 +++ b/hamocc/dipowa.F90 @@ -40,7 +40,7 @@ subroutine dipowa(kpie,kpje,kpke,omask,lspin) ! Method ! ------- ! implicit formulation; -! constant diffusion coefficient : 1.e-9 set in BODENSED. +! constant diffusion coefficient : 1.e-9 set in ini_sedmnt in mo_sedmnt ! diffusion coefficient : zcoefsu/zcoeflo for upper/lower ! sediment layer boundary. ! @@ -56,8 +56,8 @@ subroutine dipowa(kpie,kpje,kpke,omask,lspin) !********************************************************************** use mo_carbch, only: ocetra, sedfluxo - use mo_sedmnt, only: powtra,porwat,porwah,sedict,seddw,seddzi - use mo_param1_bgc, only: ks,npowtra + use mo_sedmnt, only: powtra,porwat,porwah,sedict,seddw,seddzi,zcoefsu,zcoeflo + use mo_param1_bgc, only: ks,npowtra,map_por2octra use mo_vgrid, only: kbo,bolay #ifdef cisonew use mo_param1_bgc, only: ipowc13,ipowc14,isco213,isco214 @@ -77,7 +77,6 @@ subroutine dipowa(kpie,kpje,kpke,omask,lspin) integer :: iv_oc ! index of ocetra in powtra loop real :: sedb1(kpie,0:ks,npowtra) ! ???? - real :: zcoefsu(0:ks),zcoeflo(0:ks) ! diffusion coefficients (upper/lower) real :: tredsy(kpie,0:kpke,3) ! redsy for 'reduced system'? real :: aprior ! start value of oceanic tracer in bottom layer @@ -85,14 +84,6 @@ subroutine dipowa(kpie,kpje,kpke,omask,lspin) !ik needed for boundary layer ventilation in fast sediment routine real :: bolven(kpie) ! bottom layer ventilation rate - zcoefsu(0) = 0.0 - do k = 1,ks - ! sediment diffusion coefficient * 1/dz * fraction of pore water at half depths - zcoefsu(k ) = -sedict * seddzi(k) * porwah(k) - zcoeflo(k-1) = -sedict * seddzi(k) * porwah(k) ! why the same ? - enddo - zcoeflo(ks) = 0.0 ! diffusion coefficient for bottom sediment layer - !$OMP PARALLEL DO & !$OMP&PRIVATE(i,k,iv,l,bolven,tredsy,sedb1,aprior,iv_oc) j_loop: do j=1,kpje @@ -104,19 +95,15 @@ subroutine dipowa(kpie,kpje,kpke,omask,lspin) k = 0 do i = 1,kpie - tredsy(i,k,1) = zcoefsu(k) - tredsy(i,k,3) = zcoeflo(k) + tredsy(i,k,1) = zcoefsu(i,j,k) + tredsy(i,k,3) = zcoeflo(i,j,k) tredsy(i,k,2) = bolven(i)*bolay(i,j) - tredsy(i,k,1) - tredsy(i,k,3) ! dz(kbo) - diff upper - diff lower enddo k = 0 do iv = 1,npowtra ! loop over pore water tracers - iv_oc = iv -#ifdef cisonew - if (iv == ipowc13) iv_oc = isco213 - if (iv == ipowc14) iv_oc = isco214 -#endif + iv_oc = map_por2octra(iv) do i = 1,kpie sedb1(i,k,iv) = 0. if (omask(i,j) > 0.5) then @@ -128,9 +115,9 @@ subroutine dipowa(kpie,kpje,kpke,omask,lspin) do k = 1,ks do i = 1,kpie - tredsy(i,k,1) = zcoefsu(k) - tredsy(i,k,3) = zcoeflo(k) - tredsy(i,k,2) = seddw(k)*porwat(k) -tredsy(i,k,1) -tredsy(i,k,3) + tredsy(i,k,1) = zcoefsu(i,j,k) + tredsy(i,k,3) = zcoeflo(i,j,k) + tredsy(i,k,2) = seddw(k)*porwat(i,j,k) -tredsy(i,k,1) -tredsy(i,k,3) enddo enddo @@ -138,7 +125,7 @@ subroutine dipowa(kpie,kpje,kpke,omask,lspin) do k = 1,ks do i = 1,kpie ! tracer_concentration(k[1:ks]) * porewater fraction(k) * dz(k) - sedb1(i,k,iv) = powtra(i,j,k,iv) * porwat(k) * seddw(k) + sedb1(i,k,iv) = powtra(i,j,k,iv) * porwat(i,j,k) * seddw(k) enddo enddo enddo @@ -190,16 +177,8 @@ subroutine dipowa(kpie,kpje,kpke,omask,lspin) if(.not. lspin) THEN ! sediment ocean interface -! -! CAUTION - the following assumes same indecees for ocetra and powtra -! test npowa_base 071106 -! check mo_param1_bgc.f90 for consistency do iv = 1, npowtra - iv_oc = iv -#ifdef cisonew - if (iv == ipowc13) iv_oc=isco213 - if (iv == ipowc14) iv_oc=isco214 -#endif + iv_oc = map_por2octra(iv) do i = 1,kpie l = 0 if (omask(i,j) > 0.5) then @@ -210,14 +189,15 @@ subroutine dipowa(kpie,kpje,kpke,omask,lspin) ! diffusive fluxes (positive downward) sedfluxo(i,j,iv) = sedfluxo(i,j,iv) & - & -(ocetra(i,j,kbo(i,j),iv) - aprior)* bolay(i,j) + & -(ocetra(i,j,kbo(i,j),iv_oc) - aprior)* bolay(i,j) #ifdef natDIC - if (iv==isco212) ocetra(i,j,kbo(i,j),inatsco212) = & + ! workaround as long as natDIC is not implemented throughout the sediment module + if (iv_oc==isco212) ocetra(i,j,kbo(i,j),inatsco212) = & & ocetra(i,j,kbo(i,j),inatsco212) + & - & ocetra(i,j,kbo(i,j),iv) - aprior - if (iv==ialkali) ocetra(i,j,kbo(i,j),inatalkali) = & + & ocetra(i,j,kbo(i,j),isco212) - aprior + if (iv_oc==ialkali) ocetra(i,j,kbo(i,j),inatalkali) = & & ocetra(i,j,kbo(i,j),inatalkali) + & - & ocetra(i,j,kbo(i,j),iv) - aprior + & ocetra(i,j,kbo(i,j),ialkali) - aprior #endif endif enddo diff --git a/hamocc/hamocc4bcm.F90 b/hamocc/hamocc4bcm.F90 index 0dd3e6a3..48391522 100644 --- a/hamocc/hamocc4bcm.F90 +++ b/hamocc/hamocc4bcm.F90 @@ -19,7 +19,7 @@ SUBROUTINE HAMOCC4BCM(kpie,kpje,kpke,kbnd,kplyear,kplmon,kplday,kldtday,& pdlxp,pdlyp,pddpo,prho,pglat,omask, & - dust,rivin,ndep,pi_ph, & + dust,rivin,ndep,oafx,pi_ph, & pfswr,psicomo,ppao,pfu10,ptho,psao, & patmco2,pflxco2,pflxdms,patmbromo,pflxbromo) !****************************************************************************** @@ -64,8 +64,9 @@ SUBROUTINE HAMOCC4BCM(kpie,kpje,kpke,kbnd,kplyear,kplmon,kplday,kldtday,& ! *REAL* *pglat* - latitude of grid cells [deg north]. ! *REAL* *omask* - land/ocean mask. ! *REAL* *dust* - dust deposition flux [kg/m2/month]. -! *REAL* *rivin* - riverine input [kmol m-2 yr-2]. -! *REAL* *ndep* - nitrogen deposition [kmol m-2 yr-2]. +! *REAL* *rivin* - riverine input [kmol m-2 yr-1]. +! *REAL* *ndep* - nitrogen deposition [kmol m-2 yr-1]. +! *REAL* *oaflx* - alkalinity flux from alkalinization [kmol m-2 yr-1] ! *REAL* *pfswr* - solar radiation [W/m**2]. ! *REAL* *psicomo* - sea ice concentration ! *REAL* *ppao* - sea level pressure [Pascal]. @@ -91,6 +92,7 @@ SUBROUTINE HAMOCC4BCM(kpie,kpje,kpke,kbnd,kplyear,kplmon,kplday,kldtday,& use mo_apply_fedep, only: apply_fedep use mo_apply_rivin, only: apply_rivin use mo_apply_ndep, only: apply_ndep + use mo_apply_oafx, only: apply_oafx #if defined(BOXATM) use mo_boxatm, only: update_boxatm #endif @@ -113,6 +115,7 @@ SUBROUTINE HAMOCC4BCM(kpie,kpje,kpke,kbnd,kplyear,kplmon,kplday,kldtday,& REAL, intent(in) :: dust (kpie,kpje) REAL, intent(in) :: rivin (kpie,kpje,nriv) REAL, intent(in) :: ndep (kpie,kpje) + REAL, intent(in) :: oafx (kpie,kpje) REAL, intent(in) :: pi_ph (kpie,kpje) REAL, intent(in) :: pfswr (1-kbnd:kpie+kbnd,1-kbnd:kpje+kbnd) REAL, intent(in) :: psicomo(1-kbnd:kpie+kbnd,1-kbnd:kpje+kbnd) @@ -219,7 +222,7 @@ SUBROUTINE HAMOCC4BCM(kpie,kpje,kpke,kbnd,kplyear,kplmon,kplday,kldtday,& ! the model CALL apply_fedep(kpie,kpje,kpke,pddpo,omask,dust) - CALL OCPROD(kpie,kpje,kpke,kbnd,pdlxp,pdlyp,pddpo,omask,ptho,pi_ph) + CALL OCPROD(kpie,kpje,kpke,kbnd,pdlxp,pdlyp,pddpo,omask,ptho,pi_ph,psao,ppao,prho) #ifdef PBGC_CK_TIMESTEP IF (mnproc.eq.1) THEN @@ -298,6 +301,17 @@ SUBROUTINE HAMOCC4BCM(kpie,kpje,kpke,kbnd,kplyear,kplmon,kplday,kldtday,& CALL INVENTORY_BGC(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask,0) #endif + ! Apply alkalinity flux due to ocean alkalinization + call apply_oafx(kpie,kpje,kpke,pddpo,omask,oafx) + +#ifdef PBGC_CK_TIMESTEP + IF (mnproc.eq.1) THEN + WRITE(io_stdo_bgc,*)' ' + WRITE(io_stdo_bgc,*)'after ocean alkalinization: call INVENTORY' + ENDIF + CALL INVENTORY_BGC(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask,0) +#endif + ! Update atmospheric pCO2 [ppm] #if defined(BOXATM) CALL update_boxatm(kpie,kpje,pdlxp,pdlyp) @@ -342,7 +356,7 @@ SUBROUTINE HAMOCC4BCM(kpie,kpje,kpke,kbnd,kplyear,kplmon,kplday,kldtday,& lspin=.false. endif - call POWACH(kpie,kpje,kpke,kbnd,prho,omask,psao,lspin) + call POWACH(kpie,kpje,kpke,kbnd,prho,omask,psao,ptho,lspin) enddo diff --git a/hamocc/hamocc_init.F b/hamocc/hamocc_init.F deleted file mode 100644 index 49e26675..00000000 --- a/hamocc/hamocc_init.F +++ /dev/null @@ -1,233 +0,0 @@ -c Copyright (C) 2020 K. Assmann, J. Tjiputra, J. Schwinger, M. Bentsen, -c P.-G. Chiu -c -c This file is part of BLOM/iHAMOCC. -c -c BLOM is free software: you can redistribute it and/or modify it under the -c terms of the GNU Lesser General Public License as published by the Free -c Software Foundation, either version 3 of the License, or (at your option) -c any later version. -c -c BLOM is distributed in the hope that it will be useful, but WITHOUT ANY -c WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS -c FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for -c more details. -c -c You should have received a copy of the GNU Lesser General Public License -c along with BLOM. If not, see https://www.gnu.org/licenses/. - - - subroutine hamocc_init(read_rest,rstfnm_hamocc) -c****************************************************************************** -c -c HAMOCC_INIT - initialize HAMOCC and its interface to BLOM. -c -c -c J.Schwinger, *NORCE Climate, Bergen* 2020-05-25 -c -c -c Purpose -c ------- -c - HAMOCC intialization when coupled to BLOM. -c -c -c Interface to ocean model (parameter list): -c ----------------------------------------- -c *INTEGER* *read_rest* - flag indicating whether to read restart files. -c *INTEGER* *rstfnm_hamocc* - restart filename. -c -c****************************************************************************** - use mod_time, only: date,baclin - use mod_xc, only: ii,jj,kk,idm,jdm,kdm,nbdy,isp,ifp,ilp, - . mnproc,lp,nfu,xchalt - use mod_grid, only: plon,plat - use mod_tracers, only: ntrbgc,ntr,itrbgc,trc - use mo_control_bgc, only: bgc_namelist,get_bgc_namelist, - . do_ndep,do_rivinpt,do_sedspinup, - . sedspin_yr_s,sedspin_yr_e,sedspin_ncyc, - . dtb,dtbgc,io_stdo_bgc,ldtbgc, - . ldtrunbgc,ndtdaybgc,with_dmsph - use mo_param1_bgc, only: ks,nsedtra,npowtra - use mo_carbch, only: alloc_mem_carbch,ocetra,atm,atm_co2 - use mo_biomod, only: alloc_mem_biomod - use mo_sedmnt, only: alloc_mem_sedmnt,sedlay,powtra,burial - use mo_vgrid, only: alloc_mem_vgrid,set_vgrid - use mo_bgcmean, only: alloc_mem_bgcmean - use mo_read_rivin, only: ini_read_rivin,rivinfile - use mo_read_fedep, only: ini_read_fedep,fedepfile - use mo_read_ndep, only: ini_read_ndep,ndepfile - use mo_read_pi_ph, only: ini_pi_ph,pi_ph_file - use mo_clim_swa, only: ini_swa_clim,swaclimfile - use mo_Gdata_read, only: inidic,inialk,inipo4,inioxy,inino3, - . inisil,inid13c,inid14c - use mo_intfcblom, only: alloc_mem_intfcblom,nphys, - . bgc_dx,bgc_dy,bgc_dp,bgc_rho, - . omask,sedlay2,powtra2,burial2, - . blom2hamocc -#ifdef BOXATM - use mo_intfcblom, only: atm2 -#endif -c - implicit none -c - integer, intent(in) :: read_rest - character(len=*), intent(in) :: rstfnm_hamocc - - integer :: i,j,k,l,nt - integer :: iounit - - namelist /bgcnml/ atm_co2,do_rivinpt,do_ndep, - . ndepfile,fedepfile,rivinfile, - . do_sedspinup,sedspin_yr_s, - . sedspin_yr_e,sedspin_ncyc, - . inidic,inialk,inipo4,inioxy,inino3,inisil, - . inid13c,inid14c,swaclimfile, - . with_dmsph,pi_ph_file -c -c --- Set io units and some control parameters -c - io_stdo_bgc = lp ! standard out. - dtbgc = nphys*baclin ! time step length [sec]. - ndtdaybgc=NINT(86400./dtbgc) ! time steps per day [No]. - dtb=1./ndtdaybgc ! time step length [days]. - ldtbgc = 0 - ldtrunbgc = 0 - - if (mnproc.eq.1) then - write(io_stdo_bgc,*) - WRITE(io_stdo_bgc,*)'********************************************' - write(io_stdo_bgc,*) 'iHAMOCC: initialisation' - write(io_stdo_bgc,*) - write(io_stdo_bgc,*) 'restart',read_rest - write(io_stdo_bgc,*) 'dims',idm,jdm,kdm - write(io_stdo_bgc,*) 'date',date - write(io_stdo_bgc,*) 'time step',dtbgc - endif -c -c --- Read the HAMOCC BGCNML namelist and check the value of some variables. -c - if(.not. allocated(bgc_namelist)) call get_bgc_namelist - open (newunit=iounit, file=bgc_namelist, status='old' - . ,action='read') - read (unit=iounit, nml=BGCNML) - close (unit=iounit) - IF (mnproc.eq.1) THEN - - write(io_stdo_bgc,*) - write(io_stdo_bgc,*) 'iHAMOCC: reading namelist BGCNML' - write(io_stdo_bgc,nml=BGCNML) - - if(do_sedspinup) then - if(sedspin_yr_s<0 .or. sedspin_yr_e<0 .or. - . sedspin_yr_s>sedspin_yr_e) then - call xchalt('(invalid sediment spinup start/end year)') - stop '(invalid sediment spinup start/end year)' - endif - if(sedspin_ncyc < 2) then - call xchalt('(invalid nb. of sediment spinup subcycles)') - stop '(invalid nb. of sediment spinup subcycles)' - endif - endif - - ENDIF -c -c --- Memory allocation -c - CALL ALLOC_MEM_INTFCBLOM(idm,jdm,kdm) - CALL ALLOC_MEM_BGCMEAN(idm,jdm,kdm) - CALL ALLOC_MEM_VGRID(idm,jdm,kdm) - CALL ALLOC_MEM_BIOMOD(idm,jdm,kdm) - CALL ALLOC_MEM_SEDMNT(idm,jdm) - CALL ALLOC_MEM_CARBCH(idm,jdm,kdm) -c -c --- initialise trc array (two time levels) -c - do nt=itrbgc,itrbgc+ntrbgc-1 - do k=1,2*kk - do j=1,jj - do i=1,ii - trc(i,j,k,nt)=0.0 - enddo - enddo - enddo - enddo -c -c --- initialise HAMOCC land/ocean mask -c - do j=1,jj - do l=1,isp(j) - do i=max(1,ifp(j,l)),min(ii,ilp(j,l)) - omask(i,j)=1. - enddo - enddo - enddo -c -c --- BLOM to HAMOCC interface -c - call blom2hamocc(2,1,kk,0) -c -c --- Calculate variables related to the vertical grid -c - call set_vgrid(idm,jdm,kdm,bgc_dp) -c -c --- Initialize sediment layering -c - CALL BODENSED(idm,jdm,kdm,bgc_dp) -c -c --- Initialize parameters, sediment and ocean tracer. -c - CALL BELEG_PARM(idm,jdm) - CALL BELEG_VARS(read_rest,idm,jdm,kdm,nbdy,bgc_dp,bgc_rho,omask, - . plon,plat) -c -c --- Initialise reading of input data (dust, n-deposition, river, etc.) -c - CALL ini_read_fedep(idm,jdm,omask) - - CALL ini_read_ndep(idm,jdm) - - CALL ini_read_rivin(idm,jdm,omask) - -#ifdef BROMO - CALL ini_swa_clim(idm,jdm,omask) -#endif - - call ini_pi_ph(idm,jdm,omask) -c -c --- Read restart fields from restart file if requested, otherwise -c (at first start-up) copy ocetra and sediment arrays (which are -c initialised in BELEG_VARS) to both timelevels of their respective -c two-time-level counterpart -c - IF(read_rest.eq.1) THEN - CALL AUFR_BGC(idm,jdm,kdm,ntr,ntrbgc,itrbgc,trc, - . date%year,date%month,date%day,omask,rstfnm_hamocc) - ELSE - trc(1:idm,1:jdm,1:kdm, itrbgc:itrbgc+ntrbgc-1) = - . ocetra(:,:,:,:) - trc(1:idm,1:jdm,kdm+1:2*kdm,itrbgc:itrbgc+ntrbgc-1) = - . ocetra(:,:,:,:) -#ifndef sedbypass - sedlay2(:,:,1:ks,:) = sedlay(:,:,:,:) - sedlay2(:,:,ks+1:2*ks,:) = sedlay(:,:,:,:) - powtra2(:,:,1:ks,:) = powtra(:,:,:,:) - powtra2(:,:,ks+1:2*ks,:) = powtra(:,:,:,:) - burial2(:,:,1,:) = burial(:,:,:) - burial2(:,:,2,:) = burial(:,:,:) -#endif -#if defined(BOXATM) - atm2(:,:,1,:) = atm(:,:,:) - atm2(:,:,2,:) = atm(:,:,:) -#endif - ENDIF -c - if (mnproc.eq.1) then - write(io_stdo_bgc,*) - WRITE(io_stdo_bgc,*)'********************************************' - write(io_stdo_bgc,*) 'iHAMOCC: finished initialisation' - write(io_stdo_bgc,*) - endif - - return -c****************************************************************************** - end subroutine hamocc_init diff --git a/hamocc/hamocc_init.F90 b/hamocc/hamocc_init.F90 new file mode 100644 index 00000000..40d831a5 --- /dev/null +++ b/hamocc/hamocc_init.F90 @@ -0,0 +1,248 @@ +! Copyright (C) 2020 K. Assmann, J. Tjiputra, J. Schwinger, M. Bentsen, +! P.-G. Chiu +! +! This file is part of BLOM/iHAMOCC. +! +! 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 https://www.gnu.org/licenses/. + + +subroutine hamocc_init(read_rest,rstfnm_hamocc) +!****************************************************************************** +! +! HAMOCC_INIT - initialize HAMOCC and its interface to BLOM. +! +! +! J.Schwinger, *NORCE Climate, Bergen* 2020-05-25 +! +! +! Purpose +! ------- +! - HAMOCC intialization when coupled to BLOM. +! +! +! Interface to ocean model (parameter list): +! ----------------------------------------- +! *INTEGER* *read_rest* - flag indicating whether to read restart files. +! *INTEGER* *rstfnm_hamocc* - restart filename. +! +!****************************************************************************** + use mod_time, only: date,baclin + use mod_xc, only: ii,jj,kk,idm,jdm,kdm,nbdy,isp,ifp,ilp, & + & mnproc,lp,nfu,xchalt + use mod_grid, only: plon,plat + use mod_tracers, only: ntrbgc,ntr,itrbgc,trc + use mo_control_bgc, only: bgc_namelist,get_bgc_namelist, & + & do_ndep,do_rivinpt,do_oalk,do_sedspinup, & + & sedspin_yr_s,sedspin_yr_e,sedspin_ncyc, & + & dtb,dtbgc,io_stdo_bgc,ldtbgc, & + & ldtrunbgc,ndtdaybgc,with_dmsph,l_3Dvarsedpor,lm4ago + use mo_param1_bgc, only: ks,init_por2octra_mapping + use mo_carbch, only: alloc_mem_carbch,ocetra,atm,atm_co2 + use mo_biomod, only: alloc_mem_biomod + use mo_sedmnt, only: alloc_mem_sedmnt,sedlay,powtra,burial,ini_sedmnt + use mo_vgrid, only: alloc_mem_vgrid,set_vgrid + use mo_bgcmean, only: alloc_mem_bgcmean + use mo_read_rivin, only: ini_read_rivin,rivinfile + use mo_read_fedep, only: ini_read_fedep,fedepfile + use mo_read_ndep, only: ini_read_ndep,ndepfile + use mo_read_oafx, only: ini_read_oafx,oalkfile,oalkscen + use mo_read_pi_ph, only: ini_pi_ph,pi_ph_file + use mo_read_sedpor, only: read_sedpor,sedporfile + use mo_clim_swa, only: ini_swa_clim,swaclimfile + use mo_Gdata_read, only: inidic,inialk,inipo4,inioxy,inino3, & + & inisil,inid13c,inid14c + use mo_intfcblom, only: alloc_mem_intfcblom,nphys, & + & bgc_dx,bgc_dy,bgc_dp,bgc_rho, & + & omask,sedlay2,powtra2,burial2, & + & blom2hamocc + use mo_m4ago, only: alloc_mem_m4ago +#ifdef BOXATM + use mo_intfcblom, only: atm2 +#endif +#ifdef extNcycle + use mo_extNsediment,only: alloc_mem_extNsediment_diag +#endif + + implicit none + + integer, intent(in) :: read_rest + character(len=*), intent(in) :: rstfnm_hamocc + + integer :: i,j,k,l,nt + integer :: iounit + real :: sed_por(idm,jdm,ks) = 0. + + namelist /bgcnml/ atm_co2,fedepfile,do_rivinpt,rivinfile,do_ndep,ndepfile, & + & do_oalk,oalkscen,oalkfile,do_sedspinup,sedspin_yr_s, & + & sedspin_yr_e,sedspin_ncyc, & + & inidic,inialk,inipo4,inioxy,inino3,inisil, & + & inid13c,inid14c,swaclimfile, & + & with_dmsph,pi_ph_file,l_3Dvarsedpor,sedporfile,lm4ago + ! + ! --- Set io units and some control parameters + ! + io_stdo_bgc = lp ! standard out. + dtbgc = nphys*baclin ! time step length [sec]. + ndtdaybgc=NINT(86400./dtbgc) ! time steps per day [No]. + dtb=1./ndtdaybgc ! time step length [days]. + ldtbgc = 0 + ldtrunbgc = 0 + + if (mnproc.eq.1) then + write(io_stdo_bgc,*) + WRITE(io_stdo_bgc,*)'********************************************' + write(io_stdo_bgc,*) 'iHAMOCC: initialisation' + write(io_stdo_bgc,*) + write(io_stdo_bgc,*) 'restart',read_rest + write(io_stdo_bgc,*) 'dims',idm,jdm,kdm + write(io_stdo_bgc,*) 'date',date + write(io_stdo_bgc,*) 'time step',dtbgc + endif + ! + ! --- Read the HAMOCC BGCNML namelist and check the value of some variables. + ! + if(.not. allocated(bgc_namelist)) call get_bgc_namelist + open (newunit=iounit, file=bgc_namelist, status='old' & + & ,action='read') + read (unit=iounit, nml=BGCNML) + close (unit=iounit) + IF (mnproc.eq.1) THEN + + write(io_stdo_bgc,*) + write(io_stdo_bgc,*) 'iHAMOCC: reading namelist BGCNML' + write(io_stdo_bgc,nml=BGCNML) + + if(do_sedspinup) then + if(sedspin_yr_s<0 .or. sedspin_yr_e<0 .or. & + & sedspin_yr_s>sedspin_yr_e) then + call xchalt('(invalid sediment spinup start/end year)') + stop '(invalid sediment spinup start/end year)' + endif + if(sedspin_ncyc < 2) then + call xchalt('(invalid nb. of sediment spinup subcycles)') + stop '(invalid nb. of sediment spinup subcycles)' + endif + endif + + ENDIF + ! init the index-mapping between pore water and ocean tracers + CALL init_por2octra_mapping() + + ! + ! --- Memory allocation + ! + CALL ALLOC_MEM_INTFCBLOM(idm,jdm,kdm) + CALL ALLOC_MEM_BGCMEAN(idm,jdm,kdm) + CALL ALLOC_MEM_VGRID(idm,jdm,kdm) + CALL ALLOC_MEM_BIOMOD(idm,jdm,kdm) + CALL ALLOC_MEM_SEDMNT(idm,jdm) + CALL ALLOC_MEM_CARBCH(idm,jdm,kdm) + CALL ALLOC_MEM_M4AGO(idm,jdm,kdm) +#if defined(extNcycle) && ! defined(sedbypass) + CALL ALLOC_MEM_extNsediment_diag(idm,jdm,ks) +#endif + ! + ! --- initialise trc array (two time levels) + ! + do nt=itrbgc,itrbgc+ntrbgc-1 + do k=1,2*kk + do j=1,jj + do i=1,ii + trc(i,j,k,nt)=0.0 + enddo + enddo + enddo + enddo + ! + ! --- initialise HAMOCC land/ocean mask + ! + do j=1,jj + do l=1,isp(j) + do i=max(1,ifp(j,l)),min(ii,ilp(j,l)) + omask(i,j)=1. + enddo + enddo + enddo + ! + ! --- BLOM to HAMOCC interface + ! + call blom2hamocc(2,1,kk,0) + ! + ! --- Calculate variables related to the vertical grid + ! + call set_vgrid(idm,jdm,kdm,bgc_dp) + ! + ! --- Initialize sediment layering + ! First read the porosity, then apply it in ini_sedmnt + CALL read_sedpor(idm,jdm,ks,omask,sed_por) + CALL ini_sedmnt(idm,jdm,kdm,omask,sed_por) + ! + ! --- Initialize parameters, sediment and ocean tracer. + ! + CALL BELEG_PARM(idm,jdm) + CALL BELEG_VARS(read_rest,idm,jdm,kdm,nbdy,bgc_dp,bgc_rho,omask, & + & plon,plat) + ! + ! --- Initialise reading of input data (dust, n-deposition, river, etc.) + ! + CALL ini_read_fedep(idm,jdm,omask) + + CALL ini_read_ndep(idm,jdm) + + CALL ini_read_rivin(idm,jdm,omask) + + CALL ini_read_oafx(idm,jdm,bgc_dx,bgc_dy,plat,omask) + +#ifdef BROMO + CALL ini_swa_clim(idm,jdm,omask) +#endif + + call ini_pi_ph(idm,jdm,omask) + ! + ! --- Read restart fields from restart file if requested, otherwise + ! (at first start-up) copy ocetra and sediment arrays (which are + ! initialised in BELEG_VARS) to both timelevels of their respective + ! two-time-level counterpart + ! + IF(read_rest.eq.1) THEN + CALL AUFR_BGC(idm,jdm,kdm,ntr,ntrbgc,itrbgc,trc, & + & date%year,date%month,date%day,omask,rstfnm_hamocc) + ELSE + trc(1:idm,1:jdm,1:kdm, itrbgc:itrbgc+ntrbgc-1) = & + & ocetra(:,:,:,:) + trc(1:idm,1:jdm,kdm+1:2*kdm,itrbgc:itrbgc+ntrbgc-1) = & + & ocetra(:,:,:,:) +#ifndef sedbypass + sedlay2(:,:,1:ks,:) = sedlay(:,:,:,:) + sedlay2(:,:,ks+1:2*ks,:) = sedlay(:,:,:,:) + powtra2(:,:,1:ks,:) = powtra(:,:,:,:) + powtra2(:,:,ks+1:2*ks,:) = powtra(:,:,:,:) + burial2(:,:,1,:) = burial(:,:,:) + burial2(:,:,2,:) = burial(:,:,:) +#endif +#if defined(BOXATM) + atm2(:,:,1,:) = atm(:,:,:) + atm2(:,:,2,:) = atm(:,:,:) +#endif + ENDIF + + if (mnproc.eq.1) then + write(io_stdo_bgc,*) + WRITE(io_stdo_bgc,*)'********************************************' + write(io_stdo_bgc,*) 'iHAMOCC: finished initialisation' + write(io_stdo_bgc,*) + endif + +!****************************************************************************** +end subroutine hamocc_init diff --git a/hamocc/hamocc_step.F b/hamocc/hamocc_step.F deleted file mode 100644 index c95f6b75..00000000 --- a/hamocc/hamocc_step.F +++ /dev/null @@ -1,85 +0,0 @@ -c Copyright (C) 2020 K. Assmann, J. Tjiputra, J. Schwinger, M. Bentsen -c -c This file is part of BLOM/iHAMOCC. -c -c BLOM is free software: you can redistribute it and/or modify it under the -c terms of the GNU Lesser General Public License as published by the Free -c Software Foundation, either version 3 of the License, or (at your option) -c any later version. -c -c BLOM is distributed in the hope that it will be useful, but WITHOUT ANY -c WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS -c FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for -c more details. -c -c You should have received a copy of the GNU Lesser General Public License -c along with BLOM. If not, see https://www.gnu.org/licenses/. - - - subroutine hamocc_step(m,n,mm,nn,k1m,k1n) -c -c --- ------------------------------------------------------------------ -c --- perform one HAMOCC step -c --- ------------------------------------------------------------------ -c - use mod_xc, only: idm,jdm,kdm,nbdy - use mod_time, only: date,nday_of_year,nstep,nstep_in_day - use mod_grid, only: plat - use mod_state, only: temp,saln - use mod_forcing, only: swa,slp,abswnd,atmco2,flxco2,flxdms, - . atmbrf,flxbrf - use mod_seaice, only: ficem - use mo_bgcmean, only: nbgc,bgcwrt, diagfq_bgc,diagmon_bgc, - . diagann_bgc - use mo_intfcblom, only: bgc_dx,bgc_dy,bgc_dp,bgc_rho,omask, - . blom2hamocc,hamocc2blom - use mo_read_rivin, only: rivflx - use mo_read_fedep, only: get_fedep - use mo_read_ndep, only: get_ndep - use mo_read_pi_ph, only: get_pi_ph,pi_ph - use mo_control_bgc, only: with_dmsph -c - implicit none -c - integer, intent(in) :: m,n,mm,nn,k1m,k1n - - integer :: l,ldtday - real :: ndep(idm,jdm) - real :: dust(idm,jdm) -c - call trc_limitc(nn) -c - call blom2hamocc(m,n,mm,nn) -c - ldtday = mod(nstep,nstep_in_day) -c - do l=1,nbgc - bgcwrt(l)=.false. - if (((diagann_bgc(l).and.nday_of_year.eq.1.or.diagmon_bgc(l) - . .and.date%day.eq.1).and.mod(nstep,nstep_in_day).eq.0).or. - . .not.(diagann_bgc(l).or.diagmon_bgc(l)).and. - . mod(nstep+.5,diagfq_bgc(l)).lt.1.) - . bgcwrt(l)=.true. - enddo -c - call get_fedep(idm,jdm,date%month,dust) - call get_ndep(idm,jdm,date%year,date%month,omask,ndep) - if(with_dmsph) call get_pi_ph(idm,jdm,date%month) -c - call hamocc4bcm(idm,jdm,kdm,nbdy, - . date%year,date%month,date%day,ldtday, - . bgc_dx,bgc_dy,bgc_dp,bgc_rho,plat,omask, - . dust,rivflx,ndep,pi_ph, - . swa,ficem,slp,abswnd, - . temp(1-nbdy,1-nbdy,1+nn),saln(1-nbdy,1-nbdy,1+nn), - . atmco2,flxco2,flxdms,atmbrf,flxbrf) - -c -c --- accumulate fields and write output -c - call accfields(idm,jdm,kdm,bgc_dx,bgc_dy,bgc_dp,omask) - - call hamocc2blom(m,n,mm,nn) -c - return - end diff --git a/hamocc/hamocc_step.F90 b/hamocc/hamocc_step.F90 new file mode 100644 index 00000000..74e12c8b --- /dev/null +++ b/hamocc/hamocc_step.F90 @@ -0,0 +1,87 @@ +! Copyright (C) 2020 K. Assmann, J. Tjiputra, J. Schwinger, M. Bentsen +! +! This file is part of BLOM/iHAMOCC. +! +! 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 https://www.gnu.org/licenses/. + + +subroutine hamocc_step(m,n,mm,nn,k1m,k1n) +! +! --- ------------------------------------------------------------------ +! --- perform one HAMOCC step +! --- ------------------------------------------------------------------ +! + use mod_xc, only: idm,jdm,kdm,nbdy + use mod_time, only: date,nday_of_year,nstep,nstep_in_day + use mod_grid, only: plat + use mod_state, only: temp,saln + use mod_forcing, only: swa,slp,abswnd,atmco2,flxco2,flxdms, & + & atmbrf,flxbrf + use mod_seaice, only: ficem + use mo_bgcmean, only: nbgc,bgcwrt, diagfq_bgc,diagmon_bgc, & + & diagann_bgc + use mo_intfcblom, only: bgc_dx,bgc_dy,bgc_dp,bgc_rho,omask, & + & blom2hamocc,hamocc2blom + use mo_read_rivin, only: rivflx + use mo_read_fedep, only: get_fedep + use mo_read_ndep, only: get_ndep + use mo_read_oafx, only: get_oafx + use mo_read_pi_ph, only: get_pi_ph,pi_ph + use mo_control_bgc, only: with_dmsph + + implicit none + + integer, intent(in) :: m,n,mm,nn,k1m,k1n + + integer :: l,ldtday + real :: ndep(idm,jdm) + real :: dust(idm,jdm) + real :: oafx(idm,jdm) + + call trc_limitc(nn) + + call blom2hamocc(m,n,mm,nn) + + ldtday = mod(nstep,nstep_in_day) + + do l=1,nbgc + bgcwrt(l)=.false. + if (((diagann_bgc(l).and.nday_of_year.eq.1.or.diagmon_bgc(l) & + & .and.date%day.eq.1).and.mod(nstep,nstep_in_day).eq.0).or. & + & .not.(diagann_bgc(l).or.diagmon_bgc(l)).and. & + & mod(nstep+.5,diagfq_bgc(l)).lt.1.) & + & bgcwrt(l)=.true. + enddo + + call get_fedep(idm,jdm,date%month,dust) + call get_ndep(idm,jdm,date%year,date%month,omask,ndep) + call get_oafx(idm,jdm,date%year,date%month,omask,oafx) + if(with_dmsph) call get_pi_ph(idm,jdm,date%month) + + call hamocc4bcm(idm,jdm,kdm,nbdy, & + & date%year,date%month,date%day,ldtday, & + & bgc_dx,bgc_dy,bgc_dp,bgc_rho,plat,omask, & + & dust,rivflx,ndep,oafx,pi_ph, & + & swa,ficem,slp,abswnd, & + & temp(1-nbdy,1-nbdy,1+nn),saln(1-nbdy,1-nbdy,1+nn), & + & atmco2,flxco2,flxdms,atmbrf,flxbrf) + + ! + ! --- accumulate fields and write output + ! + call accfields(idm,jdm,kdm,bgc_dx,bgc_dy,bgc_dp,omask) + + call hamocc2blom(m,n,mm,nn) + +end subroutine hamocc_step diff --git a/hamocc/inventory_bgc.F90 b/hamocc/inventory_bgc.F90 index 93908b95..f8b41d3a 100644 --- a/hamocc/inventory_bgc.F90 +++ b/hamocc/inventory_bgc.F90 @@ -68,7 +68,7 @@ SUBROUTINE INVENTORY_BGC(kpie,kpje,kpke,dlxp,dlyp,ddpo,omask,iogrp) use mo_sedmnt, only: porwat,seddw,sedlay,burial,sedhpl,powtra,porsol #endif #ifdef extNcycle - use mo_param1_bgc, only: ianh4,iano2,iatmnh3 + use mo_param1_bgc, only: ianh4,iano2,iatmnh3,ipownh4,ipown2o,ipowno2 use mo_bgcmean, only: jnh3flux #endif @@ -147,7 +147,7 @@ SUBROUTINE INVENTORY_BGC(kpie,kpje,kpke,dlxp,dlyp,ddpo,omask,iogrp) DO j=1,kpje DO i=1,kpie ztmp1(i,j) = ztmp1(i,j) + omask(i,j)*seddw(k) & - & *dlxp(i,j)*dlyp(i,j)*porwat(k) + & *dlxp(i,j)*dlyp(i,j)*porwat(i,j,k) ENDDO ENDDO ENDDO @@ -159,7 +159,7 @@ SUBROUTINE INVENTORY_BGC(kpie,kpje,kpke,dlxp,dlyp,ddpo,omask,iogrp) DO k=1,ks DO j=1,kpje DO i=1,kpie - vol = seddw(k)*dlxp(i,j)*dlyp(i,j)*porwat(k) + vol = seddw(k)*dlxp(i,j)*dlyp(i,j)*porwat(i,j,k) ztmp1(i,j)= ztmp1(i,j) + omask(i,j)*powtra(i,j,k,l)*vol ENDDO ENDDO @@ -178,7 +178,7 @@ SUBROUTINE INVENTORY_BGC(kpie,kpje,kpke,dlxp,dlyp,ddpo,omask,iogrp) DO k=1,ks DO j=1,kpje DO i=1,kpie - vol = porsol(k)*seddw(k)*dlxp(i,j)*dlyp(i,j) + vol = porsol(i,j,k)*seddw(k)*dlxp(i,j)*dlyp(i,j) ztmp1(i,j) = ztmp1(i,j) + omask(i,j)*sedlay(i,j,k,l)*vol ENDDO ENDDO @@ -191,7 +191,7 @@ SUBROUTINE INVENTORY_BGC(kpie,kpje,kpke,dlxp,dlyp,ddpo,omask,iogrp) DO k=1,ks DO j=1,kpje DO i=1,kpie - vol = porsol(k)*seddw(k)*dlxp(i,j)*dlyp(i,j) + vol = porsol(i,j,k)*seddw(k)*dlxp(i,j)*dlyp(i,j) ztmp1(i,j) = ztmp1(i,j) + omask(i,j)*sedhpl(i,j,k)*vol ENDDO ENDDO @@ -383,6 +383,7 @@ SUBROUTINE INVENTORY_BGC(kpie,kpje,kpke,dlxp,dlyp,ddpo,omask,iogrp) & +zprorca*rnit & #ifdef extNcycle & +zocetratot(ianh4)+zocetratot(iano2)+snh3flux & + & +zpowtratot(ipownh4)+zpowtratot(ipown2o)*2+zpowtratot(ipowno2) & #endif #if defined(BOXATM) & +zatmn2*ppm2con*2 @@ -416,6 +417,7 @@ SUBROUTINE INVENTORY_BGC(kpie,kpje,kpke,dlxp,dlyp,ddpo,omask,iogrp) & +zprorca*(-24.)+zprcaca & #ifdef extNcycle & +zocetratot(iano2) & + & +zpowtratot(ipown2o)*0.5+zpowtratot(ipowno2) & #endif #if defined(BOXATM) & +zatmo2*ppm2con+zatmco2*ppm2con @@ -696,7 +698,7 @@ subroutine write_netcdf(iogrp) use mo_param1_bgc, only: inatalkali,inatcalc,inatsco212 #endif #ifdef extNcycle - use mo_param1_bgc, only: ianh4 + use mo_param1_bgc, only: ianh4,iano2 #endif @@ -800,6 +802,7 @@ subroutine write_netcdf(iogrp) #endif #ifdef extNcycle integer :: zt_nh4_varid, zc_nh4_varid ! Ammonium (NH4+) + integer :: zt_ano2_varid, zc_ano2_varid ! Nitrite (NO2-) #endif !--- sum of inventory integer :: totcarb_varid, totphos_varid, totsili_varid, totnitr_varid @@ -1451,9 +1454,20 @@ subroutine write_netcdf(iogrp) call nccheck( NF90_PUT_ATT(ncid, zc_nh4_varid, 'long_name', & & 'Mean ammonium concentration') ) call nccheck( NF90_PUT_ATT(ncid, zc_nh4_varid, 'units', 'kmol/m^3') ) + + call nccheck( NF90_DEF_VAR(ncid, 'zt_ano2', NF90_DOUBLE, & + & time_dimid, zt_ano2_varid) ) + call nccheck( NF90_PUT_ATT(ncid, zt_ano2_varid, 'long_name', & + & 'Total nitrite tracer') ) + call nccheck( NF90_PUT_ATT(ncid, zt_ano2_varid, 'units', 'kmol') ) + + call nccheck( NF90_DEF_VAR(ncid, 'zc_ano2', NF90_DOUBLE, & + & time_dimid, zc_ano2_varid) ) + call nccheck( NF90_PUT_ATT(ncid, zc_ano2_varid, 'long_name', & + & 'Mean nitrite concentration') ) + call nccheck( NF90_PUT_ATT(ncid, zc_ano2_varid, 'units', 'kmol/m^3') ) #endif - !--- Define variables : sum of inventory call nccheck( NF90_DEF_VAR(ncid, 'totcarb', NF90_DOUBLE, time_dimid, & & totcarb_varid) ) @@ -1649,6 +1663,8 @@ subroutine write_netcdf(iogrp) #ifdef extNcycle call nccheck( NF90_INQ_VARID(ncid, "zt_nh4", zt_nh4_varid) ) call nccheck( NF90_INQ_VARID(ncid, "zc_nh4", zc_nh4_varid) ) + call nccheck( NF90_INQ_VARID(ncid, "zt_ano2", zt_ano2_varid) ) + call nccheck( NF90_INQ_VARID(ncid, "zc_ano2", zc_ano2_varid) ) #endif !--- Inquire varid : sum of inventory call nccheck( NF90_INQ_VARID(ncid, "totcarb", totcarb_varid) ) @@ -1880,10 +1896,14 @@ subroutine write_netcdf(iogrp) & zocetratoc(ibromo), start = wrstart) ) #endif #ifdef extNcycle - call nccheck( NF90_PUT_VAR(ncid, zt_nh4_varid, & + call nccheck( NF90_PUT_VAR(ncid, zt_nh4_varid, & & zocetratot(ianh4), start = wrstart) ) - call nccheck( NF90_PUT_VAR(ncid, zc_nh4_varid, & + call nccheck( NF90_PUT_VAR(ncid, zc_nh4_varid, & & zocetratoc(ianh4), start = wrstart) ) + call nccheck( NF90_PUT_VAR(ncid, zt_ano2_varid, & + & zocetratot(iano2), start = wrstart) ) + call nccheck( NF90_PUT_VAR(ncid, zc_ano2_varid, & + & zocetratoc(iano2), start = wrstart) ) #endif !--- Write data : sum of inventory call nccheck( NF90_PUT_VAR(ncid, totcarb_varid, totalcarbon, & diff --git a/hamocc/meson.build b/hamocc/meson.build index 60b4b817..286f0d41 100644 --- a/hamocc/meson.build +++ b/hamocc/meson.build @@ -4,7 +4,6 @@ sources += files( 'aufw_bgc.F90', 'beleg_parm.F90', 'beleg_vars.F90', - 'bodensed.F90', 'carchm.F90', 'carchm_kequi.F90', 'carchm_solve.F90', @@ -13,13 +12,14 @@ sources += files( 'dipowa.F90', 'get_cfc.F90', 'hamocc4bcm.F90', - 'hamocc_init.F', - 'hamocc_step.F', + 'hamocc_init.F90', + 'hamocc_step.F90', 'inventory_bgc.F90', 'mo_Gdata_read.F90', 'mo_apply_fedep.F90', 'mo_apply_ndep.F90', 'mo_apply_rivin.F90', + 'mo_apply_oafx.F90', 'mo_bgcmean.F90', 'mo_biomod.F90', 'mo_carbch.F90', @@ -32,9 +32,11 @@ sources += files( 'mo_read_ndep.F90', 'mo_read_pi_ph.F90', 'mo_read_rivin.F90', + 'mo_read_oafx.F90', + 'mo_read_sedpor.F90', 'mo_sedmnt.F90', 'mo_vgrid.F90', - 'ncout_hamocc.F', + 'ncout_hamocc.F90', 'netcdf_def_vardb.F90', 'ocprod.F90', 'powach.F90', @@ -42,8 +44,10 @@ sources += files( 'preftrc.F90', 'profile_gd.F90', 'read_netcdf_var.F90', - 'restart_hamoccwt.F', + 'restart_hamoccwt.F90', 'sedshi.F90', - 'trc_limitc.F', + 'trc_limitc.F90', 'write_netcdf_var.F90', - 'mo_extNbioproc.F90') + 'mo_extNbioproc.F90', + 'mo_extNsediment.F90', + 'mo_m4ago.F90') diff --git a/hamocc/mo_apply_ndep.F90 b/hamocc/mo_apply_ndep.F90 index cd16ac47..36d7159b 100644 --- a/hamocc/mo_apply_ndep.F90 +++ b/hamocc/mo_apply_ndep.F90 @@ -45,7 +45,7 @@ module mo_apply_ndep ! N deposition is activated through a logical switch 'do_ndep' read from ! HAMOCC's bgcnml namelist. ! -! -subroutine n_deposition +! -subroutine apply_ndep ! Apply n-deposition to the top-most model layer. ! ! diff --git a/hamocc/mo_apply_oafx.F90 b/hamocc/mo_apply_oafx.F90 new file mode 100644 index 00000000..16d89b6f --- /dev/null +++ b/hamocc/mo_apply_oafx.F90 @@ -0,0 +1,102 @@ +! Copyright (C) 2021 J. Schwinger +! +! This file is part of BLOM/iHAMOCC. +! +! 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 https://www.gnu.org/licenses/. + + +module mo_apply_oafx +!****************************************************************************** +! +! J.Schwinger *NORCE Climate, Bergen* 2021-11-15 +! +! Modified +! -------- +! +! Purpose +! ------- +! -Routines for applying ocean alkalinization +! +! +! Description: +! ------------ +! +! -subroutine alkalinization +! Apply alkalinization to the top-most model layer. +! +! +!****************************************************************************** + implicit none + + private + public :: apply_oafx + +!****************************************************************************** +contains + + + +subroutine apply_oafx(kpie,kpje,kpke,pddpo,omask,oafx) +!****************************************************************************** +! +! J. Schwinger *NORCE Climate, Bergen* 2021-11-15 +! +! Purpose +! ------- +! -apply alkalinization to the top-most model layer. +! +! Changes: +! -------- +! +! +! Parameter list: +! --------------- +! *INTEGER* *kpie* - 1st dimension of model grid. +! *INTEGER* *kpje* - 2nd dimension of model grid. +! *REAL* *pddpo* - size of grid cell (depth) [m]. +! *REAL* *omask* - land/ocean mask (1=ocean) +! *REAL* *oafx* - alkalinization field to apply [kmol m-2 yr-1] +! +!****************************************************************************** + use mo_control_bgc, only: dtb,do_oalk + use mo_carbch, only: ocetra + use mo_param1_bgc, only: ialkali + + implicit none + + integer, intent(in) :: kpie,kpje,kpke + real, intent(in) :: pddpo(kpie,kpje,kpke) + real, intent(in) :: omask(kpie,kpje) + real, intent(in) :: oafx(kpie,kpje) + + ! local variables + integer :: i,j + + if (.not. do_oalk) return + + ! alkalinization in topmost layer + do j=1,kpje + do i=1,kpie + if (omask(i,j).gt.0.5) then + ocetra(i,j,1,ialkali)=ocetra(i,j,1,ialkali)+oafx(i,j)*dtb/365./pddpo(i,j,1) + endif + enddo + enddo + +!****************************************************************************** +end subroutine apply_oafx + + +!****************************************************************************** +end module mo_apply_oafx diff --git a/hamocc/mo_apply_rivin.F90 b/hamocc/mo_apply_rivin.F90 index 697990d1..0dfbc528 100644 --- a/hamocc/mo_apply_rivin.F90 +++ b/hamocc/mo_apply_rivin.F90 @@ -120,28 +120,28 @@ subroutine apply_rivin(kpie,kpje,kpke,pddpo,omask,rivin) ! Distribute riverine inputs over the model mixed layer volij = 0. - DO k=1,kmle + DO k=1,kmle(i,j) volij=volij+pddpo(i,j,k) ENDDO ! DIC is updated using the assumtions that a_t=a_c+a_n and DIC=a_c (a_t: total ! alkalinity, a_c: carbonate alkalinity, a_n: contribution of nutrients to a_t). - ocetra(i,j,1:kmle,iano3) = ocetra(i,j,1:kmle,iano3) + rivin(i,j,irdin)*fdt/volij - ocetra(i,j,1:kmle,iphosph) = ocetra(i,j,1:kmle,iphosph) + rivin(i,j,irdip)*fdt/volij - ocetra(i,j,1:kmle,isilica) = ocetra(i,j,1:kmle,isilica) + rivin(i,j,irsi) *fdt/volij - ocetra(i,j,1:kmle,isco212) = ocetra(i,j,1:kmle,isco212) + rivin(i,j,iralk)*fdt/volij & + ocetra(i,j,1:kmle(i,j),iano3) = ocetra(i,j,1:kmle(i,j),iano3) + rivin(i,j,irdin)*fdt/volij + ocetra(i,j,1:kmle(i,j),iphosph) = ocetra(i,j,1:kmle(i,j),iphosph) + rivin(i,j,irdip)*fdt/volij + ocetra(i,j,1:kmle(i,j),isilica) = ocetra(i,j,1:kmle(i,j),isilica) + rivin(i,j,irsi) *fdt/volij + ocetra(i,j,1:kmle(i,j),isco212) = ocetra(i,j,1:kmle(i,j),isco212) + rivin(i,j,iralk)*fdt/volij & + rivin(i,j,irdin)*fdt/volij & + rivin(i,j,irdip)*fdt/volij - ocetra(i,j,1:kmle,ialkali) = ocetra(i,j,1:kmle,ialkali) + rivin(i,j,iralk)*fdt/volij + ocetra(i,j,1:kmle(i,j),ialkali) = ocetra(i,j,1:kmle(i,j),ialkali) + rivin(i,j,iralk)*fdt/volij #ifdef natDIC - ocetra(i,j,1:kmle,inatsco212) = ocetra(i,j,1:kmle,inatsco212) + rivin(i,j,iralk)*fdt/volij & + ocetra(i,j,1:kmle(i,j),inatsco212) = ocetra(i,j,1:kmle(i,j),inatsco212) + rivin(i,j,iralk)*fdt/volij & + rivin(i,j,irdin)*fdt/volij & + rivin(i,j,irdip)*fdt/volij - ocetra(i,j,1:kmle,inatalkali) = ocetra(i,j,1:kmle,inatalkali) + rivin(i,j,iralk)*fdt/volij + ocetra(i,j,1:kmle(i,j),inatalkali) = ocetra(i,j,1:kmle(i,j),inatalkali) + rivin(i,j,iralk)*fdt/volij #endif - ocetra(i,j,1:kmle,iiron) = ocetra(i,j,1:kmle,iiron) + rivin(i,j,iriron)*fdt/volij*dFe_frac - ocetra(i,j,1:kmle,idoc) = ocetra(i,j,1:kmle,idoc) + rivin(i,j,irdoc)*fdt/volij - ocetra(i,j,1:kmle,idet) = ocetra(i,j,1:kmle,idet) + rivin(i,j,irdet)*fdt/volij + ocetra(i,j,1:kmle(i,j),iiron) = ocetra(i,j,1:kmle(i,j),iiron) + rivin(i,j,iriron)*fdt/volij*dFe_frac + ocetra(i,j,1:kmle(i,j),idoc) = ocetra(i,j,1:kmle(i,j),idoc) + rivin(i,j,irdoc)*fdt/volij + ocetra(i,j,1:kmle(i,j),idet) = ocetra(i,j,1:kmle(i,j),idet) + rivin(i,j,irdet)*fdt/volij rivinflx(i,j,irdin) = rivin(i,j,irdin)*fdt rivinflx(i,j,irdip) = rivin(i,j,irdip)*fdt diff --git a/hamocc/mo_bgcmean.F90 b/hamocc/mo_bgcmean.F90 index c252676c..32918abd 100644 --- a/hamocc/mo_bgcmean.F90 +++ b/hamocc/mo_bgcmean.F90 @@ -55,10 +55,9 @@ MODULE mo_bgcmean !********************************************************************** use mod_xc, only: ii,jj,kk,idm,jdm,kdm,nbdy,ifp,isp,ilp,mnproc,ip use mod_dia, only: ddm,depthslev,depthslev_bnds,nstepinday,pbath - use mod_nctools, only:ncpack,nccomp,nccopa,ncwrtr + use mod_nctools, only: ncpack,nccomp,nccopa,ncwrtr use netcdf, only: nf90_fill_double use mo_param1_bgc, only: ks - use mo_control_bgc, only: get_bgc_namelist IMPLICIT NONE @@ -76,6 +75,8 @@ MODULE mo_bgcmean ! --- Namelist for diagnostic output INTEGER, DIMENSION(nbgcmax), SAVE :: & & SRF_KWCO2 =0 ,SRF_PCO2 =0 ,SRF_DMSFLUX =0 , & + & SRF_KWCO2KHM =0 ,SRF_CO2KHM =0 ,SRF_CO2KH =0 , & + & SRF_PCO2M =0 , & & SRF_CO2FXD =0 ,SRF_CO2FXU =0 ,SRF_CO213FXD =0 , & & SRF_CO213FXU =0 ,SRF_CO214FXD =0 ,SRF_CO214FXU =0 , & & SRF_OXFLUX =0 ,SRF_NIFLUX =0 ,SRF_DMS =0 , & @@ -87,10 +88,12 @@ MODULE mo_bgcmean & SRF_SF6 =0 ,SRF_PHOSPH =0 ,SRF_OXYGEN =0 , & & SRF_IRON =0 ,SRF_ANO3 =0 ,SRF_ALKALI =0 , & & SRF_SILICA =0 ,SRF_DIC =0 ,SRF_PHYTO =0 , & + & SRF_PH =0 , & & SRF_NATDIC =0 ,SRF_NATALKALI =0 ,SRF_NATPCO2 =0 , & - & SRF_NATCO2FX =0 , & + & SRF_NATCO2FX =0 ,SRF_NATPH =0 , & & SRF_ATMBROMO =0 ,SRF_BROMO =0 ,SRF_BROMOFX =0 , & & SRF_ANH4 =0 ,SRF_ANO2 =0 ,SRF_ANH3FX =0 , & + & SRF_PN2OM =0 ,SRF_PNH3 =0 , & & INT_BROMOPRO =0 ,INT_BROMOUV =0 , & & INT_PHOSY =0 ,INT_NFIX =0 ,INT_DNIT =0 , & & FLX_CAR0100 =0 ,FLX_CAR0500 =0 ,FLX_CAR1000 =0 , & @@ -101,7 +104,10 @@ MODULE mo_bgcmean & FLX_CAL2000 =0 ,FLX_CAL4000 =0 ,FLX_CAL_BOT =0 , & & FLX_SEDIFFIC =0 ,FLX_SEDIFFAL =0 ,FLX_SEDIFFPH =0 , & & FLX_SEDIFFOX =0 ,FLX_SEDIFFN2 =0 ,FLX_SEDIFFNO3 =0 , & - & FLX_SEDIFFSI =0 , & + & FLX_SEDIFFSI =0 ,FLX_SEDIFFNH4 =0 ,FLX_SEDIFFN2O =0 , & + & FLX_SEDIFFNO2 =0 , & + & FLX_BURSSO12 =0 ,FLX_BURSSSC12 =0 ,FLX_BURSSSSIL =0 , & + & FLX_BURSSSTER =0 , & & LYR_PHYTO =0 ,LYR_GRAZER =0 ,LYR_DOC =0 , & & LYR_PHOSY =0 ,LYR_PHOSPH =0 ,LYR_OXYGEN =0 , & & LYR_IRON =0 ,LYR_ANO3 =0 ,LYR_ALKALI =0 , & @@ -127,7 +133,13 @@ MODULE mo_bgcmean & LYR_nitr_NH4_OM =0 ,LYR_nitr_NO2_OM =0 ,LYR_denit_NO3 =0, & & LYR_denit_NO2 = 0 ,LYR_denit_N2O = 0 ,LYR_DNRA_NO2 =0, & & LYR_anmx_N2_prod=0 ,LYR_anmx_OM_prod=0 ,LYR_phosy_NH4 =0, & - & LYR_phosy_NO3 = 0 ,LYR_remin_aerob =0 ,LYR_remin_sulf =0, & + & LYR_phosy_NO3 = 0 ,LYR_remin_aerob =0 ,LYR_remin_sulf =0, & + ! M4AGO LYR + & LYR_agg_ws =0 ,LYR_dynvis =0 ,LYR_agg_stick =0 , & + & LYR_agg_stickf=0 ,LYR_agg_dmax =0 ,LYR_agg_avdp =0 , & + & LYR_agg_avrhop=0 ,LYR_agg_avdC =0 ,LYR_agg_df =0 , & + & LYR_agg_b =0 ,LYR_agg_Vrhof =0 ,LYR_agg_Vpor =0 , & + !========== LVLs & LVL_PHYTO =0 ,LVL_GRAZER =0 ,LVL_DOC =0 , & & LVL_PHOSY =0 ,LVL_PHOSPH =0 ,LVL_OXYGEN =0 , & & LVL_IRON =0 ,LVL_ANO3 =0 ,LVL_ALKALI =0 , & @@ -154,10 +166,22 @@ MODULE mo_bgcmean & LVL_denit_NO2 = 0 ,LVL_denit_N2O = 0 ,LVL_DNRA_NO2 =0, & & LVL_anmx_N2_prod=0 ,LVL_anmx_OM_prod=0 ,LVL_phosy_NH4 =0, & & LVL_phosy_NO3 = 0 ,LVL_remin_aerob =0 ,LVL_remin_sulf =0, & + ! M4AGO LVL + & LVL_agg_ws =0 ,LVL_dynvis =0 ,LVL_agg_stick =0 , & + & LVL_agg_stickf=0 ,LVL_agg_dmax =0 ,LVL_agg_avdp =0 , & + & LVL_agg_avrhop=0 ,LVL_agg_avdC =0 ,LVL_agg_df =0 , & + & LVL_agg_b =0 ,LVL_agg_Vrhof =0 ,LVL_agg_Vpor =0 , & & SDM_POWAIC =0 ,SDM_POWAAL =0 ,SDM_POWAPH =0 , & & SDM_POWAOX =0 ,SDM_POWN2 =0 ,SDM_POWNO3 =0 , & & SDM_POWASI =0 ,SDM_SSSO12 =0 ,SDM_SSSSIL =0 , & & SDM_SSSC12 =0 ,SDM_SSSTER =0 , & + !extNcycle + & SDM_POWNH4 =0 ,SDM_POWN2O =0 ,SDM_POWNO2 =0 , & + & SDM_nitr_NH4 =0 ,SDM_nitr_NO2 =0 ,SDM_nitr_N2O_prod =0, & + & SDM_nitr_NH4_OM =0 ,SDM_nitr_NO2_OM =0 ,SDM_denit_NO3 =0, & + & SDM_denit_NO2 = 0 ,SDM_denit_N2O = 0 ,SDM_DNRA_NO2 =0, & + & SDM_anmx_N2_prod=0 ,SDM_anmx_OM_prod=0 ,SDM_remin_aerob =0 , & + & SDM_remin_sulf =0 , & & BUR_SSSO12 =0 ,BUR_SSSC12 =0 ,BUR_SSSSIL =0 , & & BUR_SSSTER =0 , & & GLB_AVEPERIO =0 ,GLB_FILEFREQ =0 ,GLB_COMPFLAG =0 , & @@ -165,6 +189,8 @@ MODULE mo_bgcmean CHARACTER(LEN=10), DIMENSION(nbgcmax), SAVE :: GLB_FNAMETAG namelist /DIABGC/ & & SRF_KWCO2 ,SRF_PCO2 ,SRF_DMSFLUX , & + & SRF_KWCO2KHM ,SRF_CO2KHM ,SRF_CO2KH , & + & SRF_PCO2M , & & SRF_CO2FXD ,SRF_CO2FXU ,SRF_CO213FXD , & & SRF_CO213FXU ,SRF_CO214FXD ,SRF_CO214FXU , & & SRF_OXFLUX ,SRF_NIFLUX ,SRF_DMS , & @@ -176,10 +202,12 @@ MODULE mo_bgcmean & SRF_SF6 ,SRF_PHOSPH ,SRF_OXYGEN , & & SRF_IRON ,SRF_ANO3 ,SRF_ALKALI , & & SRF_SILICA ,SRF_DIC ,SRF_PHYTO , & + & SRF_PH , & & SRF_NATDIC ,SRF_NATALKALI ,SRF_NATPCO2 , & - & SRF_NATCO2FX , & + & SRF_NATCO2FX ,SRF_NATPH , & & SRF_ATMBROMO ,SRF_BROMO ,SRF_BROMOFX , & & SRF_ANH4 ,SRF_ANO2 ,SRF_ANH3FX , & + & SRF_PN2OM ,SRF_PNH3 , & & INT_BROMOPRO ,INT_BROMOUV , & & INT_PHOSY ,INT_NFIX ,INT_DNIT , & & FLX_CAR0100 ,FLX_CAR0500 ,FLX_CAR1000 , & @@ -190,7 +218,10 @@ MODULE mo_bgcmean & FLX_CAL2000 ,FLX_CAL4000 ,FLX_CAL_BOT , & & FLX_SEDIFFIC ,FLX_SEDIFFAL ,FLX_SEDIFFPH , & & FLX_SEDIFFOX ,FLX_SEDIFFN2 ,FLX_SEDIFFNO3 , & - & FLX_SEDIFFSI , & + & FLX_SEDIFFSI ,FLX_SEDIFFNH4 ,FLX_SEDIFFN2O , & + & FLX_SEDIFFNO2 , & + & FLX_BURSSO12 ,FLX_BURSSSC12 ,FLX_BURSSSSIL , & + & FLX_BURSSSTER , & & LYR_PHYTO ,LYR_GRAZER ,LYR_DOC , & & LYR_PHOSY ,LYR_PHOSPH ,LYR_OXYGEN , & & LYR_IRON ,LYR_ANO3 ,LYR_ALKALI , & @@ -216,6 +247,10 @@ MODULE mo_bgcmean & LYR_denit_NO2 ,LYR_denit_N2O ,LYR_DNRA_NO2 , & & LYR_anmx_N2_prod ,LYR_anmx_OM_prod ,LYR_phosy_NH4 , & & LYR_phosy_NO3 ,LYR_remin_aerob ,LYR_remin_sulf , & + & LYR_agg_ws ,LYR_dynvis ,LYR_agg_stick , & + & LYR_agg_stickf ,LYR_agg_dmax ,LYR_agg_avdp , & + & LYR_agg_avrhop ,LYR_agg_avdC ,LYR_agg_df , & + & LYR_agg_b ,LYR_agg_Vrhof ,LYR_agg_Vpor , & & LVL_PHYTO ,LVL_GRAZER ,LVL_DOC , & & LVL_PHOSY ,LVL_PHOSPH ,LVL_OXYGEN , & & LVL_IRON ,LVL_ANO3 ,LVL_ALKALI , & @@ -241,10 +276,20 @@ MODULE mo_bgcmean & LVL_denit_NO2 ,LVL_denit_N2O ,LVL_DNRA_NO2 , & & LVL_anmx_N2_prod ,LVL_anmx_OM_prod ,LVL_phosy_NH4 , & & LVL_phosy_NO3 ,LVL_remin_aerob ,LVL_remin_sulf , & + & LVL_agg_ws ,LVL_dynvis ,LVL_agg_stick , & + & LVL_agg_stickf ,LVL_agg_dmax ,LVL_agg_avdp , & + & LVL_agg_avrhop ,LVL_agg_avdC ,LVL_agg_df , & + & LVL_agg_b ,LVL_agg_Vrhof ,LVL_agg_Vpor , & & SDM_POWAIC ,SDM_POWAAL ,SDM_POWAPH , & & SDM_POWAOX ,SDM_POWN2 ,SDM_POWNO3 , & & SDM_POWASI ,SDM_SSSO12 ,SDM_SSSSIL , & & SDM_SSSC12 ,SDM_SSSTER , & + & SDM_POWNH4 ,SDM_POWN2O ,SDM_POWNO2 , & + & SDM_nitr_NH4 ,SDM_nitr_NO2 ,SDM_nitr_N2O_prod , & + & SDM_nitr_NH4_OM ,SDM_nitr_NO2_OM ,SDM_denit_NO3 , & + & SDM_denit_NO2 ,SDM_denit_N2O ,SDM_DNRA_NO2 , & + & SDM_anmx_N2_prod ,SDM_anmx_OM_prod ,SDM_remin_aerob , & + & SDM_remin_sulf , & & BUR_SSSO12 ,BUR_SSSC12 ,BUR_SSSSIL , & & BUR_SSSTER , & & GLB_AVEPERIO ,GLB_FILEFREQ ,GLB_COMPFLAG , & @@ -284,7 +329,11 @@ MODULE mo_bgcmean INTEGER, SAVE :: i_bsc_m2d INTEGER, DIMENSION(nbgcmax), SAVE :: & & jkwco2 = 0 , & + & jkwco2khm = 0 , & + & jco2kh = 0 , & + & jco2khm = 0 , & & jpco2 = 0 , & + & jpco2m = 0 , & & jdmsflux = 0 , & & jco2fxd = 0 , & & jco2fxu = 0 , & @@ -313,6 +362,7 @@ MODULE mo_bgcmean & jsrfsilica = 0 , & & jsrfdic = 0 , & & jsrfphyto = 0 , & + & jsrfph = 0 , & & jintphosy = 0 , & & jintnfix = 0 , & & jintdnit = 0 , & @@ -342,13 +392,21 @@ MODULE mo_bgcmean & jsediffox = 0 , & & jsediffn2 = 0 , & & jsediffno3 = 0 , & - jsediffsi = 0 + & jsediffsi = 0 , & + & jsediffnh4 = 0 , & + & jsediffn2o = 0 , & + & jsediffno2 = 0 , & + & jburflxsso12 = 0 , & + & jburflxsssc12 = 0 , & + & jburflxssssil = 0 , & + & jburflxssster = 0 INTEGER, DIMENSION(nbgcmax), SAVE :: & & jsrfnatdic = 0 , & & jsrfnatalk = 0 , & & jnatpco2 = 0 , & - & jnatco2fx = 0 + & jnatco2fx = 0 , & + & jsrfnatph = 0 INTEGER, DIMENSION(nbgcmax), SAVE :: & & jbromofx = 0 , & @@ -359,7 +417,9 @@ MODULE mo_bgcmean INTEGER, DIMENSION(nbgcmax), SAVE :: & & janh3fx = 0 , & & jsrfanh4 = 0 , & - & jsrfano2 + & jsrfano2 = 0 , & + & jsrfpn2om = 0 , & + & jsrfpnh3 = 0 INTEGER, SAVE :: i_atm_m2d INTEGER, DIMENSION(nbgcmax), SAVE :: & @@ -506,7 +566,19 @@ MODULE mo_bgcmean & jphosy_NH4 = 0 , & & jphosy_NO3 = 0 , & & jremin_aerob = 0 , & - & jremin_sulf = 0, & + & jremin_sulf = 0 , & + & jagg_ws = 0 , & + & jdynvis = 0 , & + & jagg_stick = 0 , & + & jagg_stickf = 0 , & + & jagg_dmax = 0 , & + & jagg_avdp = 0 , & + & jagg_avrhop = 0 , & + & jagg_avdC = 0 , & + & jagg_df = 0 , & + & jagg_b = 0 , & + & jagg_Vrhof = 0 , & + & jagg_Vpor = 0 , & & jlvlanh4 = 0 , & & jlvlano2 = 0 , & & jlvl_nitr_NH4 = 0 , & @@ -523,8 +595,19 @@ MODULE mo_bgcmean & jlvl_phosy_NH4 = 0 , & & jlvl_phosy_NO3 = 0 , & & jlvl_remin_aerob = 0 , & - & jlvl_remin_sulf = 0 - + & jlvl_remin_sulf = 0 , & + & jlvl_agg_ws = 0 , & + & jlvl_dynvis = 0 , & + & jlvl_agg_stick = 0 , & + & jlvl_agg_stickf = 0 , & + & jlvl_agg_dmax = 0 , & + & jlvl_agg_avdp = 0 , & + & jlvl_agg_avrhop = 0 , & + & jlvl_agg_avdC = 0 , & + & jlvl_agg_df = 0 , & + & jlvl_agg_b = 0 , & + & jlvl_agg_Vrhof = 0 , & + & jlvl_agg_Vpor = 0 INTEGER, SAVE :: nbgcm3d,nbgcm3dlvl !---------------------------------------------------------------- @@ -541,7 +624,23 @@ MODULE mo_bgcmean & jssso12 = 0 , & & jssssil = 0 , & & jsssc12 = 0 , & - & jssster = 0 + & jssster = 0 , & + & jpownh4 = 0 , & + & jpown2o = 0 , & + & jpowno2 = 0 , & + & jsdm_nitr_NH4 = 0 , & + & jsdm_nitr_NO2 = 0 , & + & jsdm_nitr_N2O_prod = 0 , & + & jsdm_nitr_NH4_OM = 0 , & + & jsdm_nitr_NO2_OM = 0 , & + & jsdm_denit_NO3 = 0 , & + & jsdm_denit_NO2 = 0 , & + & jsdm_denit_N2O = 0 , & + & jsdm_DNRA_NO2 = 0 , & + & jsdm_anmx_N2_prod = 0 , & + & jsdm_anmx_OM_prod = 0 , & + & jsdm_remin_aerob = 0 , & + & jsdm_remin_sulf = 0 INTEGER, SAVE :: nbgct_sed @@ -572,7 +671,7 @@ MODULE mo_bgcmean SUBROUTINE ALLOC_MEM_BGCMEAN(kpie,kpje,kpke) - use mo_control_bgc, only: io_stdo_bgc,bgc_namelist + use mo_control_bgc, only: io_stdo_bgc,bgc_namelist,get_bgc_namelist IMPLICIT NONE @@ -630,8 +729,16 @@ SUBROUTINE ALLOC_MEM_BGCMEAN(kpie,kpje,kpke) DO n=1,nbgc IF (SRF_KWCO2(n).GT.0) i_bsc_m2d=i_bsc_m2d+1 jkwco2(n)=i_bsc_m2d*min(1,SRF_KWCO2(n)) + IF (SRF_KWCO2KHM(n).GT.0) i_bsc_m2d=i_bsc_m2d+1 + jkwco2khm(n)=i_bsc_m2d*min(1,SRF_KWCO2KHM(n)) + IF (SRF_CO2KH(n).GT.0) i_bsc_m2d=i_bsc_m2d+1 + jco2kh(n)=i_bsc_m2d*min(1,SRF_CO2KH(n)) + IF (SRF_CO2KHM(n).GT.0) i_bsc_m2d=i_bsc_m2d+1 + jco2khm(n)=i_bsc_m2d*min(1,SRF_CO2KHM(n)) IF (SRF_PCO2(n).GT.0) i_bsc_m2d=i_bsc_m2d+1 jpco2(n)=i_bsc_m2d*min(1,SRF_PCO2(n)) + IF (SRF_PCO2M(n).GT.0) i_bsc_m2d=i_bsc_m2d+1 + jpco2m(n)=i_bsc_m2d*min(1,SRF_PCO2M(n)) IF (SRF_DMSFLUX(n).GT.0) i_bsc_m2d=i_bsc_m2d+1 jdmsflux(n)=i_bsc_m2d*min(1,SRF_DMSFLUX(n)) IF (SRF_CO2FXD(n).GT.0) i_bsc_m2d=i_bsc_m2d+1 @@ -658,6 +765,8 @@ SUBROUTINE ALLOC_MEM_BGCMEAN(kpie,kpje,kpke) jexposi(n)=i_bsc_m2d*min(1,SRF_EXPOSI(n)) IF (SRF_N2OFX(n).GT.0) i_bsc_m2d=i_bsc_m2d+1 jn2ofx(n)=i_bsc_m2d*min(1,SRF_N2OFX(n)) + IF (SRF_PN2OM(n).GT.0) i_bsc_m2d=i_bsc_m2d+1 + jsrfpn2om(n)=i_bsc_m2d*min(1,SRF_PN2OM(n)) IF (SRF_PHOSPH(n).GT.0) i_bsc_m2d=i_bsc_m2d+1 jsrfphosph(n)=i_bsc_m2d*min(1,SRF_PHOSPH(n)) IF (SRF_OXYGEN(n).GT.0) i_bsc_m2d=i_bsc_m2d+1 @@ -674,6 +783,8 @@ SUBROUTINE ALLOC_MEM_BGCMEAN(kpie,kpje,kpke) jsrfdic(n)=i_bsc_m2d*min(1,SRF_DIC(n)) IF (SRF_PHYTO(n).GT.0) i_bsc_m2d=i_bsc_m2d+1 jsrfphyto(n)=i_bsc_m2d*min(1,SRF_PHYTO(n)) + IF (SRF_PH(n).GT.0) i_bsc_m2d=i_bsc_m2d+1 + jsrfph(n)=i_bsc_m2d*min(1,SRF_PH(n)) IF (INT_PHOSY(n).GT.0) i_bsc_m2d=i_bsc_m2d+1 jintphosy(n)=i_bsc_m2d*min(1,INT_PHOSY(n)) IF (INT_NFIX(n).GT.0) i_bsc_m2d=i_bsc_m2d+1 @@ -731,6 +842,22 @@ SUBROUTINE ALLOC_MEM_BGCMEAN(kpie,kpje,kpke) jsediffno3(n)=i_bsc_m2d*min(1,FLX_SEDIFFNO3(n)) IF (FLX_SEDIFFSI(n).GT.0) i_bsc_m2d=i_bsc_m2d+1 jsediffsi(n)=i_bsc_m2d*min(1,FLX_SEDIFFSI(n)) + IF (FLX_BURSSO12(n).GT.0) i_bsc_m2d=i_bsc_m2d+1 + jburflxsso12(n)=i_bsc_m2d*min(1,FLX_BURSSO12(n)) + IF (FLX_BURSSSC12(n).GT.0) i_bsc_m2d=i_bsc_m2d+1 + jburflxsssc12(n)=i_bsc_m2d*min(1,FLX_BURSSSC12(n)) + IF (FLX_BURSSSSIL(n).GT.0) i_bsc_m2d=i_bsc_m2d+1 + jburflxssssil(n)=i_bsc_m2d*min(1,FLX_BURSSSSIL(n)) + IF (FLX_BURSSSTER(n).GT.0) i_bsc_m2d=i_bsc_m2d+1 + jburflxssster(n)=i_bsc_m2d*min(1,FLX_BURSSSTER(n)) +#endif +#if defined (extNcycle) && ! defined(sedbypass) + IF (FLX_SEDIFFNH4(n).GT.0) i_bsc_m2d=i_bsc_m2d+1 + jsediffnh4(n)=i_bsc_m2d*min(1,FLX_SEDIFFNH4(n)) + IF (FLX_SEDIFFN2O(n).GT.0) i_bsc_m2d=i_bsc_m2d+1 + jsediffn2o(n)=i_bsc_m2d*min(1,FLX_SEDIFFN2O(n)) + IF (FLX_SEDIFFNO2(n).GT.0) i_bsc_m2d=i_bsc_m2d+1 + jsediffno2(n)=i_bsc_m2d*min(1,FLX_SEDIFFNO2(n)) #endif #ifdef cisonew IF (SRF_CO213FXD(n).GT.0) i_bsc_m2d=i_bsc_m2d+1 @@ -759,6 +886,8 @@ SUBROUTINE ALLOC_MEM_BGCMEAN(kpie,kpje,kpke) jnatpco2(n)=i_bsc_m2d*min(1,SRF_NATPCO2(n)) IF (SRF_NATCO2FX(n).GT.0) i_bsc_m2d=i_bsc_m2d+1 jnatco2fx(n)=i_bsc_m2d*min(1,SRF_NATCO2FX(n)) + IF (SRF_NATPH(n).GT.0) i_bsc_m2d=i_bsc_m2d+1 + jsrfnatph(n)=i_bsc_m2d*min(1,SRF_NATPH(n)) #endif #ifdef BROMO IF (SRF_BROMO(n).GT.0) i_bsc_m2d=i_bsc_m2d+1 @@ -773,6 +902,8 @@ SUBROUTINE ALLOC_MEM_BGCMEAN(kpie,kpje,kpke) #ifdef extNcycle IF (SRF_ANH3FX(n).GT.0) i_bsc_m2d=i_bsc_m2d+1 janh3fx(n)=i_bsc_m2d*min(1,SRF_ANH3FX(n)) + IF (SRF_PNH3(n).GT.0) i_bsc_m2d=i_bsc_m2d+1 + jsrfpnh3(n)=i_bsc_m2d*min(1,SRF_PNH3(n)) IF (SRF_ANH4(n).GT.0) i_bsc_m2d=i_bsc_m2d+1 jsrfanh4(n)=i_bsc_m2d*min(1,SRF_ANH4(n)) IF (SRF_ANO2(n).GT.0) i_bsc_m2d=i_bsc_m2d+1 @@ -966,6 +1097,32 @@ SUBROUTINE ALLOC_MEM_BGCMEAN(kpie,kpje,kpke) IF (LYR_remin_sulf(n).GT.0) i_bsc_m3d=i_bsc_m3d+1 jremin_sulf(n)=i_bsc_m3d*min(1,LYR_remin_sulf(n)) #endif + ! M4AGO + IF (LYR_agg_ws(n).GT.0) i_bsc_m3d=i_bsc_m3d+1 + jagg_ws(n)=i_bsc_m3d*min(1,LYR_agg_ws(n)) + IF (LYR_dynvis(n).GT.0) i_bsc_m3d=i_bsc_m3d+1 + jdynvis(n)=i_bsc_m3d*min(1,LYR_dynvis(n)) + IF (LYR_agg_stick(n).GT.0) i_bsc_m3d=i_bsc_m3d+1 + jagg_stick(n)=i_bsc_m3d*min(1,LYR_agg_stick(n)) + IF (LYR_agg_stickf(n).GT.0) i_bsc_m3d=i_bsc_m3d+1 + jagg_stickf(n)=i_bsc_m3d*min(1,LYR_agg_stickf(n)) + IF (LYR_agg_dmax(n).GT.0) i_bsc_m3d=i_bsc_m3d+1 + jagg_dmax(n)=i_bsc_m3d*min(1,LYR_agg_dmax(n)) + IF (LYR_agg_avdp(n).GT.0) i_bsc_m3d=i_bsc_m3d+1 + jagg_avdp(n)=i_bsc_m3d*min(1,LYR_agg_avdp(n)) + IF (LYR_agg_avrhop(n).GT.0) i_bsc_m3d=i_bsc_m3d+1 + jagg_avrhop(n)=i_bsc_m3d*min(1,LYR_agg_avrhop(n)) + IF (LYR_agg_avdC(n).GT.0) i_bsc_m3d=i_bsc_m3d+1 + jagg_avdC(n)=i_bsc_m3d*min(1,LYR_agg_avdC(n)) + IF (LYR_agg_df(n).GT.0) i_bsc_m3d=i_bsc_m3d+1 + jagg_df(n)=i_bsc_m3d*min(1,LYR_agg_df(n)) + IF (LYR_agg_b(n).GT.0) i_bsc_m3d=i_bsc_m3d+1 + jagg_b(n)=i_bsc_m3d*min(1,LYR_agg_b(n)) + IF (LYR_agg_Vrhof(n).GT.0) i_bsc_m3d=i_bsc_m3d+1 + jagg_Vrhof(n)=i_bsc_m3d*min(1,LYR_agg_Vrhof(n)) + IF (LYR_agg_Vpor(n).GT.0) i_bsc_m3d=i_bsc_m3d+1 + jagg_Vpor(n)=i_bsc_m3d*min(1,LYR_agg_Vpor(n)) + IF (LVL_PHYTO(n).GT.0) ilvl_bsc_m3d=ilvl_bsc_m3d+1 jlvlphyto(n)=ilvl_bsc_m3d*min(1,LVL_PHYTO(n)) @@ -1115,6 +1272,31 @@ SUBROUTINE ALLOC_MEM_BGCMEAN(kpie,kpje,kpke) IF (LVL_remin_sulf(n).GT.0) ilvl_bsc_m3d=ilvl_bsc_m3d+1 jlvl_remin_sulf(n)=ilvl_bsc_m3d*min(1,LVL_remin_sulf(n)) #endif + ! M4AGO + IF (LVL_agg_ws(n).GT.0) ilvl_bsc_m3d=ilvl_bsc_m3d+1 + jlvl_agg_ws(n)=ilvl_bsc_m3d*min(1,LVL_agg_ws(n)) + IF (LVL_dynvis(n).GT.0) ilvl_bsc_m3d=ilvl_bsc_m3d+1 + jlvl_dynvis(n)=ilvl_bsc_m3d*min(1,LVL_dynvis(n)) + IF (LVL_agg_stick(n).GT.0) ilvl_bsc_m3d=ilvl_bsc_m3d+1 + jlvl_agg_stick(n)=ilvl_bsc_m3d*min(1,LVL_agg_stick(n)) + IF (LVL_agg_stickf(n).GT.0) ilvl_bsc_m3d=ilvl_bsc_m3d+1 + jlvl_agg_stickf(n)=ilvl_bsc_m3d*min(1,LVL_agg_stickf(n)) + IF (LVL_agg_dmax(n).GT.0) ilvl_bsc_m3d=ilvl_bsc_m3d+1 + jlvl_agg_dmax(n)=ilvl_bsc_m3d*min(1,LVL_agg_dmax(n)) + IF (LVL_agg_avdp(n).GT.0) ilvl_bsc_m3d=ilvl_bsc_m3d+1 + jlvl_agg_avdp(n)=ilvl_bsc_m3d*min(1,LVL_agg_avdp(n)) + IF (LVL_agg_avrhop(n).GT.0) ilvl_bsc_m3d=ilvl_bsc_m3d+1 + jlvl_agg_avrhop(n)=ilvl_bsc_m3d*min(1,LVL_agg_avrhop(n)) + IF (LVL_agg_avdC(n).GT.0) ilvl_bsc_m3d=ilvl_bsc_m3d+1 + jlvl_agg_avdC(n)=ilvl_bsc_m3d*min(1,LVL_agg_avdC(n)) + IF (LVL_agg_df(n).GT.0) ilvl_bsc_m3d=ilvl_bsc_m3d+1 + jlvl_agg_df(n)=ilvl_bsc_m3d*min(1,LVL_agg_df(n)) + IF (LVL_agg_b(n).GT.0) ilvl_bsc_m3d=ilvl_bsc_m3d+1 + jlvl_agg_b(n)=ilvl_bsc_m3d*min(1,LVL_agg_b(n)) + IF (LVL_agg_Vrhof(n).GT.0) ilvl_bsc_m3d=ilvl_bsc_m3d+1 + jlvl_agg_Vrhof(n)=ilvl_bsc_m3d*min(1,LVL_agg_Vrhof(n)) + IF (LVL_agg_Vpor(n).GT.0) ilvl_bsc_m3d=ilvl_bsc_m3d+1 + jlvl_agg_Vpor(n)=ilvl_bsc_m3d*min(1,LVL_agg_Vpor(n)) IF (i_bsc_m3d.NE.0) checkdp(n)=1 ENDDO @@ -1167,6 +1349,43 @@ SUBROUTINE ALLOC_MEM_BGCMEAN(kpie,kpje,kpke) jburssster(n)=i_bsc_bur*min(1,BUR_SSSTER(n)) ENDDO #endif +#if defined(extNcycle) && ! defined(sedbypass) + DO n=1,nbgc + IF (SDM_POWNH4(n).GT.0) i_bsc_sed=i_bsc_sed+1 + jpownh4(n)=i_bsc_sed*min(1,SDM_POWNH4(n)) + IF (SDM_POWN2O(n).GT.0) i_bsc_sed=i_bsc_sed+1 + jpown2o(n)=i_bsc_sed*min(1,SDM_POWN2O(n)) + IF (SDM_POWNO2(n).GT.0) i_bsc_sed=i_bsc_sed+1 + jpowno2(n)=i_bsc_sed*min(1,SDM_POWNO2(n)) + IF (SDM_nitr_NH4(n).GT.0) i_bsc_sed=i_bsc_sed+1 + jsdm_nitr_NH4(n)=i_bsc_sed*min(1,SDM_nitr_NH4(n)) + IF (SDM_nitr_NO2(n).GT.0) i_bsc_sed=i_bsc_sed+1 + jsdm_nitr_NO2(n)=i_bsc_sed*min(1,SDM_nitr_NO2(n)) + IF (SDM_nitr_N2O_prod(n).GT.0) i_bsc_sed=i_bsc_sed+1 + jsdm_nitr_N2O_prod(n)=i_bsc_sed*min(1,SDM_nitr_N2O_prod(n)) + IF (SDM_nitr_NH4_OM(n).GT.0) i_bsc_sed=i_bsc_sed+1 + jsdm_nitr_NH4_OM(n)=i_bsc_sed*min(1,SDM_nitr_NH4_OM(n)) + IF (SDM_nitr_NO2_OM(n).GT.0) i_bsc_sed=i_bsc_sed+1 + jsdm_nitr_NO2_OM(n)=i_bsc_sed*min(1,SDM_nitr_NO2_OM(n)) + IF (SDM_denit_NO3(n).GT.0) i_bsc_sed=i_bsc_sed+1 + jsdm_denit_NO3(n)=i_bsc_sed*min(1,SDM_denit_NO3(n)) + IF (SDM_denit_NO2(n).GT.0) i_bsc_sed=i_bsc_sed+1 + jsdm_denit_NO2(n)=i_bsc_sed*min(1,SDM_denit_NO2(n)) + IF (SDM_denit_N2O(n).GT.0) i_bsc_sed=i_bsc_sed+1 + jsdm_denit_N2O(n)=i_bsc_sed*min(1,SDM_denit_N2O(n)) + IF (SDM_DNRA_NO2(n).GT.0) i_bsc_sed=i_bsc_sed+1 + jsdm_DNRA_NO2(n)=i_bsc_sed*min(1,SDM_DNRA_NO2(n)) + IF (SDM_anmx_N2_prod(n).GT.0) i_bsc_sed=i_bsc_sed+1 + jsdm_anmx_N2_prod(n)=i_bsc_sed*min(1,SDM_anmx_N2_prod(n)) + IF (SDM_anmx_OM_prod(n).GT.0) i_bsc_sed=i_bsc_sed+1 + jsdm_anmx_OM_prod(n)=i_bsc_sed*min(1,SDM_anmx_OM_prod(n)) + IF (SDM_remin_aerob(n).GT.0) i_bsc_sed=i_bsc_sed+1 + jsdm_remin_aerob(n)=i_bsc_sed*min(1,SDM_remin_aerob(n)) + IF (SDM_remin_sulf(n).GT.0) i_bsc_sed=i_bsc_sed+1 + jsdm_remin_sulf(n)=i_bsc_sed*min(1,SDM_remin_sulf(n)) + ENDDO +#endif + nbgcm2d = i_bsc_m2d+i_atm_m2d nbgcm3d = i_bsc_m3d @@ -1742,8 +1961,7 @@ END SUBROUTINE finlyr - SUBROUTINE wrtsrf(pos,frmt,sfac,offs,cmpflg,vnm,vlngnm,vstdnm, & - & vunits) + SUBROUTINE wrtsrf(pos,frmt,sfac,offs,cmpflg,vnm) ! ! --- ------------------------------------------------------------------ ! --- Description: writes diagnostic 2d field to file @@ -1761,18 +1979,16 @@ SUBROUTINE wrtsrf(pos,frmt,sfac,offs,cmpflg,vnm,vlngnm,vstdnm, & ! --- int cmpflg (in) : compression flag; only wet points are ! --- written IF flag is set to 1 ! --- char vnm (in) : variable name used in nc-file -! --- char vlngnm (in) : variable long name (skipped IF ' ') -! --- char vstdnm (in) : variable standard name (skipped IF ' ') -! --- char vunits (in) : variable units (skipped IF ' ') ! --- ------------------------------------------------------------------ ! IMPLICIT NONE ! - REAL ::sfac,offs - INTEGER :: frmt,cmpflg,pos,n - CHARACTER(LEN=*) :: vnm,vlngnm,vstdnm,vunits + REAL, intent(in) :: sfac,offs + INTEGER, intent(in) :: frmt,cmpflg,pos + CHARACTER(LEN=*),intent(in) :: vnm ! - CHARACTER(LEN=100) :: dims + INTEGER :: n + CHARACTER(LEN=100) :: dims ! ! --- Check whether field should be written IF (pos.EQ.0 .OR. frmt.EQ.0) RETURN @@ -1812,20 +2028,12 @@ SUBROUTINE wrtsrf(pos,frmt,sfac,offs,cmpflg,vnm,vlngnm,vstdnm, & ELSE STOP 'unknown output format ' ENDIF -! -! --- Def.NE.attributes -! IF (len(trim(vunits)).NE.0) CALL ncattr('units',vunits) -! IF (len(trim(vlngnm)).NE.0) CALL ncattr('long_name',vlngnm) -! IF (len(trim(vstdnm)).NE.0) CALL ncattr('standard_name',vstdnm) -! CALL ncattr('coordinates','plon plat') -! CALL ncattr('cell_measures','area: parea') ! END SUBROUTINE wrtsrf - SUBROUTINE wrtlyr(pos,frmt,sfac,offs,cmpflg,vnm,vlngnm,vstdnm, & - & vunits) + SUBROUTINE wrtlyr(pos,frmt,sfac,offs,cmpflg,vnm) ! ! --- ------------------------------------------------------------------ ! --- Description: writes diagnostic layer field to file @@ -1843,18 +2051,16 @@ SUBROUTINE wrtlyr(pos,frmt,sfac,offs,cmpflg,vnm,vlngnm,vstdnm, & ! --- int cmpflg (in) : compression flag; only wet points are ! --- written IF flag is set to 1 ! --- char vnm (in) : variable name used in nc-file -! --- char vlngnm (in) : variable long name (skipped IF ' ') -! --- char vstdnm (in) : variable standard name (skipped IF ' ') -! --- char vunits (in) : variable units (skipped IF ' ') ! --- ------------------------------------------------------------------ ! IMPLICIT NONE ! - REAL ::sfac,offs - INTEGER :: frmt,cmpflg,pos,n - CHARACTER(LEN=*) :: vnm,vlngnm,vstdnm,vunits + REAL, intent(in) :: sfac,offs + INTEGER, intent(in) :: frmt,cmpflg,pos + CHARACTER(LEN=*),intent(in) :: vnm ! - CHARACTER(LEN=100) :: dims + INTEGER :: n + CHARACTER(LEN=100) :: dims ! ! --- Check whether field should be written IF (pos.EQ.0 .OR. frmt.EQ.0) RETURN @@ -1894,20 +2100,12 @@ SUBROUTINE wrtlyr(pos,frmt,sfac,offs,cmpflg,vnm,vlngnm,vstdnm, & ELSE STOP 'unknown output format ' ENDIF -! -! --- Def.NE.attributes -! IF (len(trim(vunits)).NE.0) CALL ncattr('units',vunits) -! IF (len(trim(vlngnm)).NE.0) CALL ncattr('long_name',vlngnm) -! IF (len(trim(vstdnm)).NE.0) CALL ncattr('standard_name',vstdnm) -! CALL ncattr('coordinates','plon plat') -! CALL ncattr('cell_measures','area: parea') ! END SUBROUTINE wrtlyr - SUBROUTINE wrtlvl(pos,frmt,sfac,offs,cmpflg,vnm,vlngnm,vstdnm, & - & vunits) + SUBROUTINE wrtlvl(pos,frmt,sfac,offs,cmpflg,vnm) ! ! --- ------------------------------------------------------------------ ! --- Description: writes diagnostic level field to file @@ -1925,18 +2123,16 @@ SUBROUTINE wrtlvl(pos,frmt,sfac,offs,cmpflg,vnm,vlngnm,vstdnm, & ! --- int cmpflg (in) : compression flag; only wet points are ! --- written IF flag is set to 1 ! --- char vnm (in) : variable name used in nc-file -! --- char vlngnm (in) : variable long name (skipped IF ' ') -! --- char vstdnm (in) : variable standard name (skipped IF ' ') -! --- char vunits (in) : variable units (skipped IF ' ') ! --- ------------------------------------------------------------------ ! IMPLICIT NONE ! - REAL ::sfac,offs - INTEGER :: frmt,cmpflg,pos,n - CHARACTER(LEN=*) :: vnm,vlngnm,vstdnm,vunits + REAL, intent(in) :: sfac,offs + INTEGER, intent(in) :: frmt,cmpflg,pos + CHARACTER(LEN=*),intent(in) :: vnm ! - CHARACTER(LEN=100) :: dims + INTEGER :: n + CHARACTER(LEN=100) :: dims ! ! --- Check whether field should be written IF (pos.EQ.0 .OR. frmt.EQ.0) RETURN @@ -1976,20 +2172,12 @@ SUBROUTINE wrtlvl(pos,frmt,sfac,offs,cmpflg,vnm,vlngnm,vstdnm, & ELSE STOP 'unknown output format ' ENDIF -! -! --- Def.NE.attributes -! IF (len(trim(vunits)).NE.0) CALL ncattr('units',vunits) -! IF (len(trim(vlngnm)).NE.0) CALL ncattr('long_name',vlngnm) -! IF (len(trim(vstdnm)).NE.0) CALL ncattr('standard_name',vstdnm) -! CALL ncattr('coordinates','plon plat') -! CALL ncattr('cell_measures','area: parea') ! END SUBROUTINE wrtlvl - SUBROUTINE wrtsdm(pos,frmt,sfac,offs,cmpflg,vnm,vlngnm,vstdnm, & - & vunits) + SUBROUTINE wrtsdm(pos,frmt,sfac,offs,cmpflg,vnm) ! ! --- ------------------------------------------------------------------ ! --- Description: writes diagnostic sediment field to file @@ -2007,18 +2195,16 @@ SUBROUTINE wrtsdm(pos,frmt,sfac,offs,cmpflg,vnm,vlngnm,vstdnm, & ! --- int cmpflg (in) : compression flag; only wet points are ! --- written IF flag is set to 1 ! --- char vnm (in) : variable name used in nc-file -! --- char vlngnm (in) : variable long name (skipped IF ' ') -! --- char vstdnm (in) : variable standard name (skipped IF ' ') -! --- char vunits (in) : variable units (skipped IF ' ') ! --- ------------------------------------------------------------------ ! IMPLICIT NONE ! - REAL ::sfac,offs - INTEGER :: frmt,cmpflg,pos,n - CHARACTER(LEN=*) :: vnm,vlngnm,vstdnm,vunits + REAL, intent(in) :: sfac,offs + INTEGER, intent(in) :: frmt,cmpflg,pos + CHARACTER(LEN=*),intent(in) :: vnm ! - CHARACTER(LEN=100) :: dims + INTEGER :: n + CHARACTER(LEN=100) :: dims ! ! --- Check whether field should be written IF (pos.EQ.0 .OR. frmt.EQ.0) RETURN @@ -2058,20 +2244,12 @@ SUBROUTINE wrtsdm(pos,frmt,sfac,offs,cmpflg,vnm,vlngnm,vstdnm, & ELSE STOP 'unknown output format ' ENDIF -! -! --- Def.NE.attributes -! IF (len(trim(vunits)).NE.0) CALL ncattr('units',vunits) -! IF (len(trim(vlngnm)).NE.0) CALL ncattr('long_name',vlngnm) -! IF (len(trim(vstdnm)).NE.0) CALL ncattr('standard_name',vstdnm) -! CALL ncattr('coordinates','plon plat') -! CALL ncattr('cell_measures','area: parea') ! END SUBROUTINE wrtsdm - SUBROUTINE wrtbur(pos,frmt,sfac,offs,cmpflg,vnm,vlngnm,vstdnm, & - & vunits) + SUBROUTINE wrtbur(pos,frmt,sfac,offs,cmpflg,vnm) ! ! --- ------------------------------------------------------------------ ! --- Description: writes diagnostic sediment burial field to file @@ -2089,18 +2267,16 @@ SUBROUTINE wrtbur(pos,frmt,sfac,offs,cmpflg,vnm,vlngnm,vstdnm, & ! --- int cmpflg (in) : compression flag; only wet points are ! --- written IF flag is set to 1 ! --- char vnm (in) : variable name used in nc-file -! --- char vlngnm (in) : variable long name (skipped IF ' ') -! --- char vstdnm (in) : variable standard name (skipped IF ' ') -! --- char vunits (in) : variable units (skipped IF ' ') ! --- ------------------------------------------------------------------ ! IMPLICIT NONE ! - REAL ::sfac,offs - INTEGER :: frmt,cmpflg,pos,n - CHARACTER(LEN=*) :: vnm,vlngnm,vstdnm,vunits + REAL, intent(in) :: sfac,offs + INTEGER, intent(in) :: frmt,cmpflg,pos + CHARACTER(LEN=*),intent(in) :: vnm ! - CHARACTER(LEN=100) :: dims + INTEGER :: n + CHARACTER(LEN=100) :: dims ! ! --- Check whether field should be written IF (pos.EQ.0 .OR. frmt.EQ.0) RETURN @@ -2140,13 +2316,6 @@ SUBROUTINE wrtbur(pos,frmt,sfac,offs,cmpflg,vnm,vlngnm,vstdnm, & ELSE STOP 'unknown output format ' ENDIF -! -! --- Def.NE.attributes -! IF (len(trim(vunits)).NE.0) CALL ncattr('units',vunits) -! IF (len(trim(vlngnm)).NE.0) CALL ncattr('long_name',vlngnm) -! IF (len(trim(vstdnm)).NE.0) CALL ncattr('standard_name',vstdnm) -! CALL ncattr('coordinates','plon plat') -! CALL ncattr('cell_measures','area: parea') ! END SUBROUTINE wrtbur diff --git a/hamocc/mo_biomod.F90 b/hamocc/mo_biomod.F90 index 5f373e8b..71afdfd4 100644 --- a/hamocc/mo_biomod.F90 +++ b/hamocc/mo_biomod.F90 @@ -92,19 +92,16 @@ MODULE mo_biomod REAL, DIMENSION (:,:), ALLOCATABLE :: int_chbr3_prod REAL, DIMENSION (:,:), ALLOCATABLE :: int_chbr3_uv #endif -#ifdef extNcycle REAL, DIMENSION (:,:,:), ALLOCATABLE :: nitr_NH4,nitr_NO2,nitr_N2O_prod,nitr_NH4_OM,nitr_NO2_OM,denit_NO3,denit_NO2, & & denit_N2O,DNRA_NO2,anmx_N2_prod,anmx_OM_prod,phosy_NH4,phosy_NO3,remin_aerob, & & remin_sulf -#endif - REAL :: phytomi,grami,grazra,pi_alpha REAL :: remido,dyphy,zinges,epsher,spemor,gammap,gammaz,ecan REAL :: ro2ut,rcar,rnit,rnoi,rdnit0,rdnit1,rdnit2,rdn2o1,rdn2o2,rcalc,ropal REAL :: bluefix,tf2,tf1,tf0,tff REAL :: bkphy,bkzoo,bkopal REAL :: wpoc,wcal,wopal - REAL :: drempoc,dremopal,dremn2o,dremsul + REAL :: drempoc,dremopal,dremn2o,dremsul,drempoc_anaerob,bkox_drempoc REAL :: perc_diron, riron, fesoly, relaxfe, fetune, wdust REAL :: ctochl, atten_w, atten_c, atten_uv, atten_f #ifdef cisonew diff --git a/hamocc/mo_carbch.F90 b/hamocc/mo_carbch.F90 index 2aecf82a..8c887ee6 100644 --- a/hamocc/mo_carbch.F90 +++ b/hamocc/mo_carbch.F90 @@ -69,12 +69,18 @@ MODULE mo_carbch REAL, DIMENSION (:,:,:), ALLOCATABLE :: satoxy REAL, DIMENSION (:,:), ALLOCATABLE :: satn2o + REAL, DIMENSION (:,:), ALLOCATABLE :: pn2om REAL, DIMENSION (:,:), ALLOCATABLE :: atdifv REAL, DIMENSION (:,:), ALLOCATABLE :: suppco2 - REAL, DIMENSION (:,:,:), ALLOCATABLE :: sedfluxo + REAL, DIMENSION (:,:,:), ALLOCATABLE :: sedfluxo + REAL, DIMENSION (:,:,:), ALLOCATABLE :: sedfluxb REAL, DIMENSION (:,:), ALLOCATABLE :: pco2d + REAL, DIMENSION (:,:), ALLOCATABLE :: pco2m REAL, DIMENSION (:,:), ALLOCATABLE :: kwco2sol + REAL, DIMENSION (:,:), ALLOCATABLE :: kwco2d + REAL, DIMENSION (:,:), ALLOCATABLE :: co2sold + REAL, DIMENSION (:,:), ALLOCATABLE :: co2solm REAL, DIMENSION (:,:), ALLOCATABLE :: co2fxd REAL, DIMENSION (:,:), ALLOCATABLE :: co2fxu #ifdef cisonew @@ -106,6 +112,7 @@ MODULE mo_carbch REAL :: atm_bromo, fbro1, fbro2 #endif #ifdef extNcycle + REAL, DIMENSION (:,:), ALLOCATABLE :: pnh3 REAL :: atm_nh3,atm_n2o #endif @@ -117,7 +124,7 @@ SUBROUTINE ALLOC_MEM_CARBCH(kpie,kpje,kpke) !****************************************************************************** use mod_xc, only: mnproc use mo_control_bgc, only: io_stdo_bgc - use mo_param1_bgc, only: nocetra,npowtra,natm,nriv + use mo_param1_bgc, only: nocetra,npowtra,nsedtra,natm,nriv INTEGER, intent(in) :: kpie,kpje,kpke INTEGER :: errstat @@ -248,6 +255,17 @@ SUBROUTINE ALLOC_MEM_CARBCH(kpie,kpje,kpke) if(errstat.ne.0) stop 'not enough memory sedfluxo' sedfluxo(:,:,:) = 0.0 + IF (mnproc.eq.1) THEN + WRITE(io_stdo_bgc,*)'Memory allocation for variable sedfluxb ..' + WRITE(io_stdo_bgc,*)'First dimension : ',kpie + WRITE(io_stdo_bgc,*)'Second dimension : ',kpje + WRITE(io_stdo_bgc,*)'Third dimension : ',nsedtra + ENDIF + + ALLOCATE (sedfluxb(kpie,kpje,nsedtra),stat=errstat) + if(errstat.ne.0) stop 'not enough memory sedfluxb' + sedfluxb(:,:,:) = 0.0 + IF (mnproc.eq.1) THEN WRITE(io_stdo_bgc,*)'Memory allocation for variable satn2o ...' WRITE(io_stdo_bgc,*)'First dimension : ',kpie @@ -257,6 +275,16 @@ SUBROUTINE ALLOC_MEM_CARBCH(kpie,kpje,kpke) ALLOCATE (satn2o(kpie,kpje),stat=errstat) if(errstat.ne.0) stop 'not enough memory satn2o' satn2o(:,:) = 0.0 + + IF (mnproc.eq.1) THEN + WRITE(io_stdo_bgc,*)'Memory allocation for variable pn2om ...' + WRITE(io_stdo_bgc,*)'First dimension : ',kpie + WRITE(io_stdo_bgc,*)'Second dimension : ',kpje + ENDIF + + ALLOCATE (pn2om(kpie,kpje),stat=errstat) + if(errstat.ne.0) stop 'not enough memory pn2om' + pn2om(:,:) = 0.0 IF (mnproc.eq.1) THEN WRITE(io_stdo_bgc,*)'Memory allocation for variable keqb ...' @@ -337,12 +365,51 @@ SUBROUTINE ALLOC_MEM_CARBCH(kpie,kpje,kpke) if(errstat.ne.0) stop 'not enough memory pco2d' pco2d(:,:) = 0.0 + IF (mnproc.eq.1) THEN + WRITE(io_stdo_bgc,*)'Memory allocation for variable pco2m ...' + WRITE(io_stdo_bgc,*)'First dimension : ',kpie + WRITE(io_stdo_bgc,*)'Second dimension : ',kpje + ENDIF + + ALLOCATE (pco2m(kpie,kpje),stat=errstat) + if(errstat.ne.0) stop 'not enough memory pco2m' + pco2m(:,:) = 0.0 + + IF (mnproc.eq.1) THEN + WRITE(io_stdo_bgc,*)'Memory allocation for variable kwco2d ...' + WRITE(io_stdo_bgc,*)'First dimension : ',kpie + WRITE(io_stdo_bgc,*)'Second dimension : ',kpje + ENDIF + + ALLOCATE (kwco2d(kpie,kpje),stat=errstat) + if(errstat.ne.0) stop 'not enough memory kwco2d' + kwco2d(:,:) = 0.0 IF (mnproc.eq.1) THEN WRITE(io_stdo_bgc,*)'Memory allocation for variable kwco2sol ...' WRITE(io_stdo_bgc,*)'First dimension : ',kpie WRITE(io_stdo_bgc,*)'Second dimension : ',kpje ENDIF + + IF (mnproc.eq.1) THEN + WRITE(io_stdo_bgc,*)'Memory allocation for variable co2sold ...' + WRITE(io_stdo_bgc,*)'First dimension : ',kpie + WRITE(io_stdo_bgc,*)'Second dimension : ',kpje + ENDIF + + ALLOCATE (co2sold(kpie,kpje),stat=errstat) + if(errstat.ne.0) stop 'not enough memory co2sold' + co2sold(:,:) = 0.0 + + IF (mnproc.eq.1) THEN + WRITE(io_stdo_bgc,*)'Memory allocation for variable co2solm ...' + WRITE(io_stdo_bgc,*)'First dimension : ',kpie + WRITE(io_stdo_bgc,*)'Second dimension : ',kpje + ENDIF + + ALLOCATE (co2solm(kpie,kpje),stat=errstat) + if(errstat.ne.0) stop 'not enough memory co2solm' + co2solm(:,:) = 0.0 ALLOCATE (kwco2sol(kpie,kpje),stat=errstat) if(errstat.ne.0) stop 'not enough memory co2fxd,co2fxu' @@ -378,6 +445,17 @@ SUBROUTINE ALLOC_MEM_CARBCH(kpie,kpje,kpke) co214fxd(:,:) = 0.0 co214fxu(:,:) = 0.0 #endif +#ifdef extNcycle + IF (mnproc.eq.1) THEN + WRITE(io_stdo_bgc,*)'Memory allocation for variable pnh3 ...' + WRITE(io_stdo_bgc,*)'First dimension : ',kpie + WRITE(io_stdo_bgc,*)'Second dimension : ',kpje + ENDIF + + ALLOCATE (pnh3(kpie,kpje),stat=errstat) + if(errstat.ne.0) stop 'not enough memory pnh3' + pnh3(:,:) = 0.0 +#endif !****************************************************************************** END SUBROUTINE ALLOC_MEM_CARBCH diff --git a/hamocc/mo_control_bgc.F90 b/hamocc/mo_control_bgc.F90 index 4c36ce1e..e3f7708e 100644 --- a/hamocc/mo_control_bgc.F90 +++ b/hamocc/mo_control_bgc.F90 @@ -57,13 +57,15 @@ MODULE mo_control_bgc REAL, save :: rmasks = 0.0 ! value at wet cells in sediment. REAL, save :: rmasko = 99999.00 ! value at wet cells in ocean. - + ! Logical switches set via namelist + LOGICAL, save :: l_3Dvarsedpor = .false. ! apply lon-lat-depth variable sediment porosity via input file LOGICAL, save :: do_ndep =.true. ! apply n-deposition LOGICAL, save :: do_rivinpt =.true. ! apply riverine input LOGICAL, save :: do_sedspinup=.false. ! apply sediment spin-up + LOGICAL, save :: do_oalk =.false. ! apply ocean alkalinization logical, save :: with_dmsph =.false. ! apply DMS with pH dependence - + LOGICAL, save :: lm4ago =.false. ! run with M4AGO settling scheme contains subroutine get_bgc_namelist diff --git a/hamocc/mo_extNbioproc.F90 b/hamocc/mo_extNbioproc.F90 index 69b116e5..be34dd0c 100644 --- a/hamocc/mo_extNbioproc.F90 +++ b/hamocc/mo_extNbioproc.F90 @@ -44,7 +44,9 @@ MODULE mo_extNbioproc ! ! Explicit cyanobacteria? ! - ! Sediment processes? + ! The respective sediment processes are handled in: + ! - powach.F90 and + ! - mo_extNsediment.F90 ! !**************************************************************** use mo_vgrid, only: dp_min @@ -63,18 +65,34 @@ MODULE mo_extNbioproc public :: extNbioparam_init,nitrification,denit_NO3_to_NO2,& & anammox,denit_dnra,extN_inv_check - ! public parameters + ! public parameters for primary production public :: bkphyanh4,bkphyano3,bkphosph,bkiron,ro2utammo + ! Public parameters for extended nitrogen cycle in the sediment. + ! The basic idea is that we have the same temperature dependence + ! and same nutrient sensitivities, + ! while only the rates vary between sediment and water column + ! (Thus far, we keep the rates public in order to enable to write them to the log in beleg_parm) + public :: q10ano3denit,sc_ano3denit,Trefano3denit,rano3denit,bkano3denit, & + & rano2anmx,q10anmx,Trefanmx,alphaanmx,bkoxanmx,bkano2anmx,bkanh4anmx, & + & rano2denit,q10ano2denit,Trefano2denit,bkoxano2denit,bkano2denit, & + & ran2odenit,q10an2odenit,Trefan2odenit,bkoxan2odenit,bkan2odenit, & + & rdnra,q10dnra,Trefdnra,bkoxdnra,bkdnra,ranh4nitr,q10anh4nitr, & + & Trefanh4nitr,bkoxamox,bkanh4nitr,bkamoxn2o,bkyamox, & + & rano2nitr,q10ano2nitr,Trefano2nitr,bkoxnitr,bkano2nitr,n2omaxy, & + & n2oybeta,NOB2AOAy,bn2o,mufn2o, & + & rc2n,ro2nnit,rnoxp,rnoxpi,rno2anmx,rno2anmxi,rnh4anmx, & + & rnh4anmxi,rno2dnra,rno2dnrai,rnh4dnra,rnh4dnrai,rnm1 + real :: q10ano3denit,sc_ano3denit,Trefano3denit,rano3denit,bkano3denit, & & rano2anmx,q10anmx,Trefanmx,alphaanmx,bkoxanmx,bkano2anmx,bkanh4anmx, & & rano2denit,q10ano2denit,Trefano2denit,bkoxano2denit,bkano2denit, & & ran2odenit,q10an2odenit,Trefan2odenit,bkoxan2odenit,bkan2odenit, & & rdnra,q10dnra,Trefdnra,bkoxdnra,bkdnra,ranh4nitr,q10anh4nitr, & - & Trefanh4nitr,bkoxamox,bkanh4nitr,bkamoxn2o,bkamoxno2,bkyamox, & + & Trefanh4nitr,bkoxamox,bkanh4nitr,bkamoxn2o,bkyamox, & & rano2nitr,q10ano2nitr,Trefano2nitr,bkoxnitr,bkano2nitr,n2omaxy, & - & n2oybeta,bkphyanh4,bkphyano3,bkphosph,bkiron,NOB2AOAy + & n2oybeta,bkphyanh4,bkphyano3,bkphosph,bkiron,NOB2AOAy,bn2o,mufn2o!,bkamoxno2, real :: rc2n,ro2utammo,ro2nnit,rnoxp,rnoxpi,rno2anmx,rno2anmxi,rnh4anmx, & & rnh4anmxi,rno2dnra,rno2dnrai,rnh4dnra,rnh4dnrai,rnm1 @@ -88,7 +106,7 @@ subroutine extNbioparam_init() !=========================================================================== ! Initialization of model parameters for the extended nitrogen cycle rc2n = rcar/rnit ! iHAMOCC C:N ratio - ro2utammo = 140. ! Oxygen utilization per mol detitus during ammonification + ro2utammo = 140. ! Oxygen utilization per mol detritus during ammonification ro2nnit = ro2utammo/rnit ! rnoxp = 280. ! consumption of NOx per mol detritus during denitrification rnoxpi = 1./rnoxp ! inverse @@ -103,7 +121,7 @@ subroutine extNbioparam_init() rnm1 = rnit - 1. ! Phytoplankton growth - bkphyanh4 = 0.1e-6 ! Half-saturation constant for NH4 uptake by bulk phytoplankton (kmol/m3) + bkphyanh4 = 0.12e-6 ! Half-saturation constant for NH4 uptake by bulk phytoplankton (kmol/m3) bkphyano3 = 0.16e-6 ! Half-saturation constant for NO3 uptake by bulk phytoplankton (kmol/m3) bkphosph = 0.01e-6 ! Half-saturation constant for PO4 uptake by bulk phytoplankton (kmol/m3) bkiron = bkphosph*riron ! Half-saturation constant for Fe uptake by bulk phytoplankton (kmol/m3) @@ -114,7 +132,7 @@ subroutine extNbioparam_init() q10ano3denit = 2. ! Q10 factor for denitrification on NO3 (-) Trefano3denit = 10. ! Reference temperature for denitrification on NO3 (degr C) !sc_ano3denit = 0.05e6 ! Shape factor for NO3 denitrification oxygen inhibition function (m3/kmol) - sc_ano3denit = 0.08e6 ! Shape factor for NO3 denitrification oxygen inhibition function (m3/kmol) + sc_ano3denit = 0.12e6 ! Shape factor for NO3 denitrification oxygen inhibition function (m3/kmol) bkano3denit = 5.e-6 ! Half-saturation constant for NO3 denitrification (kmol/m3) ! === Anammox @@ -155,13 +173,15 @@ subroutine extNbioparam_init() bkanh4nitr = 0.133e-6 ! Half-saturation constant for nitrification on NH4 (kmol/m3) !====== ! OLD VERSION OF pathway splitting function - !bkamoxn2o = 0.453e-6 ! Half saturation constant for pathway splitting function N2O for nitrification on NH4 (kmol/m3) + !bkamoxn2o = 0.453e-6 ! Half saturation constant for O2 in pathway splitting function N2O for nitrification on NH4 (kmol/m3) ! NEW version similar to Santoros 2021, Ji 2018: - bkamoxn2o = 0.002e-6 ! Half saturation constant for pathway splitting function N2O for nitrification on NH4 (kmol/m3) + bkamoxn2o = 0.5e-6 ! Half saturation constant for NH4 in pathway splitting function N2O for nitrification on NH4 (kmol/m3) + mufn2o = 0.11/(50.*1e6*bkoxamox) !=6.61e-3 0.11/(50*1e6)=2.2e-9 - ~Santoro et al. 2011 with simple MM, + bn2o = 0.077/(50.*mufn2o) !=0.2331 - before set to 0.3 - base fraction entering N2O !====== !bkamoxno2 = 0.479e-6 ! Half saturation constant for pathway splitting function N2O for nitrification on NH4 (kmol/m3) - bkamoxno2 = 0.1e-6 ! Half saturation constant for pathway splitting function N2O for nitrification on NH4 (kmol/m3) - n2omaxy = 0.006 ! Maximum yield of OM on NH4 nitrification (-) +! bkamoxno2 = 0.1e-6 ! Half saturation constant for pathway splitting function N2O for nitrification on NH4 (kmol/m3) + n2omaxy = 0.003 ! Maximum yield of OM on NH4 nitrification (-) n2oybeta = 18. ! Decay factor for inhibition function for yield during nitrification on NH4 (kmol/m3) bkyamox = 0.333e-6 ! Half saturation constant for pathway splitting function OM-yield for nitrification on NH4 (kmol/m3) @@ -176,6 +196,14 @@ subroutine extNbioparam_init() eps = 1.e-25 ! safe division etc. minlim = 1.e-9 ! minimum for limitation functions (e.g. nutlim or oxlim/inh can only decrease to minlim) !=========================================================================== + + ! Tweaked parameters: + rano3denit = 0.0005*dtb ! Maximum growth rate denitrification on NO3 at reference T (1/d -> 1/dt) + rano2anmx = 0.001*dtb ! Maximum growth rate for anammox at reference T (1/d -> 1/dt) + rano2denit = 0.001*dtb ! Maximum growth rate denitrification on NO2 at reference T (1/d -> 1/dt) + ran2odenit = 0.0012*dtb ! Maximum growth rate denitrification on N2O at reference T (1/d -> 1/dt) + rdnra = 0.001*dtb ! Maximum growth rate DNRA on NO2 at reference T (1/d -> 1/dt) + end subroutine extNbioparam_init !================================================================================================================================== @@ -213,102 +241,109 @@ subroutine nitrification(kpie,kpje,kpke,kbnd,pddpo,omask,ptho) !$OMP nitrfrac,totd,amox,nitr,temp,no2fn2o,no2fno2,no2fdetamox) do j = 1,kpje - do i = 1,kpie - do k = 1,kpke - if(pddpo(i,j,k) > dp_min .and. omask(i,j) > 0.5) then - potdnh4amox = 0. - fn2o = 0. - fno2 = 0. - fdetamox = 0. - potdno2nitr = 0. - fdetnitr = 0. - - if(ocetra(i,j,k,ioxygen)>minlim_oxnh4 .and. ocetra(i,j,k,ianh4)>minlim_nh4)then - temp = merge(ptho(i,j,k),10.,ptho(i,j,k)<40.) - ! Ammonium oxidation step of nitrification - Tdepanh4 = q10anh4nitr**((temp-Trefanh4nitr)/10.) - O2limanh4 = ocetra(i,j,k,ioxygen)/(ocetra(i,j,k,ioxygen) + bkoxamox) - nut1lim = ocetra(i,j,k,ianh4)/(ocetra(i,j,k,ianh4) + bkanh4nitr) - anh4new = ocetra(i,j,k,ianh4)/(1. + ranh4nitr*Tdepanh4*O2limanh4*nut1lim) - potdnh4amox = max(0.,ocetra(i,j,k,ianh4) - anh4new) + do i = 1,kpie + do k = 1,kpke + if(pddpo(i,j,k) > dp_min .and. omask(i,j) > 0.5) then + potdnh4amox = 0. + fn2o = 0. + fno2 = 0. + fdetamox = 0. + potdno2nitr = 0. + fdetnitr = 0. + +! if(ocetra(i,j,k,ioxygen)>minlim_oxnh4 .and. ocetra(i,j,k,ianh4)>minlim_nh4)then + temp = merge(ptho(i,j,k),10.,ptho(i,j,k)<40.) + ! Ammonium oxidation step of nitrification + Tdepanh4 = q10anh4nitr**((temp-Trefanh4nitr)/10.) + O2limanh4 = ocetra(i,j,k,ioxygen)/(ocetra(i,j,k,ioxygen) + bkoxamox) + nut1lim = ocetra(i,j,k,ianh4)/(ocetra(i,j,k,ianh4) + bkanh4nitr) + anh4new = ocetra(i,j,k,ianh4)/(1. + ranh4nitr*Tdepanh4*O2limanh4*nut1lim) + potdnh4amox = max(0.,ocetra(i,j,k,ianh4) - anh4new) ! pathway splitting functions according to Goreau 1980 !===== ! OLD version according to Goreau !fn2o = 1. - ocetra(i,j,k,ioxygen)/(ocetra(i,j,k,ioxygen) + bkamoxn2o) ! NEW version similar to Santoros et al. 2021, Ji et al. 2018 - fn2o = 1. - (1.-0.00157)*ocetra(i,j,k,ioxygen)/(ocetra(i,j,k,ioxygen) + bkamoxn2o) + fn2o = mufn2o * (bn2o + (1.-bn2o)*bkoxamox/(ocetra(i,j,k,ioxygen)+bkoxamox)) & + & * ocetra(i,j,k,ianh4)/(ocetra(i,j,k,ianh4)+bkamoxn2o) !===== - fno2 = ocetra(i,j,k,ioxygen)/(ocetra(i,j,k,ioxygen) + bkamoxno2) - fdetamox = n2omaxy*2.*(1. + n2oybeta)*ocetra(i,j,k,ioxygen)*bkyamox & + fno2 = ocetra(i,j,k,ioxygen)/(ocetra(i,j,k,ioxygen) + bkoxamox) + fdetamox = n2omaxy*2.*(1. + n2oybeta)*ocetra(i,j,k,ioxygen)*bkyamox & & /(ocetra(i,j,k,ioxygen)**2 + 2.*ocetra(i,j,k,ioxygen)*bkyamox + bkyamox**2) - ! normalization of pathway splitting functions to sum=1 - ftotnh4 = fn2o + fno2 + fdetamox + eps - fn2o = fn2o/ftotnh4 - fno2 = fno2/ftotnh4 - fdetamox = 1. - (fn2o + fno2) - endif - - if(ocetra(i,j,k,ioxygen)>minlim_oxno2 .and. ocetra(i,j,k,iano2)>minlim_no2)then - temp = merge(ptho(i,j,k),10.,ptho(i,j,k)<40.) - ! NO2 oxidizing step of nitrification - Tdepano2 = q10ano2nitr**((temp-Trefano2nitr)/10.) - O2limano2 = ocetra(i,j,k,ioxygen)/(ocetra(i,j,k,ioxygen) + bkoxnitr) - nut2lim = ocetra(i,j,k,iano2)/(ocetra(i,j,k,iano2) + bkano2nitr) - ano2new = ocetra(i,j,k,iano2)/(1. + rano2nitr*Tdepano2*O2limano2*nut2lim) - potdno2nitr = max(0.,ocetra(i,j,k,iano2) - ano2new) - - ! pathway splitting functions for NO2 nitrification - assuming to be the same as for NH4 - ! but with reduced OM gain per used NO2 as energy source (in amox: NH4) - no2fn2o = 1. - ocetra(i,j,k,ioxygen)/(ocetra(i,j,k,ioxygen) + bkamoxn2o) - no2fno2 = ocetra(i,j,k,ioxygen)/(ocetra(i,j,k,ioxygen) + bkamoxno2) - no2fdetamox = NOB2AOAy*n2omaxy*2.*(1. + n2oybeta)*ocetra(i,j,k,ioxygen)*bkyamox & + ! normalization of pathway splitting functions to sum=1 + ftotnh4 = fn2o + fno2 + fdetamox + eps + fn2o = fn2o/ftotnh4 + fno2 = fno2/ftotnh4 + fdetamox = 1. - (fn2o + fno2) +! endif + +! if(ocetra(i,j,k,ioxygen)>minlim_oxno2 .and. ocetra(i,j,k,iano2)>minlim_no2)then + temp = merge(ptho(i,j,k),10.,ptho(i,j,k)<40.) + ! NO2 oxidizing step of nitrification + Tdepano2 = q10ano2nitr**((temp-Trefano2nitr)/10.) + O2limano2 = ocetra(i,j,k,ioxygen)/(ocetra(i,j,k,ioxygen) + bkoxnitr) + nut2lim = ocetra(i,j,k,iano2)/(ocetra(i,j,k,iano2) + bkano2nitr) + ano2new = ocetra(i,j,k,iano2)/(1. + rano2nitr*Tdepano2*O2limano2*nut2lim) + potdno2nitr = max(0.,ocetra(i,j,k,iano2) - ano2new) + + ! pathway splitting functions for NO2 nitrification - assuming to be the same as for NH4 + ! but with reduced OM gain per used NO2 as energy source (in amox: NH4) + !===== + ! OLD version according to Goreau + ! no2fn2o = 1. - ocetra(i,j,k,ioxygen)/(ocetra(i,j,k,ioxygen) + bkamoxn2o) + ! NEW version + no2fn2o = mufn2o * (bn2o + (1.-bn2o)*bkoxamox/(ocetra(i,j,k,ioxygen)+bkoxamox)) & + & * ocetra(i,j,k,ianh4)/(ocetra(i,j,k,ianh4)+bkamoxn2o) + !===== + no2fno2 = ocetra(i,j,k,ioxygen)/(ocetra(i,j,k,ioxygen) + bkoxamox) + no2fdetamox = NOB2AOAy*n2omaxy*2.*(1. + n2oybeta)*ocetra(i,j,k,ioxygen)*bkyamox & & /(ocetra(i,j,k,ioxygen)**2 + 2.*ocetra(i,j,k,ioxygen)*bkyamox + bkyamox**2) - fdetnitr = no2fdetamox/(no2fno2 + no2fn2o) ! yield to energy usage ratio for NO2 -> ratio equals 16:x - endif + fdetnitr = no2fdetamox/(no2fno2 + no2fn2o) ! yield to energy usage ratio for NO2 -> ratio equals 16:x +! endif - ! limitation of the two processes through available nutrients, etc. - totd = potdnh4amox + potdno2nitr - amoxfrac = potdnh4amox/(totd + eps) - nitrfrac = 1. - amoxfrac + ! limitation of the two processes through available nutrients, etc. + totd = potdnh4amox + potdno2nitr + amoxfrac = potdnh4amox/(totd + eps) + nitrfrac = 1. - amoxfrac - totd = max(0., & - & min(totd, & - & ocetra(i,j,k,ianh4)/(amoxfrac + fdetnitr*nitrfrac + eps), & ! ammonium - & ocetra(i,j,k,isco212)/(rc2n*(fdetamox*amoxfrac + fdetnitr*nitrfrac) + eps), & ! CO2 - & ocetra(i,j,k,iphosph)/(rnoi*(fdetamox*amoxfrac + fdetnitr*nitrfrac) + eps), & ! PO4 - & ocetra(i,j,k,iiron)/(riron*rnoi*(fdetamox*amoxfrac + fdetnitr*nitrfrac) + eps), & ! Fe - & ocetra(i,j,k,ioxygen) & - & /((1.5*fno2 + fn2o - ro2nnit*fdetamox)*amoxfrac + (0.5 - ro2nnit*fdetnitr)*nitrfrac + eps), & ! O2 - & ocetra(i,j,k,ialkali) & - & /((2.*fno2 + fn2o + rnm1*rnoi*fdetamox)*amoxfrac + (rnm1*rnoi*fdetnitr)*nitrfrac + eps))) ! alkalinity - amox = amoxfrac*totd - nitr = nitrfrac*totd - - ocetra(i,j,k,ianh4) = ocetra(i,j,k,ianh4) - amox - fdetnitr*nitr - ocetra(i,j,k,ian2o) = ocetra(i,j,k,ian2o) + 0.5*fn2o*amox - ocetra(i,j,k,iano2) = ocetra(i,j,k,iano2) + fno2*amox - nitr - ocetra(i,j,k,iano3) = ocetra(i,j,k,iano3) + nitr - ocetra(i,j,k,idet) = ocetra(i,j,k,idet) + rnoi*(fdetamox*amox + fdetnitr*nitr) - ocetra(i,j,k,isco212) = ocetra(i,j,k,isco212) - rc2n*(fdetamox*amox + fdetnitr*nitr) - ocetra(i,j,k,iphosph) = ocetra(i,j,k,iphosph) - rnoi*(fdetamox*amox + fdetnitr*nitr) - ocetra(i,j,k,iiron) = ocetra(i,j,k,iiron) - riron*rnoi*(fdetamox*amox + fdetnitr*nitr) - ocetra(i,j,k,ioxygen) = ocetra(i,j,k,ioxygen) - (1.5*fno2 + fn2o - ro2nnit*fdetamox)*amox & - & - (0.5 - ro2nnit*fdetnitr)*nitr - ocetra(i,j,k,ialkali) = ocetra(i,j,k,ialkali) - (2.*fno2 + fn2o + rnm1*rnoi*fdetamox)*amox - rnm1*rnoi*fdetnitr*nitr - - ! Output - nitr_NH4(i,j,k) = amox ! kmol N/m3/dtb - NH4 consumption for nitrification on NH4-incl. usage for biomass - nitr_NO2(i,j,k) = nitr ! kmol N/m3/dtb - NO2 consumption for nitrification on NO2 - nitr_N2O_prod(i,j,k) = 0.5*fn2o*amox ! kmol N2O/m3/dtb - N2O production during aerob ammonium oxidation - nitr_NH4_OM(i,j,k) = rnoi*fdetamox*amox ! kmol P/m3/dtb - organic matter production during aerob NH4 oxidation - nitr_NO2_OM(i,j,k) = rnoi*fdetnitr*nitr ! kmol P/m3/dtb - organic matter production during aerob NO2 oxidation + totd = max(0., & + & min(totd, & + & ocetra(i,j,k,ianh4)/(amoxfrac + fdetnitr*nitrfrac + eps), & ! ammonium + & ocetra(i,j,k,isco212)/(rc2n*(fdetamox*amoxfrac + fdetnitr*nitrfrac) + eps), & ! CO2 + & ocetra(i,j,k,iphosph)/(rnoi*(fdetamox*amoxfrac + fdetnitr*nitrfrac) + eps), & ! PO4 + & ocetra(i,j,k,iiron)/(riron*rnoi*(fdetamox*amoxfrac + fdetnitr*nitrfrac) + eps), & ! Fe + & ocetra(i,j,k,ioxygen) & + & /((1.5*fno2 + fn2o - ro2nnit*fdetamox)*amoxfrac + (0.5 - ro2nnit*fdetnitr)*nitrfrac + eps), & ! O2 + & ocetra(i,j,k,ialkali) & + & /((2.*fno2 + fn2o + rnm1*rnoi*fdetamox)*amoxfrac + (rnm1*rnoi*fdetnitr)*nitrfrac + eps))) ! alkalinity + amox = amoxfrac*totd + nitr = nitrfrac*totd + + ocetra(i,j,k,ianh4) = ocetra(i,j,k,ianh4) - amox - fdetnitr*nitr + ocetra(i,j,k,ian2o) = ocetra(i,j,k,ian2o) + 0.5*fn2o*amox + ocetra(i,j,k,iano2) = ocetra(i,j,k,iano2) + fno2*amox - nitr + ocetra(i,j,k,iano3) = ocetra(i,j,k,iano3) + nitr + ocetra(i,j,k,idet) = ocetra(i,j,k,idet) + rnoi*(fdetamox*amox + fdetnitr*nitr) + ocetra(i,j,k,isco212) = ocetra(i,j,k,isco212) - rc2n*(fdetamox*amox + fdetnitr*nitr) + ocetra(i,j,k,iphosph) = ocetra(i,j,k,iphosph) - rnoi*(fdetamox*amox + fdetnitr*nitr) + ocetra(i,j,k,iiron) = ocetra(i,j,k,iiron) - riron*rnoi*(fdetamox*amox + fdetnitr*nitr) + ocetra(i,j,k,ioxygen) = ocetra(i,j,k,ioxygen) - (1.5*fno2 + fn2o - ro2nnit*fdetamox)*amox & + & - (0.5 - ro2nnit*fdetnitr)*nitr + ocetra(i,j,k,ialkali) = ocetra(i,j,k,ialkali) - (2.*fno2 + fn2o + rnm1*rnoi*fdetamox)*amox - rnm1*rnoi*fdetnitr*nitr + + ! Output + nitr_NH4(i,j,k) = amox ! kmol N/m3/dtb - NH4 consumption for nitrification on NH4-incl. usage for biomass + nitr_NO2(i,j,k) = nitr ! kmol N/m3/dtb - NO2 consumption for nitrification on NO2 + nitr_N2O_prod(i,j,k) = 0.5*fn2o*amox ! kmol N2O/m3/dtb - N2O production during aerob ammonium oxidation + nitr_NH4_OM(i,j,k) = rnoi*fdetamox*amox ! kmol P/m3/dtb - organic matter production during aerob NH4 oxidation + nitr_NO2_OM(i,j,k) = rnoi*fdetnitr*nitr ! kmol P/m3/dtb - organic matter production during aerob NO2 oxidation - endif - enddo - enddo + endif + enddo + enddo enddo !$OMP END PARALLEL DO @@ -337,10 +372,10 @@ subroutine denit_NO3_to_NO2(kpie,kpje,kpke,kbnd,pddpo,omask,ptho) !$OMP PARALLEL DO PRIVATE(i,k,Tdep,O2inhib,nutlim,ano3new,ano3denit,temp) do j = 1,kpje - do i = 1,kpie - do k = 1,kpke - if(pddpo(i,j,k) > dp_min .and. omask(i,j) > 0.5) then - if(ocetra(i,j,k,ioxygen) < minlim_ox .and. ocetra(i,j,k,iano3)>minlim_no3)then + do i = 1,kpie + do k = 1,kpke + if(pddpo(i,j,k) > dp_min .and. omask(i,j) > 0.5) then +! if(ocetra(i,j,k,ioxygen) < minlim_ox .and. ocetra(i,j,k,iano3)>minlim_no3)then temp = merge(ptho(i,j,k),10.,ptho(i,j,k)<40.) Tdep = q10ano3denit**((temp-Trefano3denit)/10.) O2inhib = 1. - tanh(sc_ano3denit*ocetra(i,j,k,ioxygen)) @@ -361,10 +396,10 @@ subroutine denit_NO3_to_NO2(kpie,kpje,kpke,kbnd,pddpo,omask,ptho) ! Output denit_NO3(i,j,k) = ano3denit ! kmol NO3/m3/dtb - NO3 usage for denit on NO3 - endif - endif - enddo - enddo +! endif + endif + enddo + enddo enddo !$OMP END PARALLEL DO @@ -395,10 +430,10 @@ subroutine anammox(kpie,kpje,kpke,kbnd,pddpo,omask,ptho) !$OMP PARALLEL DO PRIVATE(i,k,Tdep,O2inhib,nut1lim,nut2lim,ano2new,ano2anmx,temp) do j = 1,kpje - do i = 1,kpie - do k = 1,kpke - if(pddpo(i,j,k) > dp_min .and. omask(i,j) > 0.5) then - if(ocetra(i,j,k,iano2)>minlim_no2 .and. ocetra(i,j,k,ianh4)>minlim_nh4 .and. ocetra(i,j,k,ioxygen) dp_min .and. omask(i,j) > 0.5) then +! if(ocetra(i,j,k,iano2)>minlim_no2 .and. ocetra(i,j,k,ianh4)>minlim_nh4 .and. ocetra(i,j,k,ioxygen) dp_min .and. omask(i,j) > 0.5) then + do i = 1,kpie + do k = 1,kpke + if(pddpo(i,j,k) > dp_min .and. omask(i,j) > 0.5) then potddet = 0. an2odenit = 0. ano2denit = 0. ano2dnra = 0. - if(0.<=ocetra(i,j,k,ioxygen) .and. ocetra(i,j,k,ioxygen)minlim_n2o)then +! if(0.<=ocetra(i,j,k,ioxygen) .and. ocetra(i,j,k,ioxygen)minlim_n2o)then temp = merge(ptho(i,j,k),10.,ptho(i,j,k)<40.) ! === denitrification on N2O Tdepan2o = q10an2odenit**((temp-Trefan2odenit)/10.) @@ -488,9 +523,9 @@ subroutine denit_dnra(kpie,kpje,kpke,kbnd,pddpo,omask,ptho) nutliman2o = ocetra(i,j,k,ian2o)/(ocetra(i,j,k,ian2o) + bkan2odenit) an2onew = ocetra(i,j,k,ian2o)/(1. + ran2odenit*Tdepan2o*O2inhiban2o*nutliman2o) an2odenit = max(0.,min(ocetra(i,j,k,ian2o),ocetra(i,j,k,ian2o) - an2onew)) - endif +! endif - if(0.<=ocetra(i,j,k,ioxygen) .and. ocetra(i,j,k,ioxygen)minlim_no2)then +! if(0.<=ocetra(i,j,k,ioxygen) .and. ocetra(i,j,k,ioxygen)minlim_no2)then temp = merge(ptho(i,j,k),10.,ptho(i,j,k)<40.) ! denitrification on NO2 Tdepano2 = q10ano2denit**((temp-Trefano2denit)/10.) @@ -516,7 +551,7 @@ subroutine denit_dnra(kpie,kpje,kpke,kbnd,pddpo,omask,ptho) ! potential fractional change ano2denit = fdenit * potdano2 ano2dnra = fdnra * potdano2 - endif +! endif ! limitation of processes due to detritus potddet = rnoxpi*(ano2denit + an2odenit) + rno2dnrai*ano2dnra ! P units @@ -525,7 +560,7 @@ subroutine denit_dnra(kpie,kpje,kpke,kbnd,pddpo,omask,ptho) fdetdnra = 1. - fdetano2denit - fdetan2odenit potddet = max(0.,min(potddet,ocetra(i,j,k,idet))) - if(potddet>0.)then +! if(potddet>0.)then ! change of NO2 and N2O in N units ano2denit = fdetano2denit*rnoxp*potddet an2odenit = fdetan2odenit*rnoxp*potddet @@ -546,10 +581,10 @@ subroutine denit_dnra(kpie,kpje,kpke,kbnd,pddpo,omask,ptho) denit_NO2(i,j,k) = ano2denit ! kmol NO2/m3/dtb - denitrification on NO2 denit_N2O(i,j,k) = an2odenit ! kmol N2O/m3/dtb - denitrification on N2O DNRA_NO2(i,j,k) = ano2dnra ! kmol NO2/m3/dtb - DNRA on NO2 - endif - endif - enddo - enddo +! endif + endif + enddo + enddo enddo !$OMP END PARALLEL DO end subroutine denit_dnra diff --git a/hamocc/mo_extNsediment.F90 b/hamocc/mo_extNsediment.F90 new file mode 100644 index 00000000..8e358254 --- /dev/null +++ b/hamocc/mo_extNsediment.F90 @@ -0,0 +1,538 @@ +! Copyright (C) 2022 j. maerz +! +! This file is part of BLOM/iHAMOCC. +! +! 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 https://www.gnu.org/licenses/. + +MODULE mo_extNsediment + !********************************************************************** + ! + ! MODULE mo_extNsediment - extended nitrogen cycle processes + ! in the sediment + ! + ! j.maerz 13.09.2022 + ! + ! Pupose: + ! ------- + ! - initialization of sediment related parameters of the + ! extended nitrogen cycle + ! - representation of microbial processes + ! + ! Description: + ! ------------ + ! The module holds the sequentially operated processes of: + ! - nitrification + ! - denitrification/dissimilatory nitrate reduction from NO3 to NO2 + ! - anammox + ! - denitrification processes from NO2 -> N2O -> N2 and DNRA + ! (dissimilatory nitrite reduction to ammonium) + ! + ! The process of ammonification in the sediment for the extended + ! nitrogen cycle is handled inside powach.F90. + ! + !********************************************************************** + use mo_param1_bgc, only: issso12,ipowaic,ipowaal,ipowaph,ipowaox,ipown2,ipowno3,ipownh4,ipown2o,ipowno2,ks + use mo_vgrid, only: kbo + use mo_biomod, only: rnit,rcar,rnoi + use mo_control_bgc,only: dtb + use mo_sedmnt, only: powtra,sedlay,porsol,porwat + use mo_extNbioproc,only: rc2n,ro2utammo,ro2nnit,rnoxp,rnoxpi,rno2anmx,rno2anmxi,rnh4anmx, & + & rnh4anmxi,rno2dnra,rno2dnrai,rnh4dnra,rnh4dnrai,rnm1 + + implicit none + + private + + ! public functions + public :: extNsediment_param_init,sed_nitrification,sed_denit_NO3_to_NO2,sed_anammox,sed_denit_DNRA,alloc_mem_extNsediment_diag + + ! public parameters and fields + public :: ised_nitr_NH4,ised_nitr_NO2,ised_nitr_N2O_prod,ised_nitr_NH4_OM,ised_nitr_NO2_OM,ised_denit_NO3,ised_denit_NO2, & + ised_denit_N2O,ised_DNRA_NO2,ised_anmx_N2_prod,ised_anmx_OM_prod,ised_remin_aerob,ised_remin_sulf,extNsed_diagnostics, & + POM_remin_q10_sed, POM_remin_Tref_sed,bkox_drempoc_sed + + ! extended nitrogen cycle sediment parameters + real :: q10ano3denit_sed,sc_ano3denit_sed,Trefano3denit_sed,rano3denit_sed,bkano3denit_sed, & + & rano2anmx_sed,q10anmx_sed,Trefanmx_sed,alphaanmx_sed,bkoxanmx_sed,bkano2anmx_sed,bkanh4anmx_sed, & + & rano2denit_sed,q10ano2denit_sed,Trefano2denit_sed,bkoxano2denit_sed,bkano2denit_sed, & + & ran2odenit_sed,q10an2odenit_sed,Trefan2odenit_sed,bkoxan2odenit_sed,bkan2odenit_sed, & + & rdnra_sed,q10dnra_sed,Trefdnra_sed,bkoxdnra_sed,bkdnra_sed,ranh4nitr_sed,q10anh4nitr_sed, & + & Trefanh4nitr_sed,bkoxamox_sed,bkanh4nitr_sed,bkamoxn2o_sed,bkyamox_sed, & + & rano2nitr_sed,q10ano2nitr_sed,Trefano2nitr_sed,bkoxnitr_sed,bkano2nitr_sed,n2omaxy_sed, & + & n2oybeta_sed,NOB2AOAy_sed,bn2o_sed,mufn2o_sed,POM_remin_q10_sed, POM_remin_Tref_sed,bkox_drempoc_sed + + ! output + real, dimension (:,:,:,:), allocatable :: extNsed_diagnostics + integer, parameter :: & + ised_nitr_NH4 = 1, & + ised_nitr_NO2 = 2, & + ised_nitr_N2O_prod = 3, & + ised_nitr_NH4_OM = 4, & + ised_nitr_NO2_OM = 5, & + ised_denit_NO3 = 6, & + ised_denit_NO2 = 7, & + ised_denit_N2O = 8, & + ised_DNRA_NO2 = 9, & + ised_anmx_N2_prod = 10, & + ised_anmx_OM_prod = 11, & + ised_remin_aerob = 12, & + ised_remin_sulf = 13, & + n_seddiag = 13 + + real :: eps,minlim + + contains + + ! ================================================================================================================================ + subroutine alloc_mem_extNsediment_diag(kpie,kpje,ksed) + use mod_xc, only: mnproc + use mo_control_bgc, only: io_stdo_bgc + + implicit none + + INTEGER, intent(in) :: kpie,kpje,ksed ! ksed = ks + INTEGER :: errstat + + + IF (mnproc.eq.1) THEN + WRITE(io_stdo_bgc,*)'Memory allocation for sediment output of the extended nitrogen cycle ...' + WRITE(io_stdo_bgc,*)'First dimension : ',kpie + WRITE(io_stdo_bgc,*)'Second dimension : ',kpje + WRITE(io_stdo_bgc,*)'Third dimension : ',ksed + WRITE(io_stdo_bgc,*)'Fourth dimension : ',n_seddiag + ENDIF + + ALLOCATE (extNsed_diagnostics(kpie,kpje,ksed,n_seddiag),stat=errstat) + + if(errstat.ne.0) stop 'not enough memory extended nitrogen cycle' + + end subroutine alloc_mem_extNsediment_diag + + ! ================================================================================================================================ + subroutine extNsediment_param_init() + use mo_extNbioproc,only: q10ano3denit,sc_ano3denit,Trefano3denit,bkano3denit, & + & q10anmx,Trefanmx,alphaanmx,bkoxanmx,bkano2anmx, & + & q10ano2denit,Trefano2denit,bkoxano2denit,bkano2denit, & + & q10an2odenit,Trefan2odenit,bkoxan2odenit,bkan2odenit, & + & q10dnra,Trefdnra,bkoxdnra,bkdnra, & + & q10anh4nitr,Trefanh4nitr,bkoxamox,bkanh4nitr,bkamoxn2o,bkyamox,n2omaxy,n2oybeta, & + & q10ano2nitr,Trefano2nitr,bkoxnitr,bkano2nitr,NOB2AOAy,rno2anmx,rnh4anmx + use mo_m4ago, only: POM_remin_q10,POM_remin_Tref + use mo_biomod, only: bkox_drempoc + + implicit none + + ! === Ammonification in the sediment + POM_remin_q10_sed = POM_remin_q10 ! ammonification Q10 in sediment + POM_remin_Tref_sed = POM_remin_Tref ! ammonification Tref in sediment + bkox_drempoc_sed = bkox_drempoc ! half saturation constant for O2 limitatio of ammonification in sediment + + ! === Denitrification step NO3 -> NO2: + !rano3denit_sed = 0.15*dtb ! Maximum growth rate denitrification on NO3 at reference T (1/d -> 1/dt) + rano3denit_sed = 0.05*dtb ! Maximum growth rate denitrification on NO3 at reference T (1/d -> 1/dt) + q10ano3denit_sed = q10ano3denit ! Q10 factor for denitrification on NO3 (-) + Trefano3denit_sed = Trefano3denit ! Reference temperature for denitrification on NO3 (degr C) + !sc_ano3denit_sed = 0.05e6 ! Shape factor for NO3 denitrification oxygen inhibition function (m3/kmol) + sc_ano3denit_sed = sc_ano3denit ! Shape factor for NO3 denitrification oxygen inhibition function (m3/kmol) + bkano3denit_sed = bkano3denit ! Half-saturation constant for NO3 denitrification (kmol/m3) + + ! === Anammox + rano2anmx_sed = 0.05*dtb ! Maximum growth rate for anammox at reference T (1/d -> 1/dt) + q10anmx_sed = q10anmx ! Q10 factor for anammox (-) + Trefanmx_sed = Trefanmx ! Reference temperature for anammox (degr C) + alphaanmx_sed = alphaanmx ! Shape factor for anammox oxygen inhibition function (m3/kmol) + bkoxanmx_sed = bkoxanmx ! Half-saturation constant for oxygen inhibition function (kmol/m3) + bkano2anmx_sed = bkano2anmx ! Half-saturation constant for NO2 limitation (kmol/m3) + bkanh4anmx_sed = bkano2anmx_sed * rnh4anmx/rno2anmx !Half-saturation constant for NH4 limitation of anammox (kmol/m3) + + ! === Denitrification step NO2 -> N2O + rano2denit_sed = 0.12*dtb ! Maximum growth rate denitrification on NO2 at reference T (1/d -> 1/dt) + q10ano2denit_sed = q10ano2denit ! Q10 factor for denitrification on NO2 (-) + Trefano2denit_sed = Trefano2denit ! Reference temperature for denitrification on NO2 (degr C) + bkoxano2denit_sed = bkoxano2denit ! Half-saturation constant for (quadratic) oxygen inhibition function of denitrification on NO2 (kmol/m3) + bkano2denit_sed = bkano2denit ! Half-saturation constant for denitrification on NO2 (kmol/m3) + + ! === Denitrification step N2O -> N2 + ran2odenit_sed = 0.16*dtb ! Maximum growth rate denitrification on N2O at reference T (1/d -> 1/dt) + q10an2odenit_sed = q10an2odenit ! Q1- factor for denitrificationj on N2O (-) + Trefan2odenit_sed = Trefan2odenit ! Reference temperature for denitrification on N2O (degr C) + bkoxan2odenit_sed = bkoxan2odenit ! Half-saturation constant for (quadratic) oxygen inhibition function of denitrification on N2O (kmol/m3) + bkan2odenit_sed = bkan2odenit ! Half-saturation constant for denitrification on N2O (kmol/m3) + + ! === DNRA NO2 -> NH4 + rdnra_sed = 0.1*dtb ! Maximum growth rate DNRA on NO2 at reference T (1/d -> 1/dt) + q10dnra_sed = q10dnra ! Q10 factor for DNRA on NO2 (-) + Trefdnra_sed = Trefdnra ! Reference temperature for DNRA (degr C) + bkoxdnra_sed = bkoxdnra ! Half saturation constant for (quadratic) oxygen inhibition function of DNRA on NO2 (kmol/m3) + bkdnra_sed = bkdnra ! Half-saturation constant for DNRA on NO2 (kmol/m3) + + ! === Nitrification on NH4 + ranh4nitr_sed = 1.*dtb ! Maximum growth rate nitrification on NH4 at reference T (1/d -> 1/dt) + q10anh4nitr_sed = q10anh4nitr ! Q10 factor for nitrification on NH4 (-) + Trefanh4nitr_sed = Trefanh4nitr ! Reference temperature for nitrification on NH4 (degr C) + bkoxamox_sed = bkoxamox ! Half-saturation constant for oxygen limitation of nitrification on NH4 (kmol/m3) + bkanh4nitr_sed = bkanh4nitr ! Half-saturation constant for nitrification on NH4 (kmol/m3) +!====== +! OLD VERSION OF pathway splitting function + !bkamoxn2o_sed = 0.453e-6 ! Half saturation constant for O2 in pathway splitting function N2O for nitrification on NH4 (kmol/m3) +! NEW version similar to Santoros 2021, Ji 2018: + bkamoxn2o_sed = bkamoxn2o ! Half saturation constant for NH4 in pathway splitting function N2O for nitrification on NH4 (kmol/m3) + mufn2o_sed = 0.11/(50.*1e6*bkoxamox_sed) !=6.61e-3 0.11/(50*1e6)=2.2e-9 - ~Santoro et al. 2011 with simple MM, + bn2o_sed = 0.077/(50.*mufn2o_sed) !=0.2331 - before set to 0.3 - base fraction entering N2O +!====== + !bkamoxno2_sed = 0.479e-6 ! Half saturation constant for pathway splitting function N2O for nitrification on NH4 (kmol/m3) + ! bkamoxno2_sed = bkamoxno2 ! Half saturation constant for pathway splitting function N2O for nitrification on NH4 (kmol/m3) + n2omaxy_sed = n2omaxy ! Maximum yield of OM on NH4 nitrification (-) + n2oybeta_sed = n2oybeta ! Decay factor for inhibition function for yield during nitrification on NH4 (kmol/m3) + bkyamox_sed = bkyamox ! Half saturation constant for pathway splitting function OM-yield for nitrification on NH4 (kmol/m3) + + ! === Nitrification on NO2 + rano2nitr_sed = 1.54*dtb ! Maximum growth rate nitrification on NO2 at reference T (1/d -> 1/dt) + q10ano2nitr_sed = q10ano2nitr ! Q10 factor for nitrification on NO2 (-) + Trefano2nitr_sed = Trefano2nitr ! Reference temperature for nitrification on NO2 (degr C) + bkoxnitr_sed = bkoxnitr ! Half-saturation constant for oxygen limitation of nitrification on NO2 (kmol/m3) + bkano2nitr_sed = bkano2nitr ! Half-saturation constant for NO2 for nitrification on NO2 (kmol/m3) + NOB2AOAy_sed = NOB2AOAy ! Ratio of NOB versus AOA yield per energy source ~0.043/0.098 according to Zakem et al. 2022 + + eps = 1.e-25 ! safe division etc. + minlim = 1.e-9 ! minimum for limitation functions (e.g. nutlim or oxlim/inh can only decrease to minlim) + end subroutine extNsediment_param_init + + ! ================================================================================================================================ + subroutine sed_nitrification(j,kpie,kpje,kpke,kbnd,ptho,omask,ex_ddic,ex_dalk) + integer, intent(in) :: j,kpie,kpje,kpke,kbnd + real, intent(in) :: omask(kpie,kpje) + real, intent(in) :: ptho(1-kbnd:kpie+kbnd,1-kbnd:kpje+kbnd,kpke) + ! for calculation of pore water DIC and alkalinity changes [P-units]! + real, intent(inout) :: ex_ddic(kpie,ks) + real, intent(inout) :: ex_dalk(kpie,ks) + + ! local variables + integer :: i,k + + real :: Tdepanh4,O2limanh4,nut1lim,anh4new,potdnh4amox,fdetamox,fno2,fn2o,ftotnh4 + real :: Tdepano2,O2limano2,nut2lim,ano2new,potdno2nitr,fdetnitr,no2fn2o,no2fno2,no2fdetamox + real :: amoxfrac,nitrfrac,totd,amox,nitr,temp,w2s + + do i = 1,kpie + do k = 1,ks + if(omask(i,j)>0.5) then + potdnh4amox = 0. + fn2o = 0. + fno2 = 0. + fdetamox = 0. + potdno2nitr = 0. + fdetnitr = 0. + w2s = porwat(i,j,k) / porsol(i,j,k) + +! if(ocetra(i,j,k,ioxygen)>minlim_oxnh4 .and. ocetra(i,j,k,ianh4)>minlim_nh4)then + temp = merge(ptho(i,j,kbo(i,j)),10.,ptho(i,j,kbo(i,j))<40.) + ! Ammonium oxidation step of nitrification + Tdepanh4 = q10anh4nitr_sed**((temp-Trefanh4nitr_sed)/10.) + O2limanh4 = powtra(i,j,k,ipowaox)/(powtra(i,j,k,ipowaox) + bkoxamox_sed) + nut1lim = powtra(i,j,k,ipownh4)/(powtra(i,j,k,ipownh4) + bkanh4nitr_sed) + anh4new = powtra(i,j,k,ipownh4)/(1. + ranh4nitr_sed*Tdepanh4*O2limanh4*nut1lim) + potdnh4amox = max(0.,powtra(i,j,k,ipownh4) - anh4new) + + ! pathway splitting functions according to Goreau 1980 + !===== + ! OLD version according to Goreau + !fn2o = 1. - ocetra(i,j,k,ioxygen)/(ocetra(i,j,k,ioxygen) + bkamoxn2o) + ! NEW version similar to Santoros et al. 2021, Ji et al. 2018 + fn2o = mufn2o_sed * (bn2o_sed + (1.-bn2o_sed)*bkoxamox_sed/(powtra(i,j,k,ipowaox)+bkoxamox_sed)) & + & * powtra(i,j,k,ipownh4)/(powtra(i,j,k,ipownh4)+bkamoxn2o_sed) + !===== + fno2 = powtra(i,j,k,ipowaox)/(powtra(i,j,k,ipowaox) + bkoxamox_sed) + fdetamox = n2omaxy_sed*2.*(1. + n2oybeta_sed)*powtra(i,j,k,ipowaox)*bkyamox_sed & + & /(powtra(i,j,k,ipowaox)**2 + 2.*powtra(i,j,k,ipowaox)*bkyamox_sed + bkyamox_sed**2) + + ! normalization of pathway splitting functions to sum=1 + ftotnh4 = fn2o + fno2 + fdetamox + eps + fn2o = fn2o/ftotnh4 + fno2 = fno2/ftotnh4 + fdetamox = 1. - (fn2o + fno2) +! endif + +! if(ocetra(i,j,k,ioxygen)>minlim_oxno2 .and. ocetra(i,j,k,iano2)>minlim_no2)then +! temp = merge(ptho(i,j,kbo(i,j)),10.,ptho(i,j,kbo(i,j))<40.) + ! NO2 oxidizing step of nitrification + Tdepano2 = q10ano2nitr_sed**((temp-Trefano2nitr_sed)/10.) + O2limano2 = powtra(i,j,k,ipowaox)/(powtra(i,j,k,ipowaox) + bkoxnitr_sed) + nut2lim = powtra(i,j,k,ipowno2)/(powtra(i,j,k,ipowno2) + bkano2nitr_sed) + ano2new = powtra(i,j,k,ipowno2)/(1. + rano2nitr_sed*Tdepano2*O2limano2*nut2lim) + potdno2nitr = max(0.,powtra(i,j,k,ipowno2) - ano2new) + + ! pathway splitting functions for NO2 nitrification - assuming to be the same as for NH4 + ! but with reduced OM gain per used NO2 as energy source (in amox: NH4) + + no2fn2o = mufn2o_sed * (bn2o_sed + (1.-bn2o_sed)*bkoxamox_sed/(powtra(i,j,k,ipowaox)+bkoxamox_sed)) & + & * powtra(i,j,k,ipownh4)/(powtra(i,j,k,ipownh4)+bkamoxn2o_sed) + no2fno2 = powtra(i,j,k,ipowaox)/(powtra(i,j,k,ipowaox) + bkoxamox_sed) + no2fdetamox = NOB2AOAy_sed*n2omaxy_sed*2.*(1. + n2oybeta_sed)*powtra(i,j,k,ipowaox)*bkyamox_sed & + & /(powtra(i,j,k,ipowaox)**2 + 2.*powtra(i,j,k,ipowaox)*bkyamox_sed + bkyamox_sed**2) + + fdetnitr = no2fdetamox/(no2fno2 + no2fn2o) ! yield to energy usage ratio for NO2 -> ratio equals 16:x +! endif + + ! limitation of the two processes through available nutrients, etc. + totd = potdnh4amox + potdno2nitr + amoxfrac = potdnh4amox/(totd + eps) + nitrfrac = 1. - amoxfrac + + ! Account for potential earlier changes in DIC and alkalinity in finiding the minimum + totd = max(0., & + & min(totd, & + & powtra(i,j,k,ipownh4)/(amoxfrac + fdetnitr*nitrfrac + eps), & ! ammonium + & (powtra(i,j,k,ipowaic)+ex_ddic(i,k))/(rc2n*(fdetamox*amoxfrac + fdetnitr*nitrfrac) + eps), & ! CO2 + & powtra(i,j,k,ipowaph)/(rnoi*(fdetamox*amoxfrac + fdetnitr*nitrfrac) + eps), & ! PO4 + & powtra(i,j,k,ipowaox) & + & /((1.5*fno2 + fn2o - ro2nnit*fdetamox)*amoxfrac + (0.5 - ro2nnit*fdetnitr)*nitrfrac + eps), & ! O2 + & (powtra(i,j,k,ipowaal) + ex_dalk(i,k)) & + & /((2.*fno2 + fn2o + rnm1*rnoi*fdetamox)*amoxfrac + (rnm1*rnoi*fdetnitr)*nitrfrac + eps))) ! alkalinity + amox = amoxfrac*totd + nitr = nitrfrac*totd + + powtra(i,j,k,ipownh4) = powtra(i,j,k,ipownh4) - amox - fdetnitr*nitr + powtra(i,j,k,ipown2o) = powtra(i,j,k,ipown2o) + 0.5*fn2o*amox + powtra(i,j,k,ipowno2) = powtra(i,j,k,ipowno2) + fno2*amox - nitr + powtra(i,j,k,ipowno3) = powtra(i,j,k,ipowno3) + nitr + sedlay(i,j,k,issso12) = sedlay(i,j,k,issso12) + rnoi*(fdetamox*amox + fdetnitr*nitr) * w2s +! ocetra(i,j,k,isco212) = ocetra(i,j,k,isco212) - rc2n*(fdetamox*amox + fdetnitr*nitr) + powtra(i,j,k,ipowaph) = powtra(i,j,k,ipowaph) - rnoi*(fdetamox*amox + fdetnitr*nitr) +! ocetra(i,j,k,iiron) = ocetra(i,j,k,iiron) - riron*rnoi*(fdetamox*amox + fdetnitr*nitr) + powtra(i,j,k,ipowaox) = powtra(i,j,k,ipowaox) - (1.5*fno2 + fn2o - ro2nnit*fdetamox)*amox & + & - (0.5 - ro2nnit*fdetnitr)*nitr +! ocetra(i,j,k,ialkali) = ocetra(i,j,k,ialkali) - (2.*fno2 + fn2o + rnm1*rnoi*fdetamox)*amox - rnm1*rnoi*fdetnitr*nitr + + ! update of DIC and alkalinity through ex_ddic and ex_dalk fields + ! at later stage, when undersaturation of CaCO3 has been calculted + ex_ddic(i,k) = ex_ddic(i,k) - rc2n*(fdetamox*amox + fdetnitr*nitr) + ex_dalk(i,k) = ex_dalk(i,k) - (2.*fno2 + fn2o + rnm1*rnoi*fdetamox)*amox - rnm1*rnoi*fdetnitr*nitr + + ! output: + extNsed_diagnostics(i,j,k,ised_nitr_NH4) = amox + extNsed_diagnostics(i,j,k,ised_nitr_NO2) = nitr + extNsed_diagnostics(i,j,k,ised_nitr_N2O_prod) = 0.5*fn2o*amox + extNsed_diagnostics(i,j,k,ised_nitr_NH4_OM) = rnoi*fdetamox*amox * w2s + extNsed_diagnostics(i,j,k,ised_nitr_NO2_OM) = rnoi*fdetnitr*nitr * w2s + endif + enddo + enddo + end subroutine sed_nitrification + + ! ================================================================================================================================ + subroutine sed_denit_NO3_to_NO2(j,kpie,kpje,kpke,kbnd,ptho,omask,ex_ddic,ex_dalk) + integer, intent(in) :: j,kpie,kpje,kpke,kbnd + real, intent(in) :: omask(kpie,kpje) + real, intent(in) :: ptho(1-kbnd:kpie+kbnd,1-kbnd:kpje+kbnd,kpke) + ! for calculation of pore water DIC and alkalinity changes [P-units]! + real, intent(inout) :: ex_ddic(kpie,ks) + real, intent(inout) :: ex_dalk(kpie,ks) + + ! local variables + integer :: i,k + real :: Tdep,O2inhib,nutlim,ano3new,ano3denit,temp,s2w + + do i = 1,kpie + do k = 1,ks + if(omask(i,j)>0.5) then + s2w = porsol(i,j,k) / porwat(i,j,k) + temp = merge(ptho(i,j,kbo(i,j)),10.,ptho(i,j,kbo(i,j))<40.) + Tdep = q10ano3denit_sed**((temp-Trefano3denit_sed)/10.) + O2inhib = 1. - tanh(sc_ano3denit_sed*powtra(i,j,k,ipowaox)) + nutlim = powtra(i,j,k,ipowno3)/(powtra(i,j,k,ipowno3) + bkano3denit_sed) + + ano3new = powtra(i,j,k,ipowno3)/(1. + rano3denit_sed*Tdep*O2inhib*nutlim) + + ano3denit = max(0.,min(powtra(i,j,k,ipowno3) - ano3new, sedlay(i,j,k,issso12)*rnoxp*s2w)) + + powtra(i,j,k,ipowno3) = powtra(i,j,k,ipowno3) - ano3denit + powtra(i,j,k,ipowno2) = powtra(i,j,k,ipowno2) + ano3denit + sedlay(i,j,k,issso12) = sedlay(i,j,k,issso12) - ano3denit*rnoxpi/s2w + powtra(i,j,k,ipownh4) = powtra(i,j,k,ipownh4) + ano3denit*rnit*rnoxpi + powtra(i,j,k,ipowaph) = powtra(i,j,k,ipowaph) + ano3denit*rnoxpi + !ocetra(i,j,k,isco212) = ocetra(i,j,k,isco212) + ano3denit*rcar*rnoxpi + !ocetra(i,j,k,ialkali) = ocetra(i,j,k,ialkali) + ano3denit*rnm1*rnoxpi + + ! update of DIC and alkalinity through ex_ddic and ex_dalk fields + ! at later stage, when undersaturation of CaCO3 has been calculted + ex_ddic(i,k) = ex_ddic(i,k) + ano3denit*rcar*rnoxpi + ex_dalk(i,k) = ex_dalk(i,k) + ano3denit*rnm1*rnoxpi + + ! Output: + extNsed_diagnostics(i,j,k,ised_denit_NO3) = ano3denit + endif + enddo + enddo + + end subroutine sed_denit_NO3_to_NO2 + + ! ================================================================================================================================ + subroutine sed_anammox(j,kpie,kpje,kpke,kbnd,ptho,omask,ex_ddic,ex_dalk) + integer, intent(in) :: j,kpie,kpje,kpke,kbnd + real, intent(in) :: omask(kpie,kpje) + real, intent(in) :: ptho(1-kbnd:kpie+kbnd,1-kbnd:kpje+kbnd,kpke) + ! for calculation of pore water DIC and alkalinity changes [P-units]! + real, intent(inout) :: ex_ddic(kpie,ks) + real, intent(inout) :: ex_dalk(kpie,ks) + + ! local variables + integer :: i,k + real :: Tdep,O2inhib,nut1lim,nut2lim,ano2new,ano2anmx,temp,w2s + + do i = 1,kpie + do k = 1,ks + if(omask(i,j)>0.5) then + w2s = porwat(i,j,k) / porsol(i,j,k) + temp = merge(ptho(i,j,kbo(i,j)),10.,ptho(i,j,kbo(i,j))<40.) + Tdep = q10anmx_sed**((temp-Trefanmx_sed)/10.) + O2inhib = 1. - exp(alphaanmx_sed*(powtra(i,j,k,ipowaox)-bkoxanmx_sed)) & + & /(1.+ exp(alphaanmx_sed*(powtra(i,j,k,ipowaox)-bkoxanmx_sed))) + nut1lim = powtra(i,j,k,ipowno2)/(powtra(i,j,k,ipowno2)+bkano2anmx_sed) + nut2lim = powtra(i,j,k,ipownh4)/(powtra(i,j,k,ipownh4)+bkanh4anmx_sed) + + ano2new = powtra(i,j,k,ipowno2)/(1. + rano2anmx_sed*Tdep*O2inhib*nut1lim*nut2lim) + + ! Account for former changes in DIC and alkalinity + ano2anmx = max(0.,min(powtra(i,j,k,ipowno2) - ano2new, powtra(i,j,k,ipownh4)*rno2anmx*rnh4anmxi, & + (powtra(i,j,k,ipowaic)+ex_ddic(i,k))*rno2anmx/rcar, powtra(i,j,k,ipowaph)*rno2anmx, & + (powtra(i,j,k,ipowaal)+ex_dalk(i,k))*rno2anmx/rnm1)) + + powtra(i,j,k,ipowno2) = powtra(i,j,k,ipowno2) - ano2anmx + powtra(i,j,k,ipownh4) = powtra(i,j,k,ipownh4) - ano2anmx*rnh4anmx*rno2anmxi + powtra(i,j,k,ipown2) = powtra(i,j,k,ipown2) + ano2anmx*(rnh4anmx-rnit)*rno2anmxi + powtra(i,j,k,ipowno3) = powtra(i,j,k,ipowno3) + ano2anmx*rnoxp*rno2anmxi + sedlay(i,j,k,issso12) = sedlay(i,j,k,issso12) + ano2anmx*rno2anmxi*w2s + powtra(i,j,k,ipowaph) = powtra(i,j,k,ipowaph) - ano2anmx*rno2anmxi +! ocetra(i,j,k,isco212) = ocetra(i,j,k,isco212) - ano2anmx*rcar*rno2anmxi +! ocetra(i,j,k,ialkali) = ocetra(i,j,k,ialkali) - ano2anmx*rnm1*rno2anmxi + + ! update of DIC and alkalinity through ex_ddic and ex_dalk fields + ! at later stage, when undersaturation of CaCO3 has been calculted + ex_ddic(i,k) = ex_ddic(i,k) - ano2anmx*rcar*rno2anmxi + ex_dalk(i,k) = ex_dalk(i,k) - ano2anmx*rnm1*rno2anmxi + + ! Output: + extNsed_diagnostics(i,j,k,ised_anmx_N2_prod) = ano2anmx*(rnh4anmx-rnit)*rno2anmxi ! kmol N2/m3/dtb - N2 prod through anammox + extNsed_diagnostics(i,j,k,ised_anmx_OM_prod) = ano2anmx*rno2anmxi*w2s + endif + enddo + enddo + + end subroutine sed_anammox + + ! ================================================================================================================================ + subroutine sed_denit_DNRA(j,kpie,kpje,kpke,kbnd,ptho,omask,ex_ddic,ex_dalk) + integer, intent(in) :: j,kpie,kpje,kpke,kbnd + real, intent(in) :: omask(kpie,kpje) + real, intent(in) :: ptho(1-kbnd:kpie+kbnd,1-kbnd:kpje+kbnd,kpke) + ! for calculation of pore water DIC and alkalinity changes [P-units]! + real, intent(inout) :: ex_ddic(kpie,ks) + real, intent(inout) :: ex_dalk(kpie,ks) + + ! local variables + integer :: i,k + real :: Tdepano2,O2inhibano2,nutlimano2,rpotano2denit,ano2denit + real :: Tdepdnra,O2inhibdnra,nutlimdnra,rpotano2dnra,ano2dnra + real :: fdenit,fdnra,potano2new,potdano2,potddet,fdetano2denit,fdetan2odenit,fdetdnra + real :: Tdepan2o,O2inhiban2o,nutliman2o,an2onew,an2odenit + real :: temp,s2w + + + do i = 1,kpie + do k = 1,ks + if(omask(i,j)>0.5) then + potddet = 0. + an2odenit = 0. + ano2denit = 0. + ano2dnra = 0. + s2w = porsol(i,j,k) / porwat(i,j,k) +! if(0.<=ocetra(i,j,k,ioxygen) .and. ocetra(i,j,k,ioxygen)minlim_n2o)then + temp = merge(ptho(i,j,kbo(i,j)),10.,ptho(i,j,kbo(i,j))<40.) + ! === denitrification on N2O + Tdepan2o = q10an2odenit_sed**((temp-Trefan2odenit_sed)/10.) + O2inhiban2o = bkoxan2odenit_sed**2/(powtra(i,j,k,ipowaox)**2 + bkoxan2odenit_sed**2) + nutliman2o = powtra(i,j,k,ipown2o)/(powtra(i,j,k,ipown2o) + bkan2odenit_sed) + an2onew = powtra(i,j,k,ipown2o)/(1. + ran2odenit_sed*Tdepan2o*O2inhiban2o*nutliman2o) + an2odenit = max(0.,min(powtra(i,j,k,ipown2o),powtra(i,j,k,ipown2o) - an2onew)) +! endif + +! if(0.<=ocetra(i,j,k,ioxygen) .and. ocetra(i,j,k,ioxygen)minlim_no2)then +! temp = merge(ptho(i,j,kbo(i,j)),10.,ptho(i,j,kbo(i,j))<40.) + ! denitrification on NO2 + Tdepano2 = q10ano2denit_sed**((temp-Trefano2denit_sed)/10.) + O2inhibano2 = bkoxano2denit_sed**2/(powtra(i,j,k,ipowaox)**2 + bkoxano2denit_sed**2) + nutlimano2 = powtra(i,j,k,ipowno2)/(powtra(i,j,k,ipowno2) + bkano2denit_sed) + rpotano2denit = max(0.,rano2denit_sed*Tdepano2*O2inhibano2*nutlimano2) ! potential rate of denit + + ! DNRA on NO2 + Tdepdnra = q10dnra_sed**((temp-Trefdnra_sed)/10.) + O2inhibdnra = bkoxdnra_sed**2/(powtra(i,j,k,ipowaox)**2 + bkoxdnra_sed**2) + nutlimdnra = powtra(i,j,k,ipowno2)/(powtra(i,j,k,ipowno2) + bkdnra_sed) + rpotano2dnra = max(0.,rdnra_sed*Tdepdnra*O2inhibdnra*nutlimdnra) ! pot. rate of dnra + + ! potential new conc of NO2 due to denitrification and DNRA + potano2new = powtra(i,j,k,ipowno2)/(1. + rpotano2denit + rpotano2dnra) + potdano2 = max(0.,min(powtra(i,j,k,ipowno2), powtra(i,j,k,ipowno2) - potano2new)) + + ! === limitation due to NO2: + ! fraction on potential change of NO2: + fdenit = rpotano2denit/(rpotano2denit + rpotano2dnra + eps) + fdnra = 1. - fdenit + + ! potential fractional change + ano2denit = fdenit * potdano2 + ano2dnra = fdnra * potdano2 + ! endif + + ! limitation of processes due to detritus (based on pore water volume) + potddet = rnoxpi*(ano2denit + an2odenit) + rno2dnrai*ano2dnra ! P units + fdetano2denit = rnoxpi*ano2denit/(potddet + eps) + fdetan2odenit = rnoxpi*an2odenit/(potddet + eps) + fdetdnra = 1. - fdetano2denit - fdetan2odenit + potddet = max(0.,min(potddet,powtra(i,j,k,issso12)*s2w)) + +! if(potddet>0.)then + ! change of NO2 and N2O in N units + ano2denit = fdetano2denit*rnoxp*potddet + an2odenit = fdetan2odenit*rnoxp*potddet + ano2dnra = fdetdnra*rno2dnra*potddet + + ! change in tracer concentrations due to denit (NO2->N2O->N2) and DNRA (NO2->NH4) + powtra(i,j,k,ipowno2) = powtra(i,j,k,ipowno2) - ano2denit - ano2dnra + powtra(i,j,k,ipown2o) = powtra(i,j,k,ipown2o) - an2odenit + 0.5*ano2denit + powtra(i,j,k,ipown2) = powtra(i,j,k,ipown2) + an2odenit + powtra(i,j,k,ipownh4) = powtra(i,j,k,ipownh4) + rnit*rnoxpi*(ano2denit+an2odenit) + rnh4dnra*rno2dnrai*ano2dnra + sedlay(i,j,k,issso12) = sedlay(i,j,k,issso12) - ((ano2denit + an2odenit)*rnoxpi + ano2dnra*rno2dnrai)/s2w + powtra(i,j,k,ipowaph) = powtra(i,j,k,ipowaph) + (ano2denit + an2odenit)*rnoxpi + ano2dnra*rno2dnrai +! ocetra(i,j,k,isco212) = ocetra(i,j,k,isco212) + rcar*rnoxpi*(ano2denit + an2odenit) + rcar*rno2dnrai*ano2dnra +! ocetra(i,j,k,iiron) = ocetra(i,j,k,iiron) + riron*rnoxpi*(ano2denit + an2odenit) + riron*rno2dnrai*ano2dnra +! ocetra(i,j,k,ialkali) = ocetra(i,j,k,ialkali) + (295.*ano2denit + rnm1*an2odenit)*rnoxpi & +! & + (rno2dnra + rnh4dnra - 1.)*rno2dnrai * ano2dnra + + ! update of DIC and alkalinity through ex_ddic and ex_dalk fields + ! at later stage, when undersaturation of CaCO3 has been calculted + ex_ddic(i,k) = ex_ddic(i,k) + rcar*rnoxpi*(ano2denit + an2odenit) + rcar*rno2dnrai*ano2dnra + ex_dalk(i,k) = ex_dalk(i,k) + (295.*ano2denit + rnm1*an2odenit)*rnoxpi + (rno2dnra + rnh4dnra - 1.)*rno2dnrai * ano2dnra + + extNsed_diagnostics(i,j,k,ised_denit_NO2) = ano2denit + extNsed_diagnostics(i,j,k,ised_denit_N2O) = an2odenit + extNsed_diagnostics(i,j,k,ised_DNRA_NO2) = ano2dnra + endif + enddo + enddo + + end subroutine sed_denit_DNRA + +END MODULE mo_extNsediment diff --git a/hamocc/mo_intfcblom.F90 b/hamocc/mo_intfcblom.F90 index 68227f7b..e0d78b3b 100644 --- a/hamocc/mo_intfcblom.F90 +++ b/hamocc/mo_intfcblom.F90 @@ -244,14 +244,16 @@ subroutine blom2hamocc(m,n,mm,nn) !****************************************************************************** ! use mod_constants, only: onem - use mod_xc, only: ii,jdm,jj,kdm,kk,ifp,isp,ilp,idm + use mod_xc, only: ii,jdm,jj,kdm,kk,ifp,isp,ilp,idm use mod_grid, only: scpx,scpy use mod_state, only: dp,temp,saln use mod_eos, only: rho,p_alpha + use mod_difest, only: hOBL use mod_tracers, only: ntrbgc,itrbgc,trc use mo_param1_bgc, only: ks,nsedtra,npowtra,natm use mo_carbch, only: ocetra,atm use mo_sedmnt, only: sedlay,powtra,sedhpl,burial + use mo_vgrid, only: kmle, kmle_static implicit none @@ -292,6 +294,11 @@ subroutine blom2hamocc(m,n,mm,nn) ! --- - dimension of grid box in meters bgc_dx(i,j) = scpx(i,j)/1.e2 bgc_dy(i,j) = scpy(i,j)/1.e2 +! +! --- - index of level above OBL depth +! --- isopycninc coords: hOBL(i,j) = hOBL_static = 3. => kmle(i,j) = 2 +! --- hybrid coords: hOBL defined according to cvmix_kpp_compute_kOBL_depth + kmle(i,j) = nint(hOBL(i,j))-1 enddo enddo !$OMP END PARALLEL DO diff --git a/hamocc/mo_m4ago.F90 b/hamocc/mo_m4ago.F90 new file mode 100644 index 00000000..597f9df6 --- /dev/null +++ b/hamocc/mo_m4ago.F90 @@ -0,0 +1,127 @@ +!> +!! @par (c) Copyright +!! This software is provided under: +!! +!! The 3-Clause BSD License +!! SPDX short identifier: BSD-3-Clause +!! See https://opensource.org/licenses/BSD-3-Clause +!! +!! (c) Copyright 2016-2021 MPI-M, Joeran Maerz, Irene Stemmler; +!! first published 2020 +!! +!! Redistribution and use in source and binary forms, with or without +!! modification, are permitted provided that the following conditions are met: +!! +!! 1. Redistributions of source code must retain the above copyright notice, +!! this list of conditions and the following disclaimer. +!! 2. Redistributions in binary form must reproduce the above copyright notice, +!! this list of conditions and the following disclaimer in the documentation +!! and/or other materials provided with the distribution. +!! 3. Neither the name of the copyright holder nor the names of its contributors +!! may be used to endorse or promote products derived from this software +!! without specific prior written permission. +!! +!! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +!! AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +!! IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +!! ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE +!! LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +!! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +!! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +!! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +!! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +!! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +!! POSSIBILITY OF SUCH DAMAGE.[7] +!! +!! +!! ----------------------------------------------------------------------------- +!! ----------------------------------------------------------------------------- +!! @file mo_m4ago.F90 +!! @brief Module for Marine Aggregates: +!! The Microstructure, Multiscale, Mechanistic, Marine Aggregates +!! in the Global Ocean (M4AGO) sinking scheme +!! +!! The mo_aggregates module contains routines to calculate: +!! - aggregate properties +!! - mean sinking velocity of aggregates +!! +!! See: +!! Maerz et al. 2020: Microstructure and composition of marine aggregates +!! as co-determinants for vertical particulate organic +!! carbon transfer in the global ocean. +!! Biogeosciences, 17, 1765-1803, +!! https://doi.org/10.5194/bg-17-1765-2020 +!! +!! This module is written within the project: +!! Multiscale Approach on the Role of Marine Aggregates (MARMA) +!! funded by the Max Planck Society (MPG) +!! +!! @author: joeran maerz (joeran.maerz@mpimet.mpg.de), MPI-M, HH +!! 2019, June, revised by Irene Stemmler (refactoring, cleaning), MPI-M, HH +!! +!! 2023 adopted to iHAMOCC by joeran maerz, UiB, Bergen +!! +!! ----------------------------------------------------------------------------- +!! ----------------------------------------------------------------------------- +!! +!! + + kav_rho_p = 2, & + kav_d_C = 3, & + kws_agg = 4, & + kdf_agg = 5, & + kstickiness_agg = 6, & + kb_agg = 7, & + kstickiness_frustule = 8, & + kLmax_agg = 9, & + kdynvis = 10, & + kav_rhof_V = 11, & + kav_por_V = 12, & + naggdiag = 12 + + REAL, DIMENSION (:,:,:,:), ALLOCATABLE, TARGET :: aggregate_diagnostics + + CONTAINS + + !===================================================================================== m4ago_init_params + SUBROUTINE init_m4ago_nml_params + + END SUBROUTINE init_m4ago_nml_params + + SUBROUTINE init_m4ago_params + + END SUBROUTINE init_m4ago_params + + SUBROUTINE alloc_mem_m4ago(kpie, kpje, kpke) + IMPLICIT NONE + + INTEGER, INTENT(in) :: kpie !< 1st REAL of model grid. + INTEGER, INTENT(in) :: kpje !< 2nd REAL of model grid. + INTEGER, INTENT(in) :: kpke !< 3rd (vertical) REAL of model grid. + + ! allocate memory space for aggregate properties + ALLOCATE(aggregate_diagnostics(kpie, kpje, kpke, naggdiag)) + + ! mean sinking velocity + ALLOCATE(ws_agg(kpie,kpje,kpke)) + + aggregate_diagnostics = 0. + + END SUBROUTINE alloc_mem_m4ago + + SUBROUTINE mean_aggregate_sinking_speed(kpie, kpje, kpke, kbnd, pddpo, omask, ptho, psao, ppao, prho) + IMPLICIT NONE + + INTEGER, INTENT(in) :: kpie !< 1st REAL of model grid. + INTEGER, INTENT(in) :: kpje !< 2nd REAL of model grid. + INTEGER, INTENT(in) :: kpke !< 3rd (vertical) REAL of model grid. + INTEGER, INTENT(in) :: kbnd + REAL, INTENT(in) :: pddpo(kpie,kpje,kpke) !< size of scalar grid cell (3rd dimension) [m] + REAL, INTENT(in) :: omask(kpie,kpje) + REAL, INTENT(in) :: ptho (1-kbnd:kpie+kbnd,1-kbnd:kpje+kbnd,kpke) !< potential temperature [deg C] + REAL, INTENT(in) :: psao (1-kbnd:kpie+kbnd,1-kbnd:kpje+kbnd,kpke) !< salinity [psu.]. + REAL, INTENT(in) :: ppao (1-kbnd:kpie+kbnd,1-kbnd:kpje+kbnd) !< pressure at sea level [Pa]. + REAL, INTENT(in) :: prho (kpie,kpje,kpke) !< density [g/cm3] + END SUBROUTINE mean_aggregate_sinking_speed + +END MODULE mo_m4ago diff --git a/hamocc/mo_param1_bgc.F90 b/hamocc/mo_param1_bgc.F90 index 5793f449..d6c5626b 100644 --- a/hamocc/mo_param1_bgc.F90 +++ b/hamocc/mo_param1_bgc.F90 @@ -219,53 +219,84 @@ MODULE mo_param1_bgc & irdoc =6, & ! dissolved organic carbon & irdet =7 ! particulate carbon - -! sediment -#ifdef cisonew - INTEGER, PARAMETER :: nsedtra=8 + +! --- sediment + ! sediment solid components + INTEGER, PARAMETER :: i_sed_base = 4 INTEGER, PARAMETER :: issso12=1, & & isssc12=2, & & issssil=3, & - & issster=4, & - & issso13=5, & - & issso14=6, & - & isssc13=7, & - & isssc14=8 - -! pore water tracers, index should be the same as for ocetra - INTEGER, PARAMETER :: npowtra=9 - INTEGER, PARAMETER :: ipowaic=1, & - & ipowaal=2, & - & ipowaph=3, & - & ipowaox=4, & - & ipown2 =5, & - & ipowno3=6, & - & ipowasi=7, & - & ipowc13=8, & ! C-isotope idices do NOT correspond to ocetra! - & ipowc14=9 ! C-isotope idices do NOT correspond to ocetra! + & issster=4 +#ifdef cisonew + INTEGER, PARAMETER :: i_sed_cisonew = 4 + INTEGER, PARAMETER :: issso13 = i_sed_base+1, & + & issso14 = i_sed_base+2, & + & isssc13 = i_sed_base+3, & + & isssc14 = i_sed_base+4 #else - INTEGER, PARAMETER :: nsedtra=4 - INTEGER, PARAMETER :: issso12=1, & - & isssc12=2, & - & issssil=3, & - & issster=4, & - & issso13=-1, & - & issso14=-1, & - & isssc13=-1, & - & isssc14=-1 + INTEGER, PARAMETER :: i_sed_cisonew = 0 + INTEGER, PARAMETER :: issso13 = -1, & + & issso14 = -1, & + & isssc13 = -1, & + & isssc14 = -1 +#endif + INTEGER, PARAMETER :: nsedtra = i_sed_base + i_sed_cisonew + -! pore water tracers, index should be the same as for ocetra - INTEGER, PARAMETER :: npowtra=7 + ! sediment pore water components + INTEGER, PARAMETER :: i_pow_base=7 INTEGER, PARAMETER :: ipowaic=1, & & ipowaal=2, & & ipowaph=3, & & ipowaox=4, & & ipown2 =5, & & ipowno3=6, & - & ipowasi=7, & - & ipowc13=-1, & - & ipowc14=-1 + & ipowasi=7 +#ifdef cisonew + INTEGER, PARAMETER :: i_pow_cisonew = 2 + INTEGER, PARAMETER :: ipowc13=i_pow_base + 1, & + & ipowc14=i_pow_base + 2 +#else + INTEGER, PARAMETER :: i_pow_cisonew = 0 + INTEGER, PARAMETER :: ipowc13 = -1, & + & ipowc14 = -1 #endif +#ifdef extNcycle + INTEGER, PARAMETER :: i_pow_extNcycle = 3 !indices not corresponding to ocetra + INTEGER, PARAMETER :: ipownh4=i_pow_base + i_pow_cisonew+1, & + & ipown2o=i_pow_base + i_pow_cisonew+2, & + & ipowno2=i_pow_base + i_pow_cisonew+3 +#else + INTEGER, PARAMETER :: i_pow_extNcycle = 0 + INTEGER, PARAMETER :: ipownh4 = -1, & + & ipown2o = -1, & + & ipowno2 = -1 +#endif + INTEGER, PARAMETER :: npowtra = i_pow_base + i_pow_cisonew + i_pow_extNcycle + + ! Mapping between pore water and ocean tracers needed for pore water diffusion + INTEGER, SAVE :: map_por2octra(npowtra) + + contains + + subroutine init_por2octra_mapping() + + map_por2octra(ipowaic) = isco212 + map_por2octra(ipowaal) = ialkali + map_por2octra(ipowaph) = iphosph + map_por2octra(ipowaox) = ioxygen + map_por2octra(ipown2) = igasnit + map_por2octra(ipowno3) = iano3 + map_por2octra(ipowasi) = isilica + + ! if statements for non-base tracers + if(ipowc13 > 0) map_por2octra(ipowc13) = isco213 + if(ipowc14 > 0) map_por2octra(ipowc14) = isco214 + if(ipownh4 > 0) map_por2octra(ipownh4) = ianh4 + if(ipown2o > 0) map_por2octra(ipown2o) = ian2o + if(ipowno2 > 0) map_por2octra(ipowno2) = iano2 + + end subroutine init_por2octra_mapping !****************************************************************************** END MODULE mo_param1_bgc diff --git a/hamocc/mo_read_fedep.F90 b/hamocc/mo_read_fedep.F90 index 1e41cb14..61210a87 100644 --- a/hamocc/mo_read_fedep.F90 +++ b/hamocc/mo_read_fedep.F90 @@ -22,10 +22,14 @@ module mo_read_fedep ! MODULE mo_read_fedep - routines for reading iron deposition data ! ! -! J.Schwinger, *NORCE Climate, Bergen* 2020-05-27 +! J.Schwinger, *NORCE Climate, Bergen* 2020-05-27 ! ! Modified ! -------- +! J. Schwinger, *NORCE climate, Bergen* 2022-06-02 +! -revise structure of this module, split into a module for reading the +! data (mo_read_fedep) and a module that applies the fluxes in core +! hamocc (mo_apply_fedep) ! ! Purpose ! ------- @@ -36,8 +40,8 @@ module mo_read_fedep ! ------------ ! Public routines and variable of this module: ! -! -subroutine ini_fedep -! Initialise the iron deposition module. +! -subroutine ini_read_fedep +! Initialise the module for reading iron deposition data ! ! -subroutine get_fedep ! Get the iron (dust) deposition for a given month diff --git a/hamocc/mo_read_ndep.F90 b/hamocc/mo_read_ndep.F90 index a501de35..191dac74 100644 --- a/hamocc/mo_read_ndep.F90 +++ b/hamocc/mo_read_ndep.F90 @@ -34,36 +34,36 @@ module mo_read_ndep ! -put reading of a time-slice of n-deposition data into own subroutine ! -removed default file name ! +! J. Schwinger, *NORCE climate, Bergen* 2022-06-02 +! -revise structure of this module, split into a module for reading the +! data (mo_read_ndep) and a module that applies the fluxes in core +! hamocc (mo_apply_ndep) +! ! ! Purpose ! ------- -! -Routines for reading and applying nitrogen deposition fluxes +! -Routines for reading nitrogen deposition fluxes from netcdf files ! ! ! Description: ! ------------ ! -! The routine n_deposition reads nitrogen deposition from file and applies it -! to the top-most model layer. +! The routine get_ndep reads nitrogen deposition from file. The n-deposition +! field is then passed to hamocc4bcm where it is applied to the top-most model +! layer by a call to apply_ndep (mo_apply_ndep). ! ! N deposition is activated through a logical switch 'do_ndep' read from ! HAMOCC's bgcnml namelist. If N deposition is acitvated, a valid filename -! needs to be provided via HAMOCC's bgcnml namelist (variable ndepfile). If -! the input file is not found, an error will be issued. -! -! The input data must be already pre-interpolated to the ocean grid and stored -! in the same folder with BLOM's grid information. +! (including the full path) needs to be provided via HAMOCC's bgcnml namelist +! (variable ndepfile). If the input file is not found, an error will be issued. +! The input data must be already pre-interpolated to the ocean grid. ! -! -subroutine ini_ndep -! Initialise the n-deposition module +! -subroutine ini_read_ndep +! Initialise the module ! ! -subroutine get_ndep ! Read and return n-deposition data for a given month. ! -! -subroutine n_deposition -! Apply n-deposition to the top-most model layer. -! -! !****************************************************************************** implicit none diff --git a/hamocc/mo_read_oafx.F90 b/hamocc/mo_read_oafx.F90 new file mode 100644 index 00000000..8bfa2d28 --- /dev/null +++ b/hamocc/mo_read_oafx.F90 @@ -0,0 +1,322 @@ +! Copyright (C) 2021-2022 J. Schwinger +! +! This file is part of BLOM/iHAMOCC. +! +! 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 https://www.gnu.org/licenses/. + + +module mo_read_oafx +!****************************************************************************** +! +! J.Schwinger *NORCE Climate, Bergen* 2022-08-24 +! +! Modified +! -------- +! +! Purpose +! ------- +! -Routines for reading ocean alkalinization fluxes from netcdf files +! +! +! Description: +! ------------ +! The routine get_oafx reads a fluxs of alkalinity from file (or, for simple +! cases, constructs an alkalinity flux field from scratch). The alkalinity +! flux is then passed to hamocc4bcm where it is applied to the top-most model +! layer by a call to apply_oafx (mo_apply_oafx). +! +! Ocean alkalinization is activated through a logical switch 'do_oalk' read from +! HAMOCC's bgcnml namelist. If ocean alkalinization is acitvated, a valid +! name of an alkalinisation scenario (defined in this module, see below) and +! the file name (including the full path) of the corresponding OA-scenario +! input file needs to be provided via HAMOCC's bgcnml namelist (variables +! oascenario and oafxfile). If the input file is not found, an error will be +! issued. The input data must be already pre-interpolated to the ocean grid. +! +! Currently available ocean alkalinisation scenarios: +! (no input file needed, flux and latitude range can be defined in the +! namelist, default values are defined): +! -'const': constant alkalinity flux applied to the surface ocean +! between two latitudes. +! -'ramp': ramping-up alkalinity flux from 0 Pmol yr-1 to a maximum +! value between two specified years and kept constant +! onward, applied to the surface ocean between two +! latitudes. +! +! -subroutine ini_read_oafx +! Initialise the module +! +! -subroutine get_oafx +! Gets the alkalinity flux to apply at a given time. +! +! +!****************************************************************************** + implicit none + + private + public :: ini_read_oafx,get_oafx,oalkscen,oalkfile + + real,allocatable, save :: oalkflx(:,:) + + character(len=128), save :: oalkscen ='' + character(len=512), save :: oalkfile ='' + real, parameter :: Pmol2kmol = 1.0e12 + + ! Parameter used in the definition of alkalinization scenarios. The following + ! scenarios are defined in this module: + ! + ! const Constant homogeneous addition of alkalinity between latitude + ! cdrmip_latmin and latitude cdrmip_latmax + ! ramp Linear increase of homogeneous addition from 0 to addalk + ! Pmol ALK/yr-1 from year ramp_start to year ramp_end between + ! latitude cdrmip_latmin and latitude cdrmip_latmax + ! + real, protected :: addalk = 0.56 ! Pmol alkalinity/yr added in the + ! scenarios. Read from namelist file + ! to overwrite default value. + real, protected :: cdrmip_latmax = 70.0 ! Min and max latitude where + real, protected :: cdrmip_latmin = -60.0 ! alkalinity is added according + ! to the CDRMIP protocol. Read from + ! namelist file to overwrite default + ! value. + integer, protected :: ramp_start = 2025 ! In 'ramp' scenario, start at + integer, protected :: ramp_end = 2035 ! 0 Pmol/yr in ramp_start, and max + ! addalk Pmol/yr in ramp_end. + ! Read from namelist file to + ! overwrite default value. + + logical, save :: lini = .false. + +!****************************************************************************** +contains + + + +subroutine ini_read_oafx(kpie,kpje,pdlxp,pdlyp,pglat,omask) +!****************************************************************************** +! +! J.Schwinger *NORCE Climate, Bergen* 2021-11-15 +! +! Purpose +! ------- +! -Initialise the alkalinization module. +! +! Changes: +! -------- +! +! Parameter list: +! --------------- +! *INTEGER* *kpie* - 1st dimension of model grid. +! *INTEGER* *kpje* - 2nd dimension of model grid. +! *REAL* *pdlxp* - size of grid cell (longitudinal) [m]. +! *REAL* *pdlyp* - size of grid cell (latitudinal) [m]. +! *REAL* *pglat* - latitude grid cell centres [degree N]. +! *REAL* *omask* - land/ocean mask. +! +!****************************************************************************** + use mod_xc, only: xcsum,xchalt,mnproc,nbdy,ips + use mo_control_bgc, only: io_stdo_bgc,do_oalk,bgc_namelist,get_bgc_namelist + + implicit none + + integer, intent(in) :: kpie,kpje + real, intent(in) :: pdlxp(kpie,kpje), pdlyp(kpie,kpje) + real, intent(in) :: pglat(1-nbdy:kpie+nbdy,1-nbdy:kpje+nbdy) + real, intent(in) :: omask(kpie,kpje) + + integer :: i,j,errstat + integer :: iounit + real :: avflx,ztotarea + real :: ztmp1(1-nbdy:kpie+nbdy,1-nbdy:kpje+nbdy) + + namelist /bgcoafx/ do_oalk,oalkscen,oalkfile,addalk,cdrmip_latmax, & + & cdrmip_latmin,ramp_start,ramp_end + + ! Read parameters for alkalinization fluxes from namelist file + if(.not. allocated(bgc_namelist)) call get_bgc_namelist + open (newunit=iounit, file=bgc_namelist, status='old' & + & ,action='read') + read (unit=iounit, nml=BGCOAFX) + close (unit=iounit) + + ! Return if alkalinization is turned off + if (.not. do_oalk) then + if (mnproc.eq.1) then + write(io_stdo_bgc,*) '' + write(io_stdo_bgc,*) 'ini_read_oafx: ocean alkalinization is not activated.' + endif + return + end if + + ! Initialise the module + if(.not. lini) then + + if(mnproc.eq.1) then + write(io_stdo_bgc,*)' ' + write(io_stdo_bgc,*)'***************************************************' + write(io_stdo_bgc,*)'iHAMOCC: Initialization of module mo_read_oafx:' + write(io_stdo_bgc,*)' ' + endif + + if( trim(oalkscen)=='const' .or. trim(oalkscen)=='ramp' ) then + + if(mnproc.eq.1) then + write(io_stdo_bgc,*)'Using alkalinization scenario ', trim(oalkscen) + write(io_stdo_bgc,*)' ' + endif + + ! Allocate field to hold alkalinization fluxes + if(mnproc.eq.1) then + write(io_stdo_bgc,*)'Memory allocation for variable oalkflx ...' + write(io_stdo_bgc,*)'First dimension : ',kpie + write(io_stdo_bgc,*)'Second dimension : ',kpje + endif + + allocate(oalkflx(kpie,kpje),stat=errstat) + if(errstat.ne.0) stop 'not enough memory oalkflx' + oalkflx(:,:) = 0.0 + + ! Calculate total ocean area + ztmp1(:,:)=0.0 + do j=1,kpje + do i=1,kpie + if( omask(i,j).gt.0.5 .and. pglat(i,j)cdrmip_latmin ) then + ztmp1(i,j)=ztmp1(i,j)+pdlxp(i,j)*pdlyp(i,j) + endif + enddo + enddo + + call xcsum(ztotarea,ztmp1,ips) + + ! Calculate alkalinity flux (kmol m^2 yr-1) to be applied + avflx = addalk/ztotarea*Pmol2kmol + if(mnproc.eq.1) then + write(io_stdo_bgc,*)' ' + write(io_stdo_bgc,*)' applying alkalinity flux of ', avflx, ' kmol m-2 yr-1' + write(io_stdo_bgc,*)' over an area of ', ztotarea , ' m2' + if( trim(oalkscen)=='ramp' ) then + write(io_stdo_bgc,*)' ramping-up from ', ramp_start, ' to ', ramp_end + endif + endif + + do j=1,kpje + do i=1,kpie + if( omask(i,j).gt.0.5 .and. pglat(i,j)cdrmip_latmin ) then + oalkflx(i,j) = avflx + endif + enddo + enddo + + lini=.true. + + !-------------------------------- + ! No valid scenario specified + !-------------------------------- + else + + write(io_stdo_bgc,*) '' + write(io_stdo_bgc,*) 'ini_read_oafx: invalid alkalinization scenario... ' + call xchalt('(ini_read_oafx)') + stop '(ini_read_oafx)' + + endif + + endif ! not lini + + +!****************************************************************************** +end subroutine ini_read_oafx + + +subroutine get_oafx(kpie,kpje,kplyear,kplmon,omask,oafx) +!****************************************************************************** +! +! J. Schwinger *NORCE Climate, Bergen* 2021-11-15 +! +! Purpose +! ------- +! -return ocean alkalinization flux. +! +! Changes: +! -------- +! +! +! Parameter list: +! --------------- +! *INTEGER* *kpie* - 1st dimension of model grid. +! *INTEGER* *kpje* - 2nd dimension of model grid. +! *INTEGER* *kplyear* - current year. +! *INTEGER* *kplmon* - current month. +! *REAL* *omask* - land/ocean mask (1=ocean) +! *REAL* *oaflx* - alkalinization flux [kmol m-2 yr-1] +! +!****************************************************************************** + use mod_xc, only: xchalt,mnproc + use mo_control_bgc, only: io_stdo_bgc,do_oalk + use mod_time, only: nday_of_year + + implicit none + + integer, intent(in) :: kpie,kpje,kplyear,kplmon + real, intent(in) :: omask(kpie,kpje) + real, intent(out) :: oafx(kpie,kpje) + integer :: current_day + + ! local variables + integer :: i,j + + if (.not. do_oalk) then + oafx(:,:) = 0.0 + return + endif + + !-------------------------------- + ! Scenarios of constant fluxes + !-------------------------------- + if( trim(oalkscen)=='const' ) then + + oafx(:,:) = oalkflx(:,:) + + !-------------------------------- + ! Scenario of ramping-up fluxes + !-------------------------------- + elseif(trim(oalkscen)=='ramp' ) then + + if(kplyear.lt.ramp_start ) then + oafx(:,:) = 0.0 + elseif(kplyear.ge.ramp_end ) then + oafx(:,:) = oalkflx(:,:) + else + current_day = (kplyear-ramp_start)*365+nday_of_year + oafx(:,:) = oalkflx(:,:) * current_day / ((ramp_end-ramp_start)*365.) + endif + + else + + write(io_stdo_bgc,*) '' + write(io_stdo_bgc,*) 'get_oafx: invalid alkalinization scenario... ' + call xchalt('(get_oafx)') + stop '(get_oafx)' + + endif + +!****************************************************************************** +end subroutine get_oafx + + + +!****************************************************************************** +end module mo_read_oafx diff --git a/hamocc/mo_read_sedpor.F90 b/hamocc/mo_read_sedpor.F90 new file mode 100644 index 00000000..8f51b0ca --- /dev/null +++ b/hamocc/mo_read_sedpor.F90 @@ -0,0 +1,131 @@ +! Copyright (C) 2020 S. Gao, I. Bethke, J. Tjiputra, J. Schwinger +! +! This file is part of BLOM/iHAMOCC. +! +! 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 https://www.gnu.org/licenses/. + +module mo_read_sedpor +!***************************************************************************** +! Purpose +! ------- +! - Routine for reading sediment porosity from netcdf file +! +! Description +! ----------- +! Public routines and variable of this module: +! +! - subroutine ini_read_sedpor +! read sediment porosity file +! +! L_SED_POR must be set to true in nml to activate +! lon-lat variable sediment porosity. +! +! The model attempts to read lon-lat-sediment depth variable porosity +! from the input file 'SEDPORFILE' (incl. full path) +! +! sed_por holds then the porosity that can be applied later +! via mo_apply_sedpor +! +!***************************************************************************** + +implicit none + +private + +public :: read_sedpor,sedporfile + +character(len=512),save :: sedporfile = '' + +contains + +subroutine read_sedpor(kpie,kpje,ks,omask,sed_por) + use mod_xc, only: mnproc,xchalt + use mo_control_bgc, only: io_stdo_bgc,l_3Dvarsedpor + use netcdf, only: nf90_noerr,nf90_nowrite,nf90_close,nf90_open + + + + implicit none + + integer, intent(in) :: kpie,kpje,ks + real, intent(in) :: omask(kpie,kpje) + real, intent(inout) :: sed_por(kpie,kpje,ks) + + !local variables + integer :: i,j,k + real :: sed_por_in(kpie,kpje,ks) + logical :: file_exists = .false. + integer :: ncid,ncstat + + ! Return if l_3Dvarsedpor is turned off + if (.not. l_3Dvarsedpor) then + if (mnproc.eq.1) then + write(io_stdo_bgc,*) '' + write(io_stdo_bgc,*) 'read_sedpor: spatially variable sediment porosity is not activated.' + endif + return + endif + + ! Check if sediment porosity file exists. If not, abort. + inquire(file=sedporfile,exist=file_exists) + if (.not. file_exists .and. mnproc.eq.1) then + write(io_stdo_bgc,*) '' + write(io_stdo_bgc,*) 'read_sedpor: Cannot find sediment porosity file... ' + call xchalt('(read_sedpor)') + stop '(read_sedpor)' + endif + + ! read sediment porosity from file + if (mnproc.eq.1) then + write(io_stdo_bgc,*) '' + write(io_stdo_bgc,*) 'read_sedpor: read sediment porosity from ', & + trim(sedporfile) + endif + + ! Open netCDF data file + IF(mnproc==1) THEN + ncstat = NF90_OPEN(trim(sedporfile),NF90_NOWRITE, ncid) + IF (ncstat.NE.NF90_NOERR ) THEN + CALL xchalt('(read_sedpor: Problem with netCDF1)') + stop '(read_sedpor: Problem with netCDF1)' + END IF + END IF + + ! Read data + call read_netcdf_var(ncid,'sedpor',sed_por_in(1,1,1),ks,0,0) + + ! Close file + IF(mnproc==1) THEN + ncstat = NF90_CLOSE(ncid) + IF ( ncstat .NE. NF90_NOERR ) THEN + CALL xchalt('(read_sedpor: Problem with netCDF200)') + stop '(read_sedpor: Problem with netCDF200)' + END IF + END IF + + + do k=1,ks + do j=1,kpje + do i=1,kpie + if(omask(i,j).gt. 0.5)then + sed_por(i,j,k)=sed_por_in(i,j,k) + else + sed_por(i,j,k)=0. + endif + enddo + enddo + enddo + +end subroutine read_sedpor +end module mo_read_sedpor diff --git a/hamocc/mo_sedmnt.F90 b/hamocc/mo_sedmnt.F90 index 1eb66ade..7fab49b4 100644 --- a/hamocc/mo_sedmnt.F90 +++ b/hamocc/mo_sedmnt.F90 @@ -17,7 +17,7 @@ ! along with BLOM. If not, see https://www.gnu.org/licenses/. - MODULE mo_sedmnt + MODULE mo_sedmnt !****************************************************************************** ! ! MODULE mo_sedmnt - Variables for sediment modules. @@ -32,6 +32,7 @@ MODULE mo_sedmnt ! Purpose ! ------- ! - declaration and memory allocation +! - initialization of sediment ! ! Description: ! ------------ @@ -62,21 +63,31 @@ MODULE mo_sedmnt ! *ansed* *REAL* - . ! *o2ut* *REAL* - . ! +! -subroutine ini_sedmnt +! Initialize sediment parameters (some are also used in water column) +! -subroutine ini_sedmnt_fields +! Initialize 2D and 3D sediment fields +! !****************************************************************************** - use mo_param1_bgc, only: ks,ksp,nsedtra,npowtra + use mo_param1_bgc, only: ks,ksp,nsedtra,npowtra + use mo_control_bgc, only: io_stdo_bgc + use mod_xc, only: mnproc implicit none REAL, save :: dzs(ksp) = 0.0 REAL, save :: seddzi(ksp) = 0.0 REAL, save :: seddw(ks) = 0.0 - REAL, save :: porsol(ks) = 0.0 - REAL, save :: porwah(ks) = 0.0 - REAL, save :: porwat(ks) = 0.0 REAL, DIMENSION (:,:,:,:), ALLOCATABLE :: sedlay REAL, DIMENSION (:,:,:,:), ALLOCATABLE :: powtra REAL, DIMENSION (:,:,:), ALLOCATABLE :: sedhpl + REAL, DIMENSION (:,:,:), ALLOCATABLE :: porsol + REAL, DIMENSION (:,:,:), ALLOCATABLE :: porwah + REAL, DIMENSION (:,:,:), ALLOCATABLE :: porwat + REAL, DIMENSION (:,:), ALLOCATABLE :: solfu + REAL, DIMENSION (:,:,:), ALLOCATABLE :: zcoefsu + REAL, DIMENSION (:,:,:), ALLOCATABLE :: zcoeflo REAL, DIMENSION (:,:), ALLOCATABLE :: silpro REAL, DIMENSION (:,:), ALLOCATABLE :: prorca @@ -91,18 +102,195 @@ MODULE mo_sedmnt REAL :: sedict,rno3,o2ut,ansed REAL :: calcwei, opalwei, orgwei REAL :: calcdens, opaldens, orgdens, claydens - REAL :: calfa, oplfa, orgfa, clafa, solfu + REAL :: calfa, oplfa, orgfa, clafa + REAL :: disso_sil,silsat,disso_poc,sed_denit,disso_caco3 - CONTAINS + CONTAINS + + !======================================================================== + SUBROUTINE ini_sedmnt(kpie,kpje,kpke,omask,sed_por) + use mo_control_bgc, only: dtbgc + implicit none - SUBROUTINE ALLOC_MEM_SEDMNT(kpie,kpje) -!****************************************************************************** -! ALLOC_MEM_SEDMNT - Allocate variables in this module -!****************************************************************************** - use mod_xc, only: mnproc - use mo_control_bgc, only: io_stdo_bgc + integer, intent(in) :: kpie,kpje,kpke + real, intent(in) :: omask(kpie,kpje) + real, intent(in) :: sed_por(kpie,kpje,ks) + + integer :: k + + sedict = 1.e-9 * dtbgc ! Molecular diffusion coefficient + ! Dissolution rate constant of opal (disso) [1/(kmol Si(OH)4/m3)*1/sec] + ! THIS NEEDS TO BE CHANGED TO disso=3.e-8! THIS IS ONLY KEPT FOR THE MOMENT + ! FOR BACKWARDS COMPATIBILITY + !disso_sil = 3.e-8*dtbgc ! (2011-01-04) EMR + !disso_sil = 1.e-6*dtbgc ! test vom 03.03.04 half live sil ca. 20.000 yr + disso_sil = 1.e-6*dtbgc + ! Silicate saturation concentration is 1 mol/m3 + silsat = 0.001 + + ! Degradation rate constant of POP (disso) [1/(kmol O2/m3)*1/sec] + disso_poc = 0.01 / 86400. * dtbgc ! disso=3.e-5 was quite high + + ! Denitrification rate constant of POP (disso) [1/sec] + sed_denit = 0.01/86400. * dtbgc + + ! Dissolution rate constant of CaCO3 (disso) [1/(kmol CO3--/m3)*1/sec] + disso_caco3 = 1.e-7 * dtbgc + + ! ****************************************************************** + ! densities etc. for SEDIMENT SHIFTING + + ! define weight of calcium carbonate, opal, and poc [kg/kmol] + calcwei = 100. ! 40+12+3*16 kg/kmol C + opalwei = 60. ! 28 + 2*16 kg/kmol Si + orgwei = 30. ! from 12 kg/kmol * 2.5 POC[kg]/DW[kg] + ! after Alldredge, 1998: + ! POC(g)/DW(g) = 0.4 of diatom marine snow, size 1mm3 + + ! define densities of opal, caco3, poc [kg/m3] + calcdens = 2600. + opaldens = 2200. + orgdens = 1000. + claydens = 2600. !quartz + + ! define volumes occupied by solid constituents [m3/kmol] + calfa = calcwei / calcdens + oplfa = opalwei / opaldens + orgfa = orgwei / orgdens + clafa = 1. / claydens !clay is calculated in kg/m3 + + ! sediment layer thickness + dzs(1) = 0.001 + dzs(2) = 0.003 + dzs(3) = 0.005 + dzs(4) = 0.007 + dzs(5) = 0.009 + dzs(6) = 0.011 + dzs(7) = 0.013 + dzs(8) = 0.015 + dzs(9) = 0.017 + dzs(10) = 0.019 + dzs(11) = 0.021 + dzs(12) = 0.023 + dzs(13) = 0.025 + + if (mnproc == 1) then + write(io_stdo_bgc,*) ' ' + write(io_stdo_bgc,*) 'Sediment layer thickness [m] : ' + write(io_stdo_bgc,'(5F9.3)') dzs + write(io_stdo_bgc,*) ' ' + endif + + seddzi(1) = 500. + do k = 1, ks + seddzi(k+1) = 1. / dzs(k+1) ! inverse of grid cell size + seddw(k) = 0.5 * (dzs(k) + dzs(k+1)) ! distance between grid cell centers (pressure points) + enddo + +#ifndef sedbypass + ! 2d and 3d fields are not allocated in case of sedbypass + ! so only initialize them if we are using the sediment + CALL ini_sedmnt_por(kpie,kpje,kpke,omask,sed_por) +#endif + END SUBROUTINE ini_sedmnt + + !======================================================================== + SUBROUTINE ini_sedmnt_por(kpie,kpje,kpke,omask,sed_por) + ! + ! Initialization of: + ! - 3D porosity field (cell center and cell boundaries) + ! - solid volume fraction at cell center + ! - vertical molecular diffusion coefficients scaled with porosity + ! + use mo_control_bgc, only: l_3Dvarsedpor + + implicit none + + integer, intent(in) :: kpie,kpje,kpke + real, intent(in) :: omask(kpie,kpje) + real, intent(in) :: sed_por(kpie,kpje,ks) + + ! local + integer :: i,j,k + + ! this initialization can be done via reading a porosity map + ! porwat is the poroisty at the (pressure point) center of the grid cell + if (l_3Dvarsedpor)then + ! lon-lat variable sediment porosity from input file + do k=1,ks + do j=1,kpje + do i=1,kpie + if(omask(i,j).gt. 0.5)then + porwat(i,j,k) = sed_por(i,j,k) + endif + enddo + enddo + enddo + else + porwat(:,:,1) = 0.85 + porwat(:,:,2) = 0.83 + porwat(:,:,3) = 0.8 + porwat(:,:,4) = 0.79 + porwat(:,:,5) = 0.77 + porwat(:,:,6) = 0.75 + porwat(:,:,7) = 0.73 + porwat(:,:,8) = 0.7 + porwat(:,:,9) = 0.68 + porwat(:,:,10) = 0.66 + porwat(:,:,11) = 0.64 + porwat(:,:,12) = 0.62 + endif + + if (mnproc == 1) then + write(io_stdo_bgc,*) 'Pore water in sediment initialized' + endif + + do k = 1, ks + do j = 1, kpje + do i = 1, kpie + porsol(i,j,k) = 1. - porwat(i,j,k) ! solid volume fraction at grid center + if(k >= 2) porwah(i,j,k) = 0.5 * (porwat(i,j,k) + porwat(i,j,k-1)) ! porosity at cell interfaces + if(k == 1) porwah(i,j,k) = 0.5 * (1. + porwat(i,j,1)) + enddo + enddo + enddo + + ! determine total solid sediment volume + solfu = 0. + do i = 1, kpie + do j = 1, kpje + do k = 1, ks + solfu(i,j) = solfu(i,j) + seddw(k) * porsol(i,j,k) + enddo + enddo + enddo + + ! Initialize porosity-dependent diffusion coefficients of sediment + zcoefsu(:,:,0) = 0.0 + do k = 1,ks + do j = 1, kpje + do i = 1, kpie + ! sediment diffusion coefficient * 1/dz * fraction of pore water at half depths + zcoefsu(i,j,k ) = -sedict * seddzi(k) * porwah(i,j,k) + zcoeflo(i,j,k-1) = -sedict * seddzi(k) * porwah(i,j,k) ! why the same ? + enddo + enddo + enddo + zcoeflo(:,:,ks) = 0.0 ! diffusion coefficient for bottom sediment layer + if (mnproc == 1) then + write(io_stdo_bgc,*) 'Pore water diffusion coefficients in sediment initialized' + endif + + END SUBROUTINE ini_sedmnt_por + + + !======================================================================== + SUBROUTINE ALLOC_MEM_SEDMNT(kpie,kpje) + !****************************************************************************** + ! ALLOC_MEM_SEDMNT - Allocate variables in this module + !****************************************************************************** INTEGER, intent(in) :: kpie,kpje INTEGER :: errstat @@ -195,6 +383,71 @@ SUBROUTINE ALLOC_MEM_SEDMNT(kpie,kpje) if(errstat.ne.0) stop 'not enough memory sedhpl' sedhpl(:,:,:) = 0.0 + IF (mnproc.eq.1) THEN + WRITE(io_stdo_bgc,*)'Memory allocation for variable porsol ...' + WRITE(io_stdo_bgc,*)'First dimension : ',kpie + WRITE(io_stdo_bgc,*)'Second dimension : ',kpje + WRITE(io_stdo_bgc,*)'Third dimension : ',ks + ENDIF + + ALLOCATE (porsol(kpie,kpje,ks),stat=errstat) + if(errstat.ne.0) stop 'not enough memory porsol' + porsol(:,:,:) = 0.0 + + IF (mnproc.eq.1) THEN + WRITE(io_stdo_bgc,*)'Memory allocation for variable porwah ...' + WRITE(io_stdo_bgc,*)'First dimension : ',kpie + WRITE(io_stdo_bgc,*)'Second dimension : ',kpje + WRITE(io_stdo_bgc,*)'Third dimension : ',ks + ENDIF + + ALLOCATE (porwah(kpie,kpje,ks),stat=errstat) + if(errstat.ne.0) stop 'not enough memory porwah' + porwah(:,:,:) = 0.0 + + IF (mnproc.eq.1) THEN + WRITE(io_stdo_bgc,*)'Memory allocation for variable porwat ...' + WRITE(io_stdo_bgc,*)'First dimension : ',kpie + WRITE(io_stdo_bgc,*)'Second dimension : ',kpje + WRITE(io_stdo_bgc,*)'Third dimension : ',ks + ENDIF + + ALLOCATE (porwat(kpie,kpje,ks),stat=errstat) + if(errstat.ne.0) stop 'not enough memory porwat' + porwat(:,:,:) = 0.0 + + IF (mnproc.eq.1) THEN + WRITE(io_stdo_bgc,*)'Memory allocation for variable solfu ...' + WRITE(io_stdo_bgc,*)'First dimension : ',kpie + WRITE(io_stdo_bgc,*)'Second dimension : ',kpje + ENDIF + + ALLOCATE (solfu(kpie,kpje),stat=errstat) + if(errstat.ne.0) stop 'not enough memory solfu' + solfu(:,:) = 0.0 + + IF (mnproc.eq.1) THEN + WRITE(io_stdo_bgc,*)'Memory allocation for variable zcoefsu ...' + WRITE(io_stdo_bgc,*)'First dimension : ',kpie + WRITE(io_stdo_bgc,*)'Second dimension : ',kpje + WRITE(io_stdo_bgc,*)'Third dimension : ',ks + ENDIF + + ALLOCATE (zcoefsu(kpie,kpje,0:ks),stat=errstat) + if(errstat.ne.0) stop 'not enough memory zcoefsu' + zcoefsu(:,:,:) = 0.0 + + IF (mnproc.eq.1) THEN + WRITE(io_stdo_bgc,*)'Memory allocation for variable zcoeflo ...' + WRITE(io_stdo_bgc,*)'First dimension : ',kpie + WRITE(io_stdo_bgc,*)'Second dimension : ',kpje + WRITE(io_stdo_bgc,*)'Third dimension : ',ks + ENDIF + + ALLOCATE (zcoeflo(kpie,kpje,0:ks),stat=errstat) + if(errstat.ne.0) stop 'not enough memory zcoeflo' + zcoeflo(:,:,:) = 0.0 + IF (mnproc.eq.1) THEN WRITE(io_stdo_bgc,*)'Memory allocation for variable burial ...' WRITE(io_stdo_bgc,*)'First dimension : ',kpie @@ -221,6 +474,6 @@ SUBROUTINE ALLOC_MEM_SEDMNT(kpie,kpje) !****************************************************************************** - END SUBROUTINE ALLOC_MEM_SEDMNT + END SUBROUTINE ALLOC_MEM_SEDMNT - END MODULE mo_sedmnt + END MODULE mo_sedmnt diff --git a/hamocc/mo_vgrid.F90 b/hamocc/mo_vgrid.F90 index 0f7cc08b..e010e92e 100644 --- a/hamocc/mo_vgrid.F90 +++ b/hamocc/mo_vgrid.F90 @@ -53,16 +53,18 @@ module mo_vgrid !****************************************************************************** implicit none - INTEGER, PARAMETER :: kmle = 2 ! k-end index for layers that - ! represent the mixed layer in BLOM + INTEGER, PARAMETER :: kmle_static = 2 ! k-end index for layers that + ! represent the mixed layer in BLOM. + ! Default value used for isopycnic coordinates. REAL, PARAMETER :: dp_ez = 100.0 ! depth of euphotic zone - REAL, PARAMETER :: dp_min = 1.0E-12 ! min layer thickness layers thinner + REAL, PARAMETER :: dp_min = 1.0E-12 ! min layer thickness layers thinner ! than this are ignored by HAMOCC REAL, PARAMETER :: dp_min_sink = 1.0 ! min layer thickness for sinking (layers thinner than ! this are ignored and set to the concentration of the ! layer above). Note that the bottom layer index kbo(i,j) ! is defined as the lowermost layer thicker than dp_min_sink. + INTEGER, DIMENSION(:,:), ALLOCATABLE :: kmle INTEGER, DIMENSION(:,:), ALLOCATABLE :: kbo INTEGER, DIMENSION(:,:), ALLOCATABLE :: kwrbioz INTEGER, DIMENSION(:,:), ALLOCATABLE :: k0100,k0500,k1000,k2000,k4000 @@ -263,6 +265,17 @@ subroutine alloc_mem_vgrid(kpie,kpje,kpke) ptiestw(:,:,:) = 0.0 + IF(mnproc.eq.1) THEN + WRITE(io_stdo_bgc,*)'Memory allocation for variable kmle ...' + WRITE(io_stdo_bgc,*)'First dimension : ',kpie + WRITE(io_stdo_bgc,*)'Second dimension : ',kpje + ENDIF + + ALLOCATE(kmle(kpie,kpje),stat=errstat) + if(errstat.ne.0) stop 'not enough memory kmle' + kmle(:,:) = kmle_static + + IF(mnproc.eq.1) THEN WRITE(io_stdo_bgc,*)'Memory allocation for variable kbo ...' WRITE(io_stdo_bgc,*)'First dimension : ',kpie diff --git a/hamocc/ncout_hamocc.F b/hamocc/ncout_hamocc.F deleted file mode 100644 index 2b3e371e..00000000 --- a/hamocc/ncout_hamocc.F +++ /dev/null @@ -1,1992 +0,0 @@ -! Copyright (C) 2020 I Bethke, J. Tjiputra, J. Schwinger, A. Moree, M. -! Bentsen -! -! This file is part of BLOM/iHAMOCC. -! -! 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 https://www.gnu.org/licenses/. - - - subroutine ncwrt_bgc(iogrp) -c -c --- ------------------------------------------- -c --- output routine for HAMOCC diagnostic fields -c --- ------------------------------------------- -c - use mod_time, only: date0,date,calendar,nstep,nstep_in_day, - . nday_of_year,time0,time - use mod_xc, only: kdm,mnproc,itdm,jtdm,lp - use mod_grid, only: depths - use mod_dia, only: diafnm,sigmar1,iotype,ddm,depthslev, - . depthslev_bnds - use mo_control_bgc, only: dtbgc - use mo_vgrid, only: k0100,k0500,k1000,k2000,k4000 - use mo_param1_bgc, only: ks - use mod_nctools, only: ncwrt1,ncdims,nctime,ncfcls,ncfopn, - . ncdimc - use mo_bgcmean, only: domassfluxes, - . flx_cal0100,flx_cal0500,flx_cal1000, - . flx_cal2000,flx_cal4000,flx_cal_bot, - . flx_car0100,flx_car0500,flx_car1000, - . flx_car2000,flx_car4000,flx_car_bot, - . flx_bsi0100,flx_bsi0500,flx_bsi1000, - . flx_bsi2000,flx_bsi4000,flx_bsi_bot, - . flx_sediffic,flx_sediffal,flx_sediffph, - . flx_sediffox,flx_sediffn2,flx_sediffno3, - . flx_sediffsi, - . jsediffic,jsediffal,jsediffph,jsediffox, - . jsediffn2,jsediffno3,jsediffsi, - . jalkali,jano3,jasize,jatmco2, - . jbsiflx0100,jbsiflx0500,jbsiflx1000, - . jbsiflx2000,jbsiflx4000,jbsiflx_bot, - . jcalc,jcalflx0100,jcalflx0500,jcalflx1000, - . jcalflx2000,jcalflx4000,jcalflx_bot, - . jcarflx0100,jcarflx0500,jcarflx1000, - . jcarflx2000,jcarflx4000,jcarflx_bot, - . jco2flux,jco2fxd,jco2fxu,jco3,jdic,jdicsat, - . jdms,jdms_bac,jdms_uv,jdmsflux,jdmsprod, - . jdoc,jdp,jeps,jexpoca,jexport,jexposi, - . jgrazer, - . jintdnit,jintnfix,jintphosy,jiralk,jirdet, - . jirdin,jirdip,jirdoc,jiriron,jiron,jirsi, - . jkwco2,jlvlalkali,jlvlano3,jlvlasize, - . jlvlbigd14c,jlvlbromo,jlvlcalc,jlvlcalc13, - . jlvlcfc11,jlvlcfc12,jlvlco3,jlvld13c, - . jlvld14c,jlvldic,jlvldic13,jlvldic14, - . jlvldicsat,jlvldoc,jlvldoc13,jlvleps, - . jlvlgrazer,jlvlgrazer13,jlvliron,jlvln2o, - . jlvlnatalkali,jlvlnatcalc,jlvlnatco3, - . jlvlnatdic,jlvlnatomegaa,jlvlnatomegac, - . jlvlnos,jlvlo2sat,jlvlomegaa,jlvlomegac, - . jlvlopal,jlvloxygen,jlvlph,jlvlphosph, - . jlvlphosy,jlvlphyto,jlvlphyto13,jlvlpoc, - . jlvlpoc13,jlvlprefalk,jlvlprefdic, - . jlvlprefo2,jlvlprefpo4,jlvlsf6,jlvlsilica, - . jlvlwnos,jlvlwphy,jn2flux,jn2o,jn2oflux, - . jn2ofx,jndep,jniflux,jnos,jo2flux,jo2sat, - . jomegaa,jomegac,jopal,joxflux,joxygen,jpco2, - . jph,jphosph,jphosy,jphyto,jpoc,jprefalk, - . jprefdic,jprefo2,jprefpo4,jsilica, - . jsrfalkali,jsrfano3,jsrfdic,jsrfiron, - . jsrfoxygen,jsrfphosph,jsrfphyto,jsrfsilica, - . jwnos,jwphy, - . lyr_dp,lyr_dic,lyr_alkali,lyr_phosph, - . lyr_oxygen,lyr_ano3,lyr_silica,lyr_doc, - . lyr_phyto,lyr_grazer,lyr_poc,lyr_calc, - . lyr_opal,lyr_iron,lyr_phosy,lyr_co3,lyr_ph, - . lyr_omegaa,lyr_omegac,lyr_n2o,lyr_prefo2, - . lyr_o2sat,lyr_prefpo4,lyr_prefalk, - . lyr_prefdic,lyr_dicsat, - . lvl_dic,lvl_alkali, - . lvl_phosph,lvl_oxygen,lvl_ano3,lvl_silica, - . lvl_doc,lvl_phyto,lvl_grazer,lvl_poc, - . lvl_calc,lvl_opal,lvl_iron,lvl_phosy, - . lvl_co3,lvl_ph,lvl_omegaa,lvl_omegac, - . lvl_n2o,lvl_prefo2,lvl_o2sat,lvl_prefpo4, - . lvl_prefalk,lvl_prefdic,lvl_dicsat, - . lvl_o2sat,srf_n2ofx,srf_atmco2,srf_kwco2, - . srf_pco2,srf_dmsflux,srf_co2fxd, - . srf_co2fxu,srf_oxflux,srf_niflux,srf_dms, - . srf_dmsprod,srf_dms_bac,srf_dms_uv, - . srf_export,srf_exposi,srf_expoca,srf_dic, - . srf_alkali,srf_phosph,srf_oxygen,srf_ano3, - . srf_silica,srf_iron,srf_phyto, - . int_phosy,int_nfix,int_dnit, - . nbgc,nacc_bgc,bgcwrt,glb_inventory,bgct2d, - . nbgcmax,glb_ncformat,glb_compflag, - . glb_fnametag,filefq_bgc,diagfq_bgc, - . filemon_bgc,fileann_bgc,ip,wrtlyr,wrtlvl, - . loglyr,inilvl,inilyr,inisrf,loglvl, - . msklvl,wrtsrf,msksrf,finlyr -#ifdef AGG - use mo_bgcmean, only: lyr_nos,lyr_wphy, lyr_wnos,lyr_eps, - . lyr_asize,lvl_nos,lvl_wphy,lvl_wnos,lvl_eps, - . lvl_asize -#endif -#ifdef BROMO - use mo_bgcmean, only: jbromo,jbromofx,jsrfbromo,jbromo_prod, - . jbromo_uv,jatmbromo,lvl_bromo,srf_bromofx, - . srf_bromo,int_bromopro,int_bromouv, - . srf_atmbromo,lyr_bromo -#endif -#ifdef CFC - use mo_bgcmean,only: jcfc11,jcfc12,jsf6,jcfc11fx,jcfc12fx,jsf6fx, - . lvl_cfc11,lvl_cfc12,lvl_sf6,srf_cfc11, - . srf_cfc12,srf_sf6,lyr_cfc11,lyr_cfc12, - . lyr_sf6 -#endif -#ifdef cisonew - use mo_biomod, only: c14fac - use mo_bgcmean, only: jdic13,jdic14,jd13c,jd14c,jbigd14c,jpoc13, - . jdoc13,jcalc13,jphyto13,jgrazer13,jco213fxd, - . jco213fxu,jco214fxd,jco214fxu,jatmc13, - . jatmc14,jdic13,jdic14,jd13c,jd14c,jbigd14c, - . srf_co213fxd,srf_co213fxu,srf_co214fxd, - . srf_co214fxu,srf_atmc13,srf_atmc14,lyr_dic13, - . lyr_dic14,lyr_d13c,lyr_d14c,lyr_bigd14c, - . lyr_poc13,lyr_doc13,lyr_calc13,lyr_phyto13, - . lyr_grazer13,lvl_dic13,lvl_dic14,lvl_d13c, - . lvl_d14c,lvl_bigd14c,lvl_poc13,lvl_doc13, - . lvl_calc13,lvl_phyto13,lvl_grazer13 -#endif -#ifdef natDIC - use mo_bgcmean, only: jnatalkali,jnatdic,jnatcalc,jnatco3,jnatph, - . jnatomegaa,jnatomegac,lyr_natph,jlvlnatph, - . lvl_natph,jsrfnatdic, - . jsrfnatalk,jnatpco2,jnatco2fx,lyr_natco3, - . lyr_natalkali,lyr_natdic,lyr_natcalc, - . lyr_natomegaa,lyr_natomegac,lvl_natco3, - . lvl_natalkali,lvl_natdic,lvl_natcalc, - . lvl_natomegaa,lvl_natomegac,srf_natdic, - . srf_natalkali,srf_natpco2,srf_natco2fx -#endif -#ifndef sedbypass - use mo_bgcmean, only: jpowaic,jpowaal,jpowaph,jpowaox,jpown2, - . jpowno3,jpowasi,jssso12,jssssil,jssster, - . jsssc12,jbursssc12,jburssssil,jburssster, - . sdm_powaic,sdm_powaal,sdm_powaph,sdm_powaox, - . sdm_pown2,sdm_powno3,sdm_powasi,sdm_ssso12, - . sdm_ssssil,sdm_sssc12,sdm_ssster,jburssso12, - . bur_sssc12,bur_ssssil,bur_ssster,bur_ssso12, - . inisdm,inibur,wrtsdm,accbur,accsdm,wrtbur -#endif -#ifdef extNcycle - use mo_bgcmean, only: janh4,jano2,jlvlanh4,jlvlano2,jsrfanh4, - . jsrfano2,janh3fx,srf_anh4,srf_ano2, - . srf_anh3fx,lyr_anh4,lyr_ano2,lvl_anh4, - . lvl_ano2, - . LYR_nitr_NH4,LYR_nitr_NO2,LYR_nitr_N2O_prod, - . LYR_nitr_NH4_OM,LYR_nitr_NO2_OM, - . LYR_denit_NO3,LYR_denit_NO2,LYR_denit_N2O, - . LYR_DNRA_NO2,LYR_anmx_N2_prod, - . LYR_anmx_OM_prod,LYR_phosy_NH4, - . LYR_phosy_NO3,LYR_remin_aerob,LYR_remin_sulf, - . LVL_nitr_NH4,LVL_nitr_NO2,LVL_nitr_N2O_prod, - . LVL_nitr_NH4_OM,LVL_nitr_NO2_OM, - . LVL_denit_NO3,LVL_denit_NO2,LVL_denit_N2O, - . LVL_DNRA_NO2,LVL_anmx_N2_prod, - . LVL_anmx_OM_prod,LVL_phosy_NH4, - . LVL_phosy_NO3,LVL_remin_aerob,LVL_remin_sulf, - . jnitr_NH4,jnitr_NO2,jnitr_N2O_prod, - . jnitr_NH4_OM,jnitr_NO2_OM,jdenit_NO3, - . jdenit_NO2,jdenit_N2O,jDNRA_NO2, - . janmx_N2_prod,janmx_OM_prod,jphosy_NH4, - . jphosy_NO3,jremin_aerob,jremin_sulf, - . jlvl_nitr_NH4,jlvl_nitr_NO2, - . jlvl_nitr_N2O_prod,jlvl_nitr_NH4_OM, - . jlvl_nitr_NO2_OM,jlvl_denit_NO3, - . jlvl_denit_NO2,jlvl_denit_N2O,jlvl_DNRA_NO2, - . jlvl_anmx_N2_prod,jlvl_anmx_OM_prod, - . jlvl_phosy_NH4,jlvl_phosy_NO3, - . jlvl_remin_aerob,jlvl_remin_sulf -#endif -c - implicit none -c - integer iogrp -c - integer i,j,k,l,nt - integer ny,nm,nd,dayfrac,irec(nbgcmax),cmpflg - character*256 fname(nbgcmax) - character startdate*20,timeunits*30 - real datenum,rnacc - logical append2file(nbgcmax) - data append2file /nbgcmax*.false./ - save fname,irec,append2file -c -c --- set time information - timeunits=' ' - startdate=' ' - write(timeunits,'(a11,i4.4,a1,i2.2,a1,i2.2,a6)') - . 'days since ',min(1800,date0%year),'-',1,'-',1,' 00:00' - write(startdate,'(i4.4,a1,i2.2,a1,i2.2,a6)') - . date0%year,'-',date0%month,'-',date0%day,' 00:00' - datenum=time-time0-0.5*diagfq_bgc(iogrp)/nstep_in_day -c -c --- get file name - if (.not.append2file(iogrp)) then - call diafnm(GLB_FNAMETAG(iogrp), - . filefq_bgc(iogrp)/real(nstep_in_day), - . filemon_bgc(iogrp),fileann_bgc(iogrp),fname(iogrp)) - append2file(iogrp)=.true. - irec(iogrp)=1 - else - irec(iogrp)=irec(iogrp)+1 - endif - if (((fileann_bgc(iogrp).and.nday_of_year.eq.1.or. - . filemon_bgc(iogrp).and.date%day.eq.1).and. - . mod(nstep,nstep_in_day).eq.0).or. - . .not.(fileann_bgc(iogrp).or.filemon_bgc(iogrp)).and. - . mod(nstep+.5,filefq_bgc(iogrp)).lt.1.) then - append2file(iogrp)=.false. - endif -c -c --- prepare output fields - if (mnproc.eq.1) then - write (lp,'(a,f6.2,a)') ' ncwrt_bgc: fields averaged over ', - . real(nacc_bgc(iogrp)),' steps' - write(lp,*) 'irec(iogrp)',irec(iogrp) - endif - rnacc=1./real(nacc_bgc(iogrp)) - cmpflg=GLB_COMPFLAG(iogrp) -c -c --- create output file - if (GLB_NCFORMAT(iogrp).eq.1) then - call ncfopn(fname(iogrp),'w','6',irec(iogrp),iotype) - elseif (GLB_NCFORMAT(iogrp).eq.2) then - call ncfopn(fname(iogrp),'w','h',irec(iogrp),iotype) - else - call ncfopn(fname(iogrp),'w','c',irec(iogrp),iotype) - endif -c -c --- define spatial and time dimensions - if (cmpflg.ne.0) then - call ncdimc('pcomp',ip,0) - else - call ncdims('x',itdm) - call ncdims('y',jtdm) - endif - call ncdims('sigma',kdm) - call ncdims('depth',ddm) - call ncdims('ks',ks) - call ncdims('bounds',2) - call ncdims('time',0) - call hamoccvardef(iogrp,timeunits,calendar,cmpflg) - call nctime(datenum,calendar,timeunits,startdate) -c -c --- write auxillary dimension information - call ncwrt1('sigma','sigma',sigmar1) - call ncwrt1('depth','depth',depthslev) - call ncwrt1('depth_bnds','bounds depth',depthslev_bnds) -c -c --- finalize accumulation - call finlyr(jphyto(iogrp),jdp(iogrp)) - call finlyr(jgrazer(iogrp),jdp(iogrp)) - call finlyr(jdoc(iogrp),jdp(iogrp)) - call finlyr(jphosy(iogrp),jdp(iogrp)) - call finlyr(jphosph(iogrp),jdp(iogrp)) - call finlyr(joxygen(iogrp),jdp(iogrp)) - call finlyr(jiron(iogrp),jdp(iogrp)) - call finlyr(jano3(iogrp),jdp(iogrp)) - call finlyr(jalkali(iogrp),jdp(iogrp)) - call finlyr(jsilica(iogrp),jdp(iogrp)) - call finlyr(jdic(iogrp),jdp(iogrp)) - call finlyr(jpoc(iogrp),jdp(iogrp)) - call finlyr(jcalc(iogrp),jdp(iogrp)) - call finlyr(jopal(iogrp),jdp(iogrp)) - call finlyr(jco3(iogrp),jdp(iogrp)) - call finlyr(jph(iogrp),jdp(iogrp)) - call finlyr(jomegaa(iogrp),jdp(iogrp)) - call finlyr(jomegac(iogrp),jdp(iogrp)) - call finlyr(jn2o(iogrp),jdp(iogrp)) - call finlyr(jprefo2(iogrp),jdp(iogrp)) - call finlyr(jo2sat(iogrp),jdp(iogrp)) - call finlyr(jprefpo4(iogrp),jdp(iogrp)) - call finlyr(jprefalk(iogrp),jdp(iogrp)) - call finlyr(jprefdic(iogrp),jdp(iogrp)) - call finlyr(jdicsat(iogrp),jdp(iogrp)) -#ifdef cisonew - call finlyr(jdic13(iogrp),jdp(iogrp)) - call finlyr(jdic14(iogrp),jdp(iogrp)) - call finlyr(jd13c(iogrp),jdp(iogrp)) - call finlyr(jd14c(iogrp),jdp(iogrp)) - call finlyr(jbigd14c(iogrp),jdp(iogrp)) - call finlyr(jpoc13(iogrp),jdp(iogrp)) - call finlyr(jdoc13(iogrp),jdp(iogrp)) - call finlyr(jcalc13(iogrp),jdp(iogrp)) - call finlyr(jphyto13(iogrp),jdp(iogrp)) - call finlyr(jgrazer13(iogrp),jdp(iogrp)) -#endif -#ifdef AGG - call finlyr(jnos(iogrp),jdp(iogrp)) - call finlyr(jwphy(iogrp),jdp(iogrp)) - call finlyr(jwnos(iogrp),jdp(iogrp)) - call finlyr(jeps(iogrp),jdp(iogrp)) - call finlyr(jasize(iogrp),jdp(iogrp)) -#endif -#ifdef CFC - call finlyr(jcfc11(iogrp),jdp(iogrp)) - call finlyr(jcfc12(iogrp),jdp(iogrp)) - call finlyr(jsf6(iogrp),jdp(iogrp)) -#endif -#ifdef natDIC - call finlyr(jnatalkali(iogrp),jdp(iogrp)) - call finlyr(jnatdic(iogrp),jdp(iogrp)) - call finlyr(jnatcalc(iogrp),jdp(iogrp)) - call finlyr(jnatco3(iogrp),jdp(iogrp)) - call finlyr(jnatph(iogrp),jdp(iogrp)) - call finlyr(jnatomegaa(iogrp),jdp(iogrp)) - call finlyr(jnatomegac(iogrp),jdp(iogrp)) -#endif -#ifdef BROMO - call finlyr(jbromo(iogrp),jdp(iogrp)) -#endif -#ifdef extNcycle - call finlyr(janh4(iogrp),jdp(iogrp)) - call finlyr(jano2(iogrp),jdp(iogrp)) - call finlyr(jnitr_NH4(iogrp),jdp(iogrp)) - call finlyr(jnitr_NO2(iogrp),jdp(iogrp)) - call finlyr(jnitr_N2O_prod(iogrp),jdp(iogrp)) - call finlyr(jnitr_NH4_OM(iogrp),jdp(iogrp)) - call finlyr(jnitr_NO2_OM(iogrp),jdp(iogrp)) - call finlyr(jdenit_NO3(iogrp),jdp(iogrp)) - call finlyr(jdenit_NO2(iogrp),jdp(iogrp)) - call finlyr(jdenit_N2O(iogrp),jdp(iogrp)) - call finlyr(jDNRA_NO2(iogrp),jdp(iogrp)) - call finlyr(janmx_N2_prod(iogrp),jdp(iogrp)) - call finlyr(janmx_OM_prod(iogrp),jdp(iogrp)) - call finlyr(jphosy_NH4(iogrp),jdp(iogrp)) - call finlyr(jphosy_NO3(iogrp),jdp(iogrp)) - call finlyr(jremin_aerob(iogrp),jdp(iogrp)) - call finlyr(jremin_sulf(iogrp),jdp(iogrp)) -#endif - -c -c --- Mask sea floor in mass fluxes - call msksrf(jcarflx0100(iogrp),k0100) - call msksrf(jcarflx0500(iogrp),k0500) - call msksrf(jcarflx1000(iogrp),k1000) - call msksrf(jcarflx2000(iogrp),k2000) - call msksrf(jcarflx4000(iogrp),k4000) - call msksrf(jbsiflx0100(iogrp),k0100) - call msksrf(jbsiflx0500(iogrp),k0500) - call msksrf(jbsiflx1000(iogrp),k1000) - call msksrf(jbsiflx2000(iogrp),k2000) - call msksrf(jbsiflx4000(iogrp),k4000) - call msksrf(jcalflx0100(iogrp),k0100) - call msksrf(jcalflx0500(iogrp),k0500) - call msksrf(jcalflx1000(iogrp),k1000) - call msksrf(jcalflx2000(iogrp),k2000) - call msksrf(jcalflx4000(iogrp),k4000) -c -c --- Mask sea floor in level data - call msklvl(jlvlphyto(iogrp),depths) - call msklvl(jlvlgrazer(iogrp),depths) - call msklvl(jlvldoc(iogrp),depths) - call msklvl(jlvlphosy(iogrp),depths) - call msklvl(jlvlphosph(iogrp),depths) - call msklvl(jlvloxygen(iogrp),depths) - call msklvl(jlvliron(iogrp),depths) - call msklvl(jlvlano3(iogrp),depths) - call msklvl(jlvlalkali(iogrp),depths) - call msklvl(jlvlsilica(iogrp),depths) - call msklvl(jlvldic(iogrp),depths) - call msklvl(jlvlpoc(iogrp),depths) - call msklvl(jlvlcalc(iogrp),depths) - call msklvl(jlvlopal(iogrp),depths) - call msklvl(jlvlco3(iogrp),depths) - call msklvl(jlvlph(iogrp),depths) - call msklvl(jlvlomegaa(iogrp),depths) - call msklvl(jlvlomegac(iogrp),depths) - call msklvl(jlvln2o(iogrp),depths) - call msklvl(jlvlprefo2(iogrp),depths) - call msklvl(jlvlo2sat(iogrp),depths) - call msklvl(jlvlprefpo4(iogrp),depths) - call msklvl(jlvlprefalk(iogrp),depths) - call msklvl(jlvlprefdic(iogrp),depths) - call msklvl(jlvldicsat(iogrp),depths) -#ifdef cisonew - call msklvl(jlvldic13(iogrp),depths) - call msklvl(jlvldic14(iogrp),depths) - call msklvl(jlvld13c(iogrp),depths) - call msklvl(jlvld14c(iogrp),depths) - call msklvl(jlvlbigd14c(iogrp),depths) - call msklvl(jlvlpoc13(iogrp),depths) - call msklvl(jlvldoc13(iogrp),depths) - call msklvl(jlvlcalc13(iogrp),depths) - call msklvl(jlvlphyto13(iogrp),depths) - call msklvl(jlvlgrazer13(iogrp),depths) -#endif -#ifdef AGG - call msklvl(jlvlnos(iogrp),depths) - call msklvl(jlvlwphy(iogrp),depths) - call msklvl(jlvlwnos(iogrp),depths) - call msklvl(jlvleps(iogrp),depths) - call msklvl(jlvlasize(iogrp),depths) -#endif -#ifdef CFC - call msklvl(jlvlcfc11(iogrp),depths) - call msklvl(jlvlcfc12(iogrp),depths) - call msklvl(jlvlsf6(iogrp),depths) -#endif -#ifdef natDIC - call msklvl(jlvlnatalkali(iogrp),depths) - call msklvl(jlvlnatdic(iogrp),depths) - call msklvl(jlvlnatcalc(iogrp),depths) - call msklvl(jlvlnatco3(iogrp),depths) - call msklvl(jlvlnatph(iogrp),depths) - call msklvl(jlvlnatomegaa(iogrp),depths) - call msklvl(jlvlnatomegac(iogrp),depths) -#endif -#ifdef BROMO - call msklvl(jlvlbromo(iogrp),depths) -#endif -#ifdef extNcycle - call msklvl(jlvlanh4(iogrp),depths) - call msklvl(jlvlano2(iogrp),depths) - call msklvl(jlvl_nitr_NH4(iogrp),depths) - call msklvl(jlvl_nitr_NO2(iogrp),depths) - call msklvl(jlvl_nitr_N2O_prod(iogrp),depths) - call msklvl(jlvl_nitr_NH4_OM(iogrp),depths) - call msklvl(jlvl_nitr_NO2_OM(iogrp),depths) - call msklvl(jlvl_denit_NO3(iogrp),depths) - call msklvl(jlvl_denit_NO2(iogrp),depths) - call msklvl(jlvl_denit_N2O(iogrp),depths) - call msklvl(jlvl_DNRA_NO2(iogrp),depths) - call msklvl(jlvl_anmx_N2_prod(iogrp),depths) - call msklvl(jlvl_anmx_OM_prod(iogrp),depths) - call msklvl(jlvl_phosy_NH4(iogrp),depths) - call msklvl(jlvl_phosy_NO3(iogrp),depths) - call msklvl(jlvl_remin_aerob(iogrp),depths) - call msklvl(jlvl_remin_sulf(iogrp),depths) -#endif - -c -c --- Compute log10 of pH - if (LYR_PH(iogrp).ne.0) call loglyr(jph(iogrp),1.,0.) - if (LVL_PH(iogrp).ne.0) call loglvl(jlvlph(iogrp),rnacc,0.) -#ifdef natDIC - if (LYR_NATPH(iogrp).ne.0) call loglyr(jnatph(iogrp),1.,0.) - if (LVL_NATPH(iogrp).ne.0) call loglvl(jlvlnatph(iogrp),rnacc,0.) -#endif -c -c --- Store 2d fields - call wrtsrf(jkwco2(iogrp),SRF_KWCO2(iogrp),rnacc,0.,cmpflg, - . 'kwco2',' ',' ',' ') - call wrtsrf(jpco2(iogrp),SRF_PCO2(iogrp),rnacc,0.,cmpflg, - . 'pco2','Surface PCO2',' ','uatm') - call wrtsrf(jdmsflux(iogrp),SRF_DMSFLUX(iogrp),rnacc*1e3/dtbgc,0., - . cmpflg,'dmsflux','DMS flux',' ','mol DMS m-2 s-1') - call wrtsrf(jco2fxd(iogrp),SRF_CO2FXD(iogrp),rnacc*12./dtbgc,0., - . cmpflg,'co2fxd','Downward CO2 flux',' ','kg C m-2 s-1') - call wrtsrf(jco2fxu(iogrp),SRF_CO2FXU(iogrp),rnacc*12./dtbgc,0., - . cmpflg,'co2fxu','Upward CO2 flux',' ','kg C m-2 s-1') - call wrtsrf(joxflux(iogrp),SRF_OXFLUX(iogrp),rnacc*1e3/dtbgc,0., - . cmpflg,'fgo2','Oxygen flux',' ','mol O2 m-2 s-1') - call wrtsrf(jniflux(iogrp),SRF_NIFLUX(iogrp),rnacc*1e3/dtbgc,0., - . cmpflg,'fgn2','Nitrogen flux',' ','mol N2 m-2 s-1') - call wrtsrf(jdms(iogrp),SRF_DMS(iogrp),rnacc,0.,cmpflg, - . 'dms','DMS',' ','kmol DMS m-3') - call wrtsrf(jdmsprod(iogrp),SRF_DMSPROD(iogrp),rnacc*1e3/dtbgc,0., - . cmpflg,'dmsprod','DMS production from phytoplankton production', - . ' ','mol DMS m-2 s-1') - call wrtsrf(jdms_bac(iogrp),SRF_DMS_BAC(iogrp),rnacc*1e3/dtbgc,0., - . cmpflg,'dms_bac','DMS bacterial consumption',' ', - . 'mol DMS m-2 s-1') - call wrtsrf(jdms_uv(iogrp),SRF_DMS_UV(iogrp),rnacc*1e3/dtbgc,0., - . cmpflg,'dms_uv','DMS photolysis reduction',' ','mol DMS m-2 s-1') - call wrtsrf(jexport(iogrp),SRF_EXPORT(iogrp),rnacc*1e3/dtbgc,0., - . cmpflg,'epc100','Export production',' ','mol C m-2 s-1') - call wrtsrf(jexposi(iogrp),SRF_EXPOSI(iogrp),rnacc*1e3/dtbgc,0., - . cmpflg,'epsi100','Si export production',' ','mol Si m-2 s-1') - call wrtsrf(jexpoca(iogrp),SRF_EXPOCA(iogrp),rnacc*1e3/dtbgc,0., - . cmpflg,'epcalc100','Ca export production',' ','mol Ca m-2 s-1') - call wrtsrf(jsrfdic(iogrp),SRF_DIC(iogrp), - . rnacc*1e3,0.,cmpflg,'srfdissic', - . 'Surface dissolved inorganic carbon',' ','mol C m-3') - call wrtsrf(jsrfalkali(iogrp),SRF_ALKALI(iogrp), - . rnacc*1e3,0.,cmpflg,'srftalk', - . 'Surface alkalinity',' ','eq m-3') - call wrtsrf(jsrfphosph(iogrp),SRF_PHOSPH(iogrp), - . rnacc*1e3,0.,cmpflg,'srfpo4', - . 'Surface phosphorus',' ','mol P m-3') - call wrtsrf(jsrfoxygen(iogrp),SRF_OXYGEN(iogrp), - . rnacc*1e3,0.,cmpflg,'srfo2', - . 'Surface oxygen',' ','mol O2 m-3') - call wrtsrf(jsrfano3(iogrp),SRF_ANO3(iogrp), - . rnacc*1e3,0.,cmpflg,'srfno3', - . 'Surface nitrate',' ','mol N m-3') - call wrtsrf(jsrfsilica(iogrp),SRF_SILICA(iogrp), - . rnacc*1e3,0.,cmpflg,'srfsi', - . 'Surface silicate',' ','mol Si m-3') - call wrtsrf(jsrfiron(iogrp),SRF_IRON(iogrp), - . rnacc*1e3,0.,cmpflg,'srfdfe', - . 'Surface dissolved iron',' ','mol Fe m-3') - call wrtsrf(jsrfphyto(iogrp),SRF_PHYTO(iogrp), - . rnacc*1e3,0.,cmpflg,'srfphyc', - . 'Surface phytoplankton',' ','mol P m-3') - call wrtsrf(jintphosy(iogrp),INT_PHOSY(iogrp), - . rnacc*1e3/dtbgc,0.,cmpflg,'ppint', - . 'Integrated primary production',' ','mol C m-2 s-1') - call wrtsrf(jintnfix(iogrp),INT_NFIX(iogrp), - . rnacc*1e3/dtbgc,0.,cmpflg,'nfixint', - . 'Integrated nitrogen fixation',' ','mol N m-2 s-1') - call wrtsrf(jintdnit(iogrp),INT_DNIT(iogrp), - . rnacc*1e3/dtbgc,0.,cmpflg,'dnitint', - . 'Integrated denitrification',' ','mol N m-2 s-1') - call wrtsrf(jcarflx0100(iogrp),FLX_CAR0100(iogrp), - . rnacc*1e3/dtbgc,0.,cmpflg,'carflx0100', - . 'C flux at 100m',' ','mol C m-2 s-1') - call wrtsrf(jcarflx0500(iogrp),FLX_CAR0500(iogrp), - . rnacc*1e3/dtbgc,0.,cmpflg,'carflx0500', - . 'C flux at 500m',' ','mol C m-2 s-1') - call wrtsrf(jcarflx1000(iogrp),FLX_CAR1000(iogrp), - . rnacc*1e3/dtbgc,0.,cmpflg,'carflx1000', - . 'C flux at 1000m',' ','mol C m-2 s-1') - call wrtsrf(jcarflx2000(iogrp),FLX_CAR2000(iogrp), - . rnacc*1e3/dtbgc,0.,cmpflg,'carflx2000', - . 'C flux at 2000m',' ','mol C m-2 s-1') - call wrtsrf(jcarflx4000(iogrp),FLX_CAR4000(iogrp), - . rnacc*1e3/dtbgc,0.,cmpflg,'carflx4000', - . 'C flux at 4000m',' ','mol C m-2 s-1') - call wrtsrf(jcarflx_bot(iogrp),FLX_CAR_BOT(iogrp), - . rnacc*1e3/dtbgc,0.,cmpflg,'carflx_bot', - . 'C flux to sediment',' ','mol C m-2 s-1') - call wrtsrf(jbsiflx0100(iogrp),FLX_BSI0100(iogrp), - . rnacc*1e3/dtbgc,0.,cmpflg,'bsiflx0100', - . 'Opal flux at 100m',' ','mol Si m-2 s-1') - call wrtsrf(jbsiflx0500(iogrp),FLX_BSI0500(iogrp), - . rnacc*1e3/dtbgc,0.,cmpflg,'bsiflx0500', - . 'Opal flux at 500m',' ','mol Si m-2 s-1') - call wrtsrf(jbsiflx1000(iogrp),FLX_BSI1000(iogrp), - . rnacc*1e3/dtbgc,0.,cmpflg,'bsiflx1000', - . 'Opal flux at 1000m',' ','mol Si m-2 s-1') - call wrtsrf(jbsiflx2000(iogrp),FLX_BSI2000(iogrp), - . rnacc*1e3/dtbgc,0.,cmpflg,'bsiflx2000', - . 'Opal flux at 2000m',' ','mol Si m-2 s-1') - call wrtsrf(jbsiflx4000(iogrp),FLX_BSI4000(iogrp), - . rnacc*1e3/dtbgc,0.,cmpflg,'bsiflx4000', - . 'Opal flux at 4000m',' ','mol Si m-2 s-1') - call wrtsrf(jbsiflx_bot(iogrp),FLX_BSI_BOT(iogrp), - . rnacc*1e3/dtbgc,0.,cmpflg,'bsiflx_bot', - . 'Opal flux to sediment',' ','mol Si m-2 s-1') - call wrtsrf(jcalflx0100(iogrp),FLX_CAL0100(iogrp), - . rnacc*1e3/dtbgc,0.,cmpflg,'calflx0100', - . 'CaCO3 flux at 100m',' ','mol Ca m-2 s-1') - call wrtsrf(jcalflx0500(iogrp),FLX_CAL0500(iogrp), - . rnacc*1e3/dtbgc,0.,cmpflg,'calflx0500', - . 'CaCO3 flux at 500m',' ','mol Ca m-2 s-1') - call wrtsrf(jcalflx1000(iogrp),FLX_CAL1000(iogrp), - . rnacc*1e3/dtbgc,0.,cmpflg,'calflx1000', - . 'CaCO3 flux at 1000m',' ','mol Ca m-2 s-1') - call wrtsrf(jcalflx2000(iogrp),FLX_CAL2000(iogrp), - . rnacc*1e3/dtbgc,0.,cmpflg,'calflx2000', - . 'CaCO3 flux at 2000m',' ','mol Ca m-2 s-1') - call wrtsrf(jcalflx4000(iogrp),FLX_CAL4000(iogrp), - . rnacc*1e3/dtbgc,0.,cmpflg,'calflx4000', - . 'CaCO3 flux at 4000m',' ','mol Ca m-2 s-1') - call wrtsrf(jcalflx_bot(iogrp),FLX_CAL_BOT(iogrp), - . rnacc*1e3/dtbgc,0.,cmpflg,'calflx_bot', - . 'CaCO3 flux to sediment',' ','mol Ca m-2 s-1') -#ifndef sedbypass - call wrtsrf(jsediffic(iogrp),FLX_SEDIFFIC(iogrp), - . rnacc*1e3/dtbgc,0.,cmpflg,'sedfdic',' ',' ',' ') - call wrtsrf(jsediffal(iogrp),FLX_SEDIFFAL(iogrp), - . rnacc*1e3/dtbgc,0.,cmpflg,'sedfalk',' ',' ',' ') - call wrtsrf(jsediffph(iogrp),FLX_SEDIFFPH(iogrp), - . rnacc*1e3/dtbgc,0.,cmpflg,'sedfpho',' ',' ',' ') - call wrtsrf(jsediffox(iogrp),FLX_SEDIFFOX(iogrp), - . rnacc*1e3/dtbgc,0.,cmpflg,'sedfox',' ',' ',' ') - call wrtsrf(jsediffn2(iogrp),FLX_SEDIFFN2(iogrp), - . rnacc*1e3/dtbgc,0.,cmpflg,'sedfn2',' ',' ',' ') - call wrtsrf(jsediffno3(iogrp),FLX_SEDIFFNO3(iogrp), - . rnacc*1e3/dtbgc,0.,cmpflg,'sedfno3',' ',' ',' ') - call wrtsrf(jsediffsi(iogrp),FLX_SEDIFFSI(iogrp), - . rnacc*1e3/dtbgc,0.,cmpflg,'sedfsi',' ',' ',' ') -#endif - call wrtsrf(jn2ofx(iogrp),SRF_N2OFX(iogrp),rnacc*1e3/dtbgc,0., - . cmpflg,'n2oflux','N2O flux',' ','mol N2O m-2 s-1') -#ifdef cisonew - call wrtsrf(jco213fxd(iogrp),SRF_CO213FXD(iogrp), - . rnacc*12./dtbgc,0.,cmpflg,'co213fxd', - . 'Downward 13CO2 flux',' ','kg C m-2 s-1') - call wrtsrf(jco213fxu(iogrp),SRF_CO213FXU(iogrp), - . rnacc*12./dtbgc,0.,cmpflg,'co213fxu', - . 'Upward 13CO2 flux',' ','kg C m-2 s-1') - call wrtsrf(jco214fxd(iogrp),SRF_CO214FXD(iogrp), - . rnacc*12.*c14fac/dtbgc,0.,cmpflg,'co214fxd', - . 'Downward 14CO2 flux',' ','kg C m-2 s-1') - call wrtsrf(jco214fxu(iogrp),SRF_CO214FXU(iogrp), - . rnacc*12.*c14fac/dtbgc,0.,cmpflg,'co214fxu', - . 'Upward 14CO2 flux',' ','kg C m-2 s-1') -#endif -#ifdef CFC - call wrtsrf(jcfc11fx(iogrp),SRF_CFC11(iogrp),rnacc*1e3/dtbgc,0., - . cmpflg,'cfc11flux','CFC-11 flux',' ','mol CFC12 m-2 s-1') - call wrtsrf(jcfc12fx(iogrp),SRF_CFC12(iogrp),rnacc*1e3/dtbgc,0., - . cmpflg,'cfc12flux','CFC-12 flux',' ','mol CFC12 m-2 s-1') - call wrtsrf(jsf6fx(iogrp),SRF_SF6(iogrp),rnacc*1e3/dtbgc,0., - . cmpflg,'sf6flux','SF-6 flux',' ','mol SF6 m-2 s-1') -#endif -#ifdef natDIC - call wrtsrf(jsrfnatdic(iogrp),SRF_NATDIC(iogrp), - . rnacc*1e3,0.,cmpflg,'srfnatdissic', - . 'Surface natural dissolved inorganic carbon',' ','mol C m-3') - call wrtsrf(jsrfnatalk(iogrp),SRF_NATALKALI(iogrp), - . rnacc*1e3,0.,cmpflg,'srfnattalk', - . 'Surface natural alkalinity',' ','eq m-3') - call wrtsrf(jnatpco2(iogrp),SRF_NATPCO2(iogrp),rnacc,0.,cmpflg, - . 'natpco2','Surface natural PCO2',' ','uatm') - call wrtsrf(jnatco2fx(iogrp),SRF_NATCO2FX(iogrp), - . rnacc*12./dtbgc,0.,cmpflg,'natco2fx', - . 'Natural CO2 flux',' ','kg C m-2 s-1') -#endif -#ifdef BROMO - call wrtsrf(jbromofx(iogrp),SRF_BROMOFX(iogrp),rnacc*1e3/dtbgc, - . 0.,cmpflg,'bromofx','Bromoform flux',' ','mol CHBr3 m-2 s-1') - call wrtsrf(jsrfbromo(iogrp),SRF_BROMO(iogrp),rnacc*1e3,0., - . cmpflg,'srfbromo','Surface bromoform',' ','mol CHBr3 m-3') - call wrtsrf(jbromo_prod(iogrp),INT_BROMOPRO(iogrp), - . rnacc*1e3/dtbgc,0.,cmpflg,'intbromoprod', - . 'Integrated bromoform production',' ','mol CHBr3 m-2 s-1') - call wrtsrf(jbromo_uv(iogrp),INT_BROMOUV(iogrp), - . rnacc*1e3/dtbgc,0.,cmpflg,'intbromouv', - . 'Integrated bromoform loss to photolysis',' ', - . 'mol CHBr3 m-2 s-1') - call wrtsrf(jatmbromo(iogrp),SRF_ATMBROMO(iogrp),rnacc,0., - . cmpflg,'atmbromo','Atmospheric bromoform',' ','ppt') -#endif - - - call wrtsrf(jatmco2(iogrp),SRF_ATMCO2(iogrp),rnacc,0.,cmpflg, - . 'atmco2','Atmospheric CO2',' ','ppm') -#if defined(BOXATM) - call wrtsrf(jatmo2(iogrp),SRF_ATMO2(iogrp),rnacc,0.,cmpflg, - . 'atmo2','Atmospheric O2',' ','ppm') - call wrtsrf(jatmn2(iogrp),SRF_ATMN2(iogrp),rnacc,0.,cmpflg, - . 'atmn2','Atmospheric N2',' ','ppm') -#endif -#ifdef cisonew - call wrtsrf(jatmc13(iogrp),SRF_ATMC13(iogrp),rnacc,0.,cmpflg, - . 'atmc13','Atmospheric 13CO2',' ','ppm') - call wrtsrf(jatmc14(iogrp),SRF_ATMC14(iogrp),rnacc,0.,cmpflg, - . 'atmc14','Atmospheric 14CO2',' ','ppm') -#endif -#ifdef extNcycle - call wrtsrf(jsrfanh4(iogrp),SRF_ANH4(iogrp), - . rnacc*1e3,0.,cmpflg,'srfnh4', - . 'Surface ammonium',' ','mol N m-3') - call wrtsrf(jsrfano2(iogrp),SRF_ANO2(iogrp), - . rnacc*1e3,0.,cmpflg,'srfno2', - . 'Surface nitrite',' ','mol N m-3') - call wrtsrf(janh3fx(iogrp),SRF_ANH3FX(iogrp),rnacc*1e3/dtbgc,0., - . cmpflg,'nh3flux','NH3 flux',' ','mol NH3 m-2 s-1') -#endif -c -c --- Store 3d layer fields - call wrtlyr(jdp(iogrp),LYR_DP(iogrp),rnacc,0.,cmpflg, - . 'pddpo','Layer thickness',' ','m') - call wrtlyr(jdic(iogrp),LYR_DIC(iogrp),1e3,0.,cmpflg, - . 'dissic','Dissolved inorganic carbon',' ','mol C m-3') - call wrtlyr(jalkali(iogrp),LYR_ALKALI(iogrp),1e3,0.,cmpflg, - . 'talk','Alkalinity',' ','eq m-3') - call wrtlyr(jphosph(iogrp),LYR_PHOSPH(iogrp),1e3,0.,cmpflg, - . 'po4','Phosphorus',' ','mol P m-3') - call wrtlyr(joxygen(iogrp),LYR_OXYGEN(iogrp),1e3,0.,cmpflg, - . 'o2','Oxygen',' ','mol O2 m-3') - call wrtlyr(jano3(iogrp),LYR_ANO3(iogrp),1e3,0.,cmpflg, - . 'no3','Nitrate',' ','mol N m-3') - call wrtlyr(jsilica(iogrp),LYR_SILICA(iogrp),1e3,0.,cmpflg, - . 'si','Silicate',' ','mol Si m-3') - call wrtlyr(jdoc(iogrp),LYR_DOC(iogrp),1e3,0.,cmpflg, - . 'dissoc','Dissolved organic carbon',' ','mol P m-3') - call wrtlyr(jphyto(iogrp),LYR_PHYTO(iogrp),1e3,0.,cmpflg, - . 'phyc','Phytoplankton',' ','mol P m-3') - call wrtlyr(jgrazer(iogrp),LYR_GRAZER(iogrp),1e3,0.,cmpflg, - . 'zooc','Zooplankton',' ','mol P m-3') - call wrtlyr(jpoc(iogrp),LYR_POC(iogrp),1e3,0.,cmpflg, - . 'detoc','Detritus',' ','mol P m-3') - call wrtlyr(jcalc(iogrp),LYR_CALC(iogrp),1e3,0.,cmpflg, - . 'calc','CaCO3 shells',' ','mol C m-3') - call wrtlyr(jopal(iogrp),LYR_OPAL(iogrp),1e3,0.,cmpflg, - . 'opal','Opal shells',' ','mol Si m-3') - call wrtlyr(jiron(iogrp),LYR_IRON(iogrp),1e3,0.,cmpflg, - . 'dfe','Dissolved iron',' ','mol Fe m-3') - call wrtlyr(jphosy(iogrp),LYR_PHOSY(iogrp),1e3/dtbgc,0.,cmpflg, - . 'pp','Primary production',' ','mol C m-3 s-1') - call wrtlyr(jco3(iogrp),LYR_CO3(iogrp),1e3,0.,cmpflg, - . 'co3','Carbonate ions',' ','mol C m-3') - call wrtlyr(jph(iogrp),LYR_PH(iogrp),-1.,0.,cmpflg, - . 'ph','pH',' ','-log10([h+])') - call wrtlyr(jomegaa(iogrp),LYR_OMEGAA(iogrp),1.,0.,cmpflg, - . 'omegaa','OmegaA',' ','-') - call wrtlyr(jomegac(iogrp),LYR_OMEGAC(iogrp),1.,0.,cmpflg, - . 'omegac','OmegaC',' ','-') - call wrtlyr(jn2o(iogrp),LYR_N2O(iogrp),1e3,0.,cmpflg, - . 'n2o','N2O',' ','mol N2O m-3') - call wrtlyr(jprefo2(iogrp),LYR_PREFO2(iogrp),1e3,0.,cmpflg, - . 'p_o2','Preformed oxygen',' ','mol O2 m-3') - call wrtlyr(jo2sat(iogrp),LYR_O2SAT(iogrp),1e3,0.,cmpflg, - . 'satoxy','Saturated oxygen',' ','mol O2 m-3') - call wrtlyr(jprefpo4(iogrp),LYR_PREFPO4(iogrp),1e3,0.,cmpflg, - . 'p_po4','Preformed phosphorus',' ','mol P m-3') - call wrtlyr(jprefalk(iogrp),LYR_PREFALK(iogrp),1e3,0.,cmpflg, - . 'p_talk','Preformed alkalinity',' ','eq m-3') - call wrtlyr(jprefdic(iogrp),LYR_PREFDIC(iogrp),1e3,0.,cmpflg, - . 'p_dic','Preformed DIC',' ','mol C m-3') - call wrtlyr(jdicsat(iogrp),LYR_DICSAT(iogrp),1e3,0.,cmpflg, - . 'sat_dic','Saturated DIC',' ','mol C m-3') -#ifdef cisonew - call wrtlyr(jdic13(iogrp),LYR_DIC13(iogrp),1.e3,0.,cmpflg, - . 'dissic13','Dissolved C13',' ','mol 13C m-3') - call wrtlyr(jdic14(iogrp),LYR_DIC14(iogrp),1.e3*c14fac,0.,cmpflg, - . 'dissic14','Dissolved C14',' ','mol 14C m-3') - call wrtlyr(jd13c(iogrp),LYR_D13C(iogrp),1.,0.,cmpflg, - . 'delta13c','delta13C of DIC',' ','permil') - call wrtlyr(jd14c(iogrp),LYR_D14C(iogrp),1.,0.,cmpflg, - . 'delta14c','delta14C of DIC',' ','permil') - call wrtlyr(jbigd14c(iogrp),LYR_BIGD14C(iogrp),1.,0.,cmpflg, - . 'bigdelta14c','big delta14C of DIC',' ','permil') - call wrtlyr(jpoc13(iogrp),LYR_POC13(iogrp),1e3,0.,cmpflg, - . 'detoc13','Detritus13',' ','mol P m-3') - call wrtlyr(jdoc13(iogrp),LYR_DOC13(iogrp),1e3,0.,cmpflg, - . 'dissoc13','Dissolved organic carbon13',' ','mol P m-3') - call wrtlyr(jcalc13(iogrp),LYR_CALC13(iogrp),1e3,0.,cmpflg, - . 'calc13','Ca13CO3 shells',' ','mol 13C m-3') - call wrtlyr(jphyto13(iogrp),LYR_PHYTO13(iogrp),1e3,0.,cmpflg, - . 'phyc13','Phytoplankton13',' ','mol P m-3') - call wrtlyr(jgrazer13(iogrp),LYR_GRAZER13(iogrp),1e3,0.,cmpflg, - . 'zooc13','Zooplankton13',' ','mol P m-3') -#endif -#ifdef AGG - call wrtlyr(jnos(iogrp),LYR_NOS(iogrp),1.,0.,cmpflg, - . 'nos','Marine snow aggregates per cm^3 sea water',' ','1/cm^3') - call wrtlyr(jwphy(iogrp),LYR_WPHY(iogrp),1.,0.,cmpflg, - . 'wphy','Av. mass sinking speed of marine snow',' ','m/day') - call wrtlyr(jwnos(iogrp),LYR_WNOS(iogrp),1.,0.,cmpflg, - . 'wnos','Av. number sinking speed of marine snow',' ','m/day') - call wrtlyr(jeps(iogrp),LYR_EPS(iogrp),1.,0.,cmpflg, - . 'eps','Av. size distribution exponent',' ','-') - call wrtlyr(jasize(iogrp),LYR_ASIZE(iogrp),1.,0.,cmpflg, - . 'asize','Av. size of marine snow aggregates',' ','nb. of cells') -#endif -#ifdef CFC - call wrtlyr(jcfc11(iogrp),LYR_CFC11(iogrp),1e3,0.,cmpflg, - . 'cfc11','CFC-11',' ','mol cfc11 m-3') - call wrtlyr(jcfc12(iogrp),LYR_CFC12(iogrp),1e3,0.,cmpflg, - . 'cfc12','CFC-12',' ','mol cfc12 m-3') - call wrtlyr(jsf6(iogrp),LYR_SF6(iogrp),1e3,0.,cmpflg, - . 'sf6','SF-6',' ','mol sf6 m-3') -#endif -#ifdef natDIC - call wrtlyr(jnatco3(iogrp),LYR_NATCO3(iogrp),1e3,0.,cmpflg, - . 'natco3','Natural Carbonate ions',' ','mol C m-3') - call wrtlyr(jnatalkali(iogrp),LYR_NATALKALI(iogrp),1e3,0.,cmpflg, - . 'nattalk','Natural alkalinity',' ','eq m-3') - call wrtlyr(jnatdic(iogrp),LYR_NATDIC(iogrp),1e3,0.,cmpflg, - . 'natdissic','Natural dissolved inorganic carbon',' ', - . 'mol C m-3') - call wrtlyr(jnatcalc(iogrp),LYR_NATCALC(iogrp),1e3,0.,cmpflg, - . 'natcalc','Natural CaCO3 shells',' ','mol C m-3') - call wrtlyr(jnatph(iogrp),LYR_NATPH(iogrp),-1.,0.,cmpflg, - . 'natph','Natural pH',' ','-log10([h+])') - call wrtlyr(jnatomegaa(iogrp),LYR_NATOMEGAA(iogrp),1.,0.,cmpflg, - . 'natomegaa','Natural OmegaA',' ','-') - call wrtlyr(jnatomegac(iogrp),LYR_NATOMEGAC(iogrp),1.,0.,cmpflg, - . 'natomegac','Natural OmegaC',' ','-') -#endif -#ifdef BROMO - call wrtlyr(jbromo(iogrp),LYR_BROMO(iogrp),1e3,0.,cmpflg, - . 'bromo','Bromoform',' ','mol CHBr3 m-3') -#endif -#ifdef extNcycle - call wrtlyr(janh4(iogrp),LYR_ANH4(iogrp),1e3,0.,cmpflg, - . 'nh4','Ammonium',' ','mol N m-3') - call wrtlyr(jano2(iogrp),LYR_ANO2(iogrp),1e3,0.,cmpflg, - . 'no2','Nitrite',' ','mol N m-3') - call wrtlyr(jnitr_NH4(iogrp),LYR_nitr_NH4(iogrp),1e3/dtbgc,0., - . cmpflg, - . 'nh4nitr','NH4 nitrification rate',' ','mol N m-3 s-1') - call wrtlyr(jnitr_NO2(iogrp),LYR_nitr_NO2(iogrp),1e3/dtbgc,0., - . cmpflg, - . 'no2nitr','NO2 nitrification rate',' ','mol N m-3 s-1') - call wrtlyr(jnitr_N2O_prod(iogrp),LYR_nitr_N2O_prod(iogrp), - . 1e3/dtbgc,0.,cmpflg, - . 'nitr_n2o','N2O prod during NH4 nitrification',' ', - . 'mol N2O m-3 s-1') - call wrtlyr(jnitr_NH4_OM(iogrp),LYR_nitr_NH4_OM(iogrp),1e3/dtbgc, - . 0.,cmpflg, - . 'nh4nitr_om','OM production during NH4 nitrification',' ', - . 'mol P m-3 s-1') - call wrtlyr(jnitr_NO2_OM(iogrp),LYR_nitr_NO2_OM(iogrp),1e3/dtbgc, - . 0.,cmpflg, - . 'no2nitr_om','OM production during NO2 nitrification',' ', - . 'mol P m-3 s-1') - call wrtlyr(jdenit_NO3(iogrp),LYR_denit_NO3(iogrp),1e3/dtbgc,0., - . cmpflg, - . 'no3denit','NO3 denitrification rate',' ','mol N m-3 s-1') - call wrtlyr(jdenit_NO2(iogrp),LYR_denit_NO2(iogrp),1e3/dtbgc,0., - . cmpflg, - . 'no2denit','NO2 denitrification rate',' ','mol N m-3 s-1') - call wrtlyr(jdenit_N2O(iogrp),LYR_denit_N2O(iogrp),1e3/dtbgc,0., - . cmpflg, - . 'n2odenit','N2O denitrification rate',' ','mol N2O m-3 s-1') - call wrtlyr(jDNRA_NO2(iogrp),LYR_DNRA_NO2(iogrp),1e3/dtbgc,0., - . cmpflg, - . 'no2dnra','NO2 DNRA rate',' ','mol N m-3 s-1') - call wrtlyr(janmx_N2_prod(iogrp),LYR_anmx_N2_prod(iogrp), - . 1e3/dtbgc,0.,cmpflg, - . 'anmx_n2','Anammox N2 production rate',' ','mol N2 m-3 s-1') - call wrtlyr(janmx_OM_prod(iogrp),LYR_anmx_OM_prod(iogrp), - . 1e3/dtbgc,0.,cmpflg, - . 'anmx_om','Anammox OM production rate',' ','mol P m-3 s-1') - call wrtlyr(jphosy_NH4(iogrp),LYR_phosy_NH4(iogrp),1e3/dtbgc,0., - . cmpflg, - . 'phosy_nh4','PP consumption rate of NH4',' ','mol N m-3 s-1') - call wrtlyr(jphosy_NO3(iogrp),LYR_phosy_NO3(iogrp),1e3/dtbgc,0., - . cmpflg, - . 'phosy_no3','PP consumption rate of NO3',' ','mol N m-3 s-1') - call wrtlyr(jremin_aerob(iogrp),LYR_remin_aerob(iogrp),1e3/dtbgc, - . 0.,cmpflg, - . 'remina','Aerob remineralization rate',' ','mol N m-3 s-1') - call wrtlyr(jremin_sulf(iogrp),LYR_remin_sulf(iogrp),1e3/dtbgc, - . 0.,cmpflg, - . 'remins','Sulfate remineralization rate',' ','mol P m-3 s-1') -#endif -c -c --- Store 3d level fields - call wrtlvl(jlvldic(iogrp),LVL_DIC(iogrp),rnacc*1e3,0.,cmpflg, - . 'dissiclvl','Dissolved inorganic carbon',' ','mol C m-3') - call wrtlvl(jlvlalkali(iogrp),LVL_ALKALI(iogrp),rnacc*1e3,0., - . cmpflg, 'talklvl','Alkalinity',' ','eq m-3') - call wrtlvl(jlvlphosph(iogrp),LVL_PHOSPH(iogrp),rnacc*1e3,0., - . cmpflg,'po4lvl','Phosphorus',' ','mol P m-3') - call wrtlvl(jlvloxygen(iogrp),LVL_OXYGEN(iogrp),rnacc*1e3,0., - . cmpflg,'o2lvl','Oxygen',' ','mol O2 m-3') - call wrtlvl(jlvlano3(iogrp),LVL_ANO3(iogrp),rnacc*1e3,0.,cmpflg, - . 'no3lvl','Nitrate',' ','mol N m-3') - call wrtlvl(jlvlsilica(iogrp),LVL_SILICA(iogrp),rnacc*1e3,0., - . cmpflg, 'silvl','Silicate',' ','mol Si m-3') - call wrtlvl(jlvldoc(iogrp),LVL_DOC(iogrp),rnacc*1e3,0.,cmpflg, - . 'dissoclvl','Dissolved organic carbon',' ','mol P m-3') - call wrtlvl(jlvlphyto(iogrp),LVL_PHYTO(iogrp),rnacc*1e3,0.,cmpflg, - . 'phyclvl','Phytoplankton',' ','mol P m-3') - call wrtlvl(jlvlgrazer(iogrp),LVL_GRAZER(iogrp),rnacc*1e3,0., - . cmpflg,'zooclvl','Zooplankton',' ','mol P m-3') - call wrtlvl(jlvlpoc(iogrp),LVL_POC(iogrp),rnacc*1e3,0.,cmpflg, - . 'detoclvl','Detritus',' ','mol P m-3') - call wrtlvl(jlvlcalc(iogrp),LVL_CALC(iogrp),rnacc*1e3,0.,cmpflg, - . 'calclvl','CaCO3 shells',' ','mol C m-3') - call wrtlvl(jlvlopal(iogrp),LVL_OPAL(iogrp),rnacc*1e3,0.,cmpflg, - . 'opallvl','Opal shells',' ','mol Si m-3') - call wrtlvl(jlvliron(iogrp),LVL_IRON(iogrp),rnacc*1e3,0.,cmpflg, - . 'dfelvl','Dissolved iron',' ','mol Fe m-3') - call wrtlvl(jlvlphosy(iogrp),LVL_PHOSY(iogrp),rnacc*1e3/dtbgc,0., - . cmpflg,'pplvl','Primary production',' ','mol C m-3 s-1') - call wrtlvl(jlvlco3(iogrp),LVL_CO3(iogrp),rnacc*1e3,0.,cmpflg, - . 'co3lvl','Carbonate ions',' ','mol C m-3') - call wrtlvl(jlvlph(iogrp),LVL_PH(iogrp),-1.,0.,cmpflg, - . 'phlvl','pH',' ','-log10([h+])') - call wrtlvl(jlvlomegaa(iogrp),LVL_OMEGAA(iogrp),rnacc,0.,cmpflg, - . 'omegaalvl','OmegaA',' ','-') - call wrtlvl(jlvlomegac(iogrp),LVL_OMEGAC(iogrp),rnacc,0.,cmpflg, - . 'omegaclvl','OmegaC',' ','-') - call wrtlvl(jlvln2o(iogrp),LVL_N2O(iogrp),rnacc*1e3,0.,cmpflg, - . 'n2olvl','N2O',' ','mol N2O m-3') - call wrtlvl(jlvlprefo2(iogrp),LVL_PREFO2(iogrp),rnacc*1e3,0., - . cmpflg,'p_o2lvl','Preformed oxygen',' ','mol O2 m-3') - call wrtlvl(jlvlo2sat(iogrp),LVL_O2SAT(iogrp),rnacc*1e3,0., - . cmpflg,'satoxylvl','Saturated oxygen',' ','mol O2 m-3') - call wrtlvl(jlvlprefpo4(iogrp),LVL_PREFPO4(iogrp),rnacc*1e3,0., - . cmpflg,'p_po4lvl','Preformed phosphorus',' ','mol P m-3') - call wrtlvl(jlvlprefalk(iogrp),LVL_PREFALK(iogrp),rnacc*1e3,0., - . cmpflg, 'p_talklvl','Preformed alkalinity',' ','eq m-3') - call wrtlvl(jlvlprefdic(iogrp),LVL_PREFDIC(iogrp),rnacc*1e3,0., - . cmpflg, 'p_diclvl','Preformed DIC',' ','mol C m-3') - call wrtlvl(jlvldicsat(iogrp),LVL_DICSAT(iogrp),rnacc*1e3,0., - . cmpflg, 'sat_diclvl','Saturated DIC',' ','mol C m-3') -#ifdef cisonew - call wrtlvl(jlvldic13(iogrp),LVL_DIC13(iogrp),rnacc*1.e3, - . 0.,cmpflg,'dissic13lvl','Dissolved C13',' ','mol 13C m-3') - call wrtlvl(jlvldic14(iogrp),LVL_DIC14(iogrp),rnacc*1.e3*c14fac, - . 0.,cmpflg,'dissic14lvl','Dissolved C14',' ','mol 14C m-3') - call wrtlvl(jlvld13c(iogrp),LVL_D13C(iogrp),rnacc, - . 0.,cmpflg,'delta13clvl','delta13C of DIC',' ','permil') - call wrtlvl(jlvld14c(iogrp),LVL_D14C(iogrp),rnacc, - . 0.,cmpflg,'delta14clvl','delta14C of DIC',' ','permil') - call wrtlvl(jlvlbigd14c(iogrp),LVL_BIGD14C(iogrp),rnacc, - . 0.,cmpflg,'bigdelta14clvl','big delta14C of DIC',' ','permil') - call wrtlvl(jlvlpoc13(iogrp),LVL_POC13(iogrp),rnacc*1e3, - . 0.,cmpflg,'detoc13lvl','Detritus13',' ','mol P m-3') - call wrtlvl(jlvldoc13(iogrp),LVL_DOC13(iogrp),rnacc*1e3, - . 0.,cmpflg,'dissoc13lvl','Dissolved organic carbon13',' ', - . 'mol P m-3') - call wrtlvl(jlvlcalc13(iogrp),LVL_CALC13(iogrp),rnacc*1e3, - . 0.,cmpflg,'calc13lvl','Ca13CO3 shells',' ','mol 13C m-3') - call wrtlvl(jlvlphyto13(iogrp),LVL_PHYTO13(iogrp),rnacc*1e3, - . 0.,cmpflg,'phyc13lvl','Phytoplankton13',' ','mol P m-3') - call wrtlvl(jlvlgrazer13(iogrp),LVL_GRAZER13(iogrp),rnacc*1e3, - . 0.,cmpflg,'zooc13lvl','Zooplankton13',' ','mol P m-3') -#endif -#ifdef AGG - call wrtlvl(jlvlnos(iogrp),LVL_NOS(iogrp), - . rnacc,0.,cmpflg,'noslvl', - . 'Marine snow aggregates per cm^3 sea water',' ','1/cm^3') - call wrtlvl(jlvlwphy(iogrp),LVL_WPHY(iogrp), - . rnacc,0.,cmpflg,'wphylvl', - . 'Av. mass sinking speed of marine snow',' ','m/day') - call wrtlvl(jlvlwnos(iogrp),LVL_WNOS(iogrp), - . rnacc,0.,cmpflg,'wnoslvl', - . 'Av. number sinking speed of marine snow',' ','m/day') - call wrtlvl(jlvleps(iogrp),LVL_EPS(iogrp), - . rnacc,0.,cmpflg,'epslvl', - . 'Av. size distribution exponent',' ','-') - call wrtlvl(jlvlasize(iogrp),LVL_ASIZE(iogrp), - . rnacc,0.,cmpflg,'asizelvl', - . 'Av. size of marine snow aggregates',' ','nb. of cells') -#endif -#ifdef CFC - call wrtlvl(jlvlcfc11(iogrp),LVL_CFC11(iogrp),rnacc*1e3,0.,cmpflg, - . 'cfc11lvl','CFC-11',' ','mol cfc11 m-3') - call wrtlvl(jlvlcfc12(iogrp),LVL_CFC12(iogrp),rnacc*1e3,0.,cmpflg, - . 'cfc12lvl','CFC-12',' ','mol cfc12 m-3') - call wrtlvl(jlvlsf6(iogrp),LVL_SF6(iogrp),rnacc*1e3,0.,cmpflg, - . 'sf6lvl','SF-6',' ','mol sf6 m-3') -#endif -#ifdef natDIC - call wrtlvl(jlvlnatco3(iogrp),LVL_NATCO3(iogrp), - . rnacc*1e3,0.,cmpflg,'natco3lvl', - . 'Natural carbonate ions',' ','mol C m-3') - call wrtlvl(jlvlnatalkali(iogrp),LVL_NATALKALI(iogrp), - . rnacc*1e3,0.,cmpflg,'nattalklvl', - . 'Natural alkalinity',' ','eq m-3') - call wrtlvl(jlvlnatdic(iogrp),LVL_NATDIC(iogrp), - . rnacc*1e3,0.,cmpflg,'natdissiclvl', - . 'Natural dissolved inorganic carbon',' ','mol C m-3') - call wrtlvl(jlvlnatcalc(iogrp),LVL_NATCALC(iogrp), - . rnacc*1e3,0.,cmpflg,'natcalclvl', - . 'Natural CaCO3 shells',' ','mol C m-3') - call wrtlvl(jlvlnatph(iogrp),LVL_NATPH(iogrp),-1.,0.,cmpflg, - . 'natphlvl','Natural pH',' ','-log10([h+])') - call wrtlvl(jlvlnatomegaa(iogrp),LVL_NATOMEGAA(iogrp), - . rnacc,0.,cmpflg,'natomegaalvl', - . 'Natural OmegaA',' ','-') - call wrtlvl(jlvlnatomegac(iogrp),LVL_NATOMEGAC(iogrp), - . rnacc,0.,cmpflg,'natomegaclvl', - . 'Natural OmegaC',' ','-') -#endif -#ifdef BROMO - call wrtlvl(jlvlbromo(iogrp),LVL_BROMO(iogrp),rnacc*1e3,0., - . cmpflg,'bromolvl','Bromoform',' ','mol CHBr3 m-3') -#endif -#ifdef extNcycle - call wrtlvl(jlvlanh4(iogrp),LVL_ANH4(iogrp),rnacc*1e3,0.,cmpflg, - . 'nh4lvl','Ammonium',' ','mol N m-3') - call wrtlvl(jlvlano2(iogrp),LVL_ANO2(iogrp),rnacc*1e3,0.,cmpflg, - . 'no2lvl','Nitrite',' ','mol N m-3') - call wrtlvl(jlvl_nitr_NH4(iogrp),LVL_nitr_NH4(iogrp), - . rnacc*1e3/dtbgc,0.,cmpflg, - . 'nh4nitrlvl','NH4 nitrification rate',' ','mol N m-3 s-1') - call wrtlvl(jlvl_nitr_NO2(iogrp),LVL_nitr_NO2(iogrp), - . rnacc*1e3/dtbgc,0.,cmpflg, - . 'no2nitrlvl','NO2 nitrification rate',' ','mol N m-3 s-1') - call wrtlvl(jlvl_nitr_N2O_prod(iogrp),LVL_nitr_N2O_prod(iogrp), - . rnacc*1e3/dtbgc,0.,cmpflg, - . 'nitr_n2olvl','N2O prod during NH4 nitrification',' ', - . 'mol N2O m-3 s-1') - call wrtlvl(jlvl_nitr_NH4_OM(iogrp),LVL_nitr_NH4_OM(iogrp), - . rnacc*1e3/dtbgc,0.,cmpflg, - . 'nh4nitr_omlvl','OM production during NH4 nitrification',' ', - . 'mol P m-3 s-1') - call wrtlvl(jlvl_nitr_NO2_OM(iogrp),LVL_nitr_NO2_OM(iogrp), - . rnacc*1e3/dtbgc,0.,cmpflg, - . 'no2nitr_omlvl','OM production during NO2 nitrification',' ', - . 'mol P m-3 s-1') - call wrtlvl(jlvl_denit_NO3(iogrp),LVL_denit_NO3(iogrp), - . rnacc*1e3/dtbgc,0.,cmpflg, - . 'no3denitlvl','NO3 denitrification rate',' ','mol N m-3 s-1') - call wrtlvl(jlvl_denit_NO2(iogrp),LVL_denit_NO2(iogrp), - . rnacc*1e3/dtbgc,0.,cmpflg, - . 'no2denitlvl','NO2 denitrification rate',' ','mol N m-3 s-1') - call wrtlvl(jlvl_denit_N2O(iogrp),LVL_denit_N2O(iogrp), - . rnacc*1e3/dtbgc,0.,cmpflg, - . 'n2odenitlvl','N2O denitrification rate',' ','mol N2O m-3 s-1') - call wrtlvl(jlvl_DNRA_NO2(iogrp),LVL_DNRA_NO2(iogrp), - . rnacc*1e3/dtbgc,0.,cmpflg, - . 'no2dnralvl','NO2 DNRA rate',' ','mol N m-3 s-1') - call wrtlvl(jlvl_anmx_N2_prod(iogrp),LVL_anmx_N2_prod(iogrp), - . rnacc*1e3/dtbgc,0.,cmpflg, - . 'anmx_n2lvl','Anammox N2 production rate',' ','mol N2 m-3 s-1') - call wrtlvl(jlvl_anmx_OM_prod(iogrp),LVL_anmx_OM_prod(iogrp), - . rnacc*1e3/dtbgc,0.,cmpflg, - . 'anmx_omlvl','Anammox OM production rate',' ','mol P m-3 s-1') - call wrtlvl(jlvl_phosy_NH4(iogrp),LVL_phosy_NH4(iogrp), - . rnacc*1e3/dtbgc,0.,cmpflg, - . 'phosy_nh4lvl','PP consumption rate of NH4',' ', - . 'mol N m-3 s-1') - call wrtlvl(jlvl_phosy_NO3(iogrp),LVL_phosy_NO3(iogrp), - . rnacc*1e3/dtbgc,0.,cmpflg, - . 'phosy_no3lvl','PP consumption rate of NO3',' ', - . 'mol N m-3 s-1') - call wrtlvl(jlvl_remin_aerob(iogrp),LVL_remin_aerob(iogrp), - . rnacc*1e3/dtbgc,0.,cmpflg, - . 'reminalvl','Aerob remineralization rate',' ','mol N m-3 s-1') - call wrtlvl(jlvl_remin_sulf(iogrp),LVL_remin_sulf(iogrp), - . rnacc*1e3/dtbgc,0.,cmpflg, - . 'reminslvl','Sulfate remineralization rate',' ','mol P m-3 s-1') -#endif - -c -c --- Store sediment fields -#ifndef sedbypass - call wrtsdm(jpowaic(iogrp),SDM_POWAIC(iogrp),rnacc*1e3,0.,cmpflg, - . 'powdic','PoWa DIC',' ','mol C m-3') - call wrtsdm(jpowaal(iogrp),SDM_POWAAL(iogrp),rnacc*1e3,0.,cmpflg, - . 'powalk','PoWa alkalinity',' ','eq m-3') - call wrtsdm(jpowaph(iogrp),SDM_POWAPH(iogrp),rnacc*1e3,0.,cmpflg, - . 'powpho','PoWa phosphorus',' ','mol P m-3') - call wrtsdm(jpowaox(iogrp),SDM_POWAOX(iogrp),rnacc*1e3,0.,cmpflg, - . 'powox','PoWa oxygen',' ','mol O2 m-3') - call wrtsdm(jpown2(iogrp),SDM_POWN2(iogrp), rnacc*1e3,0.,cmpflg, - . 'pown2','PoWa N2',' ','mol N2 m-3') - call wrtsdm(jpowno3(iogrp),SDM_POWNO3(iogrp),rnacc*1e3,0.,cmpflg, - . 'powno3','PoWa nitrate',' ','mol N m-3') - call wrtsdm(jpowasi(iogrp),SDM_POWASI(iogrp),rnacc*1e3,0.,cmpflg, - . 'powsi','PoWa silicate',' ','mol Si m-3') - call wrtsdm(jssso12(iogrp),SDM_SSSO12(iogrp),rnacc*1e3,0.,cmpflg, - . 'ssso12','Sediment detritus',' ','mol P m-3') - call wrtsdm(jssssil(iogrp),SDM_SSSSIL(iogrp),rnacc*1e3,0.,cmpflg, - . 'ssssil','Sediment silicate',' ','mol Si m-3') - call wrtsdm(jsssc12(iogrp),SDM_SSSC12(iogrp),rnacc*1e3,0.,cmpflg, - . 'sssc12','Sediment CaCO3',' ','mol C m-3') - call wrtsdm(jssster(iogrp),SDM_SSSTER(iogrp),rnacc*1e3,0.,cmpflg, - . 'ssster','Sediment clay',' ','mol m-3') -c -c --- Store sediment burial fields - call wrtbur(jburssso12(iogrp),BUR_SSSO12(iogrp),rnacc*1e3,0., - . cmpflg,'buro12','Burial org carbon',' ','mol P m-2') - call wrtbur(jbursssc12(iogrp),BUR_SSSC12(iogrp),rnacc*1e3,0., - . cmpflg,'burc12','Burial calcium ',' ','mol C m-2') - call wrtbur(jburssssil(iogrp),BUR_SSSSIL(iogrp),rnacc*1e3,0., - . cmpflg,'bursil','Burial silicate',' ','mol Si m-2') - call wrtbur(jburssster(iogrp),BUR_SSSTER(iogrp),rnacc*1e3,0., - . cmpflg,'burter','Burial clay',' ','mol m-2') -#endif -c -c --- close netcdf file - call ncfcls -c -c --- Initialise fields - call inisrf(jkwco2(iogrp),0.) - call inisrf(jpco2(iogrp),0.) - call inisrf(jdmsflux(iogrp),0.) - call inisrf(jco2fxd(iogrp),0.) - call inisrf(jco2fxu(iogrp),0.) - call inisrf(joxflux(iogrp),0.) - call inisrf(jniflux(iogrp),0.) - call inisrf(jn2ofx(iogrp),0.) - call inisrf(jdms(iogrp),0.) - call inisrf(jdmsprod(iogrp),0.) - call inisrf(jdms_bac(iogrp),0.) - call inisrf(jdms_uv(iogrp),0.) - call inisrf(jexport(iogrp),0.) - call inisrf(jexposi(iogrp),0.) - call inisrf(jexpoca(iogrp),0.) - call inisrf(jsrfdic(iogrp),0.) - call inisrf(jsrfalkali(iogrp),0.) - call inisrf(jsrfphosph(iogrp),0.) - call inisrf(jsrfoxygen(iogrp),0.) - call inisrf(jsrfano3(iogrp),0.) - call inisrf(jsrfsilica(iogrp),0.) - call inisrf(jsrfiron(iogrp),0.) - call inisrf(jsrfphyto(iogrp),0.) - call inisrf(jintphosy(iogrp),0.) - call inisrf(jintnfix(iogrp),0.) - call inisrf(jintdnit(iogrp),0.) - call inisrf(jcarflx0100(iogrp),0.) - call inisrf(jcarflx0500(iogrp),0.) - call inisrf(jcarflx1000(iogrp),0.) - call inisrf(jcarflx2000(iogrp),0.) - call inisrf(jcarflx4000(iogrp),0.) - call inisrf(jcarflx_bot(iogrp),0.) - call inisrf(jbsiflx0100(iogrp),0.) - call inisrf(jbsiflx0500(iogrp),0.) - call inisrf(jbsiflx1000(iogrp),0.) - call inisrf(jbsiflx2000(iogrp),0.) - call inisrf(jbsiflx4000(iogrp),0.) - call inisrf(jbsiflx_bot(iogrp),0.) - call inisrf(jcalflx0100(iogrp),0.) - call inisrf(jcalflx0500(iogrp),0.) - call inisrf(jcalflx1000(iogrp),0.) - call inisrf(jcalflx2000(iogrp),0.) - call inisrf(jcalflx4000(iogrp),0.) - call inisrf(jcalflx_bot(iogrp),0.) -#ifndef sedbypass - call inisrf(jsediffic(iogrp),0.) - call inisrf(jsediffal(iogrp),0.) - call inisrf(jsediffph(iogrp),0.) - call inisrf(jsediffox(iogrp),0.) - call inisrf(jsediffn2(iogrp),0.) - call inisrf(jsediffno3(iogrp),0.) - call inisrf(jsediffsi(iogrp),0.) -#endif -#ifdef cisonew - call inisrf(jco213fxd(iogrp),0.) - call inisrf(jco213fxu(iogrp),0.) - call inisrf(jco214fxd(iogrp),0.) - call inisrf(jco214fxu(iogrp),0.) -#endif -#ifdef CFC - call inisrf(jcfc11fx(iogrp),0.) - call inisrf(jcfc12fx(iogrp),0.) - call inisrf(jsf6fx(iogrp),0.) -#endif -#ifdef natDIC - call inisrf(jsrfnatdic(iogrp),0.) - call inisrf(jsrfnatalk(iogrp),0.) - call inisrf(jnatpco2(iogrp),0.) - call inisrf(jnatco2fx(iogrp),0.) -#endif -#ifdef BROMO - call inisrf(jsrfbromo(iogrp),0.) - call inisrf(jbromofx(iogrp),0.) - call inisrf(jbromo_prod(iogrp),0.) - call inisrf(jbromo_uv(iogrp),0.) - call inisrf(jatmbromo(iogrp),0.) -#endif - - - call inisrf(jatmco2(iogrp),0.) -#if defined(BOXATM) - call inisrf(jatmo2(iogrp),0.) - call inisrf(jatmn2(iogrp),0.) -#endif -#ifdef cisonew - call inisrf(jatmc13(iogrp),0.) - call inisrf(jatmc14(iogrp),0.) -#endif -#ifdef extNcycle - call inisrf(jsrfanh4(iogrp),0.) - call inisrf(jsrfano2(iogrp),0.) - call inisrf(janh3fx(iogrp),0.) -#endif -c - call inilyr(jdp(iogrp),0.) - call inilyr(jdic(iogrp),0.) - call inilyr(jalkali(iogrp),0.) - call inilyr(jphosy(iogrp),0.) - call inilyr(jphosph(iogrp),0.) - call inilyr(joxygen(iogrp),0.) - call inilyr(jano3(iogrp),0.) - call inilyr(jsilica(iogrp),0.) - call inilyr(jdoc(iogrp),0.) - call inilyr(jphyto(iogrp),0.) - call inilyr(jgrazer(iogrp),0.) - call inilyr(jpoc(iogrp),0.) - call inilyr(jcalc(iogrp),0.) - call inilyr(jopal(iogrp),0.) - call inilyr(jiron(iogrp),0.) - call inilyr(jco3(iogrp),0.) - call inilyr(jph(iogrp),0.) - call inilyr(jomegaa(iogrp),0.) - call inilyr(jomegac(iogrp),0.) - call inilyr(jn2o(iogrp),0.) - call inilyr(jprefo2(iogrp),0.) - call inilyr(jo2sat(iogrp),0.) - call inilyr(jprefpo4(iogrp),0.) - call inilyr(jprefalk(iogrp),0.) - call inilyr(jprefdic(iogrp),0.) - call inilyr(jdicsat(iogrp),0.) -#ifdef cisonew - call inilyr(jdic13(iogrp),0.) - call inilyr(jdic14(iogrp),0.) - call inilyr(jd13c(iogrp),0.) - call inilyr(jd14c(iogrp),0.) - call inilyr(jbigd14c(iogrp),0.) - call inilyr(jpoc13(iogrp),0.) - call inilyr(jdoc13(iogrp),0.) - call inilyr(jcalc13(iogrp),0.) - call inilyr(jphyto13(iogrp),0.) - call inilyr(jgrazer13(iogrp),0.) -#endif -#ifdef AGG - call inilyr(jnos(iogrp),0.) - call inilyr(jwphy(iogrp),0.) - call inilyr(jwnos(iogrp),0.) - call inilyr(jeps(iogrp),0.) - call inilyr(jasize(iogrp),0.) -#endif -#ifdef CFC - call inilyr(jcfc11(iogrp),0.) - call inilyr(jcfc12(iogrp),0.) - call inilyr(jsf6(iogrp),0.) -#endif -#ifdef natDIC - call inilyr(jnatco3(iogrp),0.) - call inilyr(jnatalkali(iogrp),0.) - call inilyr(jnatdic(iogrp),0.) - call inilyr(jnatcalc(iogrp),0.) - call inilyr(jnatph(iogrp),0.) - call inilyr(jnatomegaa(iogrp),0.) - call inilyr(jnatomegac(iogrp),0.) -#endif -#ifdef BROMO - call inilyr(jbromo(iogrp),0.) -#endif -#ifdef extNcycle - call inilyr(janh4(iogrp),0.) - call inilyr(jano2(iogrp),0.) - call inilyr(jnitr_NH4(iogrp),0.) - call inilyr(jnitr_NO2(iogrp),0.) - call inilyr(jnitr_N2O_prod(iogrp),0.) - call inilyr(jnitr_NH4_OM(iogrp),0.) - call inilyr(jnitr_NO2_OM(iogrp),0.) - call inilyr(jdenit_NO3(iogrp),0.) - call inilyr(jdenit_NO2(iogrp),0.) - call inilyr(jdenit_N2O(iogrp),0.) - call inilyr(jDNRA_NO2(iogrp),0.) - call inilyr(janmx_N2_prod(iogrp),0.) - call inilyr(janmx_OM_prod(iogrp),0.) - call inilyr(jphosy_NH4(iogrp),0.) - call inilyr(jphosy_NO3(iogrp),0.) - call inilyr(jremin_aerob(iogrp),0.) - call inilyr(jremin_sulf(iogrp),0.) -#endif -c - call inilvl(jlvldic(iogrp),0.) - call inilvl(jlvlalkali(iogrp),0.) - call inilvl(jlvlphosy(iogrp),0.) - call inilvl(jlvlphosph(iogrp),0.) - call inilvl(jlvloxygen(iogrp),0.) - call inilvl(jlvlano3(iogrp),0.) - call inilvl(jlvlsilica(iogrp),0.) - call inilvl(jlvldoc(iogrp),0.) - call inilvl(jlvlphyto(iogrp),0.) - call inilvl(jlvlgrazer(iogrp),0.) - call inilvl(jlvlpoc(iogrp),0.) - call inilvl(jlvlcalc(iogrp),0.) - call inilvl(jlvlopal(iogrp),0.) - call inilvl(jlvliron(iogrp),0.) - call inilvl(jlvlco3(iogrp),0.) - call inilvl(jlvlph(iogrp),0.) - call inilvl(jlvlomegaa(iogrp),0.) - call inilvl(jlvlomegac(iogrp),0.) - call inilvl(jlvln2o(iogrp),0.) - call inilvl(jlvlprefo2(iogrp),0.) - call inilvl(jlvlo2sat(iogrp),0.) - call inilvl(jlvlprefpo4(iogrp),0.) - call inilvl(jlvlprefalk(iogrp),0.) - call inilvl(jlvlprefdic(iogrp),0.) - call inilvl(jlvldicsat(iogrp),0.) -#ifdef cisonew - call inilvl(jlvldic13(iogrp),0.) - call inilvl(jlvldic14(iogrp),0.) - call inilvl(jlvld13c(iogrp),0.) - call inilvl(jlvld14c(iogrp),0.) - call inilvl(jlvlbigd14c(iogrp),0.) - call inilvl(jlvlpoc13(iogrp),0.) - call inilvl(jlvldoc13(iogrp),0.) - call inilvl(jlvlcalc13(iogrp),0.) - call inilvl(jlvlphyto13(iogrp),0.) - call inilvl(jlvlgrazer13(iogrp),0.) -#endif -#ifdef AGG - call inilvl(jlvlnos(iogrp),0.) - call inilvl(jlvlwphy(iogrp),0.) - call inilvl(jlvlwnos(iogrp),0.) - call inilvl(jlvleps(iogrp),0.) - call inilvl(jlvlasize(iogrp),0.) -#endif -#ifdef CFC - call inilvl(jlvlcfc11(iogrp),0.) - call inilvl(jlvlcfc12(iogrp),0.) - call inilvl(jlvlsf6(iogrp),0.) -#endif -#ifdef natDIC - call inilvl(jlvlnatco3(iogrp),0.) - call inilvl(jlvlnatalkali(iogrp),0.) - call inilvl(jlvlnatdic(iogrp),0.) - call inilvl(jlvlnatcalc(iogrp),0.) - call inilvl(jlvlnatph(iogrp),0.) - call inilvl(jlvlnatomegaa(iogrp),0.) - call inilvl(jlvlnatomegac(iogrp),0.) -#endif -#ifdef BROMO - call inilvl(jlvlbromo(iogrp),0.) -#endif -#ifdef extNcycle - call inilvl(jlvlanh4(iogrp),0.) - call inilvl(jlvlano2(iogrp),0.) - call inilvl(jlvl_nitr_NH4(iogrp),0.) - call inilvl(jlvl_nitr_NO2(iogrp),0.) - call inilvl(jlvl_nitr_N2O_prod(iogrp),0.) - call inilvl(jlvl_nitr_NH4_OM(iogrp),0.) - call inilvl(jlvl_nitr_NO2_OM(iogrp),0.) - call inilvl(jlvl_denit_NO3(iogrp),0.) - call inilvl(jlvl_denit_NO2(iogrp),0.) - call inilvl(jlvl_denit_N2O(iogrp),0.) - call inilvl(jlvl_DNRA_NO2(iogrp),0.) - call inilvl(jlvl_anmx_N2_prod(iogrp),0.) - call inilvl(jlvl_anmx_OM_prod(iogrp),0.) - call inilvl(jlvl_phosy_NH4(iogrp),0.) - call inilvl(jlvl_phosy_NO3(iogrp),0.) - call inilvl(jlvl_remin_aerob(iogrp),0.) - call inilvl(jlvl_remin_sulf(iogrp),0.) -#endif -c -#ifndef sedbypass - call inisdm(jpowaic(iogrp),0.) - call inisdm(jpowaal(iogrp),0.) - call inisdm(jpowaph(iogrp),0.) - call inisdm(jpowaox(iogrp),0.) - call inisdm(jpown2(iogrp),0.) - call inisdm(jpowno3(iogrp),0.) - call inisdm(jpowasi(iogrp),0.) - call inisdm(jssso12(iogrp),0.) - call inisdm(jssssil(iogrp),0.) - call inisdm(jsssc12(iogrp),0.) - call inisdm(jssster(iogrp),0.) - - call inibur(jburssso12(iogrp),0.) - call inibur(jbursssc12(iogrp),0.) - call inibur(jburssssil(iogrp),0.) - call inibur(jburssster(iogrp),0.) -#endif -c - nacc_bgc(iogrp)=0 -c - end - - - subroutine hamoccvardef(iogrp,timeunits,calendar,cmpflg) - use mod_nctools, only:ncdefvar,ncattr,ncfopn,ncdimc,ncdims, - . nctime,ncfcls,ncedef,ncdefvar3d,ndouble - - use mo_bgcmean, only: srf_kwco2,srf_pco2,srf_dmsflux,srf_co2fxd, - . srf_co2fxu,srf_oxflux,srf_niflux,srf_dms,srf_dmsprod, - . srf_dms_bac,srf_dms_uv,srf_export,srf_exposi,srf_expoca, - . srf_dic,srf_alkali,srf_phosph,srf_oxygen,srf_ano3,srf_silica, - . srf_iron,srf_phyto,int_phosy,int_nfix,int_dnit,flx_car0100, - . flx_car0500,flx_car1000,flx_car2000,flx_car4000,flx_car_bot, - . flx_bsi0100,flx_bsi0500,flx_bsi1000,flx_bsi2000,flx_bsi4000, - . flx_bsi_bot,flx_cal0100,flx_cal0500,flx_cal1000,flx_cal2000, - . flx_cal4000,flx_cal_bot,flx_sediffic,flx_sediffal, - . flx_sediffph,flx_sediffox,flx_sediffn2,flx_sediffno3, - . flx_sediffsi,srf_n2ofx,srf_atmco2,lyr_dp,lyr_dic, - . lyr_alkali,lyr_phosph,lyr_oxygen,lyr_ano3,lyr_silica,lyr_doc, - . lyr_phyto,lyr_grazer,lyr_poc,lyr_calc,lyr_opal,lyr_iron, - . lyr_phosy,lyr_co3,lyr_ph,lyr_omegaa,lyr_omegac,lyr_n2o, - . lyr_prefo2,lyr_o2sat,lyr_prefpo4,lyr_prefalk,lyr_prefdic, - . lyr_dicsat,lvl_dic,lvl_alkali,lvl_phosph,lvl_oxygen,lvl_ano3, - . lvl_silica,lvl_doc,lvl_phyto,lvl_grazer,lvl_poc,lvl_calc, - . lvl_opal,lvl_iron,lvl_phosy,lvl_co3,lvl_ph,lvl_omegaa, - . lvl_omegac,lvl_n2o,lvl_prefo2,lvl_o2sat,lvl_prefpo4, - . lvl_prefalk,lvl_prefdic,lvl_dicsat -#ifdef AGG - use mo_bgcmean, only: lyr_nos,lyr_wphy,lyr_wnos,lyr_eps, - . lyr_asize,lvl_nos,lvl_wphy,lvl_wnos,lvl_eps,lvl_asize -#endif -#if defined(BOXATM) - use mo_bgcmean, only: srf_atmo2,srf_atmn2 -#endif - -#ifdef BROMO - use mo_bgcmean, only:srf_bromo,srf_bromofx,int_bromopro, - . int_bromouv,srf_atmbromo,lyr_bromo,lvl_bromo -#endif -#ifdef CFC - use mo_bgcmean, only: srf_cfc11,srf_cfc12,srf_sf6,lyr_cfc11, - . lyr_cfc12,lyr_sf6,lvl_cfc11,lvl_cfc12,lvl_sf6 -#endif -#ifdef cisonew - use mo_bgcmean, only: srf_co213fxd,srf_co213fxu,srf_co214fxd, - . srf_co214fxu,srf_atmc13,srf_atmc14,lyr_dic13,lyr_dic14, - . lyr_d13c,lyr_d14c,lyr_bigd14c,lyr_poc13,lyr_doc13, - . lyr_calc13,lyr_phyto13,lyr_grazer13,lvl_dic13,lvl_dic14, - . lvl_d13c,lvl_d14c,lvl_bigd14c,lvl_poc13,lvl_doc13, - . lvl_calc13,lvl_phyto13,lvl_grazer13 -#endif -#ifdef natDIC - use mo_bgcmean, only: srf_natdic,srf_natalkali,srf_natpco2, - . srf_natco2fx,lyr_natco3,lyr_natalkali,lyr_natdic, - . lyr_natcalc,lyr_natph,lyr_natomegaa,lyr_natomegac, - . lvl_natalkali,lvl_natdic,lvl_natcalc,lvl_natph, - . lvl_natomegaa,lvl_natomegac,lvl_natco3 -#endif -#ifndef sedbypass - use mo_bgcmean, only: sdm_powaic,sdm_powaal,sdm_powaph,sdm_powaox, - . sdm_pown2,sdm_powno3,sdm_powasi,sdm_ssso12,sdm_ssssil, - . sdm_sssc12,sdm_ssster,bur_ssso12,bur_sssc12,bur_ssssil, - . bur_ssster -#endif -#ifdef extNcycle - use mo_bgcmean, only: janh4,jano2,jlvlanh4,jlvlano2,jsrfanh4, - . jsrfano2,janh3fx,srf_anh4,srf_ano2, - . srf_anh3fx,lyr_anh4,lyr_ano2,lvl_anh4, - . lvl_ano2, - . LYR_nitr_NH4,LYR_nitr_NO2,LYR_nitr_N2O_prod, - . LYR_nitr_NH4_OM,LYR_nitr_NO2_OM, - . LYR_denit_NO3,LYR_denit_NO2,LYR_denit_N2O, - . LYR_DNRA_NO2,LYR_anmx_N2_prod, - . LYR_anmx_OM_prod,LYR_phosy_NH4, - . LYR_phosy_NO3,LYR_remin_aerob,LYR_remin_sulf, - . LVL_nitr_NH4,LVL_nitr_NO2,LVL_nitr_N2O_prod, - . LVL_nitr_NH4_OM,LVL_nitr_NO2_OM, - . LVL_denit_NO3,LVL_denit_NO2,LVL_denit_N2O, - . LVL_DNRA_NO2,LVL_anmx_N2_prod, - . LVL_anmx_OM_prod,LVL_phosy_NH4, - . LVL_phosy_NO3,LVL_remin_aerob,LVL_remin_sulf, - . jnitr_NH4,jnitr_NO2,jnitr_N2O_prod, - . jnitr_NH4_OM,jnitr_NO2_OM,jdenit_NO3, - . jdenit_NO2,jdenit_N2O,jDNRA_NO2, - . janmx_N2_prod,janmx_OM_prod,jphosy_NH4, - . jphosy_NO3,jremin_aerob,jremin_sulf, - . jlvl_nitr_NH4,jlvl_nitr_NO2, - . jlvl_nitr_N2O_prod,jlvl_nitr_NH4_OM, - . jlvl_nitr_NO2_OM,jlvl_denit_NO3, - . jlvl_denit_NO2,jlvl_denit_N2O,jlvl_DNRA_NO2, - . jlvl_anmx_N2_prod,jlvl_anmx_OM_prod, - . jlvl_phosy_NH4,jlvl_phosy_NO3, - . jlvl_remin_aerob,jlvl_remin_sulf -#endif - implicit none - - integer iogrp,cmpflg - character timeunits*30,calendar*19 - call ncdefvar('time','time',ndouble,0) - call ncattr('long_name','time') - call ncattr('units',timeunits) - call ncattr('calendar',calendar) - call ncdefvar('sigma','sigma',ndouble,8) - call ncattr('long_name','Potential density') - call ncattr('standard_name','sea_water_sigma_theta') - call ncattr('units','kg m-3') - call ncattr('positive','down') - call ncdefvar('depth','depth',ndouble,8) - call ncattr('long_name','z level') - call ncattr('units','m') - call ncattr('positive','down') - call ncattr('bounds','depth_bnds') - call ncdefvar('depth_bnds','bounds depth',ndouble,8) - call ncdefvar3d(SRF_KWCO2(iogrp),cmpflg,'p', - . 'kwco2',' ',' ',' ',0) - call ncdefvar3d(SRF_PCO2(iogrp),cmpflg,'p', - . 'pco2','Surface PCO2',' ','uatm',0) - call ncdefvar3d(SRF_DMSFLUX(iogrp), - . cmpflg,'p','dmsflux','DMS flux',' ','mol DMS m-2 s-1',0) - call ncdefvar3d(SRF_CO2FXD(iogrp), - . cmpflg,'p','co2fxd','Downward CO2 flux',' ','kg C m-2 s-1',0) - call ncdefvar3d(SRF_CO2FXU(iogrp), - . cmpflg,'p','co2fxu','Upward CO2 flux',' ','kg C m-2 s-1',0) - call ncdefvar3d(SRF_OXFLUX(iogrp), - . cmpflg,'p','fgo2','Oxygen flux',' ','mol O2 m-2 s-1',0) - call ncdefvar3d(SRF_NIFLUX(iogrp), - . cmpflg,'p','fgn2','Nitrogen flux',' ','mol N2 m-2 s-1',0) - call ncdefvar3d(SRF_DMS(iogrp),cmpflg,'p', - . 'dms','DMS',' ','kmol DMS m-3',0) - call ncdefvar3d(SRF_DMSPROD(iogrp),cmpflg,'p', - . 'dmsprod','DMS production from phytoplankton production',' ', - . 'mol DMS m-2 s-1',0) - call ncdefvar3d(SRF_DMS_BAC(iogrp),cmpflg,'p', - . 'dms_bac','DMS bacterial consumption',' ','mol DMS m-2 s-1',0) - call ncdefvar3d(SRF_DMS_UV(iogrp),cmpflg,'p', - . 'dms_uv','DMS photolysis reduction',' ','mol DMS m-2 s-1',0) - call ncdefvar3d(SRF_EXPORT(iogrp), - . cmpflg,'p','epc100','Export production',' ','mol C m-2 s-1',0) - call ncdefvar3d(SRF_EXPOSI(iogrp),cmpflg,'p', - . 'epsi100','Si export production',' ','mol Si m-2 s-1',0) - call ncdefvar3d(SRF_EXPOCA(iogrp),cmpflg,'p', - . 'epcalc100','Ca export production',' ','mol Ca m-2 s-1',0) - call ncdefvar3d(SRF_DIC(iogrp),cmpflg,'p','srfdissic', - . 'Surface dissolved inorganic carbon',' ','mol C m-3',0) - call ncdefvar3d(SRF_ALKALI(iogrp),cmpflg,'p','srftalk', - . 'Surface alkalinity',' ','eq m-3',0) - call ncdefvar3d(SRF_PHOSPH(iogrp),cmpflg,'p','srfpo4', - . 'Surface phosphorus',' ','mol P m-3',0) - call ncdefvar3d(SRF_OXYGEN(iogrp),cmpflg,'p','srfo2', - . 'Surface oxygen',' ','mol O2 m-3',0) - call ncdefvar3d(SRF_ANO3(iogrp),cmpflg,'p','srfno3', - . 'Surface nitrate',' ','mol N m-3',0) - call ncdefvar3d(SRF_SILICA(iogrp),cmpflg,'p','srfsi', - . 'Surface silicate',' ','mol Si m-3',0) - call ncdefvar3d(SRF_IRON(iogrp),cmpflg,'p','srfdfe', - . 'Surface dissolved iron',' ','mol Fe m-3',0) - call ncdefvar3d(SRF_PHYTO(iogrp),cmpflg,'p','srfphyc', - . 'Surface phytoplankton',' ','mol P m-3',0) - call ncdefvar3d(INT_PHOSY(iogrp),cmpflg,'p','ppint', - . 'Integrated primary production',' ','mol C m-2 s-1',0) - call ncdefvar3d(INT_NFIX(iogrp),cmpflg,'p','nfixint', - . 'Integrated nitrogen fixation',' ','mol N m-2 s-1',0) - call ncdefvar3d(INT_DNIT(iogrp),cmpflg,'p','dnitint', - . 'Integrated denitrification',' ','mol N m-2 s-1',0) - call ncdefvar3d(FLX_CAR0100(iogrp),cmpflg,'p','carflx0100', - . 'C flux at 100m',' ','mol C m-2 s-1',0) - call ncdefvar3d(FLX_CAR0500(iogrp),cmpflg,'p','carflx0500', - . 'C flux at 500m',' ','mol C m-2 s-1',0) - call ncdefvar3d(FLX_CAR1000(iogrp),cmpflg,'p','carflx1000', - . 'C flux at 1000m',' ','mol C m-2 s-1',0) - call ncdefvar3d(FLX_CAR2000(iogrp),cmpflg,'p','carflx2000', - . 'C flux at 2000m',' ','mol C m-2 s-1',0) - call ncdefvar3d(FLX_CAR4000(iogrp),cmpflg,'p','carflx4000', - . 'C flux at 4000m',' ','mol C m-2 s-1',0) - call ncdefvar3d(FLX_CAR_BOT(iogrp),cmpflg,'p','carflx_bot', - . 'C flux to sediment',' ','mol C m-2 s-1',0) - call ncdefvar3d(FLX_BSI0100(iogrp),cmpflg,'p','bsiflx0100', - . 'Opal flux at 100m',' ','mol Si m-2 s-1',0) - call ncdefvar3d(FLX_BSI0500(iogrp),cmpflg,'p','bsiflx0500', - . 'Opal flux at 500m',' ','mol Si m-2 s-1',0) - call ncdefvar3d(FLX_BSI1000(iogrp),cmpflg,'p','bsiflx1000', - . 'Opal flux at 1000m',' ','mol Si m-2 s-1',0) - call ncdefvar3d(FLX_BSI2000(iogrp),cmpflg,'p','bsiflx2000', - . 'Opal flux at 2000m',' ','mol Si m-2 s-1',0) - call ncdefvar3d(FLX_BSI4000(iogrp),cmpflg,'p','bsiflx4000', - . 'Opal flux at 4000m',' ','mol Si m-2 s-1',0) - call ncdefvar3d(FLX_BSI_BOT(iogrp),cmpflg,'p','bsiflx_bot', - . 'Opal flux to sediment',' ','mol Si m-2 s-1',0) - call ncdefvar3d(FLX_CAL0100(iogrp),cmpflg,'p','calflx0100', - . 'CaCO3 flux at 100m',' ','mol Ca m-2 s-1',0) - call ncdefvar3d(FLX_CAL0500(iogrp),cmpflg,'p','calflx0500', - . 'CaCO3 flux at 500m',' ','mol Ca m-2 s-1',0) - call ncdefvar3d(FLX_CAL1000(iogrp),cmpflg,'p','calflx1000', - . 'CaCO3 flux at 1000m',' ','mol Ca m-2 s-1',0) - call ncdefvar3d(FLX_CAL2000(iogrp),cmpflg,'p','calflx2000', - . 'CaCO3 flux at 2000m',' ','mol Ca m-2 s-1',0) - call ncdefvar3d(FLX_CAL4000(iogrp),cmpflg,'p','calflx4000', - . 'CaCO3 flux at 4000m',' ','mol Ca m-2 s-1',0) - call ncdefvar3d(FLX_CAL_BOT(iogrp),cmpflg,'p','calflx_bot', - . 'CaCO3 flux to sediment',' ','mol Ca m-2 s-1',0) - call ncdefvar3d(SRF_N2OFX(iogrp),cmpflg,'p','n2oflux', - . 'N2O flux',' ','mol N2O m-2 s-1',0) -#ifndef sedbypass - call ncdefvar3d(FLX_SEDIFFIC(iogrp),cmpflg,'p','sedfdic', - . 'diffusive DIC flux to sediment (positive downwards)', - . ' ','mol C m-2 s-1',0) - call ncdefvar3d(FLX_SEDIFFAL(iogrp),cmpflg,'p','sedfalk', - . 'diffusive alkalinity flux to sediment (positive downwards)', - . ' ','mol m-2 s-1',0) - call ncdefvar3d(FLX_SEDIFFPH(iogrp),cmpflg,'p','sedfpho', - . 'diffusive phosphate flux to sediment (positive downwards)', - . ' ','mol m-2 s-1',0) - call ncdefvar3d(FLX_SEDIFFOX(iogrp),cmpflg,'p','sedfox', - . 'diffusive oxygen flux to sediment (positive downwards)', - . ' ','mol O2 m-2 s-1',0) - call ncdefvar3d(FLX_SEDIFFN2(iogrp),cmpflg,'p','sedfn2', - . 'diffusive N2 flux to sediment (positive downwards)', - . ' ','mol N2 m-2 s-1',0) - call ncdefvar3d(FLX_SEDIFFNO3(iogrp),cmpflg,'p','sedfno3', - . 'diffusive nitrate flux to sediment (positive downwards)', - . ' ','mol NO3 m-2 s-1',0) - call ncdefvar3d(FLX_SEDIFFSI(iogrp),cmpflg,'p','sedfsi', - . 'diffusive silica flux to sediment (positive downwards)', - . ' ','mol Si m-2 s-1',0) -#endif -#ifdef cisonew - call ncdefvar3d(SRF_CO213FXD(iogrp),cmpflg,'p','co213fxd', - . 'Downward 13CO2 flux',' ','kg C m-2 s-1',0) - call ncdefvar3d(SRF_CO213FXU(iogrp),cmpflg,'p','co213fxu', - . 'Upward 13CO2 flux',' ','kg C m-2 s-1',0) - call ncdefvar3d(SRF_CO214FXD(iogrp),cmpflg,'p','co214fxd', - . 'Downward 14CO2 flux',' ','kg C m-2 s-1',0) - call ncdefvar3d(SRF_CO214FXU(iogrp),cmpflg,'p','co214fxu', - . 'Upward 14CO2 flux',' ','kg C m-2 s-1',0) -#endif -#ifdef CFC - call ncdefvar3d(SRF_CFC11(iogrp),cmpflg,'p','cfc11flux', - . 'CFC-11 flux',' ','mol CFC12 m-2 s-1',0) - call ncdefvar3d(SRF_CFC12(iogrp), - . cmpflg,'p','cfc12flux','CFC-12 flux',' ','mol CFC12 m-2 s-1',0) - call ncdefvar3d(SRF_SF6(iogrp), - . cmpflg,'p','sf6flux','SF-6 flux',' ','mol SF6 m-2 s-1',0) -#endif -#ifdef natDIC - call ncdefvar3d(SRF_NATDIC(iogrp),cmpflg,'p','srfnatdissic', - . 'Surface natural dissolved inorganic carbon',' ','mol C m-3',0) - call ncdefvar3d(SRF_NATALKALI(iogrp),cmpflg,'p','srfnattalk', - . 'Surface natural alkalinity',' ','eq m-3',0) - call ncdefvar3d(SRF_NATPCO2(iogrp),cmpflg,'p', - . 'natpco2','Surface natural PCO2',' ','uatm',0) - call ncdefvar3d(SRF_NATCO2FX(iogrp), - . cmpflg,'p','natco2fx','Natural CO2 flux',' ','kg C m-2 s-1',0) -#endif -#ifdef BROMO - call ncdefvar3d(SRF_BROMO(iogrp),cmpflg,'p','srfbromo', - . 'Surface bromoform',' ','mol CHBr3 m-3',0) - call ncdefvar3d(SRF_BROMOfx(iogrp),cmpflg,'p','bromofx', - . 'Surface bromoform flux',' ','mol CHBr3 m-2 s-1',0) - call ncdefvar3d(INT_BROMOPRO(iogrp),cmpflg,'p','intbromoprod', - . 'Integrated bromoform production',' ','mol CHBr3 m-2 s-1',0) - call ncdefvar3d(INT_BROMOUV(iogrp),cmpflg,'p','intbromouv', - . 'Integrated bromoform loss to photolysis',' ', - . 'mol CHBr3 m-2 s-1',0) - call ncdefvar3d(SRF_ATMBROMO(iogrp),cmpflg,'p', - . 'atmbromo','Atmospheric bromoform',' ','ppt',0) -#endif - - call ncdefvar3d(SRF_ATMCO2(iogrp),cmpflg,'p', - . 'atmco2','Atmospheric CO2',' ','ppm',0) -#if defined(BOXATM) - call ncdefvar3d(SRF_ATMO2(iogrp),cmpflg,'p', - . 'atmo2','Atmospheric O2',' ','ppm',0) - call ncdefvar3d(SRF_ATMN2(iogrp),cmpflg,'p', - . 'atmn2','Atmospheric N2',' ','ppm',0) -#endif -#ifdef cisonew - call ncdefvar3d(SRF_ATMC13(iogrp),cmpflg,'p', - . 'atmc13','Atmospheric 13CO2',' ','ppm',0) - call ncdefvar3d(SRF_ATMC14(iogrp),cmpflg,'p', - . 'atmc14','Atmospheric 14CO2',' ','ppm',0) -#endif -#ifdef extNcycle - call ncdefvar3d(SRF_ANH4(iogrp),cmpflg,'p','srfnh4', - . 'Surface ammonium',' ','mol N m-3',0) - call ncdefvar3d(SRF_ANO2(iogrp),cmpflg,'p','srfno2', - . 'Surface nitrite',' ','mol N m-3',0) - call ncdefvar3d(SRF_ANH3FX(iogrp),cmpflg,'p','nh3flux', - . 'NH3 flux',' ','mol NH3 m-2 s-1',0) -#endif -c -c --- define 3d layer fields - call ncdefvar3d(LYR_DP(iogrp),cmpflg,'p', - . 'pddpo','Layer thickness',' ','m',1) - call ncdefvar3d(LYR_DIC(iogrp),cmpflg,'p', - . 'dissic','Dissolved inorganic carbon',' ','mol C m-3',1) - call ncdefvar3d(LYR_ALKALI(iogrp),cmpflg,'p', - . 'talk','Alkalinity',' ','eq m-3',1) - call ncdefvar3d(LYR_PHOSPH(iogrp),cmpflg,'p', - . 'po4','Phosphorus',' ','mol P m-3',1) - call ncdefvar3d(LYR_OXYGEN(iogrp),cmpflg,'p', - . 'o2','Oxygen',' ','mol O2 m-3',1) - call ncdefvar3d(LYR_ANO3(iogrp),cmpflg,'p', - . 'no3','Nitrate',' ','mol N m-3',1) - call ncdefvar3d(LYR_SILICA(iogrp),cmpflg,'p', - . 'si','Silicate',' ','mol Si m-3',1) - call ncdefvar3d(LYR_DOC(iogrp),cmpflg,'p', - . 'dissoc','Dissolved organic carbon',' ','mol P m-3',1) - call ncdefvar3d(LYR_PHYTO(iogrp),cmpflg,'p', - . 'phyc','Phytoplankton',' ','mol P m-3',1) - call ncdefvar3d(LYR_GRAZER(iogrp),cmpflg,'p', - . 'zooc','Zooplankton',' ','mol P m-3',1) - call ncdefvar3d(LYR_POC(iogrp),cmpflg,'p', - . 'detoc','Detritus',' ','mol P m-3',1) - call ncdefvar3d(LYR_CALC(iogrp),cmpflg,'p', - . 'calc','CaCO3 shells',' ','mol C m-3',1) - call ncdefvar3d(LYR_OPAL(iogrp),cmpflg,'p', - . 'opal','Opal shells',' ','mol Si m-3',1) - call ncdefvar3d(LYR_IRON(iogrp),cmpflg,'p', - . 'dfe','Dissolved iron',' ','mol Fe m-3',1) - call ncdefvar3d(LYR_PHOSY(iogrp),cmpflg,'p', - . 'pp','Primary production',' ','mol C m-3 s-1',1) - call ncdefvar3d(LYR_CO3(iogrp),cmpflg,'p', - . 'co3','Carbonate ions',' ','mol C m-3',1) - call ncdefvar3d(LYR_PH(iogrp),cmpflg,'p', - . 'ph','pH',' ','-log10([h+])',1) - call ncdefvar3d(LYR_OMEGAA(iogrp),cmpflg,'p', - . 'omegaa','OmegaA',' ','1',1) - call ncdefvar3d(LYR_OMEGAC(iogrp),cmpflg,'p', - . 'omegac','OmegaC',' ','1',1) - call ncdefvar3d(LYR_N2O(iogrp),cmpflg,'p', - . 'n2o','N2O',' ','mol N2O m-3',1) - call ncdefvar3d(LYR_PREFO2(iogrp),cmpflg,'p', - . 'p_o2','Preformed oxygen',' ','mol O2 m-3',1) - call ncdefvar3d(LYR_O2SAT(iogrp),cmpflg,'p', - . 'satoxy','Saturated oxygen',' ','mol O2 m-3',1) - call ncdefvar3d(LYR_PREFPO4(iogrp),cmpflg,'p', - . 'p_po4','Preformed phosphorus',' ','mol P m-3',1) - call ncdefvar3d(LYR_PREFALK(iogrp),cmpflg,'p', - . 'p_talk','Preformed alkalinity',' ','eq m-3',1) - call ncdefvar3d(LYR_PREFDIC(iogrp),cmpflg,'p', - . 'p_dic','Preformed DIC',' ','mol C m-3',1) - call ncdefvar3d(LYR_DICSAT(iogrp),cmpflg,'p', - . 'sat_dic','Saturated DIC',' ','mol C m-3',1) -#ifdef cisonew - call ncdefvar3d(LYR_DIC13(iogrp),cmpflg,'p', - . 'dissic13','Dissolved C13',' ','mol 13C m-3',1) - call ncdefvar3d(LYR_DIC14(iogrp),cmpflg,'p', - . 'dissic14','Dissolved C14',' ','mol 14C m-3',1) - call ncdefvar3d(LYR_D13C(iogrp),cmpflg,'p', - . 'delta13c','delta13C of DIC',' ','permil',1) - call ncdefvar3d(LYR_D14C(iogrp),cmpflg,'p', - . 'delta14c','delta14C of DIC',' ','permil',1) - call ncdefvar3d(LYR_BIGD14C(iogrp),cmpflg,'p', - . 'bigdelta14c','big delta14C of DIC',' ','permil',1) - call ncdefvar3d(LYR_POC13(iogrp),cmpflg,'p', - . 'detoc13','Detritus13',' ','mol P m-3',1) - call ncdefvar3d(LYR_DOC13(iogrp),cmpflg,'p', - . 'dissoc13','Dissolved organic carbon13',' ','mol P m-3',1) - call ncdefvar3d(LYR_CALC13(iogrp),cmpflg,'p', - . 'calc13','Ca13CO3 shells',' ','mol 13C m-3',1) - call ncdefvar3d(LYR_PHYTO13(iogrp),cmpflg,'p', - . 'phyc13','Phytoplankton13',' ','mol P m-3',1) - call ncdefvar3d(LYR_GRAZER13(iogrp),cmpflg,'p', - . 'zooc13','Zooplankton13',' ','mol P m-3',1) -#endif -#ifdef AGG - call ncdefvar3d(LYR_NOS(iogrp),cmpflg,'p', - . 'nos','Marine snow aggregates per cm^3 sea water',' ','1/cm^3',1) - call ncdefvar3d(LYR_WPHY(iogrp),cmpflg,'p', - . 'wphy','Av. mass sinking speed of marine snow',' ','m/day',1) - call ncdefvar3d(LYR_WNOS(iogrp),cmpflg,'p', - . 'wnos','Av. number sinking speed of marine snow',' ','m/day',1) - call ncdefvar3d(LYR_EPS(iogrp),cmpflg,'p', - . 'eps','Av. size distribution exponent',' ','-',1) - call ncdefvar3d(LYR_ASIZE(iogrp),cmpflg,'p', - .'asize','Av. size of marine snow aggregates',' ','nb. of cells',1) -#endif -#ifdef CFC - call ncdefvar3d(LYR_CFC11(iogrp),cmpflg,'p', - . 'cfc11','CFC-11',' ','mol cfc11 m-3',1) - call ncdefvar3d(LYR_CFC12(iogrp),cmpflg,'p', - . 'cfc12','CFC-12',' ','mol cfc12 m-3',1) - call ncdefvar3d(LYR_SF6(iogrp),cmpflg,'p', - . 'sf6','SF-6',' ','mol sf6 m-3',1) -#endif -#ifdef natDIC - call ncdefvar3d(LYR_NATCO3(iogrp),cmpflg,'p', - . 'natco3','Natural Carbonate ions',' ','mol C m-3',1) - call ncdefvar3d(LYR_NATALKALI(iogrp),cmpflg,'p','nattalk', - . 'Natural alkalinity',' ','eq m-3',1) - call ncdefvar3d(LYR_NATDIC(iogrp),cmpflg,'p','natdissic', - . 'Natural dissolved inorganic carbon',' ','mol C m-3',1) - call ncdefvar3d(LYR_NATCALC(iogrp),cmpflg,'p','natcalc', - . 'Natural CaCO3',' ','mol C m-3',1) - call ncdefvar3d(LYR_NATPH(iogrp),cmpflg,'p', - . 'natph','Natural pH',' ','-log10([h+])',1) - call ncdefvar3d(LYR_NATOMEGAA(iogrp),cmpflg,'p','natomegaa', - . 'Natural OmegaA',' ','1',1) - call ncdefvar3d(LYR_NATOMEGAC(iogrp),cmpflg,'p','natomegac', - . 'Natural OmegaC',' ','1',1) -#endif -#ifdef BROMO - call ncdefvar3d(LYR_BROMO(iogrp),cmpflg,'p', - . 'bromo','Bromoform',' ','mol CHBr3 m-3',1) -#endif -#ifdef extNcycle - call ncdefvar3d(LYR_ANH4(iogrp),cmpflg,'p', - . 'nh4','Ammonium',' ','mol N m-3',1) - call ncdefvar3d(LYR_ANO2(iogrp),cmpflg,'p', - . 'no2','Nitrite',' ','mol N m-3',1) - call ncdefvar3d(LYR_nitr_NH4(iogrp),cmpflg,'p', - . 'nh4nitr','NH4 nitrification rate',' ','mol N m-3 s-1',1) - call ncdefvar3d(LYR_nitr_NO2(iogrp),cmpflg,'p', - . 'no2nitr','NO2 nitrification rate',' ','mol N m-3 s-1',1) - call ncdefvar3d(LYR_nitr_N2O_prod(iogrp),cmpflg,'p', - . 'nitr_n2o','N2O prod during NH4 nitrification',' ', - . 'mol N2O m-3 s-1',1) - call ncdefvar3d(LYR_nitr_NH4_OM(iogrp),cmpflg,'p', - . 'nh4nitr_om','OM production during NH4 nitrification',' ', - . 'mol P m-3 s-1',1) - call ncdefvar3d(LYR_nitr_NO2_OM(iogrp),cmpflg,'p', - . 'no2nitr_om','OM production during NO2 nitrification',' ', - . 'mol P m-3 s-1',1) - call ncdefvar3d(LYR_denit_NO3(iogrp),cmpflg,'p', - . 'no3denit','NO3 denitrification rate',' ','mol N m-3 s-1',1) - call ncdefvar3d(LYR_denit_NO2(iogrp),cmpflg,'p', - . 'no2denit','NO2 denitrification rate',' ','mol N m-3 s-1',1) - call ncdefvar3d(LYR_denit_N2O(iogrp),cmpflg,'p', - . 'n2odenit','N2O denitrification rate',' ','mol N2O m-3 s-1',1) - call ncdefvar3d(LYR_DNRA_NO2(iogrp),cmpflg,'p', - . 'no2dnra','NO2 DNRA rate',' ','mol N m-3 s-1',1) - call ncdefvar3d(LYR_anmx_N2_prod(iogrp),cmpflg,'p', - . 'anmx_n2','Anammox N2 production rate',' ','mol N2 m-3 s-1',1) - call ncdefvar3d(LYR_anmx_OM_prod(iogrp),cmpflg,'p', - . 'anmx_om','Anammox OM production rate',' ','mol P m-3 s-1',1) - call ncdefvar3d(LYR_phosy_NH4(iogrp),cmpflg,'p', - . 'phosy_nh4','PP consumption rate of NH4',' ','mol N m-3 s-1',1) - call ncdefvar3d(LYR_phosy_NO3(iogrp),cmpflg,'p', - . 'phosy_no3','PP consumption rate of NO3',' ','mol N m-3 s-1',1) - call ncdefvar3d(LYR_remin_aerob(iogrp),cmpflg,'p', - . 'remina','Aerob remineralization rate',' ','mol N m-3 s-1',1) - call ncdefvar3d(LYR_remin_sulf(iogrp),cmpflg,'p', - . 'remins','Sulfate remineralization rate',' ','mol P m-3 s-1',1) -#endif -c -c --- define 3d level fields - call ncdefvar3d(LVL_DIC(iogrp),cmpflg,'p', - . 'dissiclvl','Dissolved inorganic carbon',' ','mol C m-3',2) - call ncdefvar3d(LVL_ALKALI(iogrp),cmpflg,'p', - . 'talklvl','Alkalinity',' ','eq m-3',2) - call ncdefvar3d(LVL_PHOSPH(iogrp),cmpflg,'p', - . 'po4lvl','Phosphorus',' ','mol P m-3',2) - call ncdefvar3d(LVL_OXYGEN(iogrp),cmpflg,'p', - . 'o2lvl','Oxygen',' ','mol O2 m-3',2) - call ncdefvar3d(LVL_ANO3(iogrp),cmpflg,'p', - . 'no3lvl','Nitrate',' ','mol N m-3',2) - call ncdefvar3d(LVL_SILICA(iogrp),cmpflg,'p', - . 'silvl','Silicate',' ','mol Si m-3',2) - call ncdefvar3d(LVL_DOC(iogrp),cmpflg,'p', - . 'dissoclvl','Dissolved organic carbon',' ','mol P m-3',2) - call ncdefvar3d(LVL_PHYTO(iogrp),cmpflg,'p', - . 'phyclvl','Phytoplankton',' ','mol P m-3',2) - call ncdefvar3d(LVL_GRAZER(iogrp),cmpflg,'p', - . 'zooclvl','Zooplankton',' ','mol P m-3',2) - call ncdefvar3d(LVL_POC(iogrp),cmpflg,'p', - . 'detoclvl','Detritus',' ','mol P m-3',2) - call ncdefvar3d(LVL_CALC(iogrp),cmpflg,'p', - . 'calclvl','CaCO3 shells',' ','mol C m-3',2) - call ncdefvar3d(LVL_OPAL(iogrp),cmpflg,'p', - . 'opallvl','Opal shells',' ','mol Si m-3',2) - call ncdefvar3d(LVL_IRON(iogrp),cmpflg,'p', - . 'dfelvl','Dissolved iron',' ','mol Fe m-3',2) - call ncdefvar3d(LVL_PHOSY(iogrp),cmpflg,'p', - . 'pplvl','Primary production',' ','mol C m-3 s-1',2) - call ncdefvar3d(LVL_CO3(iogrp),cmpflg,'p', - . 'co3lvl','Carbonate ions',' ','mol C m-3',2) - call ncdefvar3d(LVL_PH(iogrp),cmpflg,'p', - . 'phlvl','pH',' ','-log10([h+])',2) - call ncdefvar3d(LVL_OMEGAA(iogrp),cmpflg,'p', - . 'omegaalvl','OmegaA',' ','1',2) - call ncdefvar3d(LVL_OMEGAC(iogrp),cmpflg,'p', - . 'omegaclvl','OmegaC',' ','1',2) - call ncdefvar3d(LVL_N2O(iogrp),cmpflg,'p', - . 'n2olvl','N2O',' ','mol N2O m-3',2) - call ncdefvar3d(LVL_PREFO2(iogrp),cmpflg,'p', - . 'p_o2lvl','Preformed oxygen',' ','mol O2 m-3',2) - call ncdefvar3d(LVL_O2SAT(iogrp),cmpflg,'p', - . 'satoxylvl','Saturated oxygen',' ','mol O2 m-3',2) - call ncdefvar3d(LVL_PREFPO4(iogrp),cmpflg,'p', - . 'p_po4lvl','Preformed phosphorus',' ','mol P m-3',2) - call ncdefvar3d(LVL_PREFALK(iogrp),cmpflg,'p', - . 'p_talklvl','Preformed alkalinity',' ','eq m-3',2) - call ncdefvar3d(LVL_PREFDIC(iogrp),cmpflg,'p', - . 'p_diclvl','Preformed DIC',' ','mol C m-3',2) - call ncdefvar3d(LVL_DICSAT(iogrp),cmpflg,'p', - . 'sat_diclvl','Saturated DIC',' ','mol C m-3',2) -#ifdef cisonew - call ncdefvar3d(LVL_DIC13(iogrp),cmpflg,'p', - . 'dissic13lvl','Dissolved C13',' ','mol 13C m-3',2) - call ncdefvar3d(LVL_DIC14(iogrp),cmpflg,'p', - . 'dissic14lvl','Dissolved C14',' ','mol 14C m-3',2) - call ncdefvar3d(LVL_D13C(iogrp),cmpflg,'p', - . 'delta13clvl','delta13C of DIC',' ','permil',2) - call ncdefvar3d(LVL_D14C(iogrp),cmpflg,'p', - . 'delta14clvl','delta14C of DIC',' ','permil',2) - call ncdefvar3d(LVL_BIGD14C(iogrp),cmpflg,'p', - . 'bigdelta14clvl','big delta14C of DIC',' ','permil',2) - call ncdefvar3d(LVL_POC13(iogrp),cmpflg,'p', - . 'detoc13lvl','Detritus13',' ','mol P m-3',2) - call ncdefvar3d(LVL_DOC13(iogrp),cmpflg,'p', - . 'dissoc13lvl','Dissolved organic carbon13',' ','mol P m-3',2) - call ncdefvar3d(LVL_CALC13(iogrp),cmpflg,'p', - . 'calc13lvl','Ca13CO3 shells',' ','mol 13C m-3',2) - call ncdefvar3d(LVL_PHYTO13(iogrp),cmpflg,'p', - . 'phyc13lvl','Phytoplankton13',' ','mol P m-3',2) - call ncdefvar3d(LVL_GRAZER13(iogrp),cmpflg,'p', - . 'zooc13lvl','Zooplankton13',' ','mol P m-3',2) -#endif -#ifdef AGG - call ncdefvar3d(LVL_NOS(iogrp),cmpflg,'p','noslvl', - . 'Marine snow aggregates per cm^3 sea water',' ','1/cm^3',2) - call ncdefvar3d(LVL_WPHY(iogrp),cmpflg,'p','wphylvl', - . 'Av. mass sinking speed of marine snow',' ','m/day',2) - call ncdefvar3d(LVL_WNOS(iogrp),cmpflg,'p','wnoslvl', - . 'Av. number sinking speed of marine snow',' ','m/day',2) - call ncdefvar3d(LVL_EPS(iogrp),cmpflg,'p','epslvl', - . 'Av. size distribution exponent',' ','-',2) - call ncdefvar3d(LVL_ASIZE(iogrp),cmpflg,'p','asizelvl', - . 'Av. size of marine snow aggregates',' ','nb. of cells',2) -#endif -#ifdef CFC - call ncdefvar3d(LVL_CFC11(iogrp),cmpflg,'p', - . 'cfc11lvl','CFC-11',' ','mol cfc11 m-3',2) - call ncdefvar3d(LVL_CFC12(iogrp),cmpflg,'p', - . 'cfc12lvl','CFC-12',' ','mol cfc12 m-3',2) - call ncdefvar3d(LVL_SF6(iogrp),cmpflg,'p', - . 'sf6lvl','SF-6',' ','mol sf6 m-3',2) -#endif -#ifdef natDIC - call ncdefvar3d(LVL_NATCO3(iogrp),cmpflg,'p', - . 'natco3lvl','Natural Carbonate ions',' ','mol C m-3',2) - call ncdefvar3d(LVL_NATALKALI(iogrp),cmpflg,'p','nattalklvl', - . 'Natural alkalinity',' ','eq m-3',2) - call ncdefvar3d(LVL_NATDIC(iogrp),cmpflg,'p','natdissiclvl', - . 'Natual dissolved inorganic carbon',' ','mol C m-3',2) - call ncdefvar3d(LVL_NATCALC(iogrp),cmpflg,'p', - . 'natcalclvl','Natural CaCO3 shells',' ','mol C m-3',2) - call ncdefvar3d(LVL_NATPH(iogrp),cmpflg,'p', - . 'natphlvl','Natural pH',' ','-log10([h+])',2) - call ncdefvar3d(LVL_NATOMEGAA(iogrp),cmpflg,'p', - . 'natomegaalvl','Natural OmegaA',' ','1',2) - call ncdefvar3d(LVL_NATOMEGAC(iogrp),cmpflg,'p', - . 'natomegaclvl','Natural OmegaC',' ','1',2) -#endif -#ifdef BROMO - call ncdefvar3d(LVL_BROMO(iogrp),cmpflg,'p', - . 'bromolvl','Bromoform',' ','mol CHBr3 m-3',2) -#endif -#ifdef extNcycle - call ncdefvar3d(LVL_ANH4(iogrp),cmpflg,'p', - . 'nh4lvl','Ammonium',' ','mol N m-3',2) - call ncdefvar3d(LVL_ANO2(iogrp),cmpflg,'p', - . 'no2lvl','Nitrite',' ','mol N m-3',2) - - call ncdefvar3d(LVL_nitr_NH4(iogrp),cmpflg,'p', - . 'nh4nitrlvl','NH4 nitrification rate',' ','mol N m-3 s-1',2) - call ncdefvar3d(LVL_nitr_NO2(iogrp),cmpflg,'p', - . 'no2nitrlvl','NO2 nitrification rate',' ','mol N m-3 s-1',2) - call ncdefvar3d(LVL_nitr_N2O_prod(iogrp),cmpflg,'p', - . 'nitr_n2olvl','N2O prod during NH4 nitrification',' ', - . 'mol N2O m-3 s-1',2) - call ncdefvar3d(LVL_nitr_NH4_OM(iogrp),cmpflg,'p', - . 'nh4nitr_omlvl','OM production during NH4 nitrification',' ', - . 'mol P m-3 s-1',2) - call ncdefvar3d(LVL_nitr_NO2_OM(iogrp),cmpflg,'p', - . 'no2nitr_omlvl','OM production during NO2 nitrification',' ', - . 'mol P m-3 s-1',2) - call ncdefvar3d(LVL_denit_NO3(iogrp),cmpflg,'p', - . 'no3denitlvl','NO3 denitrification rate',' ','mol N m-3 s-1',2) - call ncdefvar3d(LVL_denit_NO2(iogrp),cmpflg,'p', - . 'no2denitlvl','NO2 denitrification rate',' ','mol N m-3 s-1',2) - call ncdefvar3d(LVL_denit_N2O(iogrp),cmpflg,'p', - . 'n2odenitlvl','N2O denitrification rate',' ', - . 'mol N2O m-3 s-1',2) - call ncdefvar3d(LVL_DNRA_NO2(iogrp),cmpflg,'p', - . 'no2dnralvl','NO2 DNRA rate',' ','mol N m-3 s-1',2) - call ncdefvar3d(LVL_anmx_N2_prod(iogrp),cmpflg,'p', - . 'anmx_n2lvl','Anammox N2 production rate',' ', - . 'mol N2 m-3 s-1',2) - call ncdefvar3d(LVL_anmx_OM_prod(iogrp),cmpflg,'p', - . 'anmx_omlvl','Anammox OM production rate',' ','mol P m-3 s-1',2) - call ncdefvar3d(LVL_phosy_NH4(iogrp),cmpflg,'p', - . 'phosy_nh4lvl','PP consumption rate of NH4',' ', - . 'mol N m-3 s-1',2) - call ncdefvar3d(LVL_phosy_NO3(iogrp),cmpflg,'p', - . 'phosy_no3lvl','PP consumption rate of NO3',' ', - . 'mol N m-3 s-1',2) - call ncdefvar3d(LVL_remin_aerob(iogrp),cmpflg,'p', - . 'reminalvl','Aerob remineralization rate',' ', - . 'mol N m-3 s-1',2) - call ncdefvar3d(LVL_remin_sulf(iogrp),cmpflg,'p', - . 'reminslvl','Sulfate remineralization rate',' ', - . 'mol P m-3 s-1',2) -#endif -c -c --- define sediment fields -#ifndef sedbypass - call ncdefvar3d(SDM_POWAIC(iogrp),cmpflg,'p', - . 'powdic','PoWa DIC',' ','mol C m-3',3) - call ncdefvar3d(SDM_POWAAL(iogrp),cmpflg,'p', - . 'powalk','PoWa alkalinity',' ','eq m-3',3) - call ncdefvar3d(SDM_POWAPH(iogrp),cmpflg,'p', - . 'powpho','PoWa phosphorus',' ','mol P m-3',3) - call ncdefvar3d(SDM_POWAOX(iogrp),cmpflg,'p', - . 'powox','PoWa oxygen',' ','mol O2 m-3',3) - call ncdefvar3d(SDM_POWN2(iogrp), cmpflg,'p', - . 'pown2','PoWa N2',' ','mol N2 m-3',3) - call ncdefvar3d(SDM_POWNO3(iogrp),cmpflg,'p', - . 'powno3','PoWa nitrate',' ','mol N m-3',3) - call ncdefvar3d(SDM_POWASI(iogrp),cmpflg,'p', - . 'powsi','PoWa silicate',' ','mol Si m-3',3) - call ncdefvar3d(SDM_SSSO12(iogrp),cmpflg,'p', - . 'ssso12','Sediment detritus',' ','mol P m-3',3) - call ncdefvar3d(SDM_SSSSIL(iogrp),cmpflg,'p', - . 'ssssil','Sediment silicate',' ','mol Si m-3',3) - call ncdefvar3d(SDM_SSSC12(iogrp),cmpflg,'p', - . 'sssc12','Sediment CaCO3',' ','mol C m-3',3) - call ncdefvar3d(SDM_SSSTER(iogrp),cmpflg,'p', - . 'ssster','Sediment clay',' ','mol m-3',3) -c -c --- define sediment burial fields - call ncdefvar3d(BUR_SSSO12(iogrp), - . cmpflg,'p','buro12','Burial org carbon',' ','mol P m-2',4) - call ncdefvar3d(BUR_SSSC12(iogrp), - . cmpflg,'p','burc12','Burial calcium ',' ','mol C m-2',4) - call ncdefvar3d(BUR_SSSSIL(iogrp), - . cmpflg,'p','bursil','Burial silicate',' ','mol Si m-2',4) - call ncdefvar3d(BUR_SSSTER(iogrp), - . cmpflg,'p','burter','Burial clay',' ','mol m-2',4) -#endif - -c -c --- enddef netcdf file - call ncedef - end diff --git a/hamocc/ncout_hamocc.F90 b/hamocc/ncout_hamocc.F90 new file mode 100644 index 00000000..782bcc9a --- /dev/null +++ b/hamocc/ncout_hamocc.F90 @@ -0,0 +1,2006 @@ +! Copyright (C) 2020 I Bethke, J. Tjiputra, J. Schwinger, A. Moree, M. +! Bentsen +! +! This file is part of BLOM/iHAMOCC. +! +! 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 https://www.gnu.org/licenses/. + + +subroutine ncwrt_bgc(iogrp) +! +! --- ------------------------------------------- +! --- output routine for HAMOCC diagnostic fields +! --- ------------------------------------------- +! + use mod_time, only: date0,date,calendar,nstep,nstep_in_day, & + & nday_of_year,time0,time + use mod_xc, only: kdm,mnproc,itdm,jtdm,lp + use mod_grid, only: depths + use mod_dia, only: diafnm,sigmar1,iotype,ddm,depthslev, & + & depthslev_bnds + use mo_control_bgc, only: dtbgc + use mo_vgrid, only: k0100,k0500,k1000,k2000,k4000 + use mo_param1_bgc, only: ks + use mod_nctools, only: ncwrt1,ncdims,nctime,ncfcls,ncfopn, & + & ncdimc + use mo_bgcmean, only: domassfluxes, & + & flx_cal0100,flx_cal0500,flx_cal1000, & + & flx_cal2000,flx_cal4000,flx_cal_bot, & + & flx_car0100,flx_car0500,flx_car1000, & + & flx_car2000,flx_car4000,flx_car_bot, & + & flx_bsi0100,flx_bsi0500,flx_bsi1000, & + & flx_bsi2000,flx_bsi4000,flx_bsi_bot, & + & flx_sediffic,flx_sediffal,flx_sediffph, & + & flx_sediffox,flx_sediffn2,flx_sediffno3, & + & flx_sediffsi, & + & flx_bursso12,flx_bursssc12,flx_burssssil, & + & flx_burssster, & + & jsediffic,jsediffal,jsediffph,jsediffox, & + & jsediffn2,jsediffno3,jsediffsi, & + & jburflxsso12,jburflxsssc12,jburflxssssil, & + & jburflxssster, & + & jalkali,jano3,jasize,jatmco2, & + & jbsiflx0100,jbsiflx0500,jbsiflx1000, & + & jbsiflx2000,jbsiflx4000,jbsiflx_bot, & + & jcalc,jcalflx0100,jcalflx0500,jcalflx1000, & + & jcalflx2000,jcalflx4000,jcalflx_bot, & + & jcarflx0100,jcarflx0500,jcarflx1000, & + & jcarflx2000,jcarflx4000,jcarflx_bot, & + & jco2flux,jco2fxd,jco2fxu,jco3,jdic,jdicsat, & + & jdms,jdms_bac,jdms_uv,jdmsflux,jdmsprod, & + & jdoc,jdp,jeps,jexpoca,jexport,jexposi, & + & jgrazer, & + & jintdnit,jintnfix,jintphosy,jiralk,jirdet, & + & jirdin,jirdip,jirdoc,jiriron,jiron,jirsi, & + & jkwco2,jlvlalkali,jlvlano3,jlvlasize, & + & jlvlbigd14c,jlvlbromo,jlvlcalc,jlvlcalc13, & + & jlvlcfc11,jlvlcfc12,jlvlco3,jlvld13c, & + & jlvld14c,jlvldic,jlvldic13,jlvldic14, & + & jlvldicsat,jlvldoc,jlvldoc13,jlvleps, & + & jlvlgrazer,jlvlgrazer13,jlvliron,jlvln2o, & + & jlvlnatalkali,jlvlnatcalc,jlvlnatco3, & + & jlvlnatdic,jlvlnatomegaa,jlvlnatomegac, & + & jlvlnos,jlvlo2sat,jlvlomegaa,jlvlomegac, & + & jlvlopal,jlvloxygen,jlvlph,jlvlphosph, & + & jlvlphosy,jlvlphyto,jlvlphyto13,jlvlpoc, & + & jlvlpoc13,jlvlprefalk,jlvlprefdic, & + & jlvlprefo2,jlvlprefpo4,jlvlsf6,jlvlsilica, & + & jlvlwnos,jlvlwphy,jn2flux,jn2o,jsrfpn2om,jn2oflux, & + & jn2ofx,jndep,jniflux,jnos,jo2flux,jo2sat, & + & jomegaa,jomegac,jopal,joxflux,joxygen,jpco2, & + & jpco2m,jkwco2khm,jco2kh,jco2khm, & + & jph,jphosph,jphosy,jphyto,jpoc,jprefalk, & + & jprefdic,jprefo2,jprefpo4,jsilica, & + & jsrfalkali,jsrfano3,jsrfdic,jsrfiron, & + & jsrfoxygen,jsrfphosph,jsrfphyto,jsrfsilica,jsrfph, & + & jwnos,jwphy, & + & lyr_dp,lyr_dic,lyr_alkali,lyr_phosph, & + & lyr_oxygen,lyr_ano3,lyr_silica,lyr_doc, & + & lyr_phyto,lyr_grazer,lyr_poc,lyr_calc, & + & lyr_opal,lyr_iron,lyr_phosy,lyr_co3,lyr_ph, & + & lyr_omegaa,lyr_omegac,lyr_n2o,lyr_prefo2, & + & lyr_o2sat,lyr_prefpo4,lyr_prefalk, & + & lyr_prefdic,lyr_dicsat, & + & lvl_dic,lvl_alkali, & + & lvl_phosph,lvl_oxygen,lvl_ano3,lvl_silica, & + & lvl_doc,lvl_phyto,lvl_grazer,lvl_poc, & + & lvl_calc,lvl_opal,lvl_iron,lvl_phosy, & + & lvl_co3,lvl_ph,lvl_omegaa,lvl_omegac, & + & lvl_n2o,lvl_prefo2,lvl_o2sat,lvl_prefpo4, & + & lvl_prefalk,lvl_prefdic,lvl_dicsat, & + & lvl_o2sat,srf_n2ofx,srf_pn2om,srf_atmco2,srf_kwco2, & + & srf_kwco2khm,srf_co2kh,srf_co2khm,srf_pco2m, & + & srf_pco2,srf_dmsflux,srf_co2fxd, & + & srf_co2fxu,srf_oxflux,srf_niflux,srf_dms, & + & srf_dmsprod,srf_dms_bac,srf_dms_uv, & + & srf_export,srf_exposi,srf_expoca,srf_dic, & + & srf_alkali,srf_phosph,srf_oxygen,srf_ano3, & + & srf_silica,srf_iron,srf_phyto,srf_ph, & + & int_phosy,int_nfix,int_dnit, & + & nbgc,nacc_bgc,bgcwrt,glb_inventory,bgct2d, & + & nbgcmax,glb_ncformat,glb_compflag, & + & glb_fnametag,filefq_bgc,diagfq_bgc, & + & filemon_bgc,fileann_bgc,ip,wrtlyr,wrtlvl,wrtsrf, & + & loglyr,loglvl,logsrf,inilvl,inilyr,inisrf, & + & msklvl,msksrf,finlyr, & + & lyr_agg_ws,lyr_dynvis,lyr_agg_stick, & + & lyr_agg_stickf,lyr_agg_dmax,lyr_agg_avdp, & + & lyr_agg_avrhop,lyr_agg_avdC,lyr_agg_df, & + & lyr_agg_b,lyr_agg_Vrhof,lyr_agg_Vpor, & + & lvl_agg_ws,lvl_dynvis,lvl_agg_stick, & + & lvl_agg_stickf,lvl_agg_dmax,lvl_agg_avdp, & + & lvl_agg_avrhop,lvl_agg_avdC,lvl_agg_df, & + & lvl_agg_b,lvl_agg_Vrhof,lvl_agg_Vpor, & + & jagg_ws,jdynvis,jagg_stick, & + & jagg_stickf,jagg_dmax,jagg_avdp, & + & jagg_avrhop,jagg_avdC,jagg_df, & + & jagg_b,jagg_Vrhof,jagg_Vpor, & + & jlvl_agg_ws,jlvl_dynvis,jlvl_agg_stick, & + & jlvl_agg_stickf,jlvl_agg_dmax,jlvl_agg_avdp, & + & jlvl_agg_avrhop,jlvl_agg_avdC,jlvl_agg_df, & + & jlvl_agg_b,jlvl_agg_Vrhof,jlvl_agg_Vpor +#ifdef AGG + use mo_bgcmean, only: lyr_nos,lyr_wphy, lyr_wnos,lyr_eps, & + & lyr_asize,lvl_nos,lvl_wphy,lvl_wnos,lvl_eps, & + & lvl_asize +#endif +#ifdef BROMO + use mo_bgcmean, only: jbromo,jbromofx,jsrfbromo,jbromo_prod, & + & jbromo_uv,jatmbromo,lvl_bromo,srf_bromofx, & + & srf_bromo,int_bromopro,int_bromouv, & + & srf_atmbromo,lyr_bromo +#endif +#ifdef CFC + use mo_bgcmean,only: jcfc11,jcfc12,jsf6,jcfc11fx,jcfc12fx,jsf6fx, & + & lvl_cfc11,lvl_cfc12,lvl_sf6,srf_cfc11, & + & srf_cfc12,srf_sf6,lyr_cfc11,lyr_cfc12, & + & lyr_sf6 +#endif +#ifdef cisonew + use mo_biomod, only: c14fac + use mo_bgcmean, only: jdic13,jdic14,jd13c,jd14c,jbigd14c,jpoc13, & + & jdoc13,jcalc13,jphyto13,jgrazer13,jco213fxd, & + & jco213fxu,jco214fxd,jco214fxu,jatmc13, & + & jatmc14,jdic13,jdic14,jd13c,jd14c,jbigd14c, & + & srf_co213fxd,srf_co213fxu,srf_co214fxd, & + & srf_co214fxu,srf_atmc13,srf_atmc14,lyr_dic13, & + & lyr_dic14,lyr_d13c,lyr_d14c,lyr_bigd14c, & + & lyr_poc13,lyr_doc13,lyr_calc13,lyr_phyto13, & + & lyr_grazer13,lvl_dic13,lvl_dic14,lvl_d13c, & + & lvl_d14c,lvl_bigd14c,lvl_poc13,lvl_doc13, & + & lvl_calc13,lvl_phyto13,lvl_grazer13 +#endif +#ifdef natDIC + use mo_bgcmean, only: jnatalkali,jnatdic,jnatcalc,jnatco3,jnatph, & + & jnatomegaa,jnatomegac,jlvlnatph, & + & jsrfnatdic,jsrfnatalk,jsrfnatph, & + & jnatpco2,jnatco2fx,lyr_natco3, & + & lyr_natalkali,lyr_natdic,lyr_natph,lyr_natcalc, & + & lyr_natomegaa,lyr_natomegac,lvl_natco3, & + & lvl_natalkali,lvl_natdic,lvl_natph,lvl_natcalc, & + & lvl_natomegaa,lvl_natomegac,srf_natdic, & + & srf_natalkali,srf_natpco2,srf_natco2fx,srf_natph +#endif +#ifndef sedbypass + use mo_bgcmean, only: jpowaic,jpowaal,jpowaph,jpowaox,jpown2, & + & jpowno3,jpowasi,jssso12,jssssil,jssster, & + & jsssc12,jbursssc12,jburssssil,jburssster, & + & sdm_powaic,sdm_powaal,sdm_powaph,sdm_powaox, & + & sdm_pown2,sdm_powno3,sdm_powasi,sdm_ssso12, & + & sdm_ssssil,sdm_sssc12,sdm_ssster,jburssso12, & + & bur_sssc12,bur_ssssil,bur_ssster,bur_ssso12, & + & inisdm,inibur,wrtsdm,accbur,accsdm,wrtbur +#endif +#ifdef extNcycle + use mo_bgcmean, only: janh4,jano2,jlvlanh4,jlvlano2,jsrfanh4,jsrfpnh3, & + & jsrfano2,janh3fx,srf_pnh3,srf_anh4,srf_ano2, & + & srf_anh3fx,lyr_anh4,lyr_ano2,lvl_anh4, & + & lvl_ano2, & + & LYR_nitr_NH4,LYR_nitr_NO2,LYR_nitr_N2O_prod, & + & LYR_nitr_NH4_OM,LYR_nitr_NO2_OM, & + & LYR_denit_NO3,LYR_denit_NO2,LYR_denit_N2O, & + & LYR_DNRA_NO2,LYR_anmx_N2_prod, & + & LYR_anmx_OM_prod,LYR_phosy_NH4, & + & LYR_phosy_NO3,LYR_remin_aerob,LYR_remin_sulf, & + & LVL_nitr_NH4,LVL_nitr_NO2,LVL_nitr_N2O_prod, & + & LVL_nitr_NH4_OM,LVL_nitr_NO2_OM, & + & LVL_denit_NO3,LVL_denit_NO2,LVL_denit_N2O, & + & LVL_DNRA_NO2,LVL_anmx_N2_prod, & + & LVL_anmx_OM_prod,LVL_phosy_NH4, & + & LVL_phosy_NO3,LVL_remin_aerob,LVL_remin_sulf, & + & jnitr_NH4,jnitr_NO2,jnitr_N2O_prod, & + & jnitr_NH4_OM,jnitr_NO2_OM,jdenit_NO3, & + & jdenit_NO2,jdenit_N2O,jDNRA_NO2, & + & janmx_N2_prod,janmx_OM_prod,jphosy_NH4, & + & jphosy_NO3,jremin_aerob,jremin_sulf, & + & jlvl_nitr_NH4,jlvl_nitr_NO2, & + & jlvl_nitr_N2O_prod,jlvl_nitr_NH4_OM, & + & jlvl_nitr_NO2_OM,jlvl_denit_NO3, & + & jlvl_denit_NO2,jlvl_denit_N2O,jlvl_DNRA_NO2, & + & jlvl_anmx_N2_prod,jlvl_anmx_OM_prod, & + & jlvl_phosy_NH4,jlvl_phosy_NO3, & + & jlvl_remin_aerob,jlvl_remin_sulf +#endif +#if defined(extNcycle) && ! defined(sedbypass) + use mo_bgcmean, only: jpownh4,jpown2o,jpowno2,jsdm_nitr_NH4,jsdm_nitr_NO2, & + & jsdm_nitr_N2O_prod,jsdm_nitr_NH4_OM,jsdm_nitr_NO2_OM, & + & jsdm_denit_NO3,jsdm_denit_NO2,jsdm_denit_N2O, & + & jsdm_DNRA_NO2,jsdm_anmx_N2_prod,jsdm_anmx_OM_prod, & + & jsdm_remin_aerob,jsdm_remin_sulf, SDM_POWNH4,SDM_POWN2O,& + & SDM_POWNO2,SDM_nitr_NH4,SDM_nitr_NO2,SDM_nitr_N2O_prod, & + & SDM_nitr_NH4_OM,SDM_nitr_NO2_OM,SDM_denit_NO3, & + & SDM_denit_NO2,SDM_denit_N2O,SDM_DNRA_NO2, & + & SDM_anmx_N2_prod,SDM_anmx_OM_prod,SDM_remin_aerob, & + & SDM_remin_sulf,jsediffnh4,jsediffn2o,jsediffno2, & + & FLX_SEDIFFNH4,FLX_SEDIFFN2O,FLX_SEDIFFNO2 +#endif + implicit none + + integer iogrp + + integer i,j,k,l,nt + integer ny,nm,nd,dayfrac,irec(nbgcmax),cmpflg + character*256 fname(nbgcmax) + character startdate*20,timeunits*30 + real datenum,rnacc + logical append2file(nbgcmax) + data append2file /nbgcmax*.false./ + save fname,irec,append2file + + ! --- set time information + timeunits=' ' + startdate=' ' + write(timeunits,'(a11,i4.4,a1,i2.2,a1,i2.2,a6)') & + & 'days since ',min(1800,date0%year),'-',1,'-',1,' 00:00' + write(startdate,'(i4.4,a1,i2.2,a1,i2.2,a6)') & + & date0%year,'-',date0%month,'-',date0%day,' 00:00' + datenum=time-time0-0.5*diagfq_bgc(iogrp)/nstep_in_day + + ! --- get file name + if (.not.append2file(iogrp)) then + call diafnm(GLB_FNAMETAG(iogrp), & + & filefq_bgc(iogrp)/real(nstep_in_day), & + & filemon_bgc(iogrp),fileann_bgc(iogrp),fname(iogrp)) + append2file(iogrp)=.true. + irec(iogrp)=1 + else + irec(iogrp)=irec(iogrp)+1 + endif + if (((fileann_bgc(iogrp).and.nday_of_year.eq.1.or. & + & filemon_bgc(iogrp).and.date%day.eq.1).and. & + & mod(nstep,nstep_in_day).eq.0).or. & + & .not.(fileann_bgc(iogrp).or.filemon_bgc(iogrp)).and. & + & mod(nstep+.5,filefq_bgc(iogrp)).lt.1.) then + append2file(iogrp)=.false. + endif + + ! --- prepare output fields + if (mnproc.eq.1) then + write (lp,'(a,f6.2,a)') ' ncwrt_bgc: fields averaged over ', & + & real(nacc_bgc(iogrp)),' steps' + write(lp,*) 'irec(iogrp)',irec(iogrp) + endif + rnacc=1./real(nacc_bgc(iogrp)) + cmpflg=GLB_COMPFLAG(iogrp) + + ! --- create output file + if (GLB_NCFORMAT(iogrp).eq.1) then + call ncfopn(fname(iogrp),'w','6',irec(iogrp),iotype) + elseif (GLB_NCFORMAT(iogrp).eq.2) then + call ncfopn(fname(iogrp),'w','h',irec(iogrp),iotype) + else + call ncfopn(fname(iogrp),'w','c',irec(iogrp),iotype) + endif + + ! --- define spatial and time dimensions + if (cmpflg.ne.0) then + call ncdimc('pcomp',ip,0) + else + call ncdims('x',itdm) + call ncdims('y',jtdm) + endif + call ncdims('sigma',kdm) + call ncdims('depth',ddm) + call ncdims('ks',ks) + call ncdims('bounds',2) + call ncdims('time',0) + call hamoccvardef(iogrp,timeunits,calendar,cmpflg) + call nctime(datenum,calendar,timeunits,startdate) + + ! --- write auxillary dimension information + call ncwrt1('sigma','sigma',sigmar1) + call ncwrt1('depth','depth',depthslev) + call ncwrt1('depth_bnds','bounds depth',depthslev_bnds) + + ! --- finalize accumulation + call finlyr(jphyto(iogrp),jdp(iogrp)) + call finlyr(jgrazer(iogrp),jdp(iogrp)) + call finlyr(jdoc(iogrp),jdp(iogrp)) + call finlyr(jphosy(iogrp),jdp(iogrp)) + call finlyr(jphosph(iogrp),jdp(iogrp)) + call finlyr(joxygen(iogrp),jdp(iogrp)) + call finlyr(jiron(iogrp),jdp(iogrp)) + call finlyr(jano3(iogrp),jdp(iogrp)) + call finlyr(jalkali(iogrp),jdp(iogrp)) + call finlyr(jsilica(iogrp),jdp(iogrp)) + call finlyr(jdic(iogrp),jdp(iogrp)) + call finlyr(jpoc(iogrp),jdp(iogrp)) + call finlyr(jcalc(iogrp),jdp(iogrp)) + call finlyr(jopal(iogrp),jdp(iogrp)) + call finlyr(jco3(iogrp),jdp(iogrp)) + call finlyr(jph(iogrp),jdp(iogrp)) + call finlyr(jomegaa(iogrp),jdp(iogrp)) + call finlyr(jomegac(iogrp),jdp(iogrp)) + call finlyr(jn2o(iogrp),jdp(iogrp)) + call finlyr(jprefo2(iogrp),jdp(iogrp)) + call finlyr(jo2sat(iogrp),jdp(iogrp)) + call finlyr(jprefpo4(iogrp),jdp(iogrp)) + call finlyr(jprefalk(iogrp),jdp(iogrp)) + call finlyr(jprefdic(iogrp),jdp(iogrp)) + call finlyr(jdicsat(iogrp),jdp(iogrp)) +#ifdef cisonew + call finlyr(jdic13(iogrp),jdp(iogrp)) + call finlyr(jdic14(iogrp),jdp(iogrp)) + call finlyr(jd13c(iogrp),jdp(iogrp)) + call finlyr(jd14c(iogrp),jdp(iogrp)) + call finlyr(jbigd14c(iogrp),jdp(iogrp)) + call finlyr(jpoc13(iogrp),jdp(iogrp)) + call finlyr(jdoc13(iogrp),jdp(iogrp)) + call finlyr(jcalc13(iogrp),jdp(iogrp)) + call finlyr(jphyto13(iogrp),jdp(iogrp)) + call finlyr(jgrazer13(iogrp),jdp(iogrp)) +#endif +#ifdef AGG + call finlyr(jnos(iogrp),jdp(iogrp)) + call finlyr(jwphy(iogrp),jdp(iogrp)) + call finlyr(jwnos(iogrp),jdp(iogrp)) + call finlyr(jeps(iogrp),jdp(iogrp)) + call finlyr(jasize(iogrp),jdp(iogrp)) +#endif +#ifdef CFC + call finlyr(jcfc11(iogrp),jdp(iogrp)) + call finlyr(jcfc12(iogrp),jdp(iogrp)) + call finlyr(jsf6(iogrp),jdp(iogrp)) +#endif +#ifdef natDIC + call finlyr(jnatalkali(iogrp),jdp(iogrp)) + call finlyr(jnatdic(iogrp),jdp(iogrp)) + call finlyr(jnatcalc(iogrp),jdp(iogrp)) + call finlyr(jnatco3(iogrp),jdp(iogrp)) + call finlyr(jnatph(iogrp),jdp(iogrp)) + call finlyr(jnatomegaa(iogrp),jdp(iogrp)) + call finlyr(jnatomegac(iogrp),jdp(iogrp)) +#endif +#ifdef BROMO + call finlyr(jbromo(iogrp),jdp(iogrp)) +#endif +#ifdef extNcycle + call finlyr(janh4(iogrp),jdp(iogrp)) + call finlyr(jano2(iogrp),jdp(iogrp)) + call finlyr(jnitr_NH4(iogrp),jdp(iogrp)) + call finlyr(jnitr_NO2(iogrp),jdp(iogrp)) + call finlyr(jnitr_N2O_prod(iogrp),jdp(iogrp)) + call finlyr(jnitr_NH4_OM(iogrp),jdp(iogrp)) + call finlyr(jnitr_NO2_OM(iogrp),jdp(iogrp)) + call finlyr(jdenit_NO3(iogrp),jdp(iogrp)) + call finlyr(jdenit_NO2(iogrp),jdp(iogrp)) + call finlyr(jdenit_N2O(iogrp),jdp(iogrp)) + call finlyr(jDNRA_NO2(iogrp),jdp(iogrp)) + call finlyr(janmx_N2_prod(iogrp),jdp(iogrp)) + call finlyr(janmx_OM_prod(iogrp),jdp(iogrp)) + call finlyr(jphosy_NH4(iogrp),jdp(iogrp)) + call finlyr(jphosy_NO3(iogrp),jdp(iogrp)) + call finlyr(jremin_aerob(iogrp),jdp(iogrp)) + call finlyr(jremin_sulf(iogrp),jdp(iogrp)) +#endif + ! M4AGO + call finlyr(jagg_ws(iogrp),jdp(iogrp)) + call finlyr(jdynvis(iogrp),jdp(iogrp)) + call finlyr(jagg_stick(iogrp),jdp(iogrp)) + call finlyr(jagg_stickf(iogrp),jdp(iogrp)) + call finlyr(jagg_dmax(iogrp),jdp(iogrp)) + call finlyr(jagg_avdp(iogrp),jdp(iogrp)) + call finlyr(jagg_avrhop(iogrp),jdp(iogrp)) + call finlyr(jagg_avdC(iogrp),jdp(iogrp)) + call finlyr(jagg_df(iogrp),jdp(iogrp)) + call finlyr(jagg_b(iogrp),jdp(iogrp)) + call finlyr(jagg_Vrhof(iogrp),jdp(iogrp)) + call finlyr(jagg_Vpor(iogrp),jdp(iogrp)) + + ! --- Mask sea floor in mass fluxes + call msksrf(jcarflx0100(iogrp),k0100) + call msksrf(jcarflx0500(iogrp),k0500) + call msksrf(jcarflx1000(iogrp),k1000) + call msksrf(jcarflx2000(iogrp),k2000) + call msksrf(jcarflx4000(iogrp),k4000) + call msksrf(jbsiflx0100(iogrp),k0100) + call msksrf(jbsiflx0500(iogrp),k0500) + call msksrf(jbsiflx1000(iogrp),k1000) + call msksrf(jbsiflx2000(iogrp),k2000) + call msksrf(jbsiflx4000(iogrp),k4000) + call msksrf(jcalflx0100(iogrp),k0100) + call msksrf(jcalflx0500(iogrp),k0500) + call msksrf(jcalflx1000(iogrp),k1000) + call msksrf(jcalflx2000(iogrp),k2000) + call msksrf(jcalflx4000(iogrp),k4000) + + ! --- Mask sea floor in level data + call msklvl(jlvlphyto(iogrp),depths) + call msklvl(jlvlgrazer(iogrp),depths) + call msklvl(jlvldoc(iogrp),depths) + call msklvl(jlvlphosy(iogrp),depths) + call msklvl(jlvlphosph(iogrp),depths) + call msklvl(jlvloxygen(iogrp),depths) + call msklvl(jlvliron(iogrp),depths) + call msklvl(jlvlano3(iogrp),depths) + call msklvl(jlvlalkali(iogrp),depths) + call msklvl(jlvlsilica(iogrp),depths) + call msklvl(jlvldic(iogrp),depths) + call msklvl(jlvlpoc(iogrp),depths) + call msklvl(jlvlcalc(iogrp),depths) + call msklvl(jlvlopal(iogrp),depths) + call msklvl(jlvlco3(iogrp),depths) + call msklvl(jlvlph(iogrp),depths) + call msklvl(jlvlomegaa(iogrp),depths) + call msklvl(jlvlomegac(iogrp),depths) + call msklvl(jlvln2o(iogrp),depths) + call msklvl(jlvlprefo2(iogrp),depths) + call msklvl(jlvlo2sat(iogrp),depths) + call msklvl(jlvlprefpo4(iogrp),depths) + call msklvl(jlvlprefalk(iogrp),depths) + call msklvl(jlvlprefdic(iogrp),depths) + call msklvl(jlvldicsat(iogrp),depths) +#ifdef cisonew + call msklvl(jlvldic13(iogrp),depths) + call msklvl(jlvldic14(iogrp),depths) + call msklvl(jlvld13c(iogrp),depths) + call msklvl(jlvld14c(iogrp),depths) + call msklvl(jlvlbigd14c(iogrp),depths) + call msklvl(jlvlpoc13(iogrp),depths) + call msklvl(jlvldoc13(iogrp),depths) + call msklvl(jlvlcalc13(iogrp),depths) + call msklvl(jlvlphyto13(iogrp),depths) + call msklvl(jlvlgrazer13(iogrp),depths) +#endif +#ifdef AGG + call msklvl(jlvlnos(iogrp),depths) + call msklvl(jlvlwphy(iogrp),depths) + call msklvl(jlvlwnos(iogrp),depths) + call msklvl(jlvleps(iogrp),depths) + call msklvl(jlvlasize(iogrp),depths) +#endif +#ifdef CFC + call msklvl(jlvlcfc11(iogrp),depths) + call msklvl(jlvlcfc12(iogrp),depths) + call msklvl(jlvlsf6(iogrp),depths) +#endif +#ifdef natDIC + call msklvl(jlvlnatalkali(iogrp),depths) + call msklvl(jlvlnatdic(iogrp),depths) + call msklvl(jlvlnatcalc(iogrp),depths) + call msklvl(jlvlnatco3(iogrp),depths) + call msklvl(jlvlnatph(iogrp),depths) + call msklvl(jlvlnatomegaa(iogrp),depths) + call msklvl(jlvlnatomegac(iogrp),depths) +#endif +#ifdef BROMO + call msklvl(jlvlbromo(iogrp),depths) +#endif +#ifdef extNcycle + call msklvl(jlvlanh4(iogrp),depths) + call msklvl(jlvlano2(iogrp),depths) + call msklvl(jlvl_nitr_NH4(iogrp),depths) + call msklvl(jlvl_nitr_NO2(iogrp),depths) + call msklvl(jlvl_nitr_N2O_prod(iogrp),depths) + call msklvl(jlvl_nitr_NH4_OM(iogrp),depths) + call msklvl(jlvl_nitr_NO2_OM(iogrp),depths) + call msklvl(jlvl_denit_NO3(iogrp),depths) + call msklvl(jlvl_denit_NO2(iogrp),depths) + call msklvl(jlvl_denit_N2O(iogrp),depths) + call msklvl(jlvl_DNRA_NO2(iogrp),depths) + call msklvl(jlvl_anmx_N2_prod(iogrp),depths) + call msklvl(jlvl_anmx_OM_prod(iogrp),depths) + call msklvl(jlvl_phosy_NH4(iogrp),depths) + call msklvl(jlvl_phosy_NO3(iogrp),depths) + call msklvl(jlvl_remin_aerob(iogrp),depths) + call msklvl(jlvl_remin_sulf(iogrp),depths) +#endif + ! M4AGO + call msklvl(jlvl_agg_ws(iogrp),depths) + call msklvl(jlvl_dynvis(iogrp),depths) + call msklvl(jlvl_agg_stick(iogrp),depths) + call msklvl(jlvl_agg_stickf(iogrp),depths) + call msklvl(jlvl_agg_dmax(iogrp),depths) + call msklvl(jlvl_agg_avdp(iogrp),depths) + call msklvl(jlvl_agg_avrhop(iogrp),depths) + call msklvl(jlvl_agg_avdC(iogrp),depths) + call msklvl(jlvl_agg_df(iogrp),depths) + call msklvl(jlvl_agg_b(iogrp),depths) + call msklvl(jlvl_agg_Vrhof(iogrp),depths) + call msklvl(jlvl_agg_Vpor(iogrp),depths) + + ! --- Compute log10 of pH + if (SRF_PH(iogrp).ne.0) call logsrf(jsrfph(iogrp),rnacc,0.) + if (LYR_PH(iogrp).ne.0) call loglyr(jph(iogrp),1.,0.) + if (LVL_PH(iogrp).ne.0) call loglvl(jlvlph(iogrp),rnacc,0.) +#ifdef natDIC + if (SRF_NATPH(iogrp).ne.0) call logsrf(jsrfnatph(iogrp),rnacc,0.) + if (LYR_NATPH(iogrp).ne.0) call loglyr(jnatph(iogrp),1.,0.) + if (LVL_NATPH(iogrp).ne.0) call loglvl(jlvlnatph(iogrp),rnacc,0.) +#endif + + ! --- Store 2d fields + call wrtsrf(jkwco2(iogrp), SRF_KWCO2(iogrp), rnacc, 0.,cmpflg,'kwco2') + call wrtsrf(jkwco2khm(iogrp), SRF_KWCO2KHM(iogrp), rnacc, 0.,cmpflg,'kwco2khm') + call wrtsrf(jco2kh(iogrp), SRF_CO2KH(iogrp), rnacc, 0.,cmpflg,'co2kh') + call wrtsrf(jco2khm(iogrp), SRF_CO2KHM(iogrp), rnacc, 0.,cmpflg,'co2khm') + call wrtsrf(jpco2(iogrp), SRF_PCO2(iogrp), rnacc, 0.,cmpflg,'pco2') + call wrtsrf(jpco2m(iogrp), SRF_PCO2M(iogrp), rnacc, 0.,cmpflg,'pco2m') + call wrtsrf(jdmsflux(iogrp), SRF_DMSFLUX(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'dmsflux') + call wrtsrf(jco2fxd(iogrp), SRF_CO2FXD(iogrp), rnacc*12./dtbgc,0.,cmpflg,'co2fxd') + call wrtsrf(jco2fxu(iogrp), SRF_CO2FXU(iogrp), rnacc*12./dtbgc,0.,cmpflg,'co2fxu') + call wrtsrf(joxflux(iogrp), SRF_OXFLUX(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'fgo2') + call wrtsrf(jniflux(iogrp), SRF_NIFLUX(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'fgn2') + call wrtsrf(jn2ofx(iogrp), SRF_N2OFX(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'n2oflux') + call wrtsrf(jsrfpn2om(iogrp), SRF_PN2OM(iogrp), rnacc, 0.,cmpflg,'pn2om') + call wrtsrf(jdms(iogrp), SRF_DMS(iogrp), rnacc, 0.,cmpflg,'dms') + call wrtsrf(jdmsprod(iogrp), SRF_DMSPROD(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'dmsprod') + call wrtsrf(jdms_bac(iogrp), SRF_DMS_BAC(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'dms_bac') + call wrtsrf(jdms_uv(iogrp), SRF_DMS_UV(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'dms_uv') + call wrtsrf(jexport(iogrp), SRF_EXPORT(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'epc100') + call wrtsrf(jexposi(iogrp), SRF_EXPOSI(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'epsi100') + call wrtsrf(jexpoca(iogrp), SRF_EXPOCA(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'epcalc100') + call wrtsrf(jsrfdic(iogrp), SRF_DIC(iogrp), rnacc*1e3, 0.,cmpflg,'srfdissic') + call wrtsrf(jsrfalkali(iogrp), SRF_ALKALI(iogrp), rnacc*1e3, 0.,cmpflg,'srftalk') + call wrtsrf(jsrfphosph(iogrp), SRF_PHOSPH(iogrp), rnacc*1e3, 0.,cmpflg,'srfpo4') + call wrtsrf(jsrfoxygen(iogrp), SRF_OXYGEN(iogrp), rnacc*1e3, 0.,cmpflg,'srfo2') + call wrtsrf(jsrfano3(iogrp), SRF_ANO3(iogrp), rnacc*1e3, 0.,cmpflg,'srfno3') + call wrtsrf(jsrfsilica(iogrp), SRF_SILICA(iogrp), rnacc*1e3, 0.,cmpflg,'srfsi') + call wrtsrf(jsrfiron(iogrp), SRF_IRON(iogrp), rnacc*1e3, 0.,cmpflg,'srfdfe') + call wrtsrf(jsrfphyto(iogrp), SRF_PHYTO(iogrp), rnacc*1e3, 0.,cmpflg,'srfphyc') + call wrtsrf(jsrfph(iogrp), SRF_PH(iogrp), -1., 0.,cmpflg,'srfph') + call wrtsrf(jintphosy(iogrp), INT_PHOSY(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'ppint') + call wrtsrf(jintnfix(iogrp), INT_NFIX(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'nfixint') + call wrtsrf(jintdnit(iogrp), INT_DNIT(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'dnitint') + call wrtsrf(jcarflx0100(iogrp), FLX_CAR0100(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'carflx0100') + call wrtsrf(jcarflx0500(iogrp), FLX_CAR0500(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'carflx0500') + call wrtsrf(jcarflx1000(iogrp), FLX_CAR1000(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'carflx1000') + call wrtsrf(jcarflx2000(iogrp), FLX_CAR2000(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'carflx2000') + call wrtsrf(jcarflx4000(iogrp), FLX_CAR4000(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'carflx4000') + call wrtsrf(jcarflx_bot(iogrp), FLX_CAR_BOT(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'carflx_bot') + call wrtsrf(jbsiflx0100(iogrp), FLX_BSI0100(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'bsiflx0100') + call wrtsrf(jbsiflx0500(iogrp), FLX_BSI0500(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'bsiflx0500') + call wrtsrf(jbsiflx1000(iogrp), FLX_BSI1000(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'bsiflx1000') + call wrtsrf(jbsiflx2000(iogrp), FLX_BSI2000(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'bsiflx2000') + call wrtsrf(jbsiflx4000(iogrp), FLX_BSI4000(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'bsiflx4000') + call wrtsrf(jbsiflx_bot(iogrp), FLX_BSI_BOT(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'bsiflx_bot') + call wrtsrf(jcalflx0100(iogrp), FLX_CAL0100(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'calflx0100') + call wrtsrf(jcalflx0500(iogrp), FLX_CAL0500(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'calflx0500') + call wrtsrf(jcalflx1000(iogrp), FLX_CAL1000(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'calflx1000') + call wrtsrf(jcalflx2000(iogrp), FLX_CAL2000(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'calflx2000') + call wrtsrf(jcalflx4000(iogrp), FLX_CAL4000(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'calflx4000') + call wrtsrf(jcalflx_bot(iogrp), FLX_CAL_BOT(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'calflx_bot') +#ifndef sedbypass + call wrtsrf(jsediffic(iogrp), FLX_SEDIFFIC(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'sedfdic') + call wrtsrf(jsediffal(iogrp), FLX_SEDIFFAL(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'sedfalk') + call wrtsrf(jsediffph(iogrp), FLX_SEDIFFPH(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'sedfpho') + call wrtsrf(jsediffox(iogrp), FLX_SEDIFFOX(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'sedfox') + call wrtsrf(jsediffn2(iogrp), FLX_SEDIFFN2(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'sedfn2') + call wrtsrf(jsediffno3(iogrp), FLX_SEDIFFNO3(iogrp),rnacc*1e3/dtbgc,0.,cmpflg,'sedfno3') + call wrtsrf(jsediffsi(iogrp), FLX_SEDIFFSI(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'sedfsi') + call wrtsrf(jburflxsso12(iogrp), FLX_BURSSO12(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'burfsso12') + call wrtsrf(jburflxsssc12(iogrp),FLX_BURSSSC12(iogrp),rnacc*1e3/dtbgc,0.,cmpflg,'burfsssc12') + call wrtsrf(jburflxssssil(iogrp),FLX_BURSSSSIL(iogrp),rnacc*1e3/dtbgc,0.,cmpflg,'burfssssil') + call wrtsrf(jburflxssster(iogrp),FLX_BURSSSTER(iogrp),rnacc*1e3/dtbgc,0.,cmpflg,'burfssster') +#endif +#if defined(extNcycle) && ! defined(sedbypass) + call wrtsrf(jsediffnh4(iogrp), FLX_SEDIFFNH4(iogrp),rnacc*1e3/dtbgc,0.,cmpflg,'sedfnh4') + call wrtsrf(jsediffn2o(iogrp), FLX_SEDIFFN2O(iogrp),rnacc*1e3/dtbgc,0.,cmpflg,'sedfn2o') + call wrtsrf(jsediffno2(iogrp), FLX_SEDIFFNO2(iogrp),rnacc*1e3/dtbgc,0.,cmpflg,'sedfno2') +#endif +#ifdef cisonew + call wrtsrf(jco213fxd(iogrp), SRF_CO213FXD(iogrp), rnacc*12./dtbgc,0.,cmpflg,'co213fxd') + call wrtsrf(jco213fxu(iogrp), SRF_CO213FXU(iogrp), rnacc*12./dtbgc,0.,cmpflg,'co213fxu') + call wrtsrf(jco214fxd(iogrp), SRF_CO214FXD(iogrp), rnacc*12.*c14fac/dtbgc,0.,cmpflg,'co214fxd') + call wrtsrf(jco214fxu(iogrp), SRF_CO214FXU(iogrp), rnacc*12.*c14fac/dtbgc,0.,cmpflg,'co214fxu') +#endif +#ifdef CFC + call wrtsrf(jcfc11fx(iogrp), SRF_CFC11(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'cfc11flux') + call wrtsrf(jcfc12fx(iogrp), SRF_CFC12(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'cfc12flux') + call wrtsrf(jsf6fx(iogrp), SRF_SF6(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'sf6flux') +#endif +#ifdef natDIC + call wrtsrf(jsrfnatdic(iogrp), SRF_NATDIC(iogrp), rnacc*1e3, 0.,cmpflg,'srfnatdissic') + call wrtsrf(jsrfnatalk(iogrp), SRF_NATALKALI(iogrp),rnacc*1e3, 0.,cmpflg,'srfnattalk') + call wrtsrf(jnatpco2(iogrp), SRF_NATPCO2(iogrp), rnacc, 0.,cmpflg,'natpco2') + call wrtsrf(jnatco2fx(iogrp), SRF_NATCO2FX(iogrp), rnacc*12./dtbgc,0.,cmpflg,'natco2fx') + call wrtsrf(jsrfnatph(iogrp), SRF_NATPH(iogrp), -1., 0.,cmpflg,'srfnatph') +#endif +#ifdef BROMO + call wrtsrf(jbromofx(iogrp), SRF_BROMOFX(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'bromofx') + call wrtsrf(jsrfbromo(iogrp), SRF_BROMO(iogrp), rnacc*1e3, 0.,cmpflg,'srfbromo') + call wrtsrf(jbromo_prod(iogrp), INT_BROMOPRO(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'intbromoprod') + call wrtsrf(jbromo_uv(iogrp), INT_BROMOUV(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'intbromouv') + call wrtsrf(jatmbromo(iogrp), SRF_ATMBROMO(iogrp), rnacc, 0.,cmpflg,'atmbromo') +#endif + call wrtsrf(jatmco2(iogrp), SRF_ATMCO2(iogrp), rnacc, 0.,cmpflg,'atmco2') +#if defined(BOXATM) + call wrtsrf(jatmo2(iogrp), SRF_ATMO2(iogrp), rnacc, 0.,cmpflg,'atmo2') + call wrtsrf(jatmn2(iogrp), SRF_ATMN2(iogrp), rnacc, 0.,cmpflg,'atmn2') +#endif +#ifdef cisonew + call wrtsrf(jatmc13(iogrp), SRF_ATMC13(iogrp), rnacc, 0.,cmpflg,'atmc13') + call wrtsrf(jatmc14(iogrp), SRF_ATMC14(iogrp), rnacc, 0.,cmpflg,'atmc14') +#endif +#ifdef extNcycle + call wrtsrf(jsrfanh4(iogrp), SRF_ANH4(iogrp), rnacc*1e3, 0.,cmpflg,'srfnh4') + call wrtsrf(jsrfpnh3(iogrp), SRF_PNH3(iogrp), rnacc, 0.,cmpflg,'pnh3') + call wrtsrf(jsrfano2(iogrp), SRF_ANO2(iogrp), rnacc*1e3, 0.,cmpflg,'srfno2') + call wrtsrf(janh3fx(iogrp), SRF_ANH3FX(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'nh3flux') +#endif + + ! --- Store 3d layer fields + call wrtlyr(jdp(iogrp), LYR_DP(iogrp), rnacc, 0.,cmpflg,'pddpo') + call wrtlyr(jdic(iogrp), LYR_DIC(iogrp), 1e3, 0.,cmpflg,'dissic') + call wrtlyr(jalkali(iogrp), LYR_ALKALI(iogrp), 1e3, 0.,cmpflg,'talk') + call wrtlyr(jphosph(iogrp), LYR_PHOSPH(iogrp), 1e3, 0.,cmpflg,'po4') + call wrtlyr(joxygen(iogrp), LYR_OXYGEN(iogrp), 1e3, 0.,cmpflg,'o2') + call wrtlyr(jano3(iogrp), LYR_ANO3(iogrp), 1e3, 0.,cmpflg,'no3') + call wrtlyr(jsilica(iogrp), LYR_SILICA(iogrp), 1e3, 0.,cmpflg,'si') + call wrtlyr(jdoc(iogrp), LYR_DOC(iogrp), 1e3, 0.,cmpflg,'dissoc') + call wrtlyr(jphyto(iogrp), LYR_PHYTO(iogrp), 1e3, 0.,cmpflg,'phyc') + call wrtlyr(jgrazer(iogrp), LYR_GRAZER(iogrp), 1e3, 0.,cmpflg,'zooc') + call wrtlyr(jpoc(iogrp), LYR_POC(iogrp), 1e3, 0.,cmpflg,'detoc') + call wrtlyr(jcalc(iogrp), LYR_CALC(iogrp), 1e3, 0.,cmpflg,'calc') + call wrtlyr(jopal(iogrp), LYR_OPAL(iogrp), 1e3, 0.,cmpflg,'opal') + call wrtlyr(jiron(iogrp), LYR_IRON(iogrp), 1e3, 0.,cmpflg,'dfe') + call wrtlyr(jphosy(iogrp), LYR_PHOSY(iogrp), 1e3/dtbgc, 0.,cmpflg,'pp') + call wrtlyr(jco3(iogrp), LYR_CO3(iogrp), 1e3, 0.,cmpflg,'co3') + call wrtlyr(jph(iogrp), LYR_PH(iogrp), -1., 0.,cmpflg,'ph') + call wrtlyr(jomegaa(iogrp), LYR_OMEGAA(iogrp), 1., 0.,cmpflg,'omegaa') + call wrtlyr(jomegac(iogrp), LYR_OMEGAC(iogrp), 1., 0.,cmpflg,'omegac') + call wrtlyr(jn2o(iogrp), LYR_N2O(iogrp), 1e3, 0.,cmpflg,'n2o') + call wrtlyr(jprefo2(iogrp), LYR_PREFO2(iogrp), 1e3, 0.,cmpflg,'p_o2') + call wrtlyr(jo2sat(iogrp), LYR_O2SAT(iogrp), 1e3, 0.,cmpflg,'satoxy') + call wrtlyr(jprefpo4(iogrp), LYR_PREFPO4(iogrp), 1e3, 0.,cmpflg,'p_po4') + call wrtlyr(jprefalk(iogrp), LYR_PREFALK(iogrp), 1e3, 0.,cmpflg,'p_talk') + call wrtlyr(jprefdic(iogrp), LYR_PREFDIC(iogrp), 1e3, 0.,cmpflg,'p_dic') + call wrtlyr(jdicsat(iogrp), LYR_DICSAT(iogrp), 1e3, 0.,cmpflg,'sat_dic') +#ifdef cisonew + call wrtlyr(jdic13(iogrp), LYR_DIC13(iogrp), 1.e3, 0.,cmpflg,'dissic13') + call wrtlyr(jdic14(iogrp), LYR_DIC14(iogrp), 1.e3*c14fac, 0.,cmpflg,'dissic14') + call wrtlyr(jd13c(iogrp), LYR_D13C(iogrp), 1., 0.,cmpflg,'delta13c') + call wrtlyr(jd14c(iogrp), LYR_D14C(iogrp), 1., 0.,cmpflg,'delta14c') + call wrtlyr(jbigd14c(iogrp), LYR_BIGD14C(iogrp), 1., 0.,cmpflg,'bigdelta14c') + call wrtlyr(jpoc13(iogrp), LYR_POC13(iogrp), 1e3, 0.,cmpflg,'detoc13') + call wrtlyr(jdoc13(iogrp), LYR_DOC13(iogrp), 1e3, 0.,cmpflg,'dissoc13') + call wrtlyr(jcalc13(iogrp), LYR_CALC13(iogrp), 1e3, 0.,cmpflg,'calc13') + call wrtlyr(jphyto13(iogrp), LYR_PHYTO13(iogrp), 1e3, 0.,cmpflg,'phyc13') + call wrtlyr(jgrazer13(iogrp), LYR_GRAZER13(iogrp), 1e3, 0.,cmpflg,'zooc13') +#endif +#ifdef AGG + call wrtlyr(jnos(iogrp), LYR_NOS(iogrp), 1., 0.,cmpflg,'nos') + call wrtlyr(jwphy(iogrp), LYR_WPHY(iogrp), 1., 0.,cmpflg,'wphy') + call wrtlyr(jwnos(iogrp), LYR_WNOS(iogrp), 1., 0.,cmpflg,'wnos') + call wrtlyr(jeps(iogrp), LYR_EPS(iogrp), 1., 0.,cmpflg,'eps') + call wrtlyr(jasize(iogrp), LYR_ASIZE(iogrp), 1., 0.,cmpflg,'asize') +#endif +#ifdef CFC + call wrtlyr(jcfc11(iogrp), LYR_CFC11(iogrp), 1e3, 0.,cmpflg,'cfc11') + call wrtlyr(jcfc12(iogrp), LYR_CFC12(iogrp), 1e3, 0.,cmpflg,'cfc12') + call wrtlyr(jsf6(iogrp), LYR_SF6(iogrp), 1e3, 0.,cmpflg,'sf6') +#endif +#ifdef natDIC + call wrtlyr(jnatco3(iogrp), LYR_NATCO3(iogrp), 1e3, 0.,cmpflg,'natco3') + call wrtlyr(jnatalkali(iogrp), LYR_NATALKALI(iogrp),1e3, 0.,cmpflg,'nattalk') + call wrtlyr(jnatdic(iogrp), LYR_NATDIC(iogrp), 1e3, 0.,cmpflg,'natdissic') + call wrtlyr(jnatcalc(iogrp), LYR_NATCALC(iogrp), 1e3, 0.,cmpflg,'natcalc') + call wrtlyr(jnatph(iogrp), LYR_NATPH(iogrp), -1., 0.,cmpflg,'natph') + call wrtlyr(jnatomegaa(iogrp), LYR_NATOMEGAA(iogrp),1., 0.,cmpflg,'natomegaa') + call wrtlyr(jnatomegac(iogrp), LYR_NATOMEGAC(iogrp),1., 0.,cmpflg,'natomegac') +#endif +#ifdef BROMO + call wrtlyr(jbromo(iogrp), LYR_BROMO(iogrp), 1e3, 0.,cmpflg,'bromo') +#endif +#ifdef extNcycle + call wrtlyr(janh4(iogrp), LYR_ANH4(iogrp), 1e3, 0.,cmpflg,'nh4') + call wrtlyr(jano2(iogrp), LYR_ANO2(iogrp), 1e3, 0.,cmpflg,'no2') + call wrtlyr(jnitr_NH4(iogrp), LYR_nitr_NH4(iogrp), 1e3/dtbgc, 0.,cmpflg,'nh4nitr') + call wrtlyr(jnitr_NO2(iogrp), LYR_nitr_NO2(iogrp), 1e3/dtbgc, 0.,cmpflg,'no2nitr') + call wrtlyr(jnitr_N2O_prod(iogrp),LYR_nitr_N2O_prod(iogrp),1e3/dtbgc, 0.,cmpflg,'nitr_n2o') + call wrtlyr(jnitr_NH4_OM(iogrp), LYR_nitr_NH4_OM(iogrp),1e3/dtbgc, 0.,cmpflg,'nh4nitr_om') + call wrtlyr(jnitr_NO2_OM(iogrp), LYR_nitr_NO2_OM(iogrp),1e3/dtbgc, 0.,cmpflg,'no2nitr_om') + call wrtlyr(jdenit_NO3(iogrp), LYR_denit_NO3(iogrp),1e3/dtbgc, 0.,cmpflg,'no3denit') + call wrtlyr(jdenit_NO2(iogrp), LYR_denit_NO2(iogrp),1e3/dtbgc, 0.,cmpflg,'no2denit') + call wrtlyr(jdenit_N2O(iogrp), LYR_denit_N2O(iogrp),1e3/dtbgc, 0.,cmpflg,'n2odenit') + call wrtlyr(jDNRA_NO2(iogrp), LYR_DNRA_NO2(iogrp), 1e3/dtbgc, 0.,cmpflg,'no2dnra') + call wrtlyr(janmx_N2_prod(iogrp),LYR_anmx_N2_prod(iogrp),1e3/dtbgc, 0.,cmpflg,'anmx_n2') + call wrtlyr(janmx_OM_prod(iogrp),LYR_anmx_OM_prod(iogrp),1e3/dtbgc, 0.,cmpflg,'anmx_om') + call wrtlyr(jphosy_NH4(iogrp), LYR_phosy_NH4(iogrp),1e3/dtbgc, 0.,cmpflg,'phosy_nh4') + call wrtlyr(jphosy_NO3(iogrp), LYR_phosy_NO3(iogrp),1e3/dtbgc, 0.,cmpflg,'phosy_no3') + call wrtlyr(jremin_aerob(iogrp), LYR_remin_aerob(iogrp),1e3/dtbgc, 0.,cmpflg,'remina') + call wrtlyr(jremin_sulf(iogrp), LYR_remin_sulf(iogrp),1e3/dtbgc, 0.,cmpflg,'remins') +#endif +! M4AGO + call wrtlyr(jagg_ws(iogrp), LYR_agg_ws(iogrp), 1., 0.,cmpflg,'agg_ws') + call wrtlyr(jdynvis(iogrp), LYR_dynvis(iogrp), 1., 0.,cmpflg,'dynvis') + call wrtlyr(jagg_stick(iogrp), LYR_agg_stick(iogrp),1., 0.,cmpflg,'agg_stick') + call wrtlyr(jagg_stickf(iogrp), LYR_agg_stickf(iogrp),1., 0.,cmpflg,'agg_stickf') + call wrtlyr(jagg_dmax(iogrp), LYR_agg_dmax(iogrp), 1., 0.,cmpflg,'agg_dmax') + call wrtlyr(jagg_avdp(iogrp), LYR_agg_avdp(iogrp), 1., 0.,cmpflg,'agg_avdp') + call wrtlyr(jagg_avrhop(iogrp), LYR_agg_avrhop(iogrp),1., 0.,cmpflg,'agg_avrhop') + call wrtlyr(jagg_avdC(iogrp), LYR_agg_avdC(iogrp), 1., 0.,cmpflg,'agg_avdC') + call wrtlyr(jagg_df(iogrp), LYR_agg_df(iogrp), 1., 0.,cmpflg,'agg_df') + call wrtlyr(jagg_b(iogrp), LYR_agg_b(iogrp), 1., 0.,cmpflg,'agg_b') + call wrtlyr(jagg_Vrhof(iogrp), LYR_agg_Vrhof(iogrp),1., 0.,cmpflg,'agg_Vrhof') + call wrtlyr(jagg_Vpor(iogrp), LYR_agg_Vpor(iogrp), 1., 0.,cmpflg,'agg_Vpor') + + ! --- Store 3d level fields + call wrtlvl(jlvldic(iogrp), LVL_DIC(iogrp), rnacc*1e3, 0.,cmpflg,'dissiclvl') + call wrtlvl(jlvlalkali(iogrp), LVL_ALKALI(iogrp), rnacc*1e3, 0.,cmpflg,'talklvl') + call wrtlvl(jlvlphosph(iogrp), LVL_PHOSPH(iogrp), rnacc*1e3, 0.,cmpflg,'po4lvl') + call wrtlvl(jlvloxygen(iogrp), LVL_OXYGEN(iogrp), rnacc*1e3, 0.,cmpflg,'o2lvl') + call wrtlvl(jlvlano3(iogrp), LVL_ANO3(iogrp), rnacc*1e3, 0.,cmpflg,'no3lvl') + call wrtlvl(jlvlsilica(iogrp), LVL_SILICA(iogrp), rnacc*1e3, 0.,cmpflg,'silvl') + call wrtlvl(jlvldoc(iogrp), LVL_DOC(iogrp), rnacc*1e3, 0.,cmpflg,'dissoclvl') + call wrtlvl(jlvlphyto(iogrp), LVL_PHYTO(iogrp), rnacc*1e3, 0.,cmpflg,'phyclvl') + call wrtlvl(jlvlgrazer(iogrp), LVL_GRAZER(iogrp), rnacc*1e3, 0.,cmpflg,'zooclvl') + call wrtlvl(jlvlpoc(iogrp), LVL_POC(iogrp), rnacc*1e3, 0.,cmpflg,'detoclvl') + call wrtlvl(jlvlcalc(iogrp), LVL_CALC(iogrp), rnacc*1e3, 0.,cmpflg,'calclvl') + call wrtlvl(jlvlopal(iogrp), LVL_OPAL(iogrp), rnacc*1e3, 0.,cmpflg,'opallvl') + call wrtlvl(jlvliron(iogrp), LVL_IRON(iogrp), rnacc*1e3, 0.,cmpflg,'dfelvl') + call wrtlvl(jlvlphosy(iogrp), LVL_PHOSY(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'pplvl') + call wrtlvl(jlvlco3(iogrp), LVL_CO3(iogrp), rnacc*1e3, 0.,cmpflg,'co3lvl') + call wrtlvl(jlvlph(iogrp), LVL_PH(iogrp), -1., 0.,cmpflg,'phlvl') + call wrtlvl(jlvlomegaa(iogrp), LVL_OMEGAA(iogrp), rnacc, 0.,cmpflg,'omegaalvl') + call wrtlvl(jlvlomegac(iogrp), LVL_OMEGAC(iogrp), rnacc, 0.,cmpflg,'omegaclvl') + call wrtlvl(jlvln2o(iogrp), LVL_N2O(iogrp), rnacc*1e3, 0.,cmpflg,'n2olvl') + call wrtlvl(jlvlprefo2(iogrp), LVL_PREFO2(iogrp), rnacc*1e3, 0.,cmpflg,'p_o2lvl') + call wrtlvl(jlvlo2sat(iogrp), LVL_O2SAT(iogrp), rnacc*1e3, 0.,cmpflg,'satoxylvl') + call wrtlvl(jlvlprefpo4(iogrp), LVL_PREFPO4(iogrp), rnacc*1e3, 0.,cmpflg,'p_po4lvl') + call wrtlvl(jlvlprefalk(iogrp), LVL_PREFALK(iogrp), rnacc*1e3, 0.,cmpflg,'p_talklvl') + call wrtlvl(jlvlprefdic(iogrp), LVL_PREFDIC(iogrp), rnacc*1e3, 0.,cmpflg,'p_diclvl') + call wrtlvl(jlvldicsat(iogrp), LVL_DICSAT(iogrp), rnacc*1e3, 0.,cmpflg,'sat_diclvl') +#ifdef cisonew + call wrtlvl(jlvldic13(iogrp), LVL_DIC13(iogrp), rnacc*1.e3, 0.,cmpflg,'dissic13lvl') + call wrtlvl(jlvldic14(iogrp), LVL_DIC14(iogrp), rnacc*1.e3*c14fac,0.,cmpflg,'dissic14lvl') + call wrtlvl(jlvld13c(iogrp), LVL_D13C(iogrp), rnacc, 0.,cmpflg,'delta13clvl') + call wrtlvl(jlvld14c(iogrp), LVL_D14C(iogrp), rnacc, 0.,cmpflg,'delta14clvl') + call wrtlvl(jlvlbigd14c(iogrp), LVL_BIGD14C(iogrp), rnacc, 0.,cmpflg,'bigdelta14clvl') + call wrtlvl(jlvlpoc13(iogrp), LVL_POC13(iogrp), rnacc*1e3, 0.,cmpflg,'detoc13lvl') + call wrtlvl(jlvldoc13(iogrp), LVL_DOC13(iogrp), rnacc*1e3, 0.,cmpflg,'dissoc13lvl') + call wrtlvl(jlvlcalc13(iogrp), LVL_CALC13(iogrp), rnacc*1e3, 0.,cmpflg,'calc13lvl') + call wrtlvl(jlvlphyto13(iogrp), LVL_PHYTO13(iogrp), rnacc*1e3, 0.,cmpflg,'phyc13lvl') + call wrtlvl(jlvlgrazer13(iogrp), LVL_GRAZER13(iogrp), rnacc*1e3, 0.,cmpflg,'zooc13lvl') +#endif +#ifdef AGG + call wrtlvl(jlvlnos(iogrp), LVL_NOS(iogrp), rnacc, 0.,cmpflg,'noslvl') + call wrtlvl(jlvlwphy(iogrp), LVL_WPHY(iogrp), rnacc, 0.,cmpflg,'wphylvl') + call wrtlvl(jlvlwnos(iogrp), LVL_WNOS(iogrp), rnacc, 0.,cmpflg,'wnoslvl') + call wrtlvl(jlvleps(iogrp), LVL_EPS(iogrp), rnacc, 0.,cmpflg,'epslvl') + call wrtlvl(jlvlasize(iogrp), LVL_ASIZE(iogrp), rnacc, 0.,cmpflg,'asizelvl') +#endif +#ifdef CFC + call wrtlvl(jlvlcfc11(iogrp), LVL_CFC11(iogrp), rnacc*1e3, 0.,cmpflg,'cfc11lvl') + call wrtlvl(jlvlcfc12(iogrp), LVL_CFC12(iogrp), rnacc*1e3, 0.,cmpflg,'cfc12lvl') + call wrtlvl(jlvlsf6(iogrp), LVL_SF6(iogrp), rnacc*1e3, 0.,cmpflg,'sf6lvl') +#endif +#ifdef natDIC + call wrtlvl(jlvlnatco3(iogrp), LVL_NATCO3(iogrp), rnacc*1e3, 0.,cmpflg,'natco3lvl') + call wrtlvl(jlvlnatalkali(iogrp),LVL_NATALKALI(iogrp),rnacc*1e3, 0.,cmpflg,'nattalklvl') + call wrtlvl(jlvlnatdic(iogrp), LVL_NATDIC(iogrp), rnacc*1e3, 0.,cmpflg,'natdissiclvl') + call wrtlvl(jlvlnatcalc(iogrp), LVL_NATCALC(iogrp), rnacc*1e3, 0.,cmpflg,'natcalclvl') + call wrtlvl(jlvlnatph(iogrp), LVL_NATPH(iogrp), -1., 0.,cmpflg,'natphlvl') + call wrtlvl(jlvlnatomegaa(iogrp),LVL_NATOMEGAA(iogrp),rnacc, 0.,cmpflg,'natomegaalvl') + call wrtlvl(jlvlnatomegac(iogrp),LVL_NATOMEGAC(iogrp),rnacc, 0.,cmpflg,'natomegaclvl') +#endif +#ifdef BROMO + call wrtlvl(jlvlbromo(iogrp), LVL_BROMO(iogrp), rnacc*1e3, 0.,cmpflg,'bromolvl') +#endif +#ifdef extNcycle + call wrtlvl(jlvlanh4(iogrp), LVL_ANH4(iogrp), rnacc*1e3, 0.,cmpflg,'nh4lvl') + call wrtlvl(jlvlano2(iogrp), LVL_ANO2(iogrp), rnacc*1e3, 0.,cmpflg,'no2lvl') + call wrtlvl(jlvl_nitr_NH4(iogrp), LVL_nitr_NH4(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'nh4nitrlvl') + call wrtlvl(jlvl_nitr_NO2(iogrp), LVL_nitr_NO2(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'no2nitrlvl') + call wrtlvl(jlvl_nitr_N2O_prod(iogrp),LVL_nitr_N2O_prod(iogrp),rnacc*1e3/dtbgc,0.,cmpflg,'nitr_n2olvl') + call wrtlvl(jlvl_nitr_NH4_OM(iogrp), LVL_nitr_NH4_OM(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'nh4nitr_omlvl') + call wrtlvl(jlvl_nitr_NO2_OM(iogrp), LVL_nitr_NO2_OM(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'no2nitr_omlvl') + call wrtlvl(jlvl_denit_NO3(iogrp), LVL_denit_NO3(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'no3denitlvl') + call wrtlvl(jlvl_denit_NO2(iogrp), LVL_denit_NO2(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'no2denitlvl') + call wrtlvl(jlvl_denit_N2O(iogrp), LVL_denit_N2O(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'n2odenitlvl') + call wrtlvl(jlvl_DNRA_NO2(iogrp), LVL_DNRA_NO2(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'no2dnralvl') + call wrtlvl(jlvl_anmx_N2_prod(iogrp), LVL_anmx_N2_prod(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'anmx_n2lvl') + call wrtlvl(jlvl_anmx_OM_prod(iogrp), LVL_anmx_OM_prod(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'anmx_omlvl') + call wrtlvl(jlvl_phosy_NH4(iogrp), LVL_phosy_NH4(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'phosy_nh4lvl') + call wrtlvl(jlvl_phosy_NO3(iogrp), LVL_phosy_NO3(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'phosy_no3lvl') + call wrtlvl(jlvl_remin_aerob(iogrp), LVL_remin_aerob(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'reminalvl') + call wrtlvl(jlvl_remin_sulf(iogrp), LVL_remin_sulf(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'reminslvl') +#endif +! M4AGO + call wrtlvl(jlvl_agg_ws(iogrp), LVL_agg_ws(iogrp), rnacc, 0.,cmpflg,'agg_wslvl') + call wrtlvl(jlvl_dynvis(iogrp), LVL_dynvis(iogrp), rnacc, 0.,cmpflg,'dynvislvl') + call wrtlvl(jlvl_agg_stick(iogrp), LVL_agg_stick(iogrp), rnacc, 0.,cmpflg,'agg_sticklvl') + call wrtlvl(jlvl_agg_stickf(iogrp), LVL_agg_stickf(iogrp), rnacc, 0.,cmpflg,'agg_stickflvl') + call wrtlvl(jlvl_agg_dmax(iogrp), LVL_agg_dmax(iogrp), rnacc, 0.,cmpflg,'agg_dmaxlvl') + call wrtlvl(jlvl_agg_avdp(iogrp), LVL_agg_avdp(iogrp), rnacc, 0.,cmpflg,'agg_avdplvl') + call wrtlvl(jlvl_agg_avrhop(iogrp), LVL_agg_avrhop(iogrp), rnacc, 0.,cmpflg,'agg_avrhoplvl') + call wrtlvl(jlvl_agg_avdC(iogrp), LVL_agg_avdC(iogrp), rnacc, 0.,cmpflg,'agg_avdClvl') + call wrtlvl(jlvl_agg_df(iogrp), LVL_agg_df(iogrp), rnacc, 0.,cmpflg,'agg_dflvl') + call wrtlvl(jlvl_agg_b(iogrp), LVL_agg_b(iogrp), rnacc, 0.,cmpflg,'agg_blvl') + call wrtlvl(jlvl_agg_Vrhof(iogrp), LVL_agg_Vrhof(iogrp), rnacc, 0.,cmpflg,'agg_Vrhoflvl') + call wrtlvl(jlvl_agg_Vpor(iogrp), LVL_agg_Vpor(iogrp), rnacc, 0.,cmpflg,'agg_Vporlvl') + + ! --- Store sediment fields +#ifndef sedbypass + call wrtsdm(jpowaic(iogrp), SDM_POWAIC(iogrp), rnacc*1e3, 0.,cmpflg,'powdic') + call wrtsdm(jpowaal(iogrp), SDM_POWAAL(iogrp), rnacc*1e3, 0.,cmpflg,'powalk') + call wrtsdm(jpowaph(iogrp), SDM_POWAPH(iogrp), rnacc*1e3, 0.,cmpflg,'powpho') + call wrtsdm(jpowaox(iogrp), SDM_POWAOX(iogrp), rnacc*1e3, 0.,cmpflg,'powox') + call wrtsdm(jpown2(iogrp), SDM_POWN2(iogrp), rnacc*1e3, 0.,cmpflg,'pown2') + call wrtsdm(jpowno3(iogrp), SDM_POWNO3(iogrp), rnacc*1e3, 0.,cmpflg,'powno3') + call wrtsdm(jpowasi(iogrp), SDM_POWASI(iogrp), rnacc*1e3, 0.,cmpflg,'powsi') + call wrtsdm(jssso12(iogrp), SDM_SSSO12(iogrp), rnacc*1e3, 0.,cmpflg,'ssso12') + call wrtsdm(jssssil(iogrp), SDM_SSSSIL(iogrp), rnacc*1e3, 0.,cmpflg,'ssssil') + call wrtsdm(jsssc12(iogrp), SDM_SSSC12(iogrp), rnacc*1e3, 0.,cmpflg,'sssc12') + call wrtsdm(jssster(iogrp), SDM_SSSTER(iogrp), rnacc, 0.,cmpflg,'ssster') + + ! --- Store sediment burial fields + call wrtbur(jburssso12(iogrp), BUR_SSSO12(iogrp), rnacc*1e3, 0.,cmpflg,'buro12') + call wrtbur(jbursssc12(iogrp), BUR_SSSC12(iogrp), rnacc*1e3, 0.,cmpflg,'burc12') + call wrtbur(jburssssil(iogrp), BUR_SSSSIL(iogrp), rnacc*1e3, 0.,cmpflg,'bursil') + call wrtbur(jburssster(iogrp), BUR_SSSTER(iogrp), rnacc, 0.,cmpflg,'burter') +#endif +#if defined(extNcycle) && ! defined(sedbypass) + call wrtsdm(jpownh4(iogrp), SDM_POWNH4(iogrp), rnacc*1e3, 0.,cmpflg,'pownh4') + call wrtsdm(jpown2o(iogrp), SDM_POWN2O(iogrp), rnacc*1e3, 0.,cmpflg,'pown2o') + call wrtsdm(jpowno2(iogrp), SDM_POWNO2(iogrp), rnacc*1e3, 0.,cmpflg,'powno2') + call wrtsdm(jsdm_nitr_NH4(iogrp), sdm_nitr_NH4(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'nh4nitrsdm') + call wrtsdm(jsdm_nitr_NO2(iogrp), sdm_nitr_NO2(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'no2nitrsdm') + call wrtsdm(jsdm_nitr_N2O_prod(iogrp),sdm_nitr_N2O_prod(iogrp),rnacc*1e3/dtbgc,0.,cmpflg,'nitr_n2osdm') + call wrtsdm(jsdm_nitr_NH4_OM(iogrp), sdm_nitr_NH4_OM(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'nh4nitr_omsdm') + call wrtsdm(jsdm_nitr_NO2_OM(iogrp), sdm_nitr_NO2_OM(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'no2nitr_omsdm') + call wrtsdm(jsdm_denit_NO3(iogrp), sdm_denit_NO3(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'no3denitsdm') + call wrtsdm(jsdm_denit_NO2(iogrp), sdm_denit_NO2(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'no2denitsdm') + call wrtsdm(jsdm_denit_N2O(iogrp), sdm_denit_N2O(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'n2odenitsdm') + call wrtsdm(jsdm_DNRA_NO2(iogrp), sdm_DNRA_NO2(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'no2dnrasdm') + call wrtsdm(jsdm_anmx_N2_prod(iogrp), sdm_anmx_N2_prod(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'anmx_n2sdm') + call wrtsdm(jsdm_anmx_OM_prod(iogrp), sdm_anmx_OM_prod(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'anmx_omsdm') + call wrtsdm(jsdm_remin_aerob(iogrp), sdm_remin_aerob(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'reminasdm') + call wrtsdm(jsdm_remin_sulf(iogrp), sdm_remin_sulf(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'reminssdm') +#endif + + ! --- close netcdf file + call ncfcls + + ! --- Initialise fields + call inisrf(jkwco2(iogrp),0.) + call inisrf(jkwco2khm(iogrp),0.) + call inisrf(jco2kh(iogrp),0.) + call inisrf(jco2khm(iogrp),0.) + call inisrf(jpco2(iogrp),0.) + call inisrf(jpco2m(iogrp),0.) + call inisrf(jdmsflux(iogrp),0.) + call inisrf(jco2fxd(iogrp),0.) + call inisrf(jco2fxu(iogrp),0.) + call inisrf(joxflux(iogrp),0.) + call inisrf(jniflux(iogrp),0.) + call inisrf(jn2ofx(iogrp),0.) + call inisrf(jsrfpn2om(iogrp),0.) + call inisrf(jdms(iogrp),0.) + call inisrf(jdmsprod(iogrp),0.) + call inisrf(jdms_bac(iogrp),0.) + call inisrf(jdms_uv(iogrp),0.) + call inisrf(jexport(iogrp),0.) + call inisrf(jexposi(iogrp),0.) + call inisrf(jexpoca(iogrp),0.) + call inisrf(jsrfdic(iogrp),0.) + call inisrf(jsrfalkali(iogrp),0.) + call inisrf(jsrfphosph(iogrp),0.) + call inisrf(jsrfoxygen(iogrp),0.) + call inisrf(jsrfano3(iogrp),0.) + call inisrf(jsrfsilica(iogrp),0.) + call inisrf(jsrfiron(iogrp),0.) + call inisrf(jsrfphyto(iogrp),0.) + call inisrf(jsrfph(iogrp),0.) + call inisrf(jintphosy(iogrp),0.) + call inisrf(jintnfix(iogrp),0.) + call inisrf(jintdnit(iogrp),0.) + call inisrf(jcarflx0100(iogrp),0.) + call inisrf(jcarflx0500(iogrp),0.) + call inisrf(jcarflx1000(iogrp),0.) + call inisrf(jcarflx2000(iogrp),0.) + call inisrf(jcarflx4000(iogrp),0.) + call inisrf(jcarflx_bot(iogrp),0.) + call inisrf(jbsiflx0100(iogrp),0.) + call inisrf(jbsiflx0500(iogrp),0.) + call inisrf(jbsiflx1000(iogrp),0.) + call inisrf(jbsiflx2000(iogrp),0.) + call inisrf(jbsiflx4000(iogrp),0.) + call inisrf(jbsiflx_bot(iogrp),0.) + call inisrf(jcalflx0100(iogrp),0.) + call inisrf(jcalflx0500(iogrp),0.) + call inisrf(jcalflx1000(iogrp),0.) + call inisrf(jcalflx2000(iogrp),0.) + call inisrf(jcalflx4000(iogrp),0.) + call inisrf(jcalflx_bot(iogrp),0.) +#ifndef sedbypass + call inisrf(jsediffic(iogrp),0.) + call inisrf(jsediffal(iogrp),0.) + call inisrf(jsediffph(iogrp),0.) + call inisrf(jsediffox(iogrp),0.) + call inisrf(jsediffn2(iogrp),0.) + call inisrf(jsediffno3(iogrp),0.) + call inisrf(jsediffsi(iogrp),0.) + call inisrf(jburflxsso12(iogrp),0.) + call inisrf(jburflxsssc12(iogrp),0.) + call inisrf(jburflxssssil(iogrp),0.) + call inisrf(jburflxssster(iogrp),0.) +#endif +#ifdef cisonew + call inisrf(jco213fxd(iogrp),0.) + call inisrf(jco213fxu(iogrp),0.) + call inisrf(jco214fxd(iogrp),0.) + call inisrf(jco214fxu(iogrp),0.) +#endif +#ifdef CFC + call inisrf(jcfc11fx(iogrp),0.) + call inisrf(jcfc12fx(iogrp),0.) + call inisrf(jsf6fx(iogrp),0.) +#endif +#ifdef natDIC + call inisrf(jsrfnatdic(iogrp),0.) + call inisrf(jsrfnatalk(iogrp),0.) + call inisrf(jnatpco2(iogrp),0.) + call inisrf(jnatco2fx(iogrp),0.) + call inisrf(jsrfnatph(iogrp),0.) +#endif +#ifdef BROMO + call inisrf(jsrfbromo(iogrp),0.) + call inisrf(jbromofx(iogrp),0.) + call inisrf(jbromo_prod(iogrp),0.) + call inisrf(jbromo_uv(iogrp),0.) + call inisrf(jatmbromo(iogrp),0.) +#endif + + + call inisrf(jatmco2(iogrp),0.) +#if defined(BOXATM) + call inisrf(jatmo2(iogrp),0.) + call inisrf(jatmn2(iogrp),0.) +#endif +#ifdef cisonew + call inisrf(jatmc13(iogrp),0.) + call inisrf(jatmc14(iogrp),0.) +#endif +#ifdef extNcycle + call inisrf(jsrfanh4(iogrp),0.) + call inisrf(jsrfpnh3(iogrp),0.) + call inisrf(jsrfano2(iogrp),0.) + call inisrf(janh3fx(iogrp),0.) +#endif +#if defined(extNcycle) && ! defined(sedbypass) + call inisrf(jsediffnh4(iogrp),0.) + call inisrf(jsediffn2o(iogrp),0.) + call inisrf(jsediffno2(iogrp),0.) +#endif + call inilyr(jdp(iogrp),0.) + call inilyr(jdic(iogrp),0.) + call inilyr(jalkali(iogrp),0.) + call inilyr(jphosy(iogrp),0.) + call inilyr(jphosph(iogrp),0.) + call inilyr(joxygen(iogrp),0.) + call inilyr(jano3(iogrp),0.) + call inilyr(jsilica(iogrp),0.) + call inilyr(jdoc(iogrp),0.) + call inilyr(jphyto(iogrp),0.) + call inilyr(jgrazer(iogrp),0.) + call inilyr(jpoc(iogrp),0.) + call inilyr(jcalc(iogrp),0.) + call inilyr(jopal(iogrp),0.) + call inilyr(jiron(iogrp),0.) + call inilyr(jco3(iogrp),0.) + call inilyr(jph(iogrp),0.) + call inilyr(jomegaa(iogrp),0.) + call inilyr(jomegac(iogrp),0.) + call inilyr(jn2o(iogrp),0.) + call inilyr(jprefo2(iogrp),0.) + call inilyr(jo2sat(iogrp),0.) + call inilyr(jprefpo4(iogrp),0.) + call inilyr(jprefalk(iogrp),0.) + call inilyr(jprefdic(iogrp),0.) + call inilyr(jdicsat(iogrp),0.) +#ifdef cisonew + call inilyr(jdic13(iogrp),0.) + call inilyr(jdic14(iogrp),0.) + call inilyr(jd13c(iogrp),0.) + call inilyr(jd14c(iogrp),0.) + call inilyr(jbigd14c(iogrp),0.) + call inilyr(jpoc13(iogrp),0.) + call inilyr(jdoc13(iogrp),0.) + call inilyr(jcalc13(iogrp),0.) + call inilyr(jphyto13(iogrp),0.) + call inilyr(jgrazer13(iogrp),0.) +#endif +#ifdef AGG + call inilyr(jnos(iogrp),0.) + call inilyr(jwphy(iogrp),0.) + call inilyr(jwnos(iogrp),0.) + call inilyr(jeps(iogrp),0.) + call inilyr(jasize(iogrp),0.) +#endif +#ifdef CFC + call inilyr(jcfc11(iogrp),0.) + call inilyr(jcfc12(iogrp),0.) + call inilyr(jsf6(iogrp),0.) +#endif +#ifdef natDIC + call inilyr(jnatco3(iogrp),0.) + call inilyr(jnatalkali(iogrp),0.) + call inilyr(jnatdic(iogrp),0.) + call inilyr(jnatcalc(iogrp),0.) + call inilyr(jnatph(iogrp),0.) + call inilyr(jnatomegaa(iogrp),0.) + call inilyr(jnatomegac(iogrp),0.) +#endif +#ifdef BROMO + call inilyr(jbromo(iogrp),0.) +#endif +#ifdef extNcycle + call inilyr(janh4(iogrp),0.) + call inilyr(jano2(iogrp),0.) + call inilyr(jnitr_NH4(iogrp),0.) + call inilyr(jnitr_NO2(iogrp),0.) + call inilyr(jnitr_N2O_prod(iogrp),0.) + call inilyr(jnitr_NH4_OM(iogrp),0.) + call inilyr(jnitr_NO2_OM(iogrp),0.) + call inilyr(jdenit_NO3(iogrp),0.) + call inilyr(jdenit_NO2(iogrp),0.) + call inilyr(jdenit_N2O(iogrp),0.) + call inilyr(jDNRA_NO2(iogrp),0.) + call inilyr(janmx_N2_prod(iogrp),0.) + call inilyr(janmx_OM_prod(iogrp),0.) + call inilyr(jphosy_NH4(iogrp),0.) + call inilyr(jphosy_NO3(iogrp),0.) + call inilyr(jremin_aerob(iogrp),0.) + call inilyr(jremin_sulf(iogrp),0.) +#endif + ! M4AGO + call inilyr(jagg_ws(iogrp),0.) + call inilyr(jdynvis(iogrp),0.) + call inilyr(jagg_stick(iogrp),0.) + call inilyr(jagg_stickf(iogrp),0.) + call inilyr(jagg_dmax(iogrp),0.) + call inilyr(jagg_avdp(iogrp),0.) + call inilyr(jagg_avrhop(iogrp),0.) + call inilyr(jagg_avdC(iogrp),0.) + call inilyr(jagg_df(iogrp),0.) + call inilyr(jagg_b(iogrp),0.) + call inilyr(jagg_Vrhof(iogrp),0.) + call inilyr(jagg_Vpor(iogrp),0.) + + call inilvl(jlvldic(iogrp),0.) + call inilvl(jlvlalkali(iogrp),0.) + call inilvl(jlvlphosy(iogrp),0.) + call inilvl(jlvlphosph(iogrp),0.) + call inilvl(jlvloxygen(iogrp),0.) + call inilvl(jlvlano3(iogrp),0.) + call inilvl(jlvlsilica(iogrp),0.) + call inilvl(jlvldoc(iogrp),0.) + call inilvl(jlvlphyto(iogrp),0.) + call inilvl(jlvlgrazer(iogrp),0.) + call inilvl(jlvlpoc(iogrp),0.) + call inilvl(jlvlcalc(iogrp),0.) + call inilvl(jlvlopal(iogrp),0.) + call inilvl(jlvliron(iogrp),0.) + call inilvl(jlvlco3(iogrp),0.) + call inilvl(jlvlph(iogrp),0.) + call inilvl(jlvlomegaa(iogrp),0.) + call inilvl(jlvlomegac(iogrp),0.) + call inilvl(jlvln2o(iogrp),0.) + call inilvl(jlvlprefo2(iogrp),0.) + call inilvl(jlvlo2sat(iogrp),0.) + call inilvl(jlvlprefpo4(iogrp),0.) + call inilvl(jlvlprefalk(iogrp),0.) + call inilvl(jlvlprefdic(iogrp),0.) + call inilvl(jlvldicsat(iogrp),0.) +#ifdef cisonew + call inilvl(jlvldic13(iogrp),0.) + call inilvl(jlvldic14(iogrp),0.) + call inilvl(jlvld13c(iogrp),0.) + call inilvl(jlvld14c(iogrp),0.) + call inilvl(jlvlbigd14c(iogrp),0.) + call inilvl(jlvlpoc13(iogrp),0.) + call inilvl(jlvldoc13(iogrp),0.) + call inilvl(jlvlcalc13(iogrp),0.) + call inilvl(jlvlphyto13(iogrp),0.) + call inilvl(jlvlgrazer13(iogrp),0.) +#endif +#ifdef AGG + call inilvl(jlvlnos(iogrp),0.) + call inilvl(jlvlwphy(iogrp),0.) + call inilvl(jlvlwnos(iogrp),0.) + call inilvl(jlvleps(iogrp),0.) + call inilvl(jlvlasize(iogrp),0.) +#endif +#ifdef CFC + call inilvl(jlvlcfc11(iogrp),0.) + call inilvl(jlvlcfc12(iogrp),0.) + call inilvl(jlvlsf6(iogrp),0.) +#endif +#ifdef natDIC + call inilvl(jlvlnatco3(iogrp),0.) + call inilvl(jlvlnatalkali(iogrp),0.) + call inilvl(jlvlnatdic(iogrp),0.) + call inilvl(jlvlnatcalc(iogrp),0.) + call inilvl(jlvlnatph(iogrp),0.) + call inilvl(jlvlnatomegaa(iogrp),0.) + call inilvl(jlvlnatomegac(iogrp),0.) +#endif +#ifdef BROMO + call inilvl(jlvlbromo(iogrp),0.) +#endif +#ifdef extNcycle + call inilvl(jlvlanh4(iogrp),0.) + call inilvl(jlvlano2(iogrp),0.) + call inilvl(jlvl_nitr_NH4(iogrp),0.) + call inilvl(jlvl_nitr_NO2(iogrp),0.) + call inilvl(jlvl_nitr_N2O_prod(iogrp),0.) + call inilvl(jlvl_nitr_NH4_OM(iogrp),0.) + call inilvl(jlvl_nitr_NO2_OM(iogrp),0.) + call inilvl(jlvl_denit_NO3(iogrp),0.) + call inilvl(jlvl_denit_NO2(iogrp),0.) + call inilvl(jlvl_denit_N2O(iogrp),0.) + call inilvl(jlvl_DNRA_NO2(iogrp),0.) + call inilvl(jlvl_anmx_N2_prod(iogrp),0.) + call inilvl(jlvl_anmx_OM_prod(iogrp),0.) + call inilvl(jlvl_phosy_NH4(iogrp),0.) + call inilvl(jlvl_phosy_NO3(iogrp),0.) + call inilvl(jlvl_remin_aerob(iogrp),0.) + call inilvl(jlvl_remin_sulf(iogrp),0.) +#endif + ! M4AGO + call inilvl(jlvl_agg_ws(iogrp),0.) + call inilvl(jlvl_dynvis(iogrp),0.) + call inilvl(jlvl_agg_stick(iogrp),0.) + call inilvl(jlvl_agg_stickf(iogrp),0.) + call inilvl(jlvl_agg_dmax(iogrp),0.) + call inilvl(jlvl_agg_avdp(iogrp),0.) + call inilvl(jlvl_agg_avrhop(iogrp),0.) + call inilvl(jlvl_agg_avdC(iogrp),0.) + call inilvl(jlvl_agg_df(iogrp),0.) + call inilvl(jlvl_agg_b(iogrp),0.) + call inilvl(jlvl_agg_Vrhof(iogrp),0.) + call inilvl(jlvl_agg_Vpor(iogrp),0.) + +#ifndef sedbypass + call inisdm(jpowaic(iogrp),0.) + call inisdm(jpowaal(iogrp),0.) + call inisdm(jpowaph(iogrp),0.) + call inisdm(jpowaox(iogrp),0.) + call inisdm(jpown2(iogrp),0.) + call inisdm(jpowno3(iogrp),0.) + call inisdm(jpowasi(iogrp),0.) + call inisdm(jssso12(iogrp),0.) + call inisdm(jssssil(iogrp),0.) + call inisdm(jsssc12(iogrp),0.) + call inisdm(jssster(iogrp),0.) + + call inibur(jburssso12(iogrp),0.) + call inibur(jbursssc12(iogrp),0.) + call inibur(jburssssil(iogrp),0.) + call inibur(jburssster(iogrp),0.) +#endif +#if defined(extNcycle) && ! defined(sedbypass) + call inisdm(jpownh4(iogrp),0.) + call inisdm(jpown2o(iogrp),0.) + call inisdm(jpowno2(iogrp),0.) + call inisdm(jsdm_nitr_NH4(iogrp),0.) + call inisdm(jsdm_nitr_NO2(iogrp),0.) + call inisdm(jsdm_nitr_N2O_prod(iogrp),0.) + call inisdm(jsdm_nitr_NH4_OM(iogrp),0.) + call inisdm(jsdm_nitr_NO2_OM(iogrp),0.) + call inisdm(jsdm_denit_NO3(iogrp),0.) + call inisdm(jsdm_denit_NO2(iogrp),0.) + call inisdm(jsdm_denit_N2O(iogrp),0.) + call inisdm(jsdm_DNRA_NO2(iogrp),0.) + call inisdm(jsdm_anmx_N2_prod(iogrp),0.) + call inisdm(jsdm_anmx_OM_prod(iogrp),0.) + call inisdm(jsdm_remin_aerob(iogrp),0.) + call inisdm(jsdm_remin_sulf(iogrp),0.) +#endif + + nacc_bgc(iogrp)=0 + +end subroutine ncwrt_bgc + + +subroutine hamoccvardef(iogrp,timeunits,calendar,cmpflg) + use mod_nctools, only:ncdefvar,ncattr,ncfopn,ncdimc,ncdims, & + & nctime,ncfcls,ncedef,ncdefvar3d,ndouble + + use mo_bgcmean, only: srf_kwco2,srf_pco2,srf_dmsflux,srf_co2fxd, & + & srf_kwco2khm,srf_co2kh,srf_co2khm,srf_pco2m, & + & srf_co2fxu,srf_oxflux,srf_niflux,srf_pn2om,srf_dms,srf_dmsprod, & + & srf_dms_bac,srf_dms_uv,srf_export,srf_exposi,srf_expoca, & + & srf_dic,srf_alkali,srf_phosph,srf_oxygen,srf_ano3,srf_silica, & + & srf_iron,srf_phyto,srf_ph,int_phosy,int_nfix,int_dnit,flx_car0100, & + & flx_car0500,flx_car1000,flx_car2000,flx_car4000,flx_car_bot, & + & flx_bsi0100,flx_bsi0500,flx_bsi1000,flx_bsi2000,flx_bsi4000, & + & flx_bsi_bot,flx_cal0100,flx_cal0500,flx_cal1000,flx_cal2000, & + & flx_cal4000,flx_cal_bot,flx_sediffic,flx_sediffal, & + & flx_sediffph,flx_sediffox,flx_sediffn2,flx_sediffno3, & + & flx_sediffsi,flx_bursso12,flx_bursssc12,flx_burssssil,flx_burssster, & + & srf_n2ofx,srf_atmco2,lyr_dp,lyr_dic, & + & lyr_alkali,lyr_phosph,lyr_oxygen,lyr_ano3,lyr_silica,lyr_doc, & + & lyr_phyto,lyr_grazer,lyr_poc,lyr_calc,lyr_opal,lyr_iron, & + & lyr_phosy,lyr_co3,lyr_ph,lyr_omegaa,lyr_omegac,lyr_n2o, & + & lyr_prefo2,lyr_o2sat,lyr_prefpo4,lyr_prefalk,lyr_prefdic, & + & lyr_dicsat,lvl_dic,lvl_alkali,lvl_phosph,lvl_oxygen,lvl_ano3, & + & lvl_silica,lvl_doc,lvl_phyto,lvl_grazer,lvl_poc,lvl_calc, & + & lvl_opal,lvl_iron,lvl_phosy,lvl_co3,lvl_ph,lvl_omegaa, & + & lvl_omegac,lvl_n2o,lvl_prefo2,lvl_o2sat,lvl_prefpo4, & + & lvl_prefalk,lvl_prefdic,lvl_dicsat, & + & lyr_agg_ws,lyr_dynvis,lyr_agg_stick, & + & lyr_agg_stickf,lyr_agg_dmax,lyr_agg_avdp, & + & lyr_agg_avrhop,lyr_agg_avdC,lyr_agg_df, & + & lyr_agg_b,lyr_agg_Vrhof,lyr_agg_Vpor, & + & lvl_agg_ws,lvl_dynvis,lvl_agg_stick, & + & lvl_agg_stickf,lvl_agg_dmax,lvl_agg_avdp, & + & lvl_agg_avrhop,lvl_agg_avdC,lvl_agg_df, & + & lvl_agg_b,lvl_agg_Vrhof,lvl_agg_Vpor +#ifdef AGG + use mo_bgcmean, only: lyr_nos,lyr_wphy,lyr_wnos,lyr_eps, & + & lyr_asize,lvl_nos,lvl_wphy,lvl_wnos,lvl_eps,lvl_asize +#endif +#if defined(BOXATM) + use mo_bgcmean, only: srf_atmo2,srf_atmn2 +#endif + +#ifdef BROMO + use mo_bgcmean, only:srf_bromo,srf_bromofx,int_bromopro, & + & int_bromouv,srf_atmbromo,lyr_bromo,lvl_bromo +#endif +#ifdef CFC + use mo_bgcmean, only: srf_cfc11,srf_cfc12,srf_sf6,lyr_cfc11, & + & lyr_cfc12,lyr_sf6,lvl_cfc11,lvl_cfc12,lvl_sf6 +#endif +#ifdef cisonew + use mo_bgcmean, only: srf_co213fxd,srf_co213fxu,srf_co214fxd, & + & srf_co214fxu,srf_atmc13,srf_atmc14,lyr_dic13,lyr_dic14, & + & lyr_d13c,lyr_d14c,lyr_bigd14c,lyr_poc13,lyr_doc13, & + & lyr_calc13,lyr_phyto13,lyr_grazer13,lvl_dic13,lvl_dic14, & + & lvl_d13c,lvl_d14c,lvl_bigd14c,lvl_poc13,lvl_doc13, & + & lvl_calc13,lvl_phyto13,lvl_grazer13 +#endif +#ifdef natDIC + use mo_bgcmean, only: srf_natdic,srf_natalkali,srf_natpco2, & + & srf_natco2fx,srf_natph,lyr_natco3,lyr_natalkali,lyr_natdic, & + & lyr_natcalc,lyr_natph,lyr_natomegaa,lyr_natomegac, & + & lvl_natalkali,lvl_natdic,lvl_natcalc,lvl_natph, & + & lvl_natomegaa,lvl_natomegac,lvl_natco3 +#endif +#ifndef sedbypass + use mo_bgcmean, only: sdm_powaic,sdm_powaal,sdm_powaph,sdm_powaox, & + & sdm_pown2,sdm_powno3,sdm_powasi,sdm_ssso12,sdm_ssssil, & + & sdm_sssc12,sdm_ssster,bur_ssso12,bur_sssc12,bur_ssssil, & + & bur_ssster +#endif +#ifdef extNcycle + use mo_bgcmean, only: janh4,jano2,jlvlanh4,jlvlano2,jsrfanh4, & + & jsrfano2,janh3fx,srf_pnh3,srf_anh4,srf_ano2, & + & srf_anh3fx,lyr_anh4,lyr_ano2,lvl_anh4, & + & lvl_ano2, & + & LYR_nitr_NH4,LYR_nitr_NO2,LYR_nitr_N2O_prod, & + & LYR_nitr_NH4_OM,LYR_nitr_NO2_OM, & + & LYR_denit_NO3,LYR_denit_NO2,LYR_denit_N2O, & + & LYR_DNRA_NO2,LYR_anmx_N2_prod, & + & LYR_anmx_OM_prod,LYR_phosy_NH4, & + & LYR_phosy_NO3,LYR_remin_aerob,LYR_remin_sulf, & + & LVL_nitr_NH4,LVL_nitr_NO2,LVL_nitr_N2O_prod, & + & LVL_nitr_NH4_OM,LVL_nitr_NO2_OM, & + & LVL_denit_NO3,LVL_denit_NO2,LVL_denit_N2O, & + & LVL_DNRA_NO2,LVL_anmx_N2_prod, & + & LVL_anmx_OM_prod,LVL_phosy_NH4, & + & LVL_phosy_NO3,LVL_remin_aerob,LVL_remin_sulf, & + & jnitr_NH4,jnitr_NO2,jnitr_N2O_prod, & + & jnitr_NH4_OM,jnitr_NO2_OM,jdenit_NO3, & + & jdenit_NO2,jdenit_N2O,jDNRA_NO2, & + & janmx_N2_prod,janmx_OM_prod,jphosy_NH4, & + & jphosy_NO3,jremin_aerob,jremin_sulf, & + & jlvl_nitr_NH4,jlvl_nitr_NO2, & + & jlvl_nitr_N2O_prod,jlvl_nitr_NH4_OM, & + & jlvl_nitr_NO2_OM,jlvl_denit_NO3, & + & jlvl_denit_NO2,jlvl_denit_N2O,jlvl_DNRA_NO2, & + & jlvl_anmx_N2_prod,jlvl_anmx_OM_prod, & + & jlvl_phosy_NH4,jlvl_phosy_NO3, & + & jlvl_remin_aerob,jlvl_remin_sulf +#endif +#if defined(extNcycle) && ! defined(sedbypass) + use mo_bgcmean, only: jpownh4,jpown2o,jpowno2,jsdm_nitr_NH4,jsdm_nitr_NO2, & + & jsdm_nitr_N2O_prod,jsdm_nitr_NH4_OM,jsdm_nitr_NO2_OM, & + & jsdm_denit_NO3,jsdm_denit_NO2,jsdm_denit_N2O, & + & jsdm_DNRA_NO2,jsdm_anmx_N2_prod,jsdm_anmx_OM_prod, & + & jsdm_remin_aerob,jsdm_remin_sulf, SDM_POWNH4,SDM_POWN2O,& + & SDM_POWNO2,SDM_nitr_NH4,SDM_nitr_NO2,SDM_nitr_N2O_prod, & + & SDM_nitr_NH4_OM,SDM_nitr_NO2_OM,SDM_denit_NO3, & + & SDM_denit_NO2,SDM_denit_N2O,SDM_DNRA_NO2, & + & SDM_anmx_N2_prod,SDM_anmx_OM_prod,SDM_remin_aerob, & + & SDM_remin_sulf,jsediffnh4,jsediffn2o,jsediffno2, & + & FLX_SEDIFFNH4,FLX_SEDIFFN2O,FLX_SEDIFFNO2 +#endif + + + + implicit none + + integer iogrp,cmpflg + character timeunits*30,calendar*19 + call ncdefvar('time','time',ndouble,0) + call ncattr('long_name','time') + call ncattr('units',timeunits) + call ncattr('calendar',calendar) + call ncdefvar('sigma','sigma',ndouble,8) + call ncattr('long_name','Potential density') + call ncattr('standard_name','sea_water_sigma_theta') + call ncattr('units','kg m-3') + call ncattr('positive','down') + call ncdefvar('depth','depth',ndouble,8) + call ncattr('long_name','z level') + call ncattr('units','m') + call ncattr('positive','down') + call ncattr('bounds','depth_bnds') + call ncdefvar('depth_bnds','bounds depth',ndouble,8) + call ncdefvar3d(SRF_KWCO2(iogrp),cmpflg,'p', & + & 'kwco2','CO2 piston velocity',' ','m s-1',0) + call ncdefvar3d(SRF_KWCO2KHM(iogrp),cmpflg,'p', & + & 'kwco2khm','CO2 piston velocity times solubility (moist air)',' ', & + & 'm s-1 mol kg-1 muatm-1',0) + call ncdefvar3d(SRF_CO2KH(iogrp),cmpflg,'p', & + & 'co2kh','CO2 solubility (dry air)',' ','mol kg-1 atm-1',0) + call ncdefvar3d(SRF_CO2KHM(iogrp),cmpflg,'p', & + & 'co2khm','CO2 solubility (moist air)',' ','mol kg-1 atm-1',0) + call ncdefvar3d(SRF_PCO2(iogrp),cmpflg,'p', & + & 'pco2','Surface PCO2',' ','uatm',0) + call ncdefvar3d(SRF_PCO2M(iogrp),cmpflg,'p', & + & 'pco2m','Surface PCO2 (moist air)',' ','uatm',0) + call ncdefvar3d(SRF_DMSFLUX(iogrp), & + & cmpflg,'p','dmsflux','DMS flux',' ','mol DMS m-2 s-1',0) + call ncdefvar3d(SRF_CO2FXD(iogrp), & + & cmpflg,'p','co2fxd','Downward CO2 flux',' ','kg C m-2 s-1',0) + call ncdefvar3d(SRF_CO2FXU(iogrp), & + & cmpflg,'p','co2fxu','Upward CO2 flux',' ','kg C m-2 s-1',0) + call ncdefvar3d(SRF_OXFLUX(iogrp), & + & cmpflg,'p','fgo2','Oxygen flux',' ','mol O2 m-2 s-1',0) + call ncdefvar3d(SRF_PN2OM(iogrp),cmpflg,'p', & + & 'pn2om','Surface pN2O moist air',' ','natm',0) + call ncdefvar3d(SRF_NIFLUX(iogrp), & + & cmpflg,'p','fgn2','Nitrogen flux',' ','mol N2 m-2 s-1',0) + call ncdefvar3d(SRF_DMS(iogrp),cmpflg,'p', & + & 'dms','DMS',' ','kmol DMS m-3',0) + call ncdefvar3d(SRF_DMSPROD(iogrp),cmpflg,'p', & + & 'dmsprod','DMS production from phytoplankton production',' ', & + & 'mol DMS m-2 s-1',0) + call ncdefvar3d(SRF_DMS_BAC(iogrp),cmpflg,'p', & + & 'dms_bac','DMS bacterial consumption',' ','mol DMS m-2 s-1',0) + call ncdefvar3d(SRF_DMS_UV(iogrp),cmpflg,'p', & + & 'dms_uv','DMS photolysis reduction',' ','mol DMS m-2 s-1',0) + call ncdefvar3d(SRF_EXPORT(iogrp), & + & cmpflg,'p','epc100','Export production',' ','mol C m-2 s-1',0) + call ncdefvar3d(SRF_EXPOSI(iogrp),cmpflg,'p', & + & 'epsi100','Si export production',' ','mol Si m-2 s-1',0) + call ncdefvar3d(SRF_EXPOCA(iogrp),cmpflg,'p', & + & 'epcalc100','Ca export production',' ','mol Ca m-2 s-1',0) + call ncdefvar3d(SRF_DIC(iogrp),cmpflg,'p','srfdissic', & + & 'Surface dissolved inorganic carbon',' ','mol C m-3',0) + call ncdefvar3d(SRF_ALKALI(iogrp),cmpflg,'p','srftalk', & + & 'Surface alkalinity',' ','eq m-3',0) + call ncdefvar3d(SRF_PHOSPH(iogrp),cmpflg,'p','srfpo4', & + & 'Surface phosphorus',' ','mol P m-3',0) + call ncdefvar3d(SRF_OXYGEN(iogrp),cmpflg,'p','srfo2', & + & 'Surface oxygen',' ','mol O2 m-3',0) + call ncdefvar3d(SRF_ANO3(iogrp),cmpflg,'p','srfno3', & + & 'Surface nitrate',' ','mol N m-3',0) + call ncdefvar3d(SRF_SILICA(iogrp),cmpflg,'p','srfsi', & + & 'Surface silicate',' ','mol Si m-3',0) + call ncdefvar3d(SRF_IRON(iogrp),cmpflg,'p','srfdfe', & + & 'Surface dissolved iron',' ','mol Fe m-3',0) + call ncdefvar3d(SRF_PHYTO(iogrp),cmpflg,'p','srfphyc', & + & 'Surface phytoplankton',' ','mol P m-3',0) + call ncdefvar3d(SRF_PH(iogrp),cmpflg,'p','srfph', & + & 'Surface pH',' ','-log10([H+])',0) + call ncdefvar3d(INT_PHOSY(iogrp),cmpflg,'p','ppint', & + & 'Integrated primary production',' ','mol C m-2 s-1',0) + call ncdefvar3d(INT_NFIX(iogrp),cmpflg,'p','nfixint', & + & 'Integrated nitrogen fixation',' ','mol N m-2 s-1',0) + call ncdefvar3d(INT_DNIT(iogrp),cmpflg,'p','dnitint', & + & 'Integrated denitrification',' ','mol N m-2 s-1',0) + call ncdefvar3d(FLX_CAR0100(iogrp),cmpflg,'p','carflx0100', & + & 'C flux at 100m',' ','mol C m-2 s-1',0) + call ncdefvar3d(FLX_CAR0500(iogrp),cmpflg,'p','carflx0500', & + & 'C flux at 500m',' ','mol C m-2 s-1',0) + call ncdefvar3d(FLX_CAR1000(iogrp),cmpflg,'p','carflx1000', & + & 'C flux at 1000m',' ','mol C m-2 s-1',0) + call ncdefvar3d(FLX_CAR2000(iogrp),cmpflg,'p','carflx2000', & + & 'C flux at 2000m',' ','mol C m-2 s-1',0) + call ncdefvar3d(FLX_CAR4000(iogrp),cmpflg,'p','carflx4000', & + & 'C flux at 4000m',' ','mol C m-2 s-1',0) + call ncdefvar3d(FLX_CAR_BOT(iogrp),cmpflg,'p','carflx_bot', & + & 'C flux to sediment',' ','mol C m-2 s-1',0) + call ncdefvar3d(FLX_BSI0100(iogrp),cmpflg,'p','bsiflx0100', & + & 'Opal flux at 100m',' ','mol Si m-2 s-1',0) + call ncdefvar3d(FLX_BSI0500(iogrp),cmpflg,'p','bsiflx0500', & + & 'Opal flux at 500m',' ','mol Si m-2 s-1',0) + call ncdefvar3d(FLX_BSI1000(iogrp),cmpflg,'p','bsiflx1000', & + & 'Opal flux at 1000m',' ','mol Si m-2 s-1',0) + call ncdefvar3d(FLX_BSI2000(iogrp),cmpflg,'p','bsiflx2000', & + & 'Opal flux at 2000m',' ','mol Si m-2 s-1',0) + call ncdefvar3d(FLX_BSI4000(iogrp),cmpflg,'p','bsiflx4000', & + & 'Opal flux at 4000m',' ','mol Si m-2 s-1',0) + call ncdefvar3d(FLX_BSI_BOT(iogrp),cmpflg,'p','bsiflx_bot', & + & 'Opal flux to sediment',' ','mol Si m-2 s-1',0) + call ncdefvar3d(FLX_CAL0100(iogrp),cmpflg,'p','calflx0100', & + & 'CaCO3 flux at 100m',' ','mol Ca m-2 s-1',0) + call ncdefvar3d(FLX_CAL0500(iogrp),cmpflg,'p','calflx0500', & + & 'CaCO3 flux at 500m',' ','mol Ca m-2 s-1',0) + call ncdefvar3d(FLX_CAL1000(iogrp),cmpflg,'p','calflx1000', & + & 'CaCO3 flux at 1000m',' ','mol Ca m-2 s-1',0) + call ncdefvar3d(FLX_CAL2000(iogrp),cmpflg,'p','calflx2000', & + & 'CaCO3 flux at 2000m',' ','mol Ca m-2 s-1',0) + call ncdefvar3d(FLX_CAL4000(iogrp),cmpflg,'p','calflx4000', & + & 'CaCO3 flux at 4000m',' ','mol Ca m-2 s-1',0) + call ncdefvar3d(FLX_CAL_BOT(iogrp),cmpflg,'p','calflx_bot', & + & 'CaCO3 flux to sediment',' ','mol Ca m-2 s-1',0) + call ncdefvar3d(SRF_N2OFX(iogrp),cmpflg,'p','n2oflux', & + & 'N2O flux',' ','mol N2O m-2 s-1',0) +#ifndef sedbypass + call ncdefvar3d(FLX_SEDIFFIC(iogrp),cmpflg,'p','sedfdic', & + & 'diffusive DIC flux to sediment (positive downwards)', & + & ' ','mol C m-2 s-1',0) + call ncdefvar3d(FLX_SEDIFFAL(iogrp),cmpflg,'p','sedfalk', & + & 'diffusive alkalinity flux to sediment (positive downwards)', & + & ' ','mol m-2 s-1',0) + call ncdefvar3d(FLX_SEDIFFPH(iogrp),cmpflg,'p','sedfpho', & + & 'diffusive phosphate flux to sediment (positive downwards)', & + & ' ','mol m-2 s-1',0) + call ncdefvar3d(FLX_SEDIFFOX(iogrp),cmpflg,'p','sedfox', & + & 'diffusive oxygen flux to sediment (positive downwards)', & + & ' ','mol O2 m-2 s-1',0) + call ncdefvar3d(FLX_SEDIFFN2(iogrp),cmpflg,'p','sedfn2', & + & 'diffusive N2 flux to sediment (positive downwards)', & + & ' ','mol N2 m-2 s-1',0) + call ncdefvar3d(FLX_SEDIFFNO3(iogrp),cmpflg,'p','sedfno3', & + & 'diffusive nitrate flux to sediment (positive downwards)', & + & ' ','mol NO3 m-2 s-1',0) + call ncdefvar3d(FLX_SEDIFFSI(iogrp),cmpflg,'p','sedfsi', & + & 'diffusive silica flux to sediment (positive downwards)', & + & ' ','mol Si m-2 s-1',0) + call ncdefvar3d(FLX_BURSSO12(iogrp),cmpflg,'p','burfsso12', & + & 'Organic matter burial flux to burial layer (positive downwards)', & + & ' ','mol P m-2 s-1',0) + call ncdefvar3d(FLX_BURSSSC12(iogrp),cmpflg,'p','burfsssc12', & + & 'CaCO3 burial flux to burial layer (positive downwards)', & + & ' ','mol Ca m-2 s-1',0) + call ncdefvar3d(FLX_BURSSSSIL(iogrp),cmpflg,'p','burfssssil', & + & 'Opal burial flux to burial layer (positive downwards)', & + & ' ','mol Si m-2 s-1',0) + call ncdefvar3d(FLX_BURSSSTER(iogrp),cmpflg,'p','burfssster', & + & 'Clay burial flux to burial layer (positive downwards)', & + & ' ','g m-2 s-1',0) +#endif +#if defined(extNcycle) && ! defined(sedbypass) + call ncdefvar3d(FLX_SEDIFFNH4(iogrp),cmpflg,'p','sedfnh4', & + & 'diffusive ammonium flux to sediment (positive downwards)', & + & ' ','mol NH4 m-2 s-1',0) + call ncdefvar3d(FLX_SEDIFFN2O(iogrp),cmpflg,'p','sedfn2o', & + & 'diffusive nitrous oxide flux to sediment (positive downwards)', & + & ' ','mol N2O m-2 s-1',0) + call ncdefvar3d(FLX_SEDIFFNO2(iogrp),cmpflg,'p','sedfno2', & + & 'diffusive nitrite flux to sediment (positive downwards)', & + & ' ','mol NO2 m-2 s-1',0) +#endif +#ifdef cisonew + call ncdefvar3d(SRF_CO213FXD(iogrp),cmpflg,'p','co213fxd', & + & 'Downward 13CO2 flux',' ','kg C m-2 s-1',0) + call ncdefvar3d(SRF_CO213FXU(iogrp),cmpflg,'p','co213fxu', & + & 'Upward 13CO2 flux',' ','kg C m-2 s-1',0) + call ncdefvar3d(SRF_CO214FXD(iogrp),cmpflg,'p','co214fxd', & + & 'Downward 14CO2 flux',' ','kg C m-2 s-1',0) + call ncdefvar3d(SRF_CO214FXU(iogrp),cmpflg,'p','co214fxu', & + & 'Upward 14CO2 flux',' ','kg C m-2 s-1',0) +#endif +#ifdef CFC + call ncdefvar3d(SRF_CFC11(iogrp),cmpflg,'p','cfc11flux', & + & 'CFC-11 flux',' ','mol CFC12 m-2 s-1',0) + call ncdefvar3d(SRF_CFC12(iogrp), & + & cmpflg,'p','cfc12flux','CFC-12 flux',' ','mol CFC12 m-2 s-1',0) + call ncdefvar3d(SRF_SF6(iogrp), & + & cmpflg,'p','sf6flux','SF-6 flux',' ','mol SF6 m-2 s-1',0) +#endif +#ifdef natDIC + call ncdefvar3d(SRF_NATDIC(iogrp),cmpflg,'p','srfnatdissic', & + & 'Surface natural dissolved inorganic carbon',' ','mol C m-3',0) + call ncdefvar3d(SRF_NATALKALI(iogrp),cmpflg,'p','srfnattalk', & + & 'Surface natural alkalinity',' ','eq m-3',0) + call ncdefvar3d(SRF_NATPCO2(iogrp),cmpflg,'p', & + & 'natpco2','Surface natural PCO2',' ','uatm',0) + call ncdefvar3d(SRF_NATCO2FX(iogrp), & + & cmpflg,'p','natco2fx','Natural CO2 flux',' ','kg C m-2 s-1',0) + call ncdefvar3d(SRF_NATPH(iogrp),cmpflg,'p','srfnatph', & + & 'Surface natural pH',' ','-log10([H+])',0) +#endif +#ifdef BROMO + call ncdefvar3d(SRF_BROMO(iogrp),cmpflg,'p','srfbromo', & + & 'Surface bromoform',' ','mol CHBr3 m-3',0) + call ncdefvar3d(SRF_BROMOfx(iogrp),cmpflg,'p','bromofx', & + & 'Surface bromoform flux',' ','mol CHBr3 m-2 s-1',0) + call ncdefvar3d(INT_BROMOPRO(iogrp),cmpflg,'p','intbromoprod', & + & 'Integrated bromoform production',' ','mol CHBr3 m-2 s-1',0) + call ncdefvar3d(INT_BROMOUV(iogrp),cmpflg,'p','intbromouv', & + & 'Integrated bromoform loss to photolysis',' ', & + & 'mol CHBr3 m-2 s-1',0) + call ncdefvar3d(SRF_ATMBROMO(iogrp),cmpflg,'p', & + & 'atmbromo','Atmospheric bromoform',' ','ppt',0) +#endif + + call ncdefvar3d(SRF_ATMCO2(iogrp),cmpflg,'p', & + & 'atmco2','Atmospheric CO2',' ','ppm',0) +#if defined(BOXATM) + call ncdefvar3d(SRF_ATMO2(iogrp),cmpflg,'p', & + & 'atmo2','Atmospheric O2',' ','ppm',0) + call ncdefvar3d(SRF_ATMN2(iogrp),cmpflg,'p', & + & 'atmn2','Atmospheric N2',' ','ppm',0) +#endif +#ifdef cisonew + call ncdefvar3d(SRF_ATMC13(iogrp),cmpflg,'p', & + & 'atmc13','Atmospheric 13CO2',' ','ppm',0) + call ncdefvar3d(SRF_ATMC14(iogrp),cmpflg,'p', & + & 'atmc14','Atmospheric 14CO2',' ','ppm',0) +#endif +#ifdef extNcycle + call ncdefvar3d(SRF_PNH3(iogrp),cmpflg,'p', & + & 'pnh3','Surface pNH3',' ','natm',0) + call ncdefvar3d(SRF_ANH4(iogrp),cmpflg,'p','srfnh4', & + & 'Surface ammonium',' ','mol N m-3',0) + call ncdefvar3d(SRF_ANO2(iogrp),cmpflg,'p','srfno2', & + & 'Surface nitrite',' ','mol N m-3',0) + call ncdefvar3d(SRF_ANH3FX(iogrp),cmpflg,'p','nh3flux', & + & 'NH3 flux',' ','mol NH3 m-2 s-1',0) +#endif + ! --- define 3d layer fields + call ncdefvar3d(LYR_DP(iogrp),cmpflg,'p', & + & 'pddpo','Layer thickness',' ','m',1) + call ncdefvar3d(LYR_DIC(iogrp),cmpflg,'p', & + & 'dissic','Dissolved inorganic carbon',' ','mol C m-3',1) + call ncdefvar3d(LYR_ALKALI(iogrp),cmpflg,'p', & + & 'talk','Alkalinity',' ','eq m-3',1) + call ncdefvar3d(LYR_PHOSPH(iogrp),cmpflg,'p', & + & 'po4','Phosphorus',' ','mol P m-3',1) + call ncdefvar3d(LYR_OXYGEN(iogrp),cmpflg,'p', & + & 'o2','Oxygen',' ','mol O2 m-3',1) + call ncdefvar3d(LYR_ANO3(iogrp),cmpflg,'p', & + & 'no3','Nitrate',' ','mol N m-3',1) + call ncdefvar3d(LYR_SILICA(iogrp),cmpflg,'p', & + & 'si','Silicate',' ','mol Si m-3',1) + call ncdefvar3d(LYR_DOC(iogrp),cmpflg,'p', & + & 'dissoc','Dissolved organic carbon',' ','mol P m-3',1) + call ncdefvar3d(LYR_PHYTO(iogrp),cmpflg,'p', & + & 'phyc','Phytoplankton',' ','mol P m-3',1) + call ncdefvar3d(LYR_GRAZER(iogrp),cmpflg,'p', & + & 'zooc','Zooplankton',' ','mol P m-3',1) + call ncdefvar3d(LYR_POC(iogrp),cmpflg,'p', & + & 'detoc','Detritus',' ','mol P m-3',1) + call ncdefvar3d(LYR_CALC(iogrp),cmpflg,'p', & + & 'calc','CaCO3 shells',' ','mol C m-3',1) + call ncdefvar3d(LYR_OPAL(iogrp),cmpflg,'p', & + & 'opal','Opal shells',' ','mol Si m-3',1) + call ncdefvar3d(LYR_IRON(iogrp),cmpflg,'p', & + & 'dfe','Dissolved iron',' ','mol Fe m-3',1) + call ncdefvar3d(LYR_PHOSY(iogrp),cmpflg,'p', & + & 'pp','Primary production',' ','mol C m-3 s-1',1) + call ncdefvar3d(LYR_CO3(iogrp),cmpflg,'p', & + & 'co3','Carbonate ions',' ','mol C m-3',1) + call ncdefvar3d(LYR_PH(iogrp),cmpflg,'p', & + & 'ph','pH',' ','-log10([H+])',1) + call ncdefvar3d(LYR_OMEGAA(iogrp),cmpflg,'p', & + & 'omegaa','OmegaA',' ','1',1) + call ncdefvar3d(LYR_OMEGAC(iogrp),cmpflg,'p', & + & 'omegac','OmegaC',' ','1',1) + call ncdefvar3d(LYR_N2O(iogrp),cmpflg,'p', & + & 'n2o','N2O',' ','mol N2O m-3',1) + call ncdefvar3d(LYR_PREFO2(iogrp),cmpflg,'p', & + & 'p_o2','Preformed oxygen',' ','mol O2 m-3',1) + call ncdefvar3d(LYR_O2SAT(iogrp),cmpflg,'p', & + & 'satoxy','Saturated oxygen',' ','mol O2 m-3',1) + call ncdefvar3d(LYR_PREFPO4(iogrp),cmpflg,'p', & + & 'p_po4','Preformed phosphorus',' ','mol P m-3',1) + call ncdefvar3d(LYR_PREFALK(iogrp),cmpflg,'p', & + & 'p_talk','Preformed alkalinity',' ','eq m-3',1) + call ncdefvar3d(LYR_PREFDIC(iogrp),cmpflg,'p', & + & 'p_dic','Preformed DIC',' ','mol C m-3',1) + call ncdefvar3d(LYR_DICSAT(iogrp),cmpflg,'p', & + & 'sat_dic','Saturated DIC',' ','mol C m-3',1) +#ifdef cisonew + call ncdefvar3d(LYR_DIC13(iogrp),cmpflg,'p', & + & 'dissic13','Dissolved C13',' ','mol 13C m-3',1) + call ncdefvar3d(LYR_DIC14(iogrp),cmpflg,'p', & + & 'dissic14','Dissolved C14',' ','mol 14C m-3',1) + call ncdefvar3d(LYR_D13C(iogrp),cmpflg,'p', & + & 'delta13c','delta13C of DIC',' ','permil',1) + call ncdefvar3d(LYR_D14C(iogrp),cmpflg,'p', & + & 'delta14c','delta14C of DIC',' ','permil',1) + call ncdefvar3d(LYR_BIGD14C(iogrp),cmpflg,'p', & + & 'bigdelta14c','big delta14C of DIC',' ','permil',1) + call ncdefvar3d(LYR_POC13(iogrp),cmpflg,'p', & + & 'detoc13','Detritus13',' ','mol P m-3',1) + call ncdefvar3d(LYR_DOC13(iogrp),cmpflg,'p', & + & 'dissoc13','Dissolved organic carbon13',' ','mol P m-3',1) + call ncdefvar3d(LYR_CALC13(iogrp),cmpflg,'p', & + & 'calc13','Ca13CO3 shells',' ','mol 13C m-3',1) + call ncdefvar3d(LYR_PHYTO13(iogrp),cmpflg,'p', & + & 'phyc13','Phytoplankton13',' ','mol P m-3',1) + call ncdefvar3d(LYR_GRAZER13(iogrp),cmpflg,'p', & + & 'zooc13','Zooplankton13',' ','mol P m-3',1) +#endif +#ifdef AGG + call ncdefvar3d(LYR_NOS(iogrp),cmpflg,'p', & + & 'nos','Marine snow aggregates per cm^3 sea water',' ','1/cm^3',1) + call ncdefvar3d(LYR_WPHY(iogrp),cmpflg,'p', & + & 'wphy','Av. mass sinking speed of marine snow',' ','m/day',1) + call ncdefvar3d(LYR_WNOS(iogrp),cmpflg,'p', & + & 'wnos','Av. number sinking speed of marine snow',' ','m/day',1) + call ncdefvar3d(LYR_EPS(iogrp),cmpflg,'p', & + & 'eps','Av. size distribution exponent',' ','-',1) + call ncdefvar3d(LYR_ASIZE(iogrp),cmpflg,'p', & + & 'asize','Av. size of marine snow aggregates',' ','nb. of cells',1) +#endif +#ifdef CFC + call ncdefvar3d(LYR_CFC11(iogrp),cmpflg,'p', & + & 'cfc11','CFC-11',' ','mol cfc11 m-3',1) + call ncdefvar3d(LYR_CFC12(iogrp),cmpflg,'p', & + & 'cfc12','CFC-12',' ','mol cfc12 m-3',1) + call ncdefvar3d(LYR_SF6(iogrp),cmpflg,'p', & + & 'sf6','SF-6',' ','mol sf6 m-3',1) +#endif +#ifdef natDIC + call ncdefvar3d(LYR_NATCO3(iogrp),cmpflg,'p', & + & 'natco3','Natural Carbonate ions',' ','mol C m-3',1) + call ncdefvar3d(LYR_NATALKALI(iogrp),cmpflg,'p','nattalk', & + & 'Natural alkalinity',' ','eq m-3',1) + call ncdefvar3d(LYR_NATDIC(iogrp),cmpflg,'p','natdissic', & + & 'Natural dissolved inorganic carbon',' ','mol C m-3',1) + call ncdefvar3d(LYR_NATCALC(iogrp),cmpflg,'p','natcalc', & + & 'Natural CaCO3',' ','mol C m-3',1) + call ncdefvar3d(LYR_NATPH(iogrp),cmpflg,'p', & + & 'natph','Natural pH',' ','-log10([H+])',1) + call ncdefvar3d(LYR_NATOMEGAA(iogrp),cmpflg,'p','natomegaa', & + & 'Natural OmegaA',' ','1',1) + call ncdefvar3d(LYR_NATOMEGAC(iogrp),cmpflg,'p','natomegac', & + & 'Natural OmegaC',' ','1',1) +#endif +#ifdef BROMO + call ncdefvar3d(LYR_BROMO(iogrp),cmpflg,'p', & + & 'bromo','Bromoform',' ','mol CHBr3 m-3',1) +#endif +#ifdef extNcycle + call ncdefvar3d(LYR_ANH4(iogrp),cmpflg,'p', & + & 'nh4','Ammonium',' ','mol N m-3',1) + call ncdefvar3d(LYR_ANO2(iogrp),cmpflg,'p', & + & 'no2','Nitrite',' ','mol N m-3',1) + call ncdefvar3d(LYR_nitr_NH4(iogrp),cmpflg,'p', & + & 'nh4nitr','NH4 nitrification rate',' ','mol N m-3 s-1',1) + call ncdefvar3d(LYR_nitr_NO2(iogrp),cmpflg,'p', & + & 'no2nitr','NO2 nitrification rate',' ','mol N m-3 s-1',1) + call ncdefvar3d(LYR_nitr_N2O_prod(iogrp),cmpflg,'p', & + & 'nitr_n2o','N2O prod during NH4 nitrification',' ', & + & 'mol N2O m-3 s-1',1) + call ncdefvar3d(LYR_nitr_NH4_OM(iogrp),cmpflg,'p', & + & 'nh4nitr_om','OM production during NH4 nitrification',' ', & + & 'mol P m-3 s-1',1) + call ncdefvar3d(LYR_nitr_NO2_OM(iogrp),cmpflg,'p', & + & 'no2nitr_om','OM production during NO2 nitrification',' ', & + & 'mol P m-3 s-1',1) + call ncdefvar3d(LYR_denit_NO3(iogrp),cmpflg,'p', & + & 'no3denit','NO3 denitrification rate',' ','mol N m-3 s-1',1) + call ncdefvar3d(LYR_denit_NO2(iogrp),cmpflg,'p', & + & 'no2denit','NO2 denitrification rate',' ','mol N m-3 s-1',1) + call ncdefvar3d(LYR_denit_N2O(iogrp),cmpflg,'p', & + & 'n2odenit','N2O denitrification rate',' ','mol N2O m-3 s-1',1) + call ncdefvar3d(LYR_DNRA_NO2(iogrp),cmpflg,'p', & + & 'no2dnra','NO2 DNRA rate',' ','mol N m-3 s-1',1) + call ncdefvar3d(LYR_anmx_N2_prod(iogrp),cmpflg,'p', & + & 'anmx_n2','Anammox N2 production rate',' ','mol N2 m-3 s-1',1) + call ncdefvar3d(LYR_anmx_OM_prod(iogrp),cmpflg,'p', & + & 'anmx_om','Anammox OM production rate',' ','mol P m-3 s-1',1) + call ncdefvar3d(LYR_phosy_NH4(iogrp),cmpflg,'p', & + & 'phosy_nh4','PP consumption rate of NH4',' ','mol N m-3 s-1',1) + call ncdefvar3d(LYR_phosy_NO3(iogrp),cmpflg,'p', & + & 'phosy_no3','PP consumption rate of NO3',' ','mol N m-3 s-1',1) + call ncdefvar3d(LYR_remin_aerob(iogrp),cmpflg,'p', & + & 'remina','Aerob remineralization rate',' ','mol N m-3 s-1',1) + call ncdefvar3d(LYR_remin_sulf(iogrp),cmpflg,'p', & + & 'remins','Sulfate remineralization rate',' ','mol P m-3 s-1',1) +#endif + ! M4AGO + call ncdefvar3d(LYR_agg_ws(iogrp),cmpflg,'p', & + & 'agg_ws','aggregate mean settling velocity',' ','m d-1',1) + call ncdefvar3d(LYR_dynvis(iogrp),cmpflg,'p', & + & 'dynvis','dynamic viscosity of sea water',' ','kg m-1 s-1',1) + call ncdefvar3d(LYR_agg_stick(iogrp),cmpflg,'p', & + & 'agg_stick','aggregate mean stickiness',' ','-',1) + call ncdefvar3d(LYR_agg_stickf(iogrp),cmpflg,'p', & + & 'agg_stickf','opal frustule stickiness',' ','-',1) + call ncdefvar3d(LYR_agg_dmax(iogrp),cmpflg,'p', & + & 'agg_dmax','aggregate maximum diameter',' ','m',1) + call ncdefvar3d(LYR_agg_avdp(iogrp),cmpflg,'p', & + & 'agg_avdp','mean primary particle diameter',' ','m',1) + call ncdefvar3d(LYR_agg_avrhop(iogrp),cmpflg,'p', & + & 'agg_avrhop','mean primary particle density',' ','kg m-3',1) + call ncdefvar3d(LYR_agg_avdC(iogrp),cmpflg,'p', & + & 'agg_avdC','Conc.-weighted mean aggregate diameter',' ','m',1) + call ncdefvar3d(LYR_agg_df(iogrp),cmpflg,'p', & + & 'agg_df','aggregate fractal dimension',' ','-',1) + call ncdefvar3d(LYR_agg_b(iogrp),cmpflg,'p', & + & 'agg_b','aggregate number distribution slope',' ','-',1) + call ncdefvar3d(LYR_agg_Vrhof(iogrp),cmpflg,'p', & + & 'agg_Vrhof','V-weighted aggregate mean density',' ','kg m-3',1) + call ncdefvar3d(LYR_agg_Vpor(iogrp),cmpflg,'p', & + & 'agg_Vpor','V-weighted aggregate mean porosity',' ','-',1) + + ! --- define 3d level fields + call ncdefvar3d(LVL_DIC(iogrp),cmpflg,'p', & + & 'dissiclvl','Dissolved inorganic carbon',' ','mol C m-3',2) + call ncdefvar3d(LVL_ALKALI(iogrp),cmpflg,'p', & + & 'talklvl','Alkalinity',' ','eq m-3',2) + call ncdefvar3d(LVL_PHOSPH(iogrp),cmpflg,'p', & + & 'po4lvl','Phosphorus',' ','mol P m-3',2) + call ncdefvar3d(LVL_OXYGEN(iogrp),cmpflg,'p', & + & 'o2lvl','Oxygen',' ','mol O2 m-3',2) + call ncdefvar3d(LVL_ANO3(iogrp),cmpflg,'p', & + & 'no3lvl','Nitrate',' ','mol N m-3',2) + call ncdefvar3d(LVL_SILICA(iogrp),cmpflg,'p', & + & 'silvl','Silicate',' ','mol Si m-3',2) + call ncdefvar3d(LVL_DOC(iogrp),cmpflg,'p', & + & 'dissoclvl','Dissolved organic carbon',' ','mol P m-3',2) + call ncdefvar3d(LVL_PHYTO(iogrp),cmpflg,'p', & + & 'phyclvl','Phytoplankton',' ','mol P m-3',2) + call ncdefvar3d(LVL_GRAZER(iogrp),cmpflg,'p', & + & 'zooclvl','Zooplankton',' ','mol P m-3',2) + call ncdefvar3d(LVL_POC(iogrp),cmpflg,'p', & + & 'detoclvl','Detritus',' ','mol P m-3',2) + call ncdefvar3d(LVL_CALC(iogrp),cmpflg,'p', & + & 'calclvl','CaCO3 shells',' ','mol C m-3',2) + call ncdefvar3d(LVL_OPAL(iogrp),cmpflg,'p', & + & 'opallvl','Opal shells',' ','mol Si m-3',2) + call ncdefvar3d(LVL_IRON(iogrp),cmpflg,'p', & + & 'dfelvl','Dissolved iron',' ','mol Fe m-3',2) + call ncdefvar3d(LVL_PHOSY(iogrp),cmpflg,'p', & + & 'pplvl','Primary production',' ','mol C m-3 s-1',2) + call ncdefvar3d(LVL_CO3(iogrp),cmpflg,'p', & + & 'co3lvl','Carbonate ions',' ','mol C m-3',2) + call ncdefvar3d(LVL_PH(iogrp),cmpflg,'p', & + & 'phlvl','pH',' ','-log10([H+])',2) + call ncdefvar3d(LVL_OMEGAA(iogrp),cmpflg,'p', & + & 'omegaalvl','OmegaA',' ','1',2) + call ncdefvar3d(LVL_OMEGAC(iogrp),cmpflg,'p', & + & 'omegaclvl','OmegaC',' ','1',2) + call ncdefvar3d(LVL_N2O(iogrp),cmpflg,'p', & + & 'n2olvl','N2O',' ','mol N2O m-3',2) + call ncdefvar3d(LVL_PREFO2(iogrp),cmpflg,'p', & + & 'p_o2lvl','Preformed oxygen',' ','mol O2 m-3',2) + call ncdefvar3d(LVL_O2SAT(iogrp),cmpflg,'p', & + & 'satoxylvl','Saturated oxygen',' ','mol O2 m-3',2) + call ncdefvar3d(LVL_PREFPO4(iogrp),cmpflg,'p', & + & 'p_po4lvl','Preformed phosphorus',' ','mol P m-3',2) + call ncdefvar3d(LVL_PREFALK(iogrp),cmpflg,'p', & + & 'p_talklvl','Preformed alkalinity',' ','eq m-3',2) + call ncdefvar3d(LVL_PREFDIC(iogrp),cmpflg,'p', & + & 'p_diclvl','Preformed DIC',' ','mol C m-3',2) + call ncdefvar3d(LVL_DICSAT(iogrp),cmpflg,'p', & + & 'sat_diclvl','Saturated DIC',' ','mol C m-3',2) +#ifdef cisonew + call ncdefvar3d(LVL_DIC13(iogrp),cmpflg,'p', & + & 'dissic13lvl','Dissolved C13',' ','mol 13C m-3',2) + call ncdefvar3d(LVL_DIC14(iogrp),cmpflg,'p', & + & 'dissic14lvl','Dissolved C14',' ','mol 14C m-3',2) + call ncdefvar3d(LVL_D13C(iogrp),cmpflg,'p', & + & 'delta13clvl','delta13C of DIC',' ','permil',2) + call ncdefvar3d(LVL_D14C(iogrp),cmpflg,'p', & + & 'delta14clvl','delta14C of DIC',' ','permil',2) + call ncdefvar3d(LVL_BIGD14C(iogrp),cmpflg,'p', & + & 'bigdelta14clvl','big delta14C of DIC',' ','permil',2) + call ncdefvar3d(LVL_POC13(iogrp),cmpflg,'p', & + & 'detoc13lvl','Detritus13',' ','mol P m-3',2) + call ncdefvar3d(LVL_DOC13(iogrp),cmpflg,'p', & + & 'dissoc13lvl','Dissolved organic carbon13',' ','mol P m-3',2) + call ncdefvar3d(LVL_CALC13(iogrp),cmpflg,'p', & + & 'calc13lvl','Ca13CO3 shells',' ','mol 13C m-3',2) + call ncdefvar3d(LVL_PHYTO13(iogrp),cmpflg,'p', & + & 'phyc13lvl','Phytoplankton13',' ','mol P m-3',2) + call ncdefvar3d(LVL_GRAZER13(iogrp),cmpflg,'p', & + & 'zooc13lvl','Zooplankton13',' ','mol P m-3',2) +#endif +#ifdef AGG + call ncdefvar3d(LVL_NOS(iogrp),cmpflg,'p','noslvl', & + & 'Marine snow aggregates per cm^3 sea water',' ','1/cm^3',2) + call ncdefvar3d(LVL_WPHY(iogrp),cmpflg,'p','wphylvl', & + & 'Av. mass sinking speed of marine snow',' ','m/day',2) + call ncdefvar3d(LVL_WNOS(iogrp),cmpflg,'p','wnoslvl', & + & 'Av. number sinking speed of marine snow',' ','m/day',2) + call ncdefvar3d(LVL_EPS(iogrp),cmpflg,'p','epslvl', & + & 'Av. size distribution exponent',' ','-',2) + call ncdefvar3d(LVL_ASIZE(iogrp),cmpflg,'p','asizelvl', & + & 'Av. size of marine snow aggregates',' ','nb. of cells',2) +#endif +#ifdef CFC + call ncdefvar3d(LVL_CFC11(iogrp),cmpflg,'p', & + & 'cfc11lvl','CFC-11',' ','mol cfc11 m-3',2) + call ncdefvar3d(LVL_CFC12(iogrp),cmpflg,'p', & + & 'cfc12lvl','CFC-12',' ','mol cfc12 m-3',2) + call ncdefvar3d(LVL_SF6(iogrp),cmpflg,'p', & + & 'sf6lvl','SF-6',' ','mol sf6 m-3',2) +#endif +#ifdef natDIC + call ncdefvar3d(LVL_NATCO3(iogrp),cmpflg,'p', & + & 'natco3lvl','Natural Carbonate ions',' ','mol C m-3',2) + call ncdefvar3d(LVL_NATALKALI(iogrp),cmpflg,'p','nattalklvl', & + & 'Natural alkalinity',' ','eq m-3',2) + call ncdefvar3d(LVL_NATDIC(iogrp),cmpflg,'p','natdissiclvl', & + & 'Natual dissolved inorganic carbon',' ','mol C m-3',2) + call ncdefvar3d(LVL_NATCALC(iogrp),cmpflg,'p', & + & 'natcalclvl','Natural CaCO3 shells',' ','mol C m-3',2) + call ncdefvar3d(LVL_NATPH(iogrp),cmpflg,'p', & + & 'natphlvl','Natural pH',' ','-log10([H+])',2) + call ncdefvar3d(LVL_NATOMEGAA(iogrp),cmpflg,'p', & + & 'natomegaalvl','Natural OmegaA',' ','1',2) + call ncdefvar3d(LVL_NATOMEGAC(iogrp),cmpflg,'p', & + & 'natomegaclvl','Natural OmegaC',' ','1',2) +#endif +#ifdef BROMO + call ncdefvar3d(LVL_BROMO(iogrp),cmpflg,'p', & + & 'bromolvl','Bromoform',' ','mol CHBr3 m-3',2) +#endif +#ifdef extNcycle + call ncdefvar3d(LVL_ANH4(iogrp),cmpflg,'p', & + & 'nh4lvl','Ammonium',' ','mol N m-3',2) + call ncdefvar3d(LVL_ANO2(iogrp),cmpflg,'p', & + & 'no2lvl','Nitrite',' ','mol N m-3',2) + call ncdefvar3d(LVL_nitr_NH4(iogrp),cmpflg,'p', & + & 'nh4nitrlvl','NH4 nitrification rate',' ','mol N m-3 s-1',2) + call ncdefvar3d(LVL_nitr_NO2(iogrp),cmpflg,'p', & + & 'no2nitrlvl','NO2 nitrification rate',' ','mol N m-3 s-1',2) + call ncdefvar3d(LVL_nitr_N2O_prod(iogrp),cmpflg,'p', & + & 'nitr_n2olvl','N2O prod during NH4 nitrification',' ', & + & 'mol N2O m-3 s-1',2) + call ncdefvar3d(LVL_nitr_NH4_OM(iogrp),cmpflg,'p', & + & 'nh4nitr_omlvl','OM production during NH4 nitrification',' ', & + & 'mol P m-3 s-1',2) + call ncdefvar3d(LVL_nitr_NO2_OM(iogrp),cmpflg,'p', & + & 'no2nitr_omlvl','OM production during NO2 nitrification',' ', & + & 'mol P m-3 s-1',2) + call ncdefvar3d(LVL_denit_NO3(iogrp),cmpflg,'p', & + & 'no3denitlvl','NO3 denitrification rate',' ','mol N m-3 s-1',2) + call ncdefvar3d(LVL_denit_NO2(iogrp),cmpflg,'p', & + & 'no2denitlvl','NO2 denitrification rate',' ','mol N m-3 s-1',2) + call ncdefvar3d(LVL_denit_N2O(iogrp),cmpflg,'p', & + & 'n2odenitlvl','N2O denitrification rate',' ', & + & 'mol N2O m-3 s-1',2) + call ncdefvar3d(LVL_DNRA_NO2(iogrp),cmpflg,'p', & + & 'no2dnralvl','NO2 DNRA rate',' ','mol N m-3 s-1',2) + call ncdefvar3d(LVL_anmx_N2_prod(iogrp),cmpflg,'p', & + & 'anmx_n2lvl','Anammox N2 production rate',' ', & + & 'mol N2 m-3 s-1',2) + call ncdefvar3d(LVL_anmx_OM_prod(iogrp),cmpflg,'p', & + & 'anmx_omlvl','Anammox OM production rate',' ','mol P m-3 s-1',2) + call ncdefvar3d(LVL_phosy_NH4(iogrp),cmpflg,'p', & + & 'phosy_nh4lvl','PP consumption rate of NH4',' ', & + & 'mol N m-3 s-1',2) + call ncdefvar3d(LVL_phosy_NO3(iogrp),cmpflg,'p', & + & 'phosy_no3lvl','PP consumption rate of NO3',' ', & + & 'mol N m-3 s-1',2) + call ncdefvar3d(LVL_remin_aerob(iogrp),cmpflg,'p', & + & 'reminalvl','Aerob remineralization rate',' ', & + & 'mol N m-3 s-1',2) + call ncdefvar3d(LVL_remin_sulf(iogrp),cmpflg,'p', & + & 'reminslvl','Sulfate remineralization rate',' ', & + & 'mol P m-3 s-1',2) +#endif + ! M4AGO + call ncdefvar3d(LVL_agg_ws(iogrp),cmpflg,'p', & + & 'agg_wslvl','aggregate mean settling velocity',' ','m d-1',2) + call ncdefvar3d(LVL_dynvis(iogrp),cmpflg,'p', & + & 'dynvislvl','dynamic viscosity of sea water',' ','kg m-1 s-1', & + & 2) + call ncdefvar3d(LVL_agg_stick(iogrp),cmpflg,'p', & + & 'agg_sticklvl','aggregate mean stickiness',' ','-',2) + call ncdefvar3d(LVL_agg_stickf(iogrp),cmpflg,'p', & + & 'agg_stickflvl','opal frustule stickiness',' ','-',2) + call ncdefvar3d(LVL_agg_dmax(iogrp),cmpflg,'p', & + & 'agg_dmaxlvl','aggregate maximum diameter',' ','m',2) + call ncdefvar3d(LVL_agg_avdp(iogrp),cmpflg,'p', & + & 'agg_avdplvl','mean primary particle diameter',' ','m',2) + call ncdefvar3d(LVL_agg_avrhop(iogrp),cmpflg,'p', & + & 'agg_avrhoplvl','mean primary particle density',' ','kg m-3',2) + call ncdefvar3d(LVL_agg_avdC(iogrp),cmpflg,'p', & + & 'agg_avdClvl','Conc.-weighted mean aggregate diameter',' ', & + & 'm',2) + call ncdefvar3d(LVL_agg_df(iogrp),cmpflg,'p', & + & 'agg_dflvl','aggregate fractal dimension',' ','-',2) + call ncdefvar3d(LVL_agg_b(iogrp),cmpflg,'p', & + & 'agg_blvl','aggregate number distribution slope',' ','-',2) + call ncdefvar3d(LVL_agg_Vrhof(iogrp),cmpflg,'p', & + & 'agg_Vrhoflvl','V-weighted aggregate mean density',' ', & + & 'kg m-3',2) + call ncdefvar3d(LVL_agg_Vpor(iogrp),cmpflg,'p', & + & 'agg_Vporlvl','V-weighted aggregate mean porosity',' ','-',2) + + ! --- define sediment fields +#ifndef sedbypass + call ncdefvar3d(SDM_POWAIC(iogrp),cmpflg,'p', & + & 'powdic','PoWa DIC',' ','mol C m-3',3) + call ncdefvar3d(SDM_POWAAL(iogrp),cmpflg,'p', & + & 'powalk','PoWa alkalinity',' ','eq m-3',3) + call ncdefvar3d(SDM_POWAPH(iogrp),cmpflg,'p', & + & 'powpho','PoWa phosphorus',' ','mol P m-3',3) + call ncdefvar3d(SDM_POWAOX(iogrp),cmpflg,'p', & + & 'powox','PoWa oxygen',' ','mol O2 m-3',3) + call ncdefvar3d(SDM_POWN2(iogrp), cmpflg,'p', & + & 'pown2','PoWa N2',' ','mol N2 m-3',3) + call ncdefvar3d(SDM_POWNO3(iogrp),cmpflg,'p', & + & 'powno3','PoWa nitrate',' ','mol N m-3',3) + call ncdefvar3d(SDM_POWASI(iogrp),cmpflg,'p', & + & 'powsi','PoWa silicate',' ','mol Si m-3',3) + call ncdefvar3d(SDM_SSSO12(iogrp),cmpflg,'p', & + & 'ssso12','Sediment detritus',' ','mol P m-3',3) + call ncdefvar3d(SDM_SSSSIL(iogrp),cmpflg,'p', & + & 'ssssil','Sediment silicate',' ','mol Si m-3',3) + call ncdefvar3d(SDM_SSSC12(iogrp),cmpflg,'p', & + & 'sssc12','Sediment CaCO3',' ','mol C m-3',3) + call ncdefvar3d(SDM_SSSTER(iogrp),cmpflg,'p', & + & 'ssster','Sediment clay',' ','kg m-3',3) + + ! --- define sediment burial fields + call ncdefvar3d(BUR_SSSO12(iogrp), & + & cmpflg,'p','buro12','Burial org carbon',' ','mol P m-2',4) + call ncdefvar3d(BUR_SSSC12(iogrp), & + & cmpflg,'p','burc12','Burial CaCO3',' ','mol C m-2',4) + call ncdefvar3d(BUR_SSSSIL(iogrp), & + & cmpflg,'p','bursil','Burial silicate',' ','mol Si m-2',4) + call ncdefvar3d(BUR_SSSTER(iogrp), & + & cmpflg,'p','burter','Burial clay',' ','kg m-2',4) +#endif +#if defined(extNcycle) && ! defined(sedbypass) + call ncdefvar3d(SDM_POWNH4(iogrp),cmpflg,'p', & + & 'pownh4','PoWa ammonium',' ','mol N m-3',3) + call ncdefvar3d(SDM_POWN2O(iogrp),cmpflg,'p', & + & 'pown2o','PoWa nitrous oxide',' ','mol N m-3',3) + call ncdefvar3d(SDM_POWNO2(iogrp),cmpflg,'p', & + & 'powno2','PoWa nitrite',' ','mol N m-3',3) + call ncdefvar3d(sdm_nitr_NH4(iogrp),cmpflg,'p', & + & 'nh4nitrsdm','NH4 nitrification rate sediment',' ','mol N m-3 s-1',3) + call ncdefvar3d(sdm_nitr_NO2(iogrp),cmpflg,'p', & + & 'no2nitrsdm','NO2 nitrification rate sediment',' ','mol N m-3 s-1',3) + call ncdefvar3d(sdm_nitr_N2O_prod(iogrp),cmpflg,'p', & + & 'nitr_n2osdm','N2O prod during NH4 nitrification sediment',' ', & + & 'mol N2O m-3 s-1',3) + call ncdefvar3d(sdm_nitr_NH4_OM(iogrp),cmpflg,'p', & + & 'nh4nitr_omsdm','OM production during NH4 nitrification sediment',' ', & + & 'mol P m-3 s-1',3) + call ncdefvar3d(sdm_nitr_NO2_OM(iogrp),cmpflg,'p', & + & 'no2nitr_omsdm','OM production during NO2 nitrification sediment',' ', & + & 'mol P m-3 s-1',3) + call ncdefvar3d(sdm_denit_NO3(iogrp),cmpflg,'p', & + & 'no3denitsdm','NO3 denitrification rate sediment',' ','mol N m-3 s-1',3) + call ncdefvar3d(sdm_denit_NO2(iogrp),cmpflg,'p', & + & 'no2denitsdm','NO2 denitrification rate sediment',' ','mol N m-3 s-1',3) + call ncdefvar3d(sdm_denit_N2O(iogrp),cmpflg,'p', & + & 'n2odenitsdm','N2O denitrification rate sediment',' ', & + & 'mol N2O m-3 s-1',3) + call ncdefvar3d(sdm_DNRA_NO2(iogrp),cmpflg,'p', & + & 'no2dnrasdm','NO2 DNRA rate sediment',' ','mol N m-3 s-1',3) + call ncdefvar3d(sdm_anmx_N2_prod(iogrp),cmpflg,'p', & + & 'anmx_n2sdm','Anammox N2 production rate sediment',' ', & + & 'mol N2 m-3 s-1',3) + call ncdefvar3d(sdm_anmx_OM_prod(iogrp),cmpflg,'p', & + & 'anmx_omsdm','Anammox OM production rate sediment',' ', & + & 'mol P m-3 s-1',3) + call ncdefvar3d(sdm_remin_aerob(iogrp),cmpflg,'p', & + & 'reminasdm','Aerob remineralization rate sediment',' ', & + & 'mol N m-3 s-1',3) + call ncdefvar3d(sdm_remin_sulf(iogrp),cmpflg,'p', & + & 'reminssdm','Sulfate remineralization rate sediment',' ', & + & 'mol P m-3 s-1',3) +#endif + ! --- enddef netcdf file + call ncedef +end subroutine hamoccvardef diff --git a/hamocc/ocprod.F90 b/hamocc/ocprod.F90 index e1fe9879..782089ee 100644 --- a/hamocc/ocprod.F90 +++ b/hamocc/ocprod.F90 @@ -18,7 +18,7 @@ ! along with BLOM. If not, see https://www.gnu.org/licenses/. -subroutine ocprod(kpie,kpje,kpke,kbnd,pdlxp,pdlyp,pddpo,omask,ptho,pi_ph) +subroutine ocprod(kpie,kpje,kpke,kbnd,pdlxp,pdlyp,pddpo,omask,ptho,pi_ph, psao, ppao, prho) !****************************************************************************** ! ! OCPROD - biological production, remineralization and particle sinking. @@ -78,6 +78,10 @@ subroutine ocprod(kpie,kpje,kpke,kbnd,pdlxp,pdlyp,pddpo,omask,ptho,pi_ph) ! *REAL* *pddpo* - size of scalar grid cell (3rd dimension) [m]. ! *REAL* *omask* - land/ocean mask (1=ocean) ! *REAL* *ptho* - potential temperature [deg C]. +! *REAL* *pi_ph* - +! *REAL* *psao* - salinity [psu]. +! *REAL* *ppao* - sea level pressure [Pascal]. +! *REAL* *prho* - density [kg/m^3]. ! !****************************************************************************** use mo_carbch, only: dmspar,ocetra,satoxy,hi @@ -87,15 +91,16 @@ subroutine ocprod(kpie,kpje,kpke,kbnd,pdlxp,pdlyp,pddpo,omask,ptho,pi_ph) & carflx1000,carflx2000,carflx4000,carflx_bot,dremn2o,dremopal,drempoc,dremsul,dyphy,ecan,epsher,fesoly, & & gammap,gammaz,grami,grazra,expoor,exposi,expoca,intdnit,intdms_bac,intdmsprod,intdms_uv,intphosy, & & phosy3d,pi_alpha,phytomi,rcalc,rcar,rdn2o1,rdn2o2,rdnit0,rdnit1,rdnit2,relaxfe,remido, & - & riron,rnit,strahl,rnoi,ro2ut,ropal,spemor,wcal,wdust,wopal,wpoc,zinges + & riron,rnit,strahl,rnoi,ro2ut,ropal,spemor,wcal,wdust,wopal,wpoc,zinges,drempoc_anaerob,bkox_drempoc use mo_param1_bgc, only: ialkali,ian2o,iano3,icalc,idet,idms,idoc,ifdust,igasnit,iiron,iopal,ioxygen,iphosph,iphy,isco212, & & isilica,izoo - use mo_control_bgc, only: dtb,io_stdo_bgc,with_dmsph + use mo_control_bgc, only: dtb,io_stdo_bgc,with_dmsph,lm4ago use mo_vgrid, only: dp_min,dp_min_sink,k0100,k0500,k1000,k2000,k4000,kwrbioz,ptiestu use mod_xc, only: mnproc + use mo_m4ago, only: mean_aggregate_sinking_speed,ws_agg,POM_remin_q10,POM_remin_Tref,opal_remin_q10,opal_remin_Tref #ifdef AGG - use mo_biomod, only: alar1,alar2,alar3,alow1,alow2,alow3,asize3d,calmax,cellmass,cellsink,dustd1,dustd2,dustd3,dustsink, & + use mo_biomod, only: alar1,alar2,alar3,alow1,alow2,alow3,asize3d,calmax,cellmass,cellsink,dustd1,dustd2,dustd3,dustsink, & & eps3d,fractdim,fse,fsh,nmldmin,plower,pupper,sinkexp,stick,tmfac,tsfac,vsmall,zdis,wmass,wnumb use mo_param1_bgc, only: iadust,inos use mo_vgrid, only: kmle @@ -136,6 +141,9 @@ subroutine ocprod(kpie,kpje,kpke,kbnd,pdlxp,pdlyp,pddpo,omask,ptho,pi_ph) real, intent(in) :: omask(kpie,kpje) real, intent(in) :: ptho(1-kbnd:kpie+kbnd,1-kbnd:kpje+kbnd,kpke) real, intent(in) :: pi_ph(kpie,kpje) + real, intent(in) :: psao(1-kbnd:kpie+kbnd,1-kbnd:kpje+kbnd,kpke) + real, intent(in) :: ppao(1-kbnd:kpie+kbnd,1-kbnd:kpje+kbnd) + real, intent(in) :: prho(kpie,kpje,kpke) ! Local varaibles integer :: i,j,k,l @@ -156,7 +164,8 @@ subroutine ocprod(kpie,kpje,kpke,kbnd,pdlxp,pdlyp,pddpo,omask,ptho,pi_ph) real :: absorption,absorption_uv real :: dmsprod,dms_bac,dms_uv real :: dtr,dz - real :: wpocd,wcald,wopald,dagg + real :: wpocd,wcald,wopald,wdustd,dagg + real :: o2lim ! O2 limitation of ammonification (POC remin) #ifdef sedbypass real :: florca,flcaca,flsil #endif @@ -202,7 +211,7 @@ subroutine ocprod(kpie,kpje,kpke,kbnd,pdlxp,pdlyp,pddpo,omask,ptho,pi_ph) #endif #ifdef extNcycle character(len=:), allocatable :: inv_message - real :: ano3up_inh,nutlim,anh4lim,nlim,grlim,nh4uptfrac + real :: ano3up_inh,nutlim,anh4lim,nlim,grlim,nh4uptfrac #endif @@ -316,11 +325,16 @@ subroutine ocprod(kpie,kpje,kpke,kbnd,pdlxp,pdlyp,pddpo,omask,ptho,pi_ph) enddo !$OMP END PARALLEL DO + if (lm4ago) then + ! even though we loose detritus, etc. we call the calculation for settling velocity by M4AGO here + ! to enable further future development... - assuming that the operator splitting decently functions + call mean_aggregate_sinking_speed(kpie, kpje, kpke, kbnd, pddpo, omask, ptho, psao, ppao, prho) + endif !$OMP PARALLEL DO PRIVATE(avphy,avgra,avsil,avanut,avanfe,pho,xa,xn & !$OMP ,phosy,ya,yn,grazing,graton,gratpoc,grawa,bacfra,phymor & !$OMP ,zoomor,excdoc,exud,export,delsil,delcar,dmsprod & -!$OMP ,dms_bac,dms_uv,dtr,phofa,temfa,zoothresh,dms_ph,dz & +!$OMP ,dms_bac,dms_uv,dtr,phofa,temfa,zoothresh,dms_ph,dz,opalrem & # ifdef AGG !$OMP ,avmass,avnos,zmornos & # endif @@ -531,8 +545,13 @@ subroutine ocprod(kpie,kpje,kpke,kbnd,pdlxp,pdlyp,pddpo,omask,ptho,pi_ph) ocetra(i,j,k,inatalkali) = ocetra(i,j,k,inatalkali)-2.*delcar-(rnit+1)*dtr ocetra(i,j,k,inatcalc) = ocetra(i,j,k,inatcalc)+delcar #endif - ocetra(i,j,k,isilica) = ocetra(i,j,k,isilica)-delsil+dremopal*ocetra(i,j,k,iopal) - ocetra(i,j,k,iopal) = ocetra(i,j,k,iopal)+delsil-dremopal*ocetra(i,j,k,iopal) + if(lm4ago)then + opalrem = dremopal*opal_remin_q10**((ptho(i,j,k)-opal_remin_Tref)/10.)*ocetra(i,j,k,iopal) + else + opalrem = dremopal*ocetra(i,j,k,iopal) + endif + ocetra(i,j,k,isilica) = ocetra(i,j,k,isilica)-delsil+opalrem + ocetra(i,j,k,iopal) = ocetra(i,j,k,iopal)+delsil-opalrem ocetra(i,j,k,iiron) = ocetra(i,j,k,iiron)+dtr*riron & & - relaxfe*MAX(ocetra(i,j,k,iiron)-fesoly,0.) #ifdef BROMO @@ -616,7 +635,7 @@ subroutine ocprod(kpie,kpje,kpke,kbnd,pdlxp,pdlyp,pddpo,omask,ptho,pi_ph) #endif !$OMP PARALLEL DO PRIVATE(phythresh,zoothresh,sterph,sterzo,remin & -!$OMP ,opalrem,aou,refra,dms_bac,pocrem,docrem,phyrem,dz & +!$OMP ,opalrem,aou,refra,dms_bac,pocrem,docrem,phyrem,dz,o2lim & # ifdef AGG !$OMP ,avmass,avnos,zmornos & # endif @@ -665,12 +684,25 @@ subroutine ocprod(kpie,kpje,kpke,kbnd,pdlxp,pdlyp,pddpo,omask,ptho,pi_ph) #endif if(ocetra(i,j,k,ioxygen) > 5.e-8) then + if(lm4ago) then +#ifndef extNcycle + ! M4AGO comes with O2-lim + o2lim = ocetra(i,j,k,ioxygen)/(ocetra(i,j,k,ioxygen) + bkox_drempoc) + pocrem = o2lim*drempoc*POM_remin_q10**((ptho(i,j,k)-POM_remin_Tref)/10.)*ocetra(i,j,k,idet) +#else + ! nitrogen always accounts for O2-lim - see below + pocrem = drempoc*POM_remin_q10**((ptho(i,j,k)-POM_remin_Tref)/10.)*ocetra(i,j,k,idet) +#endif + else + pocrem = drempoc*ocetra(i,j,k,idet) + endif #ifndef extNcycle - pocrem = MIN(drempoc*ocetra(i,j,k,idet),0.33*ocetra(i,j,k,ioxygen)/ro2ut) + pocrem = MIN(pocrem,0.33*ocetra(i,j,k,ioxygen)/ro2ut) docrem = MIN( remido*ocetra(i,j,k,idoc),0.33*ocetra(i,j,k,ioxygen)/ro2ut) phyrem = MIN(0.5*dyphy*phythresh, 0.33*ocetra(i,j,k,ioxygen)/ro2ut) #else - pocrem = MIN(drempoc*ocetra(i,j,k,idet),0.33*ocetra(i,j,k,ioxygen)/ro2utammo) + o2lim = ocetra(i,j,k,ioxygen)/(ocetra(i,j,k,ioxygen) + bkox_drempoc) + pocrem = MIN(o2lim*pocrem,0.33*ocetra(i,j,k,ioxygen)/ro2utammo) docrem = MIN( remido*ocetra(i,j,k,idoc),0.33*ocetra(i,j,k,ioxygen)/ro2utammo) phyrem = MIN(0.5*dyphy*phythresh, 0.33*ocetra(i,j,k,ioxygen)/ro2utammo) #endif @@ -737,7 +769,11 @@ subroutine ocprod(kpie,kpje,kpke,kbnd,pdlxp,pdlyp,pddpo,omask,ptho,pi_ph) ! so the expression dremopal*(Si(OH)4sat-Si(OH)4) would change the ! rate only from 0 to 100% !*********************************************************************** - opalrem = dremopal*0.1*(temp+3.)*ocetra(i,j,k,iopal) + if(lm4ago)then + opalrem = dremopal*opal_remin_q10**((ptho(i,j,k)-opal_remin_Tref)/10.)*ocetra(i,j,k,iopal) + else + opalrem = dremopal*0.1*(temp+3.)*ocetra(i,j,k,iopal) + endif ocetra(i,j,k,iopal) = ocetra(i,j,k,iopal)-opalrem ocetra(i,j,k,isilica) = ocetra(i,j,k,isilica)+opalrem @@ -814,7 +850,7 @@ subroutine ocprod(kpie,kpje,kpke,kbnd,pdlxp,pdlyp,pddpo,omask,ptho,pi_ph) avmass = ocetra(i,j,k,iphy) + ocetra(i,j,k,idet) #endif /*AGG*/ - remin = 0.05 * drempoc * MIN(ocetra(i,j,k,idet), & + remin = drempoc_anaerob * MIN(ocetra(i,j,k,idet), & & 0.5 * ocetra(i,j,k,iano3) / rdnit1) remin2o = dremn2o * MIN(ocetra(i,j,k,idet), & & 0.003 * ocetra(i,j,k,ian2o) / rdn2o1) @@ -1028,7 +1064,7 @@ subroutine ocprod(kpie,kpje,kpke,kbnd,pdlxp,pdlyp,pddpo,omask,ptho,pi_ph) ! Set minimum particle number to nmldmin in the mixed layer. This is to prevent ! very small values of nos (and asscociated high sinking speed if there is mass) ! in high latitudes during winter - if ( k <= kmle ) then + if ( k <= kmle(i,j) ) then ocetra(i,j,k,inos) = MAX(nmldmin,ocetra(i,j,k,inos)) endif @@ -1064,7 +1100,7 @@ subroutine ocprod(kpie,kpje,kpke,kbnd,pdlxp,pdlyp,pddpo,omask,ptho,pi_ph) ! As a first step, assume that shear in the mixed layer is high and ! zero below. - if ( k <= kmle ) then + if ( k <= kmle(i,j) ) then fshear = fsh else fshear = 0. @@ -1139,7 +1175,7 @@ subroutine ocprod(kpie,kpje,kpke,kbnd,pdlxp,pdlyp,pddpo,omask,ptho,pi_ph) ! C(k,T+dt)=(ddpo(k)*C(k,T)+w*dt*C(k-1,T+dt))/(ddpo(k)+w*dt) ! sedimentation=w*dt*C(ks,T+dt) ! -!$OMP PARALLEL DO PRIVATE(kdonor,wpoc,wpocd,wcal,wcald,wopal,wopald & +!$OMP PARALLEL DO PRIVATE(kdonor,wpoc,wpocd,wcal,wcald,wopal,wopald,wdust,wdustd & #if defined(AGG) !$OMP ,wnos,wnosd,dagg & #endif @@ -1189,29 +1225,48 @@ subroutine ocprod(kpie,kpje,kpke,kbnd,pdlxp,pdlyp,pddpo,omask,ptho,pi_ph) wnos = wnumb(i,j,k) wnosd = wnumb(i,j,kdonor) wdust = dustsink + wdustd = dustsink dagg = dustagg(i,j,k) #elif defined(WLIN) wpoc = min(wmin+wlin*ptiestu(i,j,k), wmax) wpocd = min(wmin+wlin*ptiestu(i,j,kdonor),wmax) wcald = wcal wopald = wopal + wdustd = wdust dagg = 0.0 #else wpocd = wpoc wcald = wcal wopald = wopal + wdustd = wdust dagg = 0.0 #endif + if(lm4ago)then ! superseding every other method + wpoc = ws_agg(i,j,k) + wpocd = ws_agg(i,j,kdonor) + wcal = ws_agg(i,j,k) + wcald = ws_agg(i,j,kdonor) + wopal = ws_agg(i,j,k) + wopald = ws_agg(i,j,kdonor) + wdust = ws_agg(i,j,k) + wdustd = ws_agg(i,j,kdonor) + dagg = 0.0 + endif if( k == 1 ) then wpocd = 0.0 wcald = 0.0 wopald = 0.0 + wdustd = 0.0 #if defined(AGG) wnosd = 0.0 #elif defined(WLIN) - wpoc = wmin -#endif + if (lm4ago)then + wpoc = ws_agg(i,j,k) + else + wpoc = wmin + endif +#endif endif ocetra(i,j,k,idet) = (ocetra(i,j,k ,idet) * pddpo(i,j,k) & @@ -1243,7 +1298,7 @@ subroutine ocprod(kpie,kpje,kpke,kbnd,pdlxp,pdlyp,pddpo,omask,ptho,pi_ph) & + ocetra(i,j,kdonor,iopal)*wopald)/ & & (pddpo(i,j,k)+wopal) ocetra(i,j,k,ifdust) = (ocetra(i,j,k ,ifdust) * pddpo(i,j,k) & - & + ocetra(i,j,kdonor,ifdust)*wdust)/ & + & + ocetra(i,j,kdonor,ifdust)*wdustd)/ & & (pddpo(i,j,k)+wdust) - dagg #ifdef AGG ocetra(i,j,k,iphy) = (ocetra(i,j,k ,iphy) * pddpo(i,j,k) & @@ -1412,7 +1467,11 @@ subroutine ocprod(kpie,kpje,kpke,kbnd,pdlxp,pdlyp,pddpo,omask,ptho,pi_ph) #elif defined(WLIN) wpoc = min(wmin+wlin*ptiestu(i,j,k), wmax) #endif - + if(lm4ago)then + wpoc = ws_agg(i,j,k) + wcal = ws_agg(i,j,k) + wopal = ws_agg(i,j,k) + endif #if defined(AGG) carflx0100(i,j) = (ocetra(i,j,k,idet)+ocetra(i,j,k,iphy))*rcar*wpoc #else @@ -1432,7 +1491,11 @@ subroutine ocprod(kpie,kpje,kpke,kbnd,pdlxp,pdlyp,pddpo,omask,ptho,pi_ph) #elif defined(WLIN) wpoc = min(wmin+wlin*ptiestu(i,j,k), wmax) #endif - + if(lm4ago)then + wpoc = ws_agg(i,j,k) + wcal = ws_agg(i,j,k) + wopal = ws_agg(i,j,k) + endif #if defined(AGG) carflx0500(i,j) = (ocetra(i,j,k,idet)+ocetra(i,j,k,iphy))*rcar*wpoc #else @@ -1452,7 +1515,11 @@ subroutine ocprod(kpie,kpje,kpke,kbnd,pdlxp,pdlyp,pddpo,omask,ptho,pi_ph) #elif defined(WLIN) wpoc = min(wmin+wlin*ptiestu(i,j,k), wmax) #endif - + if(lm4ago)then + wpoc = ws_agg(i,j,k) + wcal = ws_agg(i,j,k) + wopal = ws_agg(i,j,k) + endif #if defined(AGG) carflx1000(i,j) = (ocetra(i,j,k,idet)+ocetra(i,j,k,iphy))*rcar*wpoc #else @@ -1472,7 +1539,11 @@ subroutine ocprod(kpie,kpje,kpke,kbnd,pdlxp,pdlyp,pddpo,omask,ptho,pi_ph) #elif defined(WLIN) wpoc = min(wmin+wlin*ptiestu(i,j,k), wmax) #endif - + if(lm4ago)then + wpoc = ws_agg(i,j,k) + wcal = ws_agg(i,j,k) + wopal = ws_agg(i,j,k) + endif #if defined(AGG) carflx2000(i,j) = (ocetra(i,j,k,idet)+ocetra(i,j,k,iphy))*rcar*wpoc #else @@ -1492,7 +1563,11 @@ subroutine ocprod(kpie,kpje,kpke,kbnd,pdlxp,pdlyp,pddpo,omask,ptho,pi_ph) #elif defined(WLIN) wpoc = min(wmin+wlin*ptiestu(i,j,k), wmax) #endif - + if(lm4ago)then + wpoc = ws_agg(i,j,k) + wcal = ws_agg(i,j,k) + wopal = ws_agg(i,j,k) + endif #if defined(AGG) carflx4000(i,j) = (ocetra(i,j,k,idet)+ocetra(i,j,k,iphy))*rcar*wpoc #else diff --git a/hamocc/powach.F90 b/hamocc/powach.F90 index 5c7f6fbc..6251e7a4 100644 --- a/hamocc/powach.F90 +++ b/hamocc/powach.F90 @@ -17,7 +17,7 @@ ! along with BLOM. If not, see https://www.gnu.org/licenses/. -subroutine powach(kpie,kpje,kpke,kbnd,prho,omask,psao,lspin) +subroutine powach(kpie,kpje,kpke,kbnd,prho,omask,psao,ptho,lspin) !****************************************************************************** ! !**** *POWACH* - . @@ -53,6 +53,7 @@ subroutine powach(kpie,kpje,kpke,kbnd,prho,omask,psao,lspin) ! *REAL* *prho* - seawater density [g/cm^3]. ! *REAL* *psao* - salinity [psu]. ! *REAL* *omask* - land/ocean mask +! *REAL* *ptho* - potential temperature [deg C] ! ! Externals ! --------- @@ -61,8 +62,9 @@ subroutine powach(kpie,kpje,kpke,kbnd,prho,omask,psao,lspin) !****************************************************************************** use mo_carbch, only: co3,keqb,ocetra,sedfluxo use mo_chemcon, only: calcon - use mo_sedmnt, only: porwat,porsol,powtra,produs,prcaca,prorca,rno3,seddw,sedhpl,sedlay,silpro - use mo_biomod, only: rnit,ro2ut + use mo_sedmnt, only: porwat,porsol,powtra,produs,prcaca,prorca,rno3,seddw,sedhpl,sedlay,silpro,disso_sil,silsat,disso_poc, & + & sed_denit,disso_caco3 + use mo_biomod, only: rnit,ro2ut,rcar,rdnit1,rdnit2 use mo_control_bgc, only: dtbgc use mo_param1_bgc, only: ioxygen,ipowaal,ipowaic,ipowaox,ipowaph,ipowasi,ipown2,ipowno3,isilica,isssc12,issso12,issssil, & & issster, ks @@ -72,6 +74,13 @@ subroutine powach(kpie,kpje,kpke,kbnd,prho,omask,psao,lspin) use mo_param1_bgc, only: ipowc13,ipowc14,isssc13,isssc14,issso13,issso14,safediv use mo_sedmnt, only: pror13,pror14,prca13,prca14 #endif +#ifdef extNcycle + use mo_param1_bgc, only: ipownh4 + use mo_extNbioproc, only: ro2utammo + use mo_extNsediment, only: extNsediment_param_init,sed_nitrification,sed_denit_NO3_to_NO2,sed_anammox,sed_denit_DNRA, & + & extNsed_diagnostics,ised_remin_aerob,ised_remin_sulf,POM_remin_q10_sed,POM_remin_Tref_sed, & + & bkox_drempoc_sed +#endif implicit none @@ -80,6 +89,7 @@ subroutine powach(kpie,kpje,kpke,kbnd,prho,omask,psao,lspin) real, intent(in) :: prho(kpie,kpje,kpke) real, intent(in) :: omask(kpie,kpje) real, intent(in) :: psao(1-kbnd:kpie+kbnd,1-kbnd:kpje+kbnd,kpke) + real, intent(in) :: ptho(1-kbnd:kpie+kbnd,1-kbnd:kpje+kbnd,kpke) logical, intent(in) :: lspin ! Local variables @@ -87,12 +97,18 @@ subroutine powach(kpie,kpje,kpke,kbnd,prho,omask,psao,lspin) real :: sedb1(kpie,0:ks),sediso(kpie,0:ks) real :: solrat(kpie,ks),powcar(kpie,ks) - real :: aerob(kpie,ks),anaerob(kpie,ks) + real :: aerob(kpie,ks),sulf(kpie,ks) +#ifndef extNcycle + real :: anaerob(kpie,ks) +#else + real :: ex_ddic(kpie,ks),ex_dalk(kpie,ks) !sum of DIC and alk changes related to extended nitrogen cycle + real :: ex_disso_poc +#endif #ifdef cisonew - real :: aerob13(kpie,ks),anaerob13(kpie,ks) - real :: aerob14(kpie,ks),anaerob14(kpie,ks) + real :: aerob13(kpie,ks),anaerob13(kpie,ks),sulf13(kpie,ks) + real :: aerob14(kpie,ks),anaerob14(kpie,ks),sulf14(kpie,ks) #endif - real :: disso, dissot, undsa, silsat, posol + real :: dissot, undsa, posol real :: umfa, denit, saln, rrho, alk, c, sit, pt real :: K1, K2, Kb, Kw, Ks1, Kf, Ksi, K1p, K2p, K3p real :: ah1, ac, cu, cb, cc, satlev @@ -116,8 +132,13 @@ subroutine powach(kpie,kpje,kpke,kbnd,prho,omask,psao,lspin) !$OMP PARALLEL DO & -!$OMP&PRIVATE(sedb1,sediso,solrat,powcar,aerob,anaerob, & -!$OMP& disso,dissot,undsa,silsat,posol, & +!$OMP&PRIVATE(sedb1,sediso,solrat,powcar,aerob, & +#ifndef extNcycle +!$OMP& anaerob, & +#else +!$OMP& ex_dalk,ex_ddic,ex_disso_poc, & +#endif +!$OMP& dissot,undsa,posol, & !$OMP& umfa,denit,saln,rrho,alk,c,sit,pt, & !$OMP& K1,K2,Kb,Kw,Ks1,Kf,Ksi,K1p,K2p,K3p, & !$OMP& ah1,ac,cu,cb,cc,satlev,bolven, & @@ -130,13 +151,21 @@ subroutine powach(kpie,kpje,kpke,kbnd,prho,omask,psao,lspin) do i = 1, kpie solrat(i,k) = 0. powcar(i,k) = 0. +#ifndef extNcycle anaerob(i,k)= 0. +#else + ex_ddic(i,k)=0. + ex_dalk(i,j)=0. +#endif aerob(i,k) = 0. + sulf(i,k) = 0. #ifdef cisonew anaerob13(i,k)=0. aerob13(i,k) =0. + sulf13(i,k) =0. anaerob14(i,k)=0. aerob14(i,k) =0. + sulf14(i,k) =0. #endif enddo enddo @@ -158,17 +187,8 @@ subroutine powach(kpie,kpje,kpke,kbnd,prho,omask,psao,lspin) ! Calculate silicate-opal cycle and simultaneous silicate diffusion !****************************************************************** -! Dissolution rate constant of opal (disso) [1/(kmol Si(OH)4/m3)*1/sec] - -! THIS NEEDS TO BE CHANGED TO disso=3.e-8! THIS IS ONLY KEPT FOR THE MOMENT -! FOR BACKWARDS COMPATIBILITY - !disso=3.e-8 ! (2011-01-04) EMR - disso=1.e-6 ! test vom 03.03.04 half live sil ca. 20.000 yr - dissot=disso*dtbgc - -! Silicate saturation concentration is 1 mol/m3 - - silsat = 0.001 +! Dissolution rate constant of opal (disso) [1/(kmol Si(OH)4/m3)*1/sec]*dtbgc + dissot=disso_sil ! Evaluate boundary conditions for sediment-water column exchange. ! Current undersaturation of bottom water: sedb(i,0) and @@ -180,8 +200,8 @@ subroutine powach(kpie,kpje,kpke,kbnd,prho,omask,psao,lspin) sedb1(i,0) = bolay(i,j) * (silsat - ocetra(i,j,kbo(i,j),isilica)) & & * bolven(i) solrat(i,1) = ( sedlay(i,j,1,issssil) & - & + silpro(i,j) / (porsol(1) * seddw(1)) ) & - & * dissot / (1. + dissot * undsa) * porsol(1) / porwat(1) + & + silpro(i,j) / (porsol(i,j,1) * seddw(1)) ) & + & * dissot / (1. + dissot * undsa) * porsol(i,j,1) / porwat(i,j,1) endif enddo @@ -194,9 +214,9 @@ subroutine powach(kpie,kpje,kpke,kbnd,prho,omask,psao,lspin) do i = 1, kpie if(omask(i,j) > 0.5) then undsa = silsat - powtra(i,j,k,ipowasi) - sedb1(i,k) = seddw(k) * porwat(k) * (silsat - powtra(i,j,k,ipowasi)) + sedb1(i,k) = seddw(k) * porwat(i,j,k) * (silsat - powtra(i,j,k,ipowasi)) if ( k > 1 ) solrat(i,k) = sedlay(i,j,k,issssil) & - & * dissot / (1. + dissot * undsa) * porsol(k) / porwat(k) + & * dissot / (1. + dissot * undsa) * porsol(i,j,k) / porwat(i,j,k) endif enddo enddo @@ -218,7 +238,7 @@ subroutine powach(kpie,kpje,kpke,kbnd,prho,omask,psao,lspin) ocetra(i,j,kbo(i,j),isilica) = silsat - sediso(i,0) endif sedlay(i,j,1,issssil) = & - & sedlay(i,j,1,issssil) + silpro(i,j) / (porsol(1) * seddw(1)) + & sedlay(i,j,1,issssil) + silpro(i,j) / (porsol(i,j,1) * seddw(1)) endif enddo @@ -230,7 +250,7 @@ subroutine powach(kpie,kpje,kpke,kbnd,prho,omask,psao,lspin) do k = 1, ks do i = 1, kpie if(omask(i,j) > 0.5) then - umfa = porsol(k)/porwat(k) + umfa = porsol(i,j,k)/porwat(i,j,k) solrat(i,k) = sedlay(i,j,k,issssil) * dissot & & / (1. + dissot * sediso(i,k)) posol = sediso(i,k) * solrat(i,k) @@ -243,10 +263,8 @@ subroutine powach(kpie,kpje,kpke,kbnd,prho,omask,psao,lspin) ! Calculate oxygen-POC cycle and simultaneous oxygen diffusion !************************************************************* -! Degradation rate constant of POP (disso) [1/(kmol O2/m3)*1/sec] - - disso = 0.01 / 86400. ! disso=3.e-5 was quite high - dissot = disso * dtbgc +! Degradation rate constant of POP (disso) [1/(kmol O2/m3)*1/sec]*dtbgc + dissot = disso_poc ! This scheme is not based on undersaturation, but on O2 itself @@ -258,10 +276,21 @@ subroutine powach(kpie,kpje,kpke,kbnd,prho,omask,psao,lspin) if(omask(i,j) > 0.5) then undsa = powtra(i,j,1,ipowaox) sedb1(i,0) = bolay(i,j) * ocetra(i,j,kbo(i,j),ioxygen) * bolven(i) +#ifndef extNcyce solrat(i,1) = ( sedlay(i,j,1,issso12) + prorca(i,j) & - & / (porsol(1) * seddw(1)) ) & + & / (porsol(i,j,1) * seddw(1)) ) & & * ro2ut * dissot / (1. + dissot * undsa) & - & * porsol(1) / porwat(1) + & * porsol(i,j,1) / porwat(i,j,1) +#else + ! extended nitrogen cycle - 140mol O2/mol POP O2-consumption + ! O2 and T-dep + ex_disso_poc = dissot * powtra(i,j,k,ipowaox)/(powtra(i,j,k,ipowaox) + bkox_drempoc_sed) & ! oxygen limitation + & * POM_remin_q10_sed**((ptho(i,j,kbo(i,j))-POM_remin_Tref_sed)/10.) ! T-dep + solrat(i,1) = ( sedlay(i,j,1,issso12) + prorca(i,j) & + & / (porsol(i,j,1) * seddw(1)) ) & + & * ro2utammo * ex_disso_poc / (1. + ex_disso_poc * undsa) & + & * porsol(i,j,1) / porwat(i,j,1) +#endif endif enddo @@ -273,9 +302,17 @@ subroutine powach(kpie,kpje,kpke,kbnd,prho,omask,psao,lspin) do i = 1, kpie if(omask(i,j) > 0.5) then undsa = powtra(i,j,k,ipowaox) - sedb1(i,k) = seddw(k) * porwat(k) * powtra(i,j,k,ipowaox) + sedb1(i,k) = seddw(k) * porwat(i,j,k) * powtra(i,j,k,ipowaox) +#ifndef extNcycle if (k > 1) solrat(i,k) = sedlay(i,j,k,issso12) * ro2ut * dissot & - & / (1. + dissot*undsa) * porsol(k) / porwat(k) + & / (1. + dissot*undsa) * porsol(i,j,k) / porwat(i,j,k) +#else + ! extended nitrogen cycle - 140mol O2/mol POP O2-consumption + ex_disso_poc = dissot * powtra(i,j,k,ipowaox)/(powtra(i,j,k,ipowaox) + bkox_drempoc_sed) & ! oxygen limitation + & * POM_remin_q10_sed**((ptho(i,j,kbo(i,j))-POM_remin_Tref_sed)/10.) ! T-dep + if (k > 1) solrat(i,k) = sedlay(i,j,k,issso12) * ro2utammo * ex_disso_poc & + & / (1. + ex_disso_poc*undsa) * porsol(i,j,k) / porwat(i,j,k) +#endif endif enddo enddo @@ -297,12 +334,12 @@ subroutine powach(kpie,kpje,kpke,kbnd,prho,omask,psao,lspin) ocetra(i,j,kbo(i,j),ioxygen) = sediso(i,0) endif sedlay(i,j,1,issso12) = & - & sedlay(i,j,1,issso12) + prorca(i,j) / (porsol(1)*seddw(1)) + & sedlay(i,j,1,issso12) + prorca(i,j) / (porsol(i,j,1)*seddw(1)) #ifdef cisonew sedlay(i,j,1,issso13) = & - & sedlay(i,j,1,issso13) + pror13(i,j) / (porsol(1)*seddw(1)) + & sedlay(i,j,1,issso13) + pror13(i,j) / (porsol(i,j,1)*seddw(1)) sedlay(i,j,1,issso14) = & - & sedlay(i,j,1,issso14) + pror14(i,j) / (porsol(1)*seddw(1)) + & sedlay(i,j,1,issso14) + pror14(i,j) / (porsol(i,j,1)*seddw(1)) #endif endif enddo @@ -315,10 +352,15 @@ subroutine powach(kpie,kpje,kpke,kbnd,prho,omask,psao,lspin) do k = 1, ks do i = 1, kpie if(omask(i,j) > 0.5) then - umfa = porsol(k) / porwat(k) + umfa = porsol(i,j,k) / porwat(i,j,k) +#ifndef extNcycle solrat(i,k) = sedlay(i,j,k,issso12) * dissot/(1. + dissot*sediso(i,k)) +#else + ex_disso_poc = dissot * powtra(i,j,k,ipowaox)/(powtra(i,j,k,ipowaox) + bkox_drempoc_sed) & ! oxygen limitation + & * POM_remin_q10_sed**((ptho(i,j,kbo(i,j))-POM_remin_Tref_sed)/10.) ! T-dep + solrat(i,k) = sedlay(i,j,k,issso12) * ex_disso_poc/(1. + ex_disso_poc*sediso(i,k)) +#endif posol = sediso(i,k)*solrat(i,k) - aerob(i,k) = posol*umfa !this has P units: kmol P/m3 of pore water #ifdef cisonew rato13 = sedlay(i,j,k,issso13) / (sedlay(i,j,k,issso12) + safediv) rato14 = sedlay(i,j,k,issso14) / (sedlay(i,j,k,issso12) + safediv) @@ -329,14 +371,19 @@ subroutine powach(kpie,kpje,kpke,kbnd,prho,omask,psao,lspin) #endif sedlay(i,j,k,issso12) = sedlay(i,j,k,issso12) - posol powtra(i,j,k,ipowaph) = powtra(i,j,k,ipowaph) + posol*umfa +#ifndef extNcycle powtra(i,j,k,ipowno3) = powtra(i,j,k,ipowno3) + posol*rnit*umfa + aerob(i,k) = posol*umfa !this has P units: kmol P/m3 of pore water +#else + powtra(i,j,k,ipownh4) = powtra(i,j,k,ipownh4) + posol*rnit*umfa + ex_ddic(i,k) = rcar*posol*umfa ! C-units kmol C/m3 of pore water + ex_dalk(i,k) = (rnit-1.)*posol*umfa ! alkalinity units + extNsed_diagnostics(i,j,k,ised_remin_aerob) = posol*rnit*umfa ! Output +#endif powtra(i,j,k,ipowaox) = sediso(i,k) #ifdef cisonew sedlay(i,j,k,issso13) = sedlay(i,j,k,issso13) - poso13 sedlay(i,j,k,issso14) = sedlay(i,j,k,issso14) - poso14 - ! is this correct? no correspondance in the lines above - powtra(i,j,k,ipowc13) = powtra(i,j,k,ipowc13) + poso13*umfa - powtra(i,j,k,ipowc14) = powtra(i,j,k,ipowc14) + poso14*umfa #endif endif enddo @@ -344,19 +391,18 @@ subroutine powach(kpie,kpje,kpke,kbnd,prho,omask,psao,lspin) ! Calculate nitrate reduction under anaerobic conditions explicitely !******************************************************************* +#ifndef extNcycle + ! Denitrification rate constant of POP (disso) [1/sec] + denit = sed_denit -! Denitrification rate constant of POP (disso) [1/sec] -! Store flux in array anaerob, for later computation of DIC and alkalinity. - -!ik denit = 1.e-6*dtbgc - denit = 0.01/86400. *dtbgc + ! Store flux in array anaerob, for later computation of DIC and alkalinity. do k = 1, ks do i = 1, kpie if(omask(i,j) > 0.5) then if(powtra(i,j,k,ipowaox) < 1.e-6) then - posol = denit * MIN(0.5*powtra(i,j,k,ipowno3)/114., & + posol = denit * MIN(0.25*powtra(i,j,k,ipowno3)/rdnit2, & & sedlay(i,j,k,issso12)) - umfa = porsol(k)/porwat(k) + umfa = porsol(i,j,k)/porwat(i,j,k) anaerob(i,k) = posol*umfa !this has P units: kmol P/m3 of pore water #ifdef cisonew rato13 = sedlay(i,j,k,issso13) / (sedlay(i,j,k,issso12) + safediv) @@ -368,19 +414,23 @@ subroutine powach(kpie,kpje,kpke,kbnd,prho,omask,psao,lspin) #endif sedlay(i,j,k,issso12) = sedlay(i,j,k,issso12) - posol powtra(i,j,k,ipowaph) = powtra(i,j,k,ipowaph) + posol*umfa - powtra(i,j,k,ipowno3) = powtra(i,j,k,ipowno3) - 98.*posol*umfa - powtra(i,j,k,ipown2) = powtra(i,j,k,ipown2) + 57.*posol*umfa + powtra(i,j,k,ipowno3) = powtra(i,j,k,ipowno3) - rdnit1*posol*umfa + powtra(i,j,k,ipown2) = powtra(i,j,k,ipown2) + rdnit2*posol*umfa #ifdef cisonew sedlay(i,j,k,issso13) = sedlay(i,j,k,issso13) - poso13 sedlay(i,j,k,issso14) = sedlay(i,j,k,issso14) - poso14 - ! is this correct? no corresponance in the lines above - powtra(i,j,k,ipowc13) = powtra(i,j,k,ipowc13) + poso13*umfa - powtra(i,j,k,ipowc14) = powtra(i,j,k,ipowc14) + poso14*umfa #endif endif endif enddo enddo +#else + !======>>>> extended nitrogen cycle processes (aerobic and anaerobic) that follow ammonification + CALL sed_nitrification(j,kpie,kpje,kpke,kbnd,ptho,omask,ex_ddic,ex_dalk) + CALL sed_denit_NO3_to_NO2(j,kpie,kpje,kpke,kbnd,ptho,omask,ex_ddic,ex_dalk) + CALL sed_anammox(j,kpie,kpje,kpke,kbnd,ptho,omask,ex_ddic,ex_dalk) + CALL sed_denit_dnra(j,kpie,kpje,kpke,kbnd,ptho,omask,ex_ddic,ex_dalk) +#endif ! sulphate reduction in sediments @@ -389,16 +439,15 @@ subroutine powach(kpie,kpje,kpke,kbnd,prho,omask,psao,lspin) if(omask(i,j) > 0.5) then if(powtra(i,j,k,ipowaox) < 3.e-6 .and. powtra(i,j,k,ipowno3) < 3.e-6) then posol = denit * sedlay(i,j,k,issso12) ! remineralization of poc - umfa = porsol(k) / porwat(k) - !this overwrites anaerob from denitrification. added =anaerob+..., works - anaerob(i,k) = anaerob(i,k) + posol*umfa !this has P units: kmol P/m3 of pore water + umfa = porsol(i,j,k) / porwat(i,j,k) + sulf(i,k) = posol*umfa !this has P units: kmol P/m3 of pore water #ifdef cisonew rato13 = sedlay(i,j,k,issso13) / (sedlay(i,j,k,issso12)+safediv) rato14 = sedlay(i,j,k,issso14) / (sedlay(i,j,k,issso12)+safediv) poso13 = posol * rato13 poso14 = posol * rato14 - anaerob13(i,k) = anaerob13(i,k) + poso13*umfa !this has P units: kmol P/m3 of pore water - anaerob14(i,k) = anaerob13(i,k) + poso14*umfa !this has P units: kmol P/m3 of pore water + sulf13(i,k) = poso13*umfa !this has P units: kmol P/m3 of pore water + sulf14(i,k) = poso14*umfa !this has P units: kmol P/m3 of pore water #endif sedlay(i,j,k,issso12) = sedlay(i,j,k,issso12) - posol powtra(i,j,k,ipowaph) = powtra(i,j,k,ipowaph) + posol*umfa @@ -406,6 +455,9 @@ subroutine powach(kpie,kpje,kpke,kbnd,prho,omask,psao,lspin) #ifdef cisonew sedlay(i,j,k,issso13) = sedlay(i,j,k,issso13) - poso13 sedlay(i,j,k,issso14) = sedlay(i,j,k,issso14) - poso14 +#endif +#ifdef extNcycle + extNsed_diagnostics(i,j,k,ised_remin_sulf) = posol*umfa ! Output #endif endif endif @@ -426,8 +478,13 @@ subroutine powach(kpie,kpje,kpke,kbnd,prho,omask,psao,lspin) if(omask(i,j) > 0.5) then saln= min( 40., max( 0., psao(i,j,kbo(i,j)))) rrho= prho(i,j,kbo(i,j)) - alk = (powtra(i,j,k,ipowaal) - (anaerob(i,k)+aerob(i,k))*16.) / rrho - c = (powtra(i,j,k,ipowaic) + (anaerob(i,k)+aerob(i,k))*122.) / rrho +#ifdef extNcycle + alk = (powtra(i,j,k,ipowaal) - (sulf(i,k)+aerob(i,k))*(rnit+1.) + ex_dalk(i,k)) / rrho + c = (powtra(i,j,k,ipowaic) + (aerob(i,k)+sulf(i,k))*rcar + ex_ddic(i,k)) / rrho +#else + alk = (powtra(i,j,k,ipowaal) - (sulf(i,k)+aerob(i,k))*(rnit+1.) + anaerob(i,k)*(rdnit1-1.)) / rrho + c = (powtra(i,j,k,ipowaic) + (anaerob(i,k)+aerob(i,k)+sulf(i,k))*rcar) / rrho +#endif sit = powtra(i,j,k,ipowasi) / rrho pt = powtra(i,j,k,ipowaph) / rrho ah1 = sedhpl(i,j,k) @@ -456,9 +513,8 @@ subroutine powach(kpie,kpje,kpke,kbnd,prho,omask,psao,lspin) enddo -! Dissolution rate constant of CaCO3 (disso) [1/(kmol CO3--/m3)*1/sec] - disso = 1.e-7 - dissot = disso * dtbgc +! Dissolution rate constant of CaCO3 (disso) [1/(kmol CO3--/m3)*1/sec]*dtbgc + dissot = disso_caco3 ! Evaluate boundary conditions for sediment-water column exchange. ! Current undersaturation of bottom water: sedb(i,0) and @@ -473,8 +529,8 @@ subroutine powach(kpie,kpje,kpke,kbnd,prho,omask,psao,lspin) undsa = MAX( satlev-powcar(i,1), 0. ) sedb1(i,0) = bolay(i,j) * (satlev-co3(i,j,kbo(i,j))) * bolven(i) solrat(i,1) = (sedlay(i,j,1,isssc12) & - & + prcaca(i,j) / (porsol(1)*seddw(1))) & - & * dissot / (1.+dissot*undsa) * porsol(1) / porwat(1) + & + prcaca(i,j) / (porsol(i,j,1)*seddw(1))) & + & * dissot / (1.+dissot*undsa) * porsol(i,j,1) / porwat(i,j,1) endif enddo @@ -486,9 +542,9 @@ subroutine powach(kpie,kpje,kpke,kbnd,prho,omask,psao,lspin) do i = 1, kpie if(omask(i,j) > 0.5) then undsa = MAX( keqb(11,i,j) / calcon - powcar(i,k), 0. ) - sedb1(i,k) = seddw(k) * porwat(k) * undsa + sedb1(i,k) = seddw(k) * porwat(i,j,k) * undsa if (k > 1) solrat(i,k) = sedlay(i,j,k,isssc12) & - & * dissot/(1.+dissot*undsa) * porsol(k)/porwat(k) + & * dissot/(1.+dissot*undsa) * porsol(i,j,k)/porwat(i,j,k) if (undsa <= 0.) solrat(i,k) = 0. endif enddo @@ -504,12 +560,12 @@ subroutine powach(kpie,kpje,kpke,kbnd,prho,omask,psao,lspin) do i = 1, kpie if(omask(i,j) > 0.5) then sedlay(i,j,1,isssc12) = & - & sedlay(i,j,1,isssc12) + prcaca(i,j) / (porsol(1)*seddw(1)) + & sedlay(i,j,1,isssc12) + prcaca(i,j) / (porsol(i,j,1)*seddw(1)) #ifdef cisonew sedlay(i,j,1,isssc13) = & - & sedlay(i,j,1,isssc13) + prca13(i,j) / (porsol(1)*seddw(1)) + & sedlay(i,j,1,isssc13) + prca13(i,j) / (porsol(i,j,1)*seddw(1)) sedlay(i,j,1,isssc14) = & - & sedlay(i,j,1,isssc14) + prca14(i,j) / (porsol(1)*seddw(1)) + & sedlay(i,j,1,isssc14) + prca14(i,j) / (porsol(i,j,1)*seddw(1)) #endif endif enddo @@ -523,7 +579,7 @@ subroutine powach(kpie,kpje,kpke,kbnd,prho,omask,psao,lspin) do k = 1, ks do i = 1, kpie if(omask(i,j) > 0.5) then - umfa = porsol(k) / porwat(k) + umfa = porsol(i,j,k) / porwat(i,j,k) solrat(i,k) = sedlay(i,j,k,isssc12) & & * dissot / (1. + dissot * sediso(i,k)) posol = sediso(i,k) * solrat(i,k) @@ -534,17 +590,24 @@ subroutine powach(kpie,kpje,kpke,kbnd,prho,omask,psao,lspin) poso14 = posol * ratc14 #endif sedlay(i,j,k,isssc12) = sedlay(i,j,k,isssc12) - posol +#ifdef extNcycle + powtra(i,j,k,ipowaic) = powtra(i,j,k,ipowaic) & + & + posol * umfa + (aerob(i,k) + sulf(i,k)) * rcar + ex_ddic(i,k) + powtra(i,j,k,ipowaal) = powtra(i,j,k,ipowaal) & + & + 2. * posol * umfa - (rnit+1.)*(aerob(i,k) + sulf(i,k)) + ex_dalk(i,k) +#else powtra(i,j,k,ipowaic) = powtra(i,j,k,ipowaic) & - & + posol * umfa + (aerob(i,k) + anaerob(i,k)) * 122. + & + posol * umfa + (aerob(i,k) + anaerob(i,k) + sulf(i,k)) * rcar powtra(i,j,k,ipowaal) = powtra(i,j,k,ipowaal) & - & + 2. * posol * umfa - 16. * (aerob(i,k) + anaerob(i,k)) + & + 2. * posol * umfa - (rnit+1.)*(aerob(i,k) + sulf(i,k)) + (rdnit1-1.)*anaerob(i,k) +#endif #ifdef cisonew sedlay(i,j,k,isssc13) = sedlay(i,j,k,isssc13) - poso13 sedlay(i,j,k,isssc14) = sedlay(i,j,k,isssc14) - poso14 powtra(i,j,k,ipowc13) = powtra(i,j,k,ipowc13) + poso13 * umfa & - & + (aerob13(i,k) + anaerob13(i,k)) * 122. + & + (aerob13(i,k) + anaerob13(i,k) + sulf13(i,k)) * rcar powtra(i,j,k,ipowc14) = powtra(i,j,k,ipowc14) + poso14 * umfa & - & + (aerob14(i,k) + anaerob14(i,k)) * 122. + & + (aerob14(i,k) + anaerob14(i,k) + sulf14(i,k)) * rcar #endif endif enddo @@ -565,7 +628,7 @@ subroutine powach(kpie,kpje,kpke,kbnd,prho,omask,psao,lspin) do j = 1, kpje do i = 1, kpie sedlay(i,j,1,issster) = sedlay(i,j,1,issster) & - & + produs(i,j) / (porsol(1) * seddw(1)) + & + produs(i,j) / (porsol(i,j,1) * seddw(1)) enddo enddo !$OMP END PARALLEL DO diff --git a/hamocc/powadi.F90 b/hamocc/powadi.F90 index a5828d91..413c3046 100644 --- a/hamocc/powadi.F90 +++ b/hamocc/powadi.F90 @@ -76,21 +76,21 @@ subroutine powadi(j,kpie,kpje,solrat,sedb1,sediso,bolven,omask) !********************************************************************** do k = 1, ks - asu = sedict * seddzi(k) * porwah(k) - alo = 0. - if(k < ks) alo = sedict * seddzi(k+1) * porwah(k+1) do i = 1, kpie + asu = sedict * seddzi(k) * porwah(i,j,k) + alo = 0. + if(k < ks) alo = sedict * seddzi(k+1) * porwah(i,j,k+1) tredsy(i,k,1) = -asu tredsy(i,k,3) = -alo - tredsy(i,k,2) = seddw(k) * porwat(k) - tredsy(i,k,1) & - & - tredsy(i,k,3) + solrat(i,k) * porwat(k) * seddw(k) + tredsy(i,k,2) = seddw(k) * porwat(i,j,k) - tredsy(i,k,1) & + & - tredsy(i,k,3) + solrat(i,k) * porwat(i,j,k) * seddw(k) enddo enddo k = 0 asu = 0. - alo = sedict * seddzi(1) * porwah(1) do i = 1, kpie + alo = sedict * seddzi(1) * porwah(i,j,1) if(omask(i,j) > 0.5) then tredsy(i,k,1) = -asu tredsy(i,k,3) = -alo diff --git a/hamocc/preftrc.F90 b/hamocc/preftrc.F90 index 34a9161c..a33280d1 100644 --- a/hamocc/preftrc.F90 +++ b/hamocc/preftrc.F90 @@ -16,7 +16,7 @@ ! along with BLOM. If not, see https://www.gnu.org/licenses/. - SUBROUTINE PREFTRC(kpie,kpje,omask) +SUBROUTINE PREFTRC(kpie,kpje,omask) !**************************************************************** ! !**** *PREFTRC* - update preformed tracers in the mixed layer. @@ -43,31 +43,27 @@ SUBROUTINE PREFTRC(kpie,kpje,omask) ! !************************************************************************** - use mo_carbch, only: ocetra - use mo_param1_bgc, only: ialkali,ioxygen,iphosph,iprefalk,iprefdic,iprefo2,iprefpo4,isco212 - use mo_vgrid, only: kmle + use mo_carbch, only: ocetra + use mo_param1_bgc, only: ialkali,ioxygen,iphosph,iprefalk,iprefdic,iprefo2,iprefpo4,isco212 + use mo_vgrid, only: kmle - implicit none + implicit none - INTEGER :: kpie,kpje - REAL :: omask(kpie,kpje) + INTEGER :: kpie,kpje + REAL :: omask(kpie,kpje) - INTEGER :: i,j,k + INTEGER :: i,j - do k=1,kmle -!$OMP PARALLEL DO PRIVATE(i) - do j=1,kpje - do i=1,kpie + do j=1,kpje + do i=1,kpie if (omask(i,j) .gt. 0.5 ) then - ocetra(i,j,k,iprefo2) =ocetra(i,j,k,ioxygen) - ocetra(i,j,k,iprefpo4)=ocetra(i,j,k,iphosph) - ocetra(i,j,k,iprefalk)=ocetra(i,j,k,ialkali) - ocetra(i,j,k,iprefdic)=ocetra(i,j,k,isco212) + ocetra(i,j,1:kmle(i,j),iprefo2) = ocetra(i,j,1:kmle(i,j),ioxygen) + ocetra(i,j,1:kmle(i,j),iprefpo4) = ocetra(i,j,1:kmle(i,j),iphosph) + ocetra(i,j,1:kmle(i,j),iprefalk) = ocetra(i,j,1:kmle(i,j),ialkali) + ocetra(i,j,1:kmle(i,j),iprefdic) = ocetra(i,j,1:kmle(i,j),isco212) endif - enddo - enddo -!$OMP END PARALLEL DO - enddo + enddo + enddo - END SUBROUTINE PREFTRC +END SUBROUTINE PREFTRC diff --git a/hamocc/read_netcdf_var.F90 b/hamocc/read_netcdf_var.F90 index 8befec8e..90b56067 100644 --- a/hamocc/read_netcdf_var.F90 +++ b/hamocc/read_netcdf_var.F90 @@ -26,6 +26,9 @@ SUBROUTINE READ_NETCDF_VAR(ncid,desc,arr,klev,time,typeio) !************************************************************************** use netcdf, only: nf90_noerr,nf90_inq_varid,nf90_strerror,nf90_get_var use mod_xc, only: idm,itdm,jtdm,jdm,lp,mnproc,nbdy,xchalt,xcaput +#ifdef PNETCDF + use mod_xc, only: i0,ii,jj,j0 +#endif implicit none #ifdef PNETCDF #include diff --git a/hamocc/restart_hamoccwt.F b/hamocc/restart_hamoccwt.F deleted file mode 100644 index 1c152d27..00000000 --- a/hamocc/restart_hamoccwt.F +++ /dev/null @@ -1,37 +0,0 @@ -c Copyright (C) 2020 K. Assmann, J. Tjiputra, J. Schwinger, M. Bentsen -c -c This file is part of BLOM/iHAMOCC. -c -c BLOM is free software: you can redistribute it and/or modify it under the -c terms of the GNU Lesser General Public License as published by the Free -c Software Foundation, either version 3 of the License, or (at your option) -c any later version. -c -c BLOM is distributed in the hope that it will be useful, but WITHOUT ANY -c WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS -c FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for -c more details. -c -c You should have received a copy of the GNU Lesser General Public License -c along with BLOM. If not, see https://www.gnu.org/licenses/. - - - subroutine restart_hamoccwt(rstfnm_ocn) -c -c write restart for HAMOCC -c - use mod_time, only: date,nstep - use mod_xc, only: idm,jdm,kdm - use mod_tracers, only: ntrbgc,ntr,itrbgc,trc - use mo_intfcblom, only: omask -c - implicit none -c - character(len=*) :: rstfnm_ocn - - CALL AUFW_BGC(idm,jdm,kdm,ntr,ntrbgc,itrbgc,trc - . ,date%year,date%month,date%day,nstep,omask - . ,rstfnm_ocn) -c - return - end diff --git a/hamocc/restart_hamoccwt.F90 b/hamocc/restart_hamoccwt.F90 new file mode 100644 index 00000000..728e2b5b --- /dev/null +++ b/hamocc/restart_hamoccwt.F90 @@ -0,0 +1,36 @@ +! Copyright (C) 2020 K. Assmann, J. Tjiputra, J. Schwinger, M. Bentsen +! +! This file is part of BLOM/iHAMOCC. +! +! 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 https://www.gnu.org/licenses/. + + +subroutine restart_hamoccwt(rstfnm_ocn) +! +! write restart for HAMOCC +! + use mod_time, only: date,nstep + use mod_xc, only: idm,jdm,kdm + use mod_tracers, only: ntrbgc,ntr,itrbgc,trc + use mo_intfcblom, only: omask + + implicit none + + character(len=*) :: rstfnm_ocn + + CALL AUFW_BGC(idm,jdm,kdm,ntr,ntrbgc,itrbgc,trc & + & ,date%year,date%month,date%day,nstep,omask & + & ,rstfnm_ocn) + +end subroutine restart_hamoccwt diff --git a/hamocc/sedshi.F90 b/hamocc/sedshi.F90 index 51eea483..c5c7bf3c 100644 --- a/hamocc/sedshi.F90 +++ b/hamocc/sedshi.F90 @@ -53,7 +53,8 @@ SUBROUTINE SEDSHI(kpie,kpje,omask) use mo_sedmnt, only: burial,calfa,clafa,oplfa,orgfa,porsol,sedlay,seddw,solfu use mo_biomod, only: rcar - use mo_param1_bgc, only: isssc12,issssil,issso12,issster,ks,nsedtra + use mo_param1_bgc, only: isssc12,issssil,issso12,issster,ks,nsedtra + use mo_carbch, only: sedfluxb #ifdef cisonew use mo_param1_bgc, only: isssc13,isssc14,issso13,issso14 #endif @@ -65,6 +66,8 @@ SUBROUTINE SEDSHI(kpie,kpje,omask) REAL :: sedlo,uebers,seddef,spresent,buried REAL :: refill,frac + + sedfluxb(:,:,:) = 0. ! DOWNWARD SHIFTING ! shift solid sediment sediment downwards, if layer is full, i.e., if ! the volume filled by the four constituents poc, opal, caco3, clay @@ -100,7 +103,7 @@ SUBROUTINE SEDSHI(kpie,kpje,omask) uebers=wsed(i,j)*sedlay(i,j,k,iv) sedlay(i,j,k ,iv)=sedlay(i,j,k ,iv)-uebers sedlay(i,j,k+1,iv)=sedlay(i,j,k+1,iv)+uebers & - & *(seddw(k)*porsol(k))/(seddw(k+1)*porsol(k+1)) + & *(seddw(k)*porsol(i,j,k))/(seddw(k+1)*porsol(i,j,k+1)) endif enddo !end i-loop enddo !end j-loop @@ -138,9 +141,10 @@ SUBROUTINE SEDSHI(kpie,kpje,omask) do i=1,kpie if(omask(i,j).gt.0.5) then !ka if(bolay(i,j).gt.0.) then - uebers=wsed(i,j)*sedlay(i,j,k,iv) + uebers=wsed(i,j)*sedlay(i,j,ks,iv) sedlay(i,j,ks ,iv)=sedlay(i,j,ks ,iv)-uebers - burial(i,j,iv)=burial(i,j,iv)+uebers*seddw(k)*porsol(k) + burial(i,j,iv)=burial(i,j,iv)+uebers*seddw(ks)*porsol(i,j,ks) + sedfluxb(i,j,iv) = uebers*seddw(ks)*porsol(i,j,ks) endif enddo !end i-loop enddo !end j-loop @@ -178,7 +182,7 @@ SUBROUTINE SEDSHI(kpie,kpje,omask) & +calfa*sedlay(i,j,k,isssc12) & & +oplfa*sedlay(i,j,k,issssil) & & +clafa*sedlay(i,j,k,issster) - fulsed(i,j)=fulsed(i,j)+porsol(k)*seddw(k)*sedlo + fulsed(i,j)=fulsed(i,j)+porsol(i,j,k)*seddw(k)*sedlo endif enddo !end i-loop enddo !end j-loop @@ -197,7 +201,7 @@ SUBROUTINE SEDSHI(kpie,kpje,omask) ! deficiency to fully loaded sediment packed in sedlay(i,j,ks) ! this is the volume required from the buried layer - seddef=solfu-fulsed(i,j) + seddef=solfu(i,j)-fulsed(i,j) ! total volume of solid constituents in buried layer spresent=orgfa*rcar*burial(i,j,issso12) & @@ -219,7 +223,7 @@ SUBROUTINE SEDSHI(kpie,kpje,omask) ! fill the last active layer refill=seddef/(buried+1.e-10) - frac = porsol(ks)*seddw(ks) !changed k to ks, ik + frac = porsol(i,j,ks)*seddw(ks) sedlay(i,j,ks,issso12)=sedlay(i,j,ks,issso12) & & +refill*burial(i,j,issso12)/frac @@ -240,6 +244,13 @@ SUBROUTINE SEDSHI(kpie,kpje,omask) burial(i,j,issster) = burial(i,j,issster) & & - refill*burial(i,j,issster) +! account for refluxes to get net-burial fluxes: +! note that this (and before) assumes no reflux of isotopes! - up to change? + sedfluxb(i,j,issso12) = sedfluxb(i,j,issso12) - refill*burial(i,j,issso12) + sedfluxb(i,j,isssc12) = sedfluxb(i,j,isssc12) - refill*burial(i,j,isssc12) + sedfluxb(i,j,issssil) = sedfluxb(i,j,issssil) - refill*burial(i,j,issssil) + sedfluxb(i,j,issster) = sedfluxb(i,j,issster) - refill*burial(i,j,issster) + endif enddo !end i-loop enddo !end j-loop @@ -269,7 +280,7 @@ SUBROUTINE SEDSHI(kpie,kpje,omask) if(omask(i,j).gt.0.5) then !ka if(bolay(i,j).gt.0.) then uebers=sedlay(i,j,k,iv)*wsed(i,j) - frac=porsol(k)*seddw(k)/(porsol(k-1)*seddw(k-1)) + frac=porsol(i,j,k)*seddw(k)/(porsol(i,j,k-1)*seddw(k-1)) sedlay(i,j,k,iv)=sedlay(i,j,k,iv)-uebers sedlay(i,j,k-1,iv)=sedlay(i,j,k-1,iv)+uebers*frac #ifdef cisonew diff --git a/hamocc/trc_limitc.F b/hamocc/trc_limitc.F deleted file mode 100644 index 7e30aa77..00000000 --- a/hamocc/trc_limitc.F +++ /dev/null @@ -1,136 +0,0 @@ -c Copyright (C) 2020 J. Schwinger, M. Bentsen -c -c This file is part of BLOM/iHAMOCC. -c -c BLOM is free software: you can redistribute it and/or modify it under the -c terms of the GNU Lesser General Public License as published by the Free -c Software Foundation, either version 3 of the License, or (at your option) -c any later version. -c -c BLOM is distributed in the hope that it will be useful, but WITHOUT ANY -c WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS -c FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for -c more details. -c -c You should have received a copy of the GNU Lesser General Public License -c along with BLOM. If not, see https://www.gnu.org/licenses/. - - - subroutine trc_limitc(nn) -c*********************************************************************** -c -c**** *SUBROUTINE trc_limitc* - remove negative tracer values. -c -c J. Schwinger *GFI, UiB initial version, 2014-06-17 -c - -c -c Modified -c -------- -c J.Schwinger, *Uni Research, Bergen* 2018-04-12 -c - fixed a bug related to the 2 time-level scheme -c -c -c -c Purpose -c ------- -c Remove negative tracer values in the first layer in a mass -c conservative fashion (i.e. the mass deficit removed is -c transfered to non-negative points by a multiplicative -c correction). This is done since the virtual tracer fluxes -c (applied in mxlayr.F directly before HAMOCC is called) can -c cause negative tracer values in regions with low concentration -c and strong precipitation. -c -c*********************************************************************** -c - use mod_xc, only: ii,jj,ips,ifp,isp,ilp,xcsum - use mod_grid, only: scp2 - use mod_state, only: dp - use mod_tracers, only: ntrbgc, itrbgc, trc - use mod_utility, only: util1 -c - implicit none -c - integer :: nn - integer :: i,j,l,nt,kn - real :: trbudo(ntrbgc),trbudn,q -c -c --- ------------------------------------------------------------------ -c --- - compute tracer budgets before removing negative values -c --- ------------------------------------------------------------------ -c - kn=1+nn -c - do nt=1,ntrbgc -c - util1(:,:)=0. -c -c$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)) - util1(i,j)=util1(i,j) - . +trc(i,j,kn,itrbgc+nt-1)*dp(i,j,kn)*scp2(i,j) - enddo - enddo - enddo -c$OMP END PARALLEL DO -c - call xcsum(trbudo(nt),util1,ips) -c - enddo -c -c -c --- ------------------------------------------------------------------ -c --- - remove negative tracer values in the surface layer -c --- ------------------------------------------------------------------ -c -c$OMP PARALLEL DO PRIVATE(j,l,i) - do nt=itrbgc,itrbgc+ntrbgc-1 - do j=1,jj - do l=1,isp(j) - do i=max(1,ifp(j,l)),min(ii,ilp(j,l)) - trc(i,j,kn,nt) = max(trc(i,j,kn,nt),0.0) - enddo - enddo - enddo - enddo -c$OMP END PARALLEL DO -c -c -c --- ------------------------------------------------------------------ -c --- - recalculate and correct tracer budgets -c --- ------------------------------------------------------------------ -c - do nt=1,ntrbgc -c - util1(:,:)=0. -c -c$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)) - util1(i,j)=util1(i,j) - . +trc(i,j,kn,itrbgc+nt-1)*dp(i,j,kn)*scp2(i,j) - enddo - enddo - enddo -c$OMP END PARALLEL DO -c - call xcsum(trbudn,util1,ips) - q=trbudo(nt)/max(1.e-14,trbudn) -c -c$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)) - trc(i,j,kn,itrbgc+nt-1) = trc(i,j,kn,itrbgc+nt-1)*q - enddo - enddo - enddo -c$OMP END PARALLEL DO -c - enddo -c - return - end diff --git a/hamocc/trc_limitc.F90 b/hamocc/trc_limitc.F90 new file mode 100644 index 00000000..51815398 --- /dev/null +++ b/hamocc/trc_limitc.F90 @@ -0,0 +1,132 @@ +! Copyright (C) 2020 J. Schwinger, M. Bentsen +! +! This file is part of BLOM/iHAMOCC. +! +! 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 https://www.gnu.org/licenses/. + + +subroutine trc_limitc(nn) +!*********************************************************************** +! +!**** *SUBROUTINE trc_limitc* - remove negative tracer values. +! +! J. Schwinger *GFI, UiB initial version, 2014-06-17 +! - +! +! Modified +! -------- +! J.Schwinger, *Uni Research, Bergen* 2018-04-12 +! - fixed a bug related to the 2 time-level scheme +! +! +! +! Purpose +! ------- +! Remove negative tracer values in the first layer in a mass +! conservative fashion (i.e. the mass deficit removed is +! transfered to non-negative points by a multiplicative +! correction). This is done since the virtual tracer fluxes +! (applied in mxlayr.F directly before HAMOCC is called) can +! cause negative tracer values in regions with low concentration +! and strong precipitation. +! +!*********************************************************************** + use mod_xc, only: ii,jj,ips,ifp,isp,ilp,xcsum + use mod_grid, only: scp2 + use mod_state, only: dp + use mod_tracers, only: ntrbgc, itrbgc, trc + use mod_utility, only: util1 + + implicit none + + integer :: nn + integer :: i,j,l,nt,kn + real :: trbudo(ntrbgc),trbudn,q + + ! --- ------------------------------------------------------------------ + ! --- - compute tracer budgets before removing negative values + ! --- ------------------------------------------------------------------ + + kn=1+nn + + do nt=1,ntrbgc + + util1(:,:)=0. + +!$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)) + util1(i,j) = util1(i,j) & + & +trc(i,j,kn,itrbgc+nt-1)*dp(i,j,kn)*scp2(i,j) + enddo + enddo + enddo +!$OMP END PARALLEL DO + + call xcsum(trbudo(nt),util1,ips) + + enddo + + ! --- ------------------------------------------------------------------ + ! --- - remove negative tracer values in the surface layer + ! --- ------------------------------------------------------------------ + +!$OMP PARALLEL DO PRIVATE(j,l,i) + do nt=itrbgc,itrbgc+ntrbgc-1 + do j=1,jj + do l=1,isp(j) + do i=max(1,ifp(j,l)),min(ii,ilp(j,l)) + trc(i,j,kn,nt) = max(trc(i,j,kn,nt),0.0) + enddo + enddo + enddo + enddo +!$OMP END PARALLEL DO + + ! --- ------------------------------------------------------------------ + ! --- - recalculate and correct tracer budgets + ! --- ------------------------------------------------------------------ + + do nt=1,ntrbgc + + util1(:,:)=0. + +!$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)) + util1(i,j) = util1(i,j) & + & +trc(i,j,kn,itrbgc+nt-1)*dp(i,j,kn)*scp2(i,j) + enddo + enddo + enddo +!$OMP END PARALLEL DO + + call xcsum(trbudn,util1,ips) + q = trbudo(nt)/max(1.e-14,trbudn) + +!$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)) + trc(i,j,kn,itrbgc+nt-1) = trc(i,j,kn,itrbgc+nt-1)*q + enddo + enddo + enddo +!$OMP END PARALLEL DO + + enddo + +end subroutine trc_limitc diff --git a/hamocc/write_netcdf_var.F90 b/hamocc/write_netcdf_var.F90 index af15b90b..d07eb4f5 100644 --- a/hamocc/write_netcdf_var.F90 +++ b/hamocc/write_netcdf_var.F90 @@ -27,6 +27,9 @@ SUBROUTINE WRITE_NETCDF_VAR(ncid,desc,arr,klev,time) use netcdf, only: nf90_noerr,nf90_inq_varid,nf90_strerror,nf90_put_var use mod_xc, only: itdm,jtdm,jdm,lp,mnproc,nbdy,idm,xchalt,xcaget use mod_dia, only: iotype +#ifdef PNETCDF + use mod_xc, only: i0,ii,jj,j0,mproc,mpe_1,nproc,xcgetrow +#endif implicit none #ifdef PNETCDF # include diff --git a/meson.build b/meson.build index 29d7e81e..a952f7f0 100644 --- a/meson.build +++ b/meson.build @@ -67,31 +67,42 @@ subdir('cesm') subdir('fuk95') subdir('channel') subdir('single_column') +subdir('pkgs/') # Handle options and add necessary flags and subfolders with source files -if get_option('iage') or get_option('turbclo').length() > 0 or get_option('ecosys') +if get_option('mks') + add_project_arguments('-DMKS', language: 'fortran') +endif + +turbclo = get_option('turbclo') +if turbclo.length() > 0 and get_option('vcoord') == 'cntiso_hybrid' + message('Setting turbclo = [] for vcoord == \'cntiso_hybrid\'') + turbclo = [] +endif + +if get_option('iage') or turbclo.length() > 0 or get_option('ecosys') add_project_arguments('-DTRC', language: 'fortran') subdir('trc') endif -if get_option('turbclo').length() > 0 - if not (get_option('turbclo').contains('oneeq') or get_option('turbclo').contains('twoeq')) +if turbclo.length() > 0 + if not (turbclo.contains('oneeq') or turbclo.contains('twoeq')) error('For turbulent closure, either twoeq or oneeq must be provided as options!') endif - if get_option('turbclo').contains('oneeq') and get_option('turbclo').contains('twoeq') + if turbclo.contains('oneeq') and turbclo.contains('twoeq') error('For turbulent closure, do not use both twoeq and oneeq as options!') endif - if get_option('turbclo').contains('oneeq') + if turbclo.contains('oneeq') add_project_arguments('-DTKE', language: 'fortran') endif - if get_option('turbclo').contains('twoeq') + if turbclo.contains('twoeq') add_project_arguments('-DTKE', '-DGLS', language: 'fortran') endif - if get_option('turbclo').contains('advection') + if turbclo.contains('advection') add_project_arguments('-DTKEADV', language: 'fortran') endif - if get_option('turbclo').contains('isodif') + if turbclo.contains('isodif') add_project_arguments('-DTKEIDF', language: 'fortran') endif endif @@ -129,7 +140,7 @@ if get_option('ecosys') endif if get_option('hamocc_ciso') if not get_option('hamocc_sedbypass') - error('hamocc_ciso=true requires hamocc_sedbypass=true!') + error('hamocc_ciso == true requires hamocc_sedbypass == true!') endif add_project_arguments('-Dcisonew', language: 'fortran') endif diff --git a/meson_options.txt b/meson_options.txt index 417ae9b8..498bbddf 100644 --- a/meson_options.txt +++ b/meson_options.txt @@ -6,10 +6,15 @@ option('grid', type: 'combo', 'tnx0.25v4', 'tnx1.5v1', 'tnx1v1', 'tnx1v3', 'tnx1v4', 'tnx2v1', 'MNP2', 'fuk95', 'single_column','channel'], description: 'Grid name', value: 'fuk95') +option('vcoord', type: 'combo', + choices: ['isopyc_bulkml', 'cntiso_hybrid'], + description: 'Vertical coordinate', value: 'isopyc_bulkml') # Which executable driver should be built option('driver', type: 'combo', choices: ['nocoupler', 'noforc'], value: 'nocoupler') # List of BLOM options +option('mks', type: 'boolean', + description: 'Enable MKS units', value: false) option('turbclo', type: 'array', choices: ['oneeq', 'twoeq', 'advection', 'isodif'], description: 'Turbulent closure options', value: ['oneeq', 'advection']) diff --git a/phy/bigrid.F b/phy/bigrid.F index 23c40e86..f79fe7e1 100644 --- a/phy/bigrid.F +++ b/phy/bigrid.F @@ -1,6 +1,6 @@ ! ------------------------------------------------------------------------------ ! Copyright (C) 2000 HYCOM Consortium and contributors -! Copyright (C) 2001-2020 Mats Bentsen, Lars Inge Enstad +! Copyright (C) 2001-2022 Mats Bentsen, Lars Inge Enstad ! ! This file is part of BLOM. ! @@ -38,9 +38,6 @@ subroutine bigrid(depth) c integer i,j,nfill,nzero real depmax -c - character fmt*13 - data fmt/'(i4,1x,120i1)'/ c c --- is the domain periodic in i-index? depmax=0.0 diff --git a/phy/blom_init.F b/phy/blom_init.F index 91771685..629c02d2 100644 --- a/phy/blom_init.F +++ b/phy/blom_init.F @@ -1,5 +1,5 @@ ! ------------------------------------------------------------------------------ -! Copyright (C) 2008-2020 Mats Bentsen, Mehmet Ilicak +! Copyright (C) 2008-2022 Mats Bentsen, Mehmet Ilicak ! ! This file is part of BLOM. ! @@ -36,10 +36,12 @@ subroutine blom_init use mod_niw, only: uml, vml, umlres, vmlres use mod_eos, only: inieos use mod_swabs, only: iniswa + use mod_ndiff, only: ndiff_init + use mod_tmsmt, only: initms use mod_dia use mod_inicon, only: inicon use mod_budget, only: budget_init - use mod_cmnfld, only: cmnfld + use mod_cmnfld_routines, only: cmnfld1 use netcdf #if defined(TRC) && defined(TKE) use mod_tke, only: initke @@ -47,7 +49,7 @@ subroutine blom_init c implicit none c - integer istat,ncid,varid,i,j,k,l,m,n,mm,km + integer istat,ncid,varid,i,j,k,l,m,n,mm,nn,k1m,k1n,mt,mmt,km real q logical icrest,fexist c @@ -140,6 +142,12 @@ subroutine blom_init c #endif c --- ------------------------------------------------------------------ +c --- Initialize neutral diffusion +c --- ------------------------------------------------------------------ +c + call ndiff_init +c +c --- ------------------------------------------------------------------ c --- Initialize diagnostic accumulation fields c --- ------------------------------------------------------------------ c @@ -200,60 +208,84 @@ subroutine blom_init endif c c --- ------------------------------------------------------------------ -c --- Set layer thickness at u,v points +c --- Initialize model time step and set time level indices consistent +c --- with starting state +c --- ------------------------------------------------------------------ +c + nstep=nstep1 + m=mod(nstep+1,2)+1 + n=mod(nstep ,2)+1 + mm=(m-1)*kk + nn=(n-1)*kk + k1m=1+mm + k1n=1+nn +c +c --- ------------------------------------------------------------------ +c --- Initialize layer thicknesses c --- ------------------------------------------------------------------ c call xctilr(dp, 1,2*kk, 3,3, halo_ps) c - n=mod(nstep1,2)+1 + if (vcoord_type_tag == isopyc_bulkml) then c - do m=n,3-n,3-2*n - mm=(m-1)*kk + do mt=n,3-n,3-2*n + mmt=(mt-1)*kk c c$OMP PARALLEL DO PRIVATE(k,l,i) - do j=-2,jj+2 - do k=1,kk - do l=1,isp(j) - do i=max(-2,ifp(j,l)),min(ii+2,ilp(j,l)) - p(i,j,k+1)=p(i,j,k)+dp(i,j,k+mm) - enddo + do j=-2,jj+2 + do k=1,kk + do l=1,isp(j) + do i=max(-2,ifp(j,l)),min(ii+2,ilp(j,l)) + p(i,j,k+1)=p(i,j,k)+dp(i,j,k+mmt) + enddo + enddo enddo enddo - enddo c$OMP END PARALLEL DO c c$OMP PARALLEL DO PRIVATE(k,km,l,i,q) - do j=-1,jj+2 - do k=1,kk - km=k+mm - 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,km)= - . .5*((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 + do j=-1,jj+2 + do k=1,kk + km=k+mmt + 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,km)= + . .5*((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,km)= + . .5*((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 - 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,km)= - . .5*((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 +c$OMP END PARALLEL DO +c + enddo +c + else +c + call xctilr(dpu, 1,2*kk, 3,3, halo_us) + call xctilr(dpv, 1,2*kk, 3,3, halo_vs) +c +c$OMP PARALLEL DO PRIVATE(k,l,i) + do j=-2,jj+2 + do k=1,kk + do l=1,isp(j) + do i=max(-2,ifp(j,l)),min(ii+2,ilp(j,l)) + p(i,j,k+1)=p(i,j,k)+dp(i,j,k+mm) enddo enddo enddo enddo c$OMP END PARALLEL DO c - enddo -c - nstep=nstep1 - if (mnproc.eq.1.and.expcnf.ne.'cesm') then - write (lp,'(/2(a,i6),2(a,i9),a/)') - . 'model starts at day',nday1,', goes to day',nday2,' (steps', - . nstep1,' --',nstep2,')' - call flush(lp) endif c c --- ------------------------------------------------------------------ @@ -280,6 +312,7 @@ subroutine blom_init call xctilr(vml, 1,4, 0,1, halo_vv) call xctilr(umlres, 1,2, 1,0, halo_uv) call xctilr(vmlres, 1,2, 0,1, halo_vv) + call xctilr(sigmar, 1,kk, 1,1, halo_ps) c c --- with arctic patch, switch xixp and xixm and xiyp and xiym in the c --- halo region adjacent to the arctic grid intersection @@ -314,8 +347,12 @@ subroutine blom_init enddo endif c - m=3-n - call cmnfld(m,n,(m-1)*kk,(n-1)*kk,1+(m-1)*kk,1+(n-1)*kk) +c --- ------------------------------------------------------------------ +c --- Initialize time smoothing variables and some common fields. +c --- ------------------------------------------------------------------ +c + call initms(m,n,mm,nn,k1m,k1n) + call cmnfld1(m,n,mm,nn,k1m,k1n) c c --- ------------------------------------------------------------------ c --- Extract reference potential density vector representative of the @@ -324,6 +361,15 @@ subroutine blom_init c call diasg1 c +c --- ------------------------------------------------------------------ +c + if (mnproc.eq.1.and.expcnf.ne.'cesm') then + write (lp,'(/2(a,i6),2(a,i9),a/)') + . 'model starts at day',nday1,', goes to day',nday2,' (steps', + . nstep1,' --',nstep2,')' + call flush(lp) + endif +c c --- print seconds elapsed since last call to system_clock (Time 0) if (mnproc.eq.1) then write (lp,'(f12.4,a,i8)') diff --git a/phy/blom_step.F b/phy/blom_step.F index 511bd441..6d366d0a 100644 --- a/phy/blom_step.F +++ b/phy/blom_step.F @@ -1,5 +1,5 @@ ! ------------------------------------------------------------------------------ -! Copyright (C) 2008-2020 Mats Bentsen, Mehmet Ilicak +! Copyright (C) 2008-2022 Mats Bentsen, Mehmet Ilicak ! ! This file is part of BLOM. ! @@ -37,6 +37,10 @@ subroutine blom_step . diaacc_total_time, io_total_time, . get_time use mod_xc, only: lp, 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_swabs, only: updswa use mod_tmsmt, only: tmsmt1, tmsmt2 use mod_eddtra, only: eddtra @@ -46,19 +50,23 @@ subroutine blom_step use mod_momtum, only: momtum use mod_mxlayr, only: mxlayr use mod_barotp, only: barotp - use mod_cmnfld, only: cmnfld + use mod_cmnfld_routines, only: cmnfld_bfsqi_cntiso_hybrid, + . cmnfld1, cmnfld2 use mod_forcing, only: fwbbal use mod_budget, only: budget_sums, budget_output use mod_eddtra, only: eddtra use mod_momtum, only: momtum + use mod_difest, only: difest_isobml, difest_lateral_hybrid, + . difest_vertical_hybrid use mod_chkvar, only: chkvar use mod_dia c - use mod_state, only: temp, saln, dp + use mod_state, only: temp, saln, dp, init_fluxes implicit none c real q integer i,m,n,mm,nn,k1m,k1n + logical update_flux_halos c real total_step_time, . auxil_time , @@ -93,19 +101,13 @@ subroutine blom_step call step_time c c --- ------------------------------------------------------------------ -c --- Update some flux halos the first time step of a day to reproduce -c --- results after restart with arctic +c --- Reset fluxes to be accumulated over a model time step and update +c --- flux halos the first time step of a day to reproduce results after +c --- restart with tripolar grid. c --- ------------------------------------------------------------------ c - if (nreg.eq.2.and.mod(nstep,nstep_in_day).eq.1) then - if (mnproc.eq.1) write (lp,*) 'blom_step: update flux halos' - call xctilr(uflx(1-nbdy,1-nbdy,k1n), 1,kk, 1,1, halo_uv) - call xctilr(utflx(1-nbdy,1-nbdy,k1n), 1,kk, 1,1, halo_uv) - call xctilr(usflx(1-nbdy,1-nbdy,k1n), 1,kk, 1,1, halo_uv) - call xctilr(vflx(1-nbdy,1-nbdy,k1n), 1,kk, 1,1, halo_vv) - call xctilr(vtflx(1-nbdy,1-nbdy,k1n), 1,kk, 1,1, halo_vv) - call xctilr(vsflx(1-nbdy,1-nbdy,k1n), 1,kk, 1,1, halo_vv) - endif + update_flux_halos = nreg == 2 .and. mod(nstep,nstep_in_day) == 1 + call init_fluxes(m,n,mm,nn,k1m,k1n,update_flux_halos) c auxil_time=get_time() c @@ -122,20 +124,37 @@ subroutine blom_step call updswa c getfrc_time=get_time() +c + 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) + convec_time=get_time() + call budget_sums(2,n,nn) + endif +c + call cmnfld2(m,n,mm,nn,k1m,k1n) c cdiag write (lp,*) 'tmsmt1...' call tmsmt1(m,n,mm,nn,k1m,k1n) tmsmt1_time=get_time() c cdiag write (lp,*) 'advdif...' - call difest(m,n,mm,nn,k1m,k1n) + if (vcoord_type_tag == isopyc_bulkml) then + call difest_isobml(m,n,mm,nn,k1m,k1n) + else + call difest_lateral_hybrid(m,n,mm,nn,k1m,k1n) + endif call eddtra(m,n,mm,nn,k1m,k1n) call advect(m,n,mm,nn,k1m,k1n) call pbcor1(m,n,mm,nn,k1m,k1n) call diffus(m,n,mm,nn,k1m,k1n) advdif_time=get_time() c - call budget_sums(2,n,nn) + if (vcoord_type_tag == isopyc_bulkml) then + call budget_sums(2,n,nn) + else + call budget_sums(3,n,nn) + endif auxil_time=auxil_time+get_time() c cdiag write (lp,*) 'sfcstr...' @@ -150,27 +169,42 @@ subroutine blom_step call momtum(m,n,mm,nn,k1m,k1n) momtum_time=get_time() c -cdiag write (lp,*) 'convec...' - call convec(m,n,mm,nn,k1m,k1n) - convec_time=get_time() + if (vcoord_type_tag == isopyc_bulkml) then c - call budget_sums(3,n,nn) - auxil_time=auxil_time+get_time() +cdiag write (lp,*) 'convec...' + call convec(m,n,mm,nn,k1m,k1n) + convec_time=get_time() c -cdiag write (lp,*) 'diapfl...' - call diapfl(m,n,mm,nn,k1m,k1n) - diapfl_time=get_time() + call budget_sums(3,n,nn) + auxil_time=auxil_time+get_time() c - call budget_sums(4,n,nn) - auxil_time=auxil_time+get_time() +cdiag write (lp,*) 'diapfl...' + call diapfl(m,n,mm,nn,k1m,k1n) + diapfl_time=get_time() +c + call budget_sums(4,n,nn) + auxil_time=auxil_time+get_time() +c + endif c cdiag write (lp,*) 'thermf...' call thermf(m,n,mm,nn,k1m,k1n) thermf_time=get_time() c -cdiag write (lp,*) 'mxlayr...' - call mxlayr(m,n,mm,nn,k1m,k1n) - mxlayr_time=get_time() + if (vcoord_type_tag == isopyc_bulkml) then +cdiag 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 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 budget_sums(4,n,nn) + diapfl_time=get_time() + endif c #ifdef TRC c --- update tracer due to non-passive processes @@ -194,10 +228,13 @@ subroutine blom_step cdiag write (lp,*) 'tmsmt2...' call tmsmt2(m,n,mm,nn,k1m,k1n) tmsmt2_time=get_time() -c - call cmnfld(m,n,mm,nn,k1m,k1n) c call budget_sums(7,m,mm) +c + call cmnfld1(m,n,mm,nn,k1m,k1n) +c + call diaacc(m,n,mm,nn,k1m,k1n) + diaacc_time=get_time() c call fwbbal(m,n,mm,nn,k1m,k1n) c @@ -212,9 +249,6 @@ subroutine blom_step c ---------------------------------------------------------------------- c call chkvar(m,n,mm,nn,k1m,k1n) -c - call diaacc(m,n,mm,nn,k1m,k1n) - diaacc_time=get_time() c if (mod(nstep,nstep_in_day).eq.0.and.nday_of_year.eq.1) then c @@ -226,7 +260,6 @@ subroutine blom_step c endif c -c c --- ------------------------------------------------------------------ c --- - output of BLOM diagnostics c --- ------------------------------------------------------------------ diff --git a/phy/cntiso_hybrid_forcing.F90 b/phy/cntiso_hybrid_forcing.F90 new file mode 100644 index 00000000..254dacfc --- /dev/null +++ b/phy/cntiso_hybrid_forcing.F90 @@ -0,0 +1,111 @@ +! ------------------------------------------------------------------------------ +! Copyright (C) 2021-2022 Mats Bentsen +! +! 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 . +! ------------------------------------------------------------------------------ + +subroutine cntiso_hybrid_forcing(m, n, mm, nn, k1m, k1n) +! --------------------------------------------------------------------------- +! Apply surface forcing to the water column. +! --------------------------------------------------------------------------- + + use mod_types, only: r8 + use mod_constants, only: g, spcifh, alpha0, onem, onemu + use mod_xc + use mod_eos, only: dsigdt0, dsigds0 + use mod_state, only: dp, temp, saln + use mod_swabs, only: swbgal, swbgfc, swamxd + use mod_forcing, only: surflx, sswflx, salflx, buoyfl, t_sw_nonloc + use mod_checksum, only: csdiag, chksummsk + + implicit none + + integer, intent(in) :: m, n, mm, nn, k1m, k1n + + real(r8) :: pres(kk+1) + real(r8) :: cpi, pswamx, gaa, dsgdt, dsgds, lei, pswamxi, pswbot + integer :: i, j, k, l, kswamx, kn + + ! Set some constants: + cpi = 1._r8/spcifh ! Multiplicative inverse of specific heat capacity. + pswamx = swamxd*onem ! Maximum pressure of shortwave absorption. + gaa = g*alpha0*alpha0 + +!$omp parallel do private(l, i, dsgdt, dsgds, lei, pres, kswamx, k, kn, & +!$omp pswamxi, pswbot) + do j = 1, jj + do l = 1, isp(j) + do i = max(1, ifp(j,l)), min(ii, ilp(j,l)) + + ! Derivatives of potential density referenced at the surface. + dsgdt = dsigdt0(temp(i,j,k1n), saln(i,j,k1n)) + dsgds = dsigds0(temp(i,j,k1n), saln(i,j,k1n)) + + ! Compute surface buoyancy flux [cm2 s-3]. + buoyfl(i,j,1) = - (dsgdt*surflx(i,j)*cpi + dsgds*salflx(i,j))*gaa + + ! Compute shortwave penetration factors at layer interfaces. + lei = 1._r8/(onem*swbgal(i,j)) + pres(1) = 0._r8 + kswamx = 1 + t_sw_nonloc(i,j,1) = 1._r8 + do k = 1, kk + kn = k + nn + pres(k+1) = pres(k) + dp(i,j,kn) + if (dp(i,j,kn) > onemu) then + t_sw_nonloc(i,j,k+1) = & + swbgfc(i,j)*exp( - lei*min(pswamx, pres(k+1))) + kswamx = k + else + t_sw_nonloc(i,j,k+1) = t_sw_nonloc(i,j,k) + endif + if (pres(k+1) > pswamx) exit + enddo + + ! Compute buoyancy flux at subsurface layer interfaces. Penetration + ! factors are modified so that shortwave radiation destined to + ! penetrate below the lowest model layer is evenly absorbed in the + ! water column. + pswamxi = 1._r8/min(pswamx, pres(kswamx+1)) + pswbot = t_sw_nonloc(i,j,kswamx+1) + do k = kswamx+1, kk+1 + t_sw_nonloc(i,j,k) = 0._r8 + buoyfl(i,j,k) = 0._r8 + enddo + do k = kswamx, 2, -1 + kn = k + nn + if (dp(i,j,kn) > onemu) then + t_sw_nonloc(i,j,k) = t_sw_nonloc(i,j,k) - pswbot*pres(k)*pswamxi + else + t_sw_nonloc(i,j,k) = t_sw_nonloc(i,j,k+1) + endif + buoyfl(i,j,k) = - dsgdt*t_sw_nonloc(i,j,k)*sswflx(i,j)*cpi*gaa + enddo + + enddo + enddo + enddo +!$omp end parallel do + + if (csdiag) then + if (mnproc == 1) then + write (lp,*) 'cntiso_hybrid_forcing:' + endif + call chksummsk(buoyfl, ip, kk+1, 'buoyfl') + call chksummsk(t_sw_nonloc, ip, kk+1, 't_sw_nonloc') + endif + +end subroutine cntiso_hybrid_forcing diff --git a/phy/convec.F b/phy/convec.F index f8faef5d..9b68bfcb 100644 --- a/phy/convec.F +++ b/phy/convec.F @@ -1,5 +1,5 @@ ! ------------------------------------------------------------------------------ -! Copyright (C) 2009-2020 Mats Bentsen +! Copyright (C) 2009-2022 Mats Bentsen, Mehmet Ilicak ! ! This file is part of BLOM. ! @@ -24,9 +24,9 @@ subroutine convec(m,n,mm,nn,k1m,k1n) c --- layers c --- ------------------------------------------------------------------ c - use mod_constants, only: epsil + use mod_constants, only: epsilp use mod_xc - use mod_grid, only: sigmar + use mod_vcoord, only: sigmar use mod_eos, only: rho, sig, sofsig use mod_state, only: u, v, dp, dpu, dpv, temp, saln, sigma, . p, pu, pv, kfpla @@ -84,7 +84,7 @@ subroutine convec(m,n,mm,nn,k1m,k1n) c k=3 dps=0. - do while (delp(k).lt.epsil) + do while (delp(k).lt.epsilp) dps=dps+delp(k) delp(k)=0. k=k+1 @@ -212,7 +212,7 @@ subroutine convec(m,n,mm,nn,k1m,k1n) k=kfpl do while (rho(dps,ttmp,stmp).gt. . rho(dps,ttem(k),ssal(k)).or. - . delp(k).lt.epsil) + . delp(k).lt.epsilp) tdps=tdps+ttem(k)*delp(k) sdps=sdps+ssal(k)*delp(k) dps=dps+delp(k) diff --git a/phy/diapfl.F b/phy/diapfl.F index 96a45944..6d6badc5 100644 --- a/phy/diapfl.F +++ b/phy/diapfl.F @@ -1,5 +1,5 @@ ! ------------------------------------------------------------------------------ -! Copyright (C) 2009-2020 Mats Bentsen, Mehmet Ilicak +! Copyright (C) 2009-2022 Mats Bentsen, Mehmet Ilicak ! ! This file is part of BLOM. ! @@ -23,10 +23,11 @@ subroutine diapfl(m,n,mm,nn,k1m,k1n) c --- Diapycnal mixing c --- ------------------------------------------------------------------ c - use mod_constants, only: g, alpha0, spval, epsil, onem + use mod_constants, only: g, alpha0, spval, epsilp, onem, L_mks2cgs use mod_time, only: delt1 use mod_xc - use mod_grid, only: sigmar, coriop + use mod_vcoord, only: sigmar + use mod_grid, only: coriop use mod_eos, only: sig, dsigdt, dsigds, sofsig use mod_temmin, only: temmin use mod_state, only: u, v, dp, dpu, dpv, temp, saln, sigma, @@ -63,7 +64,7 @@ subroutine diapfl(m,n,mm,nn,k1m,k1n) c --- scale bottom boundary layer mixing [cm/s] real dsgmnr,fcmxr,dsgcr0,dfeps,gbbl,kappa,ustmin parameter (dsgmnr=.1,fcmxr=.25,dsgcr0=.25,dfeps=1.e-12,gbbl=.2, - . kappa=.4,ustmin=.01) + . kappa=.4,ustmin=.0001*L_mks2cgs) c real, save, dimension(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy,kdm) :: . fpug=spval,fplg=spval @@ -132,7 +133,7 @@ subroutine diapfl(m,n,mm,nn,k1m,k1n) kmin=kfpl-2 kmax=1 do k=2,kk - if (delp(k).gt.epsil) kmax=k + if (delp(k).gt.epsilp) kmax=k enddo c if (kmin.lt.kmax) then @@ -313,7 +314,7 @@ subroutine diapfl(m,n,mm,nn,k1m,k1n) . i+i0,j+j0 open (10,file='diapfl.uf',form='unformatted') write (10) kk,kfpl - write (10) g,alpha0,epsil,onem,delt1,dsgmnr,q,q + write (10) g,alpha0,epsilp,onem,delt1,dsgmnr,q,q write (10) ttem0,ssal0,delp0,dens0,sigr0,nu0 close (10) call xchalt('(diapfl)') @@ -333,7 +334,7 @@ subroutine diapfl(m,n,mm,nn,k1m,k1n) f(k)=min(fmax(k), . .5*sqrt(c*nu(k)*dsg(k) . *(dsgui(k)+dsgli(k)))*dsghm(k), - . c*nu(k)*dsg(k)/max(epsil,delp(k))) + . c*nu(k)*dsg(k)/max(epsilp,delp(k))) fold(k)=f(k) h(k)=fcu(k )*dsgui(k )-fcl(k )*dsgli(k ) . +fcl(k-1)*dsgli(k-1)-fcu(k+1)*dsgui(k+1) @@ -518,7 +519,7 @@ subroutine diapfl(m,n,mm,nn,k1m,k1n) . i+i0,j+j0,maxdf,dflim open (10,file='diapfl.uf',form='unformatted') write (10) kk,kfpl - write (10) g,alpha0,epsil,onem,delt1,dsgmnr,q,q + write (10) g,alpha0,epsilp,onem,delt1,dsgmnr,q,q write (10) ttem0,ssal0,delp0,dens0,sigr0,nu0 close (10) call xchalt('(diapfl)') diff --git a/phy/difest.F b/phy/difest.F deleted file mode 100644 index 59324de2..00000000 --- a/phy/difest.F +++ /dev/null @@ -1,1410 +0,0 @@ -! ------------------------------------------------------------------------------ -! Copyright (C) 2009-2020 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 . -! ------------------------------------------------------------------------------ - - subroutine difest(m,n,mm,nn,k1m,k1n) -c -c --- ------------------------------------------------------------------ -c --- estimate layer interface, isopycnal, and diapycnal diffusivities -c --- ------------------------------------------------------------------ -#define DIAG -#undef DIAG -c - use mod_constants, only: g, alpha0, pi, epsil, onem, onecm - use mod_time, only: delt1 - use mod_xc - use mod_grid, only: sigmar, scpx, scpy, scp2, plat, - . coriop, betafp, cosang, sinang - use mod_eos, only: rho - use mod_state, only: u, v, dp, dpu, dpv, temp, saln, sigma, p, - . pbu, pbv, ubflxs_p, vbflxs_p, kfpla - use mod_diffusion, only: egc, eggam, eglsmn, egmndf, egmxdf, - . egidfq, ri0, bdmc1, bdmc2, tkepf, bdmtyp, - . edsprs, edritp, edwmth, - . difint, difiso, difdia, difmxp, difwgt - use mod_cmnfld, only: nnslpx, nnslpy - use mod_forcing, only: ustar, ustarb, ustar3, buoyfl - use mod_tidaldissip, only: twedon - use mod_niw, only: niwgf, niwbf, niwlf, idkedt, niw_ke_tendency - use mod_seaice, only: ficem - use mod_utility, only: util1 - use mod_checksum, only: csdiag, chksummsk -#if defined(TRC) && defined(TKE) - use mod_tracers, only: itrtke, itrgls, trc - use mod_tke, only: gls_cmu0, Pr_t, tke_min, gls_psi_min, gls_p, - . gls_m, gls_n, gls_c1, gls_c2, gls_c3plus, - . gls_c3minus, gls_Gh0, gls_Ghmin, gls_Ghcri, - . Ls_unlmt_min, Prod, Buoy, Shear2, L_scale, - . gls_s0, gls_s1, gls_s2, gls_s4, gls_s5, gls_s6, - . gls_b0, gls_b1, gls_b2, gls_b3, gls_b4, gls_b5, - . sqrt2, cmu_fac1, cmu_fac2, cmu_fac3, tke_exp1, - . gls_exp1, gls_fac6 -#endif -#ifdef DIAG - use mod_nctools - use mod_dia, only : iotype -#endif -c - implicit none -c - integer m,n,mm,nn,k1m,k1n -c -c --- parameters: -c --- iidtyp - type of interface and isopycnal diffusivities. If -c --- iidtyp=1 the diffusivities are diffusive velocities -c --- multiplied by the local horizontal grid scale, if -c --- iidtyp=2 the diffusivities are parameterized according -c --- to Eden and Greatbatch (2008). -c --- bdmldp - If bdmldp=1, make the background mixing latitude -c --- dependent according to Gregg et al. (2003). -c --- tdmflg - If tdmflg=1, apply tidally driven diapycnal mixing. -c --- iwdflg - If iwdflg=1, reduce background diapycnal diffusivity -c --- due to internal wave damping under sea-ice. -c --- dpbmin - smallest layer thickness allowed in evaluating -c --- local gradient richardson number [g/cm/s**2]. -c --- drhomn - minimum density difference in evaluations the -c --- Brunt-Vaisala frequency and the local gradient -c --- Richardson number [g/cm*3]. -c --- thkdff - diffusive velocity for thickness diffusion [cm/s]. -c --- temdff - diffusive velocity for tracer isopycnal diffusion -c --- [cm/s]. -c --- nu0 - diapycnal diffusivity when range of isopycnic physical -c --- layers is restricted [cm**2/s]. -c --- nus0 - maximum shear driven diapycnal diffusivity -c --- [cm**2/s]. -c --- nug0 - maximum gravity current diapycnal diffusivity -c --- [cm**2/s]. -c --- drho0 - critical local interface density difference [g/cm**3] -c --- nuls0 - maximum diapycnal diffusivity applied when local -c --- stability is weak [cm**2/s]. -c --- iwdfac - internal wave dissipation factor under sea ice []. -c --- dmxeff - diapycnal mixing efficiency []. -c --- tdmq - tidal dissipation efficiency []. -c --- tdmls0 - tidal driven mixing length scale below critical -c --- latitude [g/cm/s**2]. -c --- tdmls1 - tidal driven mixing length scale above critical -c --- latitude [g/cm/s**2]. -c --- tdclat - critical latitude for tide M2 propagation []. -c --- tddlat - latitudinal transition zone for different tidal driven -c --- mixing length scales near the critical latitude. -c --- tkepls - length scale of surface TKE penetration beneath the -c --- mixed layer [g/cm/s**2] -c --- niwls - near-inertial waves driven mixing length scale -c --- beneath the mixed layer [g/cm/s**2]. -c --- cori30 - coriolis parameter at 30N [1/s]. -c --- bvf0 - reference stratification in the parameterization of -c --- latitude dependent background diapycnal mixing [1/s]. -c --- nubmin - minimum background diapycnal diffusivity [cm**2/s]. -c --- dpgc - thickness of region near the bottom where the maximum -c --- diffusivity is increased due to gravity current mixing -c --- processes [g/cm/s**2]. -c --- dpgrav - thickness of region below the non-isopycnic surface -c --- layers used to estimate upper ocean Eady growth rate -c --- [g/cm/s**2]. -c --- dpdiav - thickness of region below the non-isopycnic surface -c --- layers used to estimate lateral diffusivities in the -c --- non-isopycnic layers [g/cm/s**2]. -c --- dpddav - thickness of region below the non-isopycnic surface -c --- layers used to estimate diapycnal diffusivities in the -c --- non-isopycnic layers [g/cm/s**2]. -c --- dpnbav - thickness of region near the bottom used to estimate -c --- bottom Brunt-Vaisala frequency [g/cm/s**2]. - integer iidtyp,bdmldp,tdmflg,iwdflg - real dptmin,dpbmin,drhomn,thkdff,temdff,nu0,nus0,nug0,drho0,nuls0, - . iwdfac,dmxeff,tdmq,tdmls0,tdmls1,tdclat,tddlat,tkepls,niwls, - . cori30,bvf0,nubmin,dpgc,dpgrav,dpdiav,dpddav,dpnbav,ustmin, - . kappa,bfeps,sleps,zetas,as,cs - parameter (iidtyp=2,bdmldp=1,tdmflg=1,iwdflg=1,dptmin=98060., - . dpbmin=980.6,drhomn=6.e-6,thkdff=.5,temdff=.35,nu0=.1, - . nus0=50.,nug0=2500.,drho0=6.e-6,nuls0=500.,iwdfac=.06, - . dmxeff=.2,tdmq=1./3.,tdmls0=500.*98060., - . tdmls1=100.*98060.,tdclat=74.5,tddlat=3., - . tkepls=20.*98060.,niwls=300.*98060.,cori30=7.2722e-5, - . bvf0=5.24e-3,nubmin=.01,dpgc=300.*98060., - . dpgrav=100.*98060.,dpdiav=100.*98060., - . dpddav=10.*98060.,dpnbav=250.*98060.,ustmin=.1, - . kappa=.4,bfeps=1.e-12,sleps=.1,zetas=-1.,as=-28.86, - . cs=98.96) -c - real, dimension(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy,kdm) :: - . dv2 - real, dimension(1-nbdy:idm+nbdy,kdm) :: - . du2,drho,bvfsq,bvf,rig,egr - real, dimension(1-nbdy:idm+nbdy) :: - . tup,pup,sup,cr,bcrrd,afeql,bvfbot,dps,egrs,egrup,dfints,urmse, - . cpse,dfddsu,dfddsl - integer, dimension(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy,kdm) :: - . mskv - integer, dimension(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy) :: - . kfil,kmax - integer, dimension(1-nbdy:idm+nbdy,kdm) :: - . msku - integer, dimension(1-nbdy:idm+nbdy) :: - . kfpl,klpl - integer i,j,k,l,kn - real q,plo,tlo,slo,rhisc,els,egrlo,umnsc,esfac,nus,nub,nut,nuls, - . vsf,nusm,ust,mols,h,sg,zeta,phis,ws -c -#if defined(TRC) && defined(TKE) - real gls_c3,tke_prod,tke_buoy,tke_epsilon,Ls_unlmt,Ls_lmt,tke_Q, - . Gm,Gh,Sm,Sh,cff,ql -# ifdef GLS - real gls_prod,gls_buoy,gls_diss,gls_Q -# endif -#endif -#ifdef DIAG - real, dimension(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy,kdm) :: - . tmp3d_1,tmp3d_2,tmp3d_3,tmp3d_4,tmp3d_5,tmp3d_6, - . tmp3d_7,tmp3d_8,tmp3d_9,tmp3d_10,tmp3d_11,tmp3d_12 - real, dimension(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy) :: - . tmp2d_1,tmp2d_2,tmp2d_3,tmp2d_4,tmp2d_5,tmp2d_6,tmp2d_7 -c - tmp3d_1=0. - tmp3d_2=0. - tmp3d_3=0. - tmp3d_4=0. - tmp3d_5=0. - tmp3d_6=0. - tmp3d_7=0. - tmp3d_8=0. - tmp3d_9=0. - tmp3d_10=0. - tmp3d_11=0. - tmp3d_12=0. - tmp2d_1=0. - tmp2d_2=0. - tmp2d_3=0. - tmp2d_4=0. - tmp2d_5=0. - tmp2d_6=0. - tmp2d_7=0. -#endif -c -c$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 -c$OMP END PARALLEL DO -c - call xctilr(u, 1,2*kk, 2,2, halo_uv) - call xctilr(v, 1,2*kk, 2,2, halo_vv) - call xctilr(ubflxs_p, 1,2, 2,2, halo_uv) - call xctilr(vbflxs_p, 1,2, 2,2, halo_vv) - call xctilr(pbu, 1,2, 2,2, halo_us) - call xctilr(pbv, 1,2, 2,2, halo_vs) -c -c --- ------------------------------------------------------------------ -c --- Estimate energy input by near-inertial waves. -c --- ------------------------------------------------------------------ -c - call niw_ke_tendency(m,n,mm,nn,k1m,k1n) -c -c --- ------------------------------------------------------------------ -c --- Estimate friction velocity cubed. -c --- ------------------------------------------------------------------ -c -c$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)) - ustar3(i,j)=ustar(i,j)**3 - enddo - enddo - enddo -c$OMP END PARALLEL DO -c -c --- Locate the range of layers to be considered in the computation of -c --- diffusivities. - do j=0,jj+1 - do i=0,ii+1 - kmax(i,j)=0 - enddo - do l=1,isp(j) - do i=max(0,ifp(j,l)),min(ii+1,ilp(j,l)) - kmax(i,j)=1 - do k=3,kk - kn=k+nn - if (dp(i,j,kn).gt.dpbmin) kmax(i,j)=k - enddo - if (kfpla(i,j,n).ge.kmax(i,j)) then - kfil(i,j)=kfpla(i,j,n)+1 - else - if (sigma(i,j,kfpla(i,j,n)+nn).lt. - . .5*(sigmar(i,j,kfpla(i,j,n) ) - . +sigmar(i,j,kfpla(i,j,n)+1))) then - kfil(i,j)=kfpla(i,j,n)+1 - else - kfil(i,j)=kfpla(i,j,n)+2 - endif - endif - enddo - enddo - enddo -c -c$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)) - util1(i,j)=kfil(i,j) -#ifdef DIAG - tmp2d_1(i,j)=kfpla(i,j,n) - tmp2d_2(i,j)=kfil(i,j) -#endif - enddo - enddo - enddo -c$OMP END PARALLEL DO - call xctilr(util1, 1,1, 1,1, halo_ps) -c$OMP PARALLEL DO PRIVATE(l,i) - do j=0,jj+1 - do l=1,isp(j) - do i=max(0,ifp(j,l)),min(ii+1,ilp(j,l)) - kfil(i,j)=nint(util1(i,j)) - enddo - enddo - enddo -c$OMP END PARALLEL DO -c -c --- Compute squared vertical velocity gradients of v-component -c$OMP PARALLEL DO PRIVATE(l,i,kfpl,klpl,k,kn,q,tup) - do j=1,jj+1 - do l=1,isv(j) - do i=max(1,ifv(j,l)),min(ii,ilv(j,l)) - kfpl(i)=kk+1 - klpl(i)=1 - enddo - enddo - do k=3,kk - kn=k+nn - do l=1,isv(j) - do i=max(1,ifv(j,l)),min(ii,ilv(j,l)) - if (dpv(i,j,kn).gt.dpbmin) klpl(i)=k - enddo - enddo - enddo - do k=kk,4,-1 - kn=k+nn - do l=1,isv(j) - do i=max(1,ifv(j,l)),min(ii,ilv(j,l)) - if (k.ge.max(kfil(i,j-1),kfil(i,j)).and. - . dpv(i,j,kn).gt.dptmin) kfpl(i)=k - enddo - enddo - enddo - do k=1,kk - kn=k+nn - do i=1,ii - dv2(i,j,k)=0. - mskv(i,j,k)=0 - enddo - do l=1,isv(j) - do i=max(1,ifv(j,l)),min(ii,ilv(j,l)) - if (k.ge.kfpl(i).and.k.le.klpl(i).and. - . klpl(i)-kfpl(i).ge.1) then - if (k.eq.kfpl(i)) then - q=v(i,j,kn+1)-v(i,j,kn) - q=q*q - dv2(i,j,k)=q - tup(i)=q - elseif (k.lt.klpl(i)) then - q=v(i,j,kn+1)-v(i,j,kn) - q=q*q - dv2(i,j,k)=.5*(tup(i)+q) - tup(i)=q - else - dv2(i,j,k)=tup(i) - endif - mskv(i,j,k)=1 - endif - enddo - enddo - enddo - enddo -c$OMP END PARALLEL DO -c -c$OMP PARALLEL DO PRIVATE( -c$OMP+ l,i,kfpl,klpl,k,kn,du2,msku,q,tup,pup,sup,cr,plo,tlo,slo,bcrrd, -c$OMP+ afeql,bvfbot,dps,drho,bvfsq,bvf,rig,egrs,egr,egrup,egrlo,dfints, -c$OMP+ rhisc,els,urmse,cpse,umnsc,esfac,dfddsu,dfddsl,nub,nus,ust,vsf, -c$OMP+ nut,nuls,nusm,mols,h,sg,zeta,phis,ws -#if defined(TRC) && defined(TKE) -c$OMP+ ,gls_c3,tke_epsilon,tke_prod,tke_buoy,tke_Q,Ls_unlmt,Ls_lmt,Gh, -c$OMP+ Gm,cff,Sm,Sh,ql -# ifdef GLS -c$OMP+ ,gls_prod,gls_buoy,gls_diss,gls_Q -# endif -#endif -c$OMP+ ) - do j=1,jj -c -c ----- Compute squared vertical velocity gradients of u-component - do l=1,isu(j) - do i=max(1,ifu(j,l)),min(ii+1,ilu(j,l)) - kfpl(i)=kk+1 - klpl(i)=1 - enddo - enddo - do k=3,kk - kn=k+nn - do l=1,isu(j) - do i=max(1,ifu(j,l)),min(ii+1,ilu(j,l)) - if (dpu(i,j,kn).gt.dpbmin) klpl(i)=k - enddo - enddo - enddo - do k=kk,4,-1 - kn=k+nn - do l=1,isu(j) - do i=max(1,ifu(j,l)),min(ii+1,ilu(j,l)) - if (k.ge.min(kfil(i-1,j),kfil(i,j)).and. - . dpu(i,j,kn).gt.dptmin) kfpl(i)=k - enddo - enddo - enddo - do k=1,kk - kn=k+nn - do i=1,ii+1 - du2(i,k)=0. - msku(i,k)=0 - enddo - do l=1,isu(j) - do i=max(1,ifu(j,l)),min(ii+1,ilu(j,l)) - if (k.ge.kfpl(i).and.k.le.klpl(i).and. - . klpl(i)-kfpl(i).ge.1) then - if (k.eq.kfpl(i)) then - q=u(i,j,kn+1)-u(i,j,kn) - q=q*q - du2(i,k)=q - tup(i)=q - elseif (k.lt.klpl(i)) then - q=u(i,j,kn+1)-u(i,j,kn) - q=q*q - du2(i,k)=.5*(tup(i)+q) - tup(i)=q - else - du2(i,k)=tup(i) - endif - msku(i,k)=1 - endif - enddo - enddo - enddo -c -c ----- Compute the first baroclinic rossby radius of deformation using -c ----- the WKB approximation by Chelton at al. (1998). -c ----- !!! Could include top layer in computation !!! - do l=1,isp(j) - do i=max(1,ifp(j,l)),min(ii,ilp(j,l)) - pup(i)=.5*(3.*p(i,j,3)-p(i,j,min(kk,kfpla(i,j,n))+1)) - kn=2+nn - tup(i)=temp(i,j,kn) - sup(i)=saln(i,j,kn) - cr(i)=0. - enddo - enddo - do k=3,kk - kn=k+nn - do l=1,isp(j) - do i=max(1,ifp(j,l)),min(ii,ilp(j,l)) - if (k.ge.kfpla(i,j,n)) then - if (p(i,j,kk+1)-p(i,j,k+1).lt.epsil) then - plo=p(i,j,kk+1) - else - plo=.5*(p(i,j,k)+p(i,j,k+1)) - endif - tlo=temp(i,j,kn) - slo=saln(i,j,kn) - cr(i)=cr(i) - . +sqrt(max(0.,(rho(p(i,j,k),tlo,slo) - . -rho(p(i,j,k),tup(i),sup(i))) - . *(plo-pup(i)))) - pup(i)=plo - tup(i)=tlo - sup(i)=slo - endif - enddo - enddo - enddo - do l=1,isp(j) - do i=max(1,ifp(j,l)),min(ii,ilp(j,l)) - cr(i)=alpha0*cr(i)/pi - bcrrd(i)= - . sqrt(cr(i)*cr(i) - . /max(coriop(i,j)*coriop(i,j)+2.*betafp(i,j)*cr(i), - . 1.e-24)) -#ifdef DIAG - tmp2d_3(i,j)=bcrrd(i) -#endif - afeql(i)=max(abs(coriop(i,j)),sqrt(2.*betafp(i,j)*cr(i))) -#ifdef DIAG - tmp2d_4(i,j)=afeql(i) -#endif - enddo - enddo -c -c ----- Compute local gradient richardson number and Brunt-Vaisala -c ----- frequency. - do l=1,isp(j) - do i=max(1,ifp(j,l)),min(ii,ilp(j,l)) - bvfbot(i)=0. - dps(i)=0. - enddo - enddo - do k=4,kk - kn=k+nn - do l=1,isp(j) - do i=max(1,ifp(j,l)),min(ii,ilp(j,l)) - if (k.ge.kfil(i,j).and.k.le.kmax(i,j).and. - . kmax(i,j)-kfil(i,j).ge.1) then - if (k.eq.kfil(i,j)) then - q=max(0.,rho(p(i,j,k+1),temp(i,j,kn+1),saln(i,j,kn+1)) - . -rho(p(i,j,k+1),temp(i,j,kn ),saln(i,j,kn ))) - drho(i,k)=q - tup(i)=q - elseif (k.lt.kmax(i,j)) then - q=max(0.,rho(p(i,j,k+1),temp(i,j,kn+1),saln(i,j,kn+1)) - . -rho(p(i,j,k+1),temp(i,j,kn ),saln(i,j,kn ))) - drho(i,k)=2.*tup(i)*q/max(1.e-14,tup(i)+q) - tup(i)=q - else - drho(i,k)=tup(i) - endif -c -c --- ------- Brunt-Vaisala frequency squared - bvfsq(i,k)=g*g*max(drhomn,drho(i,k)) - . /max(epsil,dp(i,j,kn)) -#ifdef DIAG - tmp3d_1(i,j,k)=bvfsq(i,k) -#endif -c -c --- ------- Brunt-Vaisala frequency - bvf(i,k)=sqrt(bvfsq(i,k)) -c - q=(msku(i,k)*du2(i,k)+msku(i+1,k)*du2(i+1,k)) - . /max(1,msku(i,k)+msku(i+1,k)) - . +(mskv(i,j,k)*dv2(i,j,k)+mskv(i,j+1,k)*dv2(i,j+1,k)) - . /max(1,mskv(i,j,k)+mskv(i,j+1,k)) -c -c --- ------- Local gradient Richardson number - rig(i,k)=alpha0*alpha0*max(drhomn,drho(i,k))*dp(i,j,kn) - . /max(1.e-9,q) -#ifdef DIAG - tmp3d_2(i,j,k)=rig(i,k) -#endif -#if defined(TRC) && defined(TKE) - if (dp(i,j,kn).gt.dpbmin) then - Buoy(i,j,k)=-difdia(i,j,k)*bvfsq(i,k) - h=max(onem,dp(i,j,kn))*alpha0/g -c h=max(onem*1e-8,dp(i,j,kn))*alpha0/g -c h=max(onemm,dp(i,j,kn))*alpha0/g - Shear2(i,j,k)=max(1.e-9,q)/(h*h) - Prod(i,j,k)=difdia(i,j,k)*Pr_t*Shear2(i,j,k) - else - Buoy(i,j,k)=0. - Shear2(i,j,k)=1.e-9 - Prod(i,j,k)=0. - endif -#endif -c -c --- ------- Accumulate Brunt-Vaisala frequency in a region near the -c --- ------- bottom - q=max(0.,p(i,j,k+1)-max(p(i,j,kk+1)-dpnbav,p(i,j,k))) - if (q.gt.0.) then - bvfbot(i)=bvfbot(i)+bvf(i,k)*q - dps(i)=dps(i)+q - endif - endif - enddo - enddo - enddo - do l=1,isp(j) - do i=max(1,ifp(j,l)),min(ii,ilp(j,l)) - if (dps(i).gt.0.) then - bvfbot(i)=bvfbot(i)/dps(i) -#ifdef DIAG - tmp2d_5(i,j)=bvfbot(i) -#endif - endif - enddo - enddo -c -c --- - Compute diffusivity weigth to reduce eddy diffusivity when the -c --- - Rossby radius is resolved by the grid. - if (edwmth.eq.'smooth') then - do l=1,isp(j) - do i=max(1,ifp(j,l)),min(ii,ilp(j,l)) - q=bcrrd(i)/sqrt(.5*(scpx(i,j)*scpx(i,j) - . +scpy(i,j)*scpy(i,j))) - difwgt(i,j)=1./(1.+.25*q**4) - enddo - enddo - elseif (edwmth.eq.'step') then - do l=1,isp(j) - do i=max(1,ifp(j,l)),min(ii,ilp(j,l)) - q=bcrrd(i)/sqrt(.5*(scpx(i,j)*scpx(i,j) - . +scpy(i,j)*scpy(i,j))) - if (q.le.2.) then - difwgt(i,j)=1. - else - difwgt(i,j)=0. - endif - enddo - enddo - else - if (mnproc.eq.1) then - write (lp,'(3a)') ' edwmth=',trim(edwmth), - . ' is unsupported!' - endif - call xcstop('(difest)') - stop '(difest)' - endif -c -c --- ------------------------------------------------------------------ -c --- - Compute layer interface and isopycnal diffusivities -c --- ------------------------------------------------------------------ -c - if (iidtyp.eq.1) then -c -c --- --- Type 1: Diffusivities are diffusive velocities multiplied by -c --- --- the local horizontal grid scale. - do l=1,isp(j) - do i=max(1,ifp(j,l)),min(ii,ilp(j,l)) - q=sqrt(scp2(i,j)) - difint(i,j,1)=thkdff*q - difiso(i,j,1)=temdff*q - enddo - enddo - do k=2,kk - do l=1,isp(j) - do i=max(1,ifp(j,l)),min(ii,ilp(j,l)) - difint(i,j,k)=difint(i,j,1) - difiso(i,j,k)=difiso(i,j,1) - enddo - enddo - enddo -c - else -c -c --- --- Type 2: Diffusivities are parameterized according to Eden and -c --- --- Greatbatch (2008). -c -c --- --- Eady growth rate. - if (edsprs) then - do l=1,isp(j) - do i=max(1,ifp(j,l)),min(ii,ilp(j,l)) - egrs(i)=0. - dps(i)=0. - enddo - enddo - endif - if (edritp.eq.'shear') then - do k=2,kk - do l=1,isp(j) - do i=max(1,ifp(j,l)),min(ii,ilp(j,l)) - if (k.ge.kfil(i,j).and.k.le.kmax(i,j).and. - . kmax(i,j)-kfil(i,j).ge.1) then - egr(i,k)=afeql(i)/sqrt(rig(i,k)+eggam) -#ifdef DIAG - tmp3d_3(i,j,k)=egr(i,k) -#endif - if (edsprs) then - q=max(0.,min(p(i,j,kfil(i,j))+dpgrav, - . p(i,j,k+1))-p(i,j,k)) - dps(i)=dps(i)+q - egrs(i)=egrs(i)+egr(i,k)*q - endif - endif - enddo - enddo - enddo - elseif (edritp.eq.'large scale') then - do l=1,isp(j) - do i=max(1,ifp(j,l)),min(ii,ilp(j,l)) - if (kmax(i,j)-kfil(i,j).ge.1) then - k=kfil(i,j) - if (kmax(i-1,j).ge.k.and.kmax(i+1,j).ge.k) then - q=.25*(nnslpx(i,j,k)+nnslpx(i+1,j,k))**2 - elseif (kmax(i-1,j).ge.k) then - q=nnslpx(i,j,k)**2 - elseif (kmax(i+1,j).ge.k) then - q=nnslpx(i+1,j,k)**2 - else - q=0. - endif - if (kmax(i,j-1).ge.k.and.kmax(i,j+1).ge.k) then - q=q+.25*(nnslpy(i,j,k)+nnslpy(i,j+1,k))**2 - elseif (kmax(i,j-1).ge.k) then - q=q+nnslpy(i,j,k)**2 - elseif (kmax(i,j+1).ge.k) then - q=q+nnslpy(i,j+1,k)**2 - endif - egrup(i)=sqrt(q) - endif - enddo - enddo - do k=2,kk - do l=1,isp(j) - do i=max(1,ifp(j,l)),min(ii,ilp(j,l)) - if (kmax(i,j)-kfil(i,j).ge.1) then - if (k.ge.kfil(i,j).and.k.lt.kmax(i,j)) then - if (kmax(i-1,j).gt.k.and.kmax(i+1,j).gt.k) then - q=.25*(nnslpx(i,j,k+1)+nnslpx(i+1,j,k+1))**2 - elseif (kmax(i-1,j).gt.k) then - q=nnslpx(i,j,k+1)**2 - elseif (kmax(i+1,j).gt.k) then - q=nnslpx(i+1,j,k+1)**2 - else - q=0. - endif - if (kmax(i,j-1).gt.k.and.kmax(i,j+1).gt.k) then - q=q+.25*(nnslpy(i,j,k+1)+nnslpy(i,j+1,k+1))**2 - elseif (kmax(i,j-1).gt.k) then - q=q+nnslpy(i,j,k+1)**2 - elseif (kmax(i,j+1).gt.k) then - q=q+nnslpy(i,j+1,k+1)**2 - endif - egrlo=sqrt(q) - egr(i,k)=.5*(egrup(i)+egrlo) - egrup(i)=egrlo -#ifdef DIAG - tmp3d_3(i,j,k)=egr(i,k) -#endif - if (edsprs) then - q=max(0.,min(p(i,j,kfil(i,j))+dpgrav, - . p(i,j,k+1))-p(i,j,k)) - dps(i)=dps(i)+q - egrs(i)=egrs(i)+egr(i,k)*q - endif - elseif (k.eq.kmax(i,j)) then - egr(i,k)=egr(i,k-1) -#ifdef DIAG - tmp3d_3(i,j,k)=egr(i,k) -#endif - endif - endif - enddo - enddo - enddo - else - if (mnproc.eq.1) then - write (lp,'(3a)') ' edritp=',trim(edritp), - . ' is unsupported!' - endif - call xcstop('(difest)') - stop '(difest)' - endif - if (edsprs) then - do l=1,isp(j) - do i=max(1,ifp(j,l)),min(ii,ilp(j,l)) - if (dps(i).gt.0.) then - egrs(i)=egrs(i)/dps(i) - else - egrs(i)=0. - endif - enddo - enddo - endif -c - do l=1,isp(j) - do i=max(1,ifp(j,l)),min(ii,ilp(j,l)) - difint(i,j,1)=egmndf - dfints(i)=0. - dps(i)=0. - enddo - enddo - do k=2,kk - do l=1,isp(j) - do i=max(1,ifp(j,l)),min(ii,ilp(j,l)) - if (k.ge.kfil(i,j).and.k.le.kmax(i,j).and. - . kmax(i,j)-kfil(i,j).ge.1) then -c -c --- --------- Rhines scale. - rhisc=egr(i,k)/max(1.e-24,betafp(i,j)) -c -c --- --------- Eddy length scale. - els=max(eglsmn,min(bcrrd(i),rhisc)) -c -c --- --------- Temporary layer interface diffusivity. - difint(i,j,k)=egc*egr(i,k)*els*els -#ifdef DIAG - tmp3d_4(i,j,k)=rhisc - tmp3d_5(i,j,k)=els -#endif -c -c --- --------- Accumulate diffusivities in a region below the first -c --- --------- physical layer. - q=max(0.,min(p(i,j,kfil(i,j))+dpdiav, - . p(i,j,k+1))-p(i,j,k)) - dps(i)=dps(i)+q - dfints(i)=dfints(i)+difint(i,j,k)*q -c - else - difint(i,j,k)=difint(i,j,k-1) - endif - enddo - enddo - enddo -c -c --- --- Apply eddy diffusivity limiting, suppression when the Rossby -c --- --- radius is resolved by the grid, and suppression away from -c --- --- steering levels if requested. -c -c --- --- Eddy diffusivity modification of surface non-isopycnic -c --- --- layers. - do l=1,isp(j) - do i=max(1,ifp(j,l)),min(ii,ilp(j,l)) -c - if (edsprs) then -c -c --- ------- RMS eddy velocity estimated from K = Gamma*u_rms*L, where -c --- ------- a mixing efficiency of Gamma = 0.35 is used (Klocker and -c --- ------- Abernathey, 2014). - rhisc=egrs(i)/max(1.e-24,betafp(i,j)) - els=max(eglsmn,min(bcrrd(i),rhisc)) - urmse(i)=2.86*egc*egrs(i)*els -#ifdef DIAG - tmp2d_6(i,j)=urmse(i) -#endif -c -c --- ------- Zonal eddy phase speed minus zonal barotropic velocity -c --- ------- with a lower bound of -20 cm s-1. - cpse(i)=max(-20.,-betafp(i,j)*bcrrd(i)**2) -#ifdef DIAG - tmp2d_7(i,j)=cpse(i) -#endif -c - endif -c - if (dps(i).gt.0.) then -c - if (edsprs) then -c -c --- --------- Zonal mixed layer velocity minus eddy phase speed. Note -c --- --------- that only the baroclinic component is used since the -c --- --------- barotropic velocity is subtracted from the estimate of -c --- --------- eddy phase speed. - if (ip(i-1,j)+ip(i+1,j).eq.2) then - q=.5*((u(i ,j,1+nn)*dpu(i ,j,1+nn) - . +u(i ,j,2+nn)*dpu(i ,j,2+nn)) - . /(dpu(i ,j,1+nn)+dpu(i ,j,2+nn)) - . +(u(i+1,j,1+nn)*dpu(i+1,j,1+nn) - . +u(i+1,j,2+nn)*dpu(i+1,j,2+nn)) - . /(dpu(i+1,j,1+nn)+dpu(i+1,j,2+nn))) - elseif (ip(i-1,j).eq.1) then - q=(u(i ,j,1+nn)*dpu(i ,j,1+nn) - . +u(i ,j,2+nn)*dpu(i ,j,2+nn)) - . /(dpu(i ,j,1+nn)+dpu(i ,j,2+nn)) - elseif (ip(i+1,j).eq.1) then - q=(u(i+1,j,1+nn)*dpu(i+1,j,1+nn) - . +u(i+1,j,2+nn)*dpu(i+1,j,2+nn)) - . /(dpu(i+1,j,1+nn)+dpu(i+1,j,2+nn)) - else - q=0. - endif - umnsc=q*cosang(i,j) - if (ip(i,j-1)+ip(i,j+1).eq.2) then - q=.5*((v(i,j ,1+nn)*dpv(i,j ,1+nn) - . +v(i,j ,2+nn)*dpv(i,j ,2+nn)) - . /(dpv(i,j ,1+nn)+dpv(i,j ,2+nn)) - . +(v(i,j+1,1+nn)*dpv(i,j+1,1+nn) - . +v(i,j+1,2+nn)*dpv(i,j+1,2+nn)) - . /(dpv(i,j+1,1+nn)+dpv(i,j+1,2+nn))) - elseif (ip(i,j-1).eq.1) then - q=(v(i,j ,1+nn)*dpv(i,j ,1+nn) - . +v(i,j ,2+nn)*dpv(i,j ,2+nn)) - . /(dpv(i,j ,1+nn)+dpv(i,j ,2+nn)) - elseif (ip(i,j+1).eq.1) then - q=(v(i,j+1,1+nn)*dpv(i,j+1,1+nn) - . +v(i,j+1,2+nn)*dpv(i,j+1,2+nn)) - . /(dpv(i,j+1,1+nn)+dpv(i,j+1,2+nn)) - else - q=0. - endif - umnsc=umnsc-q*sinang(i,j)-cpse(i) -#ifdef DIAG - tmp3d_6(i,j,1)=umnsc -#endif -c -c --- --------- Eddy mixing suppresion factor where lower bounds of -c --- --------- zonal velocity minus eddy phase speed and absolute value -c --- --------- of RMS eddy velocity is set to -20 cm s-1 and 5 cm s-1, -c --- --------- respectively. - esfac=1./(1.+4.*(umnsc/max(5.,abs(urmse(i))))**2) -#ifdef DIAG - tmp3d_7(i,j,1)=esfac -#endif -c - else - esfac=1. - endif -c - dfints(i)=dfints(i)/dps(i) - dfints(i)= - . min(difmxp(i,j),egmxdf, - . max(egmndf,dfints(i)*difwgt(i,j)*esfac)) - else - dfints(i)=egmndf - endif - enddo - enddo -c -c --- --- Eddy diffusivity modification of isopycnic layers. - do k=2,kk - kn=k+nn - do l=1,isp(j) - do i=max(1,ifp(j,l)),min(ii,ilp(j,l)) - if (k.ge.kfil(i,j).and.k.le.kmax(i,j).and. - . kmax(i,j)-kfil(i,j).ge.1) then -c - if (edsprs) then -c -c --- ----------- Zonal velocity minus eddy phase speed. - umnsc= - . (msku(i,k) *u(i,j,kn)+msku(i+1,k) *u(i+1,j,kn)) - . /max(1,msku(i,k) +msku(i+1,k) )*cosang(i,j) - . -(mskv(i,j,k)*v(i,j,kn)+mskv(i,j+1,k)*v(i,j+1,kn)) - . /max(1,mskv(i,j,k)+mskv(i,j+1,k))*sinang(i,j) - . -cpse(i) -#ifdef DIAG - tmp3d_6(i,j,k)=umnsc -#endif -c -c --- ----------- Eddy mixing suppresion factor. - esfac=1./(1.+4.*(umnsc/max(5.,abs(urmse(i))))**2) -#ifdef DIAG - tmp3d_7(i,j,k)=esfac -#endif -c - else - esfac=1. - endif -c - difint(i,j,k)= - . min(difmxp(i,j),egmxdf, - . max(egmndf,difint(i,j,k)*difwgt(i,j)*esfac)) - else - difint(i,j,k)=difint(i,j,k-1) - endif - enddo - enddo - enddo -c -c --- --- Set isopycnal tracer diffusivity proportional to the layer -c --- --- interface diffusivity by the factor EGIDFQ. - do k=1,kk - do l=1,isp(j) - do i=max(1,ifp(j,l)),min(ii,ilp(j,l)) - if (k.lt.kfil(i,j)) then - difint(i,j,k)=dfints(i) - endif - difiso(i,j,k)=difint(i,j,k)*egidfq - enddo - enddo - enddo -c - endif -c -c --- ------------------------------------------------------------------ -c --- - Compute diapycnal diffusivity. -c --- ------------------------------------------------------------------ -c - do l=1,isp(j) - do i=max(1,ifp(j,l)),min(ii,ilp(j,l)) - difdia(i,j,1)=nu0 - dfddsu(i)=0. - dfddsl(i)=0. - dps(i)=0. - enddo - enddo - do k=2,kk - kn=k+nn - do l=1,isp(j) - do i=max(1,ifp(j,l)),min(ii,ilp(j,l)) - if (k.ge.kfil(i,j).and.k.le.kmax(i,j).and. - . kmax(i,j)-kfil(i,j).ge.1) then -c -c --- ------- Background diapycnal mixing. - if (bdmtyp.eq.1) then -c -c --- --------- Type 1: Background diffusivity is a constant divided by -c --- --------- Brunt-Vaisala frequency. - nub=bdmc1/bvf(i,k) - elseif (bdmtyp.eq.2) then -c -c --- --------- Type 2: Background diffusivity is a constant - nub=bdmc2 - else - nub=0. - endif - if (iwdflg.eq.1) then - nub=nub*(1.+(iwdfac-1.)*ficem(i,j)) - endif -c -c --- ------- Latitude dependency of background diapycnal mixing - if (bdmldp.eq.1) then - q=max(1.e-9,abs(coriop(i,j))) - nub=nub*q/cori30*log(2.*bvf0/q)/log(2.*bvf0/cori30) - endif -c - nub=max(nubmin,nub) -c -#if !defined(TRC) || !defined(TKE) -c --- ------- Shear driven diapycnal mixing. - if (rig(i,k).lt.ri0) then -c -c --- --------- Maximum diffusivity is increased near the bottom to -c --- --------- provide additional mixing of gravity currents. - q=(p(i,j,kk+1)-p(i,j,k)+.5*dp(i,j,kn)) - . /min(dpgc,.5*p(i,j,kk+1)) - q=max(0.,1.-q*q) - q=q*q*q - nus=q*nug0+(1.-q)*nus0 -c -c --- --------- Parameterization of diffusivity as a function of local -c --- --------- gradient richardson number. - q=rig(i,k)/ri0 - q=max(0.,1.-q*q) - nus=nus*q*q*q - else - nus=0. - endif -#else - if (bvfsq(i,k).gt.0.) then ! stable stratification - gls_c3=gls_c3minus - else ! unstable stratification - gls_c3=gls_c3plus - endif -# ifndef GLS - trc(i,j,kn,itrgls)=max((gls_c1*Prod(i,j,k) - . +gls_c3*Buoy(i,j,k))/gls_c2, - . gls_psi_min) -# endif - tke_epsilon=cmu_fac2*trc(i,j,kn,itrtke)**(1.5+gls_m/gls_n) - . *trc(i,j,kn,itrgls)**(-1./gls_n) - tke_prod=Prod(i,j,k) - tke_buoy=Buoy(i,j,k) - tke_Q=tke_epsilon/trc(i,j,kn,itrtke) -# ifdef GLS - gls_prod=(trc(i,j,kn,itrgls)/trc(i,j,kn,itrtke)) - . *gls_c1*Prod(i,j,k) - gls_buoy=(trc(i,j,kn,itrgls)/trc(i,j,kn,itrtke)) - . *gls_c3*Buoy(i,j,k) - gls_diss=(trc(i,j,kn,itrgls)/trc(i,j,kn,itrtke)) - . *gls_c2*tke_epsilon - gls_Q=gls_diss/trc(i,j,kn,itrgls) -# endif -# ifdef GLS - if (gls_prod+gls_buoy.ge.0.) then - trc(i,j,kn,itrgls)= - . (trc(i,j,kn,itrgls)+delt1*(gls_prod+gls_buoy)) - . /(1.+delt1*gls_Q) - else - trc(i,j,kn,itrgls)= - . (trc(i,j,kn,itrgls)+delt1*gls_prod) - . /(1.+delt1*(gls_Q-(gls_buoy/trc(i,j,kn,itrgls)))) - endif - trc(i,j,kn,itrgls)=max(trc(i,j,kn,itrgls),gls_psi_min) - q=.56**(.5*gls_n)*gls_cmu0**gls_p - . *trc(i,j,kn,itrtke)**(gls_m+.5*gls_n) - . *bvf(i,k)**(-gls_n) - if (gls_n.lt.0.) then - trc(i,j,kn,itrgls)=max(trc(i,j,kn,itrgls),q) - else - trc(i,j,kn,itrgls)=min(trc(i,j,kn,itrgls),q) - endif -# endif -c - tke_epsilon=cmu_fac2*trc(i,j,kn,itrtke)**(1.5+gls_m/gls_n) - . *trc(i,j,kn,itrgls)**(-1./gls_n) - tke_Q=tke_epsilon/trc(i,j,kn,itrtke) -c - if (tke_prod+tke_buoy.ge.0.) then - trc(i,j,kn,itrtke)= - . (trc(i,j,kn,itrtke)+delt1*(tke_prod+tke_buoy)) - . /(1.+delt1*tke_Q) - else - trc(i,j,kn,itrtke)= - . (trc(i,j,kn,itrtke)+delt1*tke_prod) - . /(1.+delt1*(tke_Q-(tke_buoy/trc(i,j,kn,itrtke)))) - trc(i,j,kn,itrtke)=max(trc(i,j,kn,itrtke),tke_min) - endif -c -c --- ------- Penetration of surface TKE below mixed layer. - if (tkepf.gt.0.) then - if (dp(i,j,kn).lt.epsil) then - q=exp(-p(i,j,k)/tkepls) - else - q=tkepls*(exp(-p(i,j,k )/tkepls) - . -exp(-p(i,j,k+1)/tkepls))/dp(i,j,kn) - endif - trc(i,j,kn,itrtke)=trc(i,j,kn,itrtke) - . +67.83*tkepf*q*ustar(i,j)**2 - endif -c -c --- ------- Set TKE and GLS to prescribed minimum values in surface -c --- ------- mixed layers and thin layers - if (dp(i,j,kn).lt.epsil) then - trc(i,j,kn,itrtke)=tke_min - trc(i,j,kn,itrgls)=gls_psi_min - endif - trc(i,j,1+nn,itrtke)=tke_min - trc(i,j,2+nn,itrtke)=tke_min - trc(i,j,1+nn,itrgls)=gls_psi_min - trc(i,j,2+nn,itrgls)=gls_psi_min -c -c --- ------- Bottom Boundary Conditions - if (k.eq.kmax(i,j)) then - ust=max(ustarb(i,j),ustmin) - trc(i,j,kn,itrtke)=max(tke_min,(ust/gls_cmu0)**2) -# ifdef GLS - trc(i,j,kn,itrgls)=max(gls_psi_min, - . (gls_cmu0**(gls_p-2.*gls_m)) - . *(ust**(2.*gls_m)) - . *(kappa*1.e2)**gls_n) -# endif - endif -c - Ls_unlmt=max(Ls_unlmt_min, - . cmu_fac1*trc(i,j,kn,itrgls)**(gls_exp1) - . *trc(i,j,kn,itrtke)**(-tke_exp1)) - - if (bvfsq(i,k).gt.0.) then ! stable stratification -c Ls_lmt=min(Ls_unlmt, -c . sqrt(.56*trc(i,j,kn,itrtke) -c . /max(bvfsq(i,k),1.e-10))) - - Ls_lmt=min(Ls_unlmt,trc(i,j,kn,itrtke)**(-gls_m/gls_n) - . *trc(i,j,kn,itrgls)**gls_n) -c Ls_lmt=Ls_unlmt - else ! unstable stratification - Ls_lmt=Ls_unlmt - endif -c -c --- ------- Compute nondimensional stability functions for tracers -c --- ------- (Sh) and momentum (Sm). Canuto-A - Gh=min(gls_Gh0,-bvfsq(i,k)*Ls_lmt*Ls_lmt - . /(2.*trc(i,j,kn,itrtke))) - Gh=min(Gh,(Gh-(Gh-gls_Ghcri)**2) - . /(Gh+gls_Gh0-2.*gls_Ghcri)) - Gh=max(Gh,gls_Ghmin) - Gh=min(Gh,gls_Gh0) -c -c --- ------- Compute shear number. - Gm=(gls_b0/gls_fac6-gls_b1*Gh+gls_b3*gls_fac6*(Gh**2)) - . /(gls_b2-gls_b4*gls_fac6*Gh) - Gm=min(Gm,Shear2(i,j,k)*Ls_lmt*Ls_lmt - . /(2.*trc(i,j,kn,itrtke))) -c -c --- ------- Compute stability functions - cff=gls_b0-gls_b1*gls_fac6*Gh+gls_b2*gls_fac6*Gm - . +gls_b3*gls_fac6**2*Gh**2-gls_b4*gls_fac6**2*Gh*Gm - . +gls_b5*gls_fac6**2*Gm*Gm - Sm=(gls_s0-gls_s1*gls_fac6*Gh+gls_s2*gls_fac6*Gm)/cff - Sh=(gls_s4-gls_s5*gls_fac6*Gh+gls_s6*gls_fac6*Gm)/cff - Sm=max(Sm,0.) - Sh=max(Sh,0.) -c -c --- ------- Relate Canuto stability to BLOM notation - Sm=Sm*cmu_fac3/gls_cmu0**3 - Sh=Sh*cmu_fac3/gls_cmu0**3 -c - ql=sqrt2*(Ls_lmt) - . *sqrt(trc(i,j,kn,itrtke)) -c ql=sqrt2*.5*(Ls_lmt+L_scale(i,j,k)) -c . *sqrt(trc(i,j,kn,itrtke)) -c -c nus=Sh*ql -c nus=min(0.1*ql,4.05*nug0) - nus=min(Sh*ql,4.05*nug0) -c nus=Sh*(trc(i,j,k,itrtke)*trc(i,j,k,itrtke)) -c . /trc(i,j,k,itrgls) - L_scale(i,j,k)=max(Ls_lmt,Ls_unlmt_min) -# ifdef GLS -c -c --- ------- Recompute gls based on limited length scale - trc(i,j,kn,itrgls)= - . max(gls_cmu0**gls_p*trc(i,j,kn,itrtke)**gls_m - . *L_scale(i,j,k)**gls_n,gls_psi_min) -# endif -#endif -c -c --- ------- Tidally driven diapycnal mixing - if (tdmflg.eq.1) then - q=.5*(tanh(4.*(abs(plat(i,j))-tdclat)/tddlat-2.)+1.) - q=(1.-q)*tdmls0+q*tdmls1 - if (dp(i,j,kn).lt.epsil) then - vsf=exp(p(i,j,k)/q)/(q*(exp(p(i,j,kk+1)/q)-1.)) - else - vsf=(exp(p(i,j,k+1)/q)-exp(p(i,j,k)/q)) - . /(dp(i,j,kn)*(exp(p(i,j,kk+1)/q)-1.)) - endif - nut=g*tdmq*dmxeff*twedon(i,j)*bvfbot(i)*vsf/bvfsq(i,k) - else - nut=0. - endif -c -c --- ------- Diapycnal mixing when local stability is weak - if (drho(i,k).lt.drho0) then - q=drho(i,k)/drho0 - q=max(0.,1.-q*q) - nuls=nuls0*q*q*q - else - nuls=0. - endif -c -c --- ------- Total diapycnal diffusivity. - difdia(i,j,k)=nub+nus+nut+nuls -#ifdef DIAG - tmp3d_8(i,j,k)=nub - tmp3d_9(i,j,k)=nus - tmp3d_10(i,j,k)=nut - tmp3d_11(i,j,k)=nuls -#endif -c -c --- ------- Accumulate diffusivities in a region below the first -c --- ------- physical layer - q=max(0.,min(p(i,j,kfil(i,j))+dpddav,p(i,j,k+1))-p(i,j,k)) - dps(i)=dps(i)+q - dfddsu(i)=dfddsu(i)+nub*q - dfddsl(i)=dfddsl(i)+difdia(i,j,k)*q -c - else - difdia(i,j,k)=difdia(i,j,k-1) -#if defined(TRC) && defined(TKE) -c trc(i,j,kn,itrtke)=tke_min -c L_scale(i,j,k)=Ls_unlmt_min - trc(i,j,kn,itrtke)=trc(i,j,kn-1,itrtke) - L_scale(i,j,k)=L_scale(i,j,k-1) -# ifdef GLS -c trc(i,j,kn,itrgls)=gls_psi_min - trc(i,j,kn,itrgls)=trc(i,j,kn-1,itrgls) -# endif -#endif - endif - enddo - enddo - enddo - do l=1,isp(j) - do i=max(1,ifp(j,l)),min(ii,ilp(j,l)) - if (dps(i).gt.0.) then - dfddsu(i)=dfddsu(i)/dps(i) - dfddsl(i)=dfddsl(i)/dps(i) - else - dfddsu(i)=nu0 - dfddsl(i)=nu0 - endif - enddo - enddo - do k=2,kk-1 - do l=1,isp(j) - do i=max(1,ifp(j,l)),min(ii,ilp(j,l)) - if (k.lt.kfil(i,j)) then - if (k.gt.2.and.kfil(i,j).le.kk.and. - . p(i,j,min(kk,kfil(i,j)))-p(i,j,3).gt.epsil) then - q=.5*(p(i,j,k+1)+p(i,j,k)) - difdia(i,j,k)=((q-p(i,j,3))*dfddsl(i) - . +(p(i,j,kfil(i,j))-q)*dfddsu(i)) - . /(p(i,j,kfil(i,j))-p(i,j,3)) - else - difdia(i,j,k)=dfddsu(i) - endif - endif - enddo - enddo - enddo -c -c --- - Diapycnal diffusivity beneath mixed layer by dissipation of -c --- - energy originating from near-inertial waves. - do k=2,kk-1 - kn=k+nn - do l=1,isp(j) - do i=max(1,ifp(j,l)),min(ii,ilp(j,l)) - if (k.le.kmax(i,j).and.kmax(i,j)-kfil(i,j).ge.1) then - q=niwls - if (k.eq.2.or.dp(i,j,kn).lt.epsil) then - vsf=exp((p(i,j,3)-p(i,j,k+1))/q) - . /(q*(1.-exp((p(i,j,3)-p(i,j,kk+1))/q))) - else - vsf=(exp((p(i,j,3)-p(i,j,k ))/q) - . -exp((p(i,j,3)-p(i,j,k+1))/q)) - . /(dp(i,j,kn)*(1.-exp((p(i,j,3)-p(i,j,kk+1))/q))) - endif - nusm=g*niwgf*(1.-niwbf)*niwlf*dmxeff*idkedt(i,j)*vsf - . /(alpha0*bvfsq(i,max(k,kfil(i,j)))) - difdia(i,j,k)=difdia(i,j,k)+nusm -#ifdef DIAG - tmp3d_12(i,j,k)=nusm -#endif - endif - enddo - enddo - enddo -c -c --- - Diffusivity at the lower interface of the top layer - do l=1,isp(j) - do i=max(1,ifp(j,l)),min(ii,ilp(j,l)) -c -c --- --- Lower bounded friction velocity - ust=max(ustmin,ustar(i,j)) -c -c --- --- Monin-Obukhov length scale - mols=ust**3 - . /(kappa*sign(max(abs(buoyfl(i,j)),bfeps),-buoyfl(i,j))) -c -c --- --- Mixed layer thickness - h=(p(i,j,3)-p(i,j,1))/onecm -c -c --- --- Dimensionless vertical coordinate in the boundary layer - sg=(p(i,j,2)-p(i,j,1))/(p(i,j,3)-p(i,j,1)) -c -c --- --- Velocity scale - if (mols.lt.0.) then - zeta=min(sleps,sg)*h/mols - if (zeta.gt.zetas) then - phis=(1.-16.*zeta)**(-1./2.) - else - phis=(as-cs*zeta)**(-1./3.) - endif - else - zeta=sg*h/mols - phis=1.+5.*zeta - endif - ws=kappa*ust/phis -c - difdia(i,j,1)=h*ws*sg*(1.-sg)**2 - enddo - enddo -c - enddo -c$OMP END PARALLEL DO -c -#ifdef DIAG - call ncfopn('difest.nc','w','c',1,iotype) - call ncdims('x',itdm) - call ncdims('y',jtdm) - call ncdims('z',kdm) - call ncdefvar('coriop','x y',ndouble,8) - call ncdefvar('betafp','x y',ndouble,8) - call ncdefvar('kfpla','x y',ndouble,8) - call ncdefvar('kfil','x y',ndouble,8) - call ncdefvar('bcrrd','x y',ndouble,8) - call ncdefvar('afeql','x y',ndouble,8) - call ncdefvar('bvfbot','x y',ndouble,8) - if (edsprs) then - call ncdefvar('urmse','x y',ndouble,8) - call ncdefvar('cpse','x y',ndouble,8) - endif - call ncdefvar('dp','x y z',ndouble,8) - call ncdefvar('temp','x y z',ndouble,8) - call ncdefvar('saln','x y z',ndouble,8) - call ncdefvar('u','x y z',ndouble,8) - call ncdefvar('v','x y z',ndouble,8) - call ncdefvar('bvfsq','x y z',ndouble,8) - call ncdefvar('rig','x y z',ndouble,8) - call ncdefvar('egr','x y z',ndouble,8) - call ncdefvar('rhisc','x y z',ndouble,8) - call ncdefvar('els','x y z',ndouble,8) - if (edsprs) then - call ncdefvar('umnsc','x y z',ndouble,8) - call ncdefvar('esfac','x y z',ndouble,8) - endif - call ncdefvar('difint','x y z',ndouble,8) - call ncdefvar('difdia','x y z',ndouble,8) - call ncdefvar('nub','x y z',ndouble,8) - call ncdefvar('nus','x y z',ndouble,8) - call ncdefvar('nut','x y z',ndouble,8) - call ncdefvar('nuls','x y z',ndouble,8) - call ncdefvar('nusm','x y z',ndouble,8) -#if defined(TRC) && defined(TKE) - call ncdefvar('tke','x y z',ndouble,8) -# ifdef GLS - call ncdefvar('gls_psi','x y z',ndouble,8) -# endif -# endif - call ncedef - call ncwrtr('coriop','x y',coriop,ip,1,1.,0.,8) - call ncwrtr('betafp','x y',betafp,ip,1,1.,0.,8) - call ncwrtr('kfpla','x y',tmp2d_1,ip,1,1.,0.,8) - call ncwrtr('kfil','x y',tmp2d_2,ip,1,1.,0.,8) - call ncwrtr('bcrrd','x y',tmp2d_3,ip,1,1.,0.,8) - call ncwrtr('afeql','x y',tmp2d_4,ip,1,1.,0.,8) - call ncwrtr('bvfbot','x y',tmp2d_5,ip,1,1.,0.,8) - if (edsprs) then - call ncwrtr('urmse','x y',tmp2d_6,ip,1,1.,0.,8) - call ncwrtr('cpse','x y',tmp2d_7,ip,1,1.,0.,8) - endif - call ncwrtr('dp','x y z',dp(1-nbdy,1-nbdy,k1n),ip,1,1.,0.,8) - call ncwrtr('temp','x y z',temp(1-nbdy,1-nbdy,k1n),ip,1,1.,0.,8) - call ncwrtr('saln','x y z',saln(1-nbdy,1-nbdy,k1n),ip,1,1.,0.,8) - call ncwrtr('u','x y z',u(1-nbdy,1-nbdy,k1n),iu,1,1.,0.,8) - call ncwrtr('v','x y z',v(1-nbdy,1-nbdy,k1n),iv,1,1.,0.,8) - call ncwrtr('bvfsq','x y z',tmp3d_1,ip,1,1.,0.,8) - call ncwrtr('rig','x y z',tmp3d_2,ip,1,1.,0.,8) - call ncwrtr('egr','x y z',tmp3d_3,ip,1,1.,0.,8) - call ncwrtr('rhisc','x y z',tmp3d_4,ip,1,1.,0.,8) - call ncwrtr('els','x y z',tmp3d_5,ip,1,1.,0.,8) - if (edsprs) then - call ncwrtr('umnsc','x y z',tmp3d_6,ip,1,1.,0.,8) - call ncwrtr('esfac','x y z',tmp3d_7,ip,1,1.,0.,8) - endif - call ncwrtr('difint','x y z',difint,ip,1,1.,0.,8) - call ncwrtr('difdia','x y z',difdia,ip,1,1.,0.,8) - call ncwrtr('nub','x y z',tmp3d_8,ip,1,1.,0.,8) - call ncwrtr('nus','x y z',tmp3d_9,ip,1,1.,0.,8) - call ncwrtr('nut','x y z',tmp3d_10,ip,1,1.,0.,8) - call ncwrtr('nuls','x y z',tmp3d_11,ip,1,1.,0.,8) - call ncwrtr('nusm','x y z',tmp3d_12,ip,1,1.,0.,8) -#if defined(TRC) && defined(TKE) - call ncwrtr('tke','x y z',trc(1-nbdy,1-nbdy,k1n,itrtke), - . ip,1,1.,0.,8) -# ifdef GLS - call ncwrtr('gls_psi','x y z',trc(1-nbdy,1-nbdy,k1n,itrgls), - . ip,1,1.,0.,8) -# endif -# endif - call ncfcls - call xcstop('(difest)') - stop '(difest)' -#endif -c - if (csdiag) then - if (mnproc.eq.1) then - write (lp,*) 'difest:' - endif - call chksummsk(idkedt,ip,1,'idkedt') - call chksummsk(ustar3,ip,1,'ustar3') - call chksummsk(difint,ip,kk,'difint') - call chksummsk(difiso,ip,kk,'difiso') - call chksummsk(difdia,ip,kk,'difdia') -#if defined(TRC) && defined(TKE) - call chksummsk(trc(1-nbdy,1-nbdy,1,itrtke),ip,2*kk,'tke') -# ifdef GLS - call chksummsk(trc(1-nbdy,1-nbdy,1,itrgls),ip,2*kk,'gls_psi') -# endif -#endif - endif -c - return - end diff --git a/phy/diffus.F b/phy/diffus.F index ab6c6118..fc590fd7 100644 --- a/phy/diffus.F +++ b/phy/diffus.F @@ -1,5 +1,5 @@ ! ------------------------------------------------------------------------------ -! Copyright (C) 2006-2020 Mats Bentsen +! Copyright (C) 2006-2022 Mats Bentsen, Mehmet Ilicak ! ! This file is part of BLOM. ! @@ -24,12 +24,14 @@ subroutine diffus(m,n,mm,nn,k1m,k1n) c --- ------------------------------------------------------------------ c use mod_time, only: delt1 + use mod_constants, only: P_mks2cgs use mod_xc use mod_grid, only: scuy, scvx, scp2, scuxi, scvyi use mod_eos, only: sig use mod_state, only: dp, temp, saln, sigma, . utflx, vtflx, usflx, vsflx - use mod_diffusion, only: difiso, utflld, vtflld, usflld, vsflld + use mod_diffusion, only: ltedtp_opt, ltedtp_neutral, difiso, + . utflld, vtflld, usflld, vsflld use mod_checksum, only: csdiag, chksummsk #ifdef TRC use mod_tracers, only: ntr, itrtke, itrgls, trc, uflxtr, vflxtr @@ -46,20 +48,34 @@ subroutine diffus(m,n,mm,nn,k1m,k1n) #endif c real dpeps - parameter (dpeps=1.e-4) + parameter (dpeps=1.e-5*P_mks2cgs) c - 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(dp(1-nbdy,1-nbdy,k1n), 1,kk, 3,3, halo_ps) + if (ltedtp_opt.eq.ltedtp_neutral) then + 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) #ifdef TRC - do nt=1,ntr + do nt=1,ntr # if defined(TKE) && !defined(TKEIDF) - if (nt.eq.itrtke.or.nt.eq.itrgls) cycle + if (nt.eq.itrtke.or.nt.eq.itrgls) cycle # endif - call xctilr(trc(1-nbdy,1-nbdy,k1n,nt), 1,kk, 2,2, halo_ps) - enddo + call xctilr(trc(1-nbdy,1-nbdy,k1n,nt), 1,kk, 1,1, halo_ps) + enddo +#endif + return + else + 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) +#ifdef TRC + do nt=1,ntr +# if defined(TKE) && !defined(TKEIDF) + if (nt.eq.itrtke.or.nt.eq.itrgls) cycle +# endif + call xctilr(trc(1-nbdy,1-nbdy,k1n,nt), 1,kk, 2,2, halo_ps) + enddo #endif - call xctilr(difiso, 1,kk, 2,2, halo_ps) + call xctilr(difiso, 1,kk, 2,2, halo_ps) + endif c do k=1,kk kn=k+nn diff --git a/phy/fill_global.F b/phy/fill_global.F index 98a42ba5..548ad477 100644 --- a/phy/fill_global.F +++ b/phy/fill_global.F @@ -1,5 +1,5 @@ ! ------------------------------------------------------------------------------ -! Copyright (C) 2004-2018 Mats Bentsen +! Copyright (C) 2004-2021 Mats Bentsen ! ! This file is part of BLOM. ! diff --git a/phy/geoenv_file.F b/phy/geoenv_file.F index 11ebf88c..c130fd50 100644 --- a/phy/geoenv_file.F +++ b/phy/geoenv_file.F @@ -1,5 +1,5 @@ ! ------------------------------------------------------------------------------ -! Copyright (C) 2015-2020 Mats Bentsen, Ping-Gin Chiu +! Copyright (C) 2015-2022 Mats Bentsen, Ping-Gin Chiu, Mehmet Ilicak ! ! This file is part of BLOM. ! @@ -25,7 +25,7 @@ subroutine geoenv_file c --- ------------------------------------------------------------------ c use mod_config, only: inst_suffix - use mod_constants, only: rearth, pi, radian + use mod_constants, only: rearth, pi, radian, L_mks2cgs use mod_xc use mod_grid, only: grfile, qclon, qclat, pclon, pclat, uclon, . uclat, vclon, vclat, scqx, scqy, scpx, scpy, @@ -797,18 +797,18 @@ subroutine geoenv_file do j=1,jj do i=1,ii c - scqx(i,j)=scqx(i,j)*1.e2 - scqy(i,j)=scqy(i,j)*1.e2 - scpx(i,j)=scpx(i,j)*1.e2 - scpy(i,j)=scpy(i,j)*1.e2 - scux(i,j)=scux(i,j)*1.e2 - scuy(i,j)=scuy(i,j)*1.e2 - scvx(i,j)=scvx(i,j)*1.e2 - scvy(i,j)=scvy(i,j)*1.e2 - scq2(i,j)=scq2(i,j)*1.e4 - scp2(i,j)=scp2(i,j)*1.e4 - scu2(i,j)=scu2(i,j)*1.e4 - scv2(i,j)=scv2(i,j)*1.e4 + scqx(i,j)=scqx(i,j)*L_mks2cgs + scqy(i,j)=scqy(i,j)*L_mks2cgs + scpx(i,j)=scpx(i,j)*L_mks2cgs + scpy(i,j)=scpy(i,j)*L_mks2cgs + scux(i,j)=scux(i,j)*L_mks2cgs + scuy(i,j)=scuy(i,j)*L_mks2cgs + scvx(i,j)=scvx(i,j)*L_mks2cgs + scvy(i,j)=scvy(i,j)*L_mks2cgs + scq2(i,j)=scq2(i,j)*L_mks2cgs**2 + scp2(i,j)=scp2(i,j)*L_mks2cgs**2 + scu2(i,j)=scu2(i,j)*L_mks2cgs**2 + scv2(i,j)=scv2(i,j)*L_mks2cgs**2 c cosang(i,j)=cos(angle(i,j)) sinang(i,j)=sin(angle(i,j)) diff --git a/phy/iniphy.F b/phy/iniphy.F index 5f382481..7073fad2 100644 --- a/phy/iniphy.F +++ b/phy/iniphy.F @@ -25,7 +25,9 @@ subroutine iniphy c use mod_config, only: expcnf use mod_xc, only: lp, mnproc, xcstop + use mod_vcoord, only: vcoord_type_tag, cntiso_hybrid use mod_tidaldissip, only: read_tidaldissip + use mod_difest, only: init_difest c implicit none c @@ -44,6 +46,10 @@ subroutine iniphy call xcstop('(iniphy)') stop '(iniphy)' endif +c + if (vcoord_type_tag == cntiso_hybrid) then + call init_difest + endif c return end diff --git a/phy/inivar.F90 b/phy/inivar.F90 index 48716a4b..cebbcb8f 100644 --- a/phy/inivar.F90 +++ b/phy/inivar.F90 @@ -1,5 +1,5 @@ ! ------------------------------------------------------------------------------ -! Copyright (C) 2015-2020 Mats Bentsen, Jerry Tjiputra +! Copyright (C) 2015-2021 Mats Bentsen, Jerry Tjiputra ! ! This file is part of BLOM. ! @@ -24,12 +24,14 @@ subroutine inivar use mod_constants, only: spval use mod_xc + use mod_vcoord, only: inivar_vcoord use mod_state, only: inivar_state use mod_pgforc, only: inivar_pgforc use mod_momtum, only: inivar_momtum use mod_barotp, only: inivar_barotp use mod_tmsmt, only: inivar_tmsmt use mod_diffusion, only: inivar_diffusion + use mod_difest, only: inivar_difest use mod_utility, only: inivar_utility use mod_mxlayr, only: inivar_mxlayr use mod_seaice, only: inivar_seaice @@ -46,12 +48,17 @@ subroutine inivar ! --------------------------------------------------------------------------- ! Call initialization routines for various modules. ! --------------------------------------------------------------------------- +#ifdef TRC + call inivar_tracers +#endif + call inivar_vcoord call inivar_state call inivar_pgforc call inivar_momtum call inivar_barotp call inivar_tmsmt call inivar_diffusion + call inivar_difest call inivar_utility call inivar_mxlayr call inivar_seaice @@ -59,8 +66,5 @@ subroutine inivar call inivar_cmnfld call inivar_niw call inivar_tidaldissip -#ifdef TRC - call inivar_tracers -#endif end subroutine inivar diff --git a/phy/meson.build b/phy/meson.build index b86930c9..a573e1e1 100644 --- a/phy/meson.build +++ b/phy/meson.build @@ -1,15 +1,16 @@ -sources += files('bigrid.F', 'blom_init.F', 'blom_step.F', 'convec.F', 'crc.c', -'diapfl.F', 'difest.F', 'diffus.F', 'fill_global.F', 'geoenv_file.F', -'geoenv_test.F', 'getfrc.F90', 'idarlx.F', 'inifrc.F90', 'inigeo.F', -'iniphy.F', 'inivar.F90', 'intp1d.F', 'mod_advect.F', 'mod_barotp.F', -'mod_budget.F90', 'mod_calendar.F90', 'mod_checksum.F90', 'mod_chkvar.F90', -'mod_cmnfld.F', 'mod_config.F90', 'mod_constants.F90', 'mod_dia.F', -'mod_diffusion.F90', 'mod_eddtra.F', 'mod_eos.F90', 'mod_forcing.F90', -'mod_grid.F90', 'mod_inicon.F', 'mod_momtum.F', 'mod_mxlayr.F', -'mod_nctools.F', 'mod_niw.F90', 'mod_pbcor.F', 'mod_pgforc.F', +sources += files('cntiso_hybrid_forcing.F90', 'bigrid.F', 'blom_init.F', +'blom_step.F', 'convec.F', 'crc.c', 'diapfl.F', 'mod_difest.F', 'diffus.F', +'fill_global.F', 'geoenv_file.F', 'geoenv_test.F', 'getfrc.F90', 'idarlx.F', +'inifrc.F90', 'inigeo.F', 'iniphy.F', 'inivar.F90', 'intp1d.F', 'mod_advect.F', +'mod_barotp.F', 'mod_budget.F90', 'mod_calendar.F90', 'mod_checksum.F90', +'mod_chkvar.F90', 'mod_cmnfld.F90', 'mod_cmnfld_routines.F90', 'mod_config.F90', +'mod_constants.F90', 'mod_dia.F', 'mod_diffusion.F90', 'mod_eddtra.F90', +'mod_eos.F90', 'mod_forcing.F90', 'mod_grid.F90', 'mod_hor3map.F90', +'mod_inicon.F', 'mod_momtum.F', 'mod_mxlayr.F', 'mod_nctools.F', +'mod_ndiff.F90', 'mod_niw.F90', 'mod_pbcor.F', 'mod_pgforc.F', 'mod_pointtest.F90', 'mod_remap.F', 'mod_seaice.F90', 'mod_state.F90', 'mod_swabs.F', 'mod_temmin.F', 'mod_tidaldissip.F90', 'mod_time.F90', 'mod_timing.F90', 'mod_tke.F90', 'mod_tmsmt.F', 'mod_types.F90', -'mod_utility.F90', 'mod_xc.F', 'numerical_bounds.F90', 'rdcsss.F', 'rdlim.F', -'restart_rd.F', 'restart_wt.F', 'sfcstr.F90', 'thermf.F', 'wdiflx.F', -'wtime.F') +'mod_utility.F90', 'mod_vcoord.F90', 'mod_vdiff.F90', 'mod_xc.F', +'numerical_bounds.F90', 'rdcsss.F', 'rdlim.F', 'restart_rd.F', 'restart_wt.F', +'sfcstr.F90', 'thermf.F', 'wdiflx.F', 'wtime.F') diff --git a/phy/mod_budget.F90 b/phy/mod_budget.F90 index fd96f193..9eeaaddb 100644 --- a/phy/mod_budget.F90 +++ b/phy/mod_budget.F90 @@ -1,5 +1,5 @@ ! ------------------------------------------------------------------------------ -! Copyright (C) 2007-2020 Mats Bentsen +! Copyright (C) 2007-2022 Mats Bentsen ! ! This file is part of BLOM. ! @@ -26,6 +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_grid, only: scp2 use mod_state, only: pb, dp, temp, saln use mod_forcing, only: surflx, surrlx, salflx, salrlx @@ -38,12 +39,14 @@ module mod_budget private + ! Options with default values, modifiable by namelist. + logical :: & + cnsvdi = .false. ! Flag that indicates whether conservation diagnostics + ! are written. + ! Constants. integer, parameter :: & ncalls = 7 ! Number of calls after which budgets are computed. - logical :: & - cnsvdi = .true. ! Flag that indicates whether conservation diagnostics - ! are written. real(r8), dimension(ncalls, 2) :: & sdp, & ! Global mass weighted sum of salinity. @@ -197,64 +200,131 @@ subroutine budget_output(m) if (.not.cnsvdi) return if (mnproc == 1 .and. nstep > nstep1 + 1) then - open (unit = nfu, file = 'salbud', position = 'append') - write (nfu, '(i8,6e12.4)') nstep - 1, & - (sdp(2, m) - sdp(1, m))/mass0, & - (sdp(3, m) - sdp(2, m))/mass0, & - (sdp(4, m) - sdp(3, m))/mass0, & - (sdp(5, m) - sdp(4, m) + sf*g)/mass0, & - (sdp(6, m) - sdp(5, m))/mass0, & - (sdp(7, m) - sdp(6, m))/mass0 - close (nfu) - open (unit = nfu, file = 'tembud', position = 'append') - write (nfu, '(i8,6e12.4)') nstep - 1, & - (tdp(2, m) - tdp(1, m))/mass0, & - (tdp(3, m) - tdp(2, m))/mass0, & - (tdp(4, m) - tdp(3, m))/mass0, & - (tdp(5, m) - tdp(4, m) + tf*g/spcifh)/mass0, & - (tdp(6, m) - tdp(5, m))/mass0, & - (tdp(7, m) - tdp(6, m))/mass0 - close (nfu) + + if (vcoord_type_tag == isopyc_bulkml) then + + open (unit = nfu, file = 'salbud', position = 'append') + write (nfu, '(i8,6e12.4)') nstep - 1, & + (sdp(2, m) - sdp(1, m))/mass0, & + (sdp(3, m) - sdp(2, m))/mass0, & + (sdp(4, m) - sdp(3, m))/mass0, & + (sdp(5, m) - sdp(4, m) + sf*g)/mass0, & + (sdp(6, m) - sdp(5, m))/mass0, & + (sdp(7, m) - sdp(6, m))/mass0 + close (nfu) + open (unit = nfu, file = 'tembud', position = 'append') + write (nfu, '(i8,6e12.4)') nstep - 1, & + (tdp(2, m) - tdp(1, m))/mass0, & + (tdp(3, m) - tdp(2, m))/mass0, & + (tdp(4, m) - tdp(3, m))/mass0, & + (tdp(5, m) - tdp(4, m) + tf*g/spcifh)/mass0, & + (tdp(6, m) - tdp(5, m))/mass0, & + (tdp(7, m) - tdp(6, m))/mass0 + close (nfu) +#ifdef TRC +# ifdef TKE + open (unit = nfu, file = 'tkebud', position = 'append') + write (nfu, '(i8,6e12.4)') nstep - 1, & + (tkedp(2, m) - tkedp(1, m))/mass0, & + (tkedp(3, m) - tkedp(2, m))/mass0, & + (tkedp(4, m) - tkedp(3, m))/mass0, & + (tkedp(5, m) - tkedp(4, m))/mass0, & + (tkedp(6, m) - tkedp(5, m))/mass0, & + (tkedp(7, m) - tkedp(6, m))/mass0 + close (nfu) +# ifdef GLS + open (unit = nfu, file = 'glsbud', position = 'append') + write (nfu, '(i8,6e12.4)') nstep - 1, & + (glsdp(2, m) - glsdp(1, m))/mass0, & + (glsdp(3, m) - glsdp(2, m))/mass0, & + (glsdp(4, m) - glsdp(3, m))/mass0, & + (glsdp(5, m) - glsdp(4, m))/mass0, & + (glsdp(6, m) - glsdp(5, m))/mass0, & + (glsdp(7, m) - glsdp(6, m))/mass0 + close (nfu) +# endif +# endif + open (unit = nfu, file = 'trcbud', position = 'append') + write (nfu, '(i8,6e12.4)') nstep - 1, & + (trdp(2, m) - trdp(1, m))/mass0, & + (trdp(3, m) - trdp(2, m))/mass0, & + (trdp(4, m) - trdp(3, m))/mass0, & + (trdp(5, m) - trdp(4, m) + trf*g)/mass0, & + (trdp(6, m) - trdp(5, m))/mass0, & + (trdp(7, m) - trdp(6, m))/mass0 + close (nfu) + open (unit = nfu, file = 'trcbudtot', position = 'append') + write (nfu, '(i8,7e18.10)') nstep - 1, & + trdp(1, m)/mass0, trdp(2, m)/mass0, trdp(3, m)/mass0, & + trdp(4, m)/mass0, trdp(5, m)/mass0, trdp(6, m)/mass0, & + trdp(7, m)/mass0 + close (nfu) +#endif + + else + + open (unit = nfu, file = 'salbud', position = 'append') + write (nfu, '(i8,6e12.4)') nstep - 1, & + (sdp(2, m) - sdp(1, m))/mass0, & + (sdp(3, m) - sdp(2, m))/mass0, & + (sdp(4, m) - sdp(3, m) + sf*g)/mass0, & + (sdp(5, m) - sdp(4, m))/mass0, & + (sdp(6, m) - sdp(5, m))/mass0, & + (sdp(7, m) - sdp(6, m))/mass0 + close (nfu) + open (unit = nfu, file = 'tembud', position = 'append') + write (nfu, '(i8,6e12.4)') nstep - 1, & + (tdp(2, m) - tdp(1, m))/mass0, & + (tdp(3, m) - tdp(2, m))/mass0, & + (tdp(4, m) - tdp(3, m) + tf*g/spcifh)/mass0, & + (tdp(5, m) - tdp(4, m))/mass0, & + (tdp(6, m) - tdp(5, m))/mass0, & + (tdp(7, m) - tdp(6, m))/mass0 + close (nfu) #ifdef TRC # ifdef TKE - open (unit = nfu, file = 'tkebud', position = 'append') - write (nfu, '(i8,6e12.4)') nstep - 1, & - (tkedp(2, m) - tkedp(1, m))/mass0, & - (tkedp(3, m) - tkedp(2, m))/mass0, & - (tkedp(4, m) - tkedp(3, m))/mass0, & - (tkedp(5, m) - tkedp(4, m))/mass0, & - (tkedp(6, m) - tkedp(5, m))/mass0, & - (tkedp(7, m) - tkedp(6, m))/mass0 - close (nfu) + open (unit = nfu, file = 'tkebud', position = 'append') + write (nfu, '(i8,6e12.4)') nstep - 1, & + (tkedp(2, m) - tkedp(1, m))/mass0, & + (tkedp(3, m) - tkedp(2, m))/mass0, & + (tkedp(4, m) - tkedp(3, m))/mass0, & + (tkedp(5, m) - tkedp(4, m))/mass0, & + (tkedp(6, m) - tkedp(5, m))/mass0, & + (tkedp(7, m) - tkedp(6, m))/mass0 + close (nfu) # ifdef GLS - open (unit = nfu, file = 'glsbud', position = 'append') - write (nfu, '(i8,6e12.4)') nstep - 1, & - (glsdp(2, m) - glsdp(1, m))/mass0, & - (glsdp(3, m) - glsdp(2, m))/mass0, & - (glsdp(4, m) - glsdp(3, m))/mass0, & - (glsdp(5, m) - glsdp(4, m))/mass0, & - (glsdp(6, m) - glsdp(5, m))/mass0, & - (glsdp(7, m) - glsdp(6, m))/mass0 - close (nfu) + open (unit = nfu, file = 'glsbud', position = 'append') + write (nfu, '(i8,6e12.4)') nstep - 1, & + (glsdp(2, m) - glsdp(1, m))/mass0, & + (glsdp(3, m) - glsdp(2, m))/mass0, & + (glsdp(4, m) - glsdp(3, m))/mass0, & + (glsdp(5, m) - glsdp(4, m))/mass0, & + (glsdp(6, m) - glsdp(5, m))/mass0, & + (glsdp(7, m) - glsdp(6, m))/mass0 + close (nfu) # endif # endif - open (unit = nfu, file = 'trcbud', position = 'append') - write (nfu, '(i8,6e12.4)') nstep - 1, & - (trdp(2, m) - trdp(1, m))/mass0, & - (trdp(3, m) - trdp(2, m))/mass0, & - (trdp(4, m) - trdp(3, m))/mass0, & - (trdp(5, m) - trdp(4, m) + trf*g)/mass0, & - (trdp(6, m) - trdp(5, m))/mass0, & - (trdp(7, m) - trdp(6, m))/mass0 - close (nfu) - open (unit = nfu, file = 'trcbudtot', position = 'append') - write (nfu, '(i8,7e18.10)') nstep - 1, & - trdp(1, m)/mass0, trdp(2, m)/mass0, trdp(3, m)/mass0, & - trdp(4, m)/mass0, trdp(5, m)/mass0, trdp(6, m)/mass0, & - trdp(7, m)/mass0 - close (nfu) + open (unit = nfu, file = 'trcbud', position = 'append') + write (nfu, '(i8,6e12.4)') nstep - 1, & + (trdp(2, m) - trdp(1, m))/mass0, & + (trdp(3, m) - trdp(2, m))/mass0, & + (trdp(4, m) - trdp(3, m) + trf*g)/mass0, & + (trdp(5, m) - trdp(4, m))/mass0, & + (trdp(6, m) - trdp(5, m))/mass0, & + (trdp(7, m) - trdp(6, m))/mass0 + close (nfu) + open (unit = nfu, file = 'trcbudtot', position = 'append') + write (nfu, '(i8,7e18.10)') nstep - 1, & + trdp(1, m)/mass0, trdp(2, m)/mass0, trdp(3, m)/mass0, & + trdp(4, m)/mass0, trdp(5, m)/mass0, trdp(6, m)/mass0, & + trdp(7, m)/mass0 + close (nfu) #endif + + endif + endif + !$omp parallel do private(l, i) do j = 1, jj do l = 1, isp(j) diff --git a/phy/mod_checksum.F90 b/phy/mod_checksum.F90 index 73851df8..ccf0f354 100644 --- a/phy/mod_checksum.F90 +++ b/phy/mod_checksum.F90 @@ -1,5 +1,5 @@ ! ------------------------------------------------------------------------------ -! Copyright (C) 2006-2020 Mats Bentsen +! Copyright (C) 2006-2021 Mats Bentsen ! ! This file is part of BLOM. ! @@ -26,17 +26,56 @@ module mod_checksum private - ! Constants. + ! Options with default values, modifiable by namelist. logical :: & csdiag = .false. ! Flag that indicates whether checksums are written. - integer :: crcfast - external :: crcfast + interface crc32 + module procedure crc32_1d_integer, crc32_2d_r8 + end interface crc32 public :: csdiag, chksum, chksummsk contains + ! --------------------------------------------------------------------------- + ! Private procedures. + ! --------------------------------------------------------------------------- + + function crc32_1d_integer(iarr) + + integer, dimension(:), intent(in) :: iarr + + integer :: crc32_1d_integer + + integer :: crcfast + external :: crcfast + + real(r8), dimension((size(iarr) + 1)/2) :: rarr + + rarr = transfer(iarr, rarr) + + crc32_1d_integer = crcfast(rarr, size(iarr)*4) + + end function crc32_1d_integer + + function crc32_2d_r8(rarr) + + real(r8), dimension(:,:), intent(in) :: rarr + + integer :: crc32_2d_r8 + + integer :: crcfast + external :: crcfast + + crc32_2d_r8 = crcfast(rarr, size(rarr)*8) + + end function crc32_2d_r8 + + ! --------------------------------------------------------------------------- + ! Public procedures. + ! --------------------------------------------------------------------------- + subroutine chksum(a, kcsd, text) ! --------------------------------------------------------------------------- ! Compute checksum of model field. @@ -47,16 +86,21 @@ subroutine chksum(a, kcsd, text) intent(in) :: a character(len = *), intent(in) :: text - real(r8), dimension(itdm, jtdm, kcsd) :: aa + real(r8), dimension(itdm, jtdm) :: aa + integer, dimension(kcsd) :: cslist integer :: kcs do kcs = 1, kcsd - call xcaget(aa(1, 1, kcs), a(1 - nbdy, 1 - nbdy, kcs), 1) + call xcaget(aa, a(1 - nbdy, 1 - nbdy, kcs), 1) + cslist(kcs) = crc32(aa) enddo if (mnproc == 1) then - write (lp,'(3a,z8.8)') ' chksum: ', text, ': 0x', & - crcfast(aa, itdm*jtdm*kcsd*8) + if (kcsd == 1) then + write (lp,'(3a,z8.8)') ' chksum: ', text, ': 0x', cslist(1) + else + write (lp,'(3a,z8.8)') ' chksum: ', text, ': 0x', crc32(cslist) + endif endif end subroutine chksum @@ -73,34 +117,33 @@ subroutine chksummsk(a, msk, kcsd, text) intent(in) :: msk character(len = *), intent(in) :: text - real(r8), dimension(itdm, jtdm, kcsd) :: aa - real(r8), dimension(itdm, jtdm) :: rrmsk - real(r8), dimension(1 - nbdy:idm + nbdy,1 - nbdy:jdm + nbdy) :: rmsk + real(r8), dimension(1 - nbdy:idm + nbdy,1 - nbdy:jdm + nbdy) :: amsk + real(r8), dimension(itdm, jtdm) :: aa + integer, dimension(kcsd) :: cslist integer :: ics, jcs, kcs - do jcs = 1, jj - do ics = 1, ii - rmsk(ics, jcs) = msk(ics, jcs) - enddo - enddo - do kcs = 1, kcsd - call xcaget(aa(1 , 1, kcs), a(1 - nbdy, 1 - nbdy, kcs), 1) + !$omp parallel do private(ics) + do jcs = 1, jj + do ics = 1, ii + if (msk(ics, jcs) == 0) then + amsk(ics, jcs) = 0._r8 + else + amsk(ics, jcs) = a(ics, jcs, kcs) + endif + enddo + enddo + !$omp end parallel do + call xcaget(aa, amsk, 1) + cslist(kcs) = crc32(aa) enddo - call xcaget(rrmsk, rmsk, 1) if (mnproc == 1) then - do kcs = 1, kcsd - do jcs = 1, jtdm - do ics = 1, itdm - if (rrmsk(ics, jcs) < .5_r8) then - aa(ics, jcs, kcs) = 0._r8 - endif - enddo - enddo - enddo - write (lp,'(3a,z8.8)') ' chksum: ', text, ': 0x', & - crcfast(aa, itdm*jtdm*kcsd*8) + if (kcsd == 1) then + write (lp,'(3a,z8.8)') ' chksum: ', text, ': 0x', cslist(1) + else + write (lp,'(3a,z8.8)') ' chksum: ', text, ': 0x', crc32(cslist) + endif endif end subroutine chksummsk diff --git a/phy/mod_cmnfld.F b/phy/mod_cmnfld.F deleted file mode 100644 index c6434679..00000000 --- a/phy/mod_cmnfld.F +++ /dev/null @@ -1,565 +0,0 @@ -! ------------------------------------------------------------------------------ -! Copyright (C) 2015-2020 Mats Bentsen -! -! 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_cmnfld -c -c --- ------------------------------------------------------------------ -c --- This module contains variables and procedures related to common -c --- fields used by several subsequent routines. -c --- ------------------------------------------------------------------ -c - use mod_types, only: r8 - use mod_constants, only: g, alpha0, epsil, spval, onem, onemm - use mod_xc - use mod_grid, only: scuxi, scvyi - use mod_eos, only: rho, p_alpha - use mod_state, only: dp, temp, saln, p, phi, kfpla -c use mod_dia, only : nphy, ACC_BFSQ - use mod_diffusion, only: eitmth, edritp - use mod_utility, only: util1 - use mod_checksum, only: csdiag, chksummsk -c - implicit none -c - private -c -c --- Parameters: - real(r8) :: - . sls0=10._r8*98060._r8, ! Minimum smoothing length scale in the - ! computation of filtered BFSQ - ! [g cm-1 s-2]. - . slsmfq=2._r8, ! Factor to be multiplied with the mixed - ! layer depth to find the smoothing - ! length scale at the base of the mixed - ! layer in the computation of filtered - ! BFSQ []. - . slsels=2._r8, ! Factor to be multiplied with the mixed - ! layer depth to find the e-folding - ! length scale of the smoothing length - ! scale in the computation of filtered - ! BFSQ []. - . bfsqmn=1.e-7_r8 ! Minimum value of BFSQ used in the - ! computation of neutral slope [s-2]. -c - real(r8), dimension(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy,kdm) :: - . bfsqi, ! Interface buoyancy frequency squared - ! [s-2]. - . bfsql, ! Layer buoyancy frequency squared [s-2]. - . bfsqf, ! Filtered interface buoyancy frequency - ! squared [s-2]. - . nslpx, ! x-component of local neutral slope []. - . nslpy, ! y-component of local neutral slope []. - . nnslpx, ! x-component of local neutral slope - ! times buoyancy frequency [s-1]. - . nnslpy ! y-component of local neutral slope - ! times buoyancy frequency [s-1]. -c - public :: bfsql, nslpx, nslpy, nnslpx, nnslpy, - . inivar_cmnfld, cmnfld -c - contains -c -c --- ------------------------------------------------------------------ -c --- Private procedures. -c --- ------------------------------------------------------------------ -c - subroutine cmnfld_bfsqf(m,n,mm,nn,k1m,k1n) -c -c --- ------------------------------------------------------------------ -c --- Compute buoyancy frequency squared (BFSQ) on layer interfaces and -c --- representative of the layer itself. Also compute a filtered BFSQ -c --- on interfaces. -c --- ------------------------------------------------------------------ -c - integer m,n,mm,nn,k1m,k1n -c - real, dimension(kdm) :: delp,bfsq,sls2,atd,btd,ctd,rtd,gam - real pml,q,pup,tup,sup,plo,tlo,slo,bei - integer i,j,k,l,km,kfpl -c -c --- ------------------------------------------------------------------ -c --- The BFSQ is estimated locally at layer interfaces. The filtered -c --- BFSQ is smoothed in the vertical direction by solving a diffusion -c --- equation. At the mixed layer base the diffusion length scale is -c --- set to the maximum of sls0 and mixed layer depth (MLD) times -c --- slsmfq. Below the mixed layer, the diffusion length scale -c --- approaches sls0 with an e-folding length scale of MLD times -c --- slsels. -c --- ------------------------------------------------------------------ -c -c$OMP PARALLEL DO PRIVATE( -c$OMP+ l,i,kfpl,k,pml,delp,bfsq,q,sls2,pup,tup,sup,km,plo,tlo,slo,ctd, -c$OMP+ btd,rtd,atd,bei,gam) - do j=-1,jj+2 - do l=1,isp(j) - do i=max(-1,ifp(j,l)),min(ii+2,ilp(j,l)) -c -c --- --- Compute BFSQ in the mixed layer. - bfsqi(i,j,1)= - . .5*g*g*(rho(p(i,j,2),temp(i,j,2+mm),saln(i,j,2+mm)) - . -rho(p(i,j,2),temp(i,j,1+mm),saln(i,j,1+mm))) - . /(dp(i,j,1+mm)+dp(i,j,2+mm)) - bfsqi(i,j,2)=bfsqi(i,j,1) - bfsql(i,j,1)=bfsqi(i,j,1) - bfsql(i,j,2)=bfsqi(i,j,1) -c - kfpl=kfpla(i,j,m) -c - if (kfpl.gt.kk) then -c -c --- ----- If the mixed layer extends to the bottom, propagate the -c --- ----- interface and layer BFSQ of the mixed layer downwards while -c --- ----- the filtered BFSQ is set to a minimum value. - do k=3,kk - bfsqi(i,j,k)=bfsqi(i,j,1) - bfsql(i,j,k)=bfsqi(i,j,1) - enddo - do k=1,kk - bfsqf(i,j,k)=bfsqmn - enddo -c - else -c -c --- ----- At layer interfaces, compute BFSQ and length scale for the -c --- ----- subsequent smoothing. - pml=max(.5*(p(i,j,3)+p(i,j,1)), - . .5*(3.*p(i,j,3)-p(i,j,kfpl+1))) - delp(kfpl-1)=pml-p(i,j,1) - bfsqi(i,j,kfpl-1)=bfsqi(i,j,2) - bfsq(kfpl-1)=bfsqmn - q=max(sls0,delp(kfpl-1)*slsmfq) - sls2(kfpl-1)=q*q - pup=pml - tup=temp(i,j,2+mm) - sup=saln(i,j,2+mm) - do k=kfpl,kk - km=k+mm - if (p(i,j,kk+1)-p(i,j,k).lt.epsil) then - delp(k)=onemm - bfsqi(i,j,k)=bfsqi(i,j,k-1) - bfsq(k)=bfsqmn - q=exp(-(p(i,j,kk+1)-pml)/(slsels*delp(kfpl-1))) - q=max(sls0,delp(kfpl-1)*slsmfq*q+sls0*(1.-q)) - sls2(k)=q*q - else - if (p(i,j,kk+1)-p(i,j,k+1).lt.epsil) then - plo=p(i,j,kk+1) - else - plo=.5*(p(i,j,k)+p(i,j,k+1)) - endif - tlo=temp(i,j,km) - slo=saln(i,j,km) - delp(k)=max(onemm,plo-pup) - bfsqi(i,j,k)=g*g*(rho(p(i,j,k),tlo,slo) - . -rho(p(i,j,k),tup,sup))/delp(k) - bfsq(k)=max(bfsqmn,bfsqi(i,j,k)) - bfsqi(i,j,k)=bfsqi(i,j,k)*delp(k)/max(onem,delp(k)) - if (p(i,j,kk+1)-p(i,j,k).lt.onem) then - bfsqi(i,j,k)=bfsqi(i,j,k-1) - endif - q=exp(-(p(i,j,k)-pml)/(slsels*delp(kfpl-1))) - q=max(sls0,delp(kfpl-1)*slsmfq*q+sls0*(1.-q)) - sls2(k)=q*q - pup=plo - tup=tlo - sup=slo - endif - enddo -c -c --- ----- Compute the layer BFSQ as the arithmetic mean of the layer -c --- ----- interface BFSQ. - do k=kfpl,kk-1 - bfsql(i,j,k)=.5*(bfsqi(i,j,k)+bfsqi(i,j,k+1)) - enddo - bfsql(i,j,kk)=bfsqi(i,j,kk) - do k=3,kfpl-1 - bfsqi(i,j,k)=bfsqi(i,j,kfpl) - bfsql(i,j,k)=bfsql(i,j,kfpl) - enddo -c -c --- ----- For the filtered BFSQ, compute the coefficients for the -c --- ----- tridiagonal set of equations arising from the implicit -c --- ----- backward discretization. - k=kfpl-1 - ctd(k)=-2.*sls2(k )/(delp(k)*(delp(k )+delp(k+1))) - btd(k)=1.-ctd(k) - rtd(k)=bfsq(k) - do k=kfpl,kk-1 - atd(k)=-2.*sls2(k-1)/(delp(k)*(delp(k-1)+delp(k ))) - ctd(k)=-2.*sls2(k )/(delp(k)*(delp(k )+delp(k+1))) - btd(k)=1.-atd(k)-ctd(k) - rtd(k)=bfsq(k) - enddo - k=kk - atd(k)=-2.*sls2(k-1)/(delp(k)*(delp(k-1)+delp(k ))) - btd(k)=1.-atd(k) - rtd(k)=bfsq(k) -c -c --- ----- Solve the tridiagonal set of equations. - bei=1./btd(kfpl-1) - bfsqf(i,j,kfpl-1)=rtd(kfpl-1)*bei - do k=kfpl,kk - gam(k)=ctd(k-1)*bei - bei=1./(btd(k)-atd(k)*gam(k)) - bfsqf(i,j,k)=(rtd(k)-atd(k)*bfsqf(i,j,k-1))*bei - enddo - do k=kk-1,kfpl-1,-1 - bfsqf(i,j,k)=bfsqf(i,j,k)-gam(k+1)*bfsqf(i,j,k+1) - enddo - do k=1,kfpl-2 - bfsqf(i,j,k)=bfsqf(i,j,kfpl-1) - enddo -c - endif -c - enddo - enddo - enddo -c$OMP END PARALLEL DO -c - if (csdiag) then - if (mnproc.eq.1) then - write (lp,*) 'cmnfld_bfsqf:' - endif - call chksummsk(bfsqi,ip,kk,'bfsqi') - call chksummsk(bfsql,ip,kk,'bfsql') - call chksummsk(bfsqf,ip,kk,'bfsqf') - endif -c - end subroutine cmnfld_bfsqf -c -c --- ------------------------------------------------------------------ -c - subroutine cmnfld_nslope(m,n,mm,nn,k1m,k1n) -c -c --- ------------------------------------------------------------------ -c --- Estimate slope of local neutral surface. -c --- ------------------------------------------------------------------ -c -c - integer m,n,mm,nn,k1m,k1n -c - real rho0,pm,rho_x,phi_x,bfsqm,rho_y,phi_y - integer i,j,k,l,km,kintr,kmax,knnsl -c -c --- ------------------------------------------------------------------ -c --- Compute geopotential at layer interfaces. -c --- ------------------------------------------------------------------ -c -c$OMP PARALLEL DO PRIVATE(k,km,l,i) - do j=-1,jj+2 - do k=kk,1,-1 - km=k+mm - do l=1,isp(j) - do i=max(-1,ifp(j,l)),min(ii+2,ilp(j,l)) - if (dp(i,j,km).lt.epsil) then - phi(i,j,k)=phi(i,j,k+1) - else - phi(i,j,k)=phi(i,j,k+1) - . -p_alpha(p(i,j,k+1),p(i,j,k), - . temp(i,j,km),saln(i,j,km)) - endif - enddo - enddo - enddo - enddo -c$OMP END PARALLEL DO -c -c --- ------------------------------------------------------------------ -c --- Compute slope vector of local neutral surfaces and also slope -c --- vector times Brunt-Vaisala frequency (optionally used in the -c --- computation of eddy growth rate). The latter is not computed when -c --- the gradient of the geopotential is expected to be influenced by -c --- the gradient of the bathymetry and in this case values are -c --- extrapolated from above. -c --- ------------------------------------------------------------------ -c - rho0=1./alpha0 -c -c$OMP PARALLEL DO PRIVATE( -c$OMP+ l,i,k,kmax,km,kintr,knnsl,pm,rho_x,phi_x,bfsqm) - do j=-1,jj+2 - do l=1,isu(j) - do i=max(0,ifu(j,l)),min(ii+2,ilu(j,l)) -c -c --- --- Set the x-component of the slope vector to zero initially. - do k=1,kk - nslpx(i,j,k)=0. - nnslpx(i,j,k)=0. - enddo -c - if (kfpla(i-1,j,m).le.kk.or.kfpla(i,j,m).le.kk) then -c -c --- ----- Index of last layer containing mass at either of the scalar -c --- ----- points adjacent to the velocity point. - kmax=1 - do k=3,kk - km=k+mm - if (dp(i-1,j,km).gt.epsil.or.dp(i,j,km).gt.epsil) kmax=k - enddo -c -c --- ----- The first interior interface where the x-component of the -c --- ----- slope vector is estimated is at index kintr+1. - kintr=max(kfpla(i-1,j,m),kfpla(i,j,m)) -c -c --- ----- Index of last interface where slope vector times -c --- ----- Brunt-Vaisala frequency is computed. - knnsl=2 -c -c --- ----- Compute the x-component of the slope vector at the mixed -c --- ----- layer base. - pm=.5*(p(i-1,j,3)+p(i,j,3)) - rho_x=rho(pm,temp(i ,j,2+mm),saln(i ,j,2+mm)) - . -rho(pm,temp(i-1,j,2+mm),saln(i-1,j,2+mm)) - phi_x=phi(i,j,3)-phi(i-1,j,3) - bfsqm=.5*(bfsqf(i-1,j,3)+bfsqf(i,j,3)) - nslpx(i,j,3)=(g*rho_x/(rho0*bfsqm)+phi_x/g)*scuxi(i,j) - if (phi(i ,j,3).gt.phi(i-1,j,kk+1).and. - . phi(i-1,j,3).gt.phi(i ,j,kk+1)) then - nnslpx(i,j,3)=sqrt(bfsqm)*nslpx(i,j,3) - knnsl=3 - endif -c -c --- ----- Compute the x-component of the slope vector at interior -c --- ----- interfaces. - do k=kintr+1,kmax - km=k+mm - pm=.5*(p(i-1,j,k)+p(i,j,k)) - rho_x=.5*(rho(pm,temp(i ,j,km-1),saln(i ,j,km-1)) - . -rho(pm,temp(i-1,j,km-1),saln(i-1,j,km-1)) - . +rho(pm,temp(i ,j,km ),saln(i ,j,km )) - . -rho(pm,temp(i-1,j,km ),saln(i-1,j,km ))) - phi_x=phi(i,j,k)-phi(i-1,j,k) - bfsqm=.5*(bfsqf(i-1,j,k)+bfsqf(i,j,k)) - nslpx(i,j,k)=(g*rho_x/(rho0*bfsqm)+phi_x/g)*scuxi(i,j) - if (phi(i ,j,k).gt.phi(i-1,j,kk+1).and. - . phi(i-1,j,k).gt.phi(i ,j,kk+1)) then - nnslpx(i,j,k)=sqrt(bfsqm)*nslpx(i,j,k) - knnsl=k - endif - enddo - do k=knnsl+1,kmax - nnslpx(i,j,k)=nnslpx(i,j,knnsl) - enddo - if (kintr.lt.kmax) then - do k=4,kintr - nslpx(i,j,k)=nslpx(i,j,kintr+1) - nnslpx(i,j,k)=nnslpx(i,j,kintr+1) - enddo - else - do k=4,kmax - nslpx(i,j,k)=nslpx(i,j,3) - nnslpx(i,j,k)=nnslpx(i,j,3) - enddo - endif -c - endif -c - enddo - enddo - enddo -c$OMP END PARALLEL DO -c -c$OMP PARALLEL DO PRIVATE( -c$OMP+ l,i,k,kmax,km,kintr,knnsl,pm,rho_y,phi_y,bfsqm) - do j=0,jj+2 - do l=1,isv(j) - do i=max(-1,ifv(j,l)),min(ii+2,ilv(j,l)) -c -c --- --- Set the y-component of the slope vector to zero initially. - do k=1,kk - nslpy(i,j,k)=0. - nnslpy(i,j,k)=0. - enddo -c - if (kfpla(i,j-1,m).le.kk.or.kfpla(i,j,m).le.kk) then -c -c --- ----- Index of last layer containing mass at either of the scalar -c --- ----- points adjacent to the velocity point. - kmax=1 - do k=3,kk - km=k+mm - if (dp(i,j-1,km).gt.epsil.or.dp(i,j,km).gt.epsil) kmax=k - enddo -c -c --- ----- The first interior interface where the y-component of the -c --- ----- slope vector is estimated is at index kintr+1. - kintr=max(kfpla(i,j-1,m),kfpla(i,j,m)) -c -c --- ----- Index of last interface where slope vector times -c --- ----- Brunt-Vaisala frequency is computed. - knnsl=2 -c -c --- ----- Compute the y-component of the slope vector at the mixed -c --- ----- layer base. - pm=.5*(p(i,j-1,3)+p(i,j,3)) - rho_y=rho(pm,temp(i,j ,2+mm),saln(i,j ,2+mm)) - . -rho(pm,temp(i,j-1,2+mm),saln(i,j-1,2+mm)) - phi_y=phi(i,j,3)-phi(i,j-1,3) - bfsqm=.5*(bfsqf(i,j-1,3)+bfsqf(i,j,3)) - nslpy(i,j,3)=(g*rho_y/(rho0*bfsqm)+phi_y/g)*scvyi(i,j) - if (phi(i,j ,3).gt.phi(i,j-1,kk+1).and. - . phi(i,j-1,3).gt.phi(i,j ,kk+1)) then - nnslpy(i,j,3)=sqrt(bfsqm)*nslpy(i,j,3) - knnsl=3 - endif -c -c --- ----- Compute the y-component of the slope vector at interior -c --- ----- interfaces. - do k=kintr+1,kmax - km=k+mm - pm=.5*(p(i,j-1,k)+p(i,j,k)) - rho_y=.5*(rho(pm,temp(i,j ,km-1),saln(i,j ,km-1)) - . -rho(pm,temp(i,j-1,km-1),saln(i,j-1,km-1)) - . +rho(pm,temp(i,j ,km ),saln(i,j ,km )) - . -rho(pm,temp(i,j-1,km ),saln(i,j-1,km ))) - phi_y=phi(i,j,k)-phi(i,j-1,k) - bfsqm=.5*(bfsqf(i,j-1,k)+bfsqf(i,j,k)) - nslpy(i,j,k)=(g*rho_y/(rho0*bfsqm)+phi_y/g)*scvyi(i,j) - if (phi(i,j ,k).gt.phi(i,j-1,kk+1).and. - . phi(i,j-1,k).gt.phi(i,j ,kk+1)) then - nnslpy(i,j,k)=sqrt(bfsqm)*nslpy(i,j,k) - knnsl=k - endif - enddo - do k=knnsl+1,kmax - nnslpy(i,j,k)=nnslpy(i,j,knnsl) - enddo - if (kintr.lt.kmax) then - do k=4,kintr - nslpy(i,j,k)=nslpy(i,j,kintr+1) - nnslpy(i,j,k)=nnslpy(i,j,kintr+1) - enddo - else - do k=4,kmax - nslpy(i,j,k)=nslpy(i,j,3) - nnslpy(i,j,k)=nnslpy(i,j,3) - enddo - endif -c - endif -c - enddo - enddo - enddo -c$OMP END PARALLEL DO -c - if (csdiag) then - if (mnproc.eq.1) then - write (lp,*) 'cmnfld_nslope:' - endif - call chksummsk(nslpx,iu,kk,'nslpx') - call chksummsk(nslpy,iv,kk,'nslpy') - call chksummsk(nnslpx,iu,kk,'nnslpx') - call chksummsk(nnslpy,iv,kk,'nnslpy') - endif -c - end subroutine cmnfld_nslope -c -c --- ------------------------------------------------------------------ -c --- Public procedures. -c --- ------------------------------------------------------------------ -c - subroutine inivar_cmnfld -c -c --- ------------------------------------------------------------------ -c --- Initialize arrays. -c --- ------------------------------------------------------------------ -c - integer :: i,j,k -c -c$OMP PARALLEL DO PRIVATE(i) - do j=1-nbdy,jj+nbdy - do k=1,kk - do i=1-nbdy,ii+nbdy - bfsqi (i,j,k)=spval - bfsql (i,j,k)=spval - bfsqf (i,j,k)=spval - nslpx (i,j,k)=spval - nslpy (i,j,k)=spval - nnslpx(i,j,k)=spval - nnslpy(i,j,k)=spval - enddo - enddo - enddo -c$OMP END PARALLEL DO -c - end subroutine inivar_cmnfld -c -c --- ------------------------------------------------------------------ -c - subroutine cmnfld(m,n,mm,nn,k1m,k1n) -c -c --- ------------------------------------------------------------------ -c --- Compute fields that are used by several subsequent routines -c --- ------------------------------------------------------------------ -c - integer m,n,mm,nn,k1m,k1n -c - integer i,j,l -c -c --- ------------------------------------------------------------------ -c --- Update halos of various fields. -c --- ------------------------------------------------------------------ -c - call xctilr(temp, 1,2*kk, 3,3, halo_ps) - call xctilr(saln, 1,2*kk, 3,3, halo_ps) -c call xctilr(temp(1-nbdy,1-nbdy,k1n), 1,kk, 3,3, halo_ps) -c call xctilr(saln(1-nbdy,1-nbdy,k1n), 1,kk, 3,3, halo_ps) -c$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)) - util1(i,j)=kfpla(i,j,m) - enddo - enddo - enddo -c$OMP END PARALLEL DO - call xctilr(util1, 1,1, 2,2, halo_ps) -c$OMP PARALLEL DO PRIVATE(l,i) - do j=-1,jj+2 - do l=1,isp(j) - do i=max(-1,ifp(j,l)),min(ii+2,ilp(j,l)) - kfpla(i,j,m)=nint(util1(i,j)) - enddo - enddo - enddo -c$OMP END PARALLEL DO -c -c --- ------------------------------------------------------------------ -c --- Compute fields depending on selection of physics. -c --- ------------------------------------------------------------------ -c -c if (edritp.eq.'large scale'.or.eitmth.eq.'gm'.or. -c . sum(ACC_BFSQ(1:nphy)).ne.0) then - if (edritp.eq.'large scale'.or.eitmth.eq.'gm') then -c -c --- - Compute filtered buoyancy frequency squared. - call cmnfld_bfsqf(m,n,mm,nn,k1m,k1n) - endif -c - if (edritp.eq.'large scale'.or.eitmth.eq.'gm') then -c -c --- - Estimate slope of local neutral surface. - call cmnfld_nslope(m,n,mm,nn,k1m,k1n) - endif -c - end subroutine cmnfld -c - end module mod_cmnfld diff --git a/phy/mod_cmnfld.F90 b/phy/mod_cmnfld.F90 new file mode 100644 index 00000000..4b9b8890 --- /dev/null +++ b/phy/mod_cmnfld.F90 @@ -0,0 +1,114 @@ +! ------------------------------------------------------------------------------ +! Copyright (C) 2015-2022 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_cmnfld +! ------------------------------------------------------------------------------ +! This module contains variables and procedures related to common fields used by +! several subsequent routines. +! ------------------------------------------------------------------------------ + + use mod_types, only: r8 + use mod_constants, only: spval, onem, L_mks2cgs + use mod_xc + + implicit none + + private + + ! Parameters: + real(r8) :: & + sls0 = 10._r8*onem, & ! Minimum smoothing length scale in the + ! computation of filtered BFSQ [g cm-1 s-2]. + slsmfq = 2._r8, & ! Factor to be multiplied with the mixed + ! layer depth to find the smoothing length + ! scale at the base of the mixed layer in the + ! computation of filtered BFSQ []. + slsels = 2._r8, & ! Factor to be multiplied with the mixed + ! layer depth to find the e-folding length + ! scale of the smoothing length scale in the + ! computation of filtered BFSQ []. + bfsqmn = 1.e-7_r8, & ! Minimum value of BFSQ used in the + ! computation of neutral slope [s-2]. + dbcrit = .0003_r8*L_mks2cgs! Critical buoyancy difference used in the + ! mixed layer thickness estimation (Levitus, + ! 1982) [cm s-2]. + + real(r8), dimension(1 - nbdy:idm + nbdy, 1 - nbdy:jdm + nbdy, kdm + 1) :: & + bfsqi, & ! Interface buoyancy frequency squared [s-2]. + bfsqf, & ! Filtered interface buoyancy frequency + ! squared [s-2]. + z ! Interface depth [cm]. + real(r8), dimension(1 - nbdy:idm + nbdy, 1 - nbdy:jdm + nbdy, kdm) :: & + bfsql, & ! Layer buoyancy frequency squared [s-2]. + nslpx, & ! x-component of local neutral slope []. + nslpy, & ! y-component of local neutral slope []. + nnslpx, & ! x-component of local neutral slope times + ! buoyancy frequency [s-1]. + nnslpy, & ! y-component of local neutral slope times + ! buoyancy frequency [s-1]. + dz ! Layer thickness [cm]. + real(r8), dimension(1 - nbdy:idm + nbdy, 1 - nbdy:jdm + nbdy) :: & + mlts ! Mixed layer depth defined by density + ! criterion [cm]. + + public :: sls0, slsmfq, slsels, bfsqmn, dbcrit, & + bfsqi, bfsqf, z, bfsql, nslpx, nslpy, nnslpx, nnslpy, dz, mlts, & + inivar_cmnfld + + contains + + ! --------------------------------------------------------------------------- + ! Public procedures. + ! --------------------------------------------------------------------------- + + subroutine inivar_cmnfld + ! --------------------------------------------------------------------------- + ! Initialize arrays. + ! --------------------------------------------------------------------------- + + integer :: i,j,k + + !$omp parallel do private(k, i) + do j = 1 - nbdy, jj + nbdy + do k = 1, kk + 1 + do i = 1 - nbdy, ii + nbdy + bfsqi(i, j, k) = spval + bfsqf(i, j, k) = spval + z (i, j, k) = spval + enddo + enddo + do k = 1, kk + do i = 1 - nbdy, ii + nbdy + bfsql (i, j, k) = spval + nslpx (i, j, k) = spval + nslpy (i, j, k) = spval + nnslpx(i, j, k) = spval + nnslpy(i, j, k) = spval + dz (i, j, k) = spval + enddo + enddo + do i = 1 - nbdy, ii + nbdy + mlts(i, j) = spval + enddo + enddo + !$omp end parallel do + + end subroutine inivar_cmnfld + +end module mod_cmnfld diff --git a/phy/mod_cmnfld_routines.F90 b/phy/mod_cmnfld_routines.F90 new file mode 100644 index 00000000..ef6f7cb1 --- /dev/null +++ b/phy/mod_cmnfld_routines.F90 @@ -0,0 +1,1086 @@ +! ------------------------------------------------------------------------------ +! Copyright (C) 2015-2022 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_cmnfld_routines +! ------------------------------------------------------------------------------ +! This module contains variables and procedures related to common fields used by +! several subsequent 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_grid, only: scuxi, scvyi + use mod_eos, only: rho, p_alpha + use mod_state, only: dp, temp, saln, p, phi, kfpla +! use mod_dia, only : nphy, ACC_BFSQ, ACC_MLTS, ACC_MLTSMN, ACC_MLTSMX, & +! ACC_MLTSSQ, ACC_T20D, ACC_DZ, ACC_DZLVL + use mod_cmnfld, only: sls0, slsmfq, slsels, bfsqmn, dbcrit, & + bfsqi, bfsqf, z, bfsql, nslpx, nslpy, nnslpx, nnslpy, & + dz, mlts + use mod_diffusion, only: eitmth_opt, eitmth_gm, & + edritp_opt, edritp_large_scale, & + ltedtp_opt, ltedtp_neutral + use mod_utility, only: util1 + use mod_checksum, only: csdiag, chksummsk + + implicit none + + private + + public :: cmnfld_bfsqi_cntiso_hybrid, cmnfld1, cmnfld2 + + contains + + ! --------------------------------------------------------------------------- + ! Private procedures. + ! --------------------------------------------------------------------------- + + subroutine cmnfld_bfsqf_isopyc_bulkml(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 + ! interfaces. + ! --------------------------------------------------------------------------- + + integer, intent(in) :: m, n, mm, nn, k1m, k1n + + real(r8), dimension(kdm) :: delp, bfsq, sls2, atd, btd, ctd, rtd, gam + real(r8) :: pml, q, pup, tup, sup, plo, tlo, slo, bei + integer :: i, j, k, l, kn, kfpl + + ! ------------------------------------------------------------------------ + ! The BFSQ is estimated locally at layer interfaces. The filtered BFSQ is + ! smoothed in the vertical direction by solving a diffusion equation. At + ! the mixed layer base the diffusion length scale is set to the maximum of + ! sls0 and mixed layer depth (MLD) times slsmfq. Below the mixed layer, + ! the diffusion length scale approaches sls0 with an e-folding length + ! scale of MLD times slsels. + ! ------------------------------------------------------------------------ + + !$omp parallel do private(l, i, kfpl, k, pml, delp, bfsq, q, sls2, & + !$omp pup, tup, sup, kn, plo, tlo, slo, & + !$omp ctd, btd, rtd, atd, bei, gam) + do j = - 1, jj + 2 + do l = 1, isp(j) + do i = max(- 1, ifp(j, l)), min(ii + 2, ilp(j, l)) + + ! Compute BFSQ in the mixed layer. + bfsqi(i, j, 1) = & + .5_r8*g*g*( rho(p(i, j, 2), & + temp(i, j, 2 + nn), saln(i, j, 2 + nn)) & + - rho(p(i, j, 2), & + temp(i, j, 1 + nn), saln(i, j, 1 + nn))) & + /(dp(i, j, 1 + nn) + dp(i, j, 2 + nn)) + bfsqi(i, j, 2) = bfsqi(i, j, 1) + bfsql(i, j, 1) = bfsqi(i, j, 1) + bfsql(i, j, 2) = bfsqi(i, j, 1) + + kfpl = kfpla(i, j, n) + + if (kfpl > kk) then + + ! If the mixed layer extends to the bottom, propagate the + ! interface and layer BFSQ of the mixed layer downwards while the + ! filtered BFSQ is set to a minimum value. + do k = 3, kk + bfsqi(i, j, k) = bfsqi(i, j, 1) + bfsql(i, j, k) = bfsqi(i, j, 1) + enddo + bfsqi(i, j, kk + 1) = bfsqi(i, j, 1) + do k = 1, kk + 1 + bfsqf(i, j, k) = bfsqmn + enddo + + else + + ! At layer interfaces, compute BFSQ and length scale for the + ! subsequent smoothing. + pml = max(.5_r8*(p(i, j, 3) + p(i, j, 1)), & + .5_r8*(3._r8*p(i, j, 3) - p(i, j, kfpl + 1))) + delp(kfpl - 1) = pml - p(i, j, 1) + bfsqi(i, j, kfpl - 1) = bfsqi(i, j, 2) + bfsq(kfpl - 1) = bfsqmn + q = max(sls0, delp(kfpl - 1)*slsmfq) + sls2(kfpl - 1) = q*q + pup = pml + tup = temp(i, j, 2 + nn) + sup = saln(i, j, 2 + nn) + do k = kfpl, kk + kn = k + nn + if (p(i, j, kk + 1) - p(i, j, k) < epsilp) then + delp(k) = onemm + bfsqi(i, j, k) = bfsqi(i, j, k - 1) + bfsq(k) = bfsqmn + q = exp(- (p(i, j, kk + 1) - pml)/(slsels*delp(kfpl - 1))) + q = max(sls0, delp(kfpl - 1)*slsmfq*q + sls0*(1._r8 - q)) + sls2(k) = q*q + else + if (p(i, j, kk + 1) - p(i, j, k + 1) < epsilp) then + plo = p(i, j, kk + 1) + else + plo = .5_r8*(p(i, j, k) + p(i, j, k + 1)) + endif + tlo = temp(i, j, kn) + slo = saln(i, j, kn) + delp(k) = max(onemm, plo - pup) + bfsqi(i, j, k) = g*g*( rho(p(i, j, k), tlo, slo) & + - rho(p(i, j, k), tup, sup))/delp(k) + bfsq(k) = max(bfsqmn, bfsqi(i, j, k)) + bfsqi(i, j, k) = bfsqi(i, j, k)*delp(k)/max(onem, delp(k)) + if (p(i, j, kk + 1) - p(i, j, k) < onem) then + bfsqi(i, j, k) = bfsqi(i, j, k - 1) + endif + q = exp(- (p(i, j, k) - pml)/(slsels*delp(kfpl - 1))) + q = max(sls0, delp(kfpl - 1)*slsmfq*q + sls0*(1._r8 - q)) + sls2(k) = q*q + pup = plo + tup = tlo + sup = slo + endif + enddo + + ! Compute the layer BFSQ as the arithmetic mean of the layer + ! interface BFSQ. + do k = kfpl, kk - 1 + bfsql(i, j, k) = .5_r8*(bfsqi(i, j, k) + bfsqi(i, j, k + 1)) + enddo + bfsql(i, j, kk) = bfsqi(i, j, kk) + do k = 3, kfpl - 1 + bfsqi(i, j, k) = bfsqi(i, j, kfpl) + bfsql(i, j, k) = bfsql(i, j, kfpl) + enddo + + ! For the filtered BFSQ, compute the coefficients for the + ! tridiagonal set of equations arising from the implicit backward + ! discretization. + k = kfpl - 1 + ctd(k) = - 2._r8*sls2(k ) & + /(delp(k)*(delp(k ) + delp(k + 1))) + btd(k) = 1._r8 - ctd(k) + rtd(k) = bfsq(k) + do k = kfpl, kk - 1 + atd(k) = - 2._r8*sls2(k - 1) & + /(delp(k)*(delp(k - 1) + delp(k ))) + ctd(k) = - 2._r8*sls2(k ) & + /(delp(k)*(delp(k ) + delp(k + 1))) + btd(k) = 1._r8 - atd(k) - ctd(k) + rtd(k) = bfsq(k) + enddo + k = kk + atd(k) = - 2._r8*sls2(k - 1) & + /(delp(k)*(delp(k - 1) + delp(k ))) + btd(k) = 1._r8 - atd(k) + rtd(k) = bfsq(k) + + ! Solve the tridiagonal set of equations. + bei = 1._r8/btd(kfpl - 1) + bfsqf(i, j, kfpl - 1) = rtd(kfpl - 1)*bei + do k = kfpl, kk + gam(k) = ctd(k - 1)*bei + bei = 1._r8/(btd(k) - atd(k)*gam(k)) + bfsqf(i, j, k) = (rtd(k) - atd(k)*bfsqf(i, j, k - 1))*bei + enddo + do k = kk - 1, kfpl - 1, - 1 + bfsqf(i, j, k) = bfsqf(i, j, k) & + - gam(k + 1)*bfsqf(i, j, k + 1) + enddo + do k = 1, kfpl - 2 + bfsqf(i, j, k) = bfsqf(i, j, kfpl - 1) + enddo + + ! Extrapolate to the bottom interface. + bfsqi(i, j, kk + 1) = bfsqi(i, j, kk) + bfsqf(i, j, kk + 1) = bfsqf(i, j, kk) + + endif + + enddo + enddo + enddo + !$omp end parallel do + + if (csdiag) then + if (mnproc == 1) then + write(lp,*) 'cmnfld_bfsqf_isopyc_bulkml:' + 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_isopyc_bulkml + + subroutine cmnfld_bfsqf_cntiso_hybrid(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 + ! interfaces. + ! --------------------------------------------------------------------------- + + integer, intent(in) :: m, n, mm, nn, k1m, k1n + + real(r8), dimension(kdm) :: delp, bfsq, sls2, atd, btd, ctd, rtd, gam + real(r8) :: pup, tup, sup, plo, tlo, slo, bei + integer :: i, j, k, l, kn + + ! ------------------------------------------------------------------------ + ! The BFSQ is estimated locally at layer interfaces. The filtered BFSQ is + ! smoothed in the vertical direction by solving a diffusion equation. + ! ------------------------------------------------------------------------ + + bfsqi = 0.0_r8 + bfsql = 0.0_r8 + !$omp parallel do private(l, i, k, delp, bfsq, sls2, pup, tup, sup, kn, & + !$omp plo, tlo, slo, ctd, btd, rtd, atd, bei, gam) + do j = - 1, jj + 2 + do l = 1, isp(j) + do i = max(- 1, ifp(j, l)), min(ii + 2, ilp(j, l)) + + ! At layer interfaces, compute BFSQ and length scale for the + ! subsequent smoothing. + bfsqi(i, j, 1) = bfsqmn + pup = .5_r8*(p(i, j, 1) + p(i, j, 2)) + tup = temp(i, j, 1 + nn) + sup = saln(i, j, 1 + nn) + do k = 2, kk + kn = k + nn + if (p(i, j, kk + 1) - p(i, j, k) < epsilp) then + delp(k) = onemm + bfsqi(i, j, k) = bfsqi(i, j, k - 1) + bfsq(k) = bfsqmn + sls2(k) = sls0*sls0 + else + if (p(i, j, kk + 1) - p(i, j, k + 1) < epsilp) then + plo = p(i, j, kk + 1) + else + plo = .5_r8*(p(i, j, k) + p(i, j, k + 1)) + endif + tlo = temp(i, j, kn) + slo = saln(i, j, kn) + delp(k) = max(onemm, plo - pup) + bfsqi(i, j, k) = g*g*( rho(p(i, j, k), tlo, slo) & + - rho(p(i, j, k), tup, sup))/delp(k) + bfsq(k) = max(bfsqmn, bfsqi(i, j, k)) + bfsqi(i, j, k) = bfsqi(i, j, k)*delp(k)/max(onem, delp(k)) + if (p(i, j, kk + 1) - p(i, j, k) < onem) then + bfsqi(i, j, k) = bfsqi(i, j, k - 1) + endif + sls2(k) = sls0*sls0 + pup = plo + tup = tlo + sup = slo + endif + enddo + delp(1) = dp(i, j, 1 + nn) + bfsqi(i, j, 1) = bfsqi(i, j, 2) + bfsq(1) = max(bfsqmn, bfsqi(i, j, 1)) + sls2(1) = sls0*sls0 + + ! Compute the layer BFSQ as the arithmetic mean of the layer + ! interface BFSQ. + do k = 1, kk - 1 + bfsql(i, j, k) = .5_r8*(bfsqi(i, j, k) + bfsqi(i, j, k + 1)) + enddo + bfsql(i, j, kk) = bfsqi(i, j, kk) + + ! For the filtered BFSQ, compute the coefficients for the + ! tridiagonal set of equations arising from the implicit backward + ! discretization. + k = 1 + ctd(k) = - 2._r8*sls2(k ) & + /(delp(k)*(delp(k ) + delp(k + 1))) + btd(k) = 1._r8 - ctd(k) + rtd(k) = bfsq(k) + do k = 2, kk - 1 + atd(k) = - 2._r8*sls2(k - 1) & + /(delp(k)*(delp(k - 1) + delp(k ))) + ctd(k) = - 2._r8*sls2(k ) & + /(delp(k)*(delp(k ) + delp(k + 1))) + btd(k) = 1._r8 - atd(k) - ctd(k) + rtd(k) = bfsq(k) + enddo + k = kk + atd(k) = - 2._r8*sls2(k - 1) & + /(delp(k)*(delp(k - 1) + delp(k ))) + btd(k) = 1._r8 - atd(k) + rtd(k) = bfsq(k) + + ! Solve the tridiagonal set of equations. + bei = 1._r8/btd(1) + bfsqf(i, j, 1) = rtd(1)*bei + do k = 2, kk + gam(k) = ctd(k - 1)*bei + bei = 1._r8/(btd(k) - atd(k)*gam(k)) + bfsqf(i, j, k) = (rtd(k) - atd(k)*bfsqf(i, j, k - 1))*bei + enddo + do k = kk - 1, 1, - 1 + bfsqf(i, j, k) = bfsqf(i, j, k) - gam(k + 1)*bfsqf(i, j, k + 1) + enddo + + ! Extrapolate to the bottom interface. + bfsqi(i, j, kk + 1) = bfsqi(i, j, kk) + bfsqf(i, j, kk + 1) = bfsqf(i, j, kk) + + enddo + enddo + enddo + !$omp end parallel do + + if (csdiag) then + if (mnproc == 1) then + write(lp,*) 'cmnfld_bfsqf_cntiso_hybrid:' + 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 + + subroutine cmnfld_bfsqi_cntiso_hybrid(m, n, mm, nn, k1m, k1n) + ! --------------------------------------------------------------------------- + ! Compute buoyancy frequency squared (BFSQ) on layer interfaces. + ! --------------------------------------------------------------------------- + + integer, intent(in) :: m, n, mm, nn, k1m, k1n + + real(r8) :: pup, tup, sup, plo, tlo, slo + integer :: i, j, k, l, kn + + bfsqi = 0.0_r8 + !$omp parallel do private(l, i, k, pup, tup, sup, kn, plo, tlo, slo) + do j = 1, jj + do l = 1, isp(j) + do i = max(1, ifp(j, l)), min(ii, ilp(j, l)) + bfsqi(i, j, 1) = bfsqmn + pup = .5_r8*(p(i, j, 1) + p(i, j, 2)) + tup = temp(i, j, 1 + nn) + sup = saln(i, j, 1 + nn) + do k = 2, kk + kn = k + nn + if (p(i, j, kk + 1) - p(i, j, k) < epsilp) then + bfsqi(i, j, k) = bfsqi(i, j, k - 1) + else + if (p(i, j, kk + 1) - p(i, j, k + 1) < epsilp) then + plo = p(i, j, kk + 1) + else + plo = .5_r8*(p(i, j, k) + p(i, j, k + 1)) + endif + tlo = temp(i, j, kn) + slo = saln(i, j, kn) + bfsqi(i, j, k) = g*g*( rho(p(i, j, k), tlo, slo) & + - rho(p(i, j, k), tup, sup)) & + /max(onem, plo - pup) + if (p(i, j, kk + 1) - p(i, j, k) < onem) then + bfsqi(i, j, k) = bfsqi(i, j, k - 1) + endif + pup = plo + tup = tlo + sup = slo + endif + enddo + bfsqi(i, j, 1) = bfsqi(i, j, 2) + bfsqi(i, j, kk + 1) = bfsqi(i, j, kk) + enddo + enddo + enddo + !$omp end parallel do + + if (csdiag) then + if (mnproc == 1) then + write(lp,*) 'cmnfld_bfsqi_cntiso_hybrid:' + endif + call chksummsk(bfsqi, ip, kk + 1, 'bfsqi') + endif + + end subroutine cmnfld_bfsqi_cntiso_hybrid + + subroutine cmnfld_nslope_isopyc_bulkml(m, n, mm, nn, k1m, k1n) + ! --------------------------------------------------------------------------- + ! Estimate slope of local neutral surface. + ! --------------------------------------------------------------------------- + + integer, intent(in) :: m, n, mm, nn, k1m, k1n + + real(r8) :: pm, rho_x, phi_x, bfsqm, rho_y, phi_y + integer :: i, j, k, l, kn, kintr, kmax, knnsl + + ! ------------------------------------------------------------------------ + ! Compute geopotential at layer interfaces. + ! ------------------------------------------------------------------------ + + !$omp parallel do private(k, kn, l, i) + do j = - 1, jj + 2 + do k = kk, 1, - 1 + kn = k + nn + do l = 1, isp(j) + do i = max(- 1, ifp(j, l)), min(ii + 2, ilp(j, l)) + if (dp(i, j, kn) < epsilp) then + phi(i, j, k) = phi(i, j, k + 1) + else + phi(i, j, k) = phi(i, j, k + 1) & + - p_alpha(p(i, j, k + 1), p(i, j, k), & + temp(i, j, kn), saln(i, j, kn)) + endif + enddo + enddo + enddo + enddo + !$omp end parallel do + + ! ------------------------------------------------------------------------ + ! Compute slope vector of local neutral surfaces and also slope vector + ! times Brunt-Vaisala frequency (optionally used in the computation of + ! eddy growth rate). The latter is not computed when the gradient of the + ! geopotential is expected to be influenced by the gradient of the + ! bathymetry and in this case values are extrapolated from above. + ! ------------------------------------------------------------------------ + + !$omp parallel do private(l, i, k, kmax, kn, kintr, knnsl, pm, rho_x, & + !$omp phi_x, bfsqm) + do j = - 1, jj + 2 + do l = 1, isu(j) + do i = max(0, ifu(j, l)), min(ii + 2, ilu(j, l)) + + ! Set the x-component of the slope vector to zero initially. + do k = 1, kk + nslpx(i, j, k) = 0._r8 + nnslpx(i, j, k) = 0._r8 + enddo + + if (kfpla(i - 1, j, n) <= kk .or. kfpla(i, j, n) <= kk) then + + ! Index of last layer containing mass at either of the scalar + ! points adjacent to the velocity point. + kmax = 1 + do k = 3, kk + kn = k + nn + if (dp(i - 1, j, kn) > epsilp .or. dp(i, j, kn) > epsilp) & + kmax = k + enddo + + ! The first interior interface where the x-component of the slope + ! vector is estimated is at index kintr + 1. + kintr = max(kfpla(i - 1, j, n), kfpla(i, j, n)) + + ! Index of last interface where slope vector times Brunt-Vaisala + ! frequency is computed. + knnsl = 2 + + ! Compute the x-component of the slope vector at the mixed layer + ! base. + pm = .5_r8*(p(i - 1, j, 3) + p(i, j, 3)) + rho_x = rho(pm, temp(i , j, 2 + nn), saln(i , j, 2 + nn)) & + - rho(pm, temp(i - 1, j, 2 + nn), saln(i - 1, j, 2 + nn)) + phi_x = phi(i, j, 3) - phi(i - 1, j, 3) + bfsqm = .5_r8*(bfsqf(i - 1, j, 3) + bfsqf(i, j, 3)) + nslpx(i, j, 3) = (g*rho_x/(rho0*bfsqm) + phi_x/g)*scuxi(i, j) + if (phi(i , j, 3) > phi(i - 1, j, kk + 1) .and. & + phi(i - 1, j, 3) > phi(i , j, kk + 1)) then + nnslpx(i, j, 3) = sqrt(bfsqm)*nslpx(i, j, 3) + knnsl = 3 + endif + + ! Compute the x-component of the slope vector at interior + ! interfaces. + do k = kintr + 1, kmax + kn = k + nn + pm = .5_r8*(p(i - 1, j, k) + p(i, j, k)) + rho_x = .5_r8*( rho(pm, temp(i , j, kn - 1), & + saln(i , j, kn - 1)) & + - rho(pm, temp(i - 1, j, kn - 1), & + saln(i - 1, j, kn - 1)) & + + rho(pm, temp(i , j, kn ), & + saln(i , j, kn )) & + - rho(pm, temp(i - 1, j, kn ), & + saln(i - 1, j, kn ))) + phi_x = phi(i, j, k) - phi(i - 1, j, k) + bfsqm = .5_r8*(bfsqf(i - 1, j, k) + bfsqf(i, j, k)) + nslpx(i, j, k) = (g*rho_x/(rho0*bfsqm) + phi_x/g)*scuxi(i, j) + if (phi(i , j, k) > phi(i - 1, j, kk + 1) .and. & + phi(i - 1, j, k) > phi(i , j, kk + 1)) then + nnslpx(i, j, k) = sqrt(bfsqm)*nslpx(i, j, k) + knnsl = k + endif + enddo + do k = knnsl + 1, kmax + nnslpx(i, j, k) = nnslpx(i, j, knnsl) + enddo + if (kintr < kmax) then + do k = 4, kintr + nslpx(i, j, k) = nslpx(i, j, kintr + 1) + nnslpx(i, j, k) = nnslpx(i, j, kintr + 1) + enddo + else + do k = 4, kmax + nslpx(i, j, k) = nslpx(i, j, 3) + nnslpx(i, j, k) = nnslpx(i, j, 3) + enddo + endif + + endif + + enddo + enddo + enddo + !$omp end parallel do + + !$omp parallel do private(l, i, k, kmax, kn, kintr, knnsl, pm, rho_y, & + !$omp phi_y, bfsqm) + do j = 0, jj + 2 + do l = 1, isv(j) + do i = max(- 1, ifv(j, l)), min(ii + 2, ilv(j, l)) + + ! Set the y-component of the slope vector to zero initially. + do k = 1, kk + nslpy(i, j, k) = 0._r8 + nnslpy(i, j, k) = 0._r8 + enddo + + if (kfpla(i, j - 1, n) <= kk .or. kfpla(i, j, n) <= kk) then + + ! Index of last layer containing mass at either of the scalar + ! points adjacent to the velocity point. + kmax = 1 + do k = 3, kk + kn = k + nn + if (dp(i, j - 1, kn) > epsilp .or. dp(i, j, kn) > epsilp) & + kmax = k + enddo + + ! The first interior interface where the y-component of the slope + ! vector is estimated is at index kintr + 1. + kintr = max(kfpla(i, j - 1, n), kfpla(i, j, n)) + + ! Index of last interface where slope vector times Brunt-Vaisala + ! frequency is computed. + knnsl = 2 + + ! Compute the y-component of the slope vector at the mixed layer + ! base. + pm = .5_r8*(p(i, j - 1, 3) + p(i, j, 3)) + rho_y = rho(pm, temp(i, j , 2 + nn), saln(i, j , 2 + nn)) & + - rho(pm, temp(i, j - 1, 2 + nn), saln(i, j - 1, 2 + nn)) + phi_y = phi(i, j, 3) - phi(i, j - 1, 3) + bfsqm = .5_r8*(bfsqf(i, j - 1, 3) + bfsqf(i, j, 3)) + nslpy(i, j, 3) = (g*rho_y/(rho0*bfsqm) + phi_y/g)*scvyi(i, j) + if (phi(i, j , 3) > phi(i, j - 1, kk + 1) .and. & + phi(i, j - 1, 3) > phi(i, j , kk + 1)) then + nnslpy(i, j, 3) = sqrt(bfsqm)*nslpy(i, j, 3) + knnsl = 3 + endif + + ! Compute the y-component of the slope vector at interior + ! interfaces. + do k = kintr + 1, kmax + kn = k + nn + pm = .5_r8*(p(i, j - 1, k) + p(i, j, k)) + rho_y = .5_r8*( rho(pm, temp(i, j , kn - 1), & + saln(i, j , kn - 1)) & + - rho(pm, temp(i, j - 1, kn - 1), & + saln(i, j - 1, kn - 1)) & + + rho(pm, temp(i, j , kn ), & + saln(i, j , kn )) & + - rho(pm, temp(i, j - 1, kn ), & + saln(i, j - 1, kn ))) + phi_y = phi(i, j, k) - phi(i, j - 1, k) + bfsqm = .5_r8*(bfsqf(i, j - 1, k) + bfsqf(i, j, k)) + nslpy(i, j, k) = (g*rho_y/(rho0*bfsqm) + phi_y/g)*scvyi(i, j) + if (phi(i, j , k) > phi(i, j - 1, kk + 1) .and. & + phi(i, j - 1, k) > phi(i, j , kk + 1)) then + nnslpy(i, j, k) = sqrt(bfsqm)*nslpy(i, j, k) + knnsl = k + endif + enddo + do k = knnsl + 1, kmax + nnslpy(i, j, k) = nnslpy(i, j, knnsl) + enddo + if (kintr < kmax) then + do k = 4, kintr + nslpy(i, j, k) = nslpy(i, j, kintr + 1) + nnslpy(i, j, k) = nnslpy(i, j, kintr + 1) + enddo + else + do k = 4, kmax + nslpy(i, j, k) = nslpy(i, j, 3) + nnslpy(i, j, k) = nnslpy(i, j, 3) + enddo + endif + + endif + + enddo + enddo + enddo + !$omp end parallel do + + if (csdiag) then + if (mnproc == 1) then + write (lp,*) 'cmnfld_nslope_isopyc_bulkml:' + endif + call chksummsk(nslpx, iu, kk, 'nslpx') + call chksummsk(nslpy, iv, kk, 'nslpy') + call chksummsk(nnslpx, iu, kk, 'nnslpx') + call chksummsk(nnslpy, iv, kk, 'nnslpy') + endif + + end subroutine cmnfld_nslope_isopyc_bulkml + + subroutine cmnfld_nslope_cntiso_hybrid(m, n, mm, nn, k1m, k1n) + ! --------------------------------------------------------------------------- + ! Estimate slope of local neutral surface. + ! --------------------------------------------------------------------------- + + integer, intent(in) :: m, n, mm, nn, k1m, k1n + + real(r8) :: pm, rho_x, phi_x, bfsqm, rho_y, phi_y + integer :: i, j, k, l, kn, kmax, knnsl + + ! ------------------------------------------------------------------------ + ! Compute geopotential at layer interfaces. + ! ------------------------------------------------------------------------ + + !$omp parallel do private(k, kn, l, i) + do j = - 1, jj + 2 + do k = kk, 1, - 1 + kn = k + nn + do l = 1, isp(j) + do i = max(- 1, ifp(j, l)), min(ii + 2, ilp(j, l)) + if (dp(i, j, kn) < epsilp) then + phi(i, j, k) = phi(i, j, k + 1) + else + phi(i, j, k) = phi(i, j, k + 1) & + - p_alpha(p(i, j, k + 1), p(i, j, k), & + temp(i, j, kn), saln(i, j, kn)) + endif + enddo + enddo + enddo + enddo + !$omp end parallel do + + ! ------------------------------------------------------------------------ + ! Compute slope vector of local neutral surfaces and also slope vector + ! times Brunt-Vaisala frequency (optionally used in the computation of + ! eddy growth rate). The latter is not computed when the gradient of the + ! geopotential is expected to be influenced by the gradient of the + ! bathymetry and in this case values are extrapolated from above. + ! ------------------------------------------------------------------------ + + !$omp parallel do private(l, i, k, kmax, kn, knnsl, pm, rho_x, phi_x, bfsqm) + do j = - 1, jj + 2 + do l = 1, isu(j) + do i = max(0, ifu(j, l)), min(ii + 2, ilu(j, l)) + + ! Set the x-component of the slope vector to zero initially. + do k = 1, kk + nslpx(i, j, k) = 0._r8 + nnslpx(i, j, k) = 0._r8 + enddo + + ! Index of last layer containing mass at either of the scalar + ! points adjacent to the velocity point. + kmax = 1 + do k = 2, kk + kn = k + nn + if (dp(i - 1, j, kn) > epsilp .or. dp(i, j, kn) > epsilp) kmax=k + enddo + + ! Index of last interface where slope vector times Brunt-Vaisala + ! frequency is computed. + knnsl = 2 + + ! Compute the x-component of the slope vector at interfaces. + do k = 2, kmax + kn = k + nn + pm = .5_r8*(p(i - 1, j, k) + p(i, j, k)) + rho_x = .5_r8*( rho(pm, temp(i , j, kn - 1), & + saln(i , j, kn - 1)) & + - rho(pm, temp(i - 1, j, kn - 1), & + saln(i - 1, j, kn - 1)) & + + rho(pm, temp(i , j, kn ), & + saln(i , j, kn )) & + - rho(pm, temp(i - 1, j, kn ), & + saln(i - 1, j, kn ))) + phi_x = phi(i, j, k) - phi(i - 1, j, k) + bfsqm = .5_r8*(bfsqf(i - 1, j, k) + bfsqf(i, j, k)) + nslpx(i, j, k) = (g*rho_x/(rho0*bfsqm) + phi_x/g)*scuxi(i, j) + if (phi(i , j, k) > phi(i - 1, j, kk + 1) .and. & + phi(i - 1, j, k) > phi(i , j, kk + 1)) then + nnslpx(i, j, k) = sqrt(bfsqm)*nslpx(i, j, k) + knnsl = k + endif + enddo + do k = knnsl + 1, kmax + nnslpx(i, j, k) = nnslpx(i, j, knnsl) + enddo + + enddo + enddo + enddo + !$omp end parallel do + + !$omp parallel do private(l, i, k, kmax, kn, knnsl, pm, rho_y, phi_y, bfsqm) + do j = 0, jj + 2 + do l = 1, isv(j) + do i = max(- 1, ifv(j, l)), min(ii + 2, ilv(j, l)) + + ! Set the y-component of the slope vector to zero initially. + do k = 1, kk + nslpy(i, j, k) = 0._r8 + nnslpy(i, j, k) = 0._r8 + enddo + + ! Index of last layer containing mass at either of the scalar + ! points adjacent to the velocity point. + kmax = 1 + do k = 2, kk + kn = k + nn + if (dp(i, j - 1, kn) > epsilp .or. dp(i, j, kn) > epsilp) kmax=k + enddo + + ! Index of last interface where slope vector times Brunt-Vaisala + ! frequency is computed. + knnsl = 2 + + ! Compute the y-component of the slope vector at interfaces. + do k = 2, kmax + kn = k + nn + pm = .5_r8*(p(i, j - 1, k) + p(i, j, k)) + rho_y = .5_r8*( rho(pm, temp(i, j , kn - 1), & + saln(i, j , kn - 1)) & + - rho(pm, temp(i, j - 1, kn - 1), & + saln(i, j - 1, kn - 1)) & + + rho(pm, temp(i, j , kn ), & + saln(i, j , kn )) & + - rho(pm, temp(i, j - 1, kn ), & + saln(i, j - 1, kn ))) + phi_y = phi(i, j, k) - phi(i, j - 1, k) + bfsqm = .5_r8*(bfsqf(i, j - 1, k) + bfsqf(i, j, k)) + nslpy(i, j, k) = (g*rho_y/(rho0*bfsqm) + phi_y/g)*scvyi(i, j) + if (phi(i, j , k) > phi(i, j - 1, kk + 1) .and. & + phi(i, j - 1, k) > phi(i, j , kk + 1)) then + nnslpy(i, j, k) = sqrt(bfsqm)*nslpy(i, j, k) + knnsl = k + endif + enddo + do k = knnsl + 1, kmax + nnslpy(i, j, k) = nnslpy(i, j, knnsl) + enddo + + enddo + enddo + enddo + !$omp end parallel do + + if (csdiag) then + if (mnproc == 1) then + write (lp,*) 'cmnfld_nslope_cntiso_hybrid:' + endif + call chksummsk(nslpx, iu, kk, 'nslpx') + call chksummsk(nslpy, iv, kk, 'nslpy') + call chksummsk(nnslpx, iu, kk, 'nnslpx') + call chksummsk(nnslpy, iv, kk, 'nnslpy') + endif + + end subroutine cmnfld_nslope_cntiso_hybrid + + subroutine cmnfld_nnslope_cntiso_hybrid(m, n, mm, nn, k1m, k1n) + ! --------------------------------------------------------------------------- + ! Compute neutral slope times buoyancy frequency, where the neutral slope is + ! known. + ! --------------------------------------------------------------------------- + + integer, intent(in) :: m, n, mm, nn, k1m, k1n + + real(r8) :: bfsqm + integer :: i, j, k, l + + call xctilr(nslpx, 1, kk, 2, 2, halo_uv) + call xctilr(nslpy, 1, kk, 2, 2, halo_vv) + + !$omp parallel do private(k, l, i, bfsqm) + do j = - 1, jj + 2 + do k = 1, kk + do l = 1, isu(j) + do i = max(0, ifu(j, l)), min(ii + 2, ilu(j, l)) + bfsqm = .5_r8*(bfsqf(i - 1, j, k) + bfsqf(i, j, k)) + nnslpx(i, j, k) = sqrt(bfsqm)*nslpx(i, j, k) + enddo + enddo + enddo + enddo + !$omp end parallel do + + !$omp parallel do private(k, l, i, bfsqm) + do j = 0, jj + 2 + do k = 1, kk + do l = 1, isv(j) + do i = max(- 1, ifv(j, l)), min(ii + 2, ilv(j, l)) + bfsqm = .5_r8*(bfsqf(i, j - 1, k) + bfsqf(i, j, k)) + nnslpy(i, j, k) = sqrt(bfsqm)*nslpy(i, j, k) + enddo + enddo + enddo + enddo + !$omp end parallel do + + if (csdiag) then + if (mnproc == 1) then + write (lp,*) 'cmnfld_nnslope_cntiso_hybrid:' + endif + call chksummsk(nnslpx, iu, kk, 'nnslpx') + call chksummsk(nnslpy, iv, kk, 'nnslpy') + endif + + end subroutine cmnfld_nnslope_cntiso_hybrid + + subroutine cmnfld_z(m, n, mm, nn, k1m, k1n) + ! --------------------------------------------------------------------------- + ! Estimate depth of layer interfaces and thickness of layers. + ! --------------------------------------------------------------------------- + + integer, intent(in) :: m, n, mm, nn, k1m, k1n + + integer :: i, j, k, l, km + + !$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)) + z(i, j, kk + 1) = - phi(i, j, kk + 1)/g + enddo + enddo + enddo + !$omp end parallel do + !$omp parallel do private(k, km, l, i) + do j = 1, jj + do k = kk, 1, - 1 + km = k + mm + do l = 1, isp(j) + do i = max(1, ifp(j, l)), min(ii, ilp(j, l)) + if (dp(i, j, km) < epsilp) then + z(i, j, k) = z(i, j, k + 1) + else + z(i, j, k) = z(i, j, k + 1) & + + p_alpha(p(i, j, k + 1), p(i, j, k), & + temp(i, j, km), saln(i, j, km))/g + endif + dz(i, j, k) = z(i, j, k + 1) - z(i, j, k) + enddo + enddo + enddo + enddo + !$omp end parallel do + + if (csdiag) then + if (mnproc == 1) then + write (lp,*) 'cmnfld_z:' + endif + call chksummsk(z, ip, kk+1, 'z') + call chksummsk(dz, ip, kk, 'dz') + endif + + end subroutine cmnfld_z + + subroutine cmnfld_mlts(m, n, mm, nn, k1m, k1n) + ! --------------------------------------------------------------------------- + ! Estimate mixed layer depth using density criterion. + ! --------------------------------------------------------------------------- + + integer, intent(in) :: m, n, mm, nn, k1m, k1n + + real(r8) :: zup, dbup, plo, zlo, dblo + integer :: i, j, k, l, km + + !$omp parallel do private(l, i, k, km, zup, dbup, plo, zlo, dblo) + do j = 1, jj + do l = 1, isp(j) + do i = max(1, ifp(j, l)), min(ii, ilp(j, l)) + k = 2 + km = k + mm + zup = z(i, j, 1) + .5_r8*dz(i, j, 1) + dbup = 0._r8 + do + if (dp(i, j, km) > onecm) then + plo = p(i, j, k) + .5_r8*dp(i, j, km) + zlo = z(i, j, k) + .5_r8*dz(i, j, k ) + dblo = & + g*(1._r8 - rho(plo, temp(i, j, k1m), saln(i, j, k1m)) & + /rho(plo, temp(i, j, km ), saln(i, j, km ))) + if (dblo <= dbcrit) then + zup = zlo + dbup = dblo + else + dbup = min(dbup, dbcrit - epsilp) + mlts(i, j) = ( zup*(dblo - dbcrit) & + + zlo*(dbcrit - dbup))/(dblo - dbup) & + - z(i, j, 1) + exit + endif + endif + k = k + 1 + if (k > kk) then + mlts(i, j) = z(i, j, kk + 1) - z(i, j, 1) + exit + endif + km = k + mm + enddo + enddo + enddo + enddo + !$omp end parallel do + + if (csdiag) then + if (mnproc == 1) then + write (lp,*) 'cmnfld_mlts:' + endif + call chksummsk(mlts, ip, 1, 'mlts') + endif + + end subroutine cmnfld_mlts + + ! --------------------------------------------------------------------------- + ! Public procedures. + ! --------------------------------------------------------------------------- + + subroutine cmnfld1(m, n, mm, nn, k1m, k1n) + ! --------------------------------------------------------------------------- + ! Compute fields that are used by several subsequent routines + ! --------------------------------------------------------------------------- + + integer, intent(in) :: m, n, mm, nn, k1m, k1n + + ! ------------------------------------------------------------------------ + ! Compute fields depending on selection of physics and diagnostics. + ! ------------------------------------------------------------------------ + +! if (vcoord_type_tag == cntiso_hybrid .or. & +! sum( ACC_MLTS (1:nphy) + ACC_MLTSMN(1:nphy) & +! + ACC_MLTSMX(1:nphy) + ACC_MLTSSQ(1:nphy) & +! + ACC_T20D (1:nphy) + & +! + ACC_DZ (1:nphy) + ACC_DZLVL(1:nphy)) /= 0) then + + ! --------------------------------------------------------------------- + ! Estimate depth of layer interfaces and thickness of layers. + ! --------------------------------------------------------------------- + + call cmnfld_z(m, n, mm, nn, k1m, k1n) + +! endif + +! if (vcoord_type_tag == cntiso_hybrid .or. & +! sum( ACC_MLTS (1:nphy) + ACC_MLTSMN(1:nphy) & +! + ACC_MLTSMX(1:nphy) + ACC_MLTSSQ(1:nphy)) /= 0) then + + ! --------------------------------------------------------------------- + ! Estimate mixed layer depth using density criterion. + ! --------------------------------------------------------------------- + + call cmnfld_mlts(m, n, mm, nn, k1m, k1n) + +! endif + + end subroutine cmnfld1 + + subroutine cmnfld2(m, n, mm, nn, k1m, k1n) + ! --------------------------------------------------------------------------- + ! Compute fields that are used by several subsequent routines + ! --------------------------------------------------------------------------- + + integer, intent(in) :: m, n, mm, nn, k1m, k1n + + integer :: i, j, l + + ! ------------------------------------------------------------------------ + ! Update halos of various fields. + ! ------------------------------------------------------------------------ + + call xctilr(temp, 1, 2*kk, 3, 3, halo_ps) + call xctilr(saln, 1, 2*kk, 3, 3, halo_ps) +! 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 + !$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)) + util1(i, j) = kfpla(i, j, n) + enddo + enddo + enddo + !$omp end parallel do + call xctilr(util1, 1, 1, 2, 2, halo_ps) + !$omp parallel do private(l, i) + do j = - 1, jj + 2 + do l = 1, isp(j) + do i = max(- 1, ifp(j, l)), min(ii + 2, ilp(j, l)) + kfpla(i, j, n) = nint(util1(i, j)) + enddo + enddo + enddo + !$omp end parallel do + endif + + ! ------------------------------------------------------------------------ + ! Compute fields depending on selection of physics and diagnostics. + ! ------------------------------------------------------------------------ + +! if (vcoord_type_tag == cntiso_hybrid .or. & +! edritp == 'large scale' .or. eitmth == 'gm' .or. & +! sum(ACC_BFSQ(1:nphy)) /= 0) then + if (vcoord_type_tag == cntiso_hybrid .or. & + edritp_opt == edritp_large_scale .or. eitmth_opt == eitmth_gm) then + + ! --------------------------------------------------------------------- + ! Compute filtered buoyancy frequency squared. + ! --------------------------------------------------------------------- + + if (vcoord_type_tag == 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) + endif + + endif + + if (edritp_opt == edritp_large_scale .or. eitmth_opt == eitmth_gm) then + + ! --------------------------------------------------------------------- + ! Estimate slope of local neutral surface. + ! --------------------------------------------------------------------- + + if (vcoord_type_tag == 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) + else + call cmnfld_nslope_cntiso_hybrid(m, n, mm, nn, k1m, k1n) + endif + endif + + endif + + end subroutine cmnfld2 + +end module mod_cmnfld_routines diff --git a/phy/mod_config.F90 b/phy/mod_config.F90 index 860d940b..098d9589 100644 --- a/phy/mod_config.F90 +++ b/phy/mod_config.F90 @@ -34,7 +34,9 @@ module mod_config inst_suffix = '' ! Instance suffix. integer :: & inst_index = 0 ! Instance index. + logical :: & + resume_flag = .false. ! resume flag, use at ocn_run_mct() - public :: expcnf, runid, inst_name, inst_suffix, inst_index + public :: expcnf, runid, inst_name, inst_suffix, inst_index, resume_flag end module mod_config diff --git a/phy/mod_constants.F90 b/phy/mod_constants.F90 index c6db272b..adc6ce9c 100644 --- a/phy/mod_constants.F90 +++ b/phy/mod_constants.F90 @@ -1,5 +1,5 @@ ! ------------------------------------------------------------------------------ -! Copyright (C) 2020 Mats Bentsen +! Copyright (C) 2020-2022 Mats Bentsen, Mehmet Ilicak ! ! This file is part of BLOM. ! @@ -28,6 +28,39 @@ module mod_constants private +#ifdef MKS + ! MKS unit + real(r8), parameter :: & + g = 9.806_r8, & ! Gravitational acceleration [m s-2]. + rearth = 6.37122e6_r8, & ! Radius of the Earth [m]. + spcifh = 3990._r8, & ! Specific heat capacity of sea water + ! [J kg-1 K-1]. + t0deg = 273.15_r8, & ! Zero degrees Celsius in Kelvin [K]. + alpha0 = 1.e-3_r8, & ! Reference value of specific volume + ! [m3 kg-1]. + rho0 = 1.e3_r8, & ! Reference value of density [kg m-3]. + pi = 3.1415926536_r8, & ! pi []. + radian = 57.295779513_r8, & ! 180/pi []. + epsilpl = 1.e-14_r8, & ! Small value for pressure*dx []. + epsilp = 1.e-12_r8, & ! Small value for pressure []. + epsilz = 1.e-9_r8, & ! Small value for depth []. + epsilt = 1.e-11_r8, & ! Small value for time []. + epsilk = 1.e-15_r8, & ! Small value for kappa []. + spval = 1.e33_r8, & ! Large value []. + tenm = 98060._r8, & ! 10 m in units of pressure [kg m-1 s-2]. + onem = 9806._r8, & ! 1 m in units of pressure [kg m-1 s-2]. + tencm = 980.6_r8, & ! 10 cm in units of pressure [kg m-1 s-2]. + onecm = 98.06_r8, & ! 1 cm in units of pressure [kg m-1 s-2]. + onemm = 9.806_r8, & ! 1 mm in units of pressure [kg m-1 s-2]. + onemu = .009806_r8, & ! 1 micrometer in units of pressure + ! [kg m-1 s-2]. + g2kg = 1.e-3_r8, & ! convert g to kg coeff + kg2g = 1.e3_r8, & ! convert kg to g coeff + L_mks2cgs = 1._r8, & ! length coefficient converting CGS to MKS + M_mks2cgs = 1._r8, & ! mass coefficient converting CGS to MKS + P_mks2cgs = 1._r8, & ! pressure coefficient converting CGS to MKS + R_mks2cgs = 1._r8 ! rho coefficient converting CGS to MKS +#else real(r8), parameter :: & g = 980.6_r8, & ! Gravitational acceleration [cm s-2]. rearth = 6.37122e8_r8, & ! Radius of the Earth [cm]. @@ -36,18 +69,33 @@ module mod_constants t0deg = 273.15_r8, & ! Zero degrees Celsius in Kelvin [K]. alpha0 = 1._r8, & ! Reference value of specific volume ! [cm3 g-1]. + rho0 = 1._r8, & ! Reference value of density [kg m-3]. pi = 3.1415926536_r8, & ! pi []. radian = 57.295779513_r8, & ! 180/pi []. - epsil = 1.e-11_r8, & ! Small value []. + epsilpl = 1.e-11_r8, & ! Small value for pressure*dx []. + epsilp = 1.e-11_r8, & ! Small value for pressure []. + epsilz = 1.e-11_r8, & ! Small value for depth []. + epsilt = 1.e-11_r8, & ! Small value for time []. + epsilk = 1.e-11_r8, & ! Small value for kappa []. spval = 1.e33_r8, & ! Large value []. tenm = 980600._r8, & ! 10 m in units of pressure [g cm-1 s-2]. onem = 98060._r8, & ! 1 m in units of pressure [g cm-1 s-2]. tencm = 9806._r8, & ! 10 cm in units of pressure [g cm-1 s-2]. onecm = 980.6_r8, & ! 1 cm in units of pressure [g cm-1 s-2]. - onemm = 98.06_r8 ! 1 mm in units of pressure [g cm-1 s-2]. - + onemm = 98.06_r8, & ! 1 mm in units of pressure [g cm-1 s-2]. + onemu = .09806_r8, & ! 1 micrometer in units of pressure + ! [g cm-1 s-2]. + g2kg = 1.e-3_r8, & ! convert g to kg coeff + kg2g = 1.e3_r8, & ! convert kg to g coeff + L_mks2cgs = 1.e2_r8, & ! length coefficient converting CGS to MKS + M_mks2cgs = 1.e3_r8, & ! mass coefficient converting CGS to MKS + P_mks2cgs = 1.e1_r8, & ! pressure coefficient converting CGS to MKS + R_mks2cgs = 1.e-3_r8 ! rho coefficient converting CGS to MKS +#endif - public :: g, rearth, spcifh, t0deg, alpha0, pi, radian, epsil, spval, & - tenm, onem, tencm, onecm, onemm + public :: g, rearth, spcifh, t0deg, alpha0, rho0, pi, radian, & + epsilpl, epsilp, epsilz, epsilt, epsilk, spval, & + tenm, onem, tencm, onecm, onemm, onemu, g2kg, kg2g, & + L_mks2cgs, M_mks2cgs, P_mks2cgs, R_mks2cgs end module mod_constants diff --git a/phy/mod_dia.F b/phy/mod_dia.F index 300f8cdf..1edf48fd 100644 --- a/phy/mod_dia.F +++ b/phy/mod_dia.F @@ -1,5 +1,5 @@ ! ------------------------------------------------------------------------------ -! Copyright (C) 2010-2020 Ingo Bethke, Mats Bentsen, Mehmet Ilicak, +! Copyright (C) 2010-2022 Ingo Bethke, Mats Bentsen, Mehmet Ilicak, ! Alok Kumar Gupta, Jörg Schwinger, Ping-Gin Chiu ! ! This file is part of BLOM. @@ -18,19 +18,23 @@ ! along with BLOM. If not, see . ! ------------------------------------------------------------------------------ - module mod_dia + module mod_dia c use mod_types, only: i2 use mod_config, only: expcnf, runid, inst_suffix use mod_calendar, only: date_type, date_offset, calendar_noerr use mod_time, only: date0, date, calendar, nstep, nstep_in_day, . nday_of_year, time, time0, baclin, dlt - use mod_constants, only: g, spcifh, t0deg, alpha0, epsil, spval, - . onem, onecm, onemm - use mod_xc + use mod_constants, only: g, spcifh, t0deg, alpha0, epsilp, spval, + . onem, onecm, onemm, + . L_mks2cgs, M_mks2cgs, P_mks2cgs, + . R_mks2cgs, g2kg + use mod_xc use mod_nctools use netcdf, only : nf90_fill_double - use mod_grid, only: sigmar, scp2, depths, area + use mod_vcoord, only: vcoord_type_tag, isopyc_bulkml, + . cntiso_hybrid, 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, . uflx, vflx, utflx, vtflx, usflx, vsflx, @@ -39,10 +43,12 @@ module mod_dia use mod_tmsmt, only: dpold use mod_mxlayr, only: mtkeus, mtkeni, mtkebf, mtkers, mtkepe, . mtkeke, pbrnda + use mod_difest, only: OBLdepth use mod_diffusion, only: difint, difiso, difdia, + . Kvisc_m, Kdiff_t, Kdiff_s, . umfltd, vmfltd, utfltd, vtfltd, utflld, . vtflld, usfltd, vsfltd, usflld, vsflld - use mod_cmnfld, only: bfsql + use mod_cmnfld, only: z, bfsql, dz, mlts use mod_seaice, only: ficem, hicem, hsnwm, uicem, vicem, iagem use mod_forcing, only: swa, nsf, hmltfz, lip, sop, eva, rnf, rfi, . fmltfz, sfl, ztx, mty, abswnd, surflx, @@ -78,24 +84,24 @@ module mod_dia c c --- Copies of BLOM variables that are used for HAMOCC diagnostics real, save, dimension(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy) :: - . pbath,ubath,vbath - integer, save :: nstepinday - -c --- 2d and 3d diagnostic variables - integer, save :: nphyh2d,nphylyr,nphylvl + . pbath,ubath,vbath + integer, save :: nstepinday +c +c --- 2d and 3d diagnostic variables + integer, save :: nphyh2d,nphylyr,nphylvl real, save, allocatable, dimension(:,:,:) :: phyh2d - real, save, allocatable, dimension(:,:,:,:) :: phylyr,phylvl + real, save, allocatable, dimension(:,:,:,:) :: phylyr,phylvl c -c --- Levitus levels -#ifndef LEVITUS2X +c --- Levitus levels +#ifndef LEVITUS2X integer, parameter :: ddm=35,k350=12 real, parameter :: w350=1. real, parameter, dimension(ddm) :: depthslev=(/ - . 0000.0,0010.0,0020.0,0030.0,0050.0,0075.0,0100.0,0125.0,0150.0, - . 0200.0,0250.0,0300.0,0400.0,0500.0,0600.0,0700.0,0800.0,0900.0, - . 1000.0,1100.0,1200.0,1300.0,1400.0,1500.0,1750.0,2000.0,2500.0, + . 0000.0,0010.0,0020.0,0030.0,0050.0,0075.0,0100.0,0125.0,0150.0, + . 0200.0,0250.0,0300.0,0400.0,0500.0,0600.0,0700.0,0800.0,0900.0, + . 1000.0,1100.0,1200.0,1300.0,1400.0,1500.0,1750.0,2000.0,2500.0, . 3000.0,3500.0,4000.0,4500.0,5000.0,5500.0,6000.0,6500.0/) - real, parameter, dimension(2,ddm) :: + real, parameter, dimension(2,ddm) :: . depthslev_bnds=reshape((/ . 0000.0,0005.0,0005.0,0015.0,0015.0,0025.0,0025.0,0040.0,0040.0, . 0062.5,0062.5,0087.5,0087.5,0112.5,0112.5,0137.5,0137.5,0175.0, @@ -105,39 +111,39 @@ module mod_dia . 1450.0,1450.0,1625.0,1625.0,1875.0,1875.0,2250.0,2250.0,2750.0, . 2750.0,3250.0,3250.0,3750.0,3750.0,4250.0,4250.0,4750.0,4750.0, . 5250.0,5250.0,5750.0,5750.0,6250.0,6250.0,8000.0/),(/2,ddm/)) -#else +#else integer, parameter :: ddm=70,k350=25 real, parameter :: w350=0.5 real, parameter, dimension(ddm) :: depthslev=(/ - . 0000.0,0005.0,0010.0,0015.0,0020.0,0025.0,0030.0,0040.0,0050.0, - . 0062.5,0075.0,0087.5,0100.0,0112.5,0125.0,0137.5,0150.0,0175.0, - . 0200.0,0225.0,0250.0,0275.0,0300.0,0350.0,0400.0,0450.0,0500.0, - . 0550.0,0600.0,0650.0,0700.0,0750.0,0800.0,0850.0,0900.0,0950.0, - . 1000.0,1050.0,1100.0,1150.0,1200.0,1250.0,1300.0,1350.0,1400.0, - . 1450.0,1500.0,1625.0,1750.0,1875.0,2000.0,2250.0,2500.0,2750.0, - . 3000.0,3250.0,3500.0,3750.0,4000.0,4250.0,4500.0,4750.0,5000.0, + . 0000.0,0005.0,0010.0,0015.0,0020.0,0025.0,0030.0,0040.0,0050.0, + . 0062.5,0075.0,0087.5,0100.0,0112.5,0125.0,0137.5,0150.0,0175.0, + . 0200.0,0225.0,0250.0,0275.0,0300.0,0350.0,0400.0,0450.0,0500.0, + . 0550.0,0600.0,0650.0,0700.0,0750.0,0800.0,0850.0,0900.0,0950.0, + . 1000.0,1050.0,1100.0,1150.0,1200.0,1250.0,1300.0,1350.0,1400.0, + . 1450.0,1500.0,1625.0,1750.0,1875.0,2000.0,2250.0,2500.0,2750.0, + . 3000.0,3250.0,3500.0,3750.0,4000.0,4250.0,4500.0,4750.0,5000.0, . 5250.0,5500.0,5750.0,6000.0,6250.0,6500.0,6750.0/) - real, parameter, dimension(2,ddm) :: + real, parameter, dimension(2,ddm) :: . depthslev_bnds=reshape((/ - . 0000.0,0002.5,0002.5,0007.5,0007.5,0012.5,0012.5,0017.5,0017.5, - . 0022.5,0022.5,0027.5,0027.5,0035.0,0035.0,0045.0,0045.0,0056.2, - . 0056.2,0068.8,0068.8,0081.2,0081.2,0093.8,0093.8,0106.2,0106.2, - . 0118.8,0118.8,0131.2,0131.2,0143.8,0143.8,0162.5,0162.5,0187.5, - . 0187.5,0212.5,0212.5,0237.5,0237.5,0262.5,0262.5,0287.5,0287.5, - . 0325.0,0325.0,0375.0,0375.0,0425.0,0425.0,0475.0,0475.0,0525.0, - . 0525.0,0575.0,0575.0,0625.0,0625.0,0675.0,0675.0,0725.0,0725.0, - . 0775.0,0775.0,0825.0,0825.0,0875.0,0875.0,0925.0,0925.0,0975.0, - . 0975.0,1025.0,1025.0,1075.0,1075.0,1125.0,1125.0,1175.0,1175.0, - . 1225.0,1225.0,1275.0,1275.0,1325.0,1325.0,1375.0,1375.0,1425.0, - . 1425.0,1475.0,1475.0,1562.5,1562.5,1687.5,1687.5,1812.5,1812.5, - . 1937.5,1937.5,2125.0,2125.0,2375.0,2375.0,2625.0,2625.0,2875.0, - . 2875.0,3125.0,3125.0,3375.0,3375.0,3625.0,3625.0,3875.0,3875.0, - . 4125.0,4125.0,4375.0,4375.0,4625.0,4625.0,4875.0,4875.0,5125.0, - . 5125.0,5375.0,5375.0,5625.0,5625.0,5875.0,5875.0,6125.0,6125.0, + . 0000.0,0002.5,0002.5,0007.5,0007.5,0012.5,0012.5,0017.5,0017.5, + . 0022.5,0022.5,0027.5,0027.5,0035.0,0035.0,0045.0,0045.0,0056.2, + . 0056.2,0068.8,0068.8,0081.2,0081.2,0093.8,0093.8,0106.2,0106.2, + . 0118.8,0118.8,0131.2,0131.2,0143.8,0143.8,0162.5,0162.5,0187.5, + . 0187.5,0212.5,0212.5,0237.5,0237.5,0262.5,0262.5,0287.5,0287.5, + . 0325.0,0325.0,0375.0,0375.0,0425.0,0425.0,0475.0,0475.0,0525.0, + . 0525.0,0575.0,0575.0,0625.0,0625.0,0675.0,0675.0,0725.0,0725.0, + . 0775.0,0775.0,0825.0,0825.0,0875.0,0875.0,0925.0,0925.0,0975.0, + . 0975.0,1025.0,1025.0,1075.0,1075.0,1125.0,1125.0,1175.0,1175.0, + . 1225.0,1225.0,1275.0,1275.0,1325.0,1325.0,1375.0,1375.0,1425.0, + . 1425.0,1475.0,1475.0,1562.5,1562.5,1687.5,1687.5,1812.5,1812.5, + . 1937.5,1937.5,2125.0,2125.0,2375.0,2375.0,2625.0,2625.0,2875.0, + . 2875.0,3125.0,3125.0,3375.0,3375.0,3625.0,3625.0,3875.0,3875.0, + . 4125.0,4125.0,4375.0,4375.0,4625.0,4625.0,4875.0,4875.0,5125.0, + . 5125.0,5375.0,5375.0,5625.0,5625.0,5875.0,5875.0,6125.0,6125.0, . 6375.0,6375.0,6625.0,6625.0,8000.0/),(/2,ddm/)) -#endif +#endif c -c --- Meridional overturning and flux diagnostics +c --- Meridional overturning and flux diagnostics integer, parameter :: . ldm=itdm+jtdm,sdm=ldm,odm=10,slenmax=50,rflgdm=20 character(len=slenmax), save, dimension(odm) :: mer_regnam='' @@ -145,15 +151,15 @@ module mod_dia integer, save, dimension(odm,rflgdm) :: mer_regflg=-1 integer, save, dimension(odm) :: mer_nflg real, save, dimension(odm) :: mer_minlat=-90.,mer_maxlat=90. - integer, save :: mer_nreg,lmax + integer, save :: mer_nreg,lmax real, save, dimension(ldm) :: mtlat - real, save, dimension(kdm) :: sigmar1 + real, save, dimension(kdm) :: sigmar1 real, save, allocatable, dimension(:,:,:) :: . mmflxl,mmftdl,mmflxd,mmftdd real, save, allocatable, dimension(:,:) :: . mhflx,mhftd,mhfld,msflx,msftd,msfld c -c --- Section transports +c --- Section transports character(len=256), save :: sec_sifile integer, save :: sec_num integer, parameter :: max_sec=400 @@ -165,41 +171,46 @@ module mod_dia c c --- Pressure thickness [g cm-1 s-2] of region for bottom salinity and c --- temperature diagnostics - real, parameter :: dpbot=98060. + real, parameter :: dpbot=onem c -c --- Critical buoyancy difference [cm s-2] used in the mixed layer -c --- thickness estimation (Levitus, 1982) - real, parameter :: dbcrit=.03 + real, parameter :: + . L_cgs2mks=1./L_mks2cgs, + . A_cgs2mks=1./(L_mks2cgs**2), + . V_cgs2mks=1./(L_mks2cgs**3), + . M_cgs2mks=1./M_mks2cgs, + . P_cgs2mks=1./P_mks2cgs, + . R_cgs2mks=1./R_mks2cgs c -c --- Namelist +c --- Namelist integer, dimension(nphymax), save :: . H2D_ABSWND ,H2D_ALB ,H2D_BTMSTR ,H2D_BRNFLX ,H2D_BRNPD , . H2D_DFL ,H2D_EVA ,H2D_FICE ,H2D_FMLTFZ ,H2D_HICE , . H2D_HMLTFZ ,H2D_HSNW ,H2D_IAGE ,H2D_IDKEDT ,H2D_LIP , - . H2D_MAXMLD ,H2D_MLD ,H2D_MLDU ,H2D_MLDV ,H2D_MLTS , - . H2D_MLTSMN ,H2D_MLTSMX ,H2D_MLTSSQ ,H2D_MTKEUS ,H2D_MTKENI , - . H2D_MTKEBF ,H2D_MTKERS ,H2D_MTKEPE ,H2D_MTKEKE ,H2D_MTY , - . H2D_MXLU ,H2D_MXLV ,H2D_NSF ,H2D_PBOT ,H2d_PSRF , - . H2D_RFIFLX ,H2D_RNFFLX ,H2D_SALFLX ,H2D_SALRLX ,H2D_SBOT , - . H2D_SEALV ,H2D_SLVSQ ,H2D_SFL ,H2D_SOP ,H2D_SIGMX , - . H2D_SSS ,H2D_SSSSQ ,H2D_SST ,H2D_SSTSQ ,H2D_SURFLX , - . H2D_SURRLX ,H2D_SWA ,H2D_T20D ,H2D_TAUX ,H2D_TAUY , - . H2D_TBOT ,H2D_TICE ,H2D_TSRF ,H2D_UB ,H2D_UICE , - . H2D_USTAR ,H2D_USTAR3 ,H2D_VB ,H2D_VICE ,H2D_ZTX , - . LYR_BFSQ ,LYR_DIFDIA ,LYR_DIFINT ,LYR_DIFISO ,LYR_DP , - . LYR_DPU ,LYR_DPV ,LYR_DZ ,LYR_SALN ,LYR_TEMP , - . LYR_TRC ,LYR_UFLX ,LYR_UTFLX ,LYR_USFLX ,LYR_UMFLTD , - . LYR_UTFLTD ,LYR_UTFLLD ,LYR_USFLTD ,LYR_USFLLD ,LYR_UVEL , - . LYR_VFLX ,LYR_VTFLX ,LYR_VSFLX ,LYR_VMFLTD ,LYR_VTFLTD , - . LYR_VTFLLD ,LYR_VSFLTD ,LYR_VSFLLD ,LYR_VVEL ,LYR_WFLX , - . LYR_WFLX2 ,LYR_PV ,LYR_TKE ,LYR_GLS_PSI,LYR_IDLAGE , - . LVL_BFSQ ,LVL_DIFDIA ,LVL_DIFINT ,LVL_DIFISO ,LVL_DZ , - . LVL_SALN ,LVL_TEMP ,LVL_TRC ,LVL_UFLX ,LVL_UTFLX , - . LVL_USFLX ,LVL_UMFLTD ,LVL_UTFLTD ,LVL_UTFLLD ,LVL_USFLTD , - . LVL_USFLLD ,LVL_UVEL ,LVL_VFLX ,LVL_VTFLX ,LVL_VSFLX , - . LVL_VMFLTD ,LVL_VTFLTD ,LVL_VTFLLD ,LVL_VSFLTD ,LVL_VSFLLD , - . LVL_VVEL ,LVL_WFLX ,LVL_WFLX2 ,LVL_PV ,LVL_TKE , - . LVL_GLS_PSI,LVL_IDLAGE , + . H2D_MAXMLD ,H2D_MLD ,H2D_MLTS ,H2D_MLTSMN ,H2D_MLTSMX , + . H2D_MLTSSQ ,H2D_MTKEUS ,H2D_MTKENI ,H2D_MTKEBF ,H2D_MTKERS , + . H2D_MTKEPE ,H2D_MTKEKE ,H2D_MTY ,H2D_NSF ,H2D_PBOT , + . H2D_PSRF ,H2D_RFIFLX ,H2D_RNFFLX ,H2D_SALFLX ,H2D_SALRLX , + . H2D_SBOT ,H2D_SEALV ,H2D_SLVSQ ,H2D_SFL ,H2D_SOP , + . H2D_SIGMX ,H2D_SSS ,H2D_SSSSQ ,H2D_SST ,H2D_SSTSQ , + . H2D_SURFLX ,H2D_SURRLX ,H2D_SWA ,H2D_T20D ,H2D_TAUX , + . H2D_TAUY ,H2D_TBOT ,H2D_TICE ,H2D_TSRF ,H2D_UB , + . H2D_UICE ,H2D_USTAR ,H2D_USTAR3 ,H2D_VB ,H2D_VICE , + . H2D_ZTX , + . LYR_BFSQ ,LYR_DIFDIA ,LYR_DIFVMO ,LYR_DIFVHO ,LYR_DIFVSO , + . LYR_DIFINT ,LYR_DIFISO ,LYR_DP ,LYR_DPU ,LYR_DPV , + . LYR_DZ ,LYR_SALN ,LYR_TEMP ,LYR_TRC ,LYR_UFLX , + . LYR_UTFLX ,LYR_USFLX ,LYR_UMFLTD ,LYR_UTFLTD ,LYR_UTFLLD , + . LYR_USFLTD ,LYR_USFLLD ,LYR_UVEL ,LYR_VFLX ,LYR_VTFLX , + . LYR_VSFLX ,LYR_VMFLTD ,LYR_VTFLTD ,LYR_VTFLLD ,LYR_VSFLTD , + . LYR_VSFLLD ,LYR_VVEL ,LYR_WFLX ,LYR_WFLX2 ,LYR_PV , + . LYR_TKE ,LYR_GLS_PSI,LYR_IDLAGE , + . LVL_BFSQ ,LVL_DIFDIA ,LVL_DIFVMO ,LVL_DIFVHO ,LVL_DIFVSO , + . LVL_DIFINT ,LVL_DIFISO ,LVL_DZ ,LVL_SALN ,LVL_TEMP , + . LVL_TRC ,LVL_UFLX ,LVL_UTFLX ,LVL_USFLX ,LVL_UMFLTD , + . LVL_UTFLTD ,LVL_UTFLLD ,LVL_USFLTD ,LVL_USFLLD ,LVL_UVEL , + . LVL_VFLX ,LVL_VTFLX ,LVL_VSFLX ,LVL_VMFLTD ,LVL_VTFLTD , + . LVL_VTFLLD ,LVL_VSFLTD ,LVL_VSFLLD ,LVL_VVEL ,LVL_WFLX , + . LVL_WFLX2 ,LVL_PV ,LVL_TKE ,LVL_GLS_PSI,LVL_IDLAGE , . MSC_MMFLXL ,MSC_MMFLXD ,MSC_MMFTDL ,MSC_MMFTDD ,MSC_MHFLX , . MSC_MHFTD ,MSC_MHFLD ,MSC_MSFLX ,MSC_MSFTD ,MSC_MSFLD , . MSC_VOLTR ,MSC_MASSGS ,MSC_VOLGS ,MSC_SALNGA ,MSC_TEMPGA , @@ -210,35 +221,35 @@ module mod_dia . ACC_ABSWND ,ACC_ALB ,ACC_BRNFLX ,ACC_BRNPD ,ACC_DFL , . ACC_EVA ,ACC_FICE ,ACC_FMLTFZ ,ACC_HICE ,ACC_HMLTFZ , . ACC_HSNW ,ACC_IAGE ,ACC_IDKEDT ,ACC_LIP ,ACC_MAXMLD , - . ACC_MLD ,ACC_MLDU ,ACC_MLDV ,ACC_MLTS ,ACC_MLTSMN , - . ACC_MLTSMX ,ACC_MLTSSQ ,ACC_MTKEUS ,ACC_MTKENI ,ACC_MTKEBF , - . ACC_MTKERS ,ACC_MTKEPE ,ACC_MTKEKE ,ACC_MTY ,ACC_MXLU , - . ACC_MXLV ,ACC_NSF ,ACC_PBOT ,ACC_PSRF ,ACC_RFIFLX , - . ACC_RNFFLX ,ACC_SALFLX ,ACC_SALRLX ,ACC_SBOT ,ACC_SEALV , - . ACC_SLVSQ ,ACC_SFL ,ACC_SOP ,ACC_SIGMX ,ACC_SSS , - . ACC_SSSSQ ,ACC_SST ,ACC_SSTSQ ,ACC_SURFLX ,ACC_SURRLX , - . ACC_SWA ,ACC_T20D ,ACC_TAUX ,ACC_TAUY ,ACC_TBOT , - . ACC_TICE ,ACC_TSRF ,ACC_UB ,ACC_UBFLXS ,ACC_UICE , - . ACC_USTAR ,ACC_USTAR3 ,ACC_VB ,ACC_VBFLXS ,ACC_VICE , - . ACC_ZTX ,ACC_IVOLU ,ACC_IVOLV ,ACC_UTILH2D, - . ACC_BFSQ ,ACC_DIFDIA ,ACC_DIFINT ,ACC_DIFISO ,ACC_DP , - . ACC_DPU ,ACC_DPV ,ACC_DZ ,ACC_SALN ,ACC_TEMP , - . ACC_UFLX ,ACC_UTFLX ,ACC_USFLX ,ACC_UMFLTD ,ACC_UTFLTD , - . ACC_UTFLLD ,ACC_USFLTD ,ACC_USFLLD ,ACC_UVEL ,ACC_VFLX , - . ACC_VTFLX ,ACC_VSFLX ,ACC_VMFLTD ,ACC_VTFLTD ,ACC_VTFLLD , - . ACC_VSFLTD ,ACC_VSFLLD ,ACC_VVEL ,ACC_WFLX ,ACC_WFLX2 , - . ACC_AVDSG ,ACC_DPVOR ,ACC_TKE ,ACC_GLS_PSI,ACC_UTILLYR, - . ACC_BFSQLVL ,ACC_DIFDIALVL ,ACC_DIFINTLVL,ACC_DIFISOLVL, - . ACC_DZLVL ,ACC_SALNLVL ,ACC_TEMPLVL ,ACC_UFLXLVL , - . ACC_UTFLXLVL ,ACC_USFLXLVL ,ACC_UMFLTDLVL,ACC_UTFLTDLVL, - . ACC_UTFLLDLVL,ACC_USFLTDLVL ,ACC_USFLLDLVL,ACC_UVELLVL , - . ACC_VFLXLVL ,ACC_VTFLXLVL ,ACC_VSFLXLVL ,ACC_VMFLTDLVL, - . ACC_VTFLTDLVL,ACC_VTFLLDLVL ,ACC_VSFLTDLVL,ACC_VSFLLDLVL, - . ACC_VVELLVL ,ACC_WFLXLVL ,ACC_WFLX2LVL ,ACC_PVLVL , - . ACC_TKELVL ,ACC_GLS_PSILVL,ACC_UFLXOLD ,ACC_VFLXOLD , - . ACC_UTILLVL , + . ACC_MLD ,ACC_MLTS ,ACC_MLTSMN ,ACC_MLTSMX ,ACC_MLTSSQ , + . ACC_MTKEUS ,ACC_MTKENI ,ACC_MTKEBF ,ACC_MTKERS ,ACC_MTKEPE , + . ACC_MTKEKE ,ACC_MTY ,ACC_NSF ,ACC_PBOT ,ACC_PSRF , + . ACC_RFIFLX ,ACC_RNFFLX ,ACC_SALFLX ,ACC_SALRLX ,ACC_SBOT , + . ACC_SEALV ,ACC_SLVSQ ,ACC_SFL ,ACC_SOP ,ACC_SIGMX , + . ACC_SSS ,ACC_SSSSQ ,ACC_SST ,ACC_SSTSQ ,ACC_SURFLX , + . ACC_SURRLX ,ACC_SWA ,ACC_T20D ,ACC_TAUX ,ACC_TAUY , + . ACC_TBOT ,ACC_TICE ,ACC_TSRF ,ACC_UB ,ACC_UBFLXS , + . ACC_UICE ,ACC_USTAR ,ACC_USTAR3 ,ACC_VB ,ACC_VBFLXS , + . ACC_VICE ,ACC_ZTX ,ACC_IVOLU ,ACC_IVOLV ,ACC_UTILH2D, + . ACC_BFSQ ,ACC_DIFDIA ,ACC_DIFVMO ,ACC_DIFVHO ,ACC_DIFVSO , + . ACC_DIFINT ,ACC_DIFISO ,ACC_DP ,ACC_DPU ,ACC_DPV , + . ACC_DZ ,ACC_SALN ,ACC_TEMP ,ACC_UFLX ,ACC_UTFLX , + . ACC_USFLX ,ACC_UMFLTD ,ACC_UTFLTD ,ACC_UTFLLD ,ACC_USFLTD , + . ACC_USFLLD ,ACC_UVEL ,ACC_VFLX ,ACC_VTFLX ,ACC_VSFLX , + . ACC_VMFLTD ,ACC_VTFLTD ,ACC_VTFLLD ,ACC_VSFLTD ,ACC_VSFLLD , + . ACC_VVEL ,ACC_WFLX ,ACC_WFLX2 ,ACC_AVDSG ,ACC_DPVOR , + . ACC_TKE ,ACC_GLS_PSI,ACC_UTILLYR, + . ACC_BFSQLVL ,ACC_DIFDIALVL,ACC_DIFVMOLVL,ACC_DIFVHOLVL, + . ACC_DIFVSOLVL ,ACC_DIFINTLVL,ACC_DIFISOLVL,ACC_DZLVL , + . ACC_SALNLVL ,ACC_TEMPLVL ,ACC_UFLXLVL ,ACC_UTFLXLVL , + . ACC_USFLXLVL ,ACC_UMFLTDLVL,ACC_UTFLTDLVL,ACC_UTFLLDLVL, + . ACC_USFLTDLVL ,ACC_USFLLDLVL,ACC_UVELLVL ,ACC_VFLXLVL , + . ACC_VTFLXLVL ,ACC_VSFLXLVL ,ACC_VMFLTDLVL,ACC_VTFLTDLVL, + . ACC_VTFLLDLVL ,ACC_VSFLTDLVL,ACC_VSFLLDLVL,ACC_VVELLVL , + . ACC_WFLXLVL ,ACC_WFLX2LVL ,ACC_PVLVL ,ACC_TKELVL , + . ACC_GLS_PSILVL,ACC_UFLXOLD ,ACC_VFLXOLD ,ACC_UTILLVL , . ACC_MMFLXL,ACC_MMFLXD,ACC_MMFTDL,ACC_MMFTDD,ACC_MHFLX,ACC_MHFTD, - . ACC_MHFLD ,ACC_MSFLX ,ACC_MSFTD ,ACC_MSFLD ,ACC_VOLTR + . ACC_MHFLD ,ACC_MSFLX ,ACC_MSFTD ,ACC_MSFLD ,ACC_VOLTR namelist /MERDIA/ . MER_ORFILE,MER_MIFILE,MER_REGNAM,MER_REGFLG,MER_MINLAT,MER_MAXLAT namelist /SECDIA/ @@ -247,40 +258,41 @@ module mod_dia . H2D_ABSWND ,H2D_ALB ,H2D_BTMSTR ,H2D_BRNFLX ,H2D_BRNPD , . H2D_DFL ,H2D_EVA ,H2D_FICE ,H2D_FMLTFZ ,H2D_HICE , . H2D_HMLTFZ ,H2D_HSNW ,H2D_IAGE ,H2D_IDKEDT ,H2D_LIP , - . H2D_MAXMLD ,H2D_MLD ,H2D_MLDU ,H2D_MLDV ,H2D_MLTS , - . H2D_MLTSMN ,H2D_MLTSMX ,H2D_MLTSSQ ,H2D_MTKEUS ,H2D_MTKENI , - . H2D_MTKEBF ,H2D_MTKERS ,H2D_MTKEPE ,H2D_MTKEKE ,H2D_MTY , - . H2D_MXLU ,H2D_MXLV ,H2D_NSF ,H2D_PBOT ,H2D_PSRF , - . H2D_RFIFLX ,H2D_RNFFLX ,H2D_SALFLX ,H2D_SALRLX ,H2D_SBOT , - . H2D_SEALV ,H2D_SLVSQ ,H2D_SFL ,H2D_SOP ,H2D_SIGMX , - . H2D_SSS ,H2D_SSSSQ ,H2D_SST ,H2D_SSTSQ ,H2D_SURFLX , - . H2D_SURRLX ,H2D_SWA ,H2d_T20D ,H2D_TAUX ,H2D_TAUY , - . H2D_TBOT ,H2D_TICE ,H2D_TSRF ,H2D_UB ,H2D_UICE , - . H2D_USTAR ,H2D_USTAR3 ,H2D_VB ,H2D_VICE ,H2D_ZTX , - . LYR_BFSQ ,LYR_DIFDIA ,LYR_DIFINT ,LYR_DIFISO ,LYR_DP , - . LYR_DPU ,LYR_DPV ,LYR_DZ ,LYR_SALN ,LYR_TEMP , - . LYR_TRC ,LYR_UFLX ,LYR_UTFLX ,LYR_USFLX ,LYR_UMFLTD , - . LYR_UTFLTD ,LYR_UTFLLD ,LYR_USFLTD ,LYR_USFLLD ,LYR_UVEL , - . LYR_VFLX ,LYR_VTFLX ,LYR_VSFLX ,LYR_VMFLTD ,LYR_VTFLTD , - . LYR_VTFLLD ,LYR_VSFLTD ,LYR_VSFLLD ,LYR_VVEL ,LYR_WFLX , - . LYR_WFLX2 ,LYR_PV ,LYR_TKE ,LYR_GLS_PSI,LYR_IDLAGE , - . LVL_BFSQ ,LVL_DIFDIA ,LVL_DIFINT ,LVL_DIFISO ,LVL_DZ , - . LVL_SALN ,LVL_TEMP ,LVL_TRC ,LVL_UFLX ,LVL_UTFLX , - . LVL_USFLX ,LVL_UMFLTD ,LVL_UTFLTD ,LVL_UTFLLD ,LVL_USFLTD , - . LVL_USFLLD ,LVL_UVEL ,LVL_VFLX ,LVL_VTFLX ,LVL_VSFLX , - . LVL_VMFLTD ,LVL_VTFLTD ,LVL_VTFLLD ,LVL_VSFLTD ,LVL_VSFLLD , - . LVL_VVEL ,LVL_WFLX ,LVL_WFLX2 ,LVL_PV ,LVL_TKE , - . LVL_GLS_PSI,LVL_IDLAGE , + . H2D_MAXMLD ,H2D_MLD ,H2D_MLTS ,H2D_MLTSMN ,H2D_MLTSMX , + . H2D_MLTSSQ ,H2D_MTKEUS ,H2D_MTKENI ,H2D_MTKEBF ,H2D_MTKERS , + . H2D_MTKEPE ,H2D_MTKEKE ,H2D_MTY ,H2D_NSF ,H2D_PBOT , + . H2D_PSRF ,H2D_RFIFLX ,H2D_RNFFLX ,H2D_SALFLX ,H2D_SALRLX , + . H2D_SBOT ,H2D_SEALV ,H2D_SLVSQ ,H2D_SFL ,H2D_SOP , + . H2D_SIGMX ,H2D_SSS ,H2D_SSSSQ ,H2D_SST ,H2D_SSTSQ , + . H2D_SURFLX ,H2D_SURRLX ,H2D_SWA ,H2D_T20D ,H2D_TAUX , + . H2D_TAUY ,H2D_TBOT ,H2D_TICE ,H2D_TSRF ,H2D_UB , + . H2D_UICE ,H2D_USTAR ,H2D_USTAR3 ,H2D_VB ,H2D_VICE , + . H2D_ZTX , + . LYR_BFSQ ,LYR_DIFDIA ,LYR_DIFVMO ,LYR_DIFVHO ,LYR_DIFVSO , + . LYR_DIFINT ,LYR_DIFISO ,LYR_DP ,LYR_DPU ,LYR_DPV , + . LYR_DZ ,LYR_SALN ,LYR_TEMP ,LYR_TRC ,LYR_UFLX , + . LYR_UTFLX ,LYR_USFLX ,LYR_UMFLTD ,LYR_UTFLTD ,LYR_UTFLLD , + . LYR_USFLTD ,LYR_USFLLD ,LYR_UVEL ,LYR_VFLX ,LYR_VTFLX , + . LYR_VSFLX ,LYR_VMFLTD ,LYR_VTFLTD ,LYR_VTFLLD ,LYR_VSFLTD , + . LYR_VSFLLD ,LYR_VVEL ,LYR_WFLX ,LYR_WFLX2 ,LYR_PV , + . LYR_TKE ,LYR_GLS_PSI,LYR_IDLAGE , + . LVL_BFSQ ,LVL_DIFDIA ,LVL_DIFVMO ,LVL_DIFVHO ,LVL_DIFVSO , + . LVL_DIFINT ,LVL_DIFISO ,LVL_DZ ,LVL_SALN ,LVL_TEMP , + . LVL_TRC ,LVL_UFLX ,LVL_UTFLX ,LVL_USFLX ,LVL_UMFLTD , + . LVL_UTFLTD ,LVL_UTFLLD ,LVL_USFLTD ,LVL_USFLLD ,LVL_UVEL , + . LVL_VFLX ,LVL_VTFLX ,LVL_VSFLX ,LVL_VMFLTD ,LVL_VTFLTD , + . LVL_VTFLLD ,LVL_VSFLTD ,LVL_VSFLLD ,LVL_VVEL ,LVL_WFLX , + . LVL_WFLX2 ,LVL_PV ,LVL_TKE ,LVL_GLS_PSI,LVL_IDLAGE , . MSC_MMFLXL ,MSC_MMFLXD ,MSC_MMFTDL ,MSC_MMFTDD ,MSC_MHFLX , . MSC_MHFTD ,MSC_MHFLD ,MSC_MSFLX ,MSC_MSFTD ,MSC_MSFLD , . MSC_VOLTR ,MSC_MASSGS ,MSC_VOLGS ,MSC_SALNGA ,MSC_TEMPGA , . MSC_SSSGA ,MSC_SSTGA , - . GLB_AVEPERIO,GLB_FILEFREQ,GLB_COMPFLAG,GLB_NCFORMAT, + . GLB_AVEPERIO,GLB_FILEFREQ,GLB_COMPFLAG,GLB_NCFORMAT, . GLB_FNAMETAG - contains + contains @@ -288,13 +300,13 @@ subroutine diafnm(ctag,diagfq,diagmon,diagann,fname) c c --- ------------------------------------------------------------------ c --- Description: creates file name for the diagnostic output -c --- -c --- Arguments: -c --- char ctag (in) : string used in middle of file name -c --- real diagfq (in) : diagnostic frequency -c --- logi diagmon (in) : switch to show whether diagfq=month -c --- logi diagann (in) : switch to show whether diagfq=year -c --- char fname (out) : file name +c --- +c --- Arguments: +c --- char ctag (in) : string used in middle of file name +c --- real diagfq (in) : diagnostic frequency +c --- logi diagmon (in) : switch to show whether diagfq=month +c --- logi diagann (in) : switch to show whether diagfq=year +c --- char fname (out) : file name c --- ------------------------------------------ c implicit none @@ -321,7 +333,7 @@ subroutine diafnm(ctag,diagfq,diagmon,diagann,fname) c date_tmp=date c - if (diagfq+epsil.gt.1.) then + if (diagfq+epsilp.gt.1.) then errstat=date_offset(calendar,date_tmp,-1) if (errstat.ne.calendar_noerr) then if (mnproc.eq.1) then @@ -380,7 +392,7 @@ subroutine diaini logical fexist c c --- Check existence of data files for meridional and section transport -c --- diagnostics +c --- diagnostics if (mnproc.eq.1) then if (sum(MSC_MMFLXL(1:nphy)+MSC_MMFLXD(1:nphy)+MSC_MMFTDL(1:nphy) . +MSC_MMFTDD(1:nphy)+MSC_MHFLX(1:nphy)+MSC_MHFTD(1:nphy) @@ -420,7 +432,7 @@ subroutine diaini do n=1,nphy nacc_phy(n)=0 c -c --- - Solve dependencies for diagnostic variables (0=skipped) +c --- - Solve dependencies for diagnostic variables (0=skipped) ACC_ABSWND(n) = H2D_ABSWND(n) ACC_ALB(n) = H2D_ALB(n) ACC_BRNFLX(n) = H2D_BRNFLX(n) @@ -428,8 +440,8 @@ subroutine diaini ACC_DFL(n) = H2D_DFL(n) ACC_EVA(n) = H2D_EVA(n) ACC_FMLTFZ(n) = H2D_FMLTFZ(n) - ACC_FICE(n) = H2D_FICE(n) + H2D_HICE(n) + H2D_UICE(n) + - . H2D_VICE(n) + H2D_HSNW(n) + ACC_FICE(n) = H2D_FICE(n) + H2D_HICE(n) + H2D_UICE(n) + . + H2D_VICE(n) + H2D_HSNW(n) ACC_HICE(n) = H2D_HICE(n) + H2D_UICE(n) + H2D_VICE(n) ACC_HMLTFZ(n) = H2D_HMLTFZ(n) ACC_HSNW(n) = H2D_HSNW(n) @@ -440,8 +452,6 @@ subroutine diaini ACC_LIP(n) = H2D_LIP(n) ACC_MAXMLD(n) = H2D_MAXMLD(n) ACC_MLD(n) = H2D_MLD(n) - ACC_MLDU(n) = H2D_MLDU(n) + H2D_MXLU(n) - ACC_MLDV(n) = H2D_MLDV(n) + H2D_MXLV(n) ACC_MLTS(n) = H2D_MLTS(n) ACC_MLTSMN(n) = H2D_MLTSMN(n) ACC_MLTSMX(n) = H2D_MLTSMX(n) @@ -453,8 +463,6 @@ subroutine diaini ACC_MTKEPE(n) = H2D_MTKEPE(n) ACC_MTKEKE(n) = H2D_MTKEKE(n) ACC_MTY(n) = H2D_MTY(n) - ACC_MXLU(n) = H2D_MXLU(n) - ACC_MXLV(n) = H2D_MXLV(n) ACC_NSF(n) = H2D_NSF(n) ACC_PBOT(n) = H2D_PBOT(n) ACC_PSRF(n) = H2D_PSRF(n) @@ -494,18 +502,25 @@ subroutine diaini ACC_BFSQLVL(n) = LVL_BFSQ(n) ACC_DIFDIA(n) = LYR_DIFDIA(n) ACC_DIFDIALVL(n)= LVL_DIFDIA(n) + ACC_DIFVMO(n) = LYR_DIFVMO(n) + ACC_DIFVMOLVL(n)= LVL_DIFVMO(n) + ACC_DIFVHO(n) = LYR_DIFVHO(n) + ACC_DIFVHOLVL(n)= LVL_DIFVHO(n) + ACC_DIFVSO(n) = LYR_DIFVSO(n) + ACC_DIFVSOLVL(n)= LVL_DIFVSO(n) ACC_DIFINT(n) = LYR_DIFINT(n) ACC_DIFINTLVL(n)= LVL_DIFINT(n) ACC_DIFISO(n) = LYR_DIFISO(n) ACC_DIFISOLVL(n)= LVL_DIFISO(n) - ACC_DP(n) = LYR_DP(n) + LYR_BFSQ(n) + - . LYR_SALN(n) + LYR_TEMP(n) + - . LYR_DIFDIA(n) + LYR_DIFINT(n) + LYR_DIFISO(n)+ - . LYR_TKE(n) + LYR_GLS_PSI(n)+ - . LVL_BFSQ(n) + LVL_SALN(n) + LVL_TEMP(n) + - . LVL_DIFDIA(n) + LVL_DIFINT(n) + LVL_DIFISO(n)+ - . LVL_TKE(n) + LVL_GLS_PSI(n)+ - . MSC_MASSGS(n) + MSC_SALNGA(n) + MSC_TEMPGA(n) + ACC_DP(n) = LYR_DP(n) + LYR_BFSQ(n) + LYR_SALN(n) + . + LYR_TEMP(n) + LYR_DIFDIA(n) + LYR_DIFVMO(n) + . + LYR_DIFVHO(n) + LYR_DIFVSO(n) + LYR_DIFINT(n) + . + LYR_DIFISO(n) + LYR_TKE(n) + LYR_GLS_PSI(n) + . + LVL_BFSQ(n) + LVL_SALN(n) + LVL_TEMP(n) + . + LVL_DIFDIA(n) + LVL_DIFVMO(n) + LVL_DIFVHO(n) + . + LVL_DIFVSO(n) + LVL_DIFINT(n) + LVL_DIFISO(n) + . + LVL_TKE(n) + LVL_GLS_PSI(n) + . + MSC_MASSGS(n) + MSC_SALNGA(n) + MSC_TEMPGA(n) ACC_DPU(n) = LYR_DPU(n) + LYR_UVEL(n) ACC_DPV(n) = LYR_DPV(n) + LYR_VVEL(n) ACC_DZ(n) = LYR_DZ(n) + MSC_VOLGS(n) @@ -514,10 +529,10 @@ subroutine diaini ACC_SALNLVL(n) = LVL_SALN(n) ACC_TEMP(n) = LYR_TEMP(n) + MSC_TEMPGA(n) ACC_TEMPLVL(n) = LVL_TEMP(n) - ACC_UFLX(n) = LYR_UFLX(n) + MSC_MMFLXL(n) + LYR_WFLX(n) + - . LYR_WFLX2(n) - ACC_UFLXLVL(n) = LVL_UFLX(n) + MSC_MMFLXD(n) + MSC_VOLTR(n) + - . LVL_WFLX(n) + LVL_WFLX2(n) + ACC_UFLX(n) = LYR_UFLX(n) + MSC_MMFLXL(n) + LYR_WFLX(n) + . + LYR_WFLX2(n) + ACC_UFLXLVL(n) = LVL_UFLX(n) + MSC_MMFLXD(n) + MSC_VOLTR(n) + . + LVL_WFLX(n) + LVL_WFLX2(n) ACC_UFLXOLD(n) = LVL_WFLX(n) + LVL_WFLX2(n) ACC_UTFLX(n) = LYR_UTFLX(n) + MSC_MHFLX(n) ACC_UTFLXLVL(n) = LVL_UTFLX(n) @@ -535,10 +550,10 @@ subroutine diaini ACC_USFLLDLVL(n)= LVL_USFLLD(n) ACC_UVEL(n) = LYR_UVEL(n) ACC_UVELLVL(n) = LVL_UVEL(n) - ACC_VFLX(n) = LYR_VFLX(n) + MSC_MMFLXL(n) + LYR_WFLX(n) + - . LYR_WFLX2(n) - ACC_VFLXLVL(n) = LVL_VFLX(n) + MSC_MMFLXD(n) + MSC_VOLTR(n) + - . LVL_WFLX(n) + LVL_WFLX2(n) + ACC_VFLX(n) = LYR_VFLX(n) + MSC_MMFLXL(n) + LYR_WFLX(n) + . + LYR_WFLX2(n) + ACC_VFLXLVL(n) = LVL_VFLX(n) + MSC_MMFLXD(n) + MSC_VOLTR(n) + . + LVL_WFLX(n) + LVL_WFLX2(n) ACC_VFLXOLD(n) = LVL_WFLX(n) + LVL_WFLX2(n) ACC_VTFLX(n) = LYR_VTFLX(n) + MSC_MHFLX(n) ACC_VTFLXLVL(n) = LVL_VTFLX(n) @@ -556,14 +571,14 @@ subroutine diaini ACC_VSFLLDLVL(n)= LVL_VSFLLD(n) ACC_VVEL(n) = LYR_VVEL(n) ACC_VVELLVL(n) = LVL_VVEL(n) - ACC_WFLX(n) = LYR_WFLX(n) + LYR_WFLX2(n) + LVL_WFLX(n) + - . LVL_WFLX2(n) - ACC_WFLXLVL(n) = LVL_WFLX(n) + LVL_WFLX2(n) + LYR_WFLX(n) + - . LYR_WFLX2(n) - ACC_WFLX2(n) = LYR_WFLX2(n) + LYR_WFLX(n) + LVL_WFLX(n) + - . LVL_WFLX2(n) - ACC_WFLX2LVL(n) = LVL_WFLX2(n) + LVL_WFLX(n) + LYR_WFLX(n) + - . LYR_WFLX2(n) + ACC_WFLX(n) = LYR_WFLX(n) + LYR_WFLX2(n) + LVL_WFLX(n) + . + LVL_WFLX2(n) + ACC_WFLXLVL(n) = LVL_WFLX(n) + LVL_WFLX2(n) + LYR_WFLX(n) + . + LYR_WFLX2(n) + ACC_WFLX2(n) = LYR_WFLX2(n) + LYR_WFLX(n) + LVL_WFLX(n) + . + LVL_WFLX2(n) + ACC_WFLX2LVL(n) = LVL_WFLX2(n) + LVL_WFLX(n) + LYR_WFLX(n) + . + LYR_WFLX2(n) ACC_AVDSG(n) = LYR_PV(n) ACC_DPVOR(n) = LYR_PV(n) ACC_PVLVL(n) = LVL_PV(n) @@ -571,10 +586,10 @@ subroutine diaini ACC_TKELVL(n) = LVL_TKE(n) ACC_GLS_PSI(n) = LYR_GLS_PSI(n) ACC_GLS_PSILVL(n) = LVL_GLS_PSI(n) - ACC_MMFLXL(n) = MSC_MMFLXL(n) + ACC_MMFLXL(n) = MSC_MMFLXL(n) ACC_MMFLXD(n) = MSC_MMFLXD(n) - ACC_MMFTDL(n) = MSC_MMFTDL(n) - ACC_MMFTDD(n) = MSC_MMFTDD(n) + ACC_MMFTDL(n) = MSC_MMFTDL(n) + ACC_MMFTDD(n) = MSC_MMFTDD(n) ACC_MHFLX(n) = MSC_MHFLX(n) ACC_MHFTD(n) = MSC_MHFTD(n) ACC_MHFLD(n) = MSC_MHFLD(n) @@ -583,47 +598,43 @@ subroutine diaini ACC_MSFLD(n) = MSC_MSFLD(n) ACC_VOLTR(n) = MSC_VOLTR(n) c -c --- - Determine position in buffer - if (ACC_ABSWND(n).ne.0) nphyh2d=nphyh2d+1 +c --- - Determine position in buffer + if (ACC_ABSWND(n).ne.0) nphyh2d=nphyh2d+1 ACC_ABSWND(n)=nphyh2d*min(1,ACC_ABSWND(n)) if (ACC_ALB(n).ne.0) nphyh2d=nphyh2d+1 - ACC_ALB(n)=nphyh2d*min(1,ACC_ALB(n)) - if (ACC_BRNFLX(n).ne.0) nphyh2d=nphyh2d+1 + ACC_ALB(n)=nphyh2d*min(1,ACC_ALB(n)) + if (ACC_BRNFLX(n).ne.0) nphyh2d=nphyh2d+1 ACC_BRNFLX(n)=nphyh2d*min(1,ACC_BRNFLX(n)) if (ACC_BRNPD(n).ne.0) nphyh2d=nphyh2d+1 ACC_BRNPD(n)=nphyh2d*min(1,ACC_BRNPD(n)) if (ACC_DFL(n).ne.0) nphyh2d=nphyh2d+1 - ACC_DFL(n)=nphyh2d*min(1,ACC_DFL(n)) + ACC_DFL(n)=nphyh2d*min(1,ACC_DFL(n)) if (ACC_EVA(n).ne.0) nphyh2d=nphyh2d+1 - ACC_EVA(n)=nphyh2d*min(1,ACC_EVA(n)) - if (ACC_FMLTFZ(n).ne.0) nphyh2d=nphyh2d+1 + ACC_EVA(n)=nphyh2d*min(1,ACC_EVA(n)) + if (ACC_FMLTFZ(n).ne.0) nphyh2d=nphyh2d+1 ACC_FMLTFZ(n)=nphyh2d*min(1,ACC_FMLTFZ(n)) if (ACC_FICE(n).ne.0) nphyh2d=nphyh2d+1 - ACC_FICE(n)=nphyh2d*min(1,ACC_FICE(n)) + ACC_FICE(n)=nphyh2d*min(1,ACC_FICE(n)) if (ACC_HICE(n).ne.0) nphyh2d=nphyh2d+1 - ACC_HICE(n)=nphyh2d*min(1,ACC_HICE(n)) - if (ACC_HMLTFZ(n).ne.0) nphyh2d=nphyh2d+1 + ACC_HICE(n)=nphyh2d*min(1,ACC_HICE(n)) + if (ACC_HMLTFZ(n).ne.0) nphyh2d=nphyh2d+1 ACC_HMLTFZ(n)=nphyh2d*min(1,ACC_HMLTFZ(n)) if (ACC_HSNW(n).ne.0) nphyh2d=nphyh2d+1 - ACC_HSNW(n)=nphyh2d*min(1,ACC_HSNW(n)) + ACC_HSNW(n)=nphyh2d*min(1,ACC_HSNW(n)) if (ACC_IAGE(n).ne.0) nphyh2d=nphyh2d+1 - ACC_IAGE(n)=nphyh2d*min(1,ACC_IAGE(n)) - if (ACC_IDKEDT(n).ne.0) nphyh2d=nphyh2d+1 + ACC_IAGE(n)=nphyh2d*min(1,ACC_IAGE(n)) + if (ACC_IDKEDT(n).ne.0) nphyh2d=nphyh2d+1 ACC_IDKEDT(n)=nphyh2d*min(1,ACC_IDKEDT(n)) - if (ACC_IVOLU(n).ne.0) nphyh2d=nphyh2d+1 + if (ACC_IVOLU(n).ne.0) nphyh2d=nphyh2d+1 ACC_IVOLU(n)=nphyh2d*min(1,ACC_IVOLU(n)) - if (ACC_IVOLV(n).ne.0) nphyh2d=nphyh2d+1 + if (ACC_IVOLV(n).ne.0) nphyh2d=nphyh2d+1 ACC_IVOLV(n)=nphyh2d*min(1,ACC_IVOLV(n)) if (ACC_LIP(n).ne.0) nphyh2d=nphyh2d+1 - ACC_LIP(n)=nphyh2d*min(1,ACC_LIP(n)) - if (ACC_MAXMLD(n).ne.0) nphyh2d=nphyh2d+1 + ACC_LIP(n)=nphyh2d*min(1,ACC_LIP(n)) + if (ACC_MAXMLD(n).ne.0) nphyh2d=nphyh2d+1 ACC_MAXMLD(n)=nphyh2d*min(1,ACC_MAXMLD(n)) if (ACC_MLD(n).ne.0) nphyh2d=nphyh2d+1 - ACC_MLD(n)=nphyh2d*min(1,ACC_MLD(n)) - if (ACC_MLDU(n).ne.0) nphyh2d=nphyh2d+1 - ACC_MLDU(n)=nphyh2d*min(1,ACC_MLDU(n)) - if (ACC_MLDV(n).ne.0) nphyh2d=nphyh2d+1 - ACC_MLDV(n)=nphyh2d*min(1,ACC_MLDV(n)) + ACC_MLD(n)=nphyh2d*min(1,ACC_MLD(n)) if (ACC_MLTS(n).ne.0) nphyh2d=nphyh2d+1 ACC_MLTS(n)=nphyh2d*min(1,ACC_MLTS(n)) if (ACC_MLTSMN(n).ne.0) nphyh2d=nphyh2d+1 @@ -633,89 +644,85 @@ subroutine diaini if (ACC_MLTSSQ(n).ne.0) nphyh2d=nphyh2d+1 ACC_MLTSSQ(n)=nphyh2d*min(1,ACC_MLTSSQ(n)) if (ACC_MTKEUS(n).ne.0) nphyh2d=nphyh2d+1 - ACC_MTKEUS(n)=nphyh2d*min(1,ACC_MTKEUS(n)) + ACC_MTKEUS(n)=nphyh2d*min(1,ACC_MTKEUS(n)) if (ACC_MTKENI(n).ne.0) nphyh2d=nphyh2d+1 - ACC_MTKENI(n)=nphyh2d*min(1,ACC_MTKENI(n)) + ACC_MTKENI(n)=nphyh2d*min(1,ACC_MTKENI(n)) if (ACC_MTKEBF(n).ne.0) nphyh2d=nphyh2d+1 - ACC_MTKEBF(n)=nphyh2d*min(1,ACC_MTKEBF(n)) + ACC_MTKEBF(n)=nphyh2d*min(1,ACC_MTKEBF(n)) if (ACC_MTKERS(n).ne.0) nphyh2d=nphyh2d+1 - ACC_MTKERS(n)=nphyh2d*min(1,ACC_MTKERS(n)) + ACC_MTKERS(n)=nphyh2d*min(1,ACC_MTKERS(n)) if (ACC_MTKEPE(n).ne.0) nphyh2d=nphyh2d+1 - ACC_MTKEPE(n)=nphyh2d*min(1,ACC_MTKEPE(n)) + ACC_MTKEPE(n)=nphyh2d*min(1,ACC_MTKEPE(n)) if (ACC_MTKEKE(n).ne.0) nphyh2d=nphyh2d+1 - ACC_MTKEKE(n)=nphyh2d*min(1,ACC_MTKEKE(n)) + ACC_MTKEKE(n)=nphyh2d*min(1,ACC_MTKEKE(n)) if (ACC_MTY(n).ne.0) nphyh2d=nphyh2d+1 - ACC_MTY(n)=nphyh2d*min(1,ACC_MTY(n)) - if (ACC_MXLU(n).ne.0) nphyh2d=nphyh2d+1 - ACC_MXLU(n)=nphyh2d*min(1,ACC_MXLU(n)) - if (ACC_MXLV(n).ne.0) nphyh2d=nphyh2d+1 - ACC_MXLV(n)=nphyh2d*min(1,ACC_MXLV(n)) + ACC_MTY(n)=nphyh2d*min(1,ACC_MTY(n)) if (ACC_NSF(n).ne.0) nphyh2d=nphyh2d+1 - ACC_NSF(n)=nphyh2d*min(1,ACC_NSF(n)) + ACC_NSF(n)=nphyh2d*min(1,ACC_NSF(n)) if (ACC_PBOT(n).ne.0) nphyh2d=nphyh2d+1 - ACC_PBOT(n)=nphyh2d*min(1,ACC_PBOT(n)) + ACC_PBOT(n)=nphyh2d*min(1,ACC_PBOT(n)) if (ACC_PSRF(n).ne.0) nphyh2d=nphyh2d+1 - ACC_PSRF(n)=nphyh2d*min(1,ACC_PSRF(n)) - if (ACC_RFIFLX(n).ne.0) nphyh2d=nphyh2d+1 + ACC_PSRF(n)=nphyh2d*min(1,ACC_PSRF(n)) + if (ACC_RFIFLX(n).ne.0) nphyh2d=nphyh2d+1 ACC_RFIFLX(n)=nphyh2d*min(1,ACC_RFIFLX(n)) - if (ACC_RNFFLX(n).ne.0) nphyh2d=nphyh2d+1 + if (ACC_RNFFLX(n).ne.0) nphyh2d=nphyh2d+1 ACC_RNFFLX(n)=nphyh2d*min(1,ACC_RNFFLX(n)) - if (ACC_SURFLX(n).ne.0) nphyh2d=nphyh2d+1 + if (ACC_SURFLX(n).ne.0) nphyh2d=nphyh2d+1 ACC_SURFLX(n)=nphyh2d*min(1,ACC_SURFLX(n)) - if (ACC_SURRLX(n).ne.0) nphyh2d=nphyh2d+1 + if (ACC_SURRLX(n).ne.0) nphyh2d=nphyh2d+1 ACC_SURRLX(n)=nphyh2d*min(1,ACC_SURRLX(n)) - if (ACC_SALFLX(n).ne.0) nphyh2d=nphyh2d+1 + if (ACC_SALFLX(n).ne.0) nphyh2d=nphyh2d+1 ACC_SALFLX(n)=nphyh2d*min(1,ACC_SALFLX(n)) - if (ACC_SALRLX(n).ne.0) nphyh2d=nphyh2d+1 + if (ACC_SALRLX(n).ne.0) nphyh2d=nphyh2d+1 ACC_SALRLX(n)=nphyh2d*min(1,ACC_SALRLX(n)) - if (ACC_SBOT(n).ne.0) nphyh2d=nphyh2d+1 + if (ACC_SBOT(n).ne.0) nphyh2d=nphyh2d+1 ACC_SBOT(n)=nphyh2d*min(1,ACC_SBOT(n)) - if (ACC_SEALV(n).ne.0) nphyh2d=nphyh2d+1 + if (ACC_SEALV(n).ne.0) nphyh2d=nphyh2d+1 ACC_SEALV(n)=nphyh2d*min(1,ACC_SEALV(n)) - if (ACC_SLVSQ(n).ne.0) nphyh2d=nphyh2d+1 + if (ACC_SLVSQ(n).ne.0) nphyh2d=nphyh2d+1 ACC_SLVSQ(n)=nphyh2d*min(1,ACC_SLVSQ(n)) if (ACC_SFL(n).ne.0) nphyh2d=nphyh2d+1 - ACC_SFL(n)=nphyh2d*min(1,ACC_SFL(n)) - if (ACC_SIGMX(n).ne.0) nphyh2d=nphyh2d+1 + ACC_SFL(n)=nphyh2d*min(1,ACC_SFL(n)) + if (ACC_SIGMX(n).ne.0) nphyh2d=nphyh2d+1 ACC_SIGMX(n)=nphyh2d*min(1,ACC_SIGMX(n)) if (ACC_SOP(n).ne.0) nphyh2d=nphyh2d+1 - ACC_SOP(n)=nphyh2d*min(1,ACC_SOP(n)) + ACC_SOP(n)=nphyh2d*min(1,ACC_SOP(n)) if (ACC_SSS(n).ne.0) nphyh2d=nphyh2d+1 - ACC_SSS(n)=nphyh2d*min(1,ACC_SSS(n)) + ACC_SSS(n)=nphyh2d*min(1,ACC_SSS(n)) if (ACC_SSSSQ(n).ne.0) nphyh2d=nphyh2d+1 - ACC_SSSSQ(n)=nphyh2d*min(1,ACC_SSSSQ(n)) + ACC_SSSSQ(n)=nphyh2d*min(1,ACC_SSSSQ(n)) if (ACC_SST(n).ne.0) nphyh2d=nphyh2d+1 - ACC_SST(n)=nphyh2d*min(1,ACC_SST(n)) + ACC_SST(n)=nphyh2d*min(1,ACC_SST(n)) if (ACC_SSTSQ(n).ne.0) nphyh2d=nphyh2d+1 - ACC_SSTSQ(n)=nphyh2d*min(1,ACC_SSTSQ(n)) + ACC_SSTSQ(n)=nphyh2d*min(1,ACC_SSTSQ(n)) if (ACC_SWA(n).ne.0) nphyh2d=nphyh2d+1 - ACC_SWA(n)=nphyh2d*min(1,ACC_SWA(n)) + ACC_SWA(n)=nphyh2d*min(1,ACC_SWA(n)) if (ACC_T20D(n).ne.0) nphyh2d=nphyh2d+1 - ACC_T20D(n)=nphyh2d*min(1,ACC_T20D(n)) + ACC_T20D(n)=nphyh2d*min(1,ACC_T20D(n)) if (ACC_TAUX(n).ne.0) nphyh2d=nphyh2d+1 - ACC_TAUX(n)=nphyh2d*min(1,ACC_TAUX(n)) + ACC_TAUX(n)=nphyh2d*min(1,ACC_TAUX(n)) if (ACC_TAUY(n).ne.0) nphyh2d=nphyh2d+1 - ACC_TAUY(n)=nphyh2d*min(1,ACC_TAUY(n)) - if (ACC_TBOT(n).ne.0) nphyh2d=nphyh2d+1 + ACC_TAUY(n)=nphyh2d*min(1,ACC_TAUY(n)) + if (ACC_TBOT(n).ne.0) nphyh2d=nphyh2d+1 ACC_TBOT(n)=nphyh2d*min(1,ACC_TBOT(n)) if (ACC_TICE(n).ne.0) nphyh2d=nphyh2d+1 - ACC_TICE(n)=nphyh2d*min(1,ACC_TICE(n)) + ACC_TICE(n)=nphyh2d*min(1,ACC_TICE(n)) if (ACC_TSRF(n).ne.0) nphyh2d=nphyh2d+1 ACC_TSRF(n)=nphyh2d*min(1,ACC_TSRF(n)) if (ACC_UB(n).ne.0) nphyh2d=nphyh2d+1 - ACC_UB(n)=nphyh2d*min(1,ACC_UB(n)) + ACC_UB(n)=nphyh2d*min(1,ACC_UB(n)) if (ACC_UBFLXS(n).ne.0) nphyh2d=nphyh2d+1 - ACC_UBFLXS(n)=nphyh2d*min(1,ACC_UBFLXS(n)) + ACC_UBFLXS(n)=nphyh2d*min(1,ACC_UBFLXS(n)) if (ACC_UICE(n).ne.0) nphyh2d=nphyh2d+1 - ACC_UICE(n)=nphyh2d*min(1,ACC_UICE(n)) - if (ACC_USTAR(n).ne.0) nphyh2d=nphyh2d+1 + ACC_UICE(n)=nphyh2d*min(1,ACC_UICE(n)) + if (ACC_USTAR(n).ne.0) nphyh2d=nphyh2d+1 ACC_USTAR(n)=nphyh2d*min(1,ACC_USTAR(n)) - if (ACC_USTAR3(n).ne.0) nphyh2d=nphyh2d+1 + if (ACC_USTAR3(n).ne.0) nphyh2d=nphyh2d+1 ACC_USTAR3(n)=nphyh2d*min(1,ACC_USTAR3(n)) if (ACC_VB(n).ne.0) nphyh2d=nphyh2d+1 - ACC_VB(n)=nphyh2d*min(1,ACC_VB(n)) + ACC_VB(n)=nphyh2d*min(1,ACC_VB(n)) if (ACC_VBFLXS(n).ne.0) nphyh2d=nphyh2d+1 - ACC_VBFLXS(n)=nphyh2d*min(1,ACC_VBFLXS(n)) + ACC_VBFLXS(n)=nphyh2d*min(1,ACC_VBFLXS(n)) if (ACC_VICE(n).ne.0) nphyh2d=nphyh2d+1 ACC_VICE(n)=nphyh2d*min(1,ACC_VICE(n)) if (ACC_ZTX(n).ne.0) nphyh2d=nphyh2d+1 @@ -725,6 +732,12 @@ subroutine diaini ACC_BFSQ(n)=nphylyr*min(1,ACC_BFSQ(n)) if (ACC_DIFDIA(n).ne.0) nphylyr=nphylyr+1 ACC_DIFDIA(n)=nphylyr*min(1,ACC_DIFDIA(n)) + if (ACC_DIFVMO(n).ne.0) nphylyr=nphylyr+1 + ACC_DIFVMO(n)=nphylyr*min(1,ACC_DIFVMO(n)) + if (ACC_DIFVHO(n).ne.0) nphylyr=nphylyr+1 + ACC_DIFVHO(n)=nphylyr*min(1,ACC_DIFVHO(n)) + if (ACC_DIFVSO(n).ne.0) nphylyr=nphylyr+1 + ACC_DIFVSO(n)=nphylyr*min(1,ACC_DIFVSO(n)) if (ACC_DIFINT(n).ne.0) nphylyr=nphylyr+1 ACC_DIFINT(n)=nphylyr*min(1,ACC_DIFINT(n)) if (ACC_DIFISO(n).ne.0) nphylyr=nphylyr+1 @@ -794,6 +807,12 @@ subroutine diaini ACC_BFSQLVL(n)=nphylvl*min(1,ACC_BFSQLVL(n)) if (ACC_DIFDIALVL(n).ne.0) nphylvl=nphylvl+1 ACC_DIFDIALVL(n)=nphylvl*min(1,ACC_DIFDIALVL(n)) + if (ACC_DIFVMOLVL(n).ne.0) nphylvl=nphylvl+1 + ACC_DIFVMOLVL(n)=nphylvl*min(1,ACC_DIFVMOLVL(n)) + if (ACC_DIFVHOLVL(n).ne.0) nphylvl=nphylvl+1 + ACC_DIFVHOLVL(n)=nphylvl*min(1,ACC_DIFVHOLVL(n)) + if (ACC_DIFVSOLVL(n).ne.0) nphylvl=nphylvl+1 + ACC_DIFVSOLVL(n)=nphylvl*min(1,ACC_DIFVSOLVL(n)) if (ACC_DIFINTLVL(n).ne.0) nphylvl=nphylvl+1 ACC_DIFINTLVL(n)=nphylvl*min(1,ACC_DIFINTLVL(n)) if (ACC_DIFISOLVL(n).ne.0) nphylvl=nphylvl+1 @@ -857,20 +876,20 @@ subroutine diaini c c --- End loop over io groups enddo -c +c c --- Assign buffer positions for utility fields - ACC_UTILH2D=0 + ACC_UTILH2D=0 nphyh2d=nphyh2d+1 - ACC_UTILH2D(1)=nphyh2d + ACC_UTILH2D(1)=nphyh2d c - ACC_UTILLYR=0 + ACC_UTILLYR=0 nphylyr=nphylyr+1 - ACC_UTILLYR(1)=nphylyr + ACC_UTILLYR(1)=nphylyr c - ACC_UTILLVL=0 + ACC_UTILLVL=0 nphylvl=nphylvl+1 - ACC_UTILLVL(1)=nphylvl -c + ACC_UTILLVL(1)=nphylvl +c c --- Allocate buffers istatsum=0 istat=0 @@ -894,10 +913,10 @@ subroutine diaini call inifld(n) enddo c -c --- Load bathymetry into module mod_dia (used for vertical +c --- Load bathymetry into module mod_dia (used for vertical c --- interpolation in BLOM and HAMOCC) nstepinday=nstep_in_day -c$OMP PARALLEL DO PRIVATE(l,i) +c$OMP PARALLEL DO PRIVATE(l,i) do j=1,jj+1 do l=1,isp(j) do i=max(1,ifp(j,l)),min(ii,ilp(j,l)) @@ -947,7 +966,7 @@ subroutine diasg1 do i=1,itdm if (tmp2d(i,j).gt.0.) then i1=i - j1=j + j1=j lsigmar1=.true. exit endif @@ -959,10 +978,10 @@ subroutine diasg1 call xcbcst(j1) do k=1,kk call xceget(sigmar1(k),sigmar(1-nbdy,1-nbdy,k),i1,j1) - sigmar1(k)=sigmar1(k)*1.e3 ! Convert units from g cm-3 to kg m-3 + sigmar1(k)=sigmar1(k)*M_mks2cgs ! Convert units from g cm-3 to kg m-3 enddo if (mnproc.eq.1) then - write(lp,*) 'sigma layers=',sigmar1 + write(lp,*) 'sigma layers=',sigmar1 endif c end subroutine diasg1 @@ -984,22 +1003,21 @@ subroutine diaacc(m,n,mm,nn,k1m,k1n) integer i,j,k,l,km,kup,iogrp integer, dimension(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy) :: ind1,ind2, . ipsw,ipse,ipnw,ipne -c +c real, dimension(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy,ddm) :: wghts, . wghtsflx - real, dimension(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy,kdm+1) :: z real, dimension(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy,kdm) :: uvel,vvel, - . dz,avdsg_p,dpvor_p,pv_p,dummy - real, dimension(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy) :: - . dpml,sbot,tbot,dps,mlts,t20d - real dsig,q,zup,zlo,plo,dbup,dblo,tup,tlo + . avdsg_p,dpvor_p,pv_p,dummy + real, dimension(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy) :: + . dpml,sbot,tbot,dps,t20d + real dsig,q,zup,zlo,tup,tlo c -c --- Increase counter +c --- Increase counter do iogrp=1,nphy nacc_phy(iogrp)=nacc_phy(iogrp)+1 enddo c -c --- Define auxillary variables +c --- Define auxillary variables c if (sum(ACC_UICE(1:nphy)+ACC_VICE(1:nphy)).ne.0) then call xctilr(hicem, 1,1, 1,1, halo_ps) @@ -1022,33 +1040,33 @@ subroutine diaacc(m,n,mm,nn,k1m,k1n) c$OMP END PARALLEL DO endif c - if (sum(ACC_MXLU(1:nphy)+ACC_MXLV(1:nphy)).ne.0) then + if (sum(ACC_MLD(1:nphy)).ne.0) then + select case (vcoord_type_tag) + case (isopyc_bulkml) c$OMP PARALLEL DO PRIVATE(l,i) - do j=1,jj - do l=1,isu(j) - do i=max(1,ifu(j,l)),min(ii,ilu(j,l)) - util2(i,j)=(u(i,j,k1m)+ub(i,j,m))*dpu(i,j,k1m) - enddo - enddo - do l=1,isv(j) - do i=max(1,ifv(j,l)),min(ii,ilv(j,l)) - util4(i,j)=(v(i,j,k1m)+vb(i,j,m))*dpv(i,j,k1m) + do j=1,jj + do l=1,isp(j) + do i=max(1,ifp(j,l)),min(ii,ilp(j,l)) + dpml(i,j)=dp(i,j,1+mm)+dp(i,j,2+mm) + enddo + enddo enddo - enddo - enddo c$OMP END PARALLEL DO - endif -c - if (sum(ACC_MLD(1:nphy)).ne.0) then + case (cntiso_hybrid) c$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)) - dpml(i,j)=dp(i,j,1+mm)+dp(i,j,2+mm) + do j=1,jj + do l=1,isp(j) + do i=max(1,ifp(j,l)),min(ii,ilp(j,l)) + dpml(i,j)=OBLdepth(i,j)*onem + enddo + enddo enddo - enddo - enddo c$OMP END PARALLEL DO + case default + write (lp,*) 'diaacc: unsupported vertical coordinate!' + call xcstop('(diaacc)') + stop '(diaacc)' + end select endif c if (sum(ACC_UVEL(1:nphy)+ACC_UVELLVL(1:nphy)).ne.0) then @@ -1080,36 +1098,6 @@ subroutine diaacc(m,n,mm,nn,k1m,k1n) enddo c$OMP END PARALLEL DO endif -c - if (sum(ACC_DZ(1:nphy)+ACC_DZLVL(1:nphy)).ne.0) then -c$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)) - z(i,j,kk+1)=-phi(i,j,kk+1)/g - enddo - enddo - enddo -c$OMP END PARALLEL DO -c$OMP PARALLEL DO PRIVATE(k,km,l,i) - do j=1,jj - do k=kk,1,-1 - km=k+mm - do l=1,isp(j) - do i=max(1,ifp(j,l)),min(ii,ilp(j,l)) - if (dp(i,j,km).lt.epsil) then - z(i,j,k)=z(i,j,k+1) - else - z(i,j,k)=z(i,j,k+1)+p_alpha(p(i,j,k+1),p(i,j,k), - . temp(i,j,km),saln(i,j,km))/g - endif - dz(i,j,k)=z(i,j,k+1)-z(i,j,k) - enddo - enddo - enddo - enddo -c$OMP END PARALLEL DO - endif c if (sum(ACC_AVDSG(1:nphy)+ACC_PVLVL(1:nphy)).ne.0) then c$OMP PARALLEL DO PRIVATE(l,i,k,km,dsig) @@ -1195,45 +1183,6 @@ subroutine diaacc(m,n,mm,nn,k1m,k1n) enddo c$OMP END PARALLEL DO endif -c - if (sum(ACC_MLTS(1:nphy)+ACC_MLTSMN(1:nphy) - . +ACC_MLTSMX(1:nphy)+ACC_MLTSSQ(1:nphy)).ne.0) then -c$OMP PARALLEL DO PRIVATE(l,i,k,km,zup,dbup,plo,zlo,dblo) - do j=1,jj - do l=1,isp(j) - do i=max(1,ifp(j,l)),min(ii,ilp(j,l)) - k=2 - km=k+mm - zup=z(i,j,1)+.5*dz(i,j,1) ! .5*(z(i,j,1)+z(i,j,2)) - dbup=0. - do - if (dp(i,j,km).gt.onecm) then - plo=p(i,j,k)+.5*dp(i,j,km) ! .5*(p(i,j,k)+p(i,j,k+1)) - zlo=z(i,j,k)+.5*dz(i,j,k ) ! .5*(z(i,j,k)+z(i,j,k+1)) - dblo=g*(1.-rho(plo,temp(i,j,k1m),saln(i,j,k1m)) - . /rho(plo,temp(i,j,km ),saln(i,j,km ))) - if (dblo.le.dbcrit) then - zup=zlo - dbup=dblo - else - dbup=min(dbup,dbcrit-epsil) - mlts(i,j)=(zup*(dblo-dbcrit) - . +zlo*(dbcrit-dbup))/(dblo-dbup)-z(i,j,1) - exit - endif - endif - k=k+1 - if (k.gt.kk) then - mlts(i,j)=z(i,j,kk+1)-z(i,j,1) - exit - endif - km=k+mm - enddo - enddo - enddo - enddo -c$OMP END PARALLEL DO - endif c if (sum(ACC_T20D(1:nphy)).ne.0) then c$OMP PARALLEL DO PRIVATE(l,i,k,km,kup,zup,zlo,tup,tlo) @@ -1242,7 +1191,7 @@ subroutine diaacc(m,n,mm,nn,k1m,k1n) do i=max(1,ifp(j,l)),min(ii,ilp(j,l)) k=1 km=k+mm - do + do if (dp(i,j,km).gt.onecm) then if (temp(i,j,km).gt.20.) then kup=k @@ -1262,7 +1211,7 @@ subroutine diaacc(m,n,mm,nn,k1m,k1n) zup=z(i,j,kup)+.5*dz(i,j,kup) zlo=z(i,j,k )+.5*dz(i,j,k ) tup=temp(i,j,kup+mm) - tlo=min(temp(i,j,km),tup-epsil) + tlo=min(temp(i,j,km),tup-epsilp) t20d(i,j)=(zup*(tlo-20.)+zlo*(20.-tup))/(tlo-tup) endif enddo @@ -1290,12 +1239,6 @@ subroutine diaacc(m,n,mm,nn,k1m,k1n) c --- weighted u-component of ice velocity [m^2/s] call acch2d(ACC_UICE,uicem,util1,1,'u') c -c --- weighted u-component of total velocity [g/s^3] - call acch2d(ACC_MXLU,util2,dummy,0,'u') -c -c --- mixed layer pressure thickness at u-point [g/cm/s^2] - call acch2d(ACC_MLDU,dpu(1-nbdy,1-nbdy,k1m),dummy,0,'u') -c c --- v-component of barotropic velocity [cm/s] call acch2d(ACC_VB,vb(1-nbdy,1-nbdy,m),dummy,0,'v') c @@ -1311,12 +1254,6 @@ subroutine diaacc(m,n,mm,nn,k1m,k1n) c --- weighted v-component of ice velocity [m^2/s] call acch2d(ACC_VICE,vicem,util3,1,'v') c -c --- weighted v-component of total velocity [g/s^3] - call acch2d(ACC_MXLV,util4,dummy,0,'v') -c -c --- mixed layer pressure thickness at v-point [g/cm/s^2] - call acch2d(ACC_MLDV,dpv(1-nbdy,1-nbdy,k1m),dummy,0,'v') -c c --- surface pressure [g/cm/s^2] call acch2d(ACC_PSRF,p(1-nbdy,1-nbdy,1),dummy,0,'p') c @@ -1337,11 +1274,11 @@ subroutine diaacc(m,n,mm,nn,k1m,k1n) c c --- fractional ice cover call acch2d(ACC_FICE,ficem,dummy,0,'p') -c -c --- ice volume in u-points[m] +c +c --- ice volume in u-points[m] call acch2d(ACC_IVOLU,util1,dummy,0,'u') -c -c --- ice volume in v-points[m] +c +c --- ice volume in v-points[m] call acch2d(ACC_IVOLV,util3,dummy,0,'v') c c --- surface temperature [K] @@ -1571,9 +1508,18 @@ subroutine diaacc(m,n,mm,nn,k1m,k1n) c --- isopycnal diffusivity [cm^2/s] call acclyr(ACC_DIFISO,difiso,dp(1-nbdy,1-nbdy,k1m),1,'p') c -c --- diapycnal diffusivity [cm^2/s] +c --- vertical diffusivity (vcoord_type_tag == isopyc_bulkml) [cm^2/s] call acclyr(ACC_DIFDIA,difdia,dp(1-nbdy,1-nbdy,k1m),1,'p') c +c --- vertical momentum diffusivity (vcoord_type_tag == cntiso_hybrid) [cm^2/s] + call accily(ACC_DIFVMO,Kvisc_m,dp(1-nbdy,1-nbdy,k1m),1,'p') +c +c --- vertical heat diffusivity (vcoord_type_tag == cntiso_hybrid) [cm^2/s] + call accily(ACC_DIFVHO,Kdiff_t,dp(1-nbdy,1-nbdy,k1m),1,'p') +c +c --- vertical salt diffusivity (vcoord_type_tag == cntiso_hybrid) [cm^2/s] + call accily(ACC_DIFVSO,Kdiff_s,dp(1-nbdy,1-nbdy,k1m),1,'p') +c c --- absolute vorticity multiplied with potential density difference c --- over layer [g/cm^3/s] call acclyr(ACC_AVDSG,avdsg_p,dummy,0,'p') @@ -1592,28 +1538,28 @@ subroutine diaacc(m,n,mm,nn,k1m,k1n) c #endif c --- ------------------------------------------------------------------ -c --- accumulate 3d diagnostic variables on Levitus levels +c --- accumulate 3d diagnostic variables on Levitus levels c --- ------------------------------------------------------------------ c - do iogrp=1,nphy + do iogrp=1,nphy if (ACC_WFLXLVL(iogrp)+ACC_WFLX2LVL(iogrp).ne.0) then c$OMP PARALLEL DO PRIVATE(k,l,i) do j=1,jj+1 do k=1,ddm do l=1,isu(j) - do i=max(1,ifu(j,l)),min(ii+1,ilu(j,l)) + do i=max(1,ifu(j,l)),min(ii+1,ilu(j,l)) phylvl(i,j,k,ACC_UFLXOLD(iogrp))= . phylvl(i,j,k,ACC_UFLXLVL(iogrp)) enddo enddo do l=1,isv(j) - do i=max(1,ifv(j,l)),min(ii,ilv(j,l)) + do i=max(1,ifv(j,l)),min(ii,ilv(j,l)) phylvl(i,j,k,ACC_VFLXOLD(iogrp))= . phylvl(i,j,k,ACC_VFLXLVL(iogrp)) enddo enddo - enddo - enddo + enddo + enddo c$OMP END PARALLEL DO endif enddo @@ -1708,11 +1654,13 @@ subroutine diaacc(m,n,mm,nn,k1m,k1n) enddo endif c - if (sum(ACC_SALNLVL(1:nphy)+ACC_TEMPLVL(1:nphy)+ - . ACC_BFSQLVL(1:nphy)+ACC_DIFDIALVL(1:nphy)+ - . ACC_DIFINTLVL(1:nphy)+ACC_DIFISOLVL(1:nphy)+ - . ACC_TKELVL(1:nphy)+ACC_GLS_PSILVL(1:nphy)+ - . ACC_PVLVL(1:nphy)+ACC_DZLVL(1:nphy)).ne.0) then + if (sum(ACC_SALNLVL(1:nphy) +ACC_TEMPLVL(1:nphy) + . +ACC_BFSQLVL(1:nphy) +ACC_DIFDIALVL(1:nphy) + . +ACC_DIFVMOLVL(1:nphy) +ACC_DIFVHOLVL(1:nphy) + . +ACC_DIFVSOLVL(1:nphy) +ACC_DIFINTLVL(1:nphy) + . +ACC_DIFISOLVL(1:nphy) +ACC_TKELVL(1:nphy) + . +ACC_GLS_PSILVL(1:nphy)+ACC_PVLVL(1:nphy) + . +ACC_DZLVL(1:nphy) ).ne.0) then do k=1,kk call diazlv('p',k,mm,nn,ind1,ind2,wghts,wghtsflx) c @@ -1733,9 +1681,19 @@ subroutine diaacc(m,n,mm,nn,k1m,k1n) c --- --- isopycnal diffusivity [cm^2/s] call acclvl(ACC_DIFISOLVL,difiso,'p',k,ind1,ind2,wghts) c -c --- --- diapycnal diffusivity [cm^2/s] +c --- --- vertical diffusivity (vcoord_type_tag == isopyc_bulkml) [cm^2/s] call acclvl(ACC_DIFDIALVL,difdia,'p',k,ind1,ind2,wghts) c +c --- --- vertical momentum diffusivity (vcoord_type_tag == cntiso_hybrid) +c --- --- [cm^2/s] + call accilv(ACC_DIFVMOLVL,Kvisc_m,'p',k,ind1,ind2,wghts) +c +c --- --- vertical heat diffusivity (vcoord_type_tag == cntiso_hybrid) [cm^2/s] + call accilv(ACC_DIFVHOLVL,Kdiff_t,'p',k,ind1,ind2,wghts) +c +c --- --- vertical salt diffusivity (vcoord_type_tag == cntiso_hybrid) [cm^2/s] + call accilv(ACC_DIFVSOLVL,Kdiff_s,'p',k,ind1,ind2,wghts) +c c --- --- potential vorticity [s m-2] call acclvl(ACC_PVLVL,pv_p,'p',k,ind1,ind2,wghts) c @@ -1808,7 +1766,7 @@ subroutine diaout(iogrp,m,n,mm,nn,k1m,k1n) c rnacc=1./real(nacc_phy(iogrp)) cmpflg=GLB_COMPFLAG(iogrp) -c +c c --- compute meridional transports and transports through sections if (ACC_MMFLXL(iogrp)+ACC_MMFLXD(iogrp)+ACC_MMFTDL(iogrp) . +ACC_MMFTDD(iogrp)+ACC_MHFLX(iogrp)+ACC_MHFTD(iogrp) @@ -1932,7 +1890,7 @@ subroutine diaout(iogrp,m,n,mm,nn,k1m,k1n) enddo c$OMP END PARALLEL DO call xcsum(volgs(1),util1,ips) - volgs(1)=rnacc*1e-6*volgs(1)/g + volgs(1)=rnacc*V_cgs2mks*volgs(1)/g endif if (MSC_SALNGA(iogrp).ne.0) then c$OMP PARALLEL DO PRIVATE(l,i) @@ -2001,7 +1959,7 @@ subroutine diaout(iogrp,m,n,mm,nn,k1m,k1n) tempga(1)=tempga(1)/massgs(1) endif if (MSC_MASSGS(iogrp).ne.0) then - massgs(1)=rnacc*1e-3*massgs(1)/g + massgs(1)=rnacc*M_cgs2mks*massgs(1)/g endif if (MSC_SSSGA(iogrp).ne.0) then c$OMP PARALLEL DO PRIVATE(l,i) @@ -2033,8 +1991,6 @@ subroutine diaout(iogrp,m,n,mm,nn,k1m,k1n) c --- finalize accumulation of 2d fields call finh2d(ACC_HICE(iogrp),ACC_FICE(iogrp),'p') call finh2d(ACC_HSNW(iogrp),ACC_FICE(iogrp),'p') - call finh2d(ACC_MXLU(iogrp),ACC_MLDU(iogrp),'u') - call finh2d(ACC_MXLV(iogrp),ACC_MLDV(iogrp),'v') call finh2d(ACC_UICE(iogrp),ACC_IVOLU(iogrp),'u') call finh2d(ACC_VICE(iogrp),ACC_IVOLV(iogrp),'v') c @@ -2045,6 +2001,9 @@ subroutine diaout(iogrp,m,n,mm,nn,k1m,k1n) call finlyr(ACC_TEMP(iogrp),ACC_DP(iogrp),'p') call finlyr(ACC_BFSQ(iogrp),ACC_DP(iogrp),'p') call finlyr(ACC_DIFDIA(iogrp),ACC_DP(iogrp),'p') + call finlyr(ACC_DIFVMO(iogrp),ACC_DP(iogrp),'p') + call finlyr(ACC_DIFVHO(iogrp),ACC_DP(iogrp),'p') + call finlyr(ACC_DIFVSO(iogrp),ACC_DP(iogrp),'p') call finlyr(ACC_DIFINT(iogrp),ACC_DP(iogrp),'p') call finlyr(ACC_DIFISO(iogrp),ACC_DP(iogrp),'p') call finlyr(ACC_AVDSG(iogrp),ACC_DPVOR(iogrp),'p') @@ -2052,25 +2011,40 @@ subroutine diaout(iogrp,m,n,mm,nn,k1m,k1n) call finlyr(ACC_TKE(iogrp),ACC_DP(iogrp),'p') call finlyr(ACC_GLS_PSI(iogrp),ACC_DP(iogrp),'p') #endif -c +c c --- compute log10 of diffusivities if (LYR_DIFDIA(iogrp).eq.2) - . call loglyr(ACC_DIFDIA(iogrp),'p',1e-4,0.) + . call loglyr(ACC_DIFDIA(iogrp),'p',A_cgs2mks,0.) + if (LYR_DIFVMO(iogrp).eq.2) + . call loglyr(ACC_DIFVMO(iogrp),'p',A_cgs2mks,0.) + if (LYR_DIFVHO(iogrp).eq.2) + . call loglyr(ACC_DIFVHO(iogrp),'p',A_cgs2mks,0.) + if (LYR_DIFVSO(iogrp).eq.2) + . call loglyr(ACC_DIFVSO(iogrp),'p',A_cgs2mks,0.) if (LYR_DIFINT(iogrp).eq.2) - . call loglyr(ACC_DIFINT(iogrp),'p',1e-4,0.) + . call loglyr(ACC_DIFINT(iogrp),'p',A_cgs2mks,0.) if (LYR_DIFISO(iogrp).eq.2) - . call loglyr(ACC_DIFISO(iogrp),'p',1e-4,0.) + . call loglyr(ACC_DIFISO(iogrp),'p',A_cgs2mks,0.) c if (LVL_DIFDIA(iogrp).eq.2) - . call loglvl(ACC_DIFDIALVL(iogrp),'p',1e-4*rnacc,0.) + . call loglvl(ACC_DIFDIALVL(iogrp),'p',A_cgs2mks*rnacc,0.) + if (LVL_DIFVMO(iogrp).eq.2) + . call loglvl(ACC_DIFVMOLVL(iogrp),'p',A_cgs2mks*rnacc,0.) + if (LVL_DIFVHO(iogrp).eq.2) + . call loglvl(ACC_DIFVHOLVL(iogrp),'p',A_cgs2mks*rnacc,0.) + if (LVL_DIFVSO(iogrp).eq.2) + . call loglvl(ACC_DIFVSOLVL(iogrp),'p',A_cgs2mks*rnacc,0.) if (LVL_DIFINT(iogrp).eq.2) - . call loglvl(ACC_DIFINTLVL(iogrp),'p',1e-4*rnacc,0.) + . call loglvl(ACC_DIFINTLVL(iogrp),'p',A_cgs2mks*rnacc,0.) if (LVL_DIFISO(iogrp).eq.2) - . call loglvl(ACC_DIFISOLVL(iogrp),'p',1e-4*rnacc,0.) + . call loglvl(ACC_DIFISOLVL(iogrp),'p',A_cgs2mks*rnacc,0.) c c --- mask sea floor of level fields call msklvl(ACC_BFSQLVL(iogrp),'p') call msklvl(ACC_DIFDIALVL(iogrp),'p') + call msklvl(ACC_DIFVMOLVL(iogrp),'p') + call msklvl(ACC_DIFVHOLVL(iogrp),'p') + call msklvl(ACC_DIFVSOLVL(iogrp),'p') call msklvl(ACC_DIFINTLVL(iogrp),'p') call msklvl(ACC_DIFISOLVL(iogrp),'p') call msklvl(ACC_DZLVL(iogrp),'p') @@ -2101,8 +2075,8 @@ subroutine diaout(iogrp,m,n,mm,nn,k1m,k1n) call msklvl(ACC_TKELVL(iogrp),'p') call msklvl(ACC_GLS_PSILVL(iogrp),'p') #endif -c -c --- get instantaneous values for ice age +c +c --- get instantaneous values for ice age if (ACC_IAGE(iogrp).ne.0) then c$OMP PARALLEL DO PRIVATE(l,i) do j=1,jj @@ -2124,7 +2098,7 @@ subroutine diaout(iogrp,m,n,mm,nn,k1m,k1n) . date0%year,'-',date0%month,'-',date0%day,' 00:00' datenum=time-time0-0.5*diagfq_phy(iogrp)/nstep_in_day c -c --- create file name +c --- create file name if (.not.append2file(iogrp)) then call diafnm(GLB_FNAMETAG(IOGRP), . filefq_phy(iogrp)/real(nstep_in_day), @@ -2154,7 +2128,7 @@ subroutine diaout(iogrp,m,n,mm,nn,k1m,k1n) call ncfopn(fname(iogrp),'w','c',irec(iogrp),iotype) endif c -c --- compute extended ocean masks +c --- compute extended ocean masks if (iniflg) then iniflg=.false. c$OMP PARALLEL DO PRIVATE(i) @@ -2175,7 +2149,7 @@ subroutine diaout(iogrp,m,n,mm,nn,k1m,k1n) c$OMP END PARALLEL DO endif c -c --- define output dimensions +c --- define output dimensions if (cmpflg.ne.0) then call ncdimc('pcomp',ip,0) call ncdimc('ucomp',iuu,0) @@ -2186,7 +2160,7 @@ subroutine diaout(iogrp,m,n,mm,nn,k1m,k1n) endif call ncdims('sigma',kdm) call ncdims('depth',ddm) - call ncdims('bounds',2) + call ncdims('bounds',2) call ncdims('time',0) c if (ACC_MMFLXL(iogrp)+ACC_MMFLXD(iogrp)+ACC_MMFTDL(iogrp) @@ -2227,7 +2201,7 @@ subroutine diaout(iogrp,m,n,mm,nn,k1m,k1n) call nctime(datenum,calendar,timeunits,startdate) c -c --- write auxillary dimension information +c --- write auxillary dimension information if (irec(iogrp).eq.1) then c --- sigma levels call ncwrt1('sigma','sigma',sigmar1) @@ -2245,47 +2219,49 @@ subroutine diaout(iogrp,m,n,mm,nn,k1m,k1n) if (MSC_MMFLXL(iogrp)+MSC_MMFLXD(iogrp)+MSC_MMFTDL(iogrp) . +MSC_MMFTDD(iogrp)+MSC_MHFLX(iogrp)+MSC_MHFTD(iogrp) . +MSC_MHFLD(iogrp)+MSC_MSFLX(iogrp)+MSC_MSFTD(iogrp) - . +MSC_MSFLD(iogrp).ne.0) then - call ncwrt1('lat','lat',mtlat) + . +MSC_MSFLD(iogrp).ne.0) then + call ncwrt1('lat','lat',mtlat) call ncattr('long_name','Latitude') call ncattr('standard_name','latitude') call ncattr('units','degree_north') - call ncwrtc('region','slenmax region',mer_regnam) - call ncattr('long_name','Region name') + call ncwrtc('region','slenmax region',mer_regnam) + call ncattr('long_name','Region name') endif - if (MSC_VOLTR(iogrp).ne.0) then + if (MSC_VOLTR(iogrp).ne.0) then call ncwrtc('section','slenmax section',sec_name) - call ncattr('long_name','Section name') - endif + call ncattr('long_name','Section name') + endif endif c c --- write 2d fields - call wrth2d(ACC_SIGMX(iogrp),H2D_SIGMX(iogrp),rnacc*1e3, + call wrth2d(ACC_SIGMX(iogrp),H2D_SIGMX(iogrp),rnacc*R_cgs2mks, , 0.,cmpflg,ip,'p','sigmx','Mixed layer density',' ','kg m-3') c - call wrth2d(ACC_UB(iogrp),H2D_UB(iogrp),rnacc*1e-2, + call wrth2d(ACC_UB(iogrp),H2D_UB(iogrp),rnacc*L_cgs2mks, . 0.,cmpflg,iuu,'u','ubaro','Barotropic velocity x-component', . ' ','m s-1') c - call wrth2d(ACC_VB(iogrp),H2D_VB(iogrp),rnacc*1e-2, + call wrth2d(ACC_VB(iogrp),H2D_VB(iogrp),rnacc*L_cgs2mks, . 0.,cmpflg,ivv,'v','vbaro','Barotropic velocity y-component', . ' ','m s-1') c call wrth2d(ACC_PSRF(iogrp),H2D_PSRF(iogrp), - . rnacc*.1,0.,cmpflg,ip,'p','psrf','Surface pressure',' ','Pa') + . rnacc*P_cgs2mks,0.,cmpflg,ip,'p','psrf','Surface pressure', + . ' ','Pa') c call wrth2d(ACC_PBOT(iogrp),H2D_PBOT(iogrp), - . rnacc*.1,0.,cmpflg,ip,'p','pbot','Bottom pressure',' ','Pa') + . rnacc*P_cgs2mks,0.,cmpflg,ip,'p','pbot','Bottom pressure', + . ' ','Pa') c call wrth2d(ACC_SEALV(iogrp),H2D_SEALV(iogrp), - . -rnacc*1e-2,0.,cmpflg,ip,'p','sealv','Sea level',' ','m') + . -rnacc*L_cgs2mks,0.,cmpflg,ip,'p','sealv','Sea level',' ','m') c call wrth2d(ACC_SLVSQ(iogrp),H2D_SLVSQ(iogrp), - . rnacc*1e-4,0.,cmpflg,ip,'p','slvsq','Sea level squared',' ', - . 'm2') + . rnacc*A_cgs2mks,0.,cmpflg,ip,'p','slvsq','Sea level squared', + . ' ','m2') c call wrth2d(ACC_UTILH2D(1),H2D_BTMSTR(iogrp), - . rnacc*0.5e-3*dlt/(g*baclin),0.,cmpflg,ip,'p','btmstr', + . rnacc*0.5*M_cgs2mks*dlt/(g*baclin),0.,cmpflg,ip,'p','btmstr', . 'Barotropic mass streamfunction',' ','kg s-1') c call wrth2d(ACC_HICE(iogrp),H2D_HICE(iogrp),1.,0., @@ -2306,10 +2282,10 @@ subroutine diaout(iogrp,m,n,mm,nn,k1m,k1n) call wrth2d(ACC_IAGE(iogrp),H2D_IAGE(iogrp),1.,0., . cmpflg,ip,'p','iage','Ice age',' ','day') c - call wrth2d(ACC_UICE(iogrp),H2D_UICE(iogrp),1e-2,0., + call wrth2d(ACC_UICE(iogrp),H2D_UICE(iogrp),L_cgs2mks,0., . cmpflg,iuu,'u','uice','Ice velocity x-component',' ','m s-1') c - call wrth2d(ACC_VICE(iogrp),H2D_VICE(iogrp),1e-2,0., + call wrth2d(ACC_VICE(iogrp),H2D_VICE(iogrp),L_cgs2mks,0., . cmpflg,ivv,'v','vice','Ice velocity y-component',' ','m s-1') c call wrth2d(ACC_SWA(iogrp),H2D_SWA(iogrp),rnacc,0., @@ -2327,11 +2303,11 @@ subroutine diaout(iogrp,m,n,mm,nn,k1m,k1n) . 'W m-2 K-1') c call wrth2d(ACC_SURFLX(iogrp),H2D_SURFLX(iogrp), - . -rnacc*1e4,0.,cmpflg,ip,'p','hflx', + . -rnacc*L_mks2cgs*L_mks2cgs,0.,cmpflg,ip,'p','hflx', . 'Heat flux received by ocean',' ','W m-2') c call wrth2d(ACC_SURRLX(iogrp),H2D_SURRLX(iogrp), - . -rnacc*1e4,0.,cmpflg,ip,'p','hrflx', + . -rnacc*L_mks2cgs*L_mks2cgs,0.,cmpflg,ip,'p','hrflx', . 'Restoring heat flux received by ocean',' ','W m-2') c call wrth2d(ACC_LIP(iogrp),H2D_LIP(iogrp),rnacc,0., @@ -2354,16 +2330,16 @@ subroutine diaout(iogrp,m,n,mm,nn,k1m,k1n) . rnacc,0.,cmpflg,ip,'p','rfi','Frozen runoff',' ','kg m-2 s-1') c call wrth2d(ACC_SALFLX(iogrp),H2D_SALFLX(iogrp), - . -rnacc*1e-2,0.,cmpflg,ip,'p','sflx', + . -rnacc*(g2kg*M_cgs2mks/A_cgs2mks),0.,cmpflg,ip,'p','sflx', . 'Salt flux received by ocean',' ','kg m-2 s-1') c call wrth2d(ACC_SALRLX(iogrp),H2D_SALRLX(iogrp), - . -rnacc*1e-2,0.,cmpflg,ip,'p','srflx', + . -rnacc*(g2kg*M_cgs2mks/A_cgs2mks),0.,cmpflg,ip,'p','srflx', . 'Restoring salt flux received by ocean',' ','kg m-2 s-1') c call wrth2d(ACC_BRNFLX(iogrp),H2D_BRNFLX(iogrp), - . rnacc*(-1e-2),0.,cmpflg,ip,'p','bflx','Brine flux',' ', - . 'kg m-2 s-1') + . rnacc*(-g2kg*M_cgs2mks/A_cgs2mks),0.,cmpflg,ip,'p','bflx', + . 'Brine flux',' ','kg m-2 s-1') c call wrth2d(ACC_ZTX(iogrp),H2D_ZTX(iogrp),rnacc,0., . cmpflg,iuu,'u','ztx','Wind stress x-component',' ','N m-2') @@ -2376,20 +2352,20 @@ subroutine diaout(iogrp,m,n,mm,nn,k1m,k1n) . 'Momentum flux received by ocean x-component',' ','N m-2') c call wrth2d(ACC_TAUY(iogrp),H2D_TAUY(iogrp),rnacc*.1, - . 0.,cmpflg,ivv,'v','tauy', + . 0.,cmpflg,ivv,'v','tauy', . 'Momentum flux received by ocean y-component',' ','N m-2') c call wrth2d(ACC_IDKEDT(iogrp),H2D_IDKEDT(iogrp), - . rnacc*1.e-3/alpha0,0.,cmpflg,ip,'p','idkedt', + . rnacc*M_cgs2mks/alpha0,0.,cmpflg,ip,'p','idkedt', . 'Mixed layer inertial kinetic energy tendency per unit area', . ' ','kg s-3') c call wrth2d(ACC_USTAR(iogrp),H2D_USTAR(iogrp), - . rnacc*1e-2,0.,cmpflg,ip,'p','ustar','Friction velocity',' ', - . 'm s-1') + . rnacc*L_cgs2mks,0.,cmpflg,ip,'p','ustar','Friction velocity', + . ' ','m s-1') c call wrth2d(ACC_USTAR3(iogrp),H2D_USTAR3(iogrp), - . rnacc*1.e-6,0.,cmpflg,ip,'p','ustar3', + . rnacc*V_cgs2mks,0.,cmpflg,ip,'p','ustar3', . 'Friction velocity cubed',' ','m3 s-3') c call wrth2d(ACC_ABSWND(iogrp),H2D_ABSWND(iogrp), @@ -2397,37 +2373,37 @@ subroutine diaout(iogrp,m,n,mm,nn,k1m,k1n) . 'm s-1') c call wrth2d(ACC_MTKEUS(iogrp),H2D_MTKEUS(iogrp), - . rnacc*1.e-3/alpha0,0.,cmpflg,ip,'p','mtkeus', + . rnacc*M_cgs2mks/alpha0,0.,cmpflg,ip,'p','mtkeus', . 'Mixed layer turbulent kinetic energy tendency '// . 'per unit area related to friction velocity', . ' ','kg s-3') c call wrth2d(ACC_MTKENI(iogrp),H2D_MTKENI(iogrp), - . rnacc*1.e-3/alpha0,0.,cmpflg,ip,'p','mtkeni', + . rnacc*M_cgs2mks/alpha0,0.,cmpflg,ip,'p','mtkeni', . 'Mixed layer turbulent kinetic energy tendency '// . 'per unit area related to near inertial motions', . ' ','kg s-3') c call wrth2d(ACC_MTKEBF(iogrp),H2D_MTKEBF(iogrp), - . rnacc*1.e-3/alpha0,0.,cmpflg,ip,'p','mtkebf', + . rnacc*M_cgs2mks/alpha0,0.,cmpflg,ip,'p','mtkebf', . 'Mixed layer turbulent kinetic energy tendency '// . 'per unit area related to buoyancy forcing', . ' ','kg s-3') c call wrth2d(ACC_MTKERS(iogrp),H2D_MTKERS(iogrp), - . rnacc*1.e-3/alpha0,0.,cmpflg,ip,'p','mtkers', + . rnacc*M_cgs2mks/alpha0,0.,cmpflg,ip,'p','mtkers', . 'Mixed layer turbulent kinetic energy tendency '// . 'per unit area related to eddy restratification', . ' ','kg s-3') c call wrth2d(ACC_MTKEPE(iogrp),H2D_MTKEPE(iogrp), - . rnacc*1.e-3/alpha0,0.,cmpflg,ip,'p','mtkepe', + . rnacc*M_cgs2mks/alpha0,0.,cmpflg,ip,'p','mtkepe', . 'Mixed layer turbulent kinetic energy tendency '// . 'per unit area related to potential energy change', . ' ','kg s-3') c call wrth2d(ACC_MTKEKE(iogrp),H2D_MTKEKE(iogrp), - . rnacc*1.e-3/alpha0,0.,cmpflg,ip,'p','mtkeke', + . rnacc*M_cgs2mks/alpha0,0.,cmpflg,ip,'p','mtkeke', . 'Mixed layer turbulent kinetic energy tendency '// . 'per unit area related to kinetic energy change', . ' ','kg s-3') @@ -2440,36 +2416,28 @@ subroutine diaout(iogrp,m,n,mm,nn,k1m,k1n) c call wrth2d(ACC_MLD(iogrp),H2D_MLD(iogrp),rnacc/onem, . 0.,cmpflg,ip,'p','mld','Mixed layer depth',' ','m') -c - call wrth2d(ACC_MLDU(iogrp),H2D_MLDU(iogrp), - . rnacc/onem,0.,cmpflg,iuu,'u','mldu', - . 'Mixed layer depth at u-point',' ','m') -c - call wrth2d(ACC_MLDV(iogrp),H2D_MLDV(iogrp), - . rnacc/onem,0.,cmpflg,ivv,'v','mldv', - . 'Mixed layer depth at v-point',' ','m') c call wrth2d(ACC_MAXMLD(iogrp),H2D_MAXMLD(iogrp), . 1./onem,0.,cmpflg,ip,'p','maxmld','Maximum mixed layer depth', . ' ','m') c - call wrth2d(ACC_MLTS(iogrp),H2D_MLTS(iogrp),rnacc*1e-2, + call wrth2d(ACC_MLTS(iogrp),H2D_MLTS(iogrp),rnacc*L_cgs2mks, . 0.,cmpflg,ip,'p','mlts', . 'Mixed layer thickness defined by sigma t',' ','m') c - call wrth2d(ACC_MLTSMN(iogrp),H2D_MLTSMN(iogrp),1e-2, + call wrth2d(ACC_MLTSMN(iogrp),H2D_MLTSMN(iogrp),L_cgs2mks, . 0.,cmpflg,ip,'p','mltsmn', . 'Minimum mixed layer thickness defined by sigma t',' ','m') c - call wrth2d(ACC_MLTSMX(iogrp),H2D_MLTSMX(iogrp),1e-2, + call wrth2d(ACC_MLTSMX(iogrp),H2D_MLTSMX(iogrp),L_cgs2mks, . 0.,cmpflg,ip,'p','mltsmx', . 'Maximum mixed layer thickness defined by sigma t',' ','m') c - call wrth2d(ACC_MLTSSQ(iogrp),H2D_MLTSSQ(iogrp),rnacc*1e-4, + call wrth2d(ACC_MLTSSQ(iogrp),H2D_MLTSSQ(iogrp),rnacc*A_cgs2mks, . 0.,cmpflg,ip,'p','mltssq', - . 'Mixed layer thickness squared defined by sigma t',' ','m') + . 'Mixed layer thickness squared defined by sigma t',' ','m2') c - call wrth2d(ACC_T20D(iogrp),H2D_T20D(iogrp),rnacc*1e-2, + call wrth2d(ACC_T20D(iogrp),H2D_T20D(iogrp),rnacc*L_cgs2mks, . 0.,cmpflg,ip,'p','t20d','20C isoterm depth',' ','m') c call wrth2d(ACC_BRNPD(iogrp),H2D_BRNPD(iogrp),rnacc/onem, @@ -2494,21 +2462,13 @@ subroutine diaout(iogrp,m,n,mm,nn,k1m,k1n) c call wrth2d(ACC_TBOT(iogrp),H2D_TBOT(iogrp),rnacc,0., . cmpflg,ip,'p','tbot','Bottom temperature',' ','degC') -c - call wrth2d(ACC_MXLU(iogrp),H2D_MXLU(iogrp),1e-2,0., - . cmpflg,iuu,'u','mxlu','Mixed layer velocity x-component',' ', - . 'm s-1') -c - call wrth2d(ACC_MXLV(iogrp),H2D_MXLV(iogrp),1e-2,0., - . cmpflg,ivv,'v','mxlv','Mixed layer velocity y-component',' ', - . 'm s-1') c c --- write 3d layer fields - call wrtlyr(ACC_DP(iogrp),LYR_DP(iogrp),rnacc*.1,0., + call wrtlyr(ACC_DP(iogrp),LYR_DP(iogrp),rnacc*P_cgs2mks,0., . cmpflg,ip,'p','dp','Layer pressure thickness',' ','Pa') c call wrtlyr(ACC_DZ(iogrp),LYR_DZ(iogrp), - . rnacc*1e-2,0.,cmpflg,ip,'p','dz','Layer thickness',' ','m') + . rnacc*L_cgs2mks,0.,cmpflg,ip,'p','dz','Layer thickness',' ','m') c call wrtlyr(ACC_TEMP(iogrp),LYR_TEMP(iogrp),1.,0., . cmpflg,ip,'p','temp','Temperature','Ocean temperature', @@ -2517,18 +2477,18 @@ subroutine diaout(iogrp,m,n,mm,nn,k1m,k1n) call wrtlyr(ACC_SALN(iogrp),LYR_SALN(iogrp),1.,0., . cmpflg,ip,'p','saln','Salinity','Ocean salinity','g kg-1') c - call wrtlyr(ACC_UVEL(iogrp),LYR_UVEL(iogrp),1e-2, + call wrtlyr(ACC_UVEL(iogrp),LYR_UVEL(iogrp),L_cgs2mks, . 0.,cmpflg,iuu,'u','uvel','Velocity x-component',' ','m s-1') c - call wrtlyr(ACC_VVEL(iogrp),LYR_VVEL(iogrp),1e-2, + call wrtlyr(ACC_VVEL(iogrp),LYR_VVEL(iogrp),L_cgs2mks, . 0.,cmpflg,ivv,'v','vvel','Velocity y-component',' ','m s-1') c call wrtlyr(ACC_UFLX(iogrp),LYR_UFLX(iogrp), - . rnacc*0.5e-3/(g*baclin),0.,cmpflg,iuu,'u','uflx', + . rnacc*0.5*M_cgs2mks/(g*baclin),0.,cmpflg,iuu,'u','uflx', . 'Mass flux in x-direction',' ','kg s-1') c call wrtlyr(ACC_VFLX(iogrp),LYR_VFLX(iogrp), - . rnacc*0.5e-3/(g*baclin),0.,cmpflg,ivv,'v','vflx', + . rnacc*0.5*M_cgs2mks/(g*baclin),0.,cmpflg,ivv,'v','vflx', . 'Mass flux in y-direction',' ','kg s-1') c call wrtlyr(ACC_UTFLX(iogrp),LYR_UTFLX(iogrp), @@ -2540,20 +2500,20 @@ subroutine diaout(iogrp,m,n,mm,nn,k1m,k1n) . 'Heat flux in y-direction',' ','W') c call wrtlyr(ACC_USFLX(iogrp),LYR_USFLX(iogrp), - . rnacc*0.5e-6/(g*baclin),0.,cmpflg,iuu,'u','usflx', + . rnacc*0.5*g2kg*M_cgs2mks/(g*baclin),0.,cmpflg,iuu,'u','usflx', . 'Salt flux in x-direction',' ','kg s-1') c call wrtlyr(ACC_VSFLX(iogrp),LYR_VSFLX(iogrp), - . rnacc*0.5e-6/(g*baclin),0.,cmpflg,ivv,'v','vsflx', + . rnacc*0.5*g2kg*M_cgs2mks/(g*baclin),0.,cmpflg,ivv,'v','vsflx', . 'Salt flux in y-direction',' ','kg s-1') c call wrtlyr(ACC_UMFLTD(iogrp),LYR_UMFLTD(iogrp), - . rnacc*0.5e-3/(g*baclin),0.,cmpflg,iuu,'u','umfltd', + . rnacc*0.5*M_cgs2mks/(g*baclin),0.,cmpflg,iuu,'u','umfltd', . 'Mass flux due to thickness diffusion in x-direction',' ', . 'kg s-1') c call wrtlyr(ACC_VMFLTD(iogrp),LYR_VMFLTD(iogrp), - . rnacc*0.5e-3/(g*baclin),0.,cmpflg,ivv,'v','vmfltd', + . rnacc*0.5*M_cgs2mks/(g*baclin),0.,cmpflg,ivv,'v','vmfltd', . 'Mass flux due to thickness diffusion in y-direction',' ', . 'kg s-1') c @@ -2578,31 +2538,31 @@ subroutine diaout(iogrp,m,n,mm,nn,k1m,k1n) . 'W') c call wrtlyr(ACC_USFLTD(iogrp),LYR_USFLTD(iogrp), - . rnacc*0.5e-6/(g*baclin),0.,cmpflg,iuu,'u','usfltd', + . rnacc*0.5*g2kg*M_cgs2mks/(g*baclin),0.,cmpflg,iuu,'u','usfltd', . 'Salt flux due to thickness diffusion in x-direction',' ', . 'kg s-1') c call wrtlyr(ACC_VSFLTD(iogrp),LYR_VSFLTD(iogrp), - . rnacc*0.5e-6/(g*baclin),0.,cmpflg,ivv,'v','vsfltd', + . rnacc*0.5*g2kg*M_cgs2mks/(g*baclin),0.,cmpflg,ivv,'v','vsfltd', . 'Salt flux due to thickness diffusion in y-direction',' ', . 'kg s-1') c call wrtlyr(ACC_USFLLD(iogrp),LYR_USFLLD(iogrp), - . rnacc*0.5e-6/(g*baclin),0.,cmpflg,iuu,'u','usflld', + . rnacc*0.5*g2kg*M_cgs2mks/(g*baclin),0.,cmpflg,iuu,'u','usflld', . 'Salt flux due to lateral diffusion in x-direction',' ', . 'kg s-1') c call wrtlyr(ACC_VSFLLD(iogrp),LYR_VSFLLD(iogrp), - . rnacc*0.5e-6/(g*baclin),0.,cmpflg,ivv,'v','vsflld', + . rnacc*0.5*g2kg*M_cgs2mks/(g*baclin),0.,cmpflg,ivv,'v','vsflld', . 'Salt flux due to lateral diffusion in y-direction',' ', . 'kg s-1') c call wrtlyr(ACC_WFLX(iogrp),LYR_WFLX(iogrp), - . rnacc*0.5e-3/(g*baclin),0.,cmpflg,ip,'p','wflx', + . rnacc*0.5*M_cgs2mks/(g*baclin),0.,cmpflg,ip,'p','wflx', . 'Vertical mass flux',' ','kg s-1') c call wrtlyr(ACC_WFLX2(iogrp),LYR_WFLX2(iogrp), - . rnacc*(0.5e-3/(g*baclin))**2,0.,cmpflg,ip,'p','wflx2', + . rnacc*(0.5*M_cgs2mks/(g*baclin))**2,0.,cmpflg,ip,'p','wflx2', . 'Vertical mass flux squared',' ','kg2 s-2') c call wrtlyr(ACC_BFSQ(iogrp),LYR_BFSQ(iogrp),1.,0., @@ -2610,7 +2570,7 @@ subroutine diaout(iogrp,m,n,mm,nn,k1m,k1n) . 's-1') c call wrtlyr(ACC_AVDSG(iogrp),LYR_PV(iogrp), - . 1.e2*g,0.,cmpflg,ip,'p','pv','Potential vorticity',' ', + . L_mks2cgs*g,0.,cmpflg,ip,'p','pv','Potential vorticity',' ', . 'm-1 s-1') c if (LYR_DIFINT(iogrp).eq.2) then @@ -2618,7 +2578,7 @@ subroutine diaout(iogrp,m,n,mm,nn,k1m,k1n) . 0.,cmpflg,ip,'p','difint','Layer interface diffusivity', . ' ','log10(m2 s-1)') else - call wrtlyr(ACC_DIFINT(iogrp),LYR_DIFINT(iogrp),1e-4, + call wrtlyr(ACC_DIFINT(iogrp),LYR_DIFINT(iogrp),A_cgs2mks, . 0.,cmpflg,ip,'p','difint','Layer interface diffusivity', . ' ','m2 s-1') endif @@ -2628,34 +2588,65 @@ subroutine diaout(iogrp,m,n,mm,nn,k1m,k1n) . 0.,cmpflg,ip,'p','difiso','Isopycnal diffusivity',' ', . 'log10(m2 s-1)') else - call wrtlyr(ACC_DIFISO(iogrp),LYR_DIFISO(iogrp),1e-4, + call wrtlyr(ACC_DIFISO(iogrp),LYR_DIFISO(iogrp),A_cgs2mks, . 0.,cmpflg,ip,'p','difiso','Isopycnal diffusivity',' ', . 'm2 s-1') endif c if (LYR_DIFDIA(iogrp).eq.2) then call wrtlyr(ACC_DIFDIA(iogrp),LYR_DIFDIA(iogrp),1., - . 0.,cmpflg,ip,'p','difdia','Diapycnal diffusivity',' ', + . 0.,cmpflg,ip,'p','difdia','Vertical diffusivity',' ', + . 'log10(m2 s-1)') + else + call wrtlyr(ACC_DIFDIA(iogrp),LYR_DIFDIA(iogrp),A_cgs2mks, + . 0.,cmpflg,ip,'p','difdia','Vertical diffusivity',' ', + . 'm2 s-1') + endif +c + if (LYR_DIFVMO(iogrp).eq.2) then + call wrtlyr(ACC_DIFVMO(iogrp),LYR_DIFVMO(iogrp),1., + . 0.,cmpflg,ip,'p','difvmo','Vertical momentum diffusivity',' ', + . 'log10(m2 s-1)') + else + call wrtlyr(ACC_DIFVMO(iogrp),LYR_DIFVMO(iogrp),A_cgs2mks, + . 0.,cmpflg,ip,'p','difvmo','Vertical momentum diffusivity',' ', + . 'm2 s-1') + endif +c + if (LYR_DIFVHO(iogrp).eq.2) then + call wrtlyr(ACC_DIFVHO(iogrp),LYR_DIFVHO(iogrp),1., + . 0.,cmpflg,ip,'p','difvho','Vertical heat diffusivity',' ', . 'log10(m2 s-1)') else - call wrtlyr(ACC_DIFDIA(iogrp),LYR_DIFDIA(iogrp),1e-4, - . 0.,cmpflg,ip,'p','difdia','Diapycnal diffusivity',' ', + call wrtlyr(ACC_DIFVHO(iogrp),LYR_DIFVHO(iogrp),A_cgs2mks, + . 0.,cmpflg,ip,'p','difvho','Vertical heat diffusivity',' ', + . 'm2 s-1') + endif +c + if (LYR_DIFVSO(iogrp).eq.2) then + call wrtlyr(ACC_DIFVSO(iogrp),LYR_DIFVSO(iogrp),1., + . 0.,cmpflg,ip,'p','difvso','Vertical salt diffusivity',' ', + . 'log10(m2 s-1)') + else + call wrtlyr(ACC_DIFVSO(iogrp),LYR_DIFVSO(iogrp),A_cgs2mks, + . 0.,cmpflg,ip,'p','difvso','Vertical salt diffusivity',' ', . 'm2 s-1') endif c #if defined(TRC) && defined(TKE) - call wrtlyr(ACC_TKE(iogrp),LYR_TKE(iogrp),1e-4,0., + call wrtlyr(ACC_TKE(iogrp),LYR_TKE(iogrp),A_cgs2mks,0., . cmpflg,ip,'p','tke','TKE','Turbulent kinetic energy', . 'm2 s-2') c - call wrtlyr(ACC_GLS_PSI(iogrp),LYR_GLS_PSI(iogrp),1.e-4,0., + call wrtlyr(ACC_GLS_PSI(iogrp),LYR_GLS_PSI(iogrp),A_cgs2mks,0., . cmpflg,ip,'p','gls_psi','GLS_PSI','Generic length scale', . 'm2 s-3') c #endif c --- Write 3d depth fields call wrtlvl(ACC_DZLVL(iogrp),LVL_DZ(iogrp), - . rnacc*1e-2,0.,cmpflg,ip,'p','dzlvl','Layer thickness',' ','m') + . rnacc*L_cgs2mks,0.,cmpflg,ip, + . 'p','dzlvl','Layer thickness',' ','m') c call wrtlvl(ACC_TEMPLVL(iogrp),LVL_TEMP(iogrp), . rnacc,0.,cmpflg,ip,'p','templvl','Temperature', @@ -2666,19 +2657,19 @@ subroutine diaout(iogrp,m,n,mm,nn,k1m,k1n) . 'Ocean salinity','g kg-1') c call wrtlvl(ACC_UVELLVL(iogrp),LVL_UVEL(iogrp), - . rnacc*1e-2,0.,cmpflg,iuu,'u','uvellvl', + . rnacc*L_cgs2mks,0.,cmpflg,iuu,'u','uvellvl', . 'Velocity x-component',' ','m s-1') c call wrtlvl(ACC_VVELLVL(iogrp),LVL_VVEL(iogrp), - . rnacc*1e-2,0.,cmpflg,ivv,'v','vvellvl', + . rnacc*L_cgs2mks,0.,cmpflg,ivv,'v','vvellvl', . 'Velocity y-component',' ','m s-1') -c +c call wrtlvl(ACC_UFLXLVL(iogrp),LVL_UFLX(iogrp), - . rnacc*0.5e-3/(g*baclin),0.,cmpflg,iuu,'u','uflxlvl', + . rnacc*0.5*M_cgs2mks/(g*baclin),0.,cmpflg,iuu,'u','uflxlvl', . 'Mass flux in x-direction',' ','kg s-1') c call wrtlvl(ACC_VFLXLVL(iogrp),LVL_VFLX(iogrp), - . rnacc*0.5e-3/(g*baclin),0.,cmpflg,ivv,'v','vflxlvl', + . rnacc*0.5*M_cgs2mks/(g*baclin),0.,cmpflg,ivv,'v','vflxlvl', . 'Mass flux in y-direction',' ','kg s-1') c call wrtlvl(ACC_UTFLXLVL(iogrp),LVL_UTFLX(iogrp), @@ -2690,20 +2681,20 @@ subroutine diaout(iogrp,m,n,mm,nn,k1m,k1n) . 'Heat flux in y-direction',' ','W') c call wrtlvl(ACC_USFLXLVL(iogrp),LVL_USFLX(iogrp), - . rnacc*0.5e-6/(g*baclin),0.,cmpflg,iuu,'u','usflxlvl', - . 'Salt flux in x-direction',' ','kg s-1') + . rnacc*0.5*g2kg*M_cgs2mks/(g*baclin),0.,cmpflg,iuu,'u', + . 'usflxlvl','Salt flux in x-direction',' ','kg s-1') c call wrtlvl(ACC_VSFLXLVL(iogrp),LVL_VSFLX(iogrp), - . rnacc*0.5e-6/(g*baclin),0.,cmpflg,ivv,'v','vsflxlvl', - . 'Salt flux in y-direction',' ','kg s-1') + . rnacc*0.5*g2kg*M_cgs2mks/(g*baclin),0.,cmpflg,ivv,'v', + . 'vsflxlvl','Salt flux in y-direction',' ','kg s-1') c call wrtlvl(ACC_UMFLTDLVL(iogrp),LVL_UMFLTD(iogrp), - . rnacc*0.5e-3/(g*baclin),0.,cmpflg,iuu,'u','umfltdlvl', + . rnacc*0.5*M_cgs2mks/(g*baclin),0.,cmpflg,iuu,'u','umfltdlvl', . 'Mass flux due to thickness diffusion in x-direction',' ', . 'kg s-1') c call wrtlvl(ACC_VMFLTDLVL(iogrp),LVL_VMFLTD(iogrp), - . rnacc*0.5e-3/(g*baclin),0.,cmpflg,ivv,'v','vmfltdlvl', + . rnacc*0.5*M_cgs2mks/(g*baclin),0.,cmpflg,ivv,'v','vmfltdlvl', . 'Mass flux due to thickness diffusion in y-direction',' ', . 'kg s-1') c @@ -2728,31 +2719,35 @@ subroutine diaout(iogrp,m,n,mm,nn,k1m,k1n) . 'W') c call wrtlvl(ACC_USFLTDLVL(iogrp),LVL_USFLTD(iogrp), - . rnacc*0.5e-6/(g*baclin),0.,cmpflg,iuu,'u','usfltdlvl', + . rnacc*0.5*g2kg*M_cgs2mks/(g*baclin),0.,cmpflg,iuu, + . 'u','usfltdlvl', . 'Salt flux due to thickness diffusion in x-direction',' ', . 'kg s-1') c call wrtlvl(ACC_VSFLTDLVL(iogrp),LVL_VSFLTD(iogrp), - . rnacc*0.5e-6/(g*baclin),0.,cmpflg,ivv,'v','vsfltdlvl', + . rnacc*0.5*g2kg*M_cgs2mks/(g*baclin),0.,cmpflg,ivv, + . 'v','vsfltdlvl', . 'Salt flux due to thickness diffusion in y-direction',' ', . 'kg s-1') c call wrtlvl(ACC_USFLLDLVL(iogrp),LVL_USFLLD(iogrp), - . rnacc*0.5e-6/(g*baclin),0.,cmpflg,iuu,'u','usflldlvl', + . rnacc*0.5*g2kg*M_cgs2mks/(g*baclin),0.,cmpflg,iuu, + . 'u','usflldlvl', . 'Salt flux due to lateral diffusion in x-direction',' ', . 'kg s-1') c call wrtlvl(ACC_VSFLLDLVL(iogrp),LVL_VSFLLD(iogrp), - . rnacc*0.5e-6/(g*baclin),0.,cmpflg,ivv,'v','vsflldlvl', + . rnacc*0.5*g2kg*M_cgs2mks/(g*baclin),0.,cmpflg,ivv, + . 'v','vsflldlvl', . 'Salt flux due to lateral diffusion in y-direction',' ', . 'kg s-1') c call wrtlvl(ACC_WFLXLVL(iogrp),LVL_WFLX(iogrp), - . rnacc*0.5e-3/(g*baclin),0.,cmpflg,ip,'p','wflxlvl', + . rnacc*0.5*M_cgs2mks/(g*baclin),0.,cmpflg,ip,'p','wflxlvl', . 'Vertical mass flux',' ','kg s-1') c call wrtlvl(ACC_WFLX2LVL(iogrp),LVL_WFLX2(iogrp), - . rnacc*(0.5e-3/(g*baclin))**2,0.,cmpflg,ip,'p','wflx2lvl', + . rnacc*(0.5*M_cgs2mks/(g*baclin))**2,0.,cmpflg,ip,'p','wflx2lvl', . 'Vertical mass flux squared',' ','kg2 s-2') c call wrtlvl(ACC_BFSQLVL(iogrp),LVL_BFSQ(iogrp), @@ -2760,17 +2755,17 @@ subroutine diaout(iogrp,m,n,mm,nn,k1m,k1n) . ' ','s-1') c call wrtlvl(ACC_PVLVL(iogrp),LVL_PV(iogrp), - . rnacc*1.e2*g,0.,cmpflg,ip,'p','pvlvl','Potential vorticity', - . ' ','m-1 s-1') + . rnacc*L_mks2cgs*g,0.,cmpflg,ip, + . 'p','pvlvl','Potential vorticity',' ','m-1 s-1') c if (LVL_DIFINT(iogrp).eq.2) then call wrtlvl(ACC_DIFINTLVL(iogrp),LVL_DIFINT(iogrp),1., . 0.,cmpflg,ip,'p','difintlvl','Layer interface diffusivity', . ' ','log10(m2 s-1)') else - call wrtlvl(ACC_DIFINTLVL(iogrp),LVL_DIFINT(iogrp),1e-4*rnacc, - . 0.,cmpflg,ip,'p','difintlvl','Layer interface diffusivity', - . ' ','m2 s-1') + call wrtlvl(ACC_DIFINTLVL(iogrp),LVL_DIFINT(iogrp), + . A_cgs2mks*rnacc,0.,cmpflg,ip,'p','difintlvl', + . 'Layer interface diffusivity',' ','m2 s-1') endif c if (LVL_DIFISO(iogrp).eq.2) then @@ -2778,96 +2773,126 @@ subroutine diaout(iogrp,m,n,mm,nn,k1m,k1n) . 0.,cmpflg,ip,'p','difisolvl','Isopycnal diffusivity',' ', . 'log10(m2 s-1)') else - call wrtlvl(ACC_DIFISOLVL(iogrp),LVL_DIFISO(iogrp),1e-4*rnacc, - . 0.,cmpflg,ip,'p','difisolvl','Isopycnal diffusivity',' ', - . 'm2 s-1') + call wrtlvl(ACC_DIFISOLVL(iogrp),LVL_DIFISO(iogrp), + . A_cgs2mks*rnacc,0.,cmpflg,ip,'p','difisolvl', + . 'Isopycnal diffusivity',' ','m2 s-1') endif c if (LVL_DIFDIA(iogrp).eq.2) then call wrtlvl(ACC_DIFDIALVL(iogrp),LVL_DIFDIA(iogrp),1., - . 0.,cmpflg,ip,'p','difdialvl','Diapycnal diffusivity',' ', + . 0.,cmpflg,ip,'p','difdialvl','Vertical diffusivity',' ', . 'log10(m2 s-1)') else - call wrtlvl(ACC_DIFDIALVL(iogrp),LVL_DIFDIA(iogrp),1e-4*rnacc, - . 0.,cmpflg,ip,'p','difdialvl','Diapycnal diffusivity',' ', - . 'm2 s-1') + call wrtlvl(ACC_DIFDIALVL(iogrp),LVL_DIFDIA(iogrp), + . A_cgs2mks*rnacc,0.,cmpflg,ip,'p','difdialvl', + . 'Vertical diffusivity',' ','m2 s-1') + endif +c + if (LVL_DIFVMO(iogrp).eq.2) then + call wrtlvl(ACC_DIFVMOLVL(iogrp),LVL_DIFVMO(iogrp),1., + . 0.,cmpflg,ip,'p','difvmolvl','Vertical momentum diffusivity', + . ' ','log10(m2 s-1)') + else + call wrtlvl(ACC_DIFVMOLVL(iogrp),LVL_DIFVMO(iogrp), + . A_cgs2mks*rnacc,0.,cmpflg,ip,'p','difvmolvl', + . 'Vertical momentum diffusivity',' ','m2 s-1') + endif +c + if (LVL_DIFVHO(iogrp).eq.2) then + call wrtlvl(ACC_DIFVHOLVL(iogrp),LVL_DIFVHO(iogrp),1., + . 0.,cmpflg,ip,'p','difvholvl','Vertical heat diffusivity', + . ' ','log10(m2 s-1)') + else + call wrtlvl(ACC_DIFVHOLVL(iogrp),LVL_DIFVHO(iogrp), + . A_cgs2mks*rnacc,0.,cmpflg,ip,'p','difvholvl', + . 'Vertical heat diffusivity',' ','m2 s-1') + endif +c + if (LVL_DIFVSO(iogrp).eq.2) then + call wrtlvl(ACC_DIFVSOLVL(iogrp),LVL_DIFVSO(iogrp),1., + . 0.,cmpflg,ip,'p','difvsolvl','Vertical salt diffusivity', + . ' ','log10(m2 s-1)') + else + call wrtlvl(ACC_DIFVSOLVL(iogrp),LVL_DIFVSO(iogrp), + . A_cgs2mks*rnacc,0.,cmpflg,ip,'p','difvsolvl', + . 'Vertical salt diffusivity',' ','m2 s-1') endif c #if defined(TRC) && defined(TKE) - call wrtlvl(ACC_TKELVL(iogrp),LVL_TKE(iogrp),rnacc*1.e-4, + call wrtlvl(ACC_TKELVL(iogrp),LVL_TKE(iogrp),rnacc*A_cgs2mks, . 0.,cmpflg,ip,'p','tkelvl','Turbulent kinetic energy',' ', . 'm2 s-2') c - call wrtlvl(ACC_GLS_PSILVL(iogrp),LVL_GLS_PSI(iogrp),rnacc*1.e-4, - . 0.,cmpflg,ip,'p','gls_psilvl','Generic length scale',' ', - . 'm2 s-3') + call wrtlvl(ACC_GLS_PSILVL(iogrp),LVL_GLS_PSI(iogrp), + . rnacc*A_cgs2mks,0.,cmpflg,ip,'p','gls_psilvl', + . 'Generic length scale',' ','m2 s-3') c #endif c -c --- store meridional transports - if (MSC_MMFLXL(iogrp).ne.0) then +c --- store meridional transports + if (MSC_MMFLXL(iogrp).ne.0) then call ncwrt1('mmflxl','lat sigma region time',mmflxl) call ncattr('long_name', - . 'Overturning stream-function on isopycnic layers') - call ncattr('units','kg s-1') + . 'Overturning stream-function on isopycnic layers') + call ncattr('units','kg s-1') endif - if (MSC_MMFLXD(iogrp).ne.0) then + if (MSC_MMFLXD(iogrp).ne.0) then call ncwrt1('mmflxd','lat depth region time',mmflxd) call ncattr('long_name', - . 'Overturning stream-function on z-levels') - call ncattr('units','kg s-1') + . 'Overturning stream-function on z-levels') + call ncattr('units','kg s-1') endif - if (MSC_MMFTDL(iogrp).ne.0) then + if (MSC_MMFTDL(iogrp).ne.0) then call ncwrt1('mmftdl','lat sigma region time',mmftdl) call ncattr('long_name', . 'Overturning stream-function due to thickness diffusion '// - . 'on isopycnic layers') - call ncattr('units','kg s-1') + . 'on isopycnic layers') + call ncattr('units','kg s-1') endif - if (MSC_MMFTDD(iogrp).ne.0) then + if (MSC_MMFTDD(iogrp).ne.0) then call ncwrt1('mmftdd','lat depth region time',mmftdd) call ncattr('long_name', . 'Overturning stream-function due to thickness diffusion '// - . 'on z-levels') - call ncattr('units','kg s-1') + . 'on z-levels') + call ncattr('units','kg s-1') endif - if (MSC_MHFLX(iogrp).ne.0) then + if (MSC_MHFLX(iogrp).ne.0) then call ncwrt1('mhflx','lat region time',mhflx) - call ncattr('long_name','Meridional heat flux') - call ncattr('units','W') + call ncattr('long_name','Meridional heat flux') + call ncattr('units','W') endif - if (MSC_MHFTD(iogrp).ne.0) then + if (MSC_MHFTD(iogrp).ne.0) then call ncwrt1('mhftd','lat region time',mhftd) call ncattr('long_name', - . 'Meridional heat flux due to thickness diffusion') - call ncattr('units','W') + . 'Meridional heat flux due to thickness diffusion') + call ncattr('units','W') endif - if (MSC_MHFLD(iogrp).ne.0) then + if (MSC_MHFLD(iogrp).ne.0) then call ncwrt1('mhfld','lat region time',mhfld) call ncattr('long_name', - . 'Meridional heat flux due to lateral diffusion') - call ncattr('units','W') + . 'Meridional heat flux due to lateral diffusion') + call ncattr('units','W') endif - if (MSC_MSFLX(iogrp).ne.0) then + if (MSC_MSFLX(iogrp).ne.0) then call ncwrt1('msflx','lat region time',msflx) - call ncattr('long_name','Meridional salt flux') - call ncattr('units','kg s-1') + call ncattr('long_name','Meridional salt flux') + call ncattr('units','kg s-1') endif - if (MSC_MSFTD(iogrp).ne.0) then + if (MSC_MSFTD(iogrp).ne.0) then call ncwrt1('msftd','lat region time',msftd) call ncattr('long_name', - . 'Meridional salt flux due to thickness diffusion') - call ncattr('units','kg s-1') + . 'Meridional salt flux due to thickness diffusion') + call ncattr('units','kg s-1') endif - if (MSC_MSFLD(iogrp).ne.0) then + if (MSC_MSFLD(iogrp).ne.0) then call ncwrt1('msfld','lat region time',msfld) call ncattr('long_name', - . 'Meridional salt flux due to lateral diffusion') - call ncattr('units','kg s-1') + . 'Meridional salt flux due to lateral diffusion') + call ncattr('units','kg s-1') endif c -c --- store section transports - if (MSC_VOLTR(iogrp).ne.0) then +c --- store section transports + if (MSC_VOLTR(iogrp).ne.0) then call ncwrt1('voltr','section time',voltr) call ncattr('long_name','Section transports') call ncattr('units','kg s-1') @@ -2911,12 +2936,12 @@ subroutine diaout(iogrp,m,n,mm,nn,k1m,k1n) call inilyr(ACC_UTILLYR(1),'p',0.) call acclyr(ACC_UTILLYR,dp(1-nbdy,1-nbdy,k1m),tmp3d,0,'p') call wrtlyr(ACC_UTILLYR(1), - . max(LYR_IDLAGE(iogrp),LYR_TRC(iogrp)),1.,0.,cmpflg,ip,'p', - . 'dp_trc','Layer pressure thickness',' ','Pa') + . max(LYR_IDLAGE(iogrp),LYR_TRC(iogrp)),P_cgs2mks,0.,cmpflg,ip, + . 'p','dp_trc','Layer pressure thickness',' ','Pa') endif # ifdef IDLAGE c -c --- ideal age tracer +c --- ideal age tracer if (LYR_IDLAGE(iogrp).ne.0) then call inilyr(ACC_UTILLYR(1),'p',0.) call acclyr(ACC_UTILLYR,trc(1-nbdy,1-nbdy,k1m,itriag),tmp3d,0, @@ -3046,7 +3071,7 @@ subroutine diaout(iogrp,m,n,mm,nn,k1m,k1n) c --- initialisation of fields call inifld(iogrp) c -c --- reset accumulation counter +c --- reset accumulation counter nacc_phy(iogrp)=0 c end subroutine diaout @@ -3105,8 +3130,8 @@ subroutine diasec(iogrp) call xcbcst(sec_num) iniflg=.false. endif -c -c --- Prepare 2d field +c +c --- Prepare 2d field c$OMP PARALLEL DO PRIVATE(i) do j=1,jj do i=1,ii @@ -3126,14 +3151,14 @@ subroutine diasec(iogrp) do i=max(1,ifu(j,l)),min(ii,ilu(j,l)) uflx_cum(i,j)=uflx_cum(i,j)+ . phylvl(i,j,k,ACC_UFLXLVL(iogrp)) - . *0.5e-3/(g*baclin*nacc_phy(iogrp)) + . *0.5*M_cgs2mks/(g*baclin*nacc_phy(iogrp)) enddo enddo do l=1,isv(j) do i=max(1,ifv(j,l)),min(ii,ilv(j,l)) vflx_cum(i,j)=vflx_cum(i,j)+ . phylvl(i,j,k,ACC_VFLXLVL(iogrp)) - . *0.5e-3/(g*baclin*nacc_phy(iogrp)) + . *0.5*M_cgs2mks/(g*baclin*nacc_phy(iogrp)) enddo enddo c @@ -3149,7 +3174,7 @@ subroutine diasec(iogrp) vflx_cum350(i,j)=vflx_cum(i,j) enddo enddo - elseif (k.eq.k350) then + elseif (k.eq.k350) then do l=1,isu(j) do i=max(1,ifu(j,l)),min(ii,ilu(j,l)) uflx_cum350(i,j)=uflx_cum350(i,j)+ @@ -3206,7 +3231,7 @@ subroutine diamer(iogrp) implicit none c integer :: iogrp -c +c integer :: ncid,dimid,varid,i,j,k,l,m,n,o,s,ocn_nreg,iostatus, . istat,iind1,jind1,uflg1,vflg1,nind1, . nfld,ACC_UIND,ACC_VIND,nind(ldm),iind(sdm,ldm),jind(sdm,ldm), @@ -3330,7 +3355,7 @@ subroutine diamer(iogrp) c endif c -c --- Compute vertical integrated heat and salt transports +c --- Compute vertical integrated heat and salt transports c c$OMP PARALLEL DO PRIVATE(i) do j=1,jj @@ -3362,17 +3387,17 @@ subroutine diamer(iogrp) if (ACC_MSFLX(iogrp).eq.0) exit ACC_UIND=ACC_USFLX(iogrp) ACC_VIND=ACC_VSFLX(iogrp) - r=0.5e-6/(g*baclin*nacc_phy(iogrp)) + r=0.5*g2kg*M_cgs2mks/(g*baclin*nacc_phy(iogrp)) elseif (nfld.eq.5) then if (ACC_MSFTD(iogrp).eq.0) exit ACC_UIND=ACC_USFLTD(iogrp) ACC_VIND=ACC_VSFLTD(iogrp) - r=0.5e-6/(g*baclin*nacc_phy(iogrp)) + r=0.5*g2kg*M_cgs2mks/(g*baclin*nacc_phy(iogrp)) elseif (nfld.eq.6) then if (ACC_MSFLD(iogrp).eq.0) exit ACC_UIND=ACC_USFLLD(iogrp) ACC_VIND=ACC_VSFLLD(iogrp) - r=0.5e-6/(g*baclin*nacc_phy(iogrp)) + r=0.5*g2kg*M_cgs2mks/(g*baclin*nacc_phy(iogrp)) else write(lp,*) 'field index out of range' call xchalt('(diamer)') @@ -3413,8 +3438,8 @@ subroutine diamer(iogrp) do o=1,ocn_nreg mflx_or(l,o)=0. mcnt_or(l,o)=0 - enddo - do s=1,nind(l) + enddo + do s=1,nind(l) i=iind(s,l) j=jind(s,l) o=oflg(i,j) @@ -3533,7 +3558,7 @@ subroutine diamer(iogrp) enddo c$OMP END PARALLEL DO c - r=0.5e-3/(g*baclin*nacc_phy(iogrp)) + r=0.5*M_cgs2mks/(g*baclin*nacc_phy(iogrp)) c do nfld=1,2 c @@ -3604,10 +3629,10 @@ subroutine diamer(iogrp) if (mnproc.eq.1) then do l=1,lmax c ---- ------ Accumulate meridional fluxes in seperate ocean regions - do o=1,ocn_nreg + do o=1,ocn_nreg mflx_or(l,o)=0. - enddo - do s=1,nind(l) + enddo + do s=1,nind(l) i=iind(s,l) j=jind(s,l) o=oflg(i,j) @@ -3635,7 +3660,7 @@ subroutine diamer(iogrp) enddo endif if (abs(mflx_mr(l,m)-mflx_last_mr(l,m)).lt. - . 1.e5*epsil) then + . 1.e5*epsilp) then mflx_last_mr(l,m)=mflx_mr(l,m) mflx_mr(l,m)=nf90_fill_double else @@ -3668,7 +3693,7 @@ subroutine diamer(iogrp) enddo c c --- Compute overturning stream function at levitus level interfaces -c --- Prepare depth mask +c --- Prepare depth mask c if (iniflg) call xcaget(depthst,depths,1) if (iniflg.and.mnproc.eq.1) then @@ -3676,7 +3701,7 @@ subroutine diamer(iogrp) do m=1,mer_nreg kmax(l,m)=0 enddo - enddo + enddo do k=1,ddm do l=1,lmax do s=1,nind(l) @@ -3693,12 +3718,12 @@ subroutine diamer(iogrp) endif enddo endif - enddo + enddo enddo enddo endif c - r=0.5e-3/(g*baclin*nacc_phy(iogrp)) + r=0.5*M_cgs2mks/(g*baclin*nacc_phy(iogrp)) c do nfld=1,2 c @@ -3750,10 +3775,10 @@ subroutine diamer(iogrp) if (mnproc.eq.1) then do l=1,lmax c ---- ------ Accumulate meridional fluxes in seperate ocean regions - do o=1,ocn_nreg + do o=1,ocn_nreg mflx_or(l,o)=0. - enddo - do s=1,nind(l) + enddo + do s=1,nind(l) i=iind(s,l) j=jind(s,l) o=oflg(i,j) @@ -3815,7 +3840,7 @@ end subroutine diamer subroutine diavfl(iogrp,m,n,mm,nn,k1m,k1n) c c --- ------------------------------------------------------------------ -c --- computation of vertical mass flux at isopycnic layer interfaces +c --- computation of vertical mass flux at isopycnic layer interfaces c --- ------------------------------------------------------------------ c implicit none @@ -3827,7 +3852,7 @@ subroutine diavfl(iogrp,m,n,mm,nn,k1m,k1n) real :: q c c --- -c --- Compute vertical mass flux at isopycnic layer interfaces +c --- Compute vertical mass flux at isopycnic layer interfaces c --- if (ACC_WFLX(iogrp)+ACC_WFLX2(IOGRP).ne.0) then c @@ -3836,15 +3861,15 @@ subroutine diavfl(iogrp,m,n,mm,nn,k1m,k1n) do i=1,ii wflx(i,j)=0. enddo - enddo + enddo c$OMP END PARALLEL DO do k=kk,1,-1 km=k+mm kn=k+nn c$OMP PARALLEL DO PRIVATE(l,i) - do j=1,jj + do j=1,jj do l=1,isp(j) - do i=max(1,ifp(j,l)),min(ii,ilp(j,l)) + do i=max(1,ifp(j,l)),min(ii,ilp(j,l)) wflx(i,j)=wflx(i,j) . -(uflx(i+1,j,kn)-uflx(i,j,kn) . +vflx(i,j+1,kn)-vflx(i,j,kn)) @@ -3859,8 +3884,8 @@ subroutine diavfl(iogrp,m,n,mm,nn,k1m,k1n) c$OMP END PARALLEL DO enddo endif -c -c --- Computation of vertical mass flux at levitus layer interfaces +c +c --- Computation of vertical mass flux at levitus layer interfaces if (ACC_WFLXLVL(iogrp)+ACC_WFLX2LVL(iogrp).ne.0) then c call xctilr(phylvl(1-nbdy,1-nbdy,1,ACC_UFLXLVL(iogrp)), @@ -3873,35 +3898,35 @@ subroutine diavfl(iogrp,m,n,mm,nn,k1m,k1n) ucum(i,j)=0. vcum(i,j)=0. enddo - enddo + enddo c$OMP END PARALLEL DO do k=ddm,1,-1 c$OMP PARALLEL DO PRIVATE(l,i) do j=1,jj do l=1,isu(j) - do i=max(1,ifu(j,l)),min(ii+1,ilu(j,l)) + do i=max(1,ifu(j,l)),min(ii+1,ilu(j,l)) ucum(i,j)=ucum(i,j) . +phylvl(i,j,k,ACC_UFLXLVL(iogrp)) . -phylvl(i,j,k,ACC_UFLXOLD(iogrp)) enddo enddo - enddo + enddo c$OMP END PARALLEL DO c$OMP PARALLEL DO PRIVATE(l,i) - do j=1,jj+1 + do j=1,jj+1 do l=1,isv(j) - do i=max(1,ifv(j,l)),min(ii,ilv(j,l)) + do i=max(1,ifv(j,l)),min(ii,ilv(j,l)) vcum(i,j)=vcum(i,j) . +phylvl(i,j,k,ACC_VFLXLVL(iogrp)) . -phylvl(i,j,k,ACC_VFLXOLD(iogrp)) enddo enddo - enddo + enddo c$OMP END PARALLEL DO c$OMP PARALLEL DO PRIVATE(l,i,q) - do j=1,jj + do j=1,jj do l=1,isp(j) - do i=max(1,ifp(j,l)),min(ii,ilp(j,l)) + do i=max(1,ifp(j,l)),min(ii,ilp(j,l)) q=-(ucum(i+1,j)-ucum(i,j) . +vcum(i,j+1)-vcum(i,j)) phylvl(i,j,k,ACC_WFLXLVL(iogrp))= @@ -3926,7 +3951,7 @@ subroutine diazlv(gridid,k,mm,nn,ind1,ind2,weights,weightsflx) c integer :: d,i,j,k,mm,nn,l,kl,km,kn,kml,k1m integer, dimension(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy) :: ind1,ind2 -c +c real :: r,dzeps,dpeps,flxeps real, dimension(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy,kk) :: ztop,zbot real, dimension(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy,ddm) :: weights, @@ -3938,12 +3963,12 @@ subroutine diazlv(gridid,k,mm,nn,ind1,ind2,weights,weightsflx) c save ztop,zbot,dlevp,dlevu,dlevv,iniflg c -c --- Define thresholds - dzeps=1e1*epsil - dpeps=1e5*epsil - flxeps=1e5*epsil +c --- Define thresholds + dzeps=1e1*epsilp + dpeps=1e5*epsilp + flxeps=1e5*epsilp c -c --- Sort out stuff related to time stepping +c --- Sort out stuff related to time stepping km=k+mm kn=k+nn k1m=1+mm @@ -3978,7 +4003,7 @@ subroutine diazlv(gridid,k,mm,nn,ind1,ind2,weights,weightsflx) endif c c -c --- Compute top and bottom depths of density layers +c --- Compute top and bottom depths of density layers if (k.eq.1) then if (gridid.eq.'p') then c$OMP PARALLEL DO PRIVATE(l,i,kl,kml) @@ -4087,7 +4112,7 @@ subroutine diazlv(gridid,k,mm,nn,ind1,ind2,weights,weightsflx) endif endif c -c --- Compute interpolation weights +c --- Compute interpolation weights if (gridid.eq.'p') then c$OMP PARALLEL DO PRIVATE(l,i,d) do j=1,jj @@ -4114,7 +4139,7 @@ subroutine diazlv(gridid,k,mm,nn,ind1,ind2,weights,weightsflx) c$OMP END PARALLEL DO c elseif (gridid.eq.'u') then -c$OMP PARALLEL DO PRIVATE(l,i,d,r) +c$OMP PARALLEL DO PRIVATE(l,i,d,r) do j=1,jj do l=1,isu(j) do i=max(1,ifu(j,l)),min(ii+1,ilu(j,l)) @@ -4184,19 +4209,19 @@ subroutine inih2d(pos,gridid,inival) c c --- ------------------------------------------------------------------ c --- Description: initialise 2d diagnostic field -c --- +c --- c --- Arguments: -c --- int pos (in) : position in common buffer +c --- int pos (in) : position in common buffer c --- char gridid (in) : grid identifier ('p','u' or 'v') c --- real inival (in) : value used for initalisation c --- ------------------------------------------------------------------ c implicit none -c +c integer :: pos real :: inival character :: gridid -c +c integer :: i,j c c --- Check whether field should be initialised @@ -4244,19 +4269,19 @@ subroutine inilyr(pos,gridid,inival) c c --- ------------------------------------------------------------------ c --- Description: initialise layer diagnostic field -c --- +c --- c --- Arguments: -c --- int pos (in) : position in common buffer +c --- int pos (in) : position in common buffer c --- char gridid (in) : grid identifier ('p','u' or 'v') c --- real inival (in) : value used for initalisation c --- ------------------------------------------------------------------ c implicit none -c +c integer :: pos real :: inival character :: gridid -c +c integer :: i,j,k c c --- Check whether field should be initialised @@ -4265,7 +4290,7 @@ subroutine inilyr(pos,gridid,inival) if (gridid(1:1).eq.'u') then c$OMP PARALLEL DO PRIVATE(k,i) do j=1-nbdy,jj+nbdy - do k=1,kk + do k=1,kk do i=1-nbdy,ii+nbdy phylyr(i,j,k,pos)=inival*iu(i,j) enddo @@ -4275,7 +4300,7 @@ subroutine inilyr(pos,gridid,inival) elseif (gridid(1:1).eq.'v') then c$OMP PARALLEL DO PRIVATE(k,i) do j=1-nbdy,jj+nbdy - do k=1,kk + do k=1,kk do i=1-nbdy,ii+nbdy phylyr(i,j,k,pos)=inival*iv(i,j) enddo @@ -4285,7 +4310,7 @@ subroutine inilyr(pos,gridid,inival) elseif (gridid(1:1).eq.'p') then c$OMP PARALLEL DO PRIVATE(k,i) do j=1-nbdy,jj+nbdy - do k=1,kk + do k=1,kk do i=1-nbdy,ii+nbdy phylyr(i,j,k,pos)=inival*ip(i,j) enddo @@ -4295,7 +4320,7 @@ subroutine inilyr(pos,gridid,inival) else c$OMP PARALLEL DO PRIVATE(k,i) do j=1-nbdy,jj+nbdy - do k=1,kk + do k=1,kk do i=1-nbdy,ii+nbdy phylyr(i,j,k,pos)=inival enddo @@ -4312,19 +4337,19 @@ subroutine inilvl(pos,gridid,inival) c c --- ------------------------------------------------------------------ c --- Description: initialise level diagnostic field -c --- +c --- c --- Arguments: -c --- int pos (in) : position in common buffer +c --- int pos (in) : position in common buffer c --- char gridid (in) : grid identifier ('p','u' or 'v') c --- real inival (in) : value used for initalisation c --- ------------------------------------------------------------------ c implicit none -c +c integer :: pos real :: inival character :: gridid -c +c integer :: i,j,k c c --- Check whether field should be initialised @@ -4379,22 +4404,22 @@ end subroutine inilvl subroutine acch2d(pos,fld,wghts,wghtsflg,gridid) c c --- ------------------------------------------------------------------ -c --- Description: accumulate 2d fields -c --- -c --- Arguments: -c --- int pos (in) : position in 2d buffer +c --- Description: accumulate 2d fields +c --- +c --- Arguments: +c --- int pos (in) : position in 2d buffer c --- real fld (in) : input data used for accumulation c --- real wghts (in) : weights used for accumulation -c --- int wghtsflg (in) : weights flag (0=no weighting) +c --- int wghtsflg (in) : weights flag (0=no weighting) c --- char gridid (in) : grid identifier ('p','u' or 'v') c --- ------------------------------------------------------------------ c implicit none -c +c integer :: pos(nphymax),wghtsflg real, dimension(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy) :: fld,wghts character :: gridid -c +c integer :: i,j,l,o c c --- Check whether field should be accumulated @@ -4402,7 +4427,7 @@ subroutine acch2d(pos,fld,wghts,wghtsflg,gridid) if (pos(o).eq.0) cycle c if (gridid.eq.'u') then - if (wghtsflg.eq.0) then + if (wghtsflg.eq.0) then c$OMP PARALLEL DO PRIVATE(l,i) do j=1,jj do l=1,isu(j) @@ -4423,9 +4448,9 @@ subroutine acch2d(pos,fld,wghts,wghtsflg,gridid) enddo enddo c$OMP END PARALLEL DO - endif + endif elseif (gridid.eq.'v') then - if (wghtsflg.eq.0) then + if (wghtsflg.eq.0) then c$OMP PARALLEL DO PRIVATE(l,i) do j=1,jj do l=1,isv(j) @@ -4446,9 +4471,9 @@ subroutine acch2d(pos,fld,wghts,wghtsflg,gridid) enddo enddo c$OMP END PARALLEL DO - endif + endif elseif (gridid.eq.'p') then - if (wghtsflg.eq.0) then + if (wghtsflg.eq.0) then c$OMP PARALLEL DO PRIVATE(l,i) do j=1,jj do l=1,isp(j) @@ -4469,7 +4494,7 @@ subroutine acch2d(pos,fld,wghts,wghtsflg,gridid) enddo enddo c$OMP END PARALLEL DO - endif + endif else write (lp,*) 'cannot identify grid '//gridid//'!' call xchalt('(acch2d)') @@ -4477,7 +4502,7 @@ subroutine acch2d(pos,fld,wghts,wghtsflg,gridid) endif c enddo -c +c end subroutine acch2d @@ -4485,20 +4510,20 @@ end subroutine acch2d subroutine maxh2d(pos,fld,gridid) c c --- ------------------------------------------------------------------ -c --- Description: store maximum of 2d fields -c --- -c --- Arguments: -c --- int pos (in) : position in 2d buffer +c --- Description: store maximum of 2d fields +c --- +c --- Arguments: +c --- int pos (in) : position in 2d buffer c --- real fld (in) : input data used for finding maximum c --- char gridid (in) : grid identifier ('p','u' or 'v') c --- ------------------------------------------------------------------ c implicit none -c +c integer :: pos(nphymax) real, dimension(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy) :: fld character :: gridid -c +c integer :: i,j,l,o c c --- Check whether maximum of field should be stored @@ -4542,7 +4567,7 @@ subroutine maxh2d(pos,fld,gridid) endif c enddo -c +c end subroutine maxh2d @@ -4550,20 +4575,20 @@ end subroutine maxh2d subroutine minh2d(pos,fld,gridid) c c --- ------------------------------------------------------------------ -c --- Description: store minimum of 2d fields -c --- -c --- Arguments: -c --- int pos (in) : position in 2d buffer +c --- Description: store minimum of 2d fields +c --- +c --- Arguments: +c --- int pos (in) : position in 2d buffer c --- real fld (in) : input data used for finding minimum c --- char gridid (in) : grid identifier ('p','u' or 'v') c --- ------------------------------------------------------------------ c implicit none -c +c integer :: pos(nphymax) real, dimension(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy) :: fld character :: gridid -c +c integer :: i,j,l,o c c --- Check whether minimum of field should be stored @@ -4607,7 +4632,7 @@ subroutine minh2d(pos,fld,gridid) endif c enddo -c +c end subroutine minh2d @@ -4615,20 +4640,20 @@ end subroutine minh2d subroutine sqh2d(pos,fld,gridid) c c --- ------------------------------------------------------------------ -c --- Description: accumulate square of 2d fields -c --- -c --- Arguments: -c --- int pos (in) : position in 2d buffer +c --- Description: accumulate square of 2d fields +c --- +c --- Arguments: +c --- int pos (in) : position in 2d buffer c --- real fld (in) : input data used for accumulation c --- char gridid (in) : grid identifier ('p','u' or 'v') c --- ------------------------------------------------------------------ c implicit none -c +c integer :: pos(nphymax) real, dimension(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy) :: fld character :: gridid -c +c integer :: i,j,l,o c c --- Check whether field should be accumulated @@ -4672,7 +4697,7 @@ subroutine sqh2d(pos,fld,gridid) endif c enddo -c +c end subroutine sqh2d @@ -4680,22 +4705,22 @@ end subroutine sqh2d subroutine acclyr(pos,fld,wghts,wghtsflg,gridid) c c --- ------------------------------------------------------------------ -c --- Description: accumulate layer fields -c --- -c --- Arguments: -c --- int pos (in) : position in 3d layer buffer +c --- Description: accumulate layer fields +c --- +c --- Arguments: +c --- int pos (in) : position in 3d layer buffer c --- real fld (in) : input data used for accumulation c --- real wghts (in) : weights used for accumulation -c --- int wghtsflg (in) : weights flag (0=no weighting) +c --- int wghtsflg (in) : weights flag (0=no weighting) c --- char gridid (in) : grid identifier ('p','u' or 'v') c --- ------------------------------------------------------------------ c implicit none -c +c integer :: pos(nphymax),wghtsflg real, dimension(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy,kdm) :: fld,wghts character :: gridid -c +c integer :: i,j,k,l,o c c --- Check whether field should be accumulated @@ -4703,7 +4728,7 @@ subroutine acclyr(pos,fld,wghts,wghtsflg,gridid) if (pos(o).eq.0) cycle c if (gridid.eq.'u') then - if (wghtsflg.eq.0) then + if (wghtsflg.eq.0) then c$OMP PARALLEL DO PRIVATE(k,l,i) do j=1,jj do k=1,kk @@ -4721,16 +4746,16 @@ subroutine acclyr(pos,fld,wghts,wghtsflg,gridid) do k=1,kk do l=1,isu(j) do i=max(1,ifu(j,l)),min(ii,ilu(j,l)) - phylyr(i,j,k,pos(o))=phylyr(i,j,k,pos(o))+fld(i,j,k) - . *wghts(i,j,k) + phylyr(i,j,k,pos(o))=phylyr(i,j,k,pos(o)) + . +fld(i,j,k)*wghts(i,j,k) enddo enddo enddo enddo c$OMP END PARALLEL DO - endif + endif elseif (gridid.eq.'v') then - if (wghtsflg.eq.0) then + if (wghtsflg.eq.0) then c$OMP PARALLEL DO PRIVATE(k,l,i) do j=1,jj do k=1,kk @@ -4748,16 +4773,16 @@ subroutine acclyr(pos,fld,wghts,wghtsflg,gridid) do k=1,kk do l=1,isv(j) do i=max(1,ifv(j,l)),min(ii,ilv(j,l)) - phylyr(i,j,k,pos(o))=phylyr(i,j,k,pos(o))+fld(i,j,k) - . *wghts(i,j,k) + phylyr(i,j,k,pos(o))=phylyr(i,j,k,pos(o)) + . +fld(i,j,k)*wghts(i,j,k) enddo enddo enddo enddo c$OMP END PARALLEL DO - endif + endif elseif (gridid.eq.'p') then - if (wghtsflg.eq.0) then + if (wghtsflg.eq.0) then c$OMP PARALLEL DO PRIVATE(k,l,i) do j=1,jj do k=1,kk @@ -4775,14 +4800,14 @@ subroutine acclyr(pos,fld,wghts,wghtsflg,gridid) do k=1,kk do l=1,isp(j) do i=max(1,ifp(j,l)),min(ii,ilp(j,l)) - phylyr(i,j,k,pos(o))=phylyr(i,j,k,pos(o))+fld(i,j,k) - . *wghts(i,j,k) + phylyr(i,j,k,pos(o))=phylyr(i,j,k,pos(o)) + . +fld(i,j,k)*wghts(i,j,k) enddo enddo enddo enddo c$OMP END PARALLEL DO - endif + endif else write (lp,*) 'cannot identify grid '//gridid//'!' call xchalt('(acclyr)') @@ -4790,38 +4815,164 @@ subroutine acclyr(pos,fld,wghts,wghtsflg,gridid) endif c enddo -c +c end subroutine acclyr + subroutine accily(pos,fld,wghts,wghtsflg,gridid) +c +c --- ------------------------------------------------------------------ +c --- Description: accumulate interface fields after interpolation to +c --- layers +c --- +c --- Arguments: +c --- int pos (in) : position in 3d layer buffer +c --- real fld (in) : input data used for accumulation +c --- real wghts (in) : weights used for accumulation +c --- int wghtsflg (in) : weights flag (0=no weighting) +c --- char gridid (in) : grid identifier ('p','u' or 'v') +c --- ------------------------------------------------------------------ +c + implicit none +c + integer :: pos(nphymax),wghtsflg + real, dimension(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy,kdm+1) :: fld + real, dimension(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy,kdm) :: wghts + character :: gridid +c + integer :: i,j,k,l,o +c +c --- Check whether field should be accumulated + do o=1,nphy + if (pos(o).eq.0) cycle +c + if (gridid.eq.'u') then + if (wghtsflg.eq.0) then +c$OMP PARALLEL DO PRIVATE(k,l,i) + do j=1,jj + do k=1,kk + do l=1,isu(j) + do i=max(1,ifu(j,l)),min(ii,ilu(j,l)) + phylyr(i,j,k,pos(o))=phylyr(i,j,k,pos(o)) + . +.5*(fld(i,j,k)+fld(i,j,k+1)) + enddo + enddo + enddo + enddo +c$OMP END PARALLEL DO + else +c$OMP PARALLEL DO PRIVATE(k,l,i) + do j=1,jj + do k=1,kk + do l=1,isu(j) + do i=max(1,ifu(j,l)),min(ii,ilu(j,l)) + phylyr(i,j,k,pos(o))=phylyr(i,j,k,pos(o)) + . +.5*(fld(i,j,k)+fld(i,j,k+1)) + . *wghts(i,j,k) + enddo + enddo + enddo + enddo +c$OMP END PARALLEL DO + endif + elseif (gridid.eq.'v') then + if (wghtsflg.eq.0) then +c$OMP PARALLEL DO PRIVATE(k,l,i) + do j=1,jj + do k=1,kk + do l=1,isv(j) + do i=max(1,ifv(j,l)),min(ii,ilv(j,l)) + phylyr(i,j,k,pos(o))=phylyr(i,j,k,pos(o)) + . +.5*(fld(i,j,k)+fld(i,j,k+1)) + enddo + enddo + enddo + enddo +c$OMP END PARALLEL DO + else +c$OMP PARALLEL DO PRIVATE(k,l,i) + do j=1,jj + do k=1,kk + do l=1,isv(j) + do i=max(1,ifv(j,l)),min(ii,ilv(j,l)) + phylyr(i,j,k,pos(o))=phylyr(i,j,k,pos(o)) + . +.5*(fld(i,j,k)+fld(i,j,k+1)) + . *wghts(i,j,k) + enddo + enddo + enddo + enddo +c$OMP END PARALLEL DO + endif + elseif (gridid.eq.'p') then + if (wghtsflg.eq.0) then +c$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)) + phylyr(i,j,k,pos(o))=phylyr(i,j,k,pos(o)) + . +.5*(fld(i,j,k)+fld(i,j,k+1)) + enddo + enddo + enddo + enddo +c$OMP END PARALLEL DO + else +c$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)) + phylyr(i,j,k,pos(o))=phylyr(i,j,k,pos(o)) + . +.5*(fld(i,j,k)+fld(i,j,k+1)) + . *wghts(i,j,k) + enddo + enddo + enddo + enddo +c$OMP END PARALLEL DO + endif + else + write (lp,*) 'cannot identify grid '//gridid//'!' + call xchalt('(accily)') + stop '(accily)' + endif +c + enddo +c + end subroutine accily + + + subroutine acclvl(pos,fld,gridid,k,ind1,ind2,wghts) c c --- ------------------------------------------------------------------ -c --- Description: accumulate 3d level fields -c --- -c --- Arguments: -c --- int pos (in) : position in buffer +c --- Description: accumulate layer fields mapped to levels +c --- +c --- Arguments: +c --- int pos (in) : position in buffer c --- real fld (in) : input data used for accumulation c --- char gridid (in) : grid identifier ('p','u' or 'v') -c --- int k (in) : layer index of fld -c --- int ind1 (in) : index field for first accumulated level -c --- int ind2 (in) : index field for last accumulated level +c --- int k (in) : layer index of fld +c --- int ind1 (in) : index field for first accumulated level +c --- int ind2 (in) : index field for last accumulated level c --- real wghts (in) : weights used for accumulation c --- ------------------------------------------------------------------ c implicit none -c +c integer :: pos(nphymax),k integer, dimension(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy) :: ind1,ind2 real, dimension(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy,ddm) :: wghts real, dimension(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy,kdm) :: fld character :: gridid -c +c integer :: d,i,j,l,o c c --- Check whether field should be accumulated - do o=1,nphy + do o=1,nphy if (pos(o).eq.0) cycle c if (gridid.eq.'u') then @@ -4830,8 +4981,8 @@ subroutine acclvl(pos,fld,gridid,k,ind1,ind2,wghts) do l=1,isu(j) do i=max(1,ifu(j,l)),min(ii+1,ilu(j,l)) do d=ind1(i,j),ind2(i,j) - phylvl(i,j,d,pos(o))=phylvl(i,j,d,pos(o))+ - . fld(i,j,k)*wghts(i,j,d) + phylvl(i,j,d,pos(o))=phylvl(i,j,d,pos(o)) + . +fld(i,j,k)*wghts(i,j,d) enddo enddo enddo @@ -4843,8 +4994,8 @@ subroutine acclvl(pos,fld,gridid,k,ind1,ind2,wghts) do l=1,isv(j) do i=max(1,ifv(j,l)),min(ii,ilv(j,l)) do d=ind1(i,j),ind2(i,j) - phylvl(i,j,d,pos(o))=phylvl(i,j,d,pos(o))+ - . fld(i,j,k)*wghts(i,j,d) + phylvl(i,j,d,pos(o))=phylvl(i,j,d,pos(o)) + . +fld(i,j,k)*wghts(i,j,d) enddo enddo enddo @@ -4856,8 +5007,8 @@ subroutine acclvl(pos,fld,gridid,k,ind1,ind2,wghts) do l=1,isp(j) do i=max(1,ifp(j,l)),min(ii,ilp(j,l)) do d=ind1(i,j),ind2(i,j) - phylvl(i,j,d,pos(o))=phylvl(i,j,d,pos(o))+ - . fld(i,j,k)*wghts(i,j,d) + phylvl(i,j,d,pos(o))=phylvl(i,j,d,pos(o)) + . +fld(i,j,k)*wghts(i,j,d) enddo enddo enddo @@ -4869,11 +5020,93 @@ subroutine acclvl(pos,fld,gridid,k,ind1,ind2,wghts) stop '(acclvl)' endif enddo -c +c end subroutine acclvl + subroutine accilv(pos,fld,gridid,k,ind1,ind2,wghts) +c +c --- ------------------------------------------------------------------ +c --- Description: accumulate interface fields mapped to levels +c --- +c --- Arguments: +c --- int pos (in) : position in buffer +c --- real fld (in) : input data used for accumulation +c --- char gridid (in) : grid identifier ('p','u' or 'v') +c --- int k (in) : layer index of fld +c --- int ind1 (in) : index field for first accumulated level +c --- int ind2 (in) : index field for last accumulated level +c --- real wghts (in) : weights used for accumulation +c --- ------------------------------------------------------------------ +c + implicit none +c + integer :: pos(nphymax),k + integer, dimension(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy) :: ind1,ind2 + real, dimension(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy,ddm) :: wghts + real, dimension(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy,kdm+1) :: fld + character :: gridid +c + integer :: d,i,j,l,o +c +c --- Check whether field should be accumulated + do o=1,nphy + if (pos(o).eq.0) cycle +c + if (gridid.eq.'u') then +c$OMP PARALLEL DO PRIVATE(l,i,d) + do j=1,jj + do l=1,isu(j) + do i=max(1,ifu(j,l)),min(ii+1,ilu(j,l)) + do d=ind1(i,j),ind2(i,j) + phylvl(i,j,d,pos(o))=phylvl(i,j,d,pos(o)) + . +.5*(fld(i,j,k)+fld(i,j,k+1)) + . *wghts(i,j,d) + enddo + enddo + enddo + enddo +c$OMP END PARALLEL DO + elseif (gridid.eq.'v') then +c$OMP PARALLEL DO PRIVATE(l,i,d) + do j=1,jj+1 + do l=1,isv(j) + do i=max(1,ifv(j,l)),min(ii,ilv(j,l)) + do d=ind1(i,j),ind2(i,j) + phylvl(i,j,d,pos(o))=phylvl(i,j,d,pos(o)) + . +.5*(fld(i,j,k)+fld(i,j,k+1)) + . *wghts(i,j,d) + enddo + enddo + enddo + enddo +c$OMP END PARALLEL DO + elseif (gridid(1:1).eq.'p') then +c$OMP PARALLEL DO PRIVATE(l,i,d) + do j=1,jj + do l=1,isp(j) + do i=max(1,ifp(j,l)),min(ii,ilp(j,l)) + do d=ind1(i,j),ind2(i,j) + phylvl(i,j,d,pos(o))=phylvl(i,j,d,pos(o)) + . +.5*(fld(i,j,k)+fld(i,j,k+1)) + . *wghts(i,j,d) + enddo + enddo + enddo + enddo +c$OMP END PARALLEL DO + else + write (lp,*) 'cannot identify grid '//gridid//'!' + call xchalt('(accilv)') + stop '(accilv)' + endif + enddo +c + end subroutine accilv + + + subroutine inifld(iogrp) c implicit none @@ -4885,8 +5118,6 @@ subroutine inifld(iogrp) call inih2d(ACC_UBFLXS(iogrp),'u',0.) call inih2d(ACC_ZTX(iogrp),'u',0.) call inih2d(ACC_TAUX(iogrp),'u',0.) - call inih2d(ACC_MXLU(iogrp),'u',0.) - call inih2d(ACC_MLDU(iogrp),'u',0.) call inih2d(ACC_UICE(iogrp),'u',0.) call inih2d(ACC_IVOLU(iogrp),'u',0.) c @@ -4894,8 +5125,6 @@ subroutine inifld(iogrp) call inih2d(ACC_VBFLXS(iogrp),'v',0.) call inih2d(ACC_MTY(iogrp),'v',0.) call inih2d(ACC_TAUY(iogrp),'v',0.) - call inih2d(ACC_MXLV(iogrp),'v',0.) - call inih2d(ACC_MLDV(iogrp),'v',0.) call inih2d(ACC_VICE(iogrp),'v',0.) call inih2d(ACC_IVOLV(iogrp),'v',0.) c @@ -4950,7 +5179,7 @@ subroutine inifld(iogrp) call inih2d(ACC_FICE(iogrp),'p',0.) call inih2d(ACC_TSRF(iogrp),'p',0.) call inih2d(ACC_TICE(iogrp),'p',0.) -c +c c --- initialisation of 3d layer fields call inilyr(ACC_UVEL(iogrp),'u',0.) call inilyr(ACC_DPU(iogrp),'u',0.) @@ -4980,6 +5209,9 @@ subroutine inifld(iogrp) call inilyr(ACC_DZ(iogrp),'p',0.) call inilyr(ACC_BFSQ(iogrp),'p',0.) call inilyr(ACC_DIFDIA(iogrp),'p',0.) + call inilyr(ACC_DIFVMO(iogrp),'p',0.) + call inilyr(ACC_DIFVHO(iogrp),'p',0.) + call inilyr(ACC_DIFVSO(iogrp),'p',0.) call inilyr(ACC_DIFINT(iogrp),'p',0.) call inilyr(ACC_DIFISO(iogrp),'p',0.) call inilyr(ACC_WFLX(iogrp),'p',0.) @@ -5014,6 +5246,9 @@ subroutine inifld(iogrp) c call inilvl(ACC_BFSQLVL(iogrp),'p',0.) call inilvl(ACC_DIFDIALVL(iogrp),'p',0.) + call inilvl(ACC_DIFVMOLVL(iogrp),'p',0.) + call inilvl(ACC_DIFVHOLVL(iogrp),'p',0.) + call inilvl(ACC_DIFVSOLVL(iogrp),'p',0.) call inilvl(ACC_DIFINTLVL(iogrp),'p',0.) call inilvl(ACC_DIFISOLVL(iogrp),'p',0.) call inilvl(ACC_DZLVL(iogrp),'p',0.) @@ -5028,25 +5263,25 @@ subroutine inifld(iogrp) #endif c end subroutine inifld - + subroutine finh2d(posacc,poswgt,gridid) c c --- ------------------------------------------------------------------ -c --- Description: finalise accumulation of weighted 2d fields -c --- +c --- Description: finalise accumulation of weighted 2d fields +c --- c --- Arguments: c --- real posacc (in) : position of accumulated field in buffer -c --- real poswgt (in) : position of accumulated weights +c --- real poswgt (in) : position of accumulated weights c --- char gridid (in) : grid identifier ('p','u' or 'v') c --- ------------------------------------------------------------------ c implicit none -c +c integer :: posacc,poswgt character :: gridid -c +c integer :: i,j,l real, parameter :: epsil=1e-11 c @@ -5091,27 +5326,27 @@ subroutine finh2d(posacc,poswgt,gridid) call xchalt('(finh2d)') stop '(finh2d)' endif -c +c end subroutine finh2d - + subroutine finlyr(posacc,poswgt,gridid) c c --- ------------------------------------------------------------------ -c --- Description: finalise accumulation of weighted 3d layer fields -c --- +c --- Description: finalise accumulation of weighted 3d layer fields +c --- c --- Arguments: c --- real posacc (in) : position of accumulated field in buffer -c --- real poswgt (in) : position of accumulated weights +c --- real poswgt (in) : position of accumulated weights c --- char gridid (in) : grid identifier ('p','u' or 'v') c --- ------------------------------------------------------------------ c implicit none -c +c integer :: posacc,poswgt character :: gridid -c +c integer :: i,j,k,l real, parameter :: epsil=1e-11 c @@ -5126,8 +5361,8 @@ subroutine finlyr(posacc,poswgt,gridid) do i=max(1,ifu(j,l)),min(ii,ilu(j,l)) if (phylyr(i,j,k,poswgt).gt.epsil) then phylyr(i,j,k,posacc)=phylyr(i,j,k,posacc)/ - . phylyr(i,j,k,poswgt) - else + . phylyr(i,j,k,poswgt) + else phylyr(i,j,k,posacc)=nf90_fill_double endif enddo @@ -5143,8 +5378,8 @@ subroutine finlyr(posacc,poswgt,gridid) do i=max(1,ifv(j,l)),min(ii,ilv(j,l)) if (phylyr(i,j,k,poswgt).gt.epsil) then phylyr(i,j,k,posacc)=phylyr(i,j,k,posacc)/ - . phylyr(i,j,k,poswgt) - else + . phylyr(i,j,k,poswgt) + else phylyr(i,j,k,posacc)=nf90_fill_double endif enddo @@ -5160,8 +5395,8 @@ subroutine finlyr(posacc,poswgt,gridid) do i=max(1,ifp(j,l)),min(ii,ilp(j,l)) if (phylyr(i,j,k,poswgt).gt.epsil) then phylyr(i,j,k,posacc)=phylyr(i,j,k,posacc)/ - . phylyr(i,j,k,poswgt) - else + . phylyr(i,j,k,poswgt) + else phylyr(i,j,k,posacc)=nf90_fill_double endif enddo @@ -5174,7 +5409,7 @@ subroutine finlyr(posacc,poswgt,gridid) call xchalt('(finlyr)') stop '(finlyr)' endif -c +c end subroutine finlyr @@ -5183,30 +5418,30 @@ subroutine wrth2d(pos,frmt,sfac,offs,cmpflg,msk,gridid, . vnm,vlngnm,vstdnm,vunits) c c --- ------------------------------------------------------------------ -c --- Description: writes diagnostic 2d field to file -c --- +c --- Description: writes diagnostic 2d field to file +c --- c --- Arguments: c --- int pos (in) : variable position in common buffer -c --- int frmt (in) : format/precision of output -c --- 0=field is not written -c --- 2=field is written as int2 with scale -c --- factor and offset +c --- int frmt (in) : format/precision of output +c --- 0=field is not written +c --- 2=field is written as int2 with scale +c --- factor and offset c --- 4=field is written as real4 c --- 8=field is written as real8 -c --- real sfac (in) : user defined scale factor to be applied -c --- real offs (in) : user defined offset to be added -c --- int cmpflg (in) : compression flag; only wet points are -c --- written if flag is set to 1 -c --- int msk (in) ocean mask +c --- real sfac (in) : user defined scale factor to be applied +c --- real offs (in) : user defined offset to be added +c --- int cmpflg (in) : compression flag; only wet points are +c --- written if flag is set to 1 +c --- int msk (in) ocean mask c --- char gridid (in) : grid identifier ('p','u' or 'v') -c --- char vnm (in) : variable name used in nc-file -c --- char vlngnm (in) : variable long name (skipped if ' ') -c --- char vstdnm (in) : variable standard name (skipped if ' ') -c --- char vunits (in) : variable units (skipped if ' ') +c --- char vnm (in) : variable name used in nc-file +c --- char vlngnm (in) : variable long name (skipped if ' ') +c --- char vstdnm (in) : variable standard name (skipped if ' ') +c --- char vunits (in) : variable units (skipped if ' ') c --- ------------------------------------------------------------------ c implicit none -c +c real :: sfac,offs integer :: frmt,cmpflg,pos character(len=*) :: gridid,vnm,vlngnm,vstdnm,vunits @@ -5217,7 +5452,7 @@ subroutine wrth2d(pos,frmt,sfac,offs,cmpflg,msk,gridid, c --- Check whether field should be written if (frmt.eq.0) return c -c --- Create dimension string +c --- Create dimension string if (cmpflg.eq.1) then dims=gridid(1:1)//'comp time' else @@ -5271,30 +5506,30 @@ subroutine wrtlyr(pos,frmt,sfac,offs,cmpflg,msk,gridid, . vnm,vlngnm,vstdnm,vunits) c c --- ------------------------------------------------------------------ -c --- Description: writes diagnostic layer field to file -c --- +c --- Description: writes diagnostic layer field to file +c --- c --- Arguments: c --- int pos (in) : variable position in common buffer -c --- int frmt (in) : format/precision of output -c --- 0=field is not written -c --- 2=field is written as int2 with scale -c --- factor and offset +c --- int frmt (in) : format/precision of output +c --- 0=field is not written +c --- 2=field is written as int2 with scale +c --- factor and offset c --- 4=field is written as real4 c --- 8=field is written as real8 -c --- real sfac (in) : user defined scale factor to be applied -c --- real offs (in) : user defined offset to be added -c --- int cmpflg (in) : compression flag; only wet points are -c --- written if flag is set to 1 -c --- int msk (in) ocean mask +c --- real sfac (in) : user defined scale factor to be applied +c --- real offs (in) : user defined offset to be added +c --- int cmpflg (in) : compression flag; only wet points are +c --- written if flag is set to 1 +c --- int msk (in) ocean mask c --- char gridid (in) : grid identifier ('p','u' or 'v') -c --- char vnm (in) : variable name used in nc-file -c --- char vlngnm (in) : variable long name (skipped if ' ') -c --- char vstdnm (in) : variable standard name (skipped if ' ') -c --- char vunits (in) : variable units (skipped if ' ') +c --- char vnm (in) : variable name used in nc-file +c --- char vlngnm (in) : variable long name (skipped if ' ') +c --- char vstdnm (in) : variable standard name (skipped if ' ') +c --- char vunits (in) : variable units (skipped if ' ') c --- ------------------------------------------------------------------ c implicit none -c +c real :: sfac,offs integer :: frmt,cmpflg,pos character(len=*) :: gridid,vnm,vlngnm,vstdnm,vunits @@ -5305,7 +5540,7 @@ subroutine wrtlyr(pos,frmt,sfac,offs,cmpflg,msk,gridid, c --- Check whether field should be written if (frmt.eq.0) return c -c --- Create dimension string +c --- Create dimension string if (cmpflg.eq.1) then dims=gridid(1:1)//'comp sigma time' else @@ -5359,30 +5594,30 @@ subroutine wrtlvl(pos,frmt,sfac,offs,cmpflg,msk,gridid, . vnm,vlngnm,vstdnm,vunits) c c --- ------------------------------------------------------------------ -c --- Description: writes diagnostic level field to file -c --- +c --- Description: writes diagnostic level field to file +c --- c --- Arguments: c --- int pos (in) : variable position in common buffer -c --- int frmt (in) : format/precision of output -c --- 0=field is not written -c --- 2=field is written as int2 with scale -c --- factor and offset +c --- int frmt (in) : format/precision of output +c --- 0=field is not written +c --- 2=field is written as int2 with scale +c --- factor and offset c --- 4=field is written as real4 c --- 8=field is written as real8 -c --- real sfac (in) : user defined scale factor to be applied -c --- real offs (in) : user defined offset to be added -c --- int cmpflg (in) : compression flag; only wet points are -c --- written if flag is set to 1 -c --- int msk (in) ocean mask +c --- real sfac (in) : user defined scale factor to be applied +c --- real offs (in) : user defined offset to be added +c --- int cmpflg (in) : compression flag; only wet points are +c --- written if flag is set to 1 +c --- int msk (in) ocean mask c --- char gridid (in) : grid identifier ('p','u' or 'v') -c --- char vnm (in) : variable name used in nc-file -c --- char vlngnm (in) : variable long name (skipped if ' ') -c --- char vstdnm (in) : variable standard name (skipped if ' ') -c --- char vunits (in) : variable units (skipped if ' ') +c --- char vnm (in) : variable name used in nc-file +c --- char vlngnm (in) : variable long name (skipped if ' ') +c --- char vstdnm (in) : variable standard name (skipped if ' ') +c --- char vunits (in) : variable units (skipped if ' ') c --- ------------------------------------------------------------------ c implicit none -c +c real :: sfac,offs integer :: frmt,cmpflg,pos character(len=*) :: gridid,vnm,vlngnm,vstdnm,vunits @@ -5393,7 +5628,7 @@ subroutine wrtlvl(pos,frmt,sfac,offs,cmpflg,msk,gridid, c --- Check whether field should be written if (frmt.eq.0) return c -c --- Create dimension string +c --- Create dimension string if (cmpflg.eq.1) then dims=gridid//'comp depth time' else @@ -5446,21 +5681,21 @@ end subroutine wrtlvl subroutine logh2d(pos,gridid,sfac,offs) c c --- ------------------------------------------------------------------ -c --- Description: replace 2d field with log10(field) -c --- +c --- Description: replace 2d field with log10(field) +c --- c --- Arguments: -c --- int pos (in) : field position in layer buffer +c --- int pos (in) : field position in layer buffer c --- char gridid (in) : grid identifier ('p','u' or 'v') -c --- real sfac (in) : scale factor to be applied before log10 -c --- real offs (in) : offset to be added before log10 +c --- real sfac (in) : scale factor to be applied before log10 +c --- real offs (in) : offset to be added before log10 c --- ------------------------------------------------------------------ c implicit none -c +c real :: sfac,offs integer :: pos character :: gridid -c +c integer :: i,j,l real :: epsil=1e-11 c @@ -5521,21 +5756,21 @@ end subroutine logh2d subroutine loglyr(pos,gridid,sfac,offs) c c --- ------------------------------------------------------------------ -c --- Description: replace 3d layer field with log10(field) -c --- +c --- Description: replace 3d layer field with log10(field) +c --- c --- Arguments: -c --- int pos (in) : field position in layer buffer +c --- int pos (in) : field position in layer buffer c --- char gridid (in) : grid identifier ('p','u' or 'v') -c --- real sfac (in) : scale factor to be applied before log10 -c --- real offs (in) : offset to be added before log10 +c --- real sfac (in) : scale factor to be applied before log10 +c --- real offs (in) : offset to be added before log10 c --- ------------------------------------------------------------------ c implicit none -c +c real :: sfac,offs integer :: pos character :: gridid -c +c integer :: i,j,k,l real :: epsil=1e-11 c @@ -5602,21 +5837,21 @@ end subroutine loglyr subroutine loglvl(pos,gridid,sfac,offs) c c --- ------------------------------------------------------------------ -c --- Description: replace 3d level field with log10(field) -c --- +c --- Description: replace 3d level field with log10(field) +c --- c --- Arguments: -c --- int pos (in) : field position in layer buffer +c --- int pos (in) : field position in layer buffer c --- char gridid (in) : grid identifier ('p','u' or 'v') -c --- real sfac (in) : scale factor to be applied before log10 -c --- real offs (in) : offset to be added before log10 +c --- real sfac (in) : scale factor to be applied before log10 +c --- real offs (in) : offset to be added before log10 c --- ------------------------------------------------------------------ c implicit none -c +c real :: sfac,offs integer :: pos character :: gridid -c +c integer :: i,j,k,l real :: epsil=1e-11 c @@ -5683,10 +5918,10 @@ end subroutine loglvl subroutine msklvl(pos,gridid) c c --- ------------------------------------------------------------------ -c --- Description: set sea floor points to NaN in level fields -c --- +c --- Description: set sea floor points to NaN in level fields +c --- c --- Arguments: -c --- int pos (in) : field position in level buffer +c --- int pos (in) : field position in level buffer c --- char gridid (in) : grid identifier ('p','u' or 'v') c --- ------------------------------------------------------------------ c @@ -5694,14 +5929,14 @@ subroutine msklvl(pos,gridid) c integer :: pos character :: gridid -c +c integer :: i,j,k logical :: iniflg=.true. integer, dimension(idm,jdm) :: kmaxu,kmaxv,kmaxp real, parameter :: mskval=nf90_fill_double c save iniflg,kmaxu,kmaxv,kmaxp -c +c c --- Check whether field should be processed if (pos.eq.0) return c @@ -5972,12 +6207,6 @@ subroutine definevar(irec,iogrp,cmpflg,timeunits,calendar) c call ncdefvar3d(H2D_MLD(iogrp),cmpflg,'p','mld', . 'Mixed layer depth',' ','m',0) -c - call ncdefvar3d(H2D_MLDU(iogrp),cmpflg,'u','mldu', - . 'Mixed layer depth at u-point',' ','m',0) -c - call ncdefvar3d(H2D_MLDV(iogrp),cmpflg,'v','mldv', - . 'Mixed layer depth at v-point',' ','m',0) c call ncdefvar3d(H2D_MAXMLD(iogrp),cmpflg,'p','maxmld', . 'Maximum mixed layer depth',' ','m',0) @@ -6018,12 +6247,6 @@ subroutine definevar(irec,iogrp,cmpflg,timeunits,calendar) c call ncdefvar3d(H2D_TBOT(iogrp),cmpflg,'p','tbot', . 'Bottom temperature',' ','degC',0) -c - call ncdefvar3d(H2D_MXLU(iogrp),cmpflg,'u','mxlu', - . 'Mixed layer velocity x-component',' ','m s-1',0) -c - call ncdefvar3d(H2D_MXLV(iogrp),cmpflg,'v','mxlv', - . 'Mixed layer velocity y-component',' ','m s-1',0) c c --- define 3d layer fields call ncdefvar3d(LYR_DP(iogrp),cmpflg,'p','dp', @@ -6132,13 +6355,37 @@ subroutine definevar(irec,iogrp,cmpflg,timeunits,calendar) c if (LYR_DIFDIA(iogrp).eq.2) then call ncdefvar3d(LYR_DIFDIA(iogrp),cmpflg,'p','difdia', - . 'Diapycnal diffusivity',' ','log10(m2 s-1)',1) + . 'Vertical diffusivity',' ','log10(m2 s-1)',1) else call ncdefvar3d(LYR_DIFDIA(iogrp),cmpflg,'p','difdia', - . 'Diapycnal diffusivity',' ','m2 s-1',1) + . 'Vertical diffusivity',' ','m2 s-1',1) endif c -#if defined TKE + if (LYR_DIFVMO(iogrp).eq.2) then + call ncdefvar3d(LYR_DIFVMO(iogrp),cmpflg,'p','difvmo', + . 'Vertical momentum diffusivity',' ','log10(m2 s-1)',1) + else + call ncdefvar3d(LYR_DIFVMO(iogrp),cmpflg,'p','difvmo', + . 'Vertical momentum diffusivity',' ','m2 s-1',1) + endif +c + if (LYR_DIFVHO(iogrp).eq.2) then + call ncdefvar3d(LYR_DIFVHO(iogrp),cmpflg,'p','difvho', + . 'Vertical heat diffusivity',' ','log10(m2 s-1)',1) + else + call ncdefvar3d(LYR_DIFVHO(iogrp),cmpflg,'p','difvho', + . 'Vertical heat diffusivity',' ','m2 s-1',1) + endif +c + if (LYR_DIFVSO(iogrp).eq.2) then + call ncdefvar3d(LYR_DIFVSO(iogrp),cmpflg,'p','difvso', + . 'Vertical salt diffusivity',' ','log10(m2 s-1)',1) + else + call ncdefvar3d(LYR_DIFVSO(iogrp),cmpflg,'p','difvso', + . 'Vertical salt diffusivity',' ','m2 s-1',1) + endif +c +#if defined TKE call ncdefvar3d(LYR_TKE(iogrp),cmpflg,'p','tke', . 'TKE','Turbulent kinetic energy','m2 s-2',1) @@ -6162,7 +6409,7 @@ subroutine definevar(irec,iogrp,cmpflg,timeunits,calendar) c call ncdefvar3d(LVL_VVEL(iogrp),cmpflg,'v','vvellvl', . 'Velocity y-component',' ','m s-1',2) -c +c call ncdefvar3d(LVL_UFLX(iogrp),cmpflg,'u','uflxlvl', . 'Mass flux in x-direction',' ','kg s-1',2) c @@ -6251,10 +6498,34 @@ subroutine definevar(irec,iogrp,cmpflg,timeunits,calendar) c if (LVL_DIFDIA(iogrp).eq.2) then call ncdefvar3d(LVL_DIFDIA(iogrp),cmpflg,'p','difdialvl', - . 'Diapycnal diffusivity',' ','log10(m2 s-1)',2) + . 'Vertical diffusivity',' ','log10(m2 s-1)',2) else call ncdefvar3d(LVL_DIFDIA(iogrp),cmpflg,'p','difdialvl', - . 'Diapycnal diffusivity',' ','m2 s-1',2) + . 'Vertical diffusivity',' ','m2 s-1',2) + endif +c + if (LVL_DIFVMO(iogrp).eq.2) then + call ncdefvar3d(LVL_DIFVMO(iogrp),cmpflg,'p','difvmolvl', + . 'Vertical momentum diffusivity',' ','log10(m2 s-1)',2) + else + call ncdefvar3d(LVL_DIFVMO(iogrp),cmpflg,'p','difvmolvl', + . 'Vertical momentum diffusivity',' ','m2 s-1',2) + endif +c + if (LVL_DIFVHO(iogrp).eq.2) then + call ncdefvar3d(LVL_DIFVHO(iogrp),cmpflg,'p','difvholvl', + . 'Vertical heat diffusivity',' ','log10(m2 s-1)',2) + else + call ncdefvar3d(LVL_DIFVHO(iogrp),cmpflg,'p','difvholvl', + . 'Vertical heat diffusivity',' ','m2 s-1',2) + endif +c + if (LVL_DIFVSO(iogrp).eq.2) then + call ncdefvar3d(LVL_DIFVSO(iogrp),cmpflg,'p','difvsolvl', + . 'Vertical salt diffusivity',' ','log10(m2 s-1)',2) + else + call ncdefvar3d(LVL_DIFVSO(iogrp),cmpflg,'p','difvsolvl', + . 'Vertical salt diffusivity',' ','m2 s-1',2) endif c #if defined(TRC) && defined(TKE) @@ -6266,7 +6537,7 @@ subroutine definevar(irec,iogrp,cmpflg,timeunits,calendar) c #endif c -c --- define meridional transports +c --- define meridional transports if (MSC_MMFLXL(iogrp).ne.0) then call ncdefvar('mmflxl','lat sigma region time',ndouble,8) call ncattr('long_name', @@ -6328,7 +6599,7 @@ subroutine definevar(irec,iogrp,cmpflg,timeunits,calendar) call ncattr('units','kg s-1') endif c -c --- store section transports +c --- store section transports if (MSC_VOLTR(iogrp).ne.0) then call ncdefvar('voltr','section time',ndouble,8) call ncattr('long_name','Section transports') @@ -6373,7 +6644,7 @@ subroutine definevar(irec,iogrp,cmpflg,timeunits,calendar) call ncdefvar3d(max(LYR_IDLAGE(iogrp),LYR_TRC(iogrp)),cmpflg, . 'p','dp_trc','Layer pressure thickness',' ','Pa',1) endif -c --- ideal age tracer +c --- ideal age tracer #if IDLAGE call ncdefvar3d(LYR_IDLAGE(iogrp),cmpflg,'p','idlage', . 'Ideal age','sea_water_age_since_surface_contact','year',1) diff --git a/phy/mod_difest.F b/phy/mod_difest.F new file mode 100644 index 00000000..67f0f486 --- /dev/null +++ b/phy/mod_difest.F @@ -0,0 +1,2588 @@ +! ------------------------------------------------------------------------------ +! Copyright (C) 2009-2022 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_difest +c + use mod_types, only: r8 + use mod_constants, only: g, alpha0, pi, epsilp, spval, onem, + . onecm, L_mks2cgs, M_mks2cgs, R_mks2cgs + use mod_time, only: delt1 + use mod_xc + use mod_vcoord, only: vcoord_type_tag, isopyc_bulkml, + . cntiso_hybrid, sigmar + use mod_grid, only: scpx, scpy, scp2, + . plat, coriop, betafp, cosang, sinang + use mod_eos, only: rho + use mod_state, only: u, v, dp, dpu, dpv, temp, saln, sigma, p, + . pbu, pbv, ubflxs_p, vbflxs_p, kfpla + use mod_diffusion, only: egc, eggam, eglsmn, egmndf, egmxdf, + . egidfq, ri0, bdmc1, bdmc2, tkepf, bdmtyp, + . edsprs, edritp_opt, edritp_shear, + . edritp_large_scale, edwmth_opt, + . edwmth_smooth, edwmth_step, + . difint, difiso, difdia, difmxp, difwgt, + . Kvisc_m, Kdiff_t, Kdiff_s, + . t_ns_nonloc, s_nonloc + use mod_cmnfld, only: bfsqi, nnslpx, nnslpy, mlts + use mod_forcing, only: ustar, ustarb, ustar3, buoyfl, t_sw_nonloc + . , surflx, sswflx, salflx + use mod_tidaldissip, only: twedon + use mod_niw, only: niwgf, niwbf, niwlf, idkedt, niw_ke_tendency + use mod_seaice, only: ficem + use mod_utility, only: util1 + use mod_checksum, only: csdiag, chksummsk + use CVMix_kpp, only : CVMix_coeffs_kpp + use CVMix_kpp, only : CVMix_kpp_compute_turbulent_scales + use CVMix_kpp, only : CVMix_kpp_compute_bulk_Richardson + use CVMix_kpp, only : CVMix_kpp_compute_OBL_depth + use CVMix_kpp, only : CVmix_kpp_compute_unresolved_shear + use CVMix_kpp, only : CVMix_kpp_compute_kOBL_depth + use CVMix_shear, only : CVMix_init_shear, CVMix_coeffs_shear + use CVMix_background, only : CVMix_init_bkgnd, CVMix_coeffs_bkgnd + use CVMix_convection, only : CVMix_init_conv, CVMix_coeffs_conv + use CVMix_tidal, only : CVMix_init_tidal, CVMix_coeffs_tidal + use CVMix_tidal, only : CVMix_compute_Simmons_invariant, + . CVMix_tidal_params_type + use CVMix_kinds_and_types, only : CVMix_global_params_type + use CVMix_kpp, only : CVMix_kpp_params_type + use CVMix_kpp, only : CVMix_put_kpp + use CVMix_kpp, only : CVMix_init_kpp + use CVMix_put_get, only : CVMix_put +#if defined(TRC) && defined(TKE) + use mod_tracers, only: itrtke, itrgls, trc + use mod_tke, only: gls_cmu0, Pr_t, tke_min, gls_psi_min, gls_p, + . gls_m, gls_n, gls_c1, gls_c2, gls_c3plus, + . gls_c3minus, gls_Gh0, gls_Ghmin, gls_Ghcri, + . Ls_unlmt_min, Prod, Buoy, Shear2, L_scale, + . gls_s0, gls_s1, gls_s2, gls_s4, gls_s5, gls_s6, + . gls_b0, gls_b1, gls_b2, gls_b3, gls_b4, gls_b5, + . sqrt2, cmu_fac1, cmu_fac2, cmu_fac3, tke_exp1, + . gls_exp1, gls_fac6 +#endif +c + implicit none +c + private +c +c Initialize hOBL with hOBL_static = 3. for consistency with bulk +c mixed layer formulation in iHAMOCC: kmle = nint(hOBL) - 1 = 2 + real, PARAMETER :: hOBL_static = 3. +c + real, dimension(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy,kdm+1) :: + . rig + real, dimension(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy,kdm) :: + . du2l,drhol,up,vp + real, dimension(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy) :: + . OBLdepth + real, dimension(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy) :: + . hOBL + integer, dimension(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy,kdm) :: + . mskv,msku + integer, dimension(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy) :: + . kmax,kfil +c + type(CVMix_tidal_params_type) :: CVMix_tidal_params + type(CVMix_global_params_type) :: CVMix_glb_params ! CVmix_kpp_params_user + call CVMix_init_kpp(Ri_crit=0.3, + . minOBLdepth=minOBLdepth, + . minVtsqr=1e-10, + . vonKarman=0.4, + . surf_layer_ext=0.1, + . interp_type='quadratic', + . interp_type2='LMD94', + . lEkman=.false., + . lMonOb=.false., + . MatchTechnique='SimpleShapes', + . lenhanced_diff=.true., + . lnonzero_surf_nonlocal=.false. , + . lnoDGat1=.true. , + . CVMix_kpp_params_user=KPP_params ) +c call CVMix_init_kpp(Ri_crit=0.3, +c . minOBLdepth=minOBLdepth, +c . minVtsqr=1e-10, +c . vonKarman=0.4, +c . surf_layer_ext=0.1, +c . interp_type='quadratic', +c . interp_type2='LMD94', +c . lEkman=.false., +c . lMonOb=.false., +c . MatchTechnique='MatchGradient', +c . lenhanced_diff=.true., +c . lnonzero_surf_nonlocal=.false. , +c . lnoDGat1=.false. , +c . CVMix_kpp_params_user=KPP_params ) +c call CVMix_init_kpp(Ri_crit=0.3, +c . minOBLdepth=minOBLdepth, +c . minVtsqr=1e-10, +c . vonKarman=0.4, +c . surf_layer_ext=0.1, +c . interp_type='quadratic', +c . interp_type2='LMD94', +c . lEkman=.false., +c . lMonOb=.false., +c . MatchTechnique='ParabolicNonLocal', +c . lenhanced_diff=.true., +c . lnonzero_surf_nonlocal=.true. , +c . lnoDGat1=.true. , +c . CVMix_kpp_params_user=KPP_params ) +c +c$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)) + OBLdepth(i,j)=10. + enddo + enddo + enddo +c$OMP END PARALLEL DO +c + end subroutine init_difest +c + subroutine difest_common_iso(m,n,mm,nn,k1m,k1n) +c +c --- ------------------------------------------------------------------ +c --- Obtain common fields for the estimation of lateral and vertical +c --- diffusivities diapycnal diffusivities when vcoord_type_tag == +c --- isopyc_bulkml. +c --- ------------------------------------------------------------------ +c + integer m,n,mm,nn,k1m,k1n +c + real, dimension(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy,kdm) :: dv2 + real, dimension(1-nbdy:idm+nbdy,kdm) :: du2 + real, dimension(1-nbdy:idm+nbdy) :: tup + integer, dimension(1-nbdy:idm+nbdy) :: kfpl,klpl + integer i,j,k,l,kn + real q +c +c --- Locate the range of layers to be considered in the computation of +c --- diffusivities. + do j=0,jj+1 + do i=0,ii+1 + kmax(i,j)=0 + enddo + do l=1,isp(j) + do i=max(0,ifp(j,l)),min(ii+1,ilp(j,l)) + kmax(i,j)=1 + do k=3,kk + kn=k+nn + if (dp(i,j,kn).gt.dpbmin) kmax(i,j)=k + enddo + if (kfpla(i,j,n).ge.kmax(i,j)) then + kfil(i,j)=kfpla(i,j,n)+1 + else + if (sigma(i,j,kfpla(i,j,n)+nn).lt. + . .5*(sigmar(i,j,kfpla(i,j,n) ) + . +sigmar(i,j,kfpla(i,j,n)+1))) then + kfil(i,j)=kfpla(i,j,n)+1 + else + kfil(i,j)=kfpla(i,j,n)+2 + endif + endif + enddo + enddo + enddo +c +c$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)) + util1(i,j)=kfil(i,j) + enddo + enddo + enddo +c$OMP END PARALLEL DO + call xctilr(util1, 1,1, 1,1, halo_ps) +c$OMP PARALLEL DO PRIVATE(l,i) + do j=0,jj+1 + do l=1,isp(j) + do i=max(0,ifp(j,l)),min(ii+1,ilp(j,l)) + kfil(i,j)=nint(util1(i,j)) + enddo + enddo + enddo +c$OMP END PARALLEL DO +c +c --- Compute squared vertical velocity difference of v-component +c$OMP PARALLEL DO PRIVATE(l,i,kfpl,klpl,k,kn,q,tup) + do j=1,jj+1 + do l=1,isv(j) + do i=max(1,ifv(j,l)),min(ii,ilv(j,l)) + kfpl(i)=kk+1 + klpl(i)=1 + enddo + enddo + do k=3,kk + kn=k+nn + do l=1,isv(j) + do i=max(1,ifv(j,l)),min(ii,ilv(j,l)) + if (dpv(i,j,kn).gt.dpbmin) klpl(i)=k + enddo + enddo + enddo + do k=kk,4,-1 + kn=k+nn + do l=1,isv(j) + do i=max(1,ifv(j,l)),min(ii,ilv(j,l)) + if (k.ge.max(kfil(i,j-1),kfil(i,j)).and. + . dpv(i,j,kn).gt.dptmin) kfpl(i)=k + enddo + enddo + enddo + do k=1,kk + kn=k+nn + do i=1,ii + dv2(i,j,k)=0. + mskv(i,j,k)=0 + enddo + do l=1,isv(j) + do i=max(1,ifv(j,l)),min(ii,ilv(j,l)) + if (k.ge.kfpl(i).and.k.le.klpl(i).and. + . klpl(i)-kfpl(i).ge.1) then + if (k.eq.kfpl(i)) then + q=v(i,j,kn+1)-v(i,j,kn) + q=q*q + dv2(i,j,k)=q + tup(i)=q + elseif (k.lt.klpl(i)) then + q=v(i,j,kn+1)-v(i,j,kn) + q=q*q + dv2(i,j,k)=.5*(tup(i)+q) + tup(i)=q + else + dv2(i,j,k)=tup(i) + endif + mskv(i,j,k)=1 + endif + enddo + enddo + enddo + enddo +c$OMP END PARALLEL DO +c +c$OMP PARALLEL DO PRIVATE(l,i,kfpl,klpl,k,kn,du2,q,tup) + do j=1,jj +c +c ----- Compute squared vertical velocity difference of u-component + do l=1,isu(j) + do i=max(1,ifu(j,l)),min(ii+1,ilu(j,l)) + kfpl(i)=kk+1 + klpl(i)=1 + enddo + enddo + do k=3,kk + kn=k+nn + do l=1,isu(j) + do i=max(1,ifu(j,l)),min(ii+1,ilu(j,l)) + if (dpu(i,j,kn).gt.dpbmin) klpl(i)=k + enddo + enddo + enddo + do k=kk,4,-1 + kn=k+nn + do l=1,isu(j) + do i=max(1,ifu(j,l)),min(ii+1,ilu(j,l)) + if (k.ge.min(kfil(i-1,j),kfil(i,j)).and. + . dpu(i,j,kn).gt.dptmin) kfpl(i)=k + enddo + enddo + enddo + do k=1,kk + kn=k+nn + do i=1,ii+1 + du2(i,k)=0. + msku(i,j,k)=0 + enddo + do l=1,isu(j) + do i=max(1,ifu(j,l)),min(ii+1,ilu(j,l)) + if (k.ge.kfpl(i).and.k.le.klpl(i).and. + . klpl(i)-kfpl(i).ge.1) then + if (k.eq.kfpl(i)) then + q=u(i,j,kn+1)-u(i,j,kn) + q=q*q + du2(i,k)=q + tup(i)=q + elseif (k.lt.klpl(i)) then + q=u(i,j,kn+1)-u(i,j,kn) + q=q*q + du2(i,k)=.5*(tup(i)+q) + tup(i)=q + else + du2(i,k)=tup(i) + endif + msku(i,j,k)=1 + endif + enddo + enddo + enddo +c +c --- - Centered at layers, compute vertical in-situ density difference, +c --- - squared vertical velocity difference and local gradient +c --- - Richardson number. + do k=4,kk + kn=k+nn + do l=1,isp(j) + do i=max(1,ifp(j,l)),min(ii,ilp(j,l)) + if (k.ge.kfil(i,j).and.k.le.kmax(i,j).and. + . kmax(i,j)-kfil(i,j).ge.1) then +c +c --- ------- Vertical in-situ density difference. + if (k.eq.kfil(i,j)) then + q=max(0.,rho(p(i,j,k+1),temp(i,j,kn+1),saln(i,j,kn+1)) + . -rho(p(i,j,k+1),temp(i,j,kn ),saln(i,j,kn ))) + drhol(i,j,k)=q + tup(i)=q + elseif (k.lt.kmax(i,j)) then + q=max(0.,rho(p(i,j,k+1),temp(i,j,kn+1),saln(i,j,kn+1)) + . -rho(p(i,j,k+1),temp(i,j,kn ),saln(i,j,kn ))) + drhol(i,j,k)=2.*tup(i)*q/max(1.e-11*R_mks2cgs,tup(i)+q) + tup(i)=q + else + drhol(i,j,k)=tup(i) + endif +c +c --- ------- Vertical squared velocity difference. + du2l(i,j,k)=(msku(i ,j,k)*du2(i ,k) + . +msku(i+1,j,k)*du2(i+1,k)) + . /max(1,msku(i,j,k)+msku(i+1,j,k)) + . +(mskv(i,j ,k)*dv2(i,j ,k) + . +mskv(i,j+1,k)*dv2(i,j+1,k)) + . /max(1,mskv(i,j,k)+mskv(i,j+1,k)) +c +c --- ------- Local gradient Richardson number. + rig(i,j,k)=alpha0*alpha0 + . *max(drhomn,drhol(i,j,k))*dp(i,j,kn) + . /max(1.e-13*A_mks2cgs,du2l(i,j,k)) +c + endif + enddo + enddo + enddo +c + enddo +c + if (csdiag) then + if (mnproc.eq.1) then + write (lp,*) 'difest_common_iso:' + endif + call chksummsk(drhol,ip,kk,'drhol') + call chksummsk(du2l,ip,kk,'du2l') + call chksummsk(rig,ip,kk,'rig') + endif +c + end subroutine difest_common_iso +c + subroutine difest_common_hyb(m,n,mm,nn,k1m,k1n) +c +c --- ------------------------------------------------------------------ +c --- Obtain common fields for the estimation of lateral and vertical +c --- diffusivities diapycnal diffusivities when vcoord_type_tag == +c --- isopyc_bulkml. +c --- ------------------------------------------------------------------ +c + integer m,n,mm,nn,k1m,k1n +c + real, dimension(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy,kdm) :: dv2 + real, dimension(1-nbdy:idm+nbdy,kdm) :: du2 + integer, dimension(1-nbdy:idm+nbdy) :: klpl + integer i,j,k,l,kn + real q,dz +c +c --- Compute squared vertical velocity difference of v-component +c$OMP PARALLEL DO PRIVATE(l,i,klpl,k,kn,q) + do j=1,jj+1 + do l=1,isv(j) + do i=max(1,ifv(j,l)),min(ii,ilv(j,l)) + klpl(i)=1 + enddo + enddo + do k=2,kk + kn=k+nn + do l=1,isv(j) + do i=max(1,ifv(j,l)),min(ii,ilv(j,l)) + if (dpv(i,j,kn).gt.dpbmin) klpl(i)=k + enddo + enddo + enddo + do k=2,kk + do i=1,ii + dv2(i,j,k)=0. + mskv(i,j,k)=0 + enddo + kn=k+nn + do l=1,isv(j) + do i=max(1,ifv(j,l)),min(ii,ilv(j,l)) + if (klpl(i).ge.2.and.k.le.klpl(i)) then + q=v(i,j,kn)-v(i,j,kn-1) + dv2(i,j,k)=q*q + mskv(i,j,k)=1 + endif + enddo + enddo + enddo + enddo +c$OMP END PARALLEL DO +c +c$OMP PARALLEL DO PRIVATE(l,i,klpl,k,kn,du2,q,dz) + do j=1,jj +c +c ----- Compute squared vertical velocity difference of u-component + do l=1,isu(j) + do i=max(1,ifu(j,l)),min(ii+1,ilu(j,l)) + klpl(i)=1 + enddo + enddo + do k=2,kk + kn=k+nn + do l=1,isu(j) + do i=max(1,ifu(j,l)),min(ii+1,ilu(j,l)) + if (dpu(i,j,kn).gt.dpbmin) klpl(i)=k + enddo + enddo + enddo + do k=2,kk + do i=1,ii+1 + du2(i,k)=0. + msku(i,j,k)=0 + enddo + kn=k+nn + do l=1,isu(j) + do i=max(1,ifu(j,l)),min(ii+1,ilu(j,l)) + if (klpl(i).ge.2.and.k.le.klpl(i)) then + q=u(i,j,kn)-u(i,j,kn-1) + du2(i,k)=q*q + msku(i,j,k)=1 + endif + enddo + enddo + enddo +c +c --- - Compute local gradient Richardson number at interfaces. + do l=1,isp(j) + do i=max(1,ifp(j,l)),min(ii,ilp(j,l)) + rig(i,j,1)=0. + enddo + enddo + do k=2,kk + kn=k+nn + do l=1,isp(j) + do i=max(1,ifp(j,l)),min(ii,ilp(j,l)) + if (msku(i,j,k)+msku(i+1,j,k) + . +mskv(i,j,k)+mskv(i,j+1,k).gt.0) then + q=(msku(i,j,k)*du2(i,k) +msku(i+1,j,k)*du2(i+1,k)) + . /max(1,msku(i,j,k)+msku(i+1,j,k)) + . +(mskv(i,j,k)*dv2(i,j,k)+mskv(i,j+1,k)*dv2(i,j+1,k)) + . /max(1,mskv(i,j,k)+mskv(i,j+1,k)) + dz=.5*(dp(i,j,kn-1)+dp(i,j,kn))*alpha0/g + rig(i,j,k)=max(0.,bfsqi(i,j,k)*dz*dz) + . /max(1.e-13*A_mks2cgs,q) + else + rig(i,j,k)=rig(i,j,k-1) + endif + enddo + enddo + enddo + do l=1,isp(j) + do i=max(1,ifp(j,l)),min(ii,ilp(j,l)) + rig(i,j,1)=rig(i,j,2) + rig(i,j,kk+1)=rig(i,j,kk) + enddo + enddo +c +c --- - Compute velocity components at p-points. + do k=1,kk + kn=k+nn + do l=1,isp(j) + do i=max(1,ifp(j,l)),min(ii,ilp(j,l)) + up(i,j,k)=(msku(i,j,k)*u(i,j,kn)+msku(i+1,j,k)*u(i+1,j,kn)) + . /max(1,msku(i,j,k)+msku(i+1,j,k)) + vp(i,j,k)=(mskv(i,j,k)*v(i,j,kn)+mskv(i,j+1,k)*v(i,j+1,kn)) + . /max(1,mskv(i,j,k)+mskv(i,j+1,k)) + enddo + enddo + enddo +c + enddo +c + if (csdiag) then + if (mnproc.eq.1) then + write (lp,*) 'difest_common_hyb:' + endif + call chksummsk(rig,ip,kk+1,'rig') + call chksummsk(up,ip,kk,'up') + call chksummsk(vp,ip,kk,'vp') + endif +c + end subroutine difest_common_hyb +c + subroutine difest_isobml(m,n,mm,nn,k1m,k1n) +c +c --- ------------------------------------------------------------------ +c --- estimate diffusivities for eddy-induced transport, layer-wise +c --- diffusion and vertical diffusion +c --- ------------------------------------------------------------------ +c + integer m,n,mm,nn,k1m,k1n +c + integer i,j,k,l,kn +c +c --- ------------------------------------------------------------------ +c --- update halos of various fields +c --- ------------------------------------------------------------------ +c + call xctilr(u, 1,2*kk, 2,2, halo_uv) + call xctilr(v, 1,2*kk, 2,2, halo_vv) + call xctilr(ubflxs_p, 1,2, 2,2, halo_uv) + call xctilr(vbflxs_p, 1,2, 2,2, halo_vv) + call xctilr(pbu, 1,2, 2,2, halo_us) + call xctilr(pbv, 1,2, 2,2, halo_vs) +c +c --- ------------------------------------------------------------------ +c --- Update layer interface pressure. +c --- ------------------------------------------------------------------ +c +c$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 +c$OMP END PARALLEL DO +c +c --- ------------------------------------------------------------------ +c --- Estimate friction velocity cubed. +c --- ------------------------------------------------------------------ +c +c$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)) + ustar3(i,j)=ustar(i,j)**3 + enddo + enddo + enddo +c$OMP END PARALLEL DO +c +c --- Estimate energy input by near-inertial waves. + call niw_ke_tendency(m,n,mm,nn,k1m,k1n) +c +c --- Obtain common fields for the estimation of lateral and vertical +c --- diffusivities diapycnal diffusivities. + call difest_common_iso(m,n,mm,nn,k1m,k1n) +c +c --- Estimate vertical diffusivity. + call difest_vertical_iso(m,n,mm,nn,k1m,k1n) +c +c --- Estimate diffusivities for eddy-induced transport and layer-wise +c --- diffusion. + call difest_lateral_iso(m,n,mm,nn,k1m,k1n) +c + if (csdiag) then + if (mnproc.eq.1) then + write (lp,*) 'difest_isobml:' + endif + call chksummsk(ustar3,ip,1,'ustar3') + endif +c + end subroutine difest_isobml +c + subroutine difest_lateral_hybrid(m,n,mm,nn,k1m,k1n) +c +c --- ------------------------------------------------------------------ +c --- estimate diffusivities for eddy-induced transport, layer-wise +c --- diffusion and vertical diffusion +c --- ------------------------------------------------------------------ +c + integer m,n,mm,nn,k1m,k1n +c + integer i,j,k,l,kn +c +c --- ------------------------------------------------------------------ +c --- update halos of various fields +c --- ------------------------------------------------------------------ +c + call xctilr(u, 1,2*kk, 2,2, halo_uv) + call xctilr(v, 1,2*kk, 2,2, halo_vv) + call xctilr(ubflxs_p, 1,2, 2,2, halo_uv) + call xctilr(vbflxs_p, 1,2, 2,2, halo_vv) + call xctilr(pbu, 1,2, 2,2, halo_us) + call xctilr(pbv, 1,2, 2,2, halo_vs) +c +c --- ------------------------------------------------------------------ +c --- Update layer interface pressure. +c --- ------------------------------------------------------------------ +c +c$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 +c$OMP END PARALLEL DO +c +c --- ------------------------------------------------------------------ +c --- Estimate friction velocity cubed. +c --- ------------------------------------------------------------------ +c +c$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)) + ustar3(i,j)=ustar(i,j)**3 + enddo + enddo + enddo +c$OMP END PARALLEL DO +c +c --- Obtain common fields for the estimation of lateral and vertical +c --- diffusivities diapycnal diffusivities. + call difest_common_hyb(m,n,mm,nn,k1m,k1n) +c +c --- Estimate diffusivities for eddy-induced transport and layer-wise +c --- diffusion. + call difest_lateral_hyb(m,n,mm,nn,k1m,k1n) +c + if (csdiag) then + if (mnproc.eq.1) then + write (lp,*) 'difest_lateral_hybrid:' + endif + call chksummsk(ustar3,ip,1,'ustar3') + endif +c + end subroutine difest_lateral_hybrid +c + subroutine difest_vertical_hybrid(m,n,mm,nn,k1m,k1n) +c +c --- ------------------------------------------------------------------ +c --- estimate diffusivities for eddy-induced transport, layer-wise +c --- diffusion and vertical diffusion +c --- ------------------------------------------------------------------ +c + integer m,n,mm,nn,k1m,k1n +c + integer i,j,k,l,kn +c +c --- ------------------------------------------------------------------ +c --- update halos of various fields +c --- ------------------------------------------------------------------ +c + call xctilr(u(1-nbdy,1-nbdy,k1n), 1,kk, 1,1, halo_uv) + call xctilr(v(1-nbdy,1-nbdy,k1n), 1,kk, 1,1, halo_vv) +c +c --- ------------------------------------------------------------------ +c --- Update layer interface pressure. +c --- ------------------------------------------------------------------ +c +c$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 +c$OMP END PARALLEL DO +c +c --- Obtain common fields for the estimation of lateral and vertical +c --- diffusivities diapycnal diffusivities. + call difest_common_hyb(m,n,mm,nn,k1m,k1n) +c +c --- Estimate vertical diffusivities.. + call difest_vertical_hyb(m,n,mm,nn,k1m,k1n) +c + if (csdiag) then + if (mnproc.eq.1) then + write (lp,*) 'difest_vertical_hybrid:' + endif + endif +c + end subroutine difest_vertical_hybrid +c + subroutine difest_vertical_hyb(m,n,mm,nn,k1m,k1n) +c +c --- ------------------------------------------------------------------ +c --- estimate layer diapycnal, diffusivities for hybrid +c --- coordinates +c --- ------------------------------------------------------------------ +c + integer m,n,mm,nn,k1m,k1n +c + real, dimension(kdm+1) :: rig_i + integer i,j,k,l,kn + real q +c + type(CVMix_tidal_params_type) :: CVMix_tidal_params + real, dimension(kdm+1) :: depth_int + real, dimension(kdm+1) :: Kv_col, Kd_col ! background visc/diff + real, dimension(kdm+1) :: Kv_shr, Kd_shr ! shear driven visc/diff + real, dimension(kdm+1) :: Kv_conv, Kd_conv ! convection visc/diff + real, dimension(kdm+1) :: vert_dep ! vertical deposition + real, dimension(kdm+1) :: Kv_tidal, Kd_tidal ! tidal viscosity,diffusivity + real, dimension(kdm+1) :: Kv_kpp, Kt_kpp, Ks_kpp ! vertical viscosity,diffusivity temp/salt + real, dimension(kdm+1) :: iFaceHeight ! Height of interfaces [m] + real, dimension(kdm+1) :: bvfsq_i, bvf_i ! N2, N at interfaces + real, dimension(kdm) :: cellHeight ! Height of cell centers [m] + real, dimension(kdm) :: rho_zeros, rho_lwr ! dummy vars for convection + real, dimension(kdm) :: rho_1d ! 1D density at the layer center + real, dimension(kdm) :: Ws_1d ! Profile of vertical velocity scale for scalars [m s-1] + real, dimension(kdm) :: surfBuoyFlux2 + real, dimension(kdm) :: BulkRi_1d ! Bulk Richardson number for each layer + real, dimension(kdm) :: deltaU2 ! square of delta U (shear) in denominator of Bulk Ri [m2 s-2] + real, dimension(kdm) :: VT2 ! unresolved shear used for Bulk Ri + real, dimension(kdm) :: deltaRho ! delta Rho [g/cm3] in numerator of Bulk Ri number + real, dimension(kdm+1,2) :: nonLocalTrans ! Non-local transport for heat/salt at interfaces [nondim] + real :: surf_layer_ext, surfFricVel + real :: surfBuoyFlux + real :: delH, bvfbot, dps + real :: dh, hcorr + real :: Uk, Vk + real :: surfU, surfV + real :: surfHu, surfHv + real :: surfTemp, surfSalt, surfRho + real :: surfHtemp, surfHsalt + real :: SLdepth_0d, hTot + real :: Simmons_coeff, zBottomMinusOffset + real :: bl1, bl2, bl3, bl4 + integer ki, ksfc, ktmp, kOBL, kn1 +c + surf_layer_ext = 0.1 + bl1 = 8e-5 + bl2 = 1.05e-4 + bl3 = 4.5e-3 + bl4 = 2500.0 +c +c single column diffusivity + do j=1,jj + do l=1,isp(j) + do i=max(1,ifp(j,l)),min(ii,ilp(j,l)) +c +c -- ------- CVMix variables computed below +c + surfBuoyFlux2 = 0.0 + surfBuoyFlux = 0.0 +c Ws_1d = 0.0 + bvfbot = 0. + dps = 0. + depth_int = 0. + hcorr = 0. + Kv_col = 0. + Kd_col = 0. + vert_dep = 0. + Kv_tidal = 0. + Kd_tidal = 0. + Kv_conv = 0. + Kd_conv = 0. + Kv_shr = 0. + Kd_shr = 0. + iFaceHeight = 0. + cellHeight = 0. + bvfsq_i = 0. + rho_lwr(:)= drho0 + rho_zeros(:)= 0. + rho_1d = 0. + nonLocalTrans(:,:) = 0.0 + rig_i = 1.e8 !Initialize w/ large Richardson value + Kv_kpp = 0.0 + Kt_kpp = 0.0 + Ks_kpp = 0.0 + do k=1,kk+1 + Kv_kpp(k) = Kvisc_m(i,j,k)*A_cgs2mks + Kt_kpp(k) = Kdiff_t(i,j,k)*A_cgs2mks + Ks_kpp(k) = Kdiff_s(i,j,k)*A_cgs2mks + enddo + depth_int(1) = p(i,j,1)/onem + iFaceHeight(1) = -depth_int(1) + ! convert cm/s to m/s + surfFricVel = ustar(i,j) * iL_mks2cgs + ! convert cm2/s3 to m2/s3 + surfBuoyFlux = - buoyfl(i,j,1) * A_cgs2mks + do k=1,kk + kn = k + nn + kn1 = max(nn+1,kn-1) + ! Old method to compute interface location, thicknesses +c depth_int(k+1) = p(i,j,k+1)/onem +c iFaceHeight(k+1) = -depth_int(k+1) +c cellHeight(k) = 0.5*(iFaceHeight(k+1) + +c . iFaceHeight(k)) + ! New method to compute interface location, thicknesses + dh = dp(i,j,kn)/onem + dh = dh + hcorr ! Take away the accumulated error (could temporarily make dh<0) + hcorr = min(dh - 1e-10, 0.) ! If inflating then hcorr<0 + dh = max(dh, 1e-10) ! Limit increment dh>=min_thicknes + cellHeight(k) = iFaceHeight(k) - 0.5 * dh + iFaceHeight(k+1) = iFaceHeight(k) - dh + depth_int(k+1) = -iFaceHeight(k+1) + + ! compute rho_1d at the interfaces + rho_1d(k)=rho(p(i,j,k),temp(i,j,kn),saln(i,j,kn)) + + ! find ksfc for cell where "surface layer" sits + SLdepth_0d = surf_layer_ext* + . max(max(-cellHeight(k),-iFaceHeight(2)), + . minOBLdepth) + ksfc = k + do ki = 1,k + if (-1.0*iFaceHeight(ki+1) >= SLdepth_0d) then + ksfc = ki + exit + endif + enddo + surfHu = 0.0 + surfHv = 0.0 + surfHtemp = 0.0 + surfHsalt = 0.0 + hTot = 0.0 + do ki = 1,ksfc + ktmp = ki+nn + ! SLdepth_0d can be between cell interfaces + delH = min( max(0.0, SLdepth_0d - hTot), + . dp(i,j,ktmp)/onem ) + ! surface layer thickness + hTot = hTot + delH + ! surface averaged fields + surfHtemp = surfHtemp + temp(i,j,ktmp)*delH + surfHsalt = surfHsalt + saln(i,j,ktmp)*delH + surfHu = surfHu+up(i,j,ki)*delH + surfHv = surfHv+vp(i,j,ki)*delH + enddo + surfTemp = surfHtemp / hTot + surfSalt = surfHsalt / hTot + surfU = surfHu / hTot + surfV = surfHv / hTot + surfRho = rho(p(i,j,k),surfTemp,surfSalt) + if (p(i,j,kk+1)-p(i,j,k) < epsilp) then + deltaRho(k) = deltaRho(k-1) + else + deltaRho(k) = rho_1d(k) - surfRho + endif + ! vertical shear between present layer and + ! surface layer averaged surfU,surfV. + ! C-grid average to get Uk and Vk on T-points. + Uk = up(i,j,k) - surfU + Vk = vp(i,j,k) - surfV + deltaU2(k) = (Uk**2 + Vk**2) + + ! XXX: Temporary de-scaling of N2_int(i,:) into a + ! temporary variable + bvfsq_i(k) = bfsqi(i,j,k) + bvf_i(k) = sqrt( max( bvfsq_i(k), 0.) ) +c --- ------- Accumulate Brunt-Vaisala frequency in a region near the +c --- ------- bottom + q=max(0.,p(i,j,k+1)-max(p(i,j,kk+1)-dpnbav,p(i,j,k))) + if (q.gt.0.) then + bvfbot=bvfbot+bvf_i(k)*q + dps=dps+q + endif + +c --- ------- Local gradient Richardson number + rig_i(k)=rig(i,j,k) + + surfBuoyFlux2(k) = ( buoyfl(i,j,k+1) + . - buoyfl(i,j,1 )) * A_cgs2mks +c + enddo ! k + if(dps.gt.0.) bvfbot=bvfbot/dps + ! convert cm2/s2 to m2/s2 + deltaU2 = deltaU2*A_cgs2mks + + ! bottom values for the Ri, N2, and N + rig_i(kk+1) = rig_i(kk) + bvfsq_i(kk+1) = bfsqi(i,j,kk+1) + bvf_i(kk+1) = sqrt( max( bvfsq_i(kk+1), 0.) ) + +c -- ------- Background diapycnal mixing. + if (bdmtyp.eq.1) then +c zw interface depths relative to the surface in m, must be positive. + call CVMix_init_bkgnd(max_nlev=kk, zw = depth_int(:), + . bl1 = bl1, bl2 = bl2, bl3 = bl3, bl4 = bl4, + . prandtl = CVMix_glb_params%Prandtl) + call CVMix_coeffs_bkgnd(Mdiff_out=Kv_col, + . Tdiff_out=Kd_col, nlev=kk, max_nlev=kk) + elseif (bdmtyp.eq.2) then +c --- --------- Type 2: Background diffusivity is a constant + ! convert cm2/s2 to m2/s2 + Kv_col(:) = bdmc2*A_cgs2mks + Kd_col(:) = bdmc2*A_cgs2mks + else + Kv_col(:) = 0. + Kd_col(:) = 0. + endif + if (iwdflg.eq.1) then + Kv_col=Kv_col*(1.+(iwdfac-1.)*ficem(i,j)) + Kd_col=Kd_col*(1.+(iwdfac-1.)*ficem(i,j)) + endif + +c --- ------ Tidally driven diapycnal mixing +c + if (tdmflg.eq.1) then + call CVMix_init_tidal( + . CVmix_tidal_params_user=CVMix_tidal_params, + . mix_scheme='Simmons', + . efficiency=dmxeff, local_mixing_frac=tdmq) + + call CVMix_compute_Simmons_invariant(nlev=kk, + . energy_flux=twedon(i,j)*bvfbot*iM_mks2cgs, + . rho=CVMix_glb_params%FreshWaterDensity, + . SimmonsCoeff = Simmons_coeff, VertDep = vert_dep, + . zw = iFaceHeight, zt = cellHeight, + . CVmix_tidal_params_user=CVMix_tidal_params) + + + call CVMix_coeffs_tidal(Mdiff_out=Kv_tidal, + . Tdiff_out=Kd_tidal, Nsqr = bvfsq_i, + . OceanDepth = -iFaceHeight(kk+1), + . SimmonsCoeff = Simmons_coeff, + . vert_dep = vert_dep, + . nlev=kk, max_nlev=kk, + . cvmix_params = CVMix_glb_params, + . CVmix_tidal_params_user=CVMix_tidal_params) + else + Kd_tidal=0. + endif + +! Call to CVMix wrapper for computing interior mixing coefficients. + call CVMix_coeffs_shear(Mdiff_out=Kv_shr(:), + . Tdiff_out=Kd_shr(:), + . RICH=rig_i(:), + . nlev=kk, + . max_nlev=kk) + + +c --- ------ turbulent velocity scales w_s and w_m computed at the cell +c --- ------ centers. + call CVMix_kpp_compute_turbulent_scales( + . surf_layer_ext, ! (in) Normalized surface layer Cdepth; sigma = CS%surf_layer_ext + . -cellHeight, ! (in) Assume here that OBL depth [m] = -cellHeight(k) + . surfBuoyFlux2, ! (in) Buoyancy flux at surface [m2 s-3] + . surfFricVel, ! (in) Turbulent friction velocity at surface [m s-1] + . w_s=Ws_1d, ! (out) Turbulent velocity scale profile [m s-1] + . CVMix_kpp_params_user=KPP_params) + + ! Compute unresolved shear for CVMix + VT2(:) = CVmix_kpp_compute_unresolved_shear( + . zt_cntr=cellHeight, ! Depth ofcell center [m] + . ws_cntr=Ws_1d, ! Turbulent velocity scale profile, at centers [m s-1] + . N_iface=bvf_i, ! Buoyancy frequency at the interface [s-1] + . CVMix_kpp_params_user=KPP_params) + + ! Calculate Bulk Richardson number from eq (21) of LMD94 + BulkRi_1d = CVmix_kpp_compute_bulk_Richardson( + . zt_cntr = cellHeight, ! Depth of cell center [m] + . delta_buoy_cntr=g*alpha0*deltaRho*iL_mks2cgs, ! Bulk buoyancy difference, Br-B(z) [m s-2] + . delta_Vsqr_cntr=deltaU2, ! Square of resolved velocity difference [m2 s-2] + . Vt_sqr_cntr=VT2(:), ! Unresolved shear [m2 s-2] + . ws_cntr=Ws_1d, ! Turbulent velocity scale profile [m s-1] + . N_iface=bvf_i, ! Buoyancy frequency at the interface [s-1] + . CVMix_kpp_params_user=KPP_params ) ! KPP parameters + + ! Compute OBL depth for KPP + call CVMix_kpp_compute_OBL_depth( + . BulkRi_1d, ! (in) Bulk Richardson number + . iFaceHeight, ! (in) Height of interfaces [m] + . OBLdepth(i,j), ! (out) OBL depth [m] + . hOBL(i,j), ! (out) level (+fraction) of OBL extent + . zt_cntr = cellHeight, ! Depth of cell center [m] + . surf_fric=surfFricVel, ! (in) Turbulent friction velocity at surface [m s-1] + . surf_buoy=surfBuoyFlux, ! (in) Buoyancy flux at surface [m2 s-3] + . Coriolis=coriop(i,j), ! (in) Coriolis parameter [s-1] + . CVMix_kpp_params_user=KPP_params ) ! KPP parameters + + ! Avoid KPP reaching bottom + zBottomMinusOffset = iFaceHeight(kk+1) + . + min(1.0,-0.1*iFaceHeight(kk+1)) + OBLdepth(i,j) = min(OBLdepth(i,j), -zBottomMinusOffset) + ! no shallower than top layer + OBLdepth(i,j) = max(OBLdepth(i,j), -iFaceHeight(2)) + ! no deeper than bottom + OBLdepth(i,j) = min(OBLdepth(i,j), -iFaceHeight(kk+1)) + ! gets index of the level and interface above hbl + hOBL(i,j) = CVMix_kpp_compute_kOBL_depth(iFaceHeight, + . cellHeight,OBLdepth(i,j)) + + ! gets index of the level and interface above hbl + kOBL = int(hOBL(i,j)) ! index of interface above OBL depth + +c --- ------ Diapycnal mixing when local stability is weak +c --- ------ convection routine based on N2 not rho +c --- ------ make sure it is in metrics if stability depends on rho + call CVMix_coeffs_conv(Mdiff_out=Kv_conv, + . Tdiff_out=Kd_conv, Nsqr = bvfsq_i, + . dens=rho_zeros,dens_lwr=rho_lwr, + . nlev=kk, max_nlev=kk, + . OBL_ind=kOBL) + ! Do not apply mixing due to convection within the boundary layer + do k = 1,kOBL + Kv_conv(k) = 0.0 + Kd_conv(k) = 0.0 + enddo + + ! total diffusivities without KPP + Kv_kpp(:) = Kv_col(:)+Kv_conv(:)+Kv_shr(:) + Kt_kpp(:) = Kd_col(:)+Kd_conv(:)+Kd_shr(:)+Kd_tidal(:) + Ks_kpp(:) = Kd_col(:)+Kd_conv(:)+Kd_shr(:)+Kd_tidal(:) + + ! Buoyancy flux acting on the OBL + surfBuoyFlux = ( buoyfl(i,j,kOBL+1) + . - buoyfl(i,j,1 )) * A_cgs2mks + + ! Compute KPP using CVMix + call CVMix_coeffs_kpp(Kv_kpp(:), ! (inout) Total viscosity [m2 s-1] + . Kt_kpp(:), ! (inout) Total temp diffusivity [m2 s-1] + . Ks_kpp(:), ! (inout) Total salt diffusivity [m2 s-1] + . iFaceHeight, ! (in) Height of interfaces [m] + . cellHeight, ! (in) Height of level centers [m] + . Kv_kpp(:), ! (in) Original viscosity [m2 s-1] + . Kt_kpp(:), ! (in) Original temp diffusivity [m2 s-1] + . Ks_kpp(:), ! (in) Original salt diffusivity [m2 s-1] + . OBLdepth(i,j), ! (in) OBL depth [m] + . hOBL(i,j), ! (in) level (+fraction) of OBL extent + . nonLocalTrans(:,1), ! (out) Non-local heat transport [nondim] + . nonLocalTrans(:,2), ! (out) Non-local salt transport [nondim] + . surfFricVel, ! (in) Turbulent friction velocity at surface [m s-1] + . surfBuoyFlux, ! (in) Buoyancy flux at surface [m2 s-3] + . kk, ! (in) Number of levels to compute coeffs for + . kk, ! (in) Number of levels in array shape + . CVMix_kpp_params_user=KPP_params ) ! KPP parameters + +c ---- ccc ------- + ! convert m2/s to cm2/s + Kv_kpp = Kv_kpp*A_mks2cgs + Kt_kpp = Kt_kpp*A_mks2cgs + Ks_kpp = Ks_kpp*A_mks2cgs + Kv_kpp=max(nubmin,Kv_kpp) + Kt_kpp=max(nubmin,Kt_kpp) + Ks_kpp=max(nubmin,Ks_kpp) + Kvisc_m(i,j,:) = Kv_kpp(:) + Kdiff_t(i,j,:) = Kt_kpp(:) + Kdiff_s(i,j,:) = Ks_kpp(:) + t_ns_nonloc(i,j,:) = nonLocalTrans(:,1) + s_nonloc(i,j,:) = nonLocalTrans(:,2) + do k = 1, kk+1 + t_sw_nonloc(i,j,k) = max(t_sw_nonloc(i,j,k), + . nonLocalTrans(k,1)) + enddo + + enddo + enddo +c end of single column +c + enddo ! j-index +c + if (csdiag) then + if (mnproc.eq.1) then + write (lp,*) 'difest_vertical_hyb:' + endif + call chksummsk(Kvisc_m,ip,kk+1,'Kvisc_m') + call chksummsk(Kdiff_t,ip,kk+1,'Kdiff_t') + call chksummsk(Kdiff_s,ip,kk+1,'Kdiff_s') + endif +c + end subroutine difest_vertical_hyb +c + subroutine difest_lateral_hyb(m,n,mm,nn,k1m,k1n) +c +c --- ------------------------------------------------------------------ +c --- estimate layer interface, isopycnal, diffusivities for hybrid +c --- coordinates +c --- ------------------------------------------------------------------ +c + integer m,n,mm,nn,k1m,k1n +c +c + real, dimension(1-nbdy:idm+nbdy,kdm) :: egr + real, dimension(1-nbdy:idm+nbdy) :: + . tup,pup,sup,cr,bcrrd,afeql,dps,egrs,egrup,dfints,udps,vdps, + . umlzon,urmse,cpse + integer i,j,k,l,kn + real q,plo,tlo,slo,rhisc,els,egrlo,umnsc,esfac +c +c --- Locate the range of layers to be considered in the computation of +c --- diffusivities. + do j=0,jj+1 + do i=0,ii+1 + kmax(i,j)=0 + enddo + do l=1,isp(j) + do i=max(0,ifp(j,l)),min(ii+1,ilp(j,l)) + kmax(i,j)=1 + do k=2,kk + kn=k+nn + if (dp(i,j,kn).gt.dpbmin) kmax(i,j)=k + enddo + enddo + enddo + enddo + do j=1,jj + do l=1,isp(j) + do i=max(1,ifp(j,l)),min(ii,ilp(j,l)) + kfil(i,j)=kk+1 + do k=kk,2,-1 + if (p(i,j,k).gt.mlts(i,j)*(onem*iL_mks2cgs)) kfil(i,j)=k + enddo + enddo + enddo + enddo +c +c$OMP PARALLEL DO PRIVATE( +c$OMP+ l,i,k,kn,q,tup,pup,sup,cr,plo,tlo,slo,bcrrd, +c$OMP+ afeql,dps,egrs,egr,egrup,egrlo,dfints, +c$OMP+ rhisc,els,udps,vdps,umlzon,urmse,cpse,umnsc,esfac) + do j=1,jj +c +c ----- Compute the first baroclinic rossby radius of deformation using +c ----- the WKB approximation by Chelton at al. (1998). + do l=1,isp(j) + do i=max(1,ifp(j,l)),min(ii,ilp(j,l)) + pup(i)=p(i,j,1) + kn=1+nn + tup(i)=temp(i,j,kn) + sup(i)=saln(i,j,kn) + cr(i)=0. + enddo + enddo + do k=2,kk + kn=k+nn + do l=1,isp(j) + do i=max(1,ifp(j,l)),min(ii,ilp(j,l)) + if (p(i,j,kk+1)-p(i,j,k+1).lt.epsilp) then + plo=p(i,j,kk+1) + else + plo=.5*(p(i,j,k)+p(i,j,k+1)) + endif + tlo=temp(i,j,kn) + slo=saln(i,j,kn) + cr(i)=cr(i) + . +sqrt(max(0.,(rho(p(i,j,k),tlo,slo) + . -rho(p(i,j,k),tup(i),sup(i))) + . *(plo-pup(i)))) + pup(i)=plo + tup(i)=tlo + sup(i)=slo + enddo + enddo + enddo + do l=1,isp(j) + do i=max(1,ifp(j,l)),min(ii,ilp(j,l)) + cr(i)=alpha0*cr(i)/pi + bcrrd(i)= + . sqrt(cr(i)*cr(i) + . /max(coriop(i,j)*coriop(i,j)+2.*betafp(i,j)*cr(i), + . 1.e-24)) + afeql(i)=max(abs(coriop(i,j)),sqrt(2.*betafp(i,j)*cr(i))) + enddo + enddo +c +c --- - Compute diffusivity weigth to reduce eddy diffusivity when the +c --- - Rossby radius is resolved by the grid. + if (edwmth_opt.eq.edwmth_smooth) then + do l=1,isp(j) + do i=max(1,ifp(j,l)),min(ii,ilp(j,l)) + q=bcrrd(i)/sqrt(.5*(scpx(i,j)*scpx(i,j) + . +scpy(i,j)*scpy(i,j))) + difwgt(i,j)=1./(1.+.25*q**4) + enddo + enddo + elseif (edwmth_opt.eq.edwmth_step) then + do l=1,isp(j) + do i=max(1,ifp(j,l)),min(ii,ilp(j,l)) + q=bcrrd(i)/sqrt(.5*(scpx(i,j)*scpx(i,j) + . +scpy(i,j)*scpy(i,j))) + if (q.le.2.) then + difwgt(i,j)=1. + else + difwgt(i,j)=0. + endif + enddo + enddo + endif +c +c --- ------------------------------------------------------------------ +c --- - Compute layer interface and isopycnal diffusivities +c --- ------------------------------------------------------------------ +c + if (iidtyp.eq.1) then +c +c --- --- Type 1: Diffusivities are diffusive velocities multiplied by +c --- --- the local horizontal grid scale. + do l=1,isp(j) + do i=max(1,ifp(j,l)),min(ii,ilp(j,l)) + q=sqrt(scp2(i,j)) + difint(i,j,1)=thkdff*q + difiso(i,j,1)=temdff*q + enddo + enddo + do k=2,kk + do l=1,isp(j) + do i=max(1,ifp(j,l)),min(ii,ilp(j,l)) + difint(i,j,k)=difint(i,j,1) + difiso(i,j,k)=difiso(i,j,1) + enddo + enddo + enddo +c + else +c +c --- --- Type 2: Diffusivities are parameterized according to Eden and +c --- --- Greatbatch (2008). +c +c --- --- Eady growth rate. + if (edsprs) then + do l=1,isp(j) + do i=max(1,ifp(j,l)),min(ii,ilp(j,l)) + egrs(i)=0. + dps(i)=0. + enddo + enddo + endif + if (edritp_opt.eq.edritp_shear) then + do k=2,kk + do l=1,isp(j) + do i=max(1,ifp(j,l)),min(ii,ilp(j,l)) + if (k.ge.kfil(i,j).and.k.le.kmax(i,j).and. + . kmax(i,j)-kfil(i,j).ge.1) then + egr(i,k)=afeql(i) + . /sqrt(.5*(rig(i,j,k)+rig(i,j,k+1))+eggam) + if (edsprs) then + q=max(0.,min(p(i,j,kfil(i,j))+dpgrav, + . p(i,j,k+1))-p(i,j,k)) + dps(i)=dps(i)+q + egrs(i)=egrs(i)+egr(i,k)*q + endif + endif + enddo + enddo + enddo + elseif (edritp_opt.eq.edritp_large_scale) then + do l=1,isp(j) + do i=max(1,ifp(j,l)),min(ii,ilp(j,l)) + if (kmax(i,j)-kfil(i,j).ge.1) then + k=kfil(i,j) + if (kmax(i-1,j).ge.k.and.kmax(i+1,j).ge.k) then + q=.25*(nnslpx(i,j,k)+nnslpx(i+1,j,k))**2 + elseif (kmax(i-1,j).ge.k) then + q=nnslpx(i,j,k)**2 + elseif (kmax(i+1,j).ge.k) then + q=nnslpx(i+1,j,k)**2 + else + q=0. + endif + if (kmax(i,j-1).ge.k.and.kmax(i,j+1).ge.k) then + q=q+.25*(nnslpy(i,j,k)+nnslpy(i,j+1,k))**2 + elseif (kmax(i,j-1).ge.k) then + q=q+nnslpy(i,j,k)**2 + elseif (kmax(i,j+1).ge.k) then + q=q+nnslpy(i,j+1,k)**2 + endif + egrup(i)=sqrt(q) + endif + enddo + enddo + do k=2,kk + do l=1,isp(j) + do i=max(1,ifp(j,l)),min(ii,ilp(j,l)) + if (kmax(i,j)-kfil(i,j).ge.1) then + if (k.ge.kfil(i,j).and.k.lt.kmax(i,j)) then + if (kmax(i-1,j).gt.k.and.kmax(i+1,j).gt.k) then + q=.25*(nnslpx(i,j,k+1)+nnslpx(i+1,j,k+1))**2 + elseif (kmax(i-1,j).gt.k) then + q=nnslpx(i,j,k+1)**2 + elseif (kmax(i+1,j).gt.k) then + q=nnslpx(i+1,j,k+1)**2 + else + q=0. + endif + if (kmax(i,j-1).gt.k.and.kmax(i,j+1).gt.k) then + q=q+.25*(nnslpy(i,j,k+1)+nnslpy(i,j+1,k+1))**2 + elseif (kmax(i,j-1).gt.k) then + q=q+nnslpy(i,j,k+1)**2 + elseif (kmax(i,j+1).gt.k) then + q=q+nnslpy(i,j+1,k+1)**2 + endif + egrlo=sqrt(q) + egr(i,k)=.5*(egrup(i)+egrlo) + egrup(i)=egrlo + if (edsprs) then + q=max(0.,min(p(i,j,kfil(i,j))+dpgrav, + . p(i,j,k+1))-p(i,j,k)) + dps(i)=dps(i)+q + egrs(i)=egrs(i)+egr(i,k)*q + endif + elseif (k.eq.kmax(i,j)) then + egr(i,k)=egr(i,k-1) + endif + endif + enddo + enddo + enddo + endif + if (edsprs) then + do l=1,isp(j) + do i=max(1,ifp(j,l)),min(ii,ilp(j,l)) + if (dps(i).gt.0.) then + egrs(i)=egrs(i)/dps(i) + else + egrs(i)=0. + endif + enddo + enddo + endif +c + do l=1,isp(j) + do i=max(1,ifp(j,l)),min(ii,ilp(j,l)) + difint(i,j,1)=egmndf + dfints(i)=0. + dps(i)=0. + enddo + enddo + do k=2,kk + do l=1,isp(j) + do i=max(1,ifp(j,l)),min(ii,ilp(j,l)) + if (k.ge.kfil(i,j).and.k.le.kmax(i,j).and. + . kmax(i,j)-kfil(i,j).ge.1) then +c +c --- --------- Rhines scale. + rhisc=egr(i,k)/max(1.e-22*iL_mks2cgs,betafp(i,j)) +c +c --- --------- Eddy length scale. + els=max(eglsmn,min(bcrrd(i),rhisc)) +c +c --- --------- Temporary layer interface diffusivity. + difint(i,j,k)=egc*egr(i,k)*els*els +c +c --- --------- Accumulate diffusivities in a region below the first +c --- --------- physical layer. + q=max(0.,min(p(i,j,kfil(i,j))+dpdiav, + . p(i,j,k+1))-p(i,j,k)) + dps(i)=dps(i)+q + dfints(i)=dfints(i)+difint(i,j,k)*q +c + else + difint(i,j,k)=difint(i,j,k-1) + endif + enddo + enddo + enddo +c +c --- --- Apply eddy diffusivity limiting, suppression when the Rossby +c --- --- radius is resolved by the grid, and suppression away from +c --- --- steering levels if requested. +c +c --- --- Eddy diffusivity modification of surface non-isopycnic +c --- --- layers. +c + if (edsprs) then +c +c --- ----- Zonal mixed layer velocity. + do l=1,isp(j) + do i=max(1,ifp(j,l)),min(ii,ilp(j,l)) + udps(i)=0. + vdps(i)=0. + enddo + enddo + do k=1,kk + do l=1,isp(j) + do i=max(1,ifp(j,l)),min(ii,ilp(j,l)) + q=max(0.,min(p(i,j,k+1),OBLdepth(i,j)*onem)-p(i,j,k)) + udps(i)=udps(i)+up(i,j,k)*q + vdps(i)=vdps(i)+vp(i,j,k)*q + enddo + enddo + enddo + do l=1,isp(j) + do i=max(1,ifp(j,l)),min(ii,ilp(j,l)) + umlzon(i)=(udps(i)*cosang(i,j)-vdps(i)*sinang(i,j)) + . /(OBLdepth(i,j)*onem) + enddo + enddo + endif +c + do l=1,isp(j) + do i=max(1,ifp(j,l)),min(ii,ilp(j,l)) +c + if (edsprs) then +c +c --- ------- RMS eddy velocity estimated from K = Gamma*u_rms*L, where +c --- ------- a mixing efficiency of Gamma = 0.35 is used (Klocker and +c --- ------- Abernathey, 2014). + rhisc=egrs(i)/max(1.e-22*iL_mks2cgs,betafp(i,j)) + els=max(eglsmn,min(bcrrd(i),rhisc)) + urmse(i)=2.86*egc*egrs(i)*els +c +c --- ------- Zonal eddy phase speed minus zonal barotropic velocity +c --- ------- with a lower bound of -20 cm s-1. + cpse(i)=max(cpsemin,-betafp(i,j)*bcrrd(i)**2) +c + endif +c + if (dps(i).gt.0.) then +c + if (edsprs) then +c +c --- --------- Zonal mixed layer velocity minus eddy phase speed. Note +c --- --------- that only the baroclinic component is used since the +c --- --------- barotropic velocity is subtracted from the estimate of +c --- --------- eddy phase speed. + umnsc=umlzon(i)-cpse(i) +c +c --- --------- Eddy mixing suppresion factor where lower bounds of +c --- --------- zonal velocity minus eddy phase speed and absolute value +c --- --------- of RMS eddy velocity is set to -20 cm s-1 and 5 cm s-1, +c --- --------- respectively. + esfac=1./ + . (1.+4.*(umnsc/max(urmsemin,abs(urmse(i))))**2) +c + else + esfac=1. + endif +c + dfints(i)=dfints(i)/dps(i) + dfints(i)= + . min(difmxp(i,j),egmxdf, + . max(egmndf,dfints(i)*difwgt(i,j)*esfac)) + else + dfints(i)=egmndf + endif + enddo + enddo +c +c --- --- Eddy diffusivity modification of isopycnic layers. + do k=2,kk + kn=k+nn + do l=1,isp(j) + do i=max(1,ifp(j,l)),min(ii,ilp(j,l)) + if (k.ge.kfil(i,j).and.k.le.kmax(i,j).and. + . kmax(i,j)-kfil(i,j).ge.1) then +c + if (edsprs) then +c +c --- ----------- Zonal velocity minus eddy phase speed. + umnsc=up(i,j,k)*cosang(i,j)-vp(i,j,k)*sinang(i,j) + . -cpse(i) +c +c --- ----------- Eddy mixing suppresion factor. + esfac=1./ + . (1.+4.*(umnsc/max(urmsemin,abs(urmse(i))))**2) +c + else + esfac=1. + endif +c + difint(i,j,k)= + . min(difmxp(i,j),egmxdf, + . max(egmndf,difint(i,j,k)*difwgt(i,j)*esfac)) + else + difint(i,j,k)=difint(i,j,k-1) + endif + enddo + enddo + enddo +c +c --- --- Set isopycnal tracer diffusivity proportional to the layer +c --- --- interface diffusivity by the factor EGIDFQ. + do k=1,kk + do l=1,isp(j) + do i=max(1,ifp(j,l)),min(ii,ilp(j,l)) + if (k.lt.kfil(i,j)) then + difint(i,j,k)=dfints(i) + endif + difiso(i,j,k)=difint(i,j,k)*egidfq + enddo + enddo + enddo +c + endif + enddo +c$OMP END PARALLEL DO +c + if (csdiag) then + if (mnproc.eq.1) then + write (lp,*) 'difest_lateral_hyb:' + endif + call chksummsk(difint,ip,kk,'difint') + call chksummsk(difiso,ip,kk,'difiso') + endif +c + end subroutine difest_lateral_hyb +c + subroutine difest_lateral_iso(m,n,mm,nn,k1m,k1n) +c +c --- ------------------------------------------------------------------ +c --- estimate layer interface, isopycnal, diffusivities for isopycnal +c --- coordinates +c --- ------------------------------------------------------------------ +c + integer m,n,mm,nn,k1m,k1n +c + real, dimension(1-nbdy:idm+nbdy,kdm) :: egr + real, dimension(1-nbdy:idm+nbdy) :: + . tup,pup,sup,cr,bcrrd,afeql,dps,egrs,egrup,dfints,urmse,cpse + integer i,j,k,l,kn + real q,plo,tlo,slo,rhisc,els,egrlo,umnsc,esfac +c +c$OMP PARALLEL DO PRIVATE( +c$OMP+ l,i,k,kn,q,tup,pup,sup,cr,plo,tlo,slo,bcrrd, +c$OMP+ afeql,dps,egrs,egr,egrup,egrlo,dfints, +c$OMP+ rhisc,els,urmse,cpse,umnsc,esfac) + do j=1,jj +c +c ----- Compute the first baroclinic rossby radius of deformation using +c ----- the WKB approximation by Chelton at al. (1998). +c ----- !!! Could include top layer in computation !!! + do l=1,isp(j) + do i=max(1,ifp(j,l)),min(ii,ilp(j,l)) + pup(i)=.5*(3.*p(i,j,3)-p(i,j,min(kk,kfpla(i,j,n))+1)) + kn=2+nn + tup(i)=temp(i,j,kn) + sup(i)=saln(i,j,kn) + cr(i)=0. + enddo + enddo + do k=3,kk + kn=k+nn + do l=1,isp(j) + do i=max(1,ifp(j,l)),min(ii,ilp(j,l)) + if (k.ge.kfpla(i,j,n)) then + if (p(i,j,kk+1)-p(i,j,k+1).lt.epsilp) then + plo=p(i,j,kk+1) + else + plo=.5*(p(i,j,k)+p(i,j,k+1)) + endif + tlo=temp(i,j,kn) + slo=saln(i,j,kn) + cr(i)=cr(i) + . +sqrt(max(0.,(rho(p(i,j,k),tlo,slo) + . -rho(p(i,j,k),tup(i),sup(i))) + . *(plo-pup(i)))) + pup(i)=plo + tup(i)=tlo + sup(i)=slo + endif + enddo + enddo + enddo + do l=1,isp(j) + do i=max(1,ifp(j,l)),min(ii,ilp(j,l)) + cr(i)=alpha0*cr(i)/pi + bcrrd(i)= + . sqrt(cr(i)*cr(i) + . /max(coriop(i,j)*coriop(i,j)+2.*betafp(i,j)*cr(i), + . 1.e-24)) + afeql(i)=max(abs(coriop(i,j)),sqrt(2.*betafp(i,j)*cr(i))) + enddo + enddo +c +c --- - Compute diffusivity weigth to reduce eddy diffusivity when the +c --- - Rossby radius is resolved by the grid. + if (edwmth_opt.eq.edwmth_smooth) then + do l=1,isp(j) + do i=max(1,ifp(j,l)),min(ii,ilp(j,l)) + q=bcrrd(i)/sqrt(.5*(scpx(i,j)*scpx(i,j) + . +scpy(i,j)*scpy(i,j))) + difwgt(i,j)=1./(1.+.25*q**4) + enddo + enddo + elseif (edwmth_opt.eq.edwmth_step) then + do l=1,isp(j) + do i=max(1,ifp(j,l)),min(ii,ilp(j,l)) + q=bcrrd(i)/sqrt(.5*(scpx(i,j)*scpx(i,j) + . +scpy(i,j)*scpy(i,j))) + if (q.le.2.) then + difwgt(i,j)=1. + else + difwgt(i,j)=0. + endif + enddo + enddo + endif +c +c --- ------------------------------------------------------------------ +c --- - Compute layer interface and isopycnal diffusivities +c --- ------------------------------------------------------------------ +c + if (iidtyp.eq.1) then +c +c --- --- Type 1: Diffusivities are diffusive velocities multiplied by +c --- --- the local horizontal grid scale. + do l=1,isp(j) + do i=max(1,ifp(j,l)),min(ii,ilp(j,l)) + q=sqrt(scp2(i,j)) + difint(i,j,1)=thkdff*q + difiso(i,j,1)=temdff*q + enddo + enddo + do k=2,kk + do l=1,isp(j) + do i=max(1,ifp(j,l)),min(ii,ilp(j,l)) + difint(i,j,k)=difint(i,j,1) + difiso(i,j,k)=difiso(i,j,1) + enddo + enddo + enddo +c + else +c +c --- --- Type 2: Diffusivities are parameterized according to Eden and +c --- --- Greatbatch (2008). +c +c --- --- Eady growth rate. + if (edsprs) then + do l=1,isp(j) + do i=max(1,ifp(j,l)),min(ii,ilp(j,l)) + egrs(i)=0. + dps(i)=0. + enddo + enddo + endif + if (edritp_opt.eq.edritp_shear) then + do k=2,kk + do l=1,isp(j) + do i=max(1,ifp(j,l)),min(ii,ilp(j,l)) + if (k.ge.kfil(i,j).and.k.le.kmax(i,j).and. + . kmax(i,j)-kfil(i,j).ge.1) then + egr(i,k)=afeql(i)/sqrt(rig(i,j,k)+eggam) + if (edsprs) then + q=max(0.,min(p(i,j,kfil(i,j))+dpgrav, + . p(i,j,k+1))-p(i,j,k)) + dps(i)=dps(i)+q + egrs(i)=egrs(i)+egr(i,k)*q + endif + endif + enddo + enddo + enddo + elseif (edritp_opt.eq.edritp_large_scale) then + do l=1,isp(j) + do i=max(1,ifp(j,l)),min(ii,ilp(j,l)) + if (kmax(i,j)-kfil(i,j).ge.1) then + k=kfil(i,j) + if (kmax(i-1,j).ge.k.and.kmax(i+1,j).ge.k) then + q=.25*(nnslpx(i,j,k)+nnslpx(i+1,j,k))**2 + elseif (kmax(i-1,j).ge.k) then + q=nnslpx(i,j,k)**2 + elseif (kmax(i+1,j).ge.k) then + q=nnslpx(i+1,j,k)**2 + else + q=0. + endif + if (kmax(i,j-1).ge.k.and.kmax(i,j+1).ge.k) then + q=q+.25*(nnslpy(i,j,k)+nnslpy(i,j+1,k))**2 + elseif (kmax(i,j-1).ge.k) then + q=q+nnslpy(i,j,k)**2 + elseif (kmax(i,j+1).ge.k) then + q=q+nnslpy(i,j+1,k)**2 + endif + egrup(i)=sqrt(q) + endif + enddo + enddo + do k=2,kk + do l=1,isp(j) + do i=max(1,ifp(j,l)),min(ii,ilp(j,l)) + if (kmax(i,j)-kfil(i,j).ge.1) then + if (k.ge.kfil(i,j).and.k.lt.kmax(i,j)) then + if (kmax(i-1,j).gt.k.and.kmax(i+1,j).gt.k) then + q=.25*(nnslpx(i,j,k+1)+nnslpx(i+1,j,k+1))**2 + elseif (kmax(i-1,j).gt.k) then + q=nnslpx(i,j,k+1)**2 + elseif (kmax(i+1,j).gt.k) then + q=nnslpx(i+1,j,k+1)**2 + else + q=0. + endif + if (kmax(i,j-1).gt.k.and.kmax(i,j+1).gt.k) then + q=q+.25*(nnslpy(i,j,k+1)+nnslpy(i,j+1,k+1))**2 + elseif (kmax(i,j-1).gt.k) then + q=q+nnslpy(i,j,k+1)**2 + elseif (kmax(i,j+1).gt.k) then + q=q+nnslpy(i,j+1,k+1)**2 + endif + egrlo=sqrt(q) + egr(i,k)=.5*(egrup(i)+egrlo) + egrup(i)=egrlo + if (edsprs) then + q=max(0.,min(p(i,j,kfil(i,j))+dpgrav, + . p(i,j,k+1))-p(i,j,k)) + dps(i)=dps(i)+q + egrs(i)=egrs(i)+egr(i,k)*q + endif + elseif (k.eq.kmax(i,j)) then + egr(i,k)=egr(i,k-1) + endif + endif + enddo + enddo + enddo + endif + if (edsprs) then + do l=1,isp(j) + do i=max(1,ifp(j,l)),min(ii,ilp(j,l)) + if (dps(i).gt.0.) then + egrs(i)=egrs(i)/dps(i) + else + egrs(i)=0. + endif + enddo + enddo + endif +c + do l=1,isp(j) + do i=max(1,ifp(j,l)),min(ii,ilp(j,l)) + difint(i,j,1)=egmndf + dfints(i)=0. + dps(i)=0. + enddo + enddo + do k=2,kk + do l=1,isp(j) + do i=max(1,ifp(j,l)),min(ii,ilp(j,l)) + if (k.ge.kfil(i,j).and.k.le.kmax(i,j).and. + . kmax(i,j)-kfil(i,j).ge.1) then +c +c --- --------- Rhines scale. + rhisc=egr(i,k)/max(1.e-22*iL_mks2cgs,betafp(i,j)) +c +c --- --------- Eddy length scale. + els=max(eglsmn,min(bcrrd(i),rhisc)) +c +c --- --------- Temporary layer interface diffusivity. + difint(i,j,k)=egc*egr(i,k)*els*els +c +c --- --------- Accumulate diffusivities in a region below the first +c --- --------- physical layer. + q=max(0.,min(p(i,j,kfil(i,j))+dpdiav, + . p(i,j,k+1))-p(i,j,k)) + dps(i)=dps(i)+q + dfints(i)=dfints(i)+difint(i,j,k)*q +c + else + difint(i,j,k)=difint(i,j,k-1) + endif + enddo + enddo + enddo +c +c --- --- Apply eddy diffusivity limiting, suppression when the Rossby +c --- --- radius is resolved by the grid, and suppression away from +c --- --- steering levels if requested. +c +c --- --- Eddy diffusivity modification of surface non-isopycnic +c --- --- layers. + do l=1,isp(j) + do i=max(1,ifp(j,l)),min(ii,ilp(j,l)) +c + if (edsprs) then +c +c --- ------- RMS eddy velocity estimated from K = Gamma*u_rms*L, where +c --- ------- a mixing efficiency of Gamma = 0.35 is used (Klocker and +c --- ------- Abernathey, 2014). + rhisc=egrs(i)/max(1.e-22*iL_mks2cgs,betafp(i,j)) + els=max(eglsmn,min(bcrrd(i),rhisc)) + urmse(i)=2.86*egc*egrs(i)*els +c +c --- ------- Zonal eddy phase speed minus zonal barotropic velocity +c --- ------- with a lower bound of -20 cm s-1. + cpse(i)=max(cpsemin,-betafp(i,j)*bcrrd(i)**2) +c + endif +c + if (dps(i).gt.0.) then +c + if (edsprs) then +c +c --- --------- Zonal mixed layer velocity minus eddy phase speed. Note +c --- --------- that only the baroclinic component is used since the +c --- --------- barotropic velocity is subtracted from the estimate of +c --- --------- eddy phase speed. + if (ip(i-1,j)+ip(i+1,j).eq.2) then + q=.5*((u(i ,j,1+nn)*dpu(i ,j,1+nn) + . +u(i ,j,2+nn)*dpu(i ,j,2+nn)) + . /(dpu(i ,j,1+nn)+dpu(i ,j,2+nn)) + . +(u(i+1,j,1+nn)*dpu(i+1,j,1+nn) + . +u(i+1,j,2+nn)*dpu(i+1,j,2+nn)) + . /(dpu(i+1,j,1+nn)+dpu(i+1,j,2+nn))) + elseif (ip(i-1,j).eq.1) then + q=(u(i ,j,1+nn)*dpu(i ,j,1+nn) + . +u(i ,j,2+nn)*dpu(i ,j,2+nn)) + . /(dpu(i ,j,1+nn)+dpu(i ,j,2+nn)) + elseif (ip(i+1,j).eq.1) then + q=(u(i+1,j,1+nn)*dpu(i+1,j,1+nn) + . +u(i+1,j,2+nn)*dpu(i+1,j,2+nn)) + . /(dpu(i+1,j,1+nn)+dpu(i+1,j,2+nn)) + else + q=0. + endif + umnsc=q*cosang(i,j) + if (ip(i,j-1)+ip(i,j+1).eq.2) then + q=.5*((v(i,j ,1+nn)*dpv(i,j ,1+nn) + . +v(i,j ,2+nn)*dpv(i,j ,2+nn)) + . /(dpv(i,j ,1+nn)+dpv(i,j ,2+nn)) + . +(v(i,j+1,1+nn)*dpv(i,j+1,1+nn) + . +v(i,j+1,2+nn)*dpv(i,j+1,2+nn)) + . /(dpv(i,j+1,1+nn)+dpv(i,j+1,2+nn))) + elseif (ip(i,j-1).eq.1) then + q=(v(i,j ,1+nn)*dpv(i,j ,1+nn) + . +v(i,j ,2+nn)*dpv(i,j ,2+nn)) + . /(dpv(i,j ,1+nn)+dpv(i,j ,2+nn)) + elseif (ip(i,j+1).eq.1) then + q=(v(i,j+1,1+nn)*dpv(i,j+1,1+nn) + . +v(i,j+1,2+nn)*dpv(i,j+1,2+nn)) + . /(dpv(i,j+1,1+nn)+dpv(i,j+1,2+nn)) + else + q=0. + endif + umnsc=umnsc-q*sinang(i,j)-cpse(i) +c +c --- --------- Eddy mixing suppresion factor where lower bounds of +c --- --------- zonal velocity minus eddy phase speed and absolute value +c --- --------- of RMS eddy velocity is set to -20 cm s-1 and 5 cm s-1, +c --- --------- respectively. + esfac=1./ + . (1.+4.*(umnsc/max(urmsemin,abs(urmse(i))))**2) +c + else + esfac=1. + endif +c + dfints(i)=dfints(i)/dps(i) + dfints(i)= + . min(difmxp(i,j),egmxdf, + . max(egmndf,dfints(i)*difwgt(i,j)*esfac)) + else + dfints(i)=egmndf + endif + enddo + enddo +c +c --- --- Eddy diffusivity modification of isopycnic layers. + do k=2,kk + kn=k+nn + do l=1,isp(j) + do i=max(1,ifp(j,l)),min(ii,ilp(j,l)) + if (k.ge.kfil(i,j).and.k.le.kmax(i,j).and. + . kmax(i,j)-kfil(i,j).ge.1) then +c + if (edsprs) then +c +c --- ----------- Zonal velocity minus eddy phase speed. + umnsc= + . (msku(i,j,k)*u(i,j,kn)+msku(i+1,j,k)*u(i+1,j,kn)) + . /max(1,msku(i,j,k)+msku(i+1,j,k))*cosang(i,j) + . -(mskv(i,j,k)*v(i,j,kn)+mskv(i,j+1,k)*v(i,j+1,kn)) + . /max(1,mskv(i,j,k)+mskv(i,j+1,k))*sinang(i,j) + . -cpse(i) +c +c --- ----------- Eddy mixing suppresion factor. + esfac= + . 1./(1.+4.*(umnsc/max(urmsemin,abs(urmse(i))))**2) +c + else + esfac=1. + endif +c + difint(i,j,k)= + . min(difmxp(i,j),egmxdf, + . max(egmndf,difint(i,j,k)*difwgt(i,j)*esfac)) + else + difint(i,j,k)=difint(i,j,k-1) + endif + enddo + enddo + enddo +c +c --- --- Set isopycnal tracer diffusivity proportional to the layer +c --- --- interface diffusivity by the factor EGIDFQ. + do k=1,kk + do l=1,isp(j) + do i=max(1,ifp(j,l)),min(ii,ilp(j,l)) + if (k.lt.kfil(i,j)) then + difint(i,j,k)=dfints(i) + endif + difiso(i,j,k)=difint(i,j,k)*egidfq + enddo + enddo + enddo +c + endif + enddo +c$OMP END PARALLEL DO +c +c + if (csdiag) then + if (mnproc.eq.1) then + write (lp,*) 'difest_lateral_iso:' + endif + call chksummsk(difint,ip,kk,'difint') + call chksummsk(difiso,ip,kk,'difiso') + endif +c + end subroutine difest_lateral_iso +c + subroutine difest_vertical_iso(m,n,mm,nn,k1m,k1n) +c +c --- ------------------------------------------------------------------ +c --- estimate diapycnal diffusivities for isopycnal model +c --- ------------------------------------------------------------------ +c + integer m,n,mm,nn,k1m,k1n +c + real, dimension(1-nbdy:idm+nbdy,kdm) :: bvfsq,bvf + real, dimension(1-nbdy:idm+nbdy) :: bvfbot,dps,dfddsu,dfddsl + integer i,j,k,l,kn + real q,nus,nub,nut,nuls,vsf,nusm,ust,mols,h,sg,zeta,phis,ws +c +#if defined(TRC) && defined(TKE) + real gls_c3,tke_prod,tke_buoy,tke_epsilon,Ls_unlmt,Ls_lmt,tke_Q, + . Gm,Gh,Sm,Sh,cff,ql +# ifdef GLS + real gls_prod,gls_buoy,gls_diss,gls_Q +# endif +#endif +c +c$OMP PARALLEL DO PRIVATE( +c$OMP+ l,i,k,kn,q,bvfbot,dps,bvfsq,bvf,dfddsu,dfddsl,nub,nus,ust,vsf, +c$OMP+ nut,nuls,nusm,mols,h,sg,zeta,phis,ws +#if defined(TRC) && defined(TKE) +c$OMP+ ,gls_c3,tke_epsilon,tke_prod,tke_buoy,tke_Q,Ls_unlmt,Ls_lmt,Gh, +c$OMP+ Gm,cff,Sm,Sh,ql +# ifdef GLS +c$OMP+ ,gls_prod,gls_buoy,gls_diss,gls_Q +# endif +#endif +c$OMP+ ) + do j=1,jj +c +c ----- Compute Brunt-Vaisala frequency. + do l=1,isp(j) + do i=max(1,ifp(j,l)),min(ii,ilp(j,l)) + bvfbot(i)=0. + dps(i)=0. + enddo + enddo + do k=4,kk + kn=k+nn + do l=1,isp(j) + do i=max(1,ifp(j,l)),min(ii,ilp(j,l)) + if (k.ge.kfil(i,j).and.k.le.kmax(i,j).and. + . kmax(i,j)-kfil(i,j).ge.1) then +c +c --- ------- Brunt-Vaisala frequency squared + bvfsq(i,k)=g*g*max(drhomn,drhol(i,j,k)) + . /max(epsilp,dp(i,j,kn)) +c +c --- ------- Brunt-Vaisala frequency + bvf(i,k)=sqrt(bvfsq(i,k)) +c +#if defined(TRC) && defined(TKE) + if (dp(i,j,kn).gt.dpbmin) then + Buoy(i,j,k)=-difdia(i,j,k)*bvfsq(i,k) + h=max(onem,dp(i,j,kn))*alpha0/g +c h=max(onem*1e-8,dp(i,j,kn))*alpha0/g +c h=max(onemm,dp(i,j,kn))*alpha0/g + Shear2(i,j,k)=max(1.e-13*A_mks2cgs,du2l(i,j,k))/(h*h) + Prod(i,j,k)=difdia(i,j,k)*Pr_t*Shear2(i,j,k) + else + Buoy(i,j,k)=0. + Shear2(i,j,k)=1.e-9 + Prod(i,j,k)=0. + endif +#endif +c +c --- ------- Accumulate Brunt-Vaisala frequency in a region near the +c --- ------- bottom + q=max(0.,p(i,j,k+1)-max(p(i,j,kk+1)-dpnbav,p(i,j,k))) + if (q.gt.0.) then + bvfbot(i)=bvfbot(i)+bvf(i,k)*q + dps(i)=dps(i)+q + endif + endif + enddo + enddo + enddo + do l=1,isp(j) + do i=max(1,ifp(j,l)),min(ii,ilp(j,l)) + if (dps(i).gt.0.) then + bvfbot(i)=bvfbot(i)/dps(i) + endif + enddo + enddo +c +c --- ------------------------------------------------------------------ +c --- - Compute diapycnal diffusivity. +c --- ------------------------------------------------------------------ +c + do l=1,isp(j) + do i=max(1,ifp(j,l)),min(ii,ilp(j,l)) + difdia(i,j,1)=nu0 + dfddsu(i)=0. + dfddsl(i)=0. + dps(i)=0. + enddo + enddo + do k=2,kk + kn=k+nn + do l=1,isp(j) + do i=max(1,ifp(j,l)),min(ii,ilp(j,l)) + if (k.ge.kfil(i,j).and.k.le.kmax(i,j).and. + . kmax(i,j)-kfil(i,j).ge.1) then +c +c --- ------- Background diapycnal mixing. + if (bdmtyp.eq.1) then +c +c --- --------- Type 1: Background diffusivity is a constant divided by +c --- --------- Brunt-Vaisala frequency. + nub=bdmc1/bvf(i,k) + elseif (bdmtyp.eq.2) then +c +c --- --------- Type 2: Background diffusivity is a constant + nub=bdmc2 + else + nub=0. + endif + if (iwdflg.eq.1) then + nub=nub*(1.+(iwdfac-1.)*ficem(i,j)) + endif +c +c --- ------- Latitude dependency of background diapycnal mixing + if (bdmldp.eq.1) then + q=max(1.e-9,abs(coriop(i,j))) + nub=nub*q/cori30*log(2.*bvf0/q)/log(2.*bvf0/cori30) + endif +c + nub=max(nubmin,nub) +c +#if !defined(TRC) || !defined(TKE) +c --- ------- Shear driven diapycnal mixing. + if (rig(i,j,k).lt.ri0) then +c +c --- --------- Maximum diffusivity is increased near the bottom to +c --- --------- provide additional mixing of gravity currents. + q=(p(i,j,kk+1)-p(i,j,k)+.5*dp(i,j,kn)) + . /min(dpgc,.5*p(i,j,kk+1)) + q=max(0.,1.-q*q) + q=q*q*q + nus=q*nug0+(1.-q)*nus0 +c +c --- --------- Parameterization of diffusivity as a function of local +c --- --------- gradient richardson number. + q=rig(i,j,k)/ri0 + q=max(0.,1.-q*q) + nus=nus*q*q*q + else + nus=0. + endif +#else + if (bvfsq(i,k).gt.0.) then ! stable stratification + gls_c3=gls_c3minus + else ! unstable stratification + gls_c3=gls_c3plus + endif +# ifndef GLS + trc(i,j,kn,itrgls)=max((gls_c1*Prod(i,j,k) + . +gls_c3*Buoy(i,j,k))/gls_c2, + . gls_psi_min) +# endif + tke_epsilon=cmu_fac2*trc(i,j,kn,itrtke)**(1.5+gls_m/gls_n) + . *trc(i,j,kn,itrgls)**(-1./gls_n) + tke_prod=Prod(i,j,k) + tke_buoy=Buoy(i,j,k) + tke_Q=tke_epsilon/trc(i,j,kn,itrtke) +# ifdef GLS + gls_prod=(trc(i,j,kn,itrgls)/trc(i,j,kn,itrtke)) + . *gls_c1*Prod(i,j,k) + gls_buoy=(trc(i,j,kn,itrgls)/trc(i,j,kn,itrtke)) + . *gls_c3*Buoy(i,j,k) + gls_diss=(trc(i,j,kn,itrgls)/trc(i,j,kn,itrtke)) + . *gls_c2*tke_epsilon + gls_Q=gls_diss/trc(i,j,kn,itrgls) +# endif +# ifdef GLS + if (gls_prod+gls_buoy.ge.0.) then + trc(i,j,kn,itrgls)= + . (trc(i,j,kn,itrgls)+delt1*(gls_prod+gls_buoy)) + . /(1.+delt1*gls_Q) + else + trc(i,j,kn,itrgls)= + . (trc(i,j,kn,itrgls)+delt1*gls_prod) + . /(1.+delt1*(gls_Q-(gls_buoy/trc(i,j,kn,itrgls)))) + endif + trc(i,j,kn,itrgls)=max(trc(i,j,kn,itrgls),gls_psi_min) + q=.56**(.5*gls_n)*gls_cmu0**gls_p + . *trc(i,j,kn,itrtke)**(gls_m+.5*gls_n) + . *bvf(i,k)**(-gls_n) + if (gls_n.lt.0.) then + trc(i,j,kn,itrgls)=max(trc(i,j,kn,itrgls),q) + else + trc(i,j,kn,itrgls)=min(trc(i,j,kn,itrgls),q) + endif +# endif +c + tke_epsilon=cmu_fac2*trc(i,j,kn,itrtke)**(1.5+gls_m/gls_n) + . *trc(i,j,kn,itrgls)**(-1./gls_n) + tke_Q=tke_epsilon/trc(i,j,kn,itrtke) +c + if (tke_prod+tke_buoy.ge.0.) then + trc(i,j,kn,itrtke)= + . (trc(i,j,kn,itrtke)+delt1*(tke_prod+tke_buoy)) + . /(1.+delt1*tke_Q) + else + trc(i,j,kn,itrtke)= + . (trc(i,j,kn,itrtke)+delt1*tke_prod) + . /(1.+delt1*(tke_Q-(tke_buoy/trc(i,j,kn,itrtke)))) + trc(i,j,kn,itrtke)=max(trc(i,j,kn,itrtke),tke_min) + endif +c +c --- ------- Penetration of surface TKE below mixed layer. + if (tkepf.gt.0.) then + if (dp(i,j,kn).lt.epsilp) then + q=exp(-p(i,j,k)/tkepls) + else + q=tkepls*(exp(-p(i,j,k )/tkepls) + . -exp(-p(i,j,k+1)/tkepls))/dp(i,j,kn) + endif + trc(i,j,kn,itrtke)=trc(i,j,kn,itrtke) + . +67.83*tkepf*q*ustar(i,j)**2 + endif +c +c --- ------- Set TKE and GLS to prescribed minimum values in surface +c --- ------- mixed layers and thin layers + if (dp(i,j,kn).lt.epsilp) then + trc(i,j,kn,itrtke)=tke_min + trc(i,j,kn,itrgls)=gls_psi_min + endif + trc(i,j,1+nn,itrtke)=tke_min + trc(i,j,2+nn,itrtke)=tke_min + trc(i,j,1+nn,itrgls)=gls_psi_min + trc(i,j,2+nn,itrgls)=gls_psi_min +c +c --- ------- Bottom Boundary Conditions + if (k.eq.kmax(i,j)) then + ust=max(ustarb(i,j),ustmin) + trc(i,j,kn,itrtke)=max(tke_min,(ust/gls_cmu0)**2) +# ifdef GLS + trc(i,j,kn,itrgls)=max(gls_psi_min, + . (gls_cmu0**(gls_p-2.*gls_m)) + . *(ust**(2.*gls_m)) + . *(kappa*L_mks2cgs)**gls_n) +# endif + endif +c + Ls_unlmt=max(Ls_unlmt_min, + . cmu_fac1*trc(i,j,kn,itrgls)**(gls_exp1) + . *trc(i,j,kn,itrtke)**(-tke_exp1)) + + if (bvfsq(i,k).gt.0.) then ! stable stratification +c Ls_lmt=min(Ls_unlmt, +c . sqrt(.56*trc(i,j,kn,itrtke) +c . /max(bvfsq(i,k),1.e-10))) + + Ls_lmt=min(Ls_unlmt,trc(i,j,kn,itrtke)**(-gls_m/gls_n) + . *trc(i,j,kn,itrgls)**gls_n) +c Ls_lmt=Ls_unlmt + else ! unstable stratification + Ls_lmt=Ls_unlmt + endif +c +c --- ------- Compute nondimensional stability functions for tracers +c --- ------- (Sh) and momentum (Sm). Canuto-A + Gh=min(gls_Gh0,-bvfsq(i,k)*Ls_lmt*Ls_lmt + . /(2.*trc(i,j,kn,itrtke))) + Gh=min(Gh,(Gh-(Gh-gls_Ghcri)**2) + . /(Gh+gls_Gh0-2.*gls_Ghcri)) + Gh=max(Gh,gls_Ghmin) + Gh=min(Gh,gls_Gh0) +c +c --- ------- Compute shear number. + Gm=(gls_b0/gls_fac6-gls_b1*Gh+gls_b3*gls_fac6*(Gh**2)) + . /(gls_b2-gls_b4*gls_fac6*Gh) + Gm=min(Gm,Shear2(i,j,k)*Ls_lmt*Ls_lmt + . /(2.*trc(i,j,kn,itrtke))) +c +c --- ------- Compute stability functions + cff=gls_b0-gls_b1*gls_fac6*Gh+gls_b2*gls_fac6*Gm + . +gls_b3*gls_fac6**2*Gh**2-gls_b4*gls_fac6**2*Gh*Gm + . +gls_b5*gls_fac6**2*Gm*Gm + Sm=(gls_s0-gls_s1*gls_fac6*Gh+gls_s2*gls_fac6*Gm)/cff + Sh=(gls_s4-gls_s5*gls_fac6*Gh+gls_s6*gls_fac6*Gm)/cff + Sm=max(Sm,0.) + Sh=max(Sh,0.) +c +c --- ------- Relate Canuto stability to BLOM notation + Sm=Sm*cmu_fac3/gls_cmu0**3 + Sh=Sh*cmu_fac3/gls_cmu0**3 +c + ql=sqrt2*(Ls_lmt) + . *sqrt(trc(i,j,kn,itrtke)) +c ql=sqrt2*.5*(Ls_lmt+L_scale(i,j,k)) +c . *sqrt(trc(i,j,kn,itrtke)) +c +c nus=Sh*ql +c nus=min(0.1*ql,4.05*nug0) + nus=min(Sh*ql,4.05*nug0) +c nus=Sh*(trc(i,j,k,itrtke)*trc(i,j,k,itrtke)) +c . /trc(i,j,k,itrgls) + L_scale(i,j,k)=max(Ls_lmt,Ls_unlmt_min) +# ifdef GLS +c +c --- ------- Recompute gls based on limited length scale + trc(i,j,kn,itrgls)= + . max(gls_cmu0**gls_p*trc(i,j,kn,itrtke)**gls_m + . *L_scale(i,j,k)**gls_n,gls_psi_min) +# endif +#endif +c +c --- ------- Tidally driven diapycnal mixing + if (tdmflg.eq.1) then + q=.5*(tanh(4.*(abs(plat(i,j))-tdclat)/tddlat-2.)+1.) + q=(1.-q)*tdmls0+q*tdmls1 + if (dp(i,j,kn).lt.epsilp) then + vsf=exp(p(i,j,k)/q)/(q*(exp(p(i,j,kk+1)/q)-1.)) + else + vsf=(exp(p(i,j,k+1)/q)-exp(p(i,j,k)/q)) + . /(dp(i,j,kn)*(exp(p(i,j,kk+1)/q)-1.)) + endif + nut=g*tdmq*dmxeff*twedon(i,j)*bvfbot(i)*vsf/bvfsq(i,k) + else + nut=0. + endif +c +c --- ------- Diapycnal mixing when local stability is weak + if (drhol(i,j,k).lt.drho0) then + q=drhol(i,j,k)/drho0 + q=max(0.,1.-q*q) + nuls=nuls0*q*q*q + else + nuls=0. + endif +c +c --- ------- Total diapycnal diffusivity. + difdia(i,j,k)=nub+nus+nut+nuls +c +c --- ------- Accumulate diffusivities in a region below the first +c --- ------- physical layer + q=max(0.,min(p(i,j,kfil(i,j))+dpddav,p(i,j,k+1))-p(i,j,k)) + dps(i)=dps(i)+q + dfddsu(i)=dfddsu(i)+nub*q + dfddsl(i)=dfddsl(i)+difdia(i,j,k)*q +c + else + difdia(i,j,k)=difdia(i,j,k-1) +#if defined(TRC) && defined(TKE) +c trc(i,j,kn,itrtke)=tke_min +c L_scale(i,j,k)=Ls_unlmt_min + trc(i,j,kn,itrtke)=trc(i,j,kn-1,itrtke) + L_scale(i,j,k)=L_scale(i,j,k-1) +# ifdef GLS +c trc(i,j,kn,itrgls)=gls_psi_min + trc(i,j,kn,itrgls)=trc(i,j,kn-1,itrgls) +# endif +#endif + endif + enddo + enddo + enddo + do l=1,isp(j) + do i=max(1,ifp(j,l)),min(ii,ilp(j,l)) + if (dps(i).gt.0.) then + dfddsu(i)=dfddsu(i)/dps(i) + dfddsl(i)=dfddsl(i)/dps(i) + else + dfddsu(i)=nu0 + dfddsl(i)=nu0 + endif + enddo + enddo + do k=2,kk-1 + do l=1,isp(j) + do i=max(1,ifp(j,l)),min(ii,ilp(j,l)) + if (k.lt.kfil(i,j)) then + if (k.gt.2.and.kfil(i,j).le.kk.and. + . p(i,j,min(kk,kfil(i,j)))-p(i,j,3).gt.epsilp) then + q=.5*(p(i,j,k+1)+p(i,j,k)) + difdia(i,j,k)=((q-p(i,j,3))*dfddsl(i) + . +(p(i,j,kfil(i,j))-q)*dfddsu(i)) + . /(p(i,j,kfil(i,j))-p(i,j,3)) + else + difdia(i,j,k)=dfddsu(i) + endif + endif + enddo + enddo + enddo +c +c --- - Diapycnal diffusivity beneath mixed layer by dissipation of +c --- - energy originating from near-inertial waves. + do k=2,kk-1 + kn=k+nn + do l=1,isp(j) + do i=max(1,ifp(j,l)),min(ii,ilp(j,l)) + if (k.le.kmax(i,j).and.kmax(i,j)-kfil(i,j).ge.1) then + q=niwls + if (k.eq.2.or.dp(i,j,kn).lt.epsilp) then + vsf=exp((p(i,j,3)-p(i,j,k+1))/q) + . /(q*(1.-exp((p(i,j,3)-p(i,j,kk+1))/q))) + else + vsf=(exp((p(i,j,3)-p(i,j,k ))/q) + . -exp((p(i,j,3)-p(i,j,k+1))/q)) + . /(dp(i,j,kn)*(1.-exp((p(i,j,3)-p(i,j,kk+1))/q))) + endif + nusm=g*niwgf*(1.-niwbf)*niwlf*dmxeff*idkedt(i,j)*vsf + . /(alpha0*bvfsq(i,max(k,kfil(i,j)))) + difdia(i,j,k)=difdia(i,j,k)+nusm + endif + enddo + enddo + enddo +c +c --- - Diffusivity at the lower interface of the top layer + do l=1,isp(j) + do i=max(1,ifp(j,l)),min(ii,ilp(j,l)) +c +c --- --- Lower bounded friction velocity + ust=max(ustmin,ustar(i,j)) +c +c --- --- Monin-Obukhov length scale + mols=ust**3/(kappa*sign(max(abs(buoyfl(i,j,1)),bfeps), + . -buoyfl(i,j,1))) +c +c --- --- Mixed layer thickness + h=(p(i,j,3)-p(i,j,1))/(onem*iL_mks2cgs) +c +c --- --- Dimensionless vertical coordinate in the boundary layer + sg=(p(i,j,2)-p(i,j,1))/(p(i,j,3)-p(i,j,1)) +c +c --- --- Velocity scale + if (mols.lt.0.) then + zeta=min(sleps,sg)*h/mols + if (zeta.gt.zetas) then + phis=(1.-16.*zeta)**(-1./2.) + else + phis=(as-cs*zeta)**(-1./3.) + endif + else + zeta=sg*h/mols + phis=1.+5.*zeta + endif + ws=kappa*ust/phis +c + difdia(i,j,1)=h*ws*sg*(1.-sg)**2 + enddo + enddo +c + enddo +c$OMP END PARALLEL DO +c +c + if (csdiag) then + if (mnproc.eq.1) then + write (lp,*) 'difest_vertical_iso:' + endif + call chksummsk(idkedt,ip,1,'idkedt') + call chksummsk(difdia,ip,kk,'difdia') +#if defined(TRC) && defined(TKE) + call chksummsk(trc(1-nbdy,1-nbdy,1,itrtke),ip,2*kk,'tke') +# ifdef GLS + call chksummsk(trc(1-nbdy,1-nbdy,1,itrgls),ip,2*kk,'gls_psi') +# endif +#endif + endif +c + end subroutine difest_vertical_iso +c + end module mod_difest diff --git a/phy/mod_diffusion.F90 b/phy/mod_diffusion.F90 index e7ecc36f..4f82d958 100644 --- a/phy/mod_diffusion.F90 +++ b/phy/mod_diffusion.F90 @@ -1,5 +1,5 @@ ! ------------------------------------------------------------------------------ -! Copyright (C) 2020 Mats Bentsen +! Copyright (C) 2020-2022 Mats Bentsen, Mehmet Ilicak ! ! This file is part of BLOM. ! @@ -23,7 +23,8 @@ module mod_diffusion ! ------------------------------------------------------------------------------ use mod_types, only: r8 - use mod_constants, only: spval + use mod_config, only: inst_suffix + use mod_constants, only: spval, epsilk use mod_xc implicit none @@ -65,21 +66,55 @@ module mod_diffusion ! methods: 'intdif', 'gm'. edritp, & ! Type of Richardson number used in eddy diffusivity ! computation. Valid types: 'shear', 'large scale'. - edwmth ! Method to estimate eddy diffusivity weight as a function of + edwmth, & ! Method to estimate eddy diffusivity weight as a function of ! the ration of Rossby radius of deformation to the horizontal ! grid spacing. Valid methods: 'smooth', 'step'. + ltedtp ! Type of lateral tracer eddy diffusion: Valid methods: 'layer', + ! 'neutral'. + + ! Options derived from string options. + integer :: & + eitmth_opt, & + edritp_opt, & + edwmth_opt, & + ltedtp_opt + + ! Parameters: + integer, parameter :: & + ! Eddy-induced transport parameterization methods: + eitmth_intdif = 1, & ! Interface diffusion. + eitmth_gm = 2, & ! Gent-McWilliams. + ! Type of Richardson number used in eddy diffusivity computation: + edritp_shear = 1, & ! Using local vertical velocity shear. + edritp_large_scale = 2, & ! Using large scale variables. + ! Method to estimate eddy diffusivity weight: + edwmth_smooth = 1, & ! Smooth function of Rossby radius over grid + ! spacing. + edwmth_step = 2, & ! Step function of Rossby radius over grid + ! spacing. + ! Lateral tracer eddy diffusion type: + ltedtp_layer = 1, & ! Diffusion along model layers. + ltedtp_neutral = 2 ! Diffusion along neutral sublayers. real(r8), dimension(1 - nbdy:idm + nbdy,1 - nbdy:jdm + nbdy, kdm) :: & difint, & ! Layer interface diffusivity [cm2 s-1]. difiso, & ! Isopycnal diffusivity [cm2 s-1]. difdia ! Diapycnal diffusivity [cm2 s-1]. + real(r8), dimension(1 - nbdy:idm + nbdy,1 - nbdy:jdm + nbdy, kdm+1) :: & + Kvisc_m, & ! momentum eddy viscosity [cm2 s-1]. + Kdiff_t, & ! temperature eddy diffusivity [cm2 s-1]. + Kdiff_s, & ! salinity eddy diffusivity [cm2 s-1]. + t_ns_nonloc, & ! Non-local transport term that is the fraction of + ! non-shortwave flux passing a layer interface []. + s_nonloc ! Non-local transport term that is the fraction of + ! material tracer flux passing a layer interface []. + real(r8), dimension(1 - nbdy:idm + nbdy,1 - nbdy:jdm + nbdy) :: & difmxp, & ! Maximum lateral diffusivity at p-points [cm2 s-1]. difmxq, & ! Maximum lateral diffusivity at q-points [cm2 s-1]. difwgt ! Eddy diffusivity weight []. - real(r8), dimension(1 - nbdy:idm + nbdy,1 - nbdy:jdm + nbdy, 2*kdm) :: & umfltd, & ! u-component of horizontal mass flux due to thickness diffusion ! [g cm s-2]. @@ -103,14 +138,151 @@ module mod_diffusion ! [g2 cm kg-1 s-2]. public :: egc, eggam, eglsmn, egmndf, egmxdf, egidfq, ri0, bdmc1, bdmc2, & - tkepf, bdmtyp, edsprs, eitmth, edritp, edwmth, & + tkepf, bdmtyp, edsprs, eitmth_opt, eitmth_intdif, eitmth_gm, & + edritp_opt, edritp_shear, edritp_large_scale, & + edwmth_opt, edwmth_smooth, edwmth_step, & + ltedtp_opt, ltedtp_layer, ltedtp_neutral, & difint, difiso, difdia, difmxp, difmxq, difwgt, & umfltd, vmfltd, utfltd, vtfltd, utflld, vtflld, & usfltd, vsfltd, usflld, vsflld, & - inivar_diffusion + Kvisc_m, Kdiff_t, Kdiff_s, t_ns_nonloc, s_nonloc, & + readnml_diffusion, inivar_diffusion contains + subroutine readnml_diffusion + ! --------------------------------------------------------------------------- + ! Read variables in the namelist group 'diffusion' and resolve options. + ! --------------------------------------------------------------------------- + + character(len = 80) :: nml_fname + integer :: ios + logical :: fexist + + namelist /diffusion/ & + egc, eggam, eglsmn, egmndf, egmxdf, egidfq, ri0, bdmc1, bdmc2, tkepf, & + bdmtyp, edsprs, eitmth, edritp, edwmth, ltedtp + + ! Read variables in the namelist group 'diffusion'. + if (mnproc == 1) then + nml_fname = 'ocn_in'//trim(inst_suffix) + inquire(file = nml_fname, exist = fexist) + if (fexist) then + open (unit = 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 (unit = nfu, file = nml_fname, status = 'old', & + action = 'read') + else + write (lp,*) 'readnml_diffusion: could not find namelist file!' + call xchalt('(readnml_diffusion)') + stop '(readnml_diffusion)' + endif + endif + read (unit = nfu, nml = diffusion, iostat = ios) + close (unit = nfu) + endif + call xcbcst(ios) + if (ios /= 0) then + if (mnproc == 1) & + write (lp,*) 'readnml_diffusion: No diffusion variable '// & + 'group found in namelist. Using defaults.' + else + call xcbcst(egc) + call xcbcst(eggam) + call xcbcst(eglsmn) + call xcbcst(egmndf) + call xcbcst(egmxdf) + call xcbcst(egidfq) + call xcbcst(ri0) + call xcbcst(bdmc1) + call xcbcst(bdmc2) + call xcbcst(tkepf) + call xcbcst(bdmtyp) + call xcbcst(edsprs) + call xcbcst(eitmth) + call xcbcst(edritp) + call xcbcst(edwmth) + call xcbcst(ltedtp) + endif + if (mnproc == 1) then + write (lp,*) 'readnml_diffusion: diffusion variables:' + write (lp,*) ' egc = ', egc + write (lp,*) ' eggam = ', eggam + write (lp,*) ' eglsmn = ', eglsmn + write (lp,*) ' egmndf = ', egmndf + write (lp,*) ' egmxdf = ', egmxdf + write (lp,*) ' egidfq = ', egidfq + write (lp,*) ' ri0 = ', ri0 + write (lp,*) ' bdmc1 = ', bdmc1 + write (lp,*) ' bdmc2 = ', bdmc2 + write (lp,*) ' tkepf = ', tkepf + write (lp,*) ' bdmtyp = ', bdmtyp + write (lp,*) ' edsprs = ', edsprs + write (lp,*) ' eitmth = ', trim(eitmth) + write (lp,*) ' edritp = ', trim(edritp) + write (lp,*) ' edwmth = ', trim(edwmth) + write (lp,*) ' ltedtp = ', trim(ltedtp) + endif + + ! Resolve options. + select case (trim(eitmth)) + case ('intdif') + eitmth_opt = eitmth_intdif + case ('gm') + eitmth_opt = eitmth_gm + case default + if (mnproc == 1) & + write (lp,'(3a)') & + ' readnml_diffusion: eitmth = ', trim(eitmth), & + ' is unsupported!' + call xcstop('(readnml_diffusion)') + stop '(readnml_diffusion)' + end select + select case (trim(edritp)) + case ('shear') + edritp_opt = edritp_shear + case ('large scale') + edritp_opt = edritp_large_scale + case default + if (mnproc == 1) & + write (lp,'(3a)') & + ' readnml_diffusion: edritp = ', trim(edritp), & + ' is unsupported!' + call xcstop('(readnml_diffusion)') + stop '(readnml_diffusion)' + end select + select case (trim(edwmth)) + case ('smooth') + edwmth_opt = edwmth_smooth + case ('step') + edwmth_opt = edwmth_step + case default + if (mnproc == 1) & + write (lp,'(3a)') & + ' readnml_diffusion: edwmth = ', trim(edwmth), & + ' is unsupported!' + call xcstop('(readnml_diffusion)') + stop '(readnml_diffusion)' + end select + select case (trim(ltedtp)) + case ('layer') + ltedtp_opt = ltedtp_layer + case ('neutral') + ltedtp_opt = ltedtp_neutral + case default + if (mnproc == 1) & + write (lp,'(3a)') & + ' readnml_diffusion: ltedtp = ', trim(ltedtp), & + ' is unsupported!' + call xcstop('(readnml_diffusion)') + stop '(readnml_diffusion)' + end select + + end subroutine readnml_diffusion + subroutine inivar_diffusion ! --------------------------------------------------------------------------- ! Initialize arrays. @@ -146,11 +318,32 @@ subroutine inivar_diffusion vsflld(i, j, k) = spval enddo enddo + do k = 1, kk+1 + do i = 1 - nbdy, ii + nbdy + Kvisc_m(i, j, k) = epsilk + Kdiff_t(i, j, k) = epsilk + Kdiff_s(i, j, k) = epsilk + enddo + enddo + enddo + !$omp end parallel do + + ! Initialize isopycnal diffusivity. + !$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)) + difiso(i, j, k) = 0._r8 + enddo + enddo + enddo enddo !$omp end parallel do + call xctilr(difiso, 1, kk, nbdy, nbdy, halo_ps) - ! Initialize diffusive fluxes at points located upstream and downstream (in - ! i-direction) of p-points. + ! Initialize diffusive fluxes at points located upstream and downstream + ! (in i-direction) of p-points. !$omp parallel do private(k, l, i) do j = 1, jj do k = 1, 2*kk @@ -170,8 +363,8 @@ subroutine inivar_diffusion call xctilr(utflld, 1, 2*kk, nbdy, nbdy, halo_us) call xctilr(usflld, 1, 2*kk, nbdy, nbdy, halo_us) - ! Initialize diffusive fluxes at points located upstream and downstream (in - ! j-direction) of p-points. + ! Initialize diffusive fluxes at points located upstream and downstream + ! (in j-direction) of p-points. !$omp parallel do private(k, l, j) do i = 1, ii do k = 1, 2*kk diff --git a/phy/mod_eddtra.F b/phy/mod_eddtra.F deleted file mode 100644 index f393e243..00000000 --- a/phy/mod_eddtra.F +++ /dev/null @@ -1,1013 +0,0 @@ -! ------------------------------------------------------------------------------ -! Copyright (C) 2015-2020 Mats Bentsen -! -! 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_eddtra -c -c --- ------------------------------------------------------------------ -c --- This module contains variables and procedures related to advection -c --- of layer pressure thickness and tracers by calling incremental -c --- remapping routines. -c --- ------------------------------------------------------------------ -c - use mod_types, only: r8 - use mod_constants, only: g, alpha0, epsil, onemm - use mod_time, only: delt1 - use mod_xc - use mod_grid, only: scuy, scvx, scp2, scu2, scv2, scuxi, scvyi - use mod_eos, only: rho - use mod_state, only: dp, dpu, dpv, temp, saln, p, pbu, pbv, kfpla - use mod_diffusion, only: eitmth, difint, umfltd, vmfltd, - . utfltd, vtfltd, usfltd, vsfltd - use mod_cmnfld, only: nslpx, nslpy, nnslpx, nnslpy - use mod_checksum, only: csdiag, chksummsk -c - implicit none -c - private -c - public :: eddtra -c - contains -c -c --- ------------------------------------------------------------------ -c - subroutine eddtra(m,n,mm,nn,k1m,k1n) -c -c --- ------------------------------------------------------------------ -c --- Compute eddy-induced transport. -c --- ------------------------------------------------------------------ -c - integer m,n,mm,nn,k1m,k1n -c - integer i,j,k,l,km -c -c --- ------------------------------------------------------------------ -c --- Compute eddy-induced transport of mass. -c --- ------------------------------------------------------------------ -c - if (eitmth.eq.'intdif') then - call eddtra_intdif(m,n,mm,nn,k1m,k1n) - elseif (eitmth.eq.'gm') then - call eddtra_gm(m,n,mm,nn,k1m,k1n) - else - if (mnproc.eq.1) then - write (lp,'(3a)') ' eitmth=',trim(eitmth),' is unsupported!' - endif - call xcstop('(eddtra)') - stop '(eddtra)' - endif -c -c --- ------------------------------------------------------------------ -c --- Diagnose eddy-induced transport components of heat and salt. -c --- ------------------------------------------------------------------ -c -c$OMP PARALLEL DO PRIVATE(k,km,l,i) - do j=1,jj - do k=1,kk - km=k+mm - do l=1,isu(j) - do i=max(1,ifu(j,l)),min(ii,ilu(j,l)) - utfltd(i,j,km)=.5*umfltd(i,j,km) - . *(temp(i-1,j,km)+temp(i,j,km)) - usfltd(i,j,km)=.5*umfltd(i,j,km) - . *(saln(i-1,j,km)+saln(i,j,km)) - enddo - enddo - do l=1,isv(j) - do i=max(1,ifv(j,l)),min(ii,ilv(j,l)) - vtfltd(i,j,km)=.5*vmfltd(i,j,km) - . *(temp(i,j-1,km)+temp(i,j,km)) - vsfltd(i,j,km)=.5*vmfltd(i,j,km) - . *(saln(i,j-1,km)+saln(i,j,km)) - enddo - enddo - enddo - enddo -c$OMP END PARALLEL DO -c - if (csdiag) then - if (mnproc.eq.1) then - write (lp,*) 'eddtra:' - endif - call chksummsk(umfltd(1-nbdy,1-nbdy,k1m),iu,kk,'umfltd') - call chksummsk(vmfltd(1-nbdy,1-nbdy,k1m),iv,kk,'vmfltd') - call chksummsk(utfltd(1-nbdy,1-nbdy,k1m),iu,kk,'utfltd') - call chksummsk(vtfltd(1-nbdy,1-nbdy,k1m),iv,kk,'vtfltd') - call chksummsk(usfltd(1-nbdy,1-nbdy,k1m),iu,kk,'usfltd') - call chksummsk(vsfltd(1-nbdy,1-nbdy,k1m),iv,kk,'vsfltd') - endif -c - end subroutine eddtra -c -c --- ------------------------------------------------------------------ -c - subroutine eddtra_intdif(m,n,mm,nn,k1m,k1n) -c -c --- ------------------------------------------------------------------ -c --- Estimate eddy-induced transport by interface diffusion. -c --- ------------------------------------------------------------------ -c - integer m,n,mm,nn,k1m,k1n -c - integer i,j,k,l,km,kn - real flxhi,flxlo,q -c - call xctilr(difint, 1,kk, 2,2, halo_ps) -c -c$OMP PARALLEL DO PRIVATE(l,i) - do j=-1,jj+2 - do l=1,isu(j) - do i=max(0,ifu(j,l)),min(ii+2,ilu(j,l)) - umfltd(i,j,1+mm)=0. - umfltd(i,j,2+mm)=0. - umfltd(i,j,3+mm)=0. - enddo - enddo - enddo -c$OMP END PARALLEL DO -c$OMP PARALLEL DO PRIVATE(l,i) - do j=0,jj+2 - do l=1,isv(j) - do i=max(-1,ifv(j,l)),min(ii+2,ilv(j,l)) - vmfltd(i,j,1+mm)=0. - vmfltd(i,j,2+mm)=0. - vmfltd(i,j,3+mm)=0. - enddo - enddo - enddo -c$OMP END PARALLEL DO -c - do k=4,kk - km=k+mm - kn=k+nn -c -c$OMP PARALLEL DO PRIVATE(l,i,flxhi,flxlo,q) - do j=-1,jj+2 - do l=1,isu(j) - do i=max(0,ifu(j,l)),min(ii+2,ilu(j,l)) - flxhi= .125*min(dp(i-1,j,kn-1)*scp2(i-1,j), - . dp(i ,j,kn )*scp2(i ,j)) - flxlo=-.125*min(dp(i ,j,kn-1)*scp2(i ,j), - . dp(i-1,j,kn )*scp2(i-1,j)) - q=.25*(difint(i-1,j,k-1)+difint(i,j,k-1) - . +difint(i-1,j,k )+difint(i,j,k )) - q=min(flxhi,max(flxlo, - . delt1*q*(p(i-1,j,k)-p(i,j,k))*scuy(i,j)*scuxi(i,j))) - umfltd(i,j,km-1)=umfltd(i,j,km-1)+q - umfltd(i,j,km )=-q - enddo - enddo - enddo -c$OMP END PARALLEL DO -c -c$OMP PARALLEL DO PRIVATE(l,i,flxhi,flxlo,q) - do j=0,jj+2 - do l=1,isv(j) - do i=max(-1,ifv(j,l)),min(ii+2,ilv(j,l)) - flxhi= .125*min(dp(i,j-1,kn-1)*scp2(i,j-1), - . dp(i,j ,kn )*scp2(i,j )) - flxlo=-.125*min(dp(i,j ,kn-1)*scp2(i,j ), - . dp(i,j-1,kn )*scp2(i,j-1)) - q=.25*(difint(i,j-1,k-1)+difint(i,j,k-1) - . +difint(i,j-1,k )+difint(i,j,k )) - q=min(flxhi,max(flxlo, - . delt1*q*(p(i,j-1,k)-p(i,j,k))*scvx(i,j)*scvyi(i,j))) - vmfltd(i,j,km-1)=vmfltd(i,j,km-1)+q - vmfltd(i,j,km )=-q - enddo - enddo - enddo -c$OMP END PARALLEL DO -c - enddo -c - end subroutine eddtra_intdif -c -c --- ------------------------------------------------------------------ -c - subroutine eddtra_gm(m,n,mm,nn,k1m,k1n) -c -c --- ------------------------------------------------------------------ -c --- Estimate eddy-induced transport following the Gent-McWilliams -c --- parameterization. -c --- ------------------------------------------------------------------ -c - integer m,n,mm,nn,k1m,k1n -c -c --- Parameters: -c --- ffac - fraction of the mass of a grid cell a mass flux is -c --- allowed to deplete []. -c --- fface - (1-epsilon)*ffac []. -c - real ffac,fface - parameter (ffac=.0625,fface=.99*ffac) -c - real, dimension(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy) :: ptu,ptv - real, dimension(kdm+1) :: upsilon,mfl - real, dimension(kdm) :: dlm,dlp - real rho0,q,et2mf,kappa,fhi,flo - integer i,j,k,l,km,kn,kintr,kmax,kmin,niter,kdir - logical changed -c - rho0=1./alpha0 -c - call xctilr(difint, 1,kk, 2,2, halo_ps) - call xctilr(pbu, 1,2, 2,2, halo_us) - call xctilr(pbv, 1,2, 2,2, halo_vs) -c -c --- ------------------------------------------------------------------ -c --- Compute top pressure at velocity points. -c --- ------------------------------------------------------------------ -c -c$OMP PARALLEL DO PRIVATE(l,i) - do j=-1,jj+2 - do l=1,isu(j) - do i=max(0,ifu(j,l)),min(ii+2,ilu(j,l)) - ptu(i,j)=max(p(i-1,j,1),p(i,j,1)) - enddo - enddo - enddo -c$OMP END PARALLEL DO -c$OMP PARALLEL DO PRIVATE(l,i) - do j=0,jj+2 - do l=1,isv(j) - do i=max(-1,ifv(j,l)),min(ii+2,ilv(j,l)) - ptv(i,j)=max(p(i,j-1,1),p(i,j,1)) - enddo - enddo - enddo -c$OMP END PARALLEL DO -c -c --- ------------------------------------------------------------------ -c --- Compute u-component of eddy-induced mass fluxes. -c --- ------------------------------------------------------------------ -c -c$OMP PARALLEL DO PRIVATE( -c$OMP+ l,i,k,km,et2mf,kmax,kn,kintr,kappa,upsilon, -c$OMP+ kmin,mfl,dlm,dlp,fhi,flo,changed,niter,kdir,q) - do j=-1,jj+2 - do l=1,isu(j) - do i=max(0,ifu(j,l)),min(ii+2,ilu(j,l)) -c -c --- ------------------------------------------------------------------ -c --- --- Set eddy-induced mass fluxes to zero initially. -c --- ------------------------------------------------------------------ -c - do k=1,kk - km=k+mm - umfltd(i,j,km)=0. - enddo -c -c --- --- Eddy transport to mass flux conversion factor. - et2mf=-g*rho0*delt1*scuy(i,j) -c -c --- --- Index of last layer containing mass at either of the scalar -c --- --- points adjacent to the velocity point. - kmax=1 - do k=3,kk - kn=k+nn - if (dp(i-1,j,kn).gt.epsil.or.dp(i,j,kn).gt.epsil) kmax=k - enddo -c -c --- ------------------------------------------------------------------ -c --- --- Proceed with mass flux computation if at least one of the -c --- --- adjacent scalar points to the velocity point has a mass -c --- --- containing interior layer. Mass fluxes will be assigned at -c --- --- layer interface corresponding to the eddy induced transport. -c --- --- The final layer mass flux will be the lower minus the upper -c --- --- interface flux. The mass fluxes are limited to keep -c --- --- interfaces within the water column. There are 3 cases to -c --- --- consider: -c --- --- Case 1: The mixed layer extends to the bottom at both -c --- --- adjacent scalar points to the velocity point -c --- --- Case 2: The mixed layer extends to the bottom at scalar -c --- --- point (i ,j). -c --- --- Case 3: The mixed layer extends to the bottom at scalar -c --- --- point (i-1,j). -c --- --- Case 4: The mixed layer does not reach the bottom at neither -c --- --- of the scalar points adjacent to the velocity point. -c --- ------------------------------------------------------------------ -c - if (kfpla(i-1,j,n).gt.kk.and.kfpla(i,j,n).gt.kk) then -c -c --- ------------------------------------------------------------------ -c --- ----- Case 1: -c --- ------------------------------------------------------------------ -c -c --- ----- Keep the initial zero mass fluxes for this column. - cycle -c - elseif (kfpla(i-1,j,n).le.kk.and.kfpla(i,j,n).gt.kk) then -c -c --- ------------------------------------------------------------------ -c --- ----- Case 2: -c --- ------------------------------------------------------------------ -c -c --- ----- Find the index of the first layer at (i-1,j) that is -c --- ----- hydrostatically stable at the mixed layer base at (i ,j). - km=2+nn - kintr=kfpla(i-1,j,n) - kn=kintr+nn - do while - . (rho(p(i ,j,3),temp(i-1,j,kn),saln(i-1,j,kn)).lt. - . rho(p(i ,j,3),temp(i ,j,km),saln(i ,j,km)).or. - . dp(i-1,j,kn).lt.epsil) - kintr=kintr+1 - if (kintr.eq.kmax+1) exit - kn=kintr+nn - enddo -c -c --- ----- If a physical layer cannot be found, keep the initial zero -c --- ----- mass fluxes for this column. - if (kintr.eq.kmax+1) cycle -c -c --- ----- Compute the eddy induced transport (upsilon) at the mixed -c --- ----- layer base. - kappa=.5*(difint(i-1,j,2)+difint(i,j,2)) - upsilon(3)=-kappa*nslpx(i,j,3) -c -c --- ----- If the eddy-induced transport at the base of the mixed layer -c --- ----- would cause a negative mass flux below the mixed layer, keep -c --- ----- the initial zero mass fluxes for this column. - if (upsilon(3).le.0.) cycle -c -c --- ----- Assign interface mass fluxes. - kmin=kintr-1 - mfl(kmin)=0. - mfl(kintr)=et2mf*upsilon(3) - do k=kintr+1,kmax+1 - mfl(k)=0. - enddo -c - elseif (kfpla(i-1,j,n).gt.kk.and.kfpla(i,j,n).le.kk) then -c -c --- ------------------------------------------------------------------ -c --- ----- Case 3: -c --- ------------------------------------------------------------------ -c -c --- ----- Find the index of the first layer at (i ,j) that is -c --- ----- hydrostatically stable at the mixed layer base at (i-1,j). - km=2+nn - kintr=kfpla(i ,j,n) - kn=kintr+nn - do while - . (rho(p(i-1,j,3),temp(i ,j,kn),saln(i ,j,kn)).lt. - . rho(p(i-1,j,3),temp(i-1,j,km),saln(i-1,j,km)).or. - . dp(i ,j,kn).lt.epsil) - kintr=kintr+1 - if (kintr.eq.kmax+1) exit - kn=kintr+nn - enddo -c -c --- ----- If a physical layer cannot be found, keep the initial zero -c --- ----- mass fluxes for this column. - if (kintr.eq.kmax+1) cycle -c -c --- ----- Compute the eddy induced transport (upsilon) at the mixed -c --- ----- layer base. - kappa=.5*(difint(i-1,j,2)+difint(i,j,2)) - upsilon(3)=-kappa*nslpx(i,j,3) -c -c --- ----- If the eddy-induced transport at the base of the mixed layer -c --- ----- would cause a positive mass flux below the mixed layer, keep -c --- ----- the initial zero mass fluxes for this column. - if (upsilon(3).ge.0.) cycle -c -c --- ----- Assign interface mass fluxes. - kmin=kintr-1 - mfl(kmin)=0. - mfl(kintr)=et2mf*upsilon(3) - do k=kintr+1,kmax+1 - mfl(k)=0. - enddo -c - else -c -c --- ------------------------------------------------------------------ -c --- ----- Case 4: -c --- ------------------------------------------------------------------ -c -c --- ----- The first interior interface where the eddy induced -c --- ----- transport is estimated is at index kintr+1. - kintr=max(kfpla(i-1,j,n),kfpla(i,j,n)) -c -c --- ----- Compute the eddy induced transport (upsilon) at the mixed -c --- ----- layer base. - kappa=.5*(difint(i-1,j,2)+difint(i,j,2)) - upsilon(3)=-kappa*nslpx(i,j,3) -c -c --- ----- Compute the eddy induced transport at interior interfaces. - do k=kintr+1,kmax - kn=k+nn - kappa=.25*(difint(i-1,j,k-1)+difint(i ,j,k-1) - . +difint(i-1,j,k )+difint(i ,j,k )) - upsilon(k)=-kappa*nslpx(i,j,k) - enddo - upsilon(kmax+1)=0. -c -c --- ----- If the layer kintr-1 is a physical layer at either of the -c --- ----- adjacent scalar points to the velocity point, then apply -c --- ----- an upper interface mass flux corresponding to the eddy -c --- ----- induced transport at the mixed layer base and a lower -c --- ----- interface mass flux corresponding to the eddy induced -c --- ----- transport at the kintr+1 interface if this would lead to a -c --- ----- hydrostatically stable layer arrangement. - km=2+nn - kn=kintr-1+nn - if ((kfpla(i-1,j,n).lt.kintr.and. - . upsilon(3)-upsilon(kintr+1).gt.0..and. - . rho(p(i ,j,3),temp(i-1,j,kn),saln(i-1,j,kn)).gt. - . rho(p(i ,j,3),temp(i ,j,km),saln(i ,j,km))).or. - . (kfpla(i ,j,n).lt.kintr.and. - . upsilon(3)-upsilon(kintr+1).lt.0..and. - . rho(p(i-1,j,3),temp(i ,j,kn),saln(i ,j,kn)).gt. - . rho(p(i-1,j,3),temp(i-1,j,km),saln(i-1,j,km)))) then - kintr=kintr-1 - upsilon(kintr+1)=upsilon(kintr+2) - endif -c -c --- ----- Assign interface mass fluxes. - kmin=kintr-1 - mfl(kmin)=0. - mfl(kintr)=et2mf*upsilon(3) - do k=kintr+1,kmax - mfl(k)=et2mf*upsilon(k) - enddo - mfl(kmax+1)=0. -c - endif -c -c --- ------------------------------------------------------------------ -c --- --- Ensure that mass fluxes do not create negative layer -c --- --- thicknesses. -c --- ------------------------------------------------------------------ -c -c --- --- Compute the layer thicknesses available to be depleted by mass -c --- --- fluxes at the scalar points adjacent to the velocity point. -c --- --- These bounded layer thicknesses are consistent with the -c --- --- transport algorithm. - dlm(kmin)=max(0.,min(p(i-1,j,3),pbu(i,j,n)) - . -max(p(i-1,j,1),ptu(i,j))) - dlp(kmin)=max(0.,min(p(i ,j,3),pbu(i,j,n)) - . -max(p(i ,j,1),ptu(i,j))) - do k=kintr,kmax - dlm(k)=max(0.,min(p(i-1,j,k+1),pbu(i,j,n)) - . -max(p(i-1,j,k ),ptu(i,j))) - dlp(k)=max(0.,min(p(i ,j,k+1),pbu(i,j,n)) - . -max(p(i ,j,k ),ptu(i,j))) - enddo -c -c --- --- If excessive depletion of layers occur beneath the mixed layer -c --- --- base, try to adjust interface fluxes other that the mixed -c --- --- layer base interface flux. - fhi= fface - . *max(0.,min((p(i-1,j,3)-ptu(i,j))*scp2(i-1,j), - . (pbu(i,j,n)-p(i ,j,kintr))*scp2(i ,j))) - flo=-fface - . *max(0.,min((p(i ,j,3)-ptu(i,j))*scp2(i ,j), - . (pbu(i,j,n)-p(i-1,j,kintr))*scp2(i-1,j))) - mfl(kmin+1)=min(fhi,max(flo,mfl(kmin+1))) - do k=kmin+1,kmax-1 - if (mfl(k+1)-mfl(k).gt. - . ffac*max(epsil,dlm(k))*scp2(i-1,j)) then - mfl(k+1)=mfl(k )+fface*dlm(k)*scp2(i-1,j) - elseif (mfl(k+1)-mfl(k).lt. - . -ffac*max(epsil,dlp(k))*scp2(i ,j)) then - mfl(k+1)=mfl(k )-fface*dlp(k)*scp2(i ,j) - else - exit - endif - enddo -c -c --- --- Apply an iterative procedure for flux limiting by alternate -c --- --- upward and downward propagation through the layers. -c - changed=.true. - niter=0 - kdir=1 -c - do while (changed) -c - niter=niter+1 - if (niter.eq.1000) then - k=kmin - write (lp,*) - write (lp,'(i3,3e16.8)') 1,mfl(k+1),mfl(k), - . (mfl(k+1)-mfl(k)) - . /(max(onemm,dpu(i,j,1+nn)+dpu(i,j,2+nn))*delt1*scuy(i,j)) - do k=kintr,kmax - kn=k+nn - write (lp,'(i3,3e16.8)') k,mfl(k+1),mfl(k), - . (mfl(k+1)-mfl(k))/(max(onemm,dpu(i,j,kn))*delt1*scuy(i,j)) - enddo - write (lp,*) 'no convergence u',i+i0,j+j0 - call xchalt('(eddtra_gm)') - stop '(eddtra_gm)' - endif -c - changed=.false. - kdir=-kdir -c - do k=((1-kdir)*kmax+(1+kdir)*kmin)/2, - . ((1-kdir)*kmin+(1+kdir)*kmax)/2,kdir -c -c --- ------- Proceed with flux limiting of this layer if the mass flux -c --- ------- difference between lower and upper interface is beyond the -c --- ------- floating point accuracy limitation. - if (abs(mfl(k+1)-mfl(k)).gt. - . 1.e-14*max(epsil*scu2(i,j),abs(mfl(k+1)+mfl(k)))) then -c - if (mfl(k+1)-mfl(k).gt. - . ffac*max(epsil,dlm(k))*scp2(i-1,j)) then -c -c --- ----------- In this case, the mass fluxes are removing too much -c --- ----------- mass from the grid cell at (i-1,j,k). Limit the -c --- ----------- dominating interface flux. - q=fface*dlm(k)*scp2(i-1,j) - if (mfl(k+1).gt.-mfl(k)) then - if (mfl(k ).gt.-.5*q) then - mfl(k+1)=mfl(k )+q - else - mfl(k+1)= .5*q - mfl(k )=-mfl(k+1) - endif - else - if (mfl(k+1).lt. .5*q) then - mfl(k )=mfl(k+1)-q - else - mfl(k )=-.5*q - mfl(k+1)=-mfl(k ) - endif - endif - changed=.true. - elseif (mfl(k+1)-mfl(k).lt. - . -ffac*max(epsil,dlp(k))*scp2(i ,j)) then -c -c --- ----------- In this case, the mass fluxes are removing too much -c --- ----------- mass from the grid cell at (i ,j,k). Limit the -c --- ----------- dominating interface flux. - q=fface*dlp(k)*scp2(i ,j) - if (mfl(k+1).lt.-mfl(k)) then - if (mfl(k ).lt. .5*q) then - mfl(k+1)=mfl(k )-q - else - mfl(k+1)=-.5*q - mfl(k )=-mfl(k+1) - endif - else - if (mfl(k+1).gt.-.5*q) then - mfl(k )=mfl(k+1)+q - else - mfl(k )= .5*q - mfl(k+1)=-mfl(k ) - endif - endif - changed=.true. - endif - endif -c - enddo -c - enddo -c -c --- ------------------------------------------------------------------ -c --- --- Compute the final mass fluxes. -c --- ------------------------------------------------------------------ -c - k=kmin - if (abs(mfl(k+1)-mfl(k)).gt. - . 1.e-14*max(epsil*scu2(i,j),abs(mfl(k+1)+mfl(k)))) then - umfltd(i,j,2+mm)=mfl(k+1)-mfl(k) - umfltd(i,j,1+mm)=umfltd(i,j,2+mm) - . *dpu(i,j,1+nn)/(dpu(i,j,1+nn) - . +dpu(i,j,2+nn)) - umfltd(i,j,2+mm)=umfltd(i,j,2+mm)-umfltd(i,j,1+mm) - else - umfltd(i,j,1+mm)=0. - umfltd(i,j,2+mm)=0. - endif - do k=kintr,kmax - km=k+mm - if (abs(mfl(k+1)-mfl(k)).gt. - . 1.e-14*max(epsil*scu2(i,j),abs(mfl(k+1)+mfl(k)))) then - umfltd(i,j,km)=mfl(k+1)-mfl(k) - else - umfltd(i,j,km)=0. - endif - if (umfltd(i,j,km).gt. - . ffac*max(epsil,dlm(k))*scp2(i-1,j)) then - write (lp,*) 'eddtra_gm u >',i+i0,j+j0,k,umfltd(i,j,km), - . ffac*max(epsil,dlm(k))*scp2(i-1,j) - call xchalt('(eddtra_gm)') - stop '(eddtra_gm)' - endif - if (umfltd(i,j,km).lt. - . -ffac*max(epsil,dlp(k))*scp2(i ,j)) then - write (lp,*) 'eddtra_gm u <',i+i0,j+j0,k,umfltd(i,j,km), - . -ffac*max(epsil,dlp(k))*scp2(i ,j) - call xchalt('(eddtra_gm)') - stop '(eddtra_gm)' - endif - enddo -c - enddo - enddo - enddo -c$OMP END PARALLEL DO -c -c --- ------------------------------------------------------------------ -c --- Compute v-component of eddy-induced mass fluxes. -c --- ------------------------------------------------------------------ -c -c$OMP PARALLEL DO PRIVATE( -c$OMP+ l,i,k,km,et2mf,kmax,kn,kintr,kappa,upsilon, -c$OMP+ kmin,mfl,dlm,dlp,fhi,flo,changed,niter,kdir,q) - do j=0,jj+2 - do l=1,isv(j) - do i=max(-1,ifv(j,l)),min(ii+2,ilv(j,l)) -c -c --- ------------------------------------------------------------------ -c --- --- Set eddy-induced mass fluxes to zero initially. -c --- ------------------------------------------------------------------ -c - do k=1,kk - km=k+mm - vmfltd(i,j,km)=0. - enddo -c -c --- --- Eddy transport to mass flux conversion factor. - et2mf=-g*rho0*delt1*scvx(i,j) -c -c --- --- Index of last layer containing mass at either of the scalar -c --- --- points adjacent to the velocity point. - kmax=1 - do k=3,kk - kn=k+nn - if (dp(i,j-1,kn).gt.epsil.or.dp(i,j,kn).gt.epsil) kmax=k - enddo -c -c --- ------------------------------------------------------------------ -c --- --- Proceed with mass flux computation if at least one of the -c --- --- adjacent scalar points to the velocity point has a mass -c --- --- containing interior layer. Mass fluxes will be assigned at -c --- --- layer interface corresponding to the eddy induced transport. -c --- --- The final layer mass flux will be the lower minus the upper -c --- --- interface flux. The mass fluxes are limited to keep -c --- --- interfaces within the water column. There are 3 cases to -c --- --- consider: -c --- --- Case 1: The mixed layer extends to the bottom at both -c --- --- adjacent scalar points to the velocity point -c --- --- Case 2: The mixed layer extends to the bottom at scalar -c --- --- point (i,j ). -c --- --- Case 3: The mixed layer extends to the bottom at scalar -c --- --- point (i,j-1). -c --- --- Case 4: The mixed layer does not reach the bottom at neither -c --- --- of the scalar points adjacent to the velocity point. -c --- ------------------------------------------------------------------ -c - if (kfpla(i,j-1,n).gt.kk.and.kfpla(i,j,n).gt.kk) then -c -c --- ------------------------------------------------------------------ -c --- ----- Case 1: -c --- ------------------------------------------------------------------ -c -c --- ----- Keep the initial zero mass fluxes for this column. - cycle -c - elseif (kfpla(i,j-1,n).le.kk.and.kfpla(i,j,n).gt.kk) then -c -c --- ------------------------------------------------------------------ -c --- ----- Case 2: -c --- ------------------------------------------------------------------ -c -c --- ----- Find the index of the first layer at (i,j-1) that is -c --- ----- hydrostatically stable at the mixed layer base at (i,j ). - km=2+nn - kintr=kfpla(i,j-1,n) - kn=kintr+nn - do while - . (rho(p(i,j ,3),temp(i,j-1,kn),saln(i,j-1,kn)).lt. - . rho(p(i,j ,3),temp(i,j ,km),saln(i,j ,km)).or. - . dp(i,j-1,kn).lt.epsil) - kintr=kintr+1 - if (kintr.eq.kmax+1) exit - kn=kintr+nn - enddo -c -c --- ----- If a physical layer cannot be found, keep the initial zero -c --- ----- mass fluxes for this column. - if (kintr.eq.kmax+1) cycle -c -c --- ----- Compute the eddy induced transport (upsilon) at the mixed -c --- ----- layer base. - kappa=.5*(difint(i,j-1,2)+difint(i,j,2)) - upsilon(3)=-kappa*nslpy(i,j,3) -c -c --- ----- If the eddy-induced transport at the base of the mixed layer -c --- ----- would cause a negative mass flux below the mixed layer, keep -c --- ----- the initial zero mass fluxes for this column. - if (upsilon(3).le.0.) cycle -c -c --- ----- Assign interface mass fluxes. - kmin=kintr-1 - mfl(kmin)=0. - mfl(kintr)=et2mf*upsilon(3) - do k=kintr+1,kmax+1 - mfl(k)=0. - enddo -c - elseif (kfpla(i,j-1,n).gt.kk.and.kfpla(i,j,n).le.kk) then -c -c --- ------------------------------------------------------------------ -c --- ----- Case 3: -c --- ------------------------------------------------------------------ -c -c --- ----- Find the index of the first layer at (i,j ) that is -c --- ----- hydrostatically stable at the mixed layer base at (i,j-1). - km=2+nn - kintr=kfpla(i,j ,n) - kn=kintr+nn - do while - . (rho(p(i,j-1,3),temp(i,j ,kn),saln(i,j ,kn)).lt. - . rho(p(i,j-1,3),temp(i,j-1,km),saln(i,j-1,km)).or. - . dp(i,j ,kn).lt.epsil) - kintr=kintr+1 - if (kintr.eq.kmax+1) exit - kn=kintr+nn - enddo -c -c --- ----- If a physical layer cannot be found, keep the initial zero -c --- ----- mass fluxes for this column. - if (kintr.eq.kmax+1) cycle -c -c --- ----- Compute the eddy induced transport (upsilon) at the mixed -c --- ----- layer base. - kappa=.5*(difint(i,j-1,2)+difint(i,j,2)) - upsilon(3)=-kappa*nslpy(i,j,3) -c -c --- ----- If the eddy-induced transport at the base of the mixed layer -c --- ----- would cause a positive mass flux below the mixed layer, keep -c --- ----- the initial zero mass fluxes for this column. - if (upsilon(3).ge.0.) cycle -c -c --- ----- Assign interface mass fluxes. - kmin=kintr-1 - mfl(kmin)=0. - mfl(kintr)=et2mf*upsilon(3) - do k=kintr+1,kmax+1 - mfl(k)=0. - enddo -c - else -c -c --- ------------------------------------------------------------------ -c --- ----- Case 4: -c --- ------------------------------------------------------------------ -c -c --- ----- The first interior interface where the eddy induced -c --- ----- transport is estimated is at index kintr+1. - kintr=max(kfpla(i,j-1,n),kfpla(i,j,n)) -c -c --- ----- Compute the eddy induced transport (upsilon) at the mixed -c --- ----- layer base. - kappa=.5*(difint(i,j-1,2)+difint(i,j,2)) - upsilon(3)=-kappa*nslpy(i,j,3) -c -c --- ----- Compute the eddy induced transport at interior interfaces. - do k=kintr+1,kmax - kn=k+nn - kappa=.25*(difint(i,j-1,k-1)+difint(i,j ,k-1) - . +difint(i,j-1,k )+difint(i,j ,k )) - upsilon(k)=-kappa*nslpy(i,j,k) - enddo - upsilon(kmax+1)=0. -c -c --- ----- If the layer kintr-1 is a physical layer at either of the -c --- ----- adjacent scalar points to the velocity point, then apply -c --- ----- an upper interface mass flux corresponding to the eddy -c --- ----- induced transport at the mixed layer base and a lower -c --- ----- interface mass flux corresponding to the eddy induced -c --- ----- transport at the kintr+1 interface if this would lead to a -c --- ----- hydrostatically stable layer arrangement. - km=2+nn - kn=kintr-1+nn - if ((kfpla(i,j-1,n).lt.kintr.and. - . upsilon(3)-upsilon(kintr+1).gt.0..and. - . rho(p(i,j ,3),temp(i,j-1,kn),saln(i,j-1,kn)).gt. - . rho(p(i,j ,3),temp(i,j ,km),saln(i,j ,km))).or. - . (kfpla(i,j ,n).lt.kintr.and. - . upsilon(3)-upsilon(kintr+1).lt.0..and. - . rho(p(i,j-1,3),temp(i,j ,kn),saln(i,j ,kn)).gt. - . rho(p(i,j-1,3),temp(i,j-1,km),saln(i,j-1,km)))) then - kintr=kintr-1 - upsilon(kintr+1)=upsilon(kintr+2) - endif -c -c --- ----- Assign interface mass fluxes. - kmin=kintr-1 - mfl(kmin)=0. - mfl(kintr)=et2mf*upsilon(3) - do k=kintr+1,kmax - mfl(k)=et2mf*upsilon(k) - enddo - mfl(kmax+1)=0. -c - endif -c -c --- ------------------------------------------------------------------ -c --- --- Ensure that mass fluxes do not create negative layer -c --- --- thicknesses. -c --- ------------------------------------------------------------------ -c -c --- --- Compute the layer thicknesses available to be depleted by mass -c --- --- fluxes at the scalar points adjacent to the velocity point. -c --- --- These bounded layer thicknesses are consistent with the -c --- --- transport algorithm. - dlm(kmin)=max(0.,min(p(i,j-1,3),pbv(i,j,n)) - . -max(p(i,j-1,1),ptv(i,j))) - dlp(kmin)=max(0.,min(p(i,j ,3),pbv(i,j,n)) - . -max(p(i,j ,1),ptv(i,j))) - do k=kintr,kmax - dlm(k)=max(0.,min(p(i,j-1,k+1),pbv(i,j,n)) - . -max(p(i,j-1,k ),ptv(i,j))) - dlp(k)=max(0.,min(p(i,j ,k+1),pbv(i,j,n)) - . -max(p(i,j ,k ),ptv(i,j))) - enddo -c -c --- --- If excessive depletion of layers occur beneath the mixed layer -c --- --- base, try to adjust interface fluxes other that the mixed -c --- --- layer base interface flux. - fhi= fface - . *max(0.,min((p(i,j-1,3)-ptv(i,j))*scp2(i,j-1), - . (pbv(i,j,n)-p(i,j ,kintr))*scp2(i,j ))) - flo=-fface - . *max(0.,min((p(i,j ,3)-ptv(i,j))*scp2(i,j ), - . (pbv(i,j,n)-p(i,j-1,kintr))*scp2(i,j-1))) - mfl(kmin+1)=min(fhi,max(flo,mfl(kmin+1))) - do k=kmin+1,kmax-1 - if (mfl(k+1)-mfl(k).gt. - . ffac*max(epsil,dlm(k))*scp2(i,j-1)) then - mfl(k+1)=mfl(k )+fface*dlm(k)*scp2(i,j-1) - elseif (mfl(k+1)-mfl(k).lt. - . -ffac*max(epsil,dlp(k))*scp2(i,j )) then - mfl(k+1)=mfl(k )-fface*dlp(k)*scp2(i,j ) - else - exit - endif - enddo -c -c --- --- Apply an iterative procedure for flux limiting by alternate -c --- --- upward and downward propagation through the layers. -c - changed=.true. - niter=0 - kdir=1 -c - do while (changed) -c - niter=niter+1 - if (niter.eq.1000) then - k=kmin - write (lp,*) - write (lp,'(i3,3e16.8)') 1,mfl(k+1),mfl(k), - . (mfl(k+1)-mfl(k)) - . /(max(onemm,dpv(i,j,1+nn)+dpv(i,j,2+nn))*delt1*scvx(i,j)) - do k=kintr,kmax - kn=k+nn - write (lp,'(i3,3e16.8)') k,mfl(k+1),mfl(k), - . (mfl(k+1)-mfl(k))/(max(onemm,dpv(i,j,kn))*delt1*scvx(i,j)) - enddo - write (lp,*) 'no convergence v',i+i0,j+j0 - call xchalt('(eddtra_gm)') - stop '(eddtra_gm)' - endif -c - changed=.false. - kdir=-kdir -c - do k=((1-kdir)*kmax+(1+kdir)*kmin)/2, - . ((1-kdir)*kmin+(1+kdir)*kmax)/2,kdir -c -c --- ------- Proceed with flux limiting of this layer if the mass flux -c --- ------- difference between lower and upper interface is beyond the -c --- ------- floating point accuracy limitation. - if (abs(mfl(k+1)-mfl(k)).gt. - . 1.e-14*max(epsil*scv2(i,j),abs(mfl(k+1)+mfl(k)))) then -c - if (mfl(k+1)-mfl(k).gt. - . ffac*max(epsil,dlm(k))*scp2(i,j-1)) then -c -c --- ----------- In this case, the mass fluxes are removing too much -c --- ----------- mass from the grid cell at (i,j-1,k). Limit the -c --- ----------- dominating interface flux. - q=fface*dlm(k)*scp2(i,j-1) - if (mfl(k+1).gt.-mfl(k)) then - if (mfl(k ).gt.-.5*q) then - mfl(k+1)=mfl(k )+q - else - mfl(k+1)= .5*q - mfl(k )=-mfl(k+1) - endif - else - if (mfl(k+1).lt. .5*q) then - mfl(k )=mfl(k+1)-q - else - mfl(k )=-.5*q - mfl(k+1)=-mfl(k ) - endif - endif - changed=.true. - elseif (mfl(k+1)-mfl(k).lt. - . -ffac*max(epsil,dlp(k))*scp2(i,j )) then -c -c --- ----------- In this case, the mass fluxes are removing too much -c --- ----------- mass from the grid cell at (i,j ,k). Limit the -c --- ----------- dominating interface flux. - q=fface*dlp(k)*scp2(i,j ) - if (mfl(k+1).lt.-mfl(k)) then - if (mfl(k ).lt. .5*q) then - mfl(k+1)=mfl(k )-q - else - mfl(k+1)=-.5*q - mfl(k )=-mfl(k+1) - endif - else - if (mfl(k+1).gt.-.5*q) then - mfl(k )=mfl(k+1)+q - else - mfl(k )= .5*q - mfl(k+1)=-mfl(k ) - endif - endif - changed=.true. - endif - endif -c - enddo -c - enddo -c -c --- ------------------------------------------------------------------ -c --- --- Compute the final mass fluxes. -c --- ------------------------------------------------------------------ -c - k=kmin - if (abs(mfl(k+1)-mfl(k)).gt. - . 1.e-14*max(epsil*scv2(i,j),abs(mfl(k+1)+mfl(k)))) then - vmfltd(i,j,2+mm)=mfl(k+1)-mfl(k) - vmfltd(i,j,1+mm)=vmfltd(i,j,2+mm) - . *dpv(i,j,1+nn)/(dpv(i,j,1+nn) - . +dpv(i,j,2+nn)) - vmfltd(i,j,2+mm)=vmfltd(i,j,2+mm)-vmfltd(i,j,1+mm) - else - vmfltd(i,j,1+mm)=0. - vmfltd(i,j,2+mm)=0. - endif - do k=kintr,kmax - km=k+mm - if (abs(mfl(k+1)-mfl(k)).gt. - . 1.e-14*max(epsil*scv2(i,j),abs(mfl(k+1)+mfl(k)))) then - vmfltd(i,j,km)=mfl(k+1)-mfl(k) - else - vmfltd(i,j,km)=0. - endif - if (vmfltd(i,j,km).gt. - . ffac*max(epsil,dlm(k))*scp2(i,j-1)) then - write (lp,*) 'eddtra_gm v >',i+i0,j+j0,k,vmfltd(i,j,km), - . ffac*max(epsil,dlm(k))*scp2(i,j-1) - call xchalt('(eddtra_gm)') - stop '(eddtra_gm)' - endif - if (vmfltd(i,j,km).lt. - . -ffac*max(epsil,dlp(k))*scp2(i,j )) then - write (lp,*) 'eddtra_gm v <',i+i0,j+j0,k,vmfltd(i,j,km), - . -ffac*max(epsil,dlp(k))*scp2(i,j ) - call xchalt('(eddtra_gm)') - stop '(eddtra_gm)' - endif - enddo -c - enddo - enddo - enddo -c$OMP END PARALLEL DO -c - end subroutine eddtra_gm -c - end module mod_eddtra diff --git a/phy/mod_eddtra.F90 b/phy/mod_eddtra.F90 new file mode 100644 index 00000000..1490cf92 --- /dev/null +++ b/phy/mod_eddtra.F90 @@ -0,0 +1,1480 @@ +! ------------------------------------------------------------------------------ +! Copyright (C) 2015-2022 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_eddtra +! ------------------------------------------------------------------------------ +! This module contains procedures related to the computation of eddy-induced +! transport. +! ------------------------------------------------------------------------------ + + use mod_types, only: r8 + use mod_constants, only: g, alpha0, rho0, epsilp, onem, onecm, onemm, & + L_mks2cgs + use mod_time, only: delt1 + use mod_xc + use mod_vcoord, only: vcoord_type_tag, isopyc_bulkml, cntiso_hybrid + use mod_grid, only: scuy, scvx, scp2, scu2, scv2, scuxi, scvyi + use mod_eos, only: rho + use mod_state, only: dp, dpu, dpv, temp, saln, p, pbu, pbv, kfpla + use mod_diffusion, only: eitmth_opt, eitmth_intdif, eitmth_gm, & + difint, umfltd, vmfltd, utfltd, vtfltd, & + usfltd, vsfltd + use mod_cmnfld, only: nslpx, nslpy, mlts + use mod_checksum, only: csdiag, chksummsk + + implicit none + + real(r8), parameter :: & + iL_mks2cgs = 1./L_mks2cgs + + private + + public :: eddtra + +contains + + ! --------------------------------------------------------------------------- + ! Private procedures. + ! --------------------------------------------------------------------------- + + subroutine eddtra_intdif_isopyc_bulkml(m, n, mm, nn, k1m, k1n) + ! --------------------------------------------------------------------------- + ! Estimate eddy-induced transport by interface diffusion. + ! --------------------------------------------------------------------------- + + integer, intent(in) :: m, n, mm, nn, k1m, k1n + + real(r8) :: flxhi, flxlo, q + integer :: i, j, k, l, km, kn + + call xctilr(difint, 1,kk, 2,2, halo_ps) + + !$omp parallel do private(l, i) + do j = - 1, jj + 2 + do l = 1, isu(j) + do i = max(0, ifu(j, l)), min(ii + 2, ilu(j, l)) + umfltd(i, j, 1 + mm) = 0._r8 + umfltd(i, j, 2 + mm) = 0._r8 + umfltd(i, j, 3 + mm) = 0._r8 + enddo + enddo + enddo + !$omp end parallel do + !$omp parallel do private(l, i) + do j = 0, jj + 2 + do l = 1, isv(j) + do i = max(- 1, ifv(j, l)), min(ii + 2, ilv(j, l)) + vmfltd(i, j, 1 + mm) = 0._r8 + vmfltd(i, j, 2 + mm) = 0._r8 + vmfltd(i, j, 3 + mm) = 0._r8 + enddo + enddo + enddo + !$omp end parallel do + + do k = 4, kk + km = k + mm + kn = k + nn + + !$omp parallel do private(l, i, flxhi, flxlo, q) + do j = - 1, jj + 2 + do l = 1, isu(j) + do i = max(0, ifu(j, l)), min(ii + 2, ilu(j, l)) + flxhi = .125_r8*min(dp(i - 1, j, kn - 1)*scp2(i - 1, j), & + dp(i , j, kn )*scp2(i , j)) + flxlo = - .125_r8*min(dp(i , j, kn - 1)*scp2(i , j), & + dp(i - 1, j, kn )*scp2(i - 1, j)) + q = .25_r8*( difint(i - 1, j, k - 1) + difint(i, j, k - 1) & + + difint(i - 1, j, k ) + difint(i, j, k )) + q = min(flxhi, max(flxlo, & + delt1*q*(p(i - 1, j, k) - p(i, j, k)) & + *scuy(i, j)*scuxi(i, j))) + umfltd(i, j, km - 1) = umfltd(i, j, km - 1) + q + umfltd(i, j, km ) = - q + enddo + enddo + enddo + !$omp end parallel do + + !$omp parallel do private(l, i, flxhi, flxlo, q) + do j = 0, jj + 2 + do l = 1, isv(j) + do i = max(- 1, ifv(j, l)), min(ii + 2, ilv(j, l)) + flxhi = .125_r8*min(dp(i, j - 1, kn - 1)*scp2(i, j - 1), & + dp(i, j , kn )*scp2(i, j )) + flxlo = - .125_r8*min(dp(i, j , kn - 1)*scp2(i, j ), & + dp(i, j - 1, kn )*scp2(i, j - 1)) + q = .25_r8*( difint(i, j - 1, k - 1) + difint(i, j, k - 1) & + + difint(i, j - 1, k ) + difint(i, j, k )) + q = min(flxhi, max(flxlo, & + delt1*q*(p(i, j - 1, k) - p(i, j, k)) & + *scvx(i, j)*scvyi(i, j))) + vmfltd(i, j, km - 1) = vmfltd(i, j, km - 1) + q + vmfltd(i, j, km ) = - q + enddo + enddo + enddo + !$omp end parallel do + + enddo + + end subroutine eddtra_intdif_isopyc_bulkml + + subroutine eddtra_gm_isopyc_bulkml(m, n, mm, nn, k1m, k1n) + ! --------------------------------------------------------------------------- + ! Estimate eddy-induced transport following the Gent-McWilliams + ! parameterization. + ! --------------------------------------------------------------------------- + + integer, intent(in) :: m, n, mm, nn, k1m, k1n + + ! Parameters: + real(r8), parameter :: & + ffac = .0625_r8, & ! Fraction of the mass of a grid cell a mass flux + ! is allowed to deplete []. + fface = .99_r8*ffac ! (1-epsilon)*ffac []. + + real(r8), dimension(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy) :: ptu, ptv + real(r8), dimension(kdm+1) :: upsilon, mfl + real(r8), dimension(kdm) :: dlm, dlp + real(r8) :: q, et2mf, kappa, fhi, flo + integer :: i, j, k, l, km, kn, kintr, kmax, kmin, niter, kdir + logical :: changed + + call xctilr(difint, 1, kk, 2, 2, halo_ps) + call xctilr(pbu, 1, 2, 2, 2, halo_us) + call xctilr(pbv, 1, 2, 2, 2, halo_vs) + + + ! Compute top pressure at velocity points. + !$omp parallel do private(l, i) + do j= - 1, jj + 2 + do l = 1, isu(j) + do i = max(0, ifu(j, l)), min(ii + 2, ilu(j, l)) + ptu(i, j) = max(p(i - 1, j, 1), p(i, j, 1)) + enddo + enddo + enddo + !$omp end parallel do + !$omp parallel do private(l, i) + do j = 0, jj + 2 + do l = 1, isv(j) + do i = max(- 1, ifv(j, l)), min(ii + 2, ilv(j, l)) + ptv(i, j) = max(p(i, j - 1, 1), p(i, j, 1)) + enddo + enddo + enddo + !$omp end parallel do + + ! ------------------------------------------------------------------------- + ! Compute u-component of eddy-induced mass fluxes. + ! ------------------------------------------------------------------------- + + !$omp parallel do private(l, i, k, km, et2mf, kmax, kn, kintr, kappa, & + !$omp upsilon, kmin, mfl, dlm, dlp, fhi, flo, changed, & + !$omp niter, kdir, q) + do j = - 1, jj + 2 + do l = 1, isu(j) + do i = max(0, ifu(j, l)), min(ii + 2, ilu(j, l)) + + ! Set eddy-induced mass fluxes to zero initially. + do k = 1, kk + km = k + mm + umfltd(i, j, km) = 0._r8 + enddo + + ! Eddy transport to mass flux conversion factor. + et2mf = - g*rho0*delt1*scuy(i, j) + + ! Index of last layer containing mass at either of the scalar points + ! adjacent to the velocity point. + kmax = 1 + do k = 3, kk + kn = k + nn + if (dp(i - 1, j, kn) > epsilp .or. dp(i, j, kn) > epsilp) & + kmax = k + enddo + + ! ------------------------------------------------------------------ + ! Proceed with mass flux computation if at least one of the adjacent + ! scalar points to the velocity point has a mass containing interior + ! layer. Mass fluxes will be assigned at layer interface + ! corresponding to the eddy induced transport. The final layer mass + ! flux will be the lower minus the upper interface flux. The mass + ! fluxes are limited to keep interfaces within the water column. + ! There are 3 cases to consider: + ! Case 1: The mixed layer extends to the bottom at both adjacent + ! scalar points to the velocity point + ! Case 2: The mixed layer extends to the bottom at scalar point + ! (i, j). + ! Case 3: The mixed layer extends to the bottom at scalar point + ! (i - 1, j). + ! Case 4: The mixed layer does not reach the bottom at neither of + ! the scalar points adjacent to the velocity point. + ! ------------------------------------------------------------------ + + if (kfpla(i - 1, j, n) > kk .and. kfpla(i, j, n) > kk) then + ! --------------------------------------------------------------- + ! Case 1: + ! --------------------------------------------------------------- + + ! Keep the initial zero mass fluxes for this column. + cycle + + elseif (kfpla(i - 1, j, n) <= kk .and. kfpla(i, j, n) > kk) then + ! --------------------------------------------------------------- + ! Case 2: + ! --------------------------------------------------------------- + + ! Find the index of the first layer at (i - 1, j) that is + ! hydrostatically stable at the mixed layer base at (i, j). + km = 2 + nn + kintr = kfpla(i - 1, j, n) + kn = kintr + nn + do while (rho(p(i , j, 3), & + temp(i - 1, j, kn), saln(i - 1, j, kn)) < & + rho(p(i , j, 3), & + temp(i , j, km), saln(i , j, km)) .or. & + dp(i - 1, j, kn) < epsilp) + kintr = kintr + 1 + if (kintr == kmax + 1) exit + kn = kintr + nn + enddo + + ! If a physical layer cannot be found, keep the initial zero mass + ! fluxes for this column. + if (kintr == kmax + 1) cycle + + ! Compute the eddy induced transport (upsilon) at the mixed layer + ! base. + kappa = .5_r8*(difint(i - 1, j, 2) + difint(i, j, 2)) + upsilon(3) = - kappa*nslpx(i, j, 3) + + ! If the eddy-induced transport at the base of the mixed layer + ! would cause a negative mass flux below the mixed layer, keep + ! the initial zero mass fluxes for this column. + if (upsilon(3) <= 0._r8) cycle + + ! Assign interface mass fluxes. + kmin = kintr - 1 + mfl(kmin) = 0._r8 + mfl(kintr) = et2mf*upsilon(3) + do k = kintr + 1, kmax + 1 + mfl(k) = 0._r8 + enddo + + elseif (kfpla(i - 1, j, n) > kk .and. kfpla(i, j, n) <= kk) then + ! --------------------------------------------------------------- + ! Case 3: + ! --------------------------------------------------------------- + + ! Find the index of the first layer at (i, j) that is + ! hydrostatically stable at the mixed layer base at (i - 1, j). + km = 2 + nn + kintr = kfpla(i , j, n) + kn = kintr + nn + do while (rho(p(i - 1, j, 3), & + temp(i , j, kn), saln(i , j, kn)) < & + rho(p(i - 1, j, 3), & + temp(i - 1, j, km), saln(i - 1, j, km)) .or. & + dp(i , j, kn) < epsilp) + kintr = kintr + 1 + if (kintr == kmax + 1) exit + kn = kintr + nn + enddo + + ! If a physical layer cannot be found, keep the initial zero mass + ! fluxes for this column. + if (kintr == kmax + 1) cycle + + ! Compute the eddy induced transport (upsilon) at the mixed layer + ! base. + kappa = .5_r8*(difint(i - 1, j, 2) + difint(i, j, 2)) + upsilon(3) = - kappa*nslpx(i, j, 3) + + ! If the eddy-induced transport at the base of the mixed layer + ! would cause a positive mass flux below the mixed layer, keep + ! the initial zero mass fluxes for this column. + if (upsilon(3) >= 0._r8) cycle + + ! Assign interface mass fluxes. + kmin = kintr - 1 + mfl(kmin) = 0._r8 + mfl(kintr) = et2mf*upsilon(3) + do k = kintr + 1, kmax + 1 + mfl(k) = 0._r8 + enddo + + else + ! --------------------------------------------------------------- + ! Case 4: + ! --------------------------------------------------------------- + + ! The first interior interface where the eddy induced transport + ! is estimated is at index kintr + 1. + kintr = max(kfpla(i - 1, j, n), kfpla(i, j, n)) + + ! Compute the eddy induced transport (upsilon) at the mixed layer + ! base. + kappa = .5_r8*(difint(i - 1, j, 2) + difint(i, j, 2)) + upsilon(3) = - kappa*nslpx(i, j, 3) + + ! Compute the eddy induced transport at interior interfaces. + do k = kintr + 1, kmax + kn = k + nn + kappa = .25_r8*( difint(i - 1, j, k - 1) & + + difint(i , j, k - 1) & + + difint(i - 1, j, k ) & + + difint(i , j, k )) + upsilon(k) = - kappa*nslpx(i, j, k) + enddo + upsilon(kmax + 1) = 0._r8 + + ! If the layer kintr - 1 is a physical layer at either of the + ! adjacent scalar points to the velocity point, then apply an + ! upper interface mass flux corresponding to the eddy induced + ! transport at the mixed layer base and a lower interface mass + ! flux corresponding to the eddy induced transport at the + ! kintr + 1 interface if this would lead to a hydrostatically + ! stable layer arrangement. + km = 2 + nn + kn = kintr - 1 + nn + if ((kfpla(i - 1, j, n) < kintr .and. & + upsilon(3) - upsilon(kintr + 1) > 0._r8 .and. & + rho(p(i , j, 3), & + temp(i - 1, j, kn), saln(i - 1, j, kn)) > & + rho(p(i , j, 3), & + temp(i , j, km), saln(i , j, km))) .or. & + (kfpla(i , j, n) < kintr .and. & + upsilon(3) - upsilon(kintr + 1) < 0._r8 .and. & + rho(p(i - 1, j, 3), & + temp(i , j, kn), saln(i , j, kn)) > & + rho(p(i - 1, j, 3), & + temp(i - 1, j, km), saln(i - 1, j, km)))) then + kintr = kintr - 1 + upsilon(kintr + 1) = upsilon(kintr + 2) + endif + + ! Assign interface mass fluxes. + kmin = kintr - 1 + mfl(kmin) = 0._r8 + mfl(kintr) = et2mf*upsilon(3) + do k = kintr + 1, kmax + mfl(k) = et2mf*upsilon(k) + enddo + mfl(kmax + 1) = 0._r8 + + endif + + ! ------------------------------------------------------------------ + ! Ensure that mass fluxes do not create negative layer thicknesses. + ! ------------------------------------------------------------------ + + ! Compute the layer thicknesses available to be depleted by mass + ! fluxes at the scalar points adjacent to the velocity point. These + ! bounded layer thicknesses are consistent with the transport + ! algorithm. + dlm(kmin) = max(0._r8, min(p(i - 1, j, 3), pbu(i, j, n)) & + - max(p(i - 1, j, 1), ptu(i, j))) + dlp(kmin) = max(0._r8, min(p(i , j, 3), pbu(i, j, n)) & + - max(p(i , j, 1), ptu(i, j))) + do k = kintr, kmax + dlm(k) = max(0._r8, min(p(i - 1, j, k + 1), pbu(i, j, n)) & + - max(p(i - 1, j, k ), ptu(i, j))) + dlp(k) = max(0._r8, min(p(i , j, k + 1), pbu(i, j, n)) & + - max(p(i , j, k ), ptu(i, j))) + enddo + + ! If excessive depletion of layers occur beneath the mixed layer + ! base, try to adjust interface fluxes other than the mixed layer + ! base interface flux. + fhi = fface*max(0._r8, min((p(i - 1, j, 3) - ptu(i, j)) & + *scp2(i - 1, j), & + (pbu(i, j, n) - p(i , j, kintr)) & + *scp2(i , j))) + flo = - fface*max(0._r8, min((p(i , j, 3) - ptu(i, j)) & + *scp2(i , j), & + (pbu(i, j, n) - p(i - 1, j, kintr)) & + *scp2(i - 1, j))) + mfl(kmin + 1) = min(fhi, max(flo, mfl(kmin + 1))) + do k = kmin + 1, kmax - 1 + if (mfl(k + 1) - mfl(k) > & + ffac*max(epsilp, dlm(k))*scp2(i - 1, j)) then + mfl(k + 1) = mfl(k) + fface*dlm(k)*scp2(i - 1, j) + elseif (mfl(k + 1) - mfl(k) < & + - ffac*max(epsilp, dlp(k))*scp2(i , j)) then + mfl(k + 1) = mfl(k) - fface*dlp(k)*scp2(i , j) + else + exit + endif + enddo + + ! Apply an iterative procedure for flux limiting by alternate upward + ! and downward propagation through the layers. + + changed = .true. + niter = 0 + kdir = 1 + + do while (changed) + + niter = niter + 1 + if (niter == 1000) then + k = kmin + write(lp,*) + write(lp,'(i3,3e16.8)') & + 1, mfl(k + 1), mfl(k), & + (mfl(k + 1) - mfl(k)) & + /(max(onemm, dpu(i, j, 1 + nn) + dpu(i, j, 2 + nn)) & + *delt1*scuy(i, j)) + do k = kintr, kmax + kn = k + nn + write(lp,'(i3,3e16.8)') & + k, mfl(k + 1), mfl(k), & + (mfl(k + 1) - mfl(k)) & + /(max(onemm, dpu(i, j, kn))*delt1*scuy(i, j)) + enddo + write(lp,*) 'no convergence u', i + i0, j + j0 + call xchalt('(eddtra_gm_isopyc_bulkml)') + stop '(eddtra_gm_isopyc_bulkml)' + endif + + changed = .false. + kdir = - kdir + + do k = ((1 - kdir)*kmax + (1 + kdir)*kmin)/2, & + ((1 - kdir)*kmin + (1 + kdir)*kmax)/2, kdir + + ! Proceed with flux limiting of this layer if the mass flux + ! difference between lower and upper interface is beyond the + ! floating point accuracy limitation. + if (abs(mfl(k + 1) - mfl(k)) > & + 1.e-14_r8*max(epsilp*scu2(i, j), & + abs(mfl(k + 1) + mfl(k)))) then + + if (mfl(k + 1) - mfl(k) > & + ffac*max(epsilp, dlm(k))*scp2(i - 1, j)) then + ! In this case, the mass fluxes are removing too much + ! mass from the grid cell at (i - 1, j, k). Limit the + ! dominating interface flux. + q = fface*dlm(k)*scp2(i - 1, j) + if (mfl(k + 1) > - mfl(k)) then + if (mfl(k ) > - .5_r8*q) then + mfl(k + 1) = mfl(k ) + q + else + mfl(k + 1) = .5_r8*q + mfl(k ) = - mfl(k + 1) + endif + else + if (mfl(k + 1) < .5_r8*q) then + mfl(k ) = mfl(k + 1) - q + else + mfl(k ) = - .5_r8*q + mfl(k + 1) = - mfl(k ) + endif + endif + changed = .true. + elseif (mfl(k + 1) - mfl(k) < & + - ffac*max(epsilp, dlp(k))*scp2(i , j)) then + ! In this case, the mass fluxes are removing too much + ! mass from the grid cell at (i, j, k). Limit the + ! dominating interface flux. + q = fface*dlp(k)*scp2(i , j) + if (mfl(k + 1) < - mfl(k)) then + if (mfl(k ) < .5_r8*q) then + mfl(k + 1) = mfl(k ) - q + else + mfl(k + 1) = - .5_r8*q + mfl(k ) = - mfl(k + 1) + endif + else + if (mfl(k + 1) > - .5_r8*q) then + mfl(k ) = mfl(k + 1) + q + else + mfl(k ) = .5_r8*q + mfl(k + 1) = - mfl(k ) + endif + endif + changed = .true. + endif + endif + + enddo + + enddo + + ! ------------------------------------------------------------------ + ! Compute the final mass fluxes. + ! ------------------------------------------------------------------ + + k = kmin + if (abs(mfl(k + 1) - mfl(k)) > & + 1.e-14_r8*max(epsilp*scu2(i, j), & + abs(mfl(k + 1) + mfl(k)))) then + umfltd(i, j, 2 + mm) = mfl(k + 1) - mfl(k) + umfltd(i, j, 1 + mm) = umfltd(i, j, 2 + mm) & + *dpu(i, j, 1 + nn)/( dpu(i, j, 1 + nn) & + + dpu(i, j, 2 + nn)) + umfltd(i, j, 2 + mm) = umfltd(i, j, 2 + mm) & + - umfltd(i, j, 1 + mm) + else + umfltd(i, j, 1 + mm) = 0._r8 + umfltd(i, j, 2 + mm) = 0._r8 + endif + do k = kintr, kmax + km = k + mm + if (abs(mfl(k + 1) - mfl(k)) > & + 1.e-14_r8*max(epsilp*scu2(i, j), & + abs(mfl(k + 1) + mfl(k)))) then + umfltd(i, j, km) = mfl(k + 1) - mfl(k) + else + umfltd(i, j, km) = 0._r8 + endif + if (umfltd(i, j, km) > & + ffac*max(epsilp, dlm(k))*scp2(i - 1, j)) then + write(lp,*) 'eddtra_gm_isopyc_bulkml u >', & + i + i0, j + j0, k, umfltd(i, j, km), & + ffac*max(epsilp, dlm(k))*scp2(i - 1, j) + call xchalt('(eddtra_gm_isopyc_bulkml)') + stop '(eddtra_gm_isopyc_bulkml)' + endif + if (umfltd(i, j, km) < & + - ffac*max(epsilp, dlp(k))*scp2(i , j)) then + write(lp,*) 'eddtra_gm_isopyc_bulkml u <', & + i + i0, j + j0, k, umfltd(i, j, km), & + - ffac*max(epsilp, dlp(k))*scp2(i , j) + call xchalt('(eddtra_gm_isopyc_bulkml)') + stop '(eddtra_gm_isopyc_bulkml)' + endif + enddo + + enddo + enddo + enddo + !$omp end parallel do + + ! ------------------------------------------------------------------------- + ! Compute v-component of eddy-induced mass fluxes. + ! ------------------------------------------------------------------------- + + !$omp parallel do private(l, i, k, km, et2mf, kmax, kn, kintr, kappa, & + !$omp upsilon, kmin, mfl, dlm, dlp, fhi, flo, changed, & + !$omp niter, kdir, q) + do j = 0, jj + 2 + do l = 1, isv(j) + do i = max(- 1, ifv(j, l)), min(ii + 2, ilv(j, l)) + + ! Set eddy-induced mass fluxes to zero initially. + do k = 1, kk + km = k + mm + vmfltd(i, j, km) = 0._r8 + enddo + + ! Eddy transport to mass flux conversion factor. + et2mf = - g*rho0*delt1*scvx(i, j) + + ! Index of last layer containing mass at either of the scalar points + ! adjacent to the velocity point. + kmax = 1 + do k = 3, kk + kn = k + nn + if (dp(i, j - 1, kn) > epsilp .or. dp(i, j, kn) > epsilp) & + kmax = k + enddo + + ! ------------------------------------------------------------------ + ! Proceed with mass flux computation if at least one of the adjacent + ! scalar points to the velocity point has a mass containing interior + ! layer. Mass fluxes will be assigned at layer interface + ! corresponding to the eddy induced transport. The final layer mass + ! flux will be the lower minus the upper interface flux. The mass + ! fluxes are limited to keep interfaces within the water column. + ! There are 3 cases to consider: + ! Case 1: The mixed layer extends to the bottom at both adjacent + ! scalar points to the velocity point + ! Case 2: The mixed layer extends to the bottom at scalar point + ! (i, j). + ! Case 3: The mixed layer extends to the bottom at scalar point + ! (i, j - 1). + ! Case 4: The mixed layer does not reach the bottom at neither of + ! the scalar points adjacent to the velocity point. + ! ------------------------------------------------------------------ + + if (kfpla(i, j - 1, n) > kk .and. kfpla(i, j, n) > kk) then + ! --------------------------------------------------------------- + ! Case 1: + ! --------------------------------------------------------------- + + ! Keep the initial zero mass fluxes for this column. + cycle + + elseif (kfpla(i, j - 1, n) <= kk .and. kfpla(i, j, n) > kk) then + ! --------------------------------------------------------------- + ! Case 2: + ! --------------------------------------------------------------- + + ! Find the index of the first layer at (i, j - 1) that is + ! hydrostatically stable at the mixed layer base at (i, j). + km = 2 + nn + kintr = kfpla(i, j - 1, n) + kn = kintr + nn + do while (rho(p(i, j , 3), & + temp(i, j - 1, kn), saln(i, j - 1, kn)) < & + rho(p(i, j , 3), & + temp(i, j , km), saln(i, j , km)) .or. & + dp(i, j - 1, kn) < epsilp) + kintr = kintr + 1 + if (kintr == kmax + 1) exit + kn = kintr + nn + enddo + + ! If a physical layer cannot be found, keep the initial zero mass + ! fluxes for this column. + if (kintr == kmax + 1) cycle + + ! Compute the eddy induced transport (upsilon) at the mixed layer + ! base. + kappa = .5_r8*(difint(i, j - 1, 2) + difint(i, j, 2)) + upsilon(3) = - kappa*nslpy(i, j, 3) + + ! If the eddy-induced transport at the base of the mixed layer + ! would cause a negative mass flux below the mixed layer, keep + ! the initial zero mass fluxes for this column. + if (upsilon(3) <= 0._r8) cycle + + ! Assign interface mass fluxes. + kmin = kintr - 1 + mfl(kmin) = 0._r8 + mfl(kintr) = et2mf*upsilon(3) + do k = kintr + 1, kmax + 1 + mfl(k) = 0._r8 + enddo + + elseif (kfpla(i, j - 1, n) > kk .and. kfpla(i, j, n) <= kk) then + ! --------------------------------------------------------------- + ! Case 3: + ! --------------------------------------------------------------- + + ! Find the index of the first layer at (i, j) that is + ! hydrostatically stable at the mixed layer base at (i, j - 1). + km = 2 + nn + kintr = kfpla(i, j , n) + kn = kintr + nn + do while (rho(p(i, j - 1, 3), & + temp(i, j , kn), saln(i, j , kn)) < & + rho(p(i, j - 1, 3), & + temp(i, j - 1, km), saln(i, j - 1, km)) .or. & + dp(i, j , kn) < epsilp) + kintr = kintr + 1 + if (kintr == kmax + 1) exit + kn = kintr + nn + enddo + + ! If a physical layer cannot be found, keep the initial zero mass + ! fluxes for this column. + if (kintr == kmax + 1) cycle + + ! Compute the eddy induced transport (upsilon) at the mixed layer + ! base. + kappa = .5_r8*(difint(i, j - 1, 2) + difint(i, j, 2)) + upsilon(3) = - kappa*nslpy(i, j, 3) + + ! If the eddy-induced transport at the base of the mixed layer + ! would cause a positive mass flux below the mixed layer, keep + ! the initial zero mass fluxes for this column. + if (upsilon(3) >= 0._r8) cycle + + ! Assign interface mass fluxes. + kmin = kintr - 1 + mfl(kmin) = 0._r8 + mfl(kintr) = et2mf*upsilon(3) + do k = kintr + 1, kmax + 1 + mfl(k) = 0._r8 + enddo + + else + ! --------------------------------------------------------------- + ! Case 4: + ! --------------------------------------------------------------- + + ! The first interior interface where the eddy induced transport + ! is estimated is at index kintr + 1. + kintr = max(kfpla(i, j - 1, n), kfpla(i, j, n)) + + ! Compute the eddy induced transport (upsilon) at the mixed layer + ! base. + kappa = .5_r8*(difint(i, j - 1, 2) + difint(i, j, 2)) + upsilon(3) = - kappa*nslpy(i, j, 3) + + ! Compute the eddy induced transport at interior interfaces. + do k = kintr + 1, kmax + kn = k + nn + kappa = .25_r8*( difint(i, j - 1, k - 1) & + + difint(i, j , k - 1) & + + difint(i, j - 1, k ) & + + difint(i, j , k )) + upsilon(k) = - kappa*nslpy(i, j, k) + enddo + upsilon(kmax + 1) = 0._r8 + + ! If the layer kintr - 1 is a physical layer at either of the + ! adjacent scalar points to the velocity point, then apply an + ! upper interface mass flux corresponding to the eddy induced + ! transport at the mixed layer base and a lower interface mass + ! flux corresponding to the eddy induced transport at the + ! kintr + 1 interface if this would lead to a hydrostatically + ! stable layer arrangement. + km = 2 + nn + kn = kintr - 1 + nn + if ((kfpla(i, j - 1, n) < kintr .and. & + upsilon(3) - upsilon(kintr + 1) > 0._r8 .and. & + rho(p(i, j , 3), & + temp(i, j - 1, kn), saln(i, j - 1, kn)) > & + rho(p(i, j , 3), & + temp(i, j , km), saln(i, j , km))) .or. & + (kfpla(i, j , n) < kintr .and. & + upsilon(3) - upsilon(kintr + 1) < 0._r8 .and. & + rho(p(i, j - 1, 3), & + temp(i, j , kn), saln(i, j , kn)) > & + rho(p(i, j - 1, 3), & + temp(i, j - 1, km), saln(i, j - 1, km)))) then + kintr = kintr - 1 + upsilon(kintr + 1) = upsilon(kintr + 2) + endif + + ! Assign interface mass fluxes. + kmin = kintr - 1 + mfl(kmin) = 0._r8 + mfl(kintr) = et2mf*upsilon(3) + do k = kintr + 1, kmax + mfl(k) = et2mf*upsilon(k) + enddo + mfl(kmax + 1) = 0._r8 + + endif + + ! ------------------------------------------------------------------ + ! Ensure that mass fluxes do not create negative layer thicknesses. + ! ------------------------------------------------------------------ + + ! Compute the layer thicknesses available to be depleted by mass + ! fluxes at the scalar points adjacent to the velocity point. These + ! bounded layer thicknesses are consistent with the transport + ! algorithm. + dlm(kmin) = max(0._r8, min(p(i, j - 1, 3), pbv(i, j, n)) & + - max(p(i, j - 1, 1), ptv(i, j))) + dlp(kmin) = max(0._r8, min(p(i, j , 3), pbv(i, j, n)) & + - max(p(i, j , 1), ptv(i, j))) + do k = kintr, kmax + dlm(k) = max(0._r8, min(p(i, j - 1, k + 1), pbv(i, j, n)) & + - max(p(i, j - 1, k ), ptv(i, j))) + dlp(k) = max(0._r8, min(p(i, j , k + 1), pbv(i, j, n)) & + - max(p(i, j , k ), ptv(i, j))) + enddo + + ! If excessive depletion of layers occur beneath the mixed layer + ! base, try to adjust interface fluxes other than the mixed layer + ! base interface flux. + fhi = fface*max(0._r8, min((p(i, j - 1, 3) - ptv(i, j)) & + *scp2(i, j - 1), & + (pbv(i, j, n) - p(i, j , kintr)) & + *scp2(i, j ))) + flo = - fface*max(0._r8, min((p(i, j , 3) - ptv(i, j)) & + *scp2(i, j ), & + (pbv(i, j, n) - p(i, j - 1, kintr)) & + *scp2(i, j - 1))) + mfl(kmin + 1) = min(fhi, max(flo, mfl(kmin + 1))) + do k = kmin + 1, kmax - 1 + if (mfl(k + 1) - mfl(k) > & + ffac*max(epsilp, dlm(k))*scp2(i, j - 1)) then + mfl(k + 1) = mfl(k) + fface*dlm(k)*scp2(i, j - 1) + elseif (mfl(k + 1) - mfl(k) < & + - ffac*max(epsilp, dlp(k))*scp2(i, j )) then + mfl(k + 1) = mfl(k) - fface*dlp(k)*scp2(i, j ) + else + exit + endif + enddo + + ! Apply an iterative procedure for flux limiting by alternate upward + ! and downward propagation through the layers. + + changed = .true. + niter = 0 + kdir = 1 + + do while (changed) + + niter = niter + 1 + if (niter == 1000) then + k = kmin + write(lp,*) + write(lp,'(i3,3e16.8)') & + 1, mfl(k + 1), mfl(k), & + (mfl(k + 1) - mfl(k)) & + /(max(onemm, dpv(i, j, 1 + nn) + dpv(i, j, 2 + nn)) & + *delt1*scvx(i, j)) + do k = kintr, kmax + kn = k + nn + write(lp,'(i3,3e16.8)') & + k, mfl(k + 1), mfl(k), & + (mfl(k + 1) - mfl(k)) & + /(max(onemm, dpv(i, j, kn))*delt1*scvx(i, j)) + enddo + write(lp,*) 'no convergence v', i + i0, j + j0 + call xchalt('(eddtra_gm_isopyc_bulkml)') + stop '(eddtra_gm_isopyc_bulkml)' + endif + + changed = .false. + kdir = - kdir + + do k = ((1 - kdir)*kmax + (1 + kdir)*kmin)/2, & + ((1 - kdir)*kmin + (1 + kdir)*kmax)/2, kdir + + ! Proceed with flux limiting of this layer if the mass flux + ! difference between lower and upper interface is beyond the + ! floating point accuracy limitation. + if (abs(mfl(k + 1) - mfl(k)) > & + 1.e-14_r8*max(epsilp*scv2(i, j), & + abs(mfl(k + 1) + mfl(k)))) then + + if (mfl(k + 1) - mfl(k) > & + ffac*max(epsilp, dlm(k))*scp2(i, j - 1)) then + ! In this case, the mass fluxes are removing too much + ! mass from the grid cell at (i, j - 1, k). Limit the + ! dominating interface flux. + q = fface*dlm(k)*scp2(i, j - 1) + if (mfl(k + 1) > - mfl(k)) then + if (mfl(k ) > - .5_r8*q) then + mfl(k + 1) = mfl(k ) + q + else + mfl(k + 1) = .5_r8*q + mfl(k ) = - mfl(k + 1) + endif + else + if (mfl(k + 1) < .5_r8*q) then + mfl(k ) = mfl(k + 1) - q + else + mfl(k ) = - .5_r8*q + mfl(k + 1) = - mfl(k ) + endif + endif + changed = .true. + elseif (mfl(k + 1) - mfl(k) < & + - ffac*max(epsilp, dlp(k))*scp2(i, j )) then + ! In this case, the mass fluxes are removing too much + ! mass from the grid cell at (i, j, k). Limit the + ! dominating interface flux. + q = fface*dlp(k)*scp2(i, j ) + if (mfl(k + 1) < - mfl(k)) then + if (mfl(k ) < .5_r8*q) then + mfl(k + 1) = mfl(k ) - q + else + mfl(k + 1) = - .5_r8*q + mfl(k ) = - mfl(k + 1) + endif + else + if (mfl(k + 1) > - .5_r8*q) then + mfl(k ) = mfl(k + 1) + q + else + mfl(k ) = .5_r8*q + mfl(k + 1) = - mfl(k ) + endif + endif + changed = .true. + endif + endif + + enddo + + enddo + + ! ------------------------------------------------------------------ + ! Compute the final mass fluxes. + ! ------------------------------------------------------------------ + + k = kmin + if (abs(mfl(k + 1) - mfl(k)) > & + 1.e-14_r8*max(epsilp*scv2(i, j), & + abs(mfl(k + 1) + mfl(k)))) then + vmfltd(i, j, 2 + mm) = mfl(k + 1) - mfl(k) + vmfltd(i, j, 1 + mm) = vmfltd(i, j, 2 + mm) & + *dpv(i, j, 1 + nn)/( dpv(i, j, 1 + nn) & + + dpv(i, j, 2 + nn)) + vmfltd(i, j, 2 + mm) = vmfltd(i, j, 2 + mm) & + - vmfltd(i, j, 1 + mm) + else + vmfltd(i, j, 1 + mm) = 0._r8 + vmfltd(i, j, 2 + mm) = 0._r8 + endif + do k = kintr, kmax + km = k + mm + if (abs(mfl(k + 1) - mfl(k)) > & + 1.e-14_r8*max(epsilp*scv2(i, j), & + abs(mfl(k + 1) + mfl(k)))) then + vmfltd(i, j, km) = mfl(k + 1) - mfl(k) + else + vmfltd(i, j, km) = 0._r8 + endif + if (vmfltd(i, j, km) > & + ffac*max(epsilp, dlm(k))*scp2(i, j - 1)) then + write(lp,*) 'eddtra_gm_isopyc_bulkml v >', & + i + i0, j + j0, k, vmfltd(i, j, km), & + ffac*max(epsilp, dlm(k))*scp2(i, j - 1) + call xchalt('(eddtra_gm_isopyc_bulkml)') + stop '(eddtra_gm_isopyc_bulkml)' + endif + if (vmfltd(i, j, km) < & + - ffac*max(epsilp, dlp(k))*scp2(i, j )) then + write(lp,*) 'eddtra_gm_isopyc_bulkml v <', & + i + i0, j + j0, k, vmfltd(i, j, km), & + - ffac*max(epsilp, dlp(k))*scp2(i, j ) + call xchalt('(eddtra_gm_isopyc_bulkml)') + stop '(eddtra_gm_isopyc_bulkml)' + endif + enddo + + enddo + enddo + enddo + !$omp end parallel do + + end subroutine eddtra_gm_isopyc_bulkml + + subroutine eddtra_gm_cntiso_hybrid(m, n, mm, nn, k1m, k1n) + ! --------------------------------------------------------------------------- + ! Estimate eddy-induced transport following the Gent-McWilliams + ! parameterization. + ! --------------------------------------------------------------------------- + + integer, intent(in) :: m, n, mm, nn, k1m, k1n + + ! Parameters: + real(r8), parameter :: & + ffac = .0625_r8, & ! Fraction of the mass of a grid cell a mass flux + ! is allowed to deplete []. + fface = .99_r8*ffac ! (1-epsilon)*ffac []. + + real(r8), dimension(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy) :: ptu, ptv + real(r8), dimension(kdm+1) :: mfl + real(r8), dimension(kdm) :: puv, dlm, dlp + real(r8) :: q, et2mf, mlp, kappa + integer :: i, j, k, l, km, kn, kmax, kml, niter, kdir + logical :: changed + + call xctilr(difint, 1, kk, 2, 2, halo_ps) + call xctilr(pbu, 1, 2, 2, 2, halo_us) + call xctilr(pbv, 1, 2, 2, 2, halo_vs) + call xctilr(mlts, 1, 1, 1, 1, halo_ps) + + ! Compute top pressure at velocity points. + !$omp parallel do private(l, i) + do j= - 1, jj + 2 + do l = 1, isu(j) + do i = max(0, ifu(j, l)), min(ii + 2, ilu(j, l)) + ptu(i, j) = max(p(i - 1, j, 1), p(i, j, 1)) + enddo + enddo + enddo + !$omp end parallel do + !$omp parallel do private(l, i) + do j = 0, jj + 2 + do l = 1, isv(j) + do i = max(- 1, ifv(j, l)), min(ii + 2, ilv(j, l)) + ptv(i, j) = max(p(i, j - 1, 1), p(i, j, 1)) + enddo + enddo + enddo + !$omp end parallel do + + ! ------------------------------------------------------------------------- + ! Compute u-component of eddy-induced mass fluxes. + ! ------------------------------------------------------------------------- + + !$omp parallel do private(l, i, k, km, et2mf, kmax, puv, kn, mlp, kml, & + !$omp kappa, mfl, dlm, dlp, changed, niter, kdir, q) + do j = - 1, jj + 2 + do l = 1, isu(j) + do i = max(0, ifu(j, l)), min(ii + 2, ilu(j, l)) + + ! Set eddy-induced mass fluxes to zero initially. + do k = 1, kk + km = k + mm + umfltd(i, j, km) = 0._r8 + enddo + + ! Eddy transport to mass flux conversion factor. + et2mf = - g*rho0*delt1*scuy(i, j) + + ! Find index of last layer containing mass at either of the scalar + ! points adjacent to the velocity point and pressure at interfaces. + kmax = 1 + puv(1) = ptu(i,j) + do k = 2, kk + kn = k + nn + puv(k) = puv(k - 1) + dpu(i, j, kn - 1) + if (dp(i - 1, j, kn) > epsilp .or. dp(i, j, kn) > epsilp) & + kmax = k + enddo + + ! Compute the eddy induced mass flux at layer interfaces below the + ! mixed layer. + mlp = .5_r8*(mlts(i - 1, j) + mlts(i, j))*(onem*iL_mks2cgs) + kml = kmax + 1 + mfl(kmax + 1) = 0._r8 + do k = kmax, 2, -1 + if (puv(k) > mlp) then + kappa = .25_r8*( difint(i - 1, j, k - 1) & + + difint(i , j, k - 1) & + + difint(i - 1, j, k ) & + + difint(i , j, k )) + mfl(k) = - kappa*nslpx(i, j, k)*et2mf + kml = k + else + exit + endif + enddo + + ! In the mixed layer, let the eddy induced mass flux change + ! linearly, with respect to interface pressure, from zero at the + ! surface to the mass flux below the mixed layer. + mfl(1) = 0._r8 + q = 1._r8/(mlp - puv(1)) + do k = 2, kml - 1 + mfl(k) = mfl(kml)*(puv(k) - puv(1))*q + enddo + + ! ------------------------------------------------------------------ + ! Ensure that mass fluxes do not create negative layer thicknesses. + ! ------------------------------------------------------------------ + + ! Compute the layer thicknesses available to be depleted by mass + ! fluxes at the scalar points adjacent to the velocity point. These + ! bounded layer thicknesses are consistent with the transport + ! algorithm. + do k = 1, kmax + dlm(k) = max(0._r8, min(p(i - 1, j, k + 1), pbu(i, j, n)) & + - max(p(i - 1, j, k ), ptu(i, j))) + dlp(k) = max(0._r8, min(p(i , j, k + 1), pbu(i, j, n)) & + - max(p(i , j, k ), ptu(i, j))) + enddo + + ! Apply an iterative procedure for flux limiting by alternate upward + ! and downward propagation through the layers. + + changed = .true. + niter = 0 + kdir = 1 + + do while (changed) + + niter = niter + 1 + if (niter == 1000) then + do k = 1, kmax + kn = k + nn + write(lp,'(i3,3e16.8)') & + k, mfl(k + 1), mfl(k), & + (mfl(k + 1) - mfl(k)) & + /(max(onemm, dpu(i, j, kn))*delt1*scuy(i, j)) + enddo + write(lp,*) 'no convergence u', i + i0, j + j0 + call xchalt('(eddtra_gm_cntiso_hybrid)') + stop '(eddtra_gm_cntiso_hybrid)' + endif + + changed = .false. + kdir = - kdir + + do k = (1 + kdir + (1 - kdir)*kmax)/2, & + (1 - kdir + (1 + kdir)*kmax)/2, kdir + + ! Proceed with flux limiting of this layer if the mass flux + ! difference between lower and upper interface is beyond the + ! floating point accuracy limitation. + if (abs(mfl(k + 1) - mfl(k)) > & + 1.e-14_r8*max(epsilp*scu2(i, j), & + abs(mfl(k + 1) + mfl(k)))) then + + if (mfl(k + 1) - mfl(k) > & + ffac*max(epsilp, dlm(k))*scp2(i - 1, j)) then + ! In this case, the mass fluxes are removing too much + ! mass from the grid cell at (i - 1, j, k). Limit the + ! dominating interface flux. + q = fface*dlm(k)*scp2(i - 1, j) + if (mfl(k + 1) > - mfl(k)) then + if (mfl(k ) > - .5_r8*q) then + mfl(k + 1) = mfl(k ) + q + else + mfl(k + 1) = .5_r8*q + mfl(k ) = - mfl(k + 1) + endif + else + if (mfl(k + 1) < .5_r8*q) then + mfl(k ) = mfl(k + 1) - q + else + mfl(k ) = - .5_r8*q + mfl(k + 1) = - mfl(k ) + endif + endif + changed = .true. + elseif (mfl(k + 1) - mfl(k) < & + - ffac*max(epsilp, dlp(k))*scp2(i , j)) then + ! In this case, the mass fluxes are removing too much + ! mass from the grid cell at (i, j, k). Limit the + ! dominating interface flux. + q = fface*dlp(k)*scp2(i , j) + if (mfl(k + 1) < - mfl(k)) then + if (mfl(k ) < .5_r8*q) then + mfl(k + 1) = mfl(k ) - q + else + mfl(k + 1) = - .5_r8*q + mfl(k ) = - mfl(k + 1) + endif + else + if (mfl(k + 1) > - .5_r8*q) then + mfl(k ) = mfl(k + 1) + q + else + mfl(k ) = .5_r8*q + mfl(k + 1) = - mfl(k ) + endif + endif + changed = .true. + endif + endif + + enddo + + enddo + + ! ------------------------------------------------------------------ + ! Compute the final mass fluxes. + ! ------------------------------------------------------------------ + + do k = 1, kmax + km = k + mm + if (abs(mfl(k + 1) - mfl(k)) > & + 1.e-14_r8*max(epsilp*scu2(i, j), & + abs(mfl(k + 1) + mfl(k)))) then + umfltd(i, j, km) = mfl(k + 1) - mfl(k) + else + umfltd(i, j, km) = 0._r8 + endif + if (umfltd(i, j, km) > & + ffac*max(epsilp, dlm(k))*scp2(i - 1, j)) then + write(lp,*) 'eddtra_gm_cntiso_hybrid u >', & + i + i0, j + j0, k, umfltd(i, j, km), & + ffac*max(epsilp, dlm(k))*scp2(i - 1, j) + call xchalt('(eddtra_gm_cntiso_hybrid)') + stop '(eddtra_gm_cntiso_hybrid)' + endif + if (umfltd(i, j, km) < & + - ffac*max(epsilp, dlp(k))*scp2(i , j)) then + write(lp,*) 'eddtra_gm_cntiso_hybrid u <', & + i + i0, j + j0, k, umfltd(i, j, km), & + - ffac*max(epsilp, dlp(k))*scp2(i , j) + call xchalt('(eddtra_gm_cntiso_hybrid)') + stop '(eddtra_gm_cntiso_hybrid)' + endif + enddo + + enddo + enddo + enddo + !$omp end parallel do + + ! ------------------------------------------------------------------------- + ! Compute v-component of eddy-induced mass fluxes. + ! ------------------------------------------------------------------------- + + !$omp parallel do private(l, i, k, km, et2mf, kmax, puv, kn, mlp, kml, & + !$omp kappa, mfl, dlm, dlp, changed, niter, kdir, q) + do j = 0, jj + 2 + do l = 1, isv(j) + do i = max(- 1, ifv(j, l)), min(ii + 2, ilv(j, l)) + + ! Set eddy-induced mass fluxes to zero initially. + do k = 1, kk + km = k + mm + vmfltd(i, j, km) = 0._r8 + enddo + + ! Eddy transport to mass flux conversion factor. + et2mf = - g*rho0*delt1*scvx(i, j) + + ! Find index of last layer containing mass at either of the scalar + ! points adjacent to the velocity point and pressure at interfaces. + kmax = 1 + puv(1) = ptv(i,j) + do k = 2, kk + kn = k + nn + puv(k) = puv(k - 1) + dpv(i, j, kn - 1) + if (dp(i, j - 1, kn) > epsilp .or. dp(i, j, kn) > epsilp) & + kmax = k + enddo + + ! Compute the eddy induced mass flux at layer interfaces below the + ! mixed layer. + mlp = .5_r8*(mlts(i, j - 1) + mlts(i, j))*(onem*iL_mks2cgs) + kml = kmax + 1 + mfl(kmax + 1) = 0._r8 + do k = kmax, 2, -1 + if (puv(k) > mlp) then + kappa = .25_r8*( difint(i, j - 1, k - 1) & + + difint(i, j , k - 1) & + + difint(i, j - 1, k ) & + + difint(i, j , k )) + mfl(k) = - kappa*nslpy(i, j, k)*et2mf + kml = k + else + exit + endif + enddo + + ! In the mixed layer, let the eddy induced mass flux change + ! linearly, with respect to interface pressure, from zero at the + ! surface to the mass flux below the mixed layer. + mfl(1) = 0._r8 + q = 1._r8/(mlp - puv(1)) + do k = 2, kml - 1 + mfl(k) = mfl(kml)*(puv(k) - puv(1))*q + enddo + + ! ------------------------------------------------------------------ + ! Ensure that mass fluxes do not create negative layer thicknesses. + ! ------------------------------------------------------------------ + + ! Compute the layer thicknesses available to be depleted by mass + ! fluxes at the scalar points adjacent to the velocity point. These + ! bounded layer thicknesses are consistent with the transport + ! algorithm. + do k = 1, kmax + dlm(k) = max(0._r8, min(p(i, j - 1, k + 1), pbv(i, j, n)) & + - max(p(i, j - 1, k ), ptv(i, j))) + dlp(k) = max(0._r8, min(p(i, j , k + 1), pbv(i, j, n)) & + - max(p(i, j , k ), ptv(i, j))) + enddo + + ! Apply an iterative procedure for flux limiting by alternate upward + ! and downward propagation through the layers. + + changed = .true. + niter = 0 + kdir = 1 + + do while (changed) + + niter = niter + 1 + if (niter == 1000) then + do k = 1, kmax + kn = k + nn + write(lp,'(i3,3e16.8)') & + k, mfl(k + 1), mfl(k), & + (mfl(k + 1) - mfl(k)) & + /(max(onemm, dpv(i, j, kn))*delt1*scvx(i, j)) + enddo + write(lp,*) 'no convergence v', i + i0, j + j0 + call xchalt('(eddtra_gm_cntiso_hybrid)') + stop '(eddtra_gm_cntiso_hybrid)' + endif + + changed = .false. + kdir = - kdir + + do k = (1 + kdir + (1 - kdir)*kmax)/2, & + (1 - kdir + (1 + kdir)*kmax)/2, kdir + + ! Proceed with flux limiting of this layer if the mass flux + ! difference between lower and upper interface is beyond the + ! floating point accuracy limitation. + if (abs(mfl(k + 1) - mfl(k)) > & + 1.e-14_r8*max(epsilp*scv2(i, j), & + abs(mfl(k + 1) + mfl(k)))) then + + if (mfl(k + 1) - mfl(k) > & + ffac*max(epsilp, dlm(k))*scp2(i, j - 1)) then + ! In this case, the mass fluxes are removing too much + ! mass from the grid cell at (i, j - 1, k). Limit the + ! dominating interface flux. + q = fface*dlm(k)*scp2(i, j - 1) + if (mfl(k + 1) > - mfl(k)) then + if (mfl(k ) > - .5_r8*q) then + mfl(k + 1) = mfl(k ) + q + else + mfl(k + 1) = .5_r8*q + mfl(k ) = - mfl(k + 1) + endif + else + if (mfl(k + 1) < .5_r8*q) then + mfl(k ) = mfl(k + 1) - q + else + mfl(k ) = - .5_r8*q + mfl(k + 1) = - mfl(k ) + endif + endif + changed = .true. + elseif (mfl(k + 1) - mfl(k) < & + - ffac*max(epsilp, dlp(k))*scp2(i, j )) then + ! In this case, the mass fluxes are removing too much + ! mass from the grid cell at (i, j, k). Limit the + ! dominating interface flux. + q = fface*dlp(k)*scp2(i, j ) + if (mfl(k + 1) < - mfl(k)) then + if (mfl(k ) < .5_r8*q) then + mfl(k + 1) = mfl(k ) - q + else + mfl(k + 1) = - .5_r8*q + mfl(k ) = - mfl(k + 1) + endif + else + if (mfl(k + 1) > - .5_r8*q) then + mfl(k ) = mfl(k + 1) + q + else + mfl(k ) = .5_r8*q + mfl(k + 1) = - mfl(k ) + endif + endif + changed = .true. + endif + endif + + enddo + + enddo + + ! ------------------------------------------------------------------ + ! Compute the final mass fluxes. + ! ------------------------------------------------------------------ + + do k = 1, kmax + km = k + mm + if (abs(mfl(k + 1) - mfl(k)) > & + 1.e-14_r8*max(epsilp*scv2(i, j), & + abs(mfl(k + 1) + mfl(k)))) then + vmfltd(i, j, km) = mfl(k + 1) - mfl(k) + else + vmfltd(i, j, km) = 0._r8 + endif + if (vmfltd(i, j, km) > & + ffac*max(epsilp, dlm(k))*scp2(i, j - 1)) then + write(lp,*) 'eddtra_gm_cntiso_hybrid v >', & + i + i0, j + j0, k, vmfltd(i, j, km), & + ffac*max(epsilp, dlm(k))*scp2(i, j - 1) + call xchalt('(eddtra_gm_cntiso_hybrid)') + stop '(eddtra_gm_cntiso_hybrid)' + endif + if (vmfltd(i, j, km) < & + - ffac*max(epsilp, dlp(k))*scp2(i, j )) then + write(lp,*) 'eddtra_gm_cntiso_hybrid v <', & + i + i0, j + j0, k, vmfltd(i, j, km), & + - ffac*max(epsilp, dlp(k))*scp2(i, j ) + call xchalt('(eddtra_gm_cntiso_hybrid)') + stop '(eddtra_gm_cntiso_hybrid)' + endif + enddo + + enddo + enddo + enddo + !$omp end parallel do + + end subroutine eddtra_gm_cntiso_hybrid + + ! --------------------------------------------------------------------------- + ! Public procedures. + ! --------------------------------------------------------------------------- + + subroutine eddtra(m, n, mm, nn, k1m, k1n) + ! --------------------------------------------------------------------------- + ! Compute eddy-induced transport. + ! --------------------------------------------------------------------------- + + integer, intent(in) :: m, n, mm, nn, k1m, k1n + + integer :: i, j, k, l, km + + ! Compute eddy-induced transport of mass. + if (vcoord_type_tag == isopyc_bulkml) then + if (eitmth_opt == eitmth_intdif) then + call eddtra_intdif_isopyc_bulkml(m, n, mm, nn, k1m, k1n) + elseif (eitmth_opt == eitmth_gm) then + call eddtra_gm_isopyc_bulkml(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 = ''isopyc_bulkml''!' + endif + call xcstop('(eddtra)') + stop '(eddtra)' + endif + else + if (eitmth_opt == eitmth_gm) then + call eddtra_gm_cntiso_hybrid(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''!' + endif + call xcstop('(eddtra)') + stop '(eddtra)' + endif + endif + + ! Diagnose eddy-induced transport components of heat and salt. + !$omp parallel do private(k,km,l,i) + do j = 1, jj + do k = 1, kk + km = k + mm + do l = 1, isu(j) + do i = max(1, ifu(j, l)), min(ii, ilu(j, l)) + utfltd(i, j, km) = .5_r8*umfltd(i, j, km) & + *(temp(i - 1, j, km) + temp(i, j, km)) + usfltd(i, j, km) = .5_r8*umfltd(i, j, km) & + *(saln(i - 1, j, km) + saln(i, j, km)) + enddo + enddo + do l = 1, isv(j) + do i = max(1, ifv(j, l)), min(ii, ilv(j, l)) + vtfltd(i, j, km) = .5_r8*vmfltd(i, j, km) & + *(temp(i, j - 1, km) + temp(i, j, km)) + vsfltd(i, j, km) = .5_r8*vmfltd(i, j, km) & + *(saln(i, j - 1, km) + saln(i, j, km)) + enddo + enddo + enddo + enddo + !$omp end parallel do + + if (csdiag) then + if (mnproc == 1) then + write(lp,*) 'eddtra:' + endif + call chksummsk(umfltd(1 - nbdy, 1 - nbdy, k1m), iu, kk, 'umfltd') + call chksummsk(vmfltd(1 - nbdy, 1 - nbdy, k1m), iv, kk, 'vmfltd') + call chksummsk(utfltd(1 - nbdy, 1 - nbdy, k1m), iu, kk, 'utfltd') + call chksummsk(vtfltd(1 - nbdy, 1 - nbdy, k1m), iv, kk, 'vtfltd') + call chksummsk(usfltd(1 - nbdy, 1 - nbdy, k1m), iu, kk, 'usfltd') + call chksummsk(vsfltd(1 - nbdy, 1 - nbdy, k1m), iv, kk, 'vsfltd') + endif + + end subroutine eddtra + +end module mod_eddtra diff --git a/phy/mod_eos.F90 b/phy/mod_eos.F90 index 875ebcb8..7226abff 100644 --- a/phy/mod_eos.F90 +++ b/phy/mod_eos.F90 @@ -1,5 +1,5 @@ ! ------------------------------------------------------------------------------ -! Copyright (C) 2007-2021 Mats Bentsen, Mehmet Ilicak, Aleksi Nummelin +! Copyright (C) 2007-2022 Mats Bentsen, Mehmet Ilicak, Aleksi Nummelin ! ! This file is part of BLOM. ! @@ -24,6 +24,7 @@ module mod_eos ! ------------------------------------------------------------------------------ use mod_types, only: r8 + use mod_constants, only: alpha0 use mod_config, only: expcnf use mod_xc, only: mnproc, lp, xcstop @@ -32,6 +33,27 @@ module mod_eos private ! Coefficients for the functional fit of in situ density. +#ifdef MKS + real(r8), parameter :: & + a11 = 9.9985372432159340e+02_r8, & + a12 = 1.0380621928183473e+01_r8, & + a13 = 1.7073577195684715e+00_r8, & + a14 = -3.6570490496333680e-02_r8, & + a15 = -7.3677944503527477e-03_r8, & + a16 = -3.5529175999643348e-03_r8, & + b11 = 1.7083494994335439e-06_r8, & + b12 = 7.1567921402953455e-09_r8, & + b13 = 1.2821026080049485e-09_r8, & + a21 = 1.0_r8 , & + a22 = 1.0316374535350838e-02_r8, & + a23 = 8.9521792365142522e-04_r8, & + a24 = -2.8438341552142710e-05_r8, & + a25 = -1.1887778959461776e-05_r8, & + a26 = -4.0163964812921489e-06_r8, & + b21 = 1.1995545126831476e-09_r8, & + b22 = 5.5234008384648383e-12_r8, & + b23 = 8.4310335919950873e-13_r8 +#else real(r8), parameter :: & a11 = 9.9985372432159340e-01_r8, & a12 = 1.0380621928183473e-02_r8, & @@ -51,6 +73,7 @@ module mod_eos b21 = 1.1995545126831476e-10_r8, & b22 = 5.5234008384648383e-13_r8, & b23 = 8.4310335919950873e-14_r8 +#endif ! Reference pressure [g cm-1 s-2]. real(r8) :: pref @@ -72,7 +95,8 @@ module mod_eos ap11, ap12, ap13, ap14, ap15, ap16, & ap21, ap22, ap23, ap24, ap25, ap26, & atf, btf, ctf, & - inieos, rho, alp, sig, sig0, dsigdt, dsigdt0, dsigds, dsigds0, & + inieos, rho, alp, sig, sig0, & + drhodt, dsigdt, dsigdt0, drhods, dsigds, dsigds0, & tofsig, sofsig, p_alpha, p_p_alpha, delphi contains @@ -105,12 +129,12 @@ subroutine inieos ap24 = a24 ap25 = a25 ap26 = a26 - ap11 = a11 + b11*pref - ap21 - ap12 = a12 + b12*pref - ap22 - ap13 = a13 + b13*pref - ap23 - ap14 = a14 - ap24 - ap15 = a15 - ap25 - ap16 = a16 - ap26 + ap11 = a11 + b11*pref - ap21/alpha0 + ap12 = a12 + b12*pref - ap22/alpha0 + ap13 = a13 + b13*pref - ap23/alpha0 + ap14 = a14 - ap24/alpha0 + ap15 = a15 - ap25/alpha0 + ap16 = a16 - ap26/alpha0 ap210 = a21 ap220 = a22 @@ -118,12 +142,12 @@ subroutine inieos ap240 = a24 ap250 = a25 ap260 = a26 - ap110 = a11 - ap210 - ap120 = a12 - ap220 - ap130 = a13 - ap230 - ap140 = a14 - ap240 - ap150 = a15 - ap250 - ap160 = a16 - ap260 + ap110 = a11 - ap210/alpha0 + ap120 = a12 - ap220/alpha0 + ap130 = a13 - ap230/alpha0 + ap140 = a14 - ap240/alpha0 + ap150 = a15 - ap250/alpha0 + ap160 = a16 - ap260/alpha0 ! Coefficients for freezing temperature. select case (trim(expcnf)) @@ -213,6 +237,29 @@ pure real(r8) function sig0(th, s) end function sig0 + pure real(r8) function drhodt(p, th, s) + ! --------------------------------------------------------------------------- + ! Derivative of in situ density with respect to potential temperature + ! [g cm-3 K-1]. + ! --------------------------------------------------------------------------- + + real(r8), intent(in) :: & + p, & ! Pressure [g cm-1 s-2]. + th, & ! Potental temperature [deg C]. + s ! Salinity [g kg-1]. + + real(r8) :: r1, r2i + + r1 = a11 + (a12 + a14*th + a15*s)*th + (a13 + a16*s)*s & + + (b11 + b12*th + b13*s)*p + r2i = 1._r8/( a21 + (a22 + a24*th + a25*s)*th + (a23 + a26*s)*s & + + (b21 + b22*th + b23*s)*p) + + drhodt = ( a12 + 2._r8*a14*th + a15*s + b12*p & + - (a22 + 2._r8*a24*th + a25*s + b22*p)*r1*r2i)*r2i + + end function drhodt + pure real(r8) function dsigdt(th, s) ! --------------------------------------------------------------------------- ! Derivative of potential density with respect to potential temperature @@ -254,6 +301,28 @@ pure real(r8) function dsigdt0(th, s) end function dsigdt0 + pure real(r8) function drhods(p, th, s) + ! --------------------------------------------------------------------------- + ! Derivative of in situ density with respect to salinity [kg cm-3]. + ! --------------------------------------------------------------------------- + + real(r8), intent(in) :: & + p, & ! Pressure [g cm-1 s-2]. + th, & ! Potental temperature [deg C]. + s ! Salinity [g kg-1]. + + real(r8) :: r1, r2i + + r1 = a11 + (a12 + a14*th + a15*s)*th + (a13 + a16*s)*s & + + (b11 + b12*th + b13*s)*p + r2i = 1._r8/( a21 + (a22 + a24*th + a25*s)*th + (a23 + a26*s)*s & + + (b21 + b22*th + b23*s)*p) + + drhods = ( a13 + a15*th + 2._r8*a16*s + b13*p & + - (a23 + a25*th + 2._r8*a26*s + b23*p)*r1*r2i)*r2i + + end function drhods + pure real(r8) function dsigds(th, s) ! --------------------------------------------------------------------------- ! Derivative of potential density with respect to salinity [kg cm-3]. diff --git a/phy/mod_forcing.F90 b/phy/mod_forcing.F90 index 48d2b138..64b546b3 100644 --- a/phy/mod_forcing.F90 +++ b/phy/mod_forcing.F90 @@ -1,5 +1,5 @@ ! ------------------------------------------------------------------------------ -! Copyright (C) 2002-2021 Mats Bentsen, Jerry Tjiputra, Jörg Schwinger +! Copyright (C) 2002-2022 Mats Bentsen, Jerry Tjiputra, Jörg Schwinger ! ! This file is part of BLOM. ! @@ -106,6 +106,10 @@ module mod_forcing ustarw, & ! Friction velocity for open water [m s-1]. slp, & ! Sea-level pressure [kg m-1 s-2]. abswnd, & ! Wind speed at measurement height (zu) [m s-1]. + lamult, & ! Langmuir enhancement factor []. + lasl, & ! Surface layer averaged Langmuir number []. + ustokes, & ! u-component of surface Stokes drift [m s-1]. + vstokes, & ! v-component of surface Stokes drift [m s-1]. atmco2, & ! Atmospheric CO2 concentration [ppm]. flxco2, & ! Air-sea CO2 flux [kg m-2 s-1]. flxdms, & ! Sea-air DMS flux [kg m-2 s-1]. @@ -124,17 +128,24 @@ module mod_forcing tauy, & ! v-component of surface stress [g cm-1 s-2]. ustar, & ! Surface friction velocity [cm s-1]. ustarb, & ! Bottom friction velocity [cm s-1]. - ustar3, & ! Friction velocity cubed [cm3 s-3]. - buoyfl ! Surface buoyancy flux [cm2 s-3]. + ustar3 ! Friction velocity cubed [cm3 s-3]. + + ! Flux fields at model interfaces. + + real(r8), dimension(1 - nbdy:idm + nbdy,1 - nbdy:jdm + nbdy, kk + 1) :: & + buoyfl, & ! Buoyancy flux [cm2 s-3]. + t_sw_nonloc ! Non-local transport term that is the fraction of + ! shortwave flux passing a layer interface []. public :: aptflx, apsflx, ditflx, disflx, srxbal, sprfac, & trxday, srxday, trxdpt, srxdpt, trxlim, srxlim, scfile, & sref, tflxap, sflxap, tflxdi, sflxdi, nflxdi, & sstclm, ricclm, sssclm, prfac, eiacc, pracc, & swa, nsf, hmltfz, lip, sop, eva, rnf, rfi, fmltfz, sfl, ztx, mty, & - ustarw, slp, abswnd, atmco2, flxco2, flxdms, flxbrf, atmbrf, & + ustarw, slp, abswnd, lamult, lasl, ustokes, vstokes, & + atmco2, flxco2, flxdms, flxbrf, atmbrf, & surflx, surrlx, sswflx, salflx, brnflx, salrlx, taux, tauy, & - ustar, ustarb, ustar3, buoyfl, & + ustar, ustarb, ustar3, buoyfl, t_sw_nonloc, & inivar_forcing, fwbbal contains @@ -144,7 +155,7 @@ subroutine inivar_forcing ! Initialize variables related to forcing. ! --------------------------------------------------------------------------- - integer :: i, j, l + integer :: i, j, k, l !$omp parallel do private(i) do j = 1 - nbdy, jj + nbdy @@ -166,6 +177,10 @@ subroutine inivar_forcing ustarw(i, j) = spval slp(i, j) = spval abswnd(i, j) = spval + lamult(i, j) = spval + lasl(i, j) = spval + ustokes(i, j) = spval + vstokes(i, j) = spval atmco2(i, j) = spval flxco2(i, j) = spval flxdms(i, j) = spval @@ -182,7 +197,16 @@ subroutine inivar_forcing ustar(i, j) = spval ustarb(i, j) = spval ustar3(i, j) = spval - buoyfl(i, j) = spval + enddo + enddo + !$omp end parallel do + + !$omp parallel do private(k, i) + do j = 1 - nbdy, jj + nbdy + do k = 1, kk + 1 + do i = 1 - nbdy, ii + nbdy + buoyfl(i, j, k) = spval + enddo enddo enddo !$omp end parallel do @@ -193,15 +217,26 @@ subroutine inivar_forcing do i = max(1, ifp(j, l)), min(ii, ilp(j, l)) flxco2(i, j) = 0._r8 flxdms(i, j) = 0._r8 + flxbrf(i, j) = 0._r8 ustar (i, j) = 0._r8 ustarb(i, j) = 0._r8 - buoyfl(i, j) = 0._r8 - flxbrf(i, j) = 0._r8 enddo enddo enddo !$omp end parallel do + !$omp parallel do private(k, l, i) + do j = 1, jj + do k = 1, kk + 1 + do l = 1, isp(j) + do i = max(1, ifp(j, l)), min(ii, ilp(j, l)) + buoyfl(i, j, k) = 0._r8 + enddo + enddo + enddo + enddo + !$omp end parallel do + if (sprfac) then prfac = 1._r8 !$omp parallel do private(l, i) diff --git a/phy/mod_grid.F90 b/phy/mod_grid.F90 index 2d29a82f..8f849b3c 100644 --- a/phy/mod_grid.F90 +++ b/phy/mod_grid.F90 @@ -1,5 +1,5 @@ ! ------------------------------------------------------------------------------ -! Copyright (C) 2020 Mats Bentsen +! Copyright (C) 2020-2021 Mats Bentsen ! ! This file is part of BLOM. ! @@ -34,9 +34,6 @@ module mod_grid character(len = 256) :: & grfile ! Name of file containing grid specification. - real(r8), dimension(1 - nbdy:idm + nbdy, 1 - nbdy:jdm + nbdy, kdm) :: & - sigmar ! Reference potential density [g cm-3]. - real(r8), dimension(1 - nbdy:idm + nbdy, 1 - nbdy:jdm + nbdy, 4) :: & qclon, & ! Longitude of q-cell corners [degrees]. qclat, & ! Latitude of q-cell corners [degrees]. @@ -92,7 +89,7 @@ module mod_grid integer :: & nwp ! Number of wet grid cells. - public :: grfile, sigmar, & + public :: grfile, & qclon, qclat, pclon, pclat, uclon, uclat, vclon, vclat, & scqx, scqy, scpx, scpy, scux, scuy, scvx, scvy, & scq2, scp2, scu2, scv2, scq2i, scp2i, & @@ -113,11 +110,6 @@ subroutine inivar_grid !$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 do k = 1, 4 do i = 1 - nbdy, ii + nbdy qclon(i, j, k) = spval diff --git a/phy/mod_hor3map.F90 b/phy/mod_hor3map.F90 new file mode 100644 index 00000000..fd28b6e9 --- /dev/null +++ b/phy/mod_hor3map.F90 @@ -0,0 +1,4931 @@ +! ------------------------------------------------------------------------------ +! Copyright (C) 2021-2022 Mats Bentsen +! +! 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_hor3map +! ------------------------------------------------------------------------------ +! This module contains routines and data structures for High-order +! One-dimensional Reconstruction, Regridding and ReMAPping (HOR3MAP) on +! nonuniform grids. The remapping is done by integrating a piecewise polynomial +! reconstruction of the source data in segments to establish finite volume +! averages on the destination grid. For computational efficiency when remapping +! multiple data with same source and destination grids, stages of the +! reconstruction and remapping are separated into distinct routines. The module +! also have a routine for regridding, where grid locations are found as +! intersections between a polynomial reconstruction of the source data and +! desired grid cell edge data values. +! ------------------------------------------------------------------------------ + +#undef DEBUG +#define DEBUG + + use, intrinsic :: iso_fortran_env, only: real64 +#ifdef DEBUG + use, intrinsic :: ieee_arithmetic, only: ieee_value, ieee_signaling_nan +#endif + + implicit none + + private + + ! Option parameters. + integer, parameter :: & + hor3map_pcm = 100, & ! Reconstruction methods + hor3map_plm = 101, & + hor3map_ppm = 102, & + hor3map_pqm = 103, & + hor3map_no_limiting = 200, & ! Limiting methods + hor3map_monotonic = 201, & + hor3map_non_oscillatory = 203, & + hor3map_non_oscillatory_posdef = 204 + + ! Error parameters. + integer, parameter :: & + hor3map_noerr = 0, & + hor3map_invalid_method = 1, & + hor3map_resizing_initialized_rcgs = 2, & + hor3map_nonmonotonic_src_edges = 3, & + hor3map_src_extent_too_small = 4, & + hor3map_failed_to_allocate_rcgs = 5, & + hor3map_recon_not_prepared = 6, & + hor3map_resizing_initialized_rms = 7, & + hor3map_inconsistent_grid_range = 8, & + hor3map_nonmonotonic_dst_edges = 9, & + hor3map_failed_to_allocate_rms = 10, & + hor3map_src_size_mismatch = 11, & + hor3map_failed_to_allocate_rcss = 12, & + hor3map_invalid_plm_limiting = 13, & + 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 + character(len = 80), dimension(hor3map_errmsg_num), parameter :: errmsg = & + ["Invalid reconstruction method! ", & + "Cannot resize initialized reconstruction grid data structure! ", & + "Source grid edges do not monotonically increase or decrease! ", & + "Source grid extent too small! ", & + "Failed to allocate reconstruction grid data structure! ", & + "Call 'prepare_reconstruction' first! ", & + "Cannot resize initialized remapping data structure! ", & + "Inconsistent source and destination grid range! ", & + "Destination grid edges do not monotonically increase or decrease!", & + "Failed to allocate remapping data structure! ", & + "Size mismatch between source grid edges and data array! ", & + "Failed to allocate reconstruction source data structure! ", & + "Invalid limiting method for PLM! ", & + "Invalid limiting method for PPM! ", & + "Invalid limiting method for PQM! ", & + "Call 'reconstruct' first! ", & + "Size mismatch between grid edge values and locations! ", & + "Call 'prepare_remapping' first! ", & + "Size mismatch between destination grid edges and data array! ", & + "Array index of data structure is out of bounds! ", & + "Inconsistent data structure for reconstruction and remapping! "] + + ! Numeric data types. + integer, parameter :: & + r8 = real64 + + ! Small non-dimensional value. + real(r8), parameter :: eps = 1.e-14_r8 + + ! Lower bounds of prod(h(i))/max(h(i))^n, where h(i) are cell widths + ! belonging to a stencil of n grid cells. Respecting these bounds will ensure + ! condition numbers below 10^8 of matrices involved in various linear + ! equation systems. + real(r8), parameter :: & + hplim_ih4 = 5.e-7_r8, & + hplim_ih6 = 5.e-5_r8, & + hplim_eh4 = 3.e-10_r8, & + hplim_eh6 = 3.e-7_r8 + + ! Numeric constants. + real(r8), parameter :: & + c0 = 0._r8, c1 = 1._r8, c2 = 2._r8, c3 = 3._r8, c4 = 4._r8, c5 = 5._r8, & + c6 = 6._r8, c10 = 10._r8, c12 = 12._r8, c15 = 15._r8, c18 = 18._r8, & + c20 = 20._r8, c28 = 28._r8, c30 = 30._r8, c32 = 32._r8, c60 = 60._r8, & + c1_2 = 1._r8/2._r8, c1_3 = 1._r8/3._r8, c1_4 = 1._r8/4._r8, & + c1_5 = 1._r8/5._r8, c1_6 = 1._r8/6._r8, c1_8 = 1._r8/8._r8, & + c1_12 = 1._r8/12._r8, c1_16 = 1._r8/16._r8, c1_24 = 1._r8/24._r8, & + c1_80 = 1._r8/80._r8, c1_120 = 1._r8/120._r8, & + c2_3 = 2._r8/3._r8, c3_4 = 3._r8/4._r8, c3_2 = 3._r8/2._r8, & + c5_2 = 5._r8/2._r8, c8_3 = 8._r8/3._r8, c10_3 = 10._r8/3._r8, & + c9_2 = 9._r8/2._r8 + + type :: recon_grd_struct + + integer :: & + i_lbound = 1, & + i_ubound = 1, & + j_lbound = 1, & + j_ubound = 1, & + i_index = 1, & + j_index = 1, & + i_index_curr = 0, & + j_index_curr = 0, & + method = hor3map_ppm + logical :: & + initialized = .false. + integer :: n_src, p_ord + + real(r8), allocatable, dimension(:,:,:) :: & + tdecoeff_data, tdscoeff_data, lblu_data, rblu_data + real(r8), allocatable, dimension(:,:) :: & + x_edge_src_data, h_src_data, hi_src_data, hci_src_data, & + src_dst_weight_data + real(r8), allocatable, dimension(:) :: & + x_eps_data + integer, allocatable, dimension(:,:) :: & + src_dst_index_data + integer, allocatable, dimension(:) :: & + n_src_actual_data, method_actual_data + logical, allocatable, dimension(:) :: & + prepared_data + + real(r8), dimension(:,:), pointer :: & + tdecoeff, tdscoeff, lblu, rblu + real(r8), dimension(:), pointer :: & + x_edge_src, h_src, hi_src, hci_src, & + src_dst_weight + real(r8), pointer :: & + x_eps + integer, dimension(:), pointer :: & + src_dst_index + integer, pointer :: & + n_src_actual, method_actual + logical, pointer :: & + prepared + + type(recon_src_struct), pointer :: rcss_dep_head + type(remap_struct), pointer :: rms_dep_head + + end type recon_grd_struct + + type :: recon_src_struct + + integer :: & + limiting = hor3map_monotonic, & + i_index_curr = 0, & + j_index_curr = 0 + logical :: & + pc_left_bndr = .true., & + pc_right_bndr = .true., & + initialized = .false. + real(r8) :: u_range, u_eps, uu_eps + + real(r8), allocatable, dimension(:,:,:) :: & + polycoeff_data + real(r8), allocatable, dimension(:,:) :: & + u_src_data, uel_data, uer_data, usl_data, usr_data + logical, allocatable, dimension(:) :: & + reconstructed_data + + real(r8), dimension(:,:), pointer :: & + polycoeff + real(r8), dimension(:), pointer :: & + u_src, uel, uer, usl, usr + logical, pointer :: & + reconstructed + + type(recon_grd_struct), pointer :: rcgs + type(recon_src_struct), pointer :: rcss_dep_next + + end type recon_src_struct + + type :: remap_struct + + integer :: & + i_index_curr = 0, & + j_index_curr = 0 + logical :: & + initialized = .false. + integer :: n_dst + + real(r8), allocatable, dimension(:,:) :: & + h_dst_data, hi_dst_data, seg_int_lim_data + integer, allocatable, dimension(:,:) :: & + n_src_seg_data, seg_dst_index_data + logical, allocatable, dimension(:) :: & + prepared_data + + real(r8), dimension(:), pointer :: h_dst, hi_dst, seg_int_lim + integer, dimension(:), pointer :: n_src_seg, seg_dst_index + logical, pointer :: prepared + + type(recon_grd_struct), pointer :: rcgs + type(remap_struct), pointer :: rms_dep_next + + end type remap_struct + + 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, & + free_rcgs, free_rcss, free_rms, & + hor3map_pcm, hor3map_plm, hor3map_ppm, hor3map_pqm, & + hor3map_no_limiting, hor3map_monotonic, hor3map_non_oscillatory, & + hor3map_non_oscillatory_posdef, & + hor3map_noerr, hor3map_errstr + +contains + + ! --------------------------------------------------------------------------- + ! Private procedures. + ! --------------------------------------------------------------------------- + + function assign_ptr_rcgs(rcgs) result(errstat) + ! --------------------------------------------------------------------------- + ! Assign array pointers within reconstruction grid data structure. + ! --------------------------------------------------------------------------- + + type(recon_grd_struct), target, intent(inout) :: rcgs + + integer :: errstat + + integer :: ij_index + + errstat = hor3map_noerr + + ! Check if new pointer assignments are needed. + if (rcgs%i_index == rcgs%i_index_curr .and. & + rcgs%j_index == rcgs%j_index_curr) return + + ! Check index bounds. + if (rcgs%i_index < rcgs%i_lbound .or. rcgs%i_index > rcgs%i_ubound .or. & + rcgs%j_index < rcgs%j_lbound .or. rcgs%j_index > rcgs%j_ubound) then + errstat = hor3map_index_out_of_bounds + return + endif + + ! Assign array pointers within the reconstruction grid data structure. + + ij_index = rcgs%i_index - rcgs%i_lbound + 1 & + + (rcgs%j_index - rcgs%j_lbound) & + *(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) + rcgs%h_src => rcgs%h_src_data(:,ij_index) + rcgs%hi_src => rcgs%hi_src_data(:,ij_index) + rcgs%src_dst_index => rcgs%src_dst_index_data(:,ij_index) + rcgs%n_src_actual => rcgs%n_src_actual_data(ij_index) + rcgs%method_actual => rcgs%method_actual_data(ij_index) + rcgs%prepared => rcgs%prepared_data(ij_index) + if (rcgs%method /= hor3map_pcm) then + rcgs%hci_src => rcgs%hci_src_data(:,ij_index) + endif + if (rcgs%method == hor3map_ppm .or. rcgs%method == hor3map_pqm) then + rcgs%src_dst_weight => rcgs%src_dst_weight_data(:,ij_index) + rcgs%tdecoeff => rcgs%tdecoeff_data(:,:,ij_index) + rcgs%tdscoeff => rcgs%tdscoeff_data(:,:,ij_index) + rcgs%lblu => rcgs%lblu_data(:,:,ij_index) + rcgs%rblu => rcgs%rblu_data(:,:,ij_index) + endif + + rcgs%i_index_curr = rcgs%i_index + rcgs%j_index_curr = rcgs%j_index + + end function assign_ptr_rcgs + + function assign_ptr_rcss(rcss) result(errstat) + ! --------------------------------------------------------------------------- + ! Assign array pointers within reconstruction grid and source data + ! structures. + ! --------------------------------------------------------------------------- + + type(recon_src_struct), target, intent(inout) :: rcss + + integer :: errstat + + integer :: ij_index + + errstat = hor3map_noerr + + ! Check if new pointer assignments are needed. + if (rcss%rcgs%i_index == rcss%i_index_curr .and. & + rcss%rcgs%j_index == rcss%j_index_curr) return + + ! Check index bounds. + if (rcss%rcgs%i_index < rcss%rcgs%i_lbound .or. & + rcss%rcgs%i_index > rcss%rcgs%i_ubound .or. & + rcss%rcgs%j_index < rcss%rcgs%j_lbound .or. & + rcss%rcgs%j_index > rcss%rcgs%j_ubound) then + errstat = hor3map_index_out_of_bounds + return + endif + + ij_index = rcss%rcgs%i_index - rcss%rcgs%i_lbound + 1 & + + (rcss%rcgs%j_index - rcss%rcgs%j_lbound) & + *(rcss%rcgs%i_ubound - rcss%rcgs%i_lbound + 1) + + rcss%u_src => rcss%u_src_data(:,ij_index) + rcss%uel => rcss%uel_data(:,ij_index) + rcss%uer => rcss%uer_data(:,ij_index) + rcss%polycoeff => rcss%polycoeff_data(:,:,ij_index) + rcss%reconstructed => rcss%reconstructed_data(ij_index) + if (rcss%rcgs%method == hor3map_pqm) then + rcss%usl => rcss%usl_data(:,ij_index) + rcss%usr => rcss%usr_data(:,ij_index) + endif + + rcss%i_index_curr = rcss%rcgs%i_index + rcss%j_index_curr = rcss%rcgs%j_index + + end function assign_ptr_rcss + + function assign_ptr_rms(rms) result(errstat) + ! --------------------------------------------------------------------------- + ! Assign array pointers within the remapping data structure. + ! --------------------------------------------------------------------------- + + type(remap_struct), target, intent(inout) :: rms + + integer :: errstat + + integer :: ij_index + + errstat = hor3map_noerr + + ! Check if new pointer assignments are needed. + if (rms%rcgs%i_index == rms%i_index_curr .and. & + rms%rcgs%j_index == rms%j_index_curr) return + + ! Check index bounds. + if (rms%rcgs%i_index < rms%rcgs%i_lbound .or. & + rms%rcgs%i_index > rms%rcgs%i_ubound .or. & + rms%rcgs%j_index < rms%rcgs%j_lbound .or. & + rms%rcgs%j_index > rms%rcgs%j_ubound) then + errstat = hor3map_index_out_of_bounds + return + endif + + ij_index = rms%rcgs%i_index - rms%rcgs%i_lbound + 1 & + + (rms%rcgs%j_index - rms%rcgs%j_lbound) & + *(rms%rcgs%i_ubound - rms%rcgs%i_lbound + 1) + + rms%h_dst => rms%h_dst_data(:,ij_index) + rms%hi_dst => rms%hi_dst_data(:,ij_index) + rms%seg_int_lim => rms%seg_int_lim_data(:,ij_index) + rms%n_src_seg => rms%n_src_seg_data(:,ij_index) + rms%seg_dst_index => rms%seg_dst_index_data(:,ij_index) + rms%prepared => rms%prepared_data(ij_index) + + rms%i_index_curr = rms%rcgs%i_index + rms%j_index_curr = rms%rcgs%j_index + + end function assign_ptr_rms + + pure subroutine lu_decompose(n, a) + ! --------------------------------------------------------------------------- + ! Replace the n x n input matrix A with its LU decomposition. + ! --------------------------------------------------------------------------- + + integer, intent(in) :: n + real(r8), dimension(:,:), intent(inout) :: a + + integer :: i, j, k + + do k = 1, n-1 + do i = k+1, n + a(i,k) = a(i,k)/a(k,k) + do j = k+1, n + a(i,j) = a(i,j) - a(i,k)*a(k,j) + enddo + enddo + enddo + + end subroutine lu_decompose + + pure subroutine lu_solve(n, lu, x) + ! --------------------------------------------------------------------------- + ! Solve the linear system of equations A*x = b using the LU decomposition of + ! the n x n matrix A. The argument x has b as input and is replaced with the + ! solution upon return. + ! --------------------------------------------------------------------------- + + integer, intent(in) :: n + real(r8), dimension(:,:), intent(in) :: lu + real(r8), dimension(:), intent(inout) :: x + + integer :: i, j + + ! Forward substitution. + do i = 2, n + do j = 1, i-1 + x(i) = x(i) - lu(i,j)*x(j) + enddo + enddo + + ! Back substitution. + x(n) = x(n)/lu(n, n) + do i = n-1, 1, -1 + do j = i+1, n + x(i) = x(i) - lu(i,j)*x(j) + enddo + x(i) = x(i)/lu(i,i) + enddo + + end subroutine lu_solve + + pure subroutine edge_ih4_coeff(h, tdecoeff) + ! --------------------------------------------------------------------------- + ! Compute row coefficients for the tridiagonal system of equations to be + ! solved for 4th order accurate edge estimates. + ! --------------------------------------------------------------------------- + + real(r8), dimension(:), intent(in) :: h + real(r8), dimension(:), intent(inout) :: tdecoeff + + real(r8) :: q + + q = c1/(h(1) + h(2)) + tdecoeff(1) = h(2)*h(2)*q*q + tdecoeff(2) = h(1)*h(1)*q*q + tdecoeff(3) = c2*tdecoeff(1)*(h(2) + c2*h(1))*q + tdecoeff(4) = c2*tdecoeff(2)*(h(1) + c2*h(2))*q + + end subroutine edge_ih4_coeff + + pure subroutine edge_ih6_slope_ih5_coeff_common(a, tdecoeff, tdscoeff) + ! --------------------------------------------------------------------------- + ! Common procedure for the various stencils for the computation of row + ! coefficients for the tridiagonal system of equations to be solved for 6th + ! and 5th order accurate edge and slope estimates, respectively. + ! --------------------------------------------------------------------------- + + real(r8), dimension(:,:), intent(inout) :: a + real(r8), dimension(:), intent(inout) :: tdecoeff, tdscoeff + + real(r8), dimension(6,6) :: b + + ! Define matrix for linear system to be solved for slope coefficients. + + b(1:5,3:6) = a(2:6,3:6) + + b(1,1) = c1 + b(2,1) = c2*a(2,1) + b(3,1) = c3*a(3,1) + b(4,1) = c4*a(4,1) + b(5,1) = c5*a(5,1) + b(6,1) = c0 + + b(1,2) = c1 + b(2,2) = c2*a(2,2) + b(3,2) = c3*a(3,2) + b(4,2) = c4*a(4,2) + b(5,2) = c5*a(5,2) + b(6,2) = c0 + + b(6,3:6) = c1 + + ! Solve linear system for edge coefficients. + tdecoeff(:) = [ - c1, c0, c0, c0, c0, c0] + call lu_decompose(6, a) + call lu_solve(6, a, tdecoeff) + + ! Solve linear system for slope coefficients. + tdscoeff(:) = [ - c1, c0, c0, c0, c0, c0] + call lu_decompose(6, b) + call lu_solve(6, b, tdscoeff) + + end subroutine edge_ih6_slope_ih5_coeff_common + + pure subroutine edge_ih6_slope_ih5_coeff_asymleft(h, tdecoeff, tdscoeff) + ! --------------------------------------------------------------------------- + ! With an asymmetrical stencil, where edge values are shifted left compared + ! to cell mean values, compute row coefficients for the tridiagonal system of + ! equations to be solved for 6th and 5th order accurate edge and slope + ! estimates, respectively. + ! --------------------------------------------------------------------------- + + real(r8), dimension(:), intent(in) :: h + real(r8), dimension(:), intent(inout) :: tdecoeff, tdscoeff + + real(r8), dimension(6,6) :: a + real(r8) :: a25sq, a26sq, h3sq, h4sq + + ! Define matrix for linear system to be solved for edge coefficients. + + a(1,1) = c1 + a(2,1) = - h(1) + a(3,1) = - a(2,1)*h(1) + a(4,1) = - a(3,1)*h(1) + a(5,1) = - a(4,1)*h(1) + a(6,1) = - a(5,1)*h(1) + + a(1,2) = c1 + a(2,2) = h(2) + a(3,2) = a(2,2)*h(2) + a(4,2) = a(3,2)*h(2) + a(5,2) = a(4,2)*h(2) + a(6,2) = a(5,2)*h(2) + + a(1,3) = - c1 + a(2,3) = - c1_2*a(2,1) + a(3,3) = - c1_3*a(3,1) + a(4,3) = - c1_4*a(4,1) + a(5,3) = - c1_5*a(5,1) + a(6,3) = - c1_6*a(6,1) + + a(1,4) = - c1 + a(2,4) = - c1_2*a(2,2) + a(3,4) = - c1_3*a(3,2) + a(4,4) = - c1_4*a(4,2) + a(5,4) = - c1_5*a(5,2) + a(6,4) = - c1_6*a(6,2) + + a(1,5) = - c1 + a(2,5) = - h(2) - c1_2*h(3) + a25sq = a(2,5)*a(2,5) + h3sq = h(3)*h(3) + a(3,5) = - a25sq - c1_12*h3sq + a(4,5) = a(2,5)*(a25sq + c1_4*h3sq) + a(5,5) = - a25sq*(a25sq + c1_2*h3sq) - c1_80*h3sq*h3sq + a(6,5) = a(2,5)*(a25sq + c3_4*h3sq)*(a25sq + c1_12*h3sq) + + a(1,6) = - c1 + a(2,6) = - h(2) - h(3) - c1_2*h(4) + a26sq = a(2,6)*a(2,6) + h4sq = h(4)*h(4) + a(3,6) = - a26sq - c1_12*h4sq + a(4,6) = a(2,6)*(a26sq + c1_4*h4sq) + a(5,6) = - a26sq*(a26sq + c1_2*h4sq) - c1_80*h4sq*h4sq + a(6,6) = a(2,6)*(a26sq + c3_4*h4sq)*(a26sq + c1_12*h4sq) + + call edge_ih6_slope_ih5_coeff_common(a, tdecoeff, tdscoeff) + + end subroutine edge_ih6_slope_ih5_coeff_asymleft + + pure subroutine edge_ih6_slope_ih5_coeff_sym(h, tdecoeff, tdscoeff) + ! --------------------------------------------------------------------------- + ! With a symmetrical stencil, compute row coefficients for the tridiagonal + ! system of equations to be solved for 6th and 5th order accurate edge and + ! slope estimates, respectively. + ! --------------------------------------------------------------------------- + + real(r8), dimension(:), intent(in) :: h + real(r8), dimension(:), intent(inout) :: tdecoeff, tdscoeff + + real(r8), dimension(6,6) :: a + real(r8) :: a23sq, a26sq, h1sq, h4sq + + ! Define matrix for linear system to be solved for edge coefficients. + + a(1,1) = c1 + a(2,1) = - h(2) + a(3,1) = - a(2,1)*h(2) + a(4,1) = - a(3,1)*h(2) + a(5,1) = - a(4,1)*h(2) + a(6,1) = - a(5,1)*h(2) + + a(1,2) = c1 + a(2,2) = h(3) + a(3,2) = a(2,2)*h(3) + a(4,2) = a(3,2)*h(3) + a(5,2) = a(4,2)*h(3) + a(6,2) = a(5,2)*h(3) + + a(1,3) = - c1 + a(2,3) = c1_2*h(1) + h(2) + a23sq = a(2,3)*a(2,3) + h1sq = h(1)*h(1) + a(3,3) = - a23sq - c1_12*h1sq + a(4,3) = a(2,3)*(a23sq + c1_4*h1sq) + a(5,3) = - a23sq*(a23sq + c1_2*h1sq) - c1_80*h1sq*h1sq + a(6,3) = a(2,3)*(a23sq + c3_4*h1sq)*(a23sq + c1_12*h1sq) + + a(1,4) = - c1 + a(2,4) = - c1_2*a(2,1) + a(3,4) = - c1_3*a(3,1) + a(4,4) = - c1_4*a(4,1) + a(5,4) = - c1_5*a(5,1) + a(6,4) = - c1_6*a(6,1) + + a(1,5) = - c1 + a(2,5) = - c1_2*a(2,2) + a(3,5) = - c1_3*a(3,2) + a(4,5) = - c1_4*a(4,2) + a(5,5) = - c1_5*a(5,2) + a(6,5) = - c1_6*a(6,2) + + a(1,6) = - c1 + a(2,6) = - h(3) - c1_2*h(4) + a26sq = a(2,6)*a(2,6) + h4sq = h(4)*h(4) + a(3,6) = - a26sq - c1_12*h4sq + a(4,6) = a(2,6)*(a26sq + c1_4*h4sq) + a(5,6) = - a26sq*(a26sq + c1_2*h4sq) - c1_80*h4sq*h4sq + a(6,6) = a(2,6)*(a26sq + c3_4*h4sq)*(a26sq + c1_12*h4sq) + + call edge_ih6_slope_ih5_coeff_common(a, tdecoeff, tdscoeff) + + end subroutine edge_ih6_slope_ih5_coeff_sym + + pure subroutine edge_ih6_slope_ih5_coeff_asymright(h, tdecoeff, tdscoeff) + ! --------------------------------------------------------------------------- + ! With an asymmetrical stencil, where edge values are shifted left compared + ! to cell mean values, compute row coefficients for the tridiagonal system of + ! equations to be solved for 6th and 5th order accurate edge and slope + ! estimates, respectively. + ! --------------------------------------------------------------------------- + + real(r8), dimension(:), intent(in) :: h + real(r8), dimension(:), intent(inout) :: tdecoeff, tdscoeff + + real(r8), dimension(6,6) :: a + real(r8) :: a23sq, a24sq, h1sq, h2sq + + ! Define matrix for linear system to be solved for edge coefficients. + + a(1,1) = c1 + a(2,1) = - h(3) + a(3,1) = - a(2,1)*h(3) + a(4,1) = - a(3,1)*h(3) + a(5,1) = - a(4,1)*h(3) + a(6,1) = - a(5,1)*h(3) + + a(1,2) = c1 + a(2,2) = h(4) + a(3,2) = a(2,2)*h(4) + a(4,2) = a(3,2)*h(4) + a(5,2) = a(4,2)*h(4) + a(6,2) = a(5,2)*h(4) + + a(1,3) = - c1 + a(2,3) = c1_2*h(1) + h(2) + h(3) + a23sq = a(2,3)*a(2,3) + h1sq = h(1)*h(1) + a(3,3) = - a23sq - c1_12*h1sq + a(4,3) = a(2,3)*(a23sq + c1_4*h1sq) + a(5,3) = - a23sq*(a23sq + c1_2*h1sq) - c1_80*h1sq*h1sq + a(6,3) = a(2,3)*(a23sq + c3_4*h1sq)*(a23sq + c1_12*h1sq) + + a(1,4) = - c1 + a(2,4) = c1_2*h(2) + h(3) + a24sq = a(2,4)*a(2,4) + h2sq = h(2)*h(2) + a(3,4) = - a24sq - c1_12*h2sq + a(4,4) = a(2,4)*(a24sq + c1_4*h2sq) + a(5,4) = - a24sq*(a24sq + c1_2*h2sq) - c1_80*h2sq*h2sq + a(6,4) = a(2,4)*(a24sq + c3_4*h2sq)*(a24sq + c1_12*h2sq) + + a(1,5) = - c1 + a(2,5) = - c1_2*a(2,1) + a(3,5) = - c1_3*a(3,1) + a(4,5) = - c1_4*a(4,1) + a(5,5) = - c1_5*a(5,1) + a(6,5) = - c1_6*a(6,1) + + a(1,6) = - c1 + a(2,6) = - c1_2*a(2,2) + a(3,6) = - c1_3*a(3,2) + a(4,6) = - c1_4*a(4,2) + a(5,6) = - c1_5*a(5,2) + a(6,6) = - c1_6*a(6,2) + + call edge_ih6_slope_ih5_coeff_common(a, tdecoeff, tdscoeff) + + end subroutine edge_ih6_slope_ih5_coeff_asymright + + pure subroutine edge_eh4_lblu(h, a) + ! --------------------------------------------------------------------------- + ! Compute LU matrix for explicitly estimating 4th order accurate left + ! boundary edge value. + ! --------------------------------------------------------------------------- + + real(r8), dimension(:), intent(in) :: h + real(r8), dimension(:,:), intent(inout) :: a + + real(r8) :: a22sq, a32sq, a42sq, h2sq, h3sq, h4sq + + ! Define matrix for linear system to be solved for edge value. + + a(1:4,1) = c1 + + a(1,2) = c1_2*h(1) + a(2,2) = a(1,2) + c1_2*(h(1) + h(2)) + a(3,2) = a(2,2) + c1_2*(h(2) + h(3)) + a(4,2) = a(3,2) + c1_2*(h(3) + h(4)) + + a22sq = a(2,2)*a(2,2) + a32sq = a(3,2)*a(3,2) + a42sq = a(4,2)*a(4,2) + h2sq = h(2)*h(2) + h3sq = h(3)*h(3) + h4sq = h(4)*h(4) + + a(1,3) = c1_3*a(1,2)*h(1) + a(2,3) = c1_2*(a22sq + c1_12*h2sq) + a(3,3) = c1_2*(a32sq + c1_12*h3sq) + a(4,3) = c1_2*(a42sq + c1_12*h4sq) + + a(1,4) = c1_4*a(1,3)*h(1) + a(2,4) = c1_6*a(2,2)*(a22sq + c1_4*h2sq) + a(3,4) = c1_6*a(3,2)*(a32sq + c1_4*h3sq) + a(4,4) = c1_6*a(4,2)*(a42sq + c1_4*h4sq) + + ! LU decomposition. + call lu_decompose(4, a) + + end subroutine edge_eh4_lblu + + pure subroutine edge_eh4_rblu(h, a) + ! --------------------------------------------------------------------------- + ! Compute LU matrix for explicitly estimating 4th order accurate right + ! boundary edge value. + ! --------------------------------------------------------------------------- + + real(r8), dimension(:), intent(in) :: h + real(r8), dimension(:,:), intent(inout) :: a + + real(r8) :: a12sq, a22sq, a32sq, h1sq, h2sq, h3sq + + ! Define matrix for linear system to be solved for edge value. + + a(1:4,1) = c1 + + a(4,2) = - c1_2*h(4) + a(3,2) = a(4,2) - c1_2*(h(4) + h(3)) + a(2,2) = a(3,2) - c1_2*(h(3) + h(2)) + a(1,2) = a(2,2) - c1_2*(h(2) + h(1)) + + a12sq = a(1,2)*a(1,2) + a22sq = a(2,2)*a(2,2) + a32sq = a(3,2)*a(3,2) + h1sq = h(1)*h(1) + h2sq = h(2)*h(2) + h3sq = h(3)*h(3) + + a(1,3) = c1_2*(a12sq + c1_12*h1sq) + a(2,3) = c1_2*(a22sq + c1_12*h2sq) + a(3,3) = c1_2*(a32sq + c1_12*h3sq) + a(4,3) = - c1_3*a(4,2)*h(4) + + a(1,4) = c1_6*a(1,2)*(a12sq + c1_4*h1sq) + a(2,4) = c1_6*a(2,2)*(a22sq + c1_4*h2sq) + a(3,4) = c1_6*a(3,2)*(a32sq + c1_4*h3sq) + a(4,4) = - c1_4*a(4,3)*h(4) + + ! LU decomposition. + call lu_decompose(4, a) + + end subroutine edge_eh4_rblu + + pure subroutine edge_eh6_slope_eh5_lblu(h, a) + ! --------------------------------------------------------------------------- + ! Compute LU matrix for explicitly estimating 6th and 5th order accurate left + ! edge and slope values, respectively. + ! --------------------------------------------------------------------------- + + real(r8), dimension(:), intent(in) :: h + real(r8), dimension(:,:), intent(inout) :: a + + real(r8) :: a22sq, a32sq, a42sq, a52sq, a62sq, & + h2sq, h3sq, h4sq, h5sq, h6sq + + ! Define matrix for linear system to be solved for edge and slope values. + + a(1:6,1) = c1 + + a(1,2) = c1_2*h(1) + a(2,2) = a(1,2) + c1_2*(h(1) + h(2)) + a(3,2) = a(2,2) + c1_2*(h(2) + h(3)) + a(4,2) = a(3,2) + c1_2*(h(3) + h(4)) + a(5,2) = a(4,2) + c1_2*(h(4) + h(5)) + a(6,2) = a(5,2) + c1_2*(h(5) + h(6)) + + a22sq = a(2,2)*a(2,2) + a32sq = a(3,2)*a(3,2) + a42sq = a(4,2)*a(4,2) + a52sq = a(5,2)*a(5,2) + a62sq = a(6,2)*a(6,2) + h2sq = h(2)*h(2) + h3sq = h(3)*h(3) + h4sq = h(4)*h(4) + h5sq = h(5)*h(5) + h6sq = h(6)*h(6) + + a(1,3) = c1_3*a(1,2)*h(1) + a(2,3) = c1_2*(a22sq + c1_12*h2sq) + a(3,3) = c1_2*(a32sq + c1_12*h3sq) + a(4,3) = c1_2*(a42sq + c1_12*h4sq) + a(5,3) = c1_2*(a52sq + c1_12*h5sq) + a(6,3) = c1_2*(a62sq + c1_12*h6sq) + + a(1,4) = c1_4*a(1,3)*h(1) + a(2,4) = c1_6*a(2,2)*(a22sq + c1_4*h2sq) + a(3,4) = c1_6*a(3,2)*(a32sq + c1_4*h3sq) + a(4,4) = c1_6*a(4,2)*(a42sq + c1_4*h4sq) + a(5,4) = c1_6*a(5,2)*(a52sq + c1_4*h5sq) + a(6,4) = c1_6*a(6,2)*(a62sq + c1_4*h6sq) + + a(1,5) = c1_5*a(1,4)*h(1) + a(2,5) = c1_24*(a22sq*(a22sq + c1_2*h2sq) + c1_80*h2sq*h2sq) + a(3,5) = c1_24*(a32sq*(a32sq + c1_2*h3sq) + c1_80*h3sq*h3sq) + a(4,5) = c1_24*(a42sq*(a42sq + c1_2*h4sq) + c1_80*h4sq*h4sq) + a(5,5) = c1_24*(a52sq*(a52sq + c1_2*h5sq) + c1_80*h5sq*h5sq) + a(6,5) = c1_24*(a62sq*(a62sq + c1_2*h6sq) + c1_80*h6sq*h6sq) + + a(1,6) = c1_6*a(1,5)*h(1) + a(2,6) = c1_120*a(2,2)*(a22sq + c3_4*h2sq)*(a22sq + c1_12*h2sq) + a(3,6) = c1_120*a(3,2)*(a32sq + c3_4*h3sq)*(a32sq + c1_12*h3sq) + a(4,6) = c1_120*a(4,2)*(a42sq + c3_4*h4sq)*(a42sq + c1_12*h4sq) + a(5,6) = c1_120*a(5,2)*(a52sq + c3_4*h5sq)*(a52sq + c1_12*h5sq) + a(6,6) = c1_120*a(6,2)*(a62sq + c3_4*h6sq)*(a62sq + c1_12*h6sq) + + ! LU decomposition. + call lu_decompose(6, a) + + end subroutine edge_eh6_slope_eh5_lblu + + pure subroutine edge_eh6_slope_eh5_rblu(h, a) + ! --------------------------------------------------------------------------- + ! Compute LU matrix for explicitly estimating 6th and 5th order accurate + ! right edge and slope values, respectively. + ! --------------------------------------------------------------------------- + + real(r8), dimension(:), intent(in) :: h + real(r8), dimension(:,:), intent(inout) :: a + + real(r8) :: a12sq, a22sq, a32sq, a42sq, a52sq, & + h1sq, h2sq, h3sq, h4sq, h5sq + + ! Define matrix for linear system to be solved for edge and slope values. + + a(1:6,1) = c1 + + a(6,2) = - c1_2*h(6) + a(5,2) = a(6,2) - c1_2*(h(6) + h(5)) + a(4,2) = a(5,2) - c1_2*(h(5) + h(4)) + a(3,2) = a(4,2) - c1_2*(h(4) + h(3)) + a(2,2) = a(3,2) - c1_2*(h(3) + h(2)) + a(1,2) = a(2,2) - c1_2*(h(2) + h(1)) + + a12sq = a(1,2)*a(1,2) + a22sq = a(2,2)*a(2,2) + a32sq = a(3,2)*a(3,2) + a42sq = a(4,2)*a(4,2) + a52sq = a(5,2)*a(5,2) + h1sq = h(1)*h(1) + h2sq = h(2)*h(2) + h3sq = h(3)*h(3) + h4sq = h(4)*h(4) + h5sq = h(5)*h(5) + + a(1,3) = c1_2*(a12sq + c1_12*h1sq) + a(2,3) = c1_2*(a22sq + c1_12*h2sq) + a(3,3) = c1_2*(a32sq + c1_12*h3sq) + a(4,3) = c1_2*(a42sq + c1_12*h4sq) + a(5,3) = c1_2*(a52sq + c1_12*h5sq) + a(6,3) = - c1_3*a(6,2)*h(6) + + a(1,4) = c1_6*a(1,2)*(a12sq + c1_4*h1sq) + a(2,4) = c1_6*a(2,2)*(a22sq + c1_4*h2sq) + a(3,4) = c1_6*a(3,2)*(a32sq + c1_4*h3sq) + a(4,4) = c1_6*a(4,2)*(a42sq + c1_4*h4sq) + a(5,4) = c1_6*a(5,2)*(a52sq + c1_4*h5sq) + a(6,4) = - c1_4*a(6,3)*h(6) + + a(1,5) = c1_24*(a12sq*(a12sq + c1_2*h1sq) + c1_80*h1sq*h1sq) + a(2,5) = c1_24*(a22sq*(a22sq + c1_2*h2sq) + c1_80*h2sq*h2sq) + a(3,5) = c1_24*(a32sq*(a32sq + c1_2*h3sq) + c1_80*h3sq*h3sq) + a(4,5) = c1_24*(a42sq*(a42sq + c1_2*h4sq) + c1_80*h4sq*h4sq) + a(5,5) = c1_24*(a52sq*(a52sq + c1_2*h5sq) + c1_80*h5sq*h5sq) + a(6,5) = - c1_5*a(6,4)*h(6) + + a(1,6) = c1_120*a(1,2)*(a12sq + c3_4*h1sq)*(a12sq + c1_12*h1sq) + a(2,6) = c1_120*a(2,2)*(a22sq + c3_4*h2sq)*(a22sq + c1_12*h2sq) + a(3,6) = c1_120*a(3,2)*(a32sq + c3_4*h3sq)*(a32sq + c1_12*h3sq) + a(4,6) = c1_120*a(4,2)*(a42sq + c3_4*h4sq)*(a42sq + c1_12*h4sq) + a(5,6) = c1_120*a(5,2)*(a52sq + c3_4*h5sq)*(a52sq + c1_12*h5sq) + a(6,6) = - c1_6*a(6,5)*h(6) + + ! LU decomposition. + call lu_decompose(6, a) + + end subroutine edge_eh6_slope_eh5_rblu + + pure subroutine prepare_pqm(rcgs, x_edge_src) + ! --------------------------------------------------------------------------- + ! Prepare reconstruction with piecewise quartics using implicit 6th order + ! accurate edge and 5th order accurate slope estimation. + ! --------------------------------------------------------------------------- + + type(recon_grd_struct), intent(inout) :: rcgs + real(r8), dimension(:), intent(in) :: x_edge_src + + integer, dimension(rcgs%n_src) :: prev_index, next_index + real(r8) :: hp, h_max, h_min, h + integer :: ns, jp, j, last_index, jf, jl, n, j_min, jn, jd, js + integer :: first_index +! integer :: first_index = 0 ! Initialized to avoid compiler warning. + + ! Exclude near-empty grid cells and establish a doubly linked list that + ! connects the remaining grid cells. + ns = 0 + jp = 0 + do j = 1, rcgs%n_src + rcgs%h_src(j) = abs(x_edge_src(j+1) - x_edge_src(j)) + if (rcgs%h_src(j) > c2*rcgs%x_eps) then + ns = ns + 1 + rcgs%src_dst_index(j) = 1 + prev_index(j) = jp + if (jp == 0) then + first_index = j + else + next_index(jp) = j + endif + jp = j + else + rcgs%src_dst_index(j) = 0 + endif + enddo + last_index = jp + next_index(jp) = 0 + if (ns < 6) then + rcgs%n_src_actual = ns + return + endif + + ! Exclude grid cells that may lead to large condition numbers for the + ! linear systems to be solved in edge_ih6_slope_ih5_coeff_asymleft, + ! edge_ih6_slope_ih5_coeff_sym and edge_ih6_slope_ih5_coeff_asymright. + ! Excluded grid cells are merged with the non-excluded neighbour grid cell + ! having the smallest grid cell width. + jf = first_index + outer: do + j = jf + hp = rcgs%h_src(j) + h_max = rcgs%h_src(j) + do n = 1, 3 + j = next_index(j) + if (j == 0) exit outer + hp = hp*rcgs%h_src(j) + h_max = max(h_max, rcgs%h_src(j)) + enddo + if (hp > hplim_ih6*h_max**4) then + jf = next_index(jf) + else + ns = ns - 1 + if (ns < 6) then + rcgs%n_src_actual = ns + return + endif + j = jf + h_min = rcgs%h_src(j) + j_min = j + do n = 1, 3 + j = next_index(j) + if (rcgs%h_src(j) < h_min) then + h_min = rcgs%h_src(j) + j_min = j + endif + enddo + jp = prev_index(j_min) + jn = next_index(j_min) + if (jp == 0) then + rcgs%src_dst_index(j_min) = - jn + rcgs%h_src(jn) = rcgs%h_src(jn) + rcgs%h_src(j_min) + first_index = jn + prev_index(jn) = 0 + jf = jn + elseif (jn == 0) then + rcgs%src_dst_index(j_min) = - jp + rcgs%h_src(jp) = rcgs%h_src(jp) + rcgs%h_src(j_min) + next_index(jp) = 0 + last_index = jp + exit + else + if (rcgs%h_src(jn) < rcgs%h_src(jp)) then + rcgs%src_dst_index(j_min) = - jn + rcgs%h_src(jn) = rcgs%h_src(jn) + rcgs%h_src(j_min) + else + rcgs%src_dst_index(j_min) = - jp + rcgs%h_src(jp) = rcgs%h_src(jp) + rcgs%h_src(j_min) + endif + next_index(jp) = jn + prev_index(jn) = jp + jf = jp + if (jf /= first_index) then + jf = prev_index(jf) + if (jf /= first_index) jf = prev_index(jf) + endif + endif + endif + enddo outer + + ! Exclude grid cells that may lead to a large condition number for the + ! linear system to be solved in edge_eh6_slope_eh5_lblu. Excluded grid + ! cells are merged with the non-excluded neighbour grid cell having the + ! smallest grid cell width. + jf = first_index + do + j = jf + hp = rcgs%h_src(j) + h_max = rcgs%h_src(j) + do n = 1, 5 + j = next_index(j) + hp = hp*rcgs%h_src(j) + h_max = max(h_max, rcgs%h_src(j)) + enddo + if (hp > hplim_eh6*h_max**6) then + exit + else + ns = ns - 1 + if (ns < 6) then + rcgs%n_src_actual = ns + return + endif + j = jf + h_min = rcgs%h_src(j) + j_min = j + do n = 1, 5 + j = next_index(j) + if (rcgs%h_src(j) < h_min) then + h_min = rcgs%h_src(j) + j_min = j + endif + enddo + jp = prev_index(j_min) + jn = next_index(j_min) + if (jp == 0) then + rcgs%src_dst_index(j_min) = - jn + rcgs%h_src(jn) = rcgs%h_src(jn) + rcgs%h_src(j_min) + first_index = jn + prev_index(jn) = 0 + jf = jn + else + if (rcgs%h_src(jn) < rcgs%h_src(jp)) then + rcgs%src_dst_index(j_min) = - jn + rcgs%h_src(jn) = rcgs%h_src(jn) + rcgs%h_src(j_min) + else + rcgs%src_dst_index(j_min) = - jp + rcgs%h_src(jp) = rcgs%h_src(jp) + rcgs%h_src(j_min) + endif + next_index(jp) = jn + prev_index(jn) = jp + endif + endif + enddo + + ! Exclude grid cells that may lead to a large condition number for the + ! linear system to be solved in edge_eh6_slope_eh5_rblu. Excluded grid + ! cells are merged with the non-excluded neighbour grid cell having the + ! smallest grid cell width. + jl = last_index + do + j = jl + hp = rcgs%h_src(j) + h_max = rcgs%h_src(j) + do n = 1, 5 + j = prev_index(j) + hp = hp*rcgs%h_src(j) + h_max = max(h_max, rcgs%h_src(j)) + enddo + if (hp > hplim_eh6*h_max**6) then + exit + else + ns = ns - 1 + if (ns < 6) then + rcgs%n_src_actual = ns + return + endif + j = jl + h_min = rcgs%h_src(j) + j_min = j + do n = 1, 5 + j = prev_index(j) + if (rcgs%h_src(j) < h_min) then + h_min = rcgs%h_src(j) + j_min = j + endif + enddo + jp = prev_index(j_min) + jn = next_index(j_min) + if (jn == 0) then + rcgs%src_dst_index(j_min) = - jp + rcgs%h_src(jp) = rcgs%h_src(jp) + rcgs%h_src(j_min) + next_index(jp) = 0 + jl = jp + else + if (rcgs%h_src(jn) < rcgs%h_src(jp)) then + rcgs%src_dst_index(j_min) = - jn + rcgs%h_src(jn) = rcgs%h_src(jn) + rcgs%h_src(j_min) + else + rcgs%src_dst_index(j_min) = - jp + rcgs%h_src(jp) = rcgs%h_src(jp) + rcgs%h_src(j_min) + endif + next_index(jp) = jn + prev_index(jn) = jp + endif + endif + enddo + + ! For the non-excluded grid cells, assign the destination index in the + ! continuous array of grid cells to be used in the reconstruction. Also + ! set the grid cell widths of the continuous array. + jd = 0 + do js = 1, rcgs%n_src + if (rcgs%src_dst_index(js) > 0) then + jd = jd + 1 + rcgs%src_dst_index(js) = jd + rcgs%h_src(jd) = rcgs%h_src(js) + rcgs%hi_src(jd) = c1/rcgs%h_src(jd) + endif + enddo + + ! Find the destination index of excluded grid cells to be merged and + ! compute the mapping weights. + do js = 1, rcgs%n_src + jd = rcgs%src_dst_index(js) + do while (jd < 0) + jd = rcgs%src_dst_index(- jd) + enddo + rcgs%src_dst_index(js) = jd + if (jd > 0) then + h = abs(x_edge_src(js+1) - x_edge_src(js)) + if (abs(h - rcgs%h_src(jd)) < rcgs%x_eps) then + rcgs%src_dst_weight(js) = c1 + else + rcgs%src_dst_weight(js) = h*rcgs%hi_src(jd) + endif + endif + enddo + + ! Set source edge values in the continuous reconstruction array. + rcgs%x_edge_src(1) = x_edge_src(1) + js = 1 + do j = 1, ns-1 + do + js = js + 1 + if (rcgs%src_dst_index(js) /= j .and. & + rcgs%src_dst_index(js) /= 0) exit + enddo + rcgs%x_edge_src(j+1) = x_edge_src(js) + enddo + rcgs%x_edge_src(ns+1) = x_edge_src(rcgs%n_src+1) + + ! Compute the multiplicative inverse of cell width used for estimating + ! centered linear slope. + do j = 2, ns-1 + rcgs%hci_src(j) = c2/( rcgs%h_src(j-1) + c2*rcgs%h_src(j) & + + rcgs%h_src(j+1)) + enddo + + ! Compute coefficients for the tridiagonal system of equations for the + ! estimation of interior edge and slope values. + call edge_ih6_slope_ih5_coeff_asymleft(rcgs%h_src(1:4), & + rcgs%tdecoeff(:,2), & + rcgs%tdscoeff(:,2)) + do j = 3, ns-1 + call edge_ih6_slope_ih5_coeff_sym(rcgs%h_src((j-2):(j+1)), & + rcgs%tdecoeff(:,j), & + rcgs%tdscoeff(:,j)) + enddo + call edge_ih6_slope_ih5_coeff_asymright(rcgs%h_src((ns-3):ns), & + rcgs%tdecoeff(:,ns), & + rcgs%tdscoeff(:,ns)) + + ! Compute LU matrices for the explicit estimation of boundary edge and + ! slope values. + call edge_eh6_slope_eh5_lblu(rcgs%h_src(1:6), rcgs%lblu) + call edge_eh6_slope_eh5_rblu(rcgs%h_src((ns-5):ns), rcgs%rblu) + + rcgs%n_src_actual = ns + + end subroutine prepare_pqm + + pure subroutine prepare_ppm(rcgs, x_edge_src) + ! --------------------------------------------------------------------------- + ! Prepare reconstruction with piecewise parabolas using implicit 4th order + ! accurate edge estimation. + ! --------------------------------------------------------------------------- + + type(recon_grd_struct), intent(inout) :: rcgs + real(r8), dimension(:), intent(in) :: x_edge_src + + integer, dimension(rcgs%n_src) :: prev_index, next_index + real(r8) :: hp, h_max, h_min, h + integer :: ns, jp, j, last_index, jf, jl, n, j_min, jn, jd, js + integer :: first_index +! integer :: first_index = 0 ! Initialized to avoid compiler warning. + + ! Exclude near-empty grid cells and establish a doubly linked list that + ! connects the remaining grid cells. + ns = 0 + jp = 0 + do j = 1, rcgs%n_src + rcgs%h_src(j) = abs(x_edge_src(j+1) - x_edge_src(j)) + if (rcgs%h_src(j) > c2*rcgs%x_eps) then + ns = ns + 1 + rcgs%src_dst_index(j) = 1 + prev_index(j) = jp + if (jp == 0) then + first_index = j + else + next_index(jp) = j + endif + jp = j + else + rcgs%src_dst_index(j) = 0 + endif + enddo + last_index = jp + next_index(jp) = 0 + if (ns < 4) then + rcgs%n_src_actual = ns + return + endif + + ! Exclude grid cells that may lead to large condition numbers for the + ! linear systems to be solved in edge_ih4_coeff. Excluded grid cells are + ! merged with the non-excluded neighbour grid cell having the smallest + ! grid cell width. + jf = first_index + jl = next_index(jf) + do + if (rcgs%h_src(jf)*rcgs%h_src(jl) > & + hplim_ih4*max(rcgs%h_src(jf), rcgs%h_src(jl))**2) then + jf = jl + jl = next_index(jf) + if (jl == 0) exit + else + ns = ns - 1 + if (ns < 4) then + rcgs%n_src_actual = ns + return + endif + if (rcgs%h_src(jf) < rcgs%h_src(jl)) then + j = jf + jf = prev_index(jf) + prev_index(jl) = jf + if (jf == 0) then + rcgs%src_dst_index(j) = - jl + rcgs%h_src(jl) = rcgs%h_src(jl) + rcgs%h_src(j) + first_index = jl + jf = jl + jl = next_index(jf) + if (jl == 0) exit + else + if (rcgs%h_src(jf) < rcgs%h_src(jl)) then + rcgs%src_dst_index(j) = - jf + rcgs%h_src(jf) = rcgs%h_src(jf) + rcgs%h_src(j) + else + rcgs%src_dst_index(j) = - jl + rcgs%h_src(jl) = rcgs%h_src(jl) + rcgs%h_src(j) + endif + next_index(jf) = jl + endif + else + j = jl + jl = next_index(jl) + next_index(jf) = jl + if (jl == 0) then + rcgs%src_dst_index(j) = - jf + rcgs%h_src(jf) = rcgs%h_src(jf) + rcgs%h_src(j) + last_index = jf + exit + endif + if (rcgs%h_src(jf) < rcgs%h_src(jl)) then + rcgs%src_dst_index(j) = - jf + rcgs%h_src(jf) = rcgs%h_src(jf) + rcgs%h_src(j) + else + rcgs%src_dst_index(j) = - jl + rcgs%h_src(jl) = rcgs%h_src(jl) + rcgs%h_src(j) + endif + prev_index(jl) = jf + endif + endif + enddo + + ! Exclude grid cells that may lead to a large condition number for the + ! linear system to be solved in edge_eh4_lblu. Excluded grid cells are + ! merged with the non-excluded neighbour grid cell having the smallest + ! grid cell width. + jf = first_index + do + j = jf + hp = rcgs%h_src(j) + h_max = rcgs%h_src(j) + do n = 1, 3 + j = next_index(j) + hp = hp*rcgs%h_src(j) + h_max = max(h_max, rcgs%h_src(j)) + enddo + if (hp > hplim_eh4*h_max**4) then + exit + else + ns = ns - 1 + if (ns < 4) then + rcgs%n_src_actual = ns + return + endif + j = jf + h_min = rcgs%h_src(j) + j_min = j + do n = 1, 3 + j = next_index(j) + if (rcgs%h_src(j) < h_min) then + h_min = rcgs%h_src(j) + j_min = j + endif + enddo + jp = prev_index(j_min) + jn = next_index(j_min) + if (jp == 0) then + rcgs%src_dst_index(j_min) = - jn + rcgs%h_src(jn) = rcgs%h_src(jn) + rcgs%h_src(j_min) + first_index = jn + prev_index(jn) = 0 + jf = jn + else + if (rcgs%h_src(jn) < rcgs%h_src(jp)) then + rcgs%src_dst_index(j_min) = - jn + rcgs%h_src(jn) = rcgs%h_src(jn) + rcgs%h_src(j_min) + else + rcgs%src_dst_index(j_min) = - jp + rcgs%h_src(jp) = rcgs%h_src(jp) + rcgs%h_src(j_min) + endif + next_index(jp) = jn + prev_index(jn) = jp + endif + endif + enddo + + ! Exclude grid cells that may lead to a large condition number for the + ! linear system to be solved in edge_eh4_rblu. Excluded grid cells are + ! merged with the non-excluded neighbour grid cell having the smallest + ! grid cell width. + jl = last_index + do + j = jl + hp = rcgs%h_src(j) + h_max = rcgs%h_src(j) + do n = 1, 3 + j = prev_index(j) + hp = hp*rcgs%h_src(j) + h_max = max(h_max, rcgs%h_src(j)) + enddo + if (hp > hplim_eh4*h_max**4) then + exit + else + ns = ns - 1 + if (ns < 4) then + rcgs%n_src_actual = ns + return + endif + j = jl + h_min = rcgs%h_src(j) + j_min = j + do n = 1, 3 + j = prev_index(j) + if (rcgs%h_src(j) < h_min) then + h_min = rcgs%h_src(j) + j_min = j + endif + enddo + jp = prev_index(j_min) + jn = next_index(j_min) + if (jn == 0) then + rcgs%src_dst_index(j_min) = - jp + rcgs%h_src(jp) = rcgs%h_src(jp) + rcgs%h_src(j_min) + next_index(jp) = 0 + jl = jp + else + if (rcgs%h_src(jn) < rcgs%h_src(jp)) then + rcgs%src_dst_index(j_min) = - jn + rcgs%h_src(jn) = rcgs%h_src(jn) + rcgs%h_src(j_min) + else + rcgs%src_dst_index(j_min) = - jp + rcgs%h_src(jp) = rcgs%h_src(jp) + rcgs%h_src(j_min) + endif + next_index(jp) = jn + prev_index(jn) = jp + endif + endif + enddo + + ! For the non-excluded grid cells, assign the destination index in the + ! continuous array of grid cells to be used in the reconstruction. Also + ! set the grid cell widths of the continuous array. + jd = 0 + do js = 1, rcgs%n_src + if (rcgs%src_dst_index(js) > 0) then + jd = jd + 1 + rcgs%src_dst_index(js) = jd + rcgs%h_src(jd) = rcgs%h_src(js) + rcgs%hi_src(jd) = c1/rcgs%h_src(jd) + endif + enddo + + ! Find the destination index of excluded grid cells to be merged and + ! compute the mapping weights. + do js = 1, rcgs%n_src + jd = rcgs%src_dst_index(js) + do while (jd < 0) + jd = rcgs%src_dst_index(- jd) + enddo + rcgs%src_dst_index(js) = jd + if (jd > 0) then + h = abs(x_edge_src(js+1) - x_edge_src(js)) + if (abs(h - rcgs%h_src(jd)) < rcgs%x_eps) then + rcgs%src_dst_weight(js) = c1 + else + rcgs%src_dst_weight(js) = h*rcgs%hi_src(jd) + endif + endif + enddo + + ! Set source edge values in the continuous reconstruction array. + rcgs%x_edge_src(1) = x_edge_src(1) + js = 1 + do j = 1, ns-1 + do + js = js + 1 + if (rcgs%src_dst_index(js) /= j .and. & + rcgs%src_dst_index(js) /= 0) exit + enddo + rcgs%x_edge_src(j+1) = x_edge_src(js) + enddo + rcgs%x_edge_src(ns+1) = x_edge_src(rcgs%n_src+1) + + ! Compute the multiplicative inverse of cell width used for estimating + ! centered linear slope. + do j = 2, ns-1 + rcgs%hci_src(j) = c2/( rcgs%h_src(j-1) + c2*rcgs%h_src(j) & + + rcgs%h_src(j+1)) + enddo + + ! Compute coefficients for the tridiagonal system of equations for the + ! estimation of interior edge values. + do j = 2, ns + call edge_ih4_coeff(rcgs%h_src((j-1):j), rcgs%tdecoeff(:,j)) + enddo + + ! Compute LU matrices for the explicit estimation of boundary edge values. + call edge_eh4_lblu(rcgs%h_src(1:4), rcgs%lblu) + call edge_eh4_rblu(rcgs%h_src((ns-3):ns), rcgs%rblu) + + rcgs%n_src_actual = ns + + end subroutine prepare_ppm + + pure subroutine prepare_plm(rcgs, x_edge_src) + ! --------------------------------------------------------------------------- + ! Prepare reconstruction with piecewise lines. + ! --------------------------------------------------------------------------- + + type(recon_grd_struct), intent(inout) :: rcgs + real(r8), dimension(:), intent(in) :: x_edge_src + + integer :: ns, j, js + + ! Exclude near-empty grid cells and assign the destination index in the + ! continuous array of grid cells to be used in the reconstruction. + ns = 0 + do j = 1, rcgs%n_src + if (abs(x_edge_src(j+1) - x_edge_src(j)) > c2*rcgs%x_eps) then + ns = ns + 1 + rcgs%src_dst_index(j) = ns + else + rcgs%src_dst_index(j) = 0 + endif + enddo + if (ns < 2) then + rcgs%n_src_actual = ns + return + endif + + ! Set source edge values in the continuous reconstruction array. + rcgs%x_edge_src(1) = x_edge_src(1) + js = 1 + do j = 1, ns-1 + do + js = js + 1 + if (rcgs%src_dst_index(js) /= j .and. & + rcgs%src_dst_index(js) /= 0) exit + enddo + rcgs%x_edge_src(j+1) = x_edge_src(js) + enddo + rcgs%x_edge_src(ns+1) = x_edge_src(rcgs%n_src+1) + + ! From edge locations, obtain source grid cell widths and their + ! multiplicative inverse. + do j = 1, ns + rcgs%h_src(j) = abs(rcgs%x_edge_src(j+1) - rcgs%x_edge_src(j)) + rcgs%hi_src(j) = c1/rcgs%h_src(j) + enddo + + ! Compute the multiplicative inverse of cell width used for estimating + ! centered linear slope. + do j = 2, ns-1 + rcgs%hci_src(j) = c2/( rcgs%h_src(j-1) + c2*rcgs%h_src(j) & + + rcgs%h_src(j+1)) + enddo + + rcgs%n_src_actual = ns + + end subroutine prepare_plm + + pure subroutine prepare_pcm(rcgs, x_edge_src) + ! --------------------------------------------------------------------------- + ! Prepare piecewise constant reconstruction. + ! --------------------------------------------------------------------------- + + type(recon_grd_struct), intent(inout) :: rcgs + real(r8), dimension(:), intent(in) :: x_edge_src + + integer :: ns, j, js + + ! Exclude near-empty grid cells and assign the destination index in the + ! continuous array of grid cells to be used in the reconstruction. + ns = 0 + do j = 1, rcgs%n_src + if (abs(x_edge_src(j+1) - x_edge_src(j)) > c2*rcgs%x_eps) then + ns = ns + 1 + rcgs%src_dst_index(j) = ns + else + rcgs%src_dst_index(j) = 0 + endif + enddo + if (ns == 0) then + rcgs%n_src_actual = ns + return + endif + + ! Set source edge values in the continuous reconstruction array. + rcgs%x_edge_src(1) = x_edge_src(1) + js = 1 + do j = 1, ns-1 + do + js = js + 1 + if (rcgs%src_dst_index(js) /= j .and. & + rcgs%src_dst_index(js) /= 0) exit + enddo + rcgs%x_edge_src(j+1) = x_edge_src(js) + enddo + rcgs%x_edge_src(ns+1) = x_edge_src(rcgs%n_src+1) + + ! From edge locations, obtain source grid cell widths and their + ! multiplicative inverse. + do j = 1, ns + rcgs%h_src(j) = abs(rcgs%x_edge_src(j+1) - rcgs%x_edge_src(j)) + rcgs%hi_src(j) = c1/rcgs%h_src(j) + enddo + + rcgs%n_src_actual = ns + + end subroutine prepare_pcm + + pure subroutine reconstruct_plm_no_limiting(rcss) + ! --------------------------------------------------------------------------- + ! Carry out a reconstruction with piecewise lines. + ! --------------------------------------------------------------------------- + + type(recon_src_struct), intent(inout) :: rcss + + real(r8) :: sc + integer :: ns, j + + ns = rcss%rcgs%n_src_actual + + sc = c2*(rcss%u_src(2) - rcss%u_src(1)) & + /(rcss%rcgs%h_src(2) + rcss%rcgs%h_src(1)) + rcss%polycoeff(2,1) = sc*rcss%rcgs%h_src(1) + rcss%polycoeff(1,1) = rcss%u_src(1) - c1_2*rcss%polycoeff(2,1) + rcss%uel(1) = rcss%polycoeff(1,1) + rcss%uer(1) = rcss%polycoeff(1,1) + rcss%polycoeff(2,1) + do j = 2, ns-1 + sc = (rcss%u_src(j+1) - rcss%u_src(j-1))*rcss%rcgs%hci_src(j) + rcss%polycoeff(2,j) = sc*rcss%rcgs%h_src(j) + rcss%polycoeff(1,j) = rcss%u_src(j) - c1_2*rcss%polycoeff(2,j) + rcss%uel(j) = rcss%polycoeff(1,j) + rcss%uer(j) = rcss%polycoeff(1,j) + rcss%polycoeff(2,j) + enddo + sc = c2*(rcss%u_src(ns) - rcss%u_src(ns-1)) & + /(rcss%rcgs%h_src(ns) + rcss%rcgs%h_src(ns-1)) + rcss%polycoeff(2,ns) = sc*rcss%rcgs%h_src(ns) + rcss%polycoeff(1,ns) = rcss%u_src(ns) - c1_2*rcss%polycoeff(2,ns) + rcss%uel(ns) = rcss%polycoeff(1,ns) + rcss%uer(ns) = rcss%polycoeff(1,ns) + rcss%polycoeff(2,ns) + + rcss%polycoeff(3:rcss%rcgs%p_ord+1,:) = c0 + + end subroutine reconstruct_plm_no_limiting + + pure subroutine reconstruct_plm_monotonic(rcss) + ! --------------------------------------------------------------------------- + ! Carry out a reconstruction with piecewise lines and apply limiting to + ! ensure a monotonic reconstruction. + ! --------------------------------------------------------------------------- + + type(recon_src_struct), intent(inout) :: rcss + + real(r8) :: sl, sr, sc + integer :: ns, j + + ns = rcss%rcgs%n_src_actual + + ! Use monotonized central-difference limiter for interior grid cells. + do j = 2, ns-1 + sl = c2*(rcss%u_src(j) - rcss%u_src(j-1))*rcss%rcgs%hi_src(j) + sr = c2*(rcss%u_src(j+1) - rcss%u_src(j))*rcss%rcgs%hi_src(j) + if (sl*sr > c0) then + sc = (rcss%u_src(j+1) - rcss%u_src(j-1))*rcss%rcgs%hci_src(j) + sc = sign(min(abs(sl), abs(sr), abs(sc)), sc) + else + sc = c0 + endif + rcss%polycoeff(2,j) = sc*rcss%rcgs%h_src(j) + rcss%polycoeff(1,j) = rcss%u_src(j) - c1_2*rcss%polycoeff(2,j) + rcss%uel(j) = rcss%polycoeff(1,j) + rcss%uer(j) = rcss%polycoeff(1,j) + rcss%polycoeff(2,j) + enddo + + if (rcss%pc_left_bndr) then + ! Piecewise constant reconstruction of left boundary cell. + rcss%polycoeff(1,1) = rcss%u_src(1) + rcss%polycoeff(2,1) = c0 + rcss%uel(1) = rcss%u_src(1) + rcss%uer(1) = rcss%u_src(1) + else + ! Piecewise linear reconstruction of left boundary cell. + sc = c2*(rcss%u_src(2) - rcss%u_src(1)) & + /(rcss%rcgs%h_src(2) + rcss%rcgs%h_src(1)) + rcss%polycoeff(2,1) = sc*rcss%rcgs%h_src(1) + rcss%polycoeff(1,1) = rcss%u_src(1) - c1_2*rcss%polycoeff(2,1) + rcss%uel(1) = rcss%polycoeff(1,1) + rcss%uer(1) = rcss%polycoeff(1,1) + rcss%polycoeff(2,1) + endif + + if (rcss%pc_right_bndr) then + ! Piecewise constant reconstruction of right boundary cell. + rcss%polycoeff(1,ns) = rcss%u_src(ns) + rcss%polycoeff(2,ns) = c0 + rcss%uel(ns) = rcss%u_src(ns) + rcss%uer(ns) = rcss%u_src(ns) + else + ! Piecewise linear reconstruction of right boundary cell. + sc = c2*(rcss%u_src(ns) - rcss%u_src(ns-1)) & + /(rcss%rcgs%h_src(ns) + rcss%rcgs%h_src(ns-1)) + rcss%polycoeff(2,ns) = sc*rcss%rcgs%h_src(ns) + rcss%polycoeff(1,ns) = rcss%u_src(ns) - c1_2*rcss%polycoeff(2,ns) + rcss%uel(ns) = rcss%polycoeff(1,ns) + rcss%uer(ns) = rcss%polycoeff(1,ns) + rcss%polycoeff(2,ns) + endif + + rcss%polycoeff(3:rcss%rcgs%p_ord+1,:) = c0 + + end subroutine reconstruct_plm_monotonic + + pure subroutine reconstruct_ppm_edge_values(rcss) + ! --------------------------------------------------------------------------- + ! Reconstruct edge values using an implicit 4th order scheme. + ! --------------------------------------------------------------------------- + + type(recon_src_struct), intent(inout) :: rcss + + real(r8), dimension(4) :: x + real(r8), dimension(rcss%rcgs%n_src_actual+1) :: uedge + real(r8), dimension(rcss%rcgs%n_src_actual) :: rhs, gam + real(r8) :: bei + integer :: ns, j + + ns = rcss%rcgs%n_src_actual + + ! Obtain the left boundary edge value. + x(:) = rcss%u_src(1:4) + call lu_solve(4, rcss%rcgs%lblu, x) + uedge(1) = x(1) + + ! Obtain the right boundary edge value. + x(:) = rcss%u_src((ns-3):ns) + call lu_solve(4, rcss%rcgs%rblu, x) + uedge(ns+1) = x(1) + + ! Obtain right hand side of tridiagonal system of equations. + do j = 2, ns + rhs(j) = rcss%rcgs%tdecoeff(3,j)*rcss%u_src(j-1) & + + rcss%rcgs%tdecoeff(4,j)*rcss%u_src(j ) + enddo + + ! Solve tridiagonal system of equations to obtain interior edge values. + gam(1) = c0 + do j = 2, ns + bei = c1/(c1 - rcss%rcgs%tdecoeff(1,j)*gam(j-1)) + uedge(j) = (rhs(j) - rcss%rcgs%tdecoeff(1,j)*uedge(j-1))*bei + gam(j) = rcss%rcgs%tdecoeff(2,j)*bei + enddo + do j = ns, 2, -1 + uedge(j) = uedge(j) - gam(j)*uedge(j+1) + enddo + + ! Set left and right edge values for each grid cell. + rcss%uel(1:ns) = uedge(1:ns) + rcss%uer(1:ns) = uedge(2:(ns+1)) + + end subroutine reconstruct_ppm_edge_values + + pure subroutine reconstruct_pqm_edge_slope_values(rcss) + ! --------------------------------------------------------------------------- + ! Reconstruct edge and slope values using implicit 6th and 5th order schemes, + ! respectively. + ! --------------------------------------------------------------------------- + + type(recon_src_struct), intent(inout) :: rcss + + real(r8), dimension(6) :: x + real(r8), dimension(rcss%rcgs%n_src_actual+1) :: uedge, uslope + real(r8), dimension(rcss%rcgs%n_src_actual) :: rhs, gam + real(r8) :: bei + integer :: ns, j + + ns = rcss%rcgs%n_src_actual + + ! Obtain the left boundary edge and slope values. + x(:) = rcss%u_src(1:6) + call lu_solve(6, rcss%rcgs%lblu, x) + uedge(1) = x(1) + uslope(1) = x(2) + + ! Obtain the right boundary edge and slope values. + x(:) = rcss%u_src((ns - 5):ns) + call lu_solve(6, rcss%rcgs%rblu, x) + uedge(ns+1) = x(1) + uslope(ns+1) = x(2) + + ! Obtain right hand side of tridiagonal system of equations for edge + ! values. + rhs(2) = rcss%rcgs%tdecoeff(3,2)*rcss%u_src(1) & + + rcss%rcgs%tdecoeff(4,2)*rcss%u_src(2) & + + rcss%rcgs%tdecoeff(5,2)*rcss%u_src(3) & + + rcss%rcgs%tdecoeff(6,2)*rcss%u_src(4) + do j = 3, ns-1 + rhs(j) = rcss%rcgs%tdecoeff(3,j)*rcss%u_src(j-2) & + + rcss%rcgs%tdecoeff(4,j)*rcss%u_src(j-1) & + + rcss%rcgs%tdecoeff(5,j)*rcss%u_src(j ) & + + rcss%rcgs%tdecoeff(6,j)*rcss%u_src(j+1) + enddo + rhs(ns) = rcss%rcgs%tdecoeff(3,ns)*rcss%u_src(ns-3) & + + rcss%rcgs%tdecoeff(4,ns)*rcss%u_src(ns-2) & + + rcss%rcgs%tdecoeff(5,ns)*rcss%u_src(ns-1) & + + rcss%rcgs%tdecoeff(6,ns)*rcss%u_src(ns ) + + ! Solve tridiagonal system of equations to obtain interior edge values. + gam(1) = c0 + do j = 2, ns + bei = c1/(c1 - rcss%rcgs%tdecoeff(1,j)*gam(j-1)) + uedge(j) = (rhs(j) - rcss%rcgs%tdecoeff(1,j)*uedge(j-1))*bei + gam(j) = rcss%rcgs%tdecoeff(2,j)*bei + enddo + do j = ns, 2, -1 + uedge(j) = uedge(j) - gam(j)*uedge(j+1) + enddo + + ! Obtain right hand side of tridiagonal system of equations for slope + ! values. + rhs(2) = rcss%rcgs%tdscoeff(3,2)*rcss%u_src(1) & + + rcss%rcgs%tdscoeff(4,2)*rcss%u_src(2) & + + rcss%rcgs%tdscoeff(5,2)*rcss%u_src(3) & + + rcss%rcgs%tdscoeff(6,2)*rcss%u_src(4) + do j = 3, ns-1 + rhs(j) = rcss%rcgs%tdscoeff(3,j)*rcss%u_src(j-2) & + + rcss%rcgs%tdscoeff(4,j)*rcss%u_src(j-1) & + + rcss%rcgs%tdscoeff(5,j)*rcss%u_src(j ) & + + rcss%rcgs%tdscoeff(6,j)*rcss%u_src(j+1) + enddo + rhs(ns) = rcss%rcgs%tdscoeff(3,ns)*rcss%u_src(ns-3) & + + rcss%rcgs%tdscoeff(4,ns)*rcss%u_src(ns-2) & + + rcss%rcgs%tdscoeff(5,ns)*rcss%u_src(ns-1) & + + rcss%rcgs%tdscoeff(6,ns)*rcss%u_src(ns ) + + ! Solve tridiagonal system of equations to obtain interior slope values. + gam(1) = c0 + do j = 2, ns + bei = c1/(c1 - rcss%rcgs%tdscoeff(1,j)*gam(j-1)) + uslope(j) = (rhs(j) - rcss%rcgs%tdscoeff(1,j)*uslope(j-1))*bei + gam(j) = rcss%rcgs%tdscoeff(2,j)*bei + enddo + do j = ns, 2, -1 + uslope(j) = uslope(j) - gam(j)*uslope(j+1) + enddo + + ! Set left and right edge values for each grid cell. + rcss%uel(1:ns) = uedge(1:ns) + rcss%uer(1:ns) = uedge(2:(ns+1)) + + ! Set left and right slope values for each grid cell and scale the slope + ! values with the grid cell widths. + rcss%usl(1:ns) = uslope(1:ns)*rcss%rcgs%h_src(1:ns) + rcss%usr(1:ns) = uslope(2:(ns+1))*rcss%rcgs%h_src(1:ns) + + end subroutine reconstruct_pqm_edge_slope_values + + pure subroutine limit_ppm_interior_monotonic(rcss) + ! --------------------------------------------------------------------------- + ! Apply limiting to ensure a monotonic reconstruction of piecewise parabolas + ! for interior grid cells. + ! --------------------------------------------------------------------------- + + type(recon_src_struct), intent(inout) :: rcss + + real(r8) :: sl, sr, sc, d, q, r + integer :: ns, j + + ns = rcss%rcgs%n_src_actual + + do j = 2, ns-1 + sl = c2*(rcss%u_src(j) - rcss%u_src(j-1))*rcss%rcgs%hi_src(j) + sr = c2*(rcss%u_src(j+1) - rcss%u_src(j))*rcss%rcgs%hi_src(j) + if (sl*sr > c0) then + sc = (rcss%u_src(j+1) - rcss%u_src(j-1))*rcss%rcgs%hci_src(j) + sc = sign(min(abs(sl), abs(sr), abs(sc)), sc) + if ( (rcss%u_src(j-1) - rcss%uel(j)) & + *(rcss%u_src(j ) - rcss%uel(j)) > c0) & + rcss%uel(j) = rcss%u_src(j) & + - sign(min(c1_2*rcss%rcgs%h_src(j)*abs(sc), & + abs(rcss%uel(j) - rcss%u_src(j))), sc) + if ( (rcss%u_src(j+1) - rcss%uer(j)) & + *(rcss%u_src(j ) - rcss%uer(j)) > c0) & + rcss%uer(j) = rcss%u_src(j) & + + sign(min(c1_2*rcss%rcgs%h_src(j)*abs(sc), & + abs(rcss%uer(j) - rcss%u_src(j))), sc) + else + rcss%uel(j) = rcss%u_src(j) + rcss%uer(j) = rcss%u_src(j) + endif + enddo + +! do j = 2, ns-1 + do j = 3, ns-1 + if ( (rcss%uel(j) - rcss%uer(j-1)) & + *(rcss%u_src(j) - rcss%u_src(j-1)) < c0) then + rcss%uel(j) = c1_2*(rcss%uer(j-1) + rcss%uel(j)) + rcss%uer(j-1) = rcss%uel(j) + endif + enddo + + do j = 2, ns-1 + d = rcss%uer(j) - rcss%uel(j) + q = d*(c2*rcss%u_src(j) - rcss%uel(j) - rcss%uer(j)) + r = c1_3*d*d + if ( q > r) then + rcss%uel(j) = c3*rcss%u_src(j) - c2*rcss%uer(j) + elseif (- r > q) then + rcss%uer(j) = c3*rcss%u_src(j) - c2*rcss%uel(j) + endif + enddo + + end subroutine limit_ppm_interior_monotonic + + pure subroutine limit_ppm_interior_non_oscillatory(rcss) + ! --------------------------------------------------------------------------- + ! Apply limiting to prevent a oscillatory reconstruction of piecewise + ! parabolas for interior grid cells. + ! --------------------------------------------------------------------------- + + type(recon_src_struct), intent(inout) :: rcss + + real(r8), dimension(rcss%rcgs%n_src_actual) :: d2 + real(r8) :: sl, sr, sc, d, q, r + integer :: ns, j + + ns = rcss%rcgs%n_src_actual + + ! Obtain values proportional to the second derivative of the unlimited + ! parabolas. + do j = 1, ns + d2(j) = rcss%uel(j) - c2*rcss%u_src(j) + rcss%uer(j) + enddo + + do j = 2, ns-1 + ! Only apply limiting if the sign of the second + ! derivative differs from the sign of second derivatives + ! of any of the neighbouring parabolas. + if (d2(j-1)*d2(j) < c0 .or. d2(j)*d2(j+1) < c0) then + sl = c2*(rcss%u_src(j) - rcss%u_src(j-1))*rcss%rcgs%hi_src(j) + sr = c2*(rcss%u_src(j+1) - rcss%u_src(j))*rcss%rcgs%hi_src(j) + if (sl*sr > c0) then + sc = (rcss%u_src(j+1) - rcss%u_src(j-1))*rcss%rcgs%hci_src(j) + sc = sign(min(abs(sl), abs(sr), abs(sc)), sc) + if ( (rcss%u_src(j-1) - rcss%uel(j)) & + *(rcss%u_src(j ) - rcss%uel(j)) > c0) & + rcss%uel(j) = rcss%u_src(j) & + - sign(min(c1_2*rcss%rcgs%h_src(j)*abs(sc), & + abs(rcss%uel(j) - rcss%u_src(j))), sc) + if ( (rcss%u_src(j+1) - rcss%uer(j)) & + *(rcss%u_src(j ) - rcss%uer(j)) > c0) & + rcss%uer(j) = rcss%u_src(j) & + + sign(min(c1_2*rcss%rcgs%h_src(j)*abs(sc), & + abs(rcss%uer(j) - rcss%u_src(j))), sc) + else + rcss%uel(j) = rcss%u_src(j) + rcss%uer(j) = rcss%u_src(j) + endif + endif + enddo + +! do j = 2, ns-1 + do j = 3, ns-1 + if ( (rcss%uel(j) - rcss%uer(j-1)) & + *(rcss%u_src(j) - rcss%u_src(j-1)) < c0) then + rcss%uel(j) = c1_2*(rcss%uer(j-1) + rcss%uel(j)) + rcss%uer(j-1) = rcss%uel(j) + endif + enddo + + do j = 2, ns-1 + if (d2(j-1)*d2(j) < c0 .or. d2(j)*d2(j+1) < c0) then + d = rcss%uer(j) - rcss%uel(j) + q = d*(c2*rcss%u_src(j) - rcss%uel(j) - rcss%uer(j)) + r = c1_3*d*d + if ( q > r) then + rcss%uel(j) = c3*rcss%u_src(j) - c2*rcss%uer(j) + elseif (- r > q) then + rcss%uer(j) = c3*rcss%u_src(j) - c2*rcss%uel(j) + endif + endif + enddo + + end subroutine limit_ppm_interior_non_oscillatory + + pure subroutine limit_ppm_boundary(rcss) + ! --------------------------------------------------------------------------- + ! Handle piecewise parabola limiting of boundary cells. + ! --------------------------------------------------------------------------- + + type(recon_src_struct), intent(inout) :: rcss + + real(r8) :: s + integer :: ns + + ns = rcss%rcgs%n_src_actual + + if (rcss%pc_left_bndr) then + ! Piecewise constant reconstruction of the left boundary cell. + rcss%uel(1) = rcss%u_src(1) + rcss%uer(1) = rcss%u_src(1) + else + ! Do not treat the left boundary cell as a local extrema, but ensure + ! that the piecewise parabola is monotonic within the cell. + if ( (rcss%u_src(2) - rcss%uer(1)) & + *(rcss%u_src(1) - rcss%uer(1)) > c0) then + rcss%uel(1) = rcss%u_src(1) + rcss%uer(1) = rcss%u_src(1) + else + s = c2*(rcss%u_src(3) - rcss%u_src(2)) & + /(rcss%rcgs%h_src(2) + rcss%rcgs%h_src(3)) + if (s > 0) then + rcss%uer(1) = & + max(rcss%u_src(1), & + min(rcss%uer(1), & + rcss%u_src(1) + c1_3*s*rcss%rcgs%h_src(1))) + else + rcss%uer(1) = & + min(rcss%u_src(1), & + max(rcss%uer(1), & + rcss%u_src(1) + c1_3*s*rcss%rcgs%h_src(1))) + endif + rcss%uel(1) = c1_2*(c3*rcss%u_src(1) - rcss%uer(1)) + endif + endif + + if (rcss%pc_right_bndr) then + ! Piecewise constant reconstruction of the right boundary cell. + rcss%uel(ns) = rcss%u_src(ns) + rcss%uer(ns) = rcss%u_src(ns) + else + ! Do not treat the right boundary cell as a local extrema, but ensure + ! that the piecewise parabola is monotonic within the cell. + if ( (rcss%u_src(ns ) - rcss%uel(ns)) & + *(rcss%u_src(ns-1) - rcss%uel(ns)) > c0) then + rcss%uel(ns) = rcss%u_src(ns) + rcss%uer(ns) = rcss%u_src(ns) + else + s = c2*(rcss%u_src(ns-1) - rcss%u_src(ns-2)) & + /(rcss%rcgs%h_src(ns-2) + rcss%rcgs%h_src(ns-1)) + if (s > 0) then + rcss%uel(ns) = & + min(rcss%u_src(ns), & + max(rcss%uel(ns), & + rcss%u_src(ns) - c1_3*s*rcss%rcgs%h_src(ns))) + else + rcss%uel(ns) = & + max(rcss%u_src(ns), & + min(rcss%uel(ns), & + rcss%u_src(ns) - c1_3*s*rcss%rcgs%h_src(ns))) + endif + rcss%uer(ns) = c1_2*(c3*rcss%u_src(ns) - rcss%uel(ns)) + endif + endif + + end subroutine limit_ppm_boundary + + pure subroutine limit_ppm_posdef(rcss) + ! --------------------------------------------------------------------------- + ! Modify piecewise parabolas so they are never negative within the grid cell. + ! --------------------------------------------------------------------------- + + type(recon_src_struct), intent(inout) :: rcss + + real(r8) :: min_u_0, sl, a2, sr, q + integer :: j + + do j = 1, rcss%rcgs%n_src_actual + min_u_0 = min(rcss%u_src(j), c0) + rcss%uel(j) = max(rcss%uel(j), min_u_0) + rcss%uer(j) = max(rcss%uer(j), min_u_0) + sl = c2*(c3*rcss%u_src(j) - c2*rcss%uel(j) - rcss%uer(j)) + a2 = c3*(rcss%uel(j) - c2*rcss%u_src(j) + rcss%uer(j)) + sr = sl + c2*a2 + if (sl < c0 .and. sr > c0) then + if (a2*rcss%uel(j) - c1_4*sl*sl < a2*min_u_0) then + q = c3*rcss%u_src(j)/(c3*sl*sr + c4*a2*a2) + rcss%uel(j) = sl*sl*q + rcss%uer(j) = sr*sr*q + endif + endif + enddo + + end subroutine limit_ppm_posdef + + pure subroutine polycoeff_ppm(rcss) + ! --------------------------------------------------------------------------- + ! Obtain coefficients for piecewise parabolas from grid cell means and left + ! and right edge values. + ! --------------------------------------------------------------------------- + + type(recon_src_struct), intent(inout) :: rcss + + integer :: j + + do j = 1, rcss%rcgs%n_src_actual + rcss%polycoeff(1,j) = rcss%uel(j) + rcss%polycoeff(2,j) = c6*rcss%u_src(j) - c4*rcss%uel(j) & + - c2*rcss%uer(j) + rcss%polycoeff(3,j) = c3*(rcss%uel(j) - c2*rcss%u_src(j) + rcss%uer(j)) + enddo + + end subroutine polycoeff_ppm + + pure subroutine limit_pqm_monotonic(rcss) + ! --------------------------------------------------------------------------- + ! Apply limiting to ensure a monotonic reconstruction of piecewise quartics + ! for interior grid cells. + ! --------------------------------------------------------------------------- + + type(recon_src_struct), intent(inout) :: rcss + + real(r8), dimension(rcss%rcgs%n_src_actual) :: sl, sr, sc + real(r8) :: a0, a1, a2, a3, b0, b1, b2, q1, q2, q3, s, xi + integer :: ns, j + logical :: incon_inflex + + ns = rcss%rcgs%n_src_actual + + do j = 2, ns-1 + sl(j) = c2*(rcss%u_src(j) - rcss%u_src(j-1))*rcss%rcgs%hi_src(j) + sr(j) = c2*(rcss%u_src(j+1) - rcss%u_src(j))*rcss%rcgs%hi_src(j) + sc(j) = (rcss%u_src(j+1) - rcss%u_src(j-1))*rcss%rcgs%hci_src(j) + sc(j) = sign(min(abs(sl(j)), abs(sr(j)), abs(sc(j))), sc(j)) + if (sl(j)*sr(j) > c0) then + if ( (rcss%u_src(j-1) - rcss%uel(j)) & + *(rcss%u_src(j ) - rcss%uel(j)) > c0) & + rcss%uel(j) = rcss%u_src(j) & + - sign(min(c1_2*rcss%rcgs%h_src(j)*abs(sc(j)), & + abs(rcss%uel(j) - rcss%u_src(j))), sc(j)) + if ( (rcss%u_src(j+1) - rcss%uer(j)) & + *(rcss%u_src(j ) - rcss%uer(j)) > c0) & + rcss%uer(j) = rcss%u_src(j) & + + sign(min(c1_2*rcss%rcgs%h_src(j)*abs(sc(j)), & + abs(rcss%uer(j) - rcss%u_src(j))), sc(j)) +! if (rcss%usl(j)*sc(j) < c0) rcss%usl(j) = sc(j) +! if (rcss%usr(j)*sc(j) < c0) rcss%usr(j) = sc(j) + if (rcss%usl(j)*sc(j) < c0) rcss%usl(j) = c0 + if (rcss%usr(j)*sc(j) < c0) rcss%usr(j) = c0 + else + rcss%uel(j) = rcss%u_src(j) + rcss%uer(j) = rcss%u_src(j) + rcss%usl(j) = c0 + rcss%usr(j) = c0 + endif + enddo + + do j = 3, ns-1 + if ( (rcss%uel(j) - rcss%uer(j-1)) & + *(rcss%u_src(j) - rcss%u_src(j-1)) < c0) then + rcss%uel(j) = c1_2*(rcss%uer(j-1) + rcss%uel(j)) + rcss%uer(j-1) = rcss%uel(j) + endif + enddo + + do j = 2, ns-1 + + ! Compute polynomial coefficients for 1. derivative of the + ! reconstruction. + a0 = rcss%usl(j) + a1 = c2*( c30*rcss%u_src(j) - c18*rcss%uel(j) - c12*rcss%uer(j) & + - c9_2*rcss%usl(j) + c3_2*rcss%usr(j)) + a2 = c3*(- c60*rcss%u_src(j) + c32*rcss%uel(j) + c28*rcss%uer(j) & + + c6*rcss%usl(j) - c4*rcss%usr(j)) + a3 = c4*( c30*rcss%u_src(j) - c15*(rcss%uel(j) + rcss%uer(j)) & + - c5_2*(rcss%usl(j) - rcss%usr(j))) + + ! Compute polynomial coefficients for 2. derivative of the + ! reconstruction. + b0 = a1 + b1 = c2*a2 + b2 = c3*a3 + + ! Check for inconsistent inflextion points. + incon_inflex = .false. + q1 = b0*b2 + q2 = b1*b1 - c4*q1 + if (q2 > c0) then + if (b0*(b0 + b1 + b2) < c0) then + ! One inflection point. + if (abs(b2) < rcss%u_eps) then + if (abs(b1) > rcss%u_eps) then + xi = - b0/b1 + if ((a0 + xi*(a1 + xi*(a2 + xi*a3)))*sc(j) < c0) & + incon_inflex = .true. + endif + else + q3 = c1_2/b2 + s = sqrt(q2) + xi = - (b1 + s)*q3 + if (xi > c0 .and. xi < c1) then + if ((a0 + xi*(a1 + xi*(a2 + xi*a3)))*sc(j) < c0) & + incon_inflex = .true. + else + xi = - (b1 - s)*q3 + if ((a0 + xi*(a1 + xi*(a2 + xi*a3)))*sc(j) < c0) & + incon_inflex = .true. + endif + endif + elseif (q1 > rcss%uu_eps) then ! Should imply b2 != 0 + ! Two inflection points. + q3 = c1_2/b2 + s = sqrt(q2) + xi = - (b1 + s)*q3 + if ((a0 + xi*(a1 + xi*(a2 + xi*a3)))*sc(j) < c0) then + incon_inflex = .true. + else + xi = - (b1 - s)*q3 + if ((a0 + xi*(a1 + xi*(a2 + xi*a3)))*sc(j) < c0) & + incon_inflex = .true. + endif + endif + endif + + if (incon_inflex) then + if (abs(sl(j)) < abs(sr(j))) then + rcss%usl(j) = c10_3*rcss%u_src(j) - c8_3*rcss%uel(j) & + - c2_3*rcss%uer(j) + if (rcss%usl(j)*sc(j) < c0) then + rcss%usl(j) = c0 + rcss%uer(j) = c5*rcss%u_src(j) - c4*rcss%uel(j) + rcss%usr(j) = c20*(rcss%u_src(j) - rcss%uel(j)) + else + rcss%usr(j) = c4*rcss%uel(j) + c6*rcss%uer(j) & + - c10*rcss%u_src(j) + if (rcss%usr(j)*sc(j) < c0) then + rcss%usr(j) = c0 + rcss%uel(j) = c5_2*rcss%u_src(j) - c3_2*rcss%uer(j) + rcss%usl(j) = c10_3*(rcss%uer(j) - rcss%u_src(j)) + endif + endif + else + rcss%usr(j) = c8_3*rcss%uer(j) + c2_3*rcss%uel(j) & + - c10_3*rcss%u_src(j) + if (rcss%usr(j)*sc(j) < c0) then + rcss%usr(j) = c0 + rcss%uel(j) = c5*rcss%u_src(j) - c4*rcss%uer(j) + rcss%usl(j) = c20*(rcss%uer(j) - rcss%u_src(j)) + else + rcss%usl(j) = c10*rcss%u_src(j) - c4*rcss%uer(j) & + - c6*rcss%uel(j) + if (rcss%usl(j)*sc(j) < c0) then + rcss%usl(j) = c0 + rcss%uer(j) = c5_2*rcss%u_src(j) - c3_2*rcss%uel(j) + rcss%usr(j) = c10_3*(rcss%u_src(j) - rcss%uel(j)) + endif + endif + endif + endif + + enddo + + + if (rcss%pc_left_bndr) then + ! Piecewise constant reconstruction of the left boundary cell. + rcss%uel(1) = rcss%u_src(1) + rcss%uer(1) = rcss%u_src(1) + rcss%usl(1) = c0 + rcss%usr(1) = c0 + else + ! Do not treat the left boundary cell as a local extrema, but ensure + ! that the piecewise parabola is monotonic within the cell. + if ( (rcss%u_src(2) - rcss%uer(1)) & + *(rcss%u_src(1) - rcss%uer(1)) > c0) then + rcss%uel(1) = rcss%u_src(1) + rcss%uer(1) = rcss%u_src(1) + rcss%usl(1) = c0 + rcss%usr(1) = c0 + else + s = c2*(rcss%u_src(3) - rcss%u_src(2)) & + /(rcss%rcgs%h_src(2) + rcss%rcgs%h_src(3)) + if (s > 0) then + rcss%uer(1) = & + max(rcss%u_src(1), & + min(rcss%uel(2), & + rcss%u_src(1) + c1_3*s*rcss%rcgs%h_src(1))) + else + rcss%uer(1) = & + min(rcss%u_src(1), & + max(rcss%uel(2), & + rcss%u_src(1) + c1_3*s*rcss%rcgs%h_src(1))) + endif + rcss%uel(1) = c1_2*(c3*rcss%u_src(1) - rcss%uer(1)) + rcss%usl(1) = c6*rcss%u_src(1) - c4*rcss%uel(1) - c2*rcss%uer(1) + rcss%usr(1) = c2*rcss%uel(1) + c4*rcss%uer(1) - c6*rcss%u_src(1) + endif + endif + + if (rcss%pc_right_bndr) then + ! Piecewise constant reconstruction of the right boundary cell. + rcss%uel(ns) = rcss%u_src(ns) + rcss%uer(ns) = rcss%u_src(ns) + rcss%usl(ns) = c0 + rcss%usr(ns) = c0 + else + ! Do not treat the right boundary cell as a local extrema, but ensure + ! that the piecewise parabola is monotonic within the cell. + if ( (rcss%u_src(ns ) - rcss%uel(ns)) & + *(rcss%u_src(ns-1) - rcss%uel(ns)) > c0) then + rcss%uel(ns) = rcss%u_src(ns) + rcss%uer(ns) = rcss%u_src(ns) + rcss%usl(ns) = c0 + rcss%usr(ns) = c0 + else + s = c2*(rcss%u_src(ns-1) - rcss%u_src(ns-2)) & + /(rcss%rcgs%h_src(ns-2) + rcss%rcgs%h_src(ns-1)) + if (s > 0) then + rcss%uel(ns) = & + min(rcss%u_src(ns), & + max(rcss%uer(ns-1), & + rcss%u_src(ns) - c1_3*s*rcss%rcgs%h_src(ns))) + else + rcss%uel(ns) = & + max(rcss%u_src(ns), & + min(rcss%uer(ns-1), & + rcss%u_src(ns) - c1_3*s*rcss%rcgs%h_src(ns))) + endif + rcss%uer(ns) = c1_2*(c3*rcss%u_src(ns) - rcss%uel(ns)) + rcss%usl(ns) = c6*rcss%u_src(ns) - c4*rcss%uel(ns) - c2*rcss%uer(ns) + rcss%usr(ns) = c2*rcss%uel(ns) + c4*rcss%uer(ns) - c6*rcss%u_src(ns) + endif + endif + + end subroutine limit_pqm_monotonic + + pure subroutine limit_pqm_non_oscillatory(rcss) + ! --------------------------------------------------------------------------- + ! Apply limiting to ensure a monotonic reconstruction of piecewise quartics + ! for interior grid cells. + ! --------------------------------------------------------------------------- + + type(recon_src_struct), intent(inout) :: rcss + + real(r8), dimension(rcss%rcgs%n_src_actual) :: d2, sl, sr, sc + logical, dimension(rcss%rcgs%n_src_actual) :: smooth + real(r8) :: a0, a1, a2, a3, b0, b1, b2, q1, q2, q3, s, xi + integer :: ns, j + logical :: inflex, incon_inflex + + ns = rcss%rcgs%n_src_actual + + ! Obtain values proportional to the second derivative of the unlimited + ! parabolas. + do j = 1, ns + d2(j) = rcss%uel(j) - c2*rcss%u_src(j) + rcss%uer(j) + enddo + + do j = 2, ns-1 + ! Set flag if the reconstruction is considered smooth, that is + ! the sign of the second derivative equals the sign of the second + ! derivatives of both the neighbouring parabolas. + smooth(j) = d2(j-1)*d2(j) >= c0 .and. d2(j)*d2(j+1) >= c0 + + if (smooth(j)) then + + ! Slopes of a parabolic reconstruction. + sl(j) = c6*rcss%u_src(j) - c4*rcss%uel(j) - c2*rcss%uer(j) + sr(j) = c2*rcss%uel(j) + c4*rcss%uer(j) - c6*rcss%u_src(j) + + if (sl(j) < c0 .and. sr(j) > c0) then + + ! If the slopes of a parabolic reconstruction has different + ! signs, the parabolic reconstruction is chosen. + rcss%usl(j) = sl(j) + rcss%usr(j) = sr(j) + + else + + ! If the quartic reconstruction has one or more inflextion + ! points, a parabolic reconstruction is chosen. + b0 = c2*( c30*rcss%u_src(j) - c18*rcss%uel(j) - c12*rcss%uer(j) & + - c9_2*rcss%usl(j) + c3_2*rcss%usr(j)) + b1 = c6*(- c60*rcss%u_src(j) + c32*rcss%uel(j) & + + c28*rcss%uer(j) + c6*rcss%usl(j) - c4*rcss%usr(j)) + b2 = c12*( c30*rcss%u_src(j) - c15*(rcss%uel(j) + rcss%uer(j)) & + - c5_2*(rcss%usl(j) - rcss%usr(j))) + q1 = b0*b2 + q2 = b1*b1 - c4*q1 + if (q2 > c0 .and. & + (b0*(b0 + b1 + b2) < c0 .or. q1 > rcss%uu_eps)) then + inflex = .true. + else + inflex = .false. + endif + if (inflex) then + rcss%usl(j) = sl(j) + rcss%usr(j) = sr(j) + endif + + endif + + else + + ! Apply limiting for unsmooth reconstruction. + sl(j) = c2*(rcss%u_src(j) - rcss%u_src(j-1))*rcss%rcgs%hi_src(j) + sr(j) = c2*(rcss%u_src(j+1) - rcss%u_src(j))*rcss%rcgs%hi_src(j) + sc(j) = (rcss%u_src(j+1) - rcss%u_src(j-1))*rcss%rcgs%hci_src(j) + sc(j) = sign(min(abs(sl(j)), abs(sr(j)), abs(sc(j))), sc(j)) + if (sl(j)*sr(j) > c0) then + if ( (rcss%u_src(j-1) - rcss%uel(j)) & + *(rcss%u_src(j ) - rcss%uel(j)) > c0) & + rcss%uel(j) = rcss%u_src(j) & + - sign(min(c1_2*rcss%rcgs%h_src(j)*abs(sc(j)), & + abs(rcss%uel(j) - rcss%u_src(j))), & + sc(j)) + if ( (rcss%u_src(j+1) - rcss%uer(j)) & + *(rcss%u_src(j ) - rcss%uer(j)) > c0) & + rcss%uer(j) = rcss%u_src(j) & + + sign(min(c1_2*rcss%rcgs%h_src(j)*abs(sc(j)), & + abs(rcss%uer(j) - rcss%u_src(j))), & + sc(j)) +! if (rcss%usl(j)*sc(j) < c0) rcss%usl(j) = sc(j) +! if (rcss%usr(j)*sc(j) < c0) rcss%usr(j) = sc(j) + if (rcss%usl(j)*sc(j) < c0) rcss%usl(j) = c0 + if (rcss%usr(j)*sc(j) < c0) rcss%usr(j) = c0 + else + rcss%uel(j) = rcss%u_src(j) + rcss%uer(j) = rcss%u_src(j) + rcss%usl(j) = c0 + rcss%usr(j) = c0 + endif + + endif + enddo + + do j = 3, ns-1 + if ( (rcss%uel(j) - rcss%uer(j-1)) & + *(rcss%u_src(j) - rcss%u_src(j-1)) < c0) then + if (smooth(j-1)) then + rcss%uel(j) = rcss%uer(j-1) + elseif (smooth(j )) then + rcss%uer(j-1) = rcss%uel(j) + else + rcss%uel(j) = c1_2*(rcss%uer(j-1) + rcss%uel(j)) + rcss%uer(j-1) = rcss%uel(j) + endif + endif + enddo + + do j = 2, ns-1 + + if (.not.smooth(j)) then + + ! Compute polynomial coefficients for 1. derivative of the + ! reconstruction. + a0 = rcss%usl(j) + a1 = c2*( c30*rcss%u_src(j) - c18*rcss%uel(j) - c12*rcss%uer(j) & + - c9_2*rcss%usl(j) + c3_2*rcss%usr(j)) + a2 = c3*(- c60*rcss%u_src(j) + c32*rcss%uel(j) + c28*rcss%uer(j) & + + c6*rcss%usl(j) - c4*rcss%usr(j)) + a3 = c4*( c30*rcss%u_src(j) - c15*(rcss%uel(j) + rcss%uer(j)) & + - c5_2*(rcss%usl(j) - rcss%usr(j))) + + ! Compute polynomial coefficients for 2. derivative of the + ! reconstruction. + b0 = a1 + b1 = c2*a2 + b2 = c3*a3 + + ! Check for inconsistent inflextion points. + incon_inflex = .false. + q1 = b0*b2 + q2 = b1*b1 - c4*q1 + if (q2 > c0) then + if (b0*(b0 + b1 + b2) < c0) then + ! One inflection point. + if (abs(b2) < rcss%u_eps) then + if (abs(b1) > rcss%u_eps) then + xi = - b0/b1 + if ((a0 + xi*(a1 + xi*(a2 + xi*a3)))*sc(j) < c0) & + incon_inflex = .true. + endif + else + q3 = c1_2/b2 + s = sqrt(q2) + xi = - (b1 + s)*q3 + if (xi > c0 .and. xi < c1) then + if ((a0 + xi*(a1 + xi*(a2 + xi*a3)))*sc(j) < c0) & + incon_inflex = .true. + else + xi = - (b1 - s)*q3 + if ((a0 + xi*(a1 + xi*(a2 + xi*a3)))*sc(j) < c0) & + incon_inflex = .true. + endif + endif + elseif (q1 > rcss%uu_eps) then ! Should imply b2 != 0 + ! Two inflection points. + q3 = c1_2/b2 + s = sqrt(q2) + xi = - (b1 + s)*q3 + if ((a0 + xi*(a1 + xi*(a2 + xi*a3)))*sc(j) < c0) then + incon_inflex = .true. + else + xi = - (b1 - s)*q3 + if ((a0 + xi*(a1 + xi*(a2 + xi*a3)))*sc(j) < c0) & + incon_inflex = .true. + endif + endif + endif + + if (incon_inflex) then + if (abs(sl(j)) < abs(sr(j))) then + rcss%usl(j) = c10_3*rcss%u_src(j) - c8_3*rcss%uel(j) & + - c2_3*rcss%uer(j) + if (rcss%usl(j)*sc(j) < c0) then + rcss%usl(j) = c0 + rcss%uer(j) = c5*rcss%u_src(j) - c4*rcss%uel(j) + rcss%usr(j) = c20*(rcss%u_src(j) - rcss%uel(j)) + else + rcss%usr(j) = c4*rcss%uel(j) + c6*rcss%uer(j) & + - c10*rcss%u_src(j) + if (rcss%usr(j)*sc(j) < c0) then + rcss%usr(j) = c0 + rcss%uel(j) = c5_2*rcss%u_src(j) - c3_2*rcss%uer(j) + rcss%usl(j) = c10_3*(rcss%uer(j) - rcss%u_src(j)) + endif + endif + else + rcss%usr(j) = c8_3*rcss%uer(j) + c2_3*rcss%uel(j) & + - c10_3*rcss%u_src(j) + if (rcss%usr(j)*sc(j) < c0) then + rcss%usr(j) = c0 + rcss%uel(j) = c5*rcss%u_src(j) - c4*rcss%uer(j) + rcss%usl(j) = c20*(rcss%uer(j) - rcss%u_src(j)) + else + rcss%usl(j) = c10*rcss%u_src(j) - c4*rcss%uer(j) & + - c6*rcss%uel(j) + if (rcss%usl(j)*sc(j) < c0) then + rcss%usl(j) = c0 + rcss%uer(j) = c5_2*rcss%u_src(j) - c3_2*rcss%uel(j) + rcss%usr(j) = c10_3*(rcss%u_src(j) - rcss%uel(j)) + endif + endif + endif + endif + + endif + + enddo + + + if (rcss%pc_left_bndr) then + ! Piecewise constant reconstruction of the left boundary cell. + rcss%uel(1) = rcss%u_src(1) + rcss%uer(1) = rcss%u_src(1) + rcss%usl(1) = c0 + rcss%usr(1) = c0 + else + ! Do not treat the left boundary cell as a local extrema, but ensure + ! that the piecewise parabola is monotonic within the cell. + if ( (rcss%u_src(2) - rcss%uer(1)) & + *(rcss%u_src(1) - rcss%uer(1)) > c0) then + rcss%uel(1) = rcss%u_src(1) + rcss%uer(1) = rcss%u_src(1) + rcss%usl(1) = c0 + rcss%usr(1) = c0 + else + s = c2*(rcss%u_src(3) - rcss%u_src(2)) & + /(rcss%rcgs%h_src(2) + rcss%rcgs%h_src(3)) + if (s > 0) then + rcss%uer(1) = & + max(rcss%u_src(1), & + min(rcss%uel(2), & + rcss%u_src(1) + c1_3*s*rcss%rcgs%h_src(1))) + else + rcss%uer(1) = & + min(rcss%u_src(1), & + max(rcss%uel(2), & + rcss%u_src(1) + c1_3*s*rcss%rcgs%h_src(1))) + endif + rcss%uel(1) = c1_2*(c3*rcss%u_src(1) - rcss%uer(1)) + rcss%usl(1) = c6*rcss%u_src(1) - c4*rcss%uel(1) - c2*rcss%uer(1) + rcss%usr(1) = c2*rcss%uel(1) + c4*rcss%uer(1) - c6*rcss%u_src(1) + endif + endif + + if (rcss%pc_right_bndr) then + ! Piecewise constant reconstruction of the right boundary cell. + rcss%uel(ns) = rcss%u_src(ns) + rcss%uer(ns) = rcss%u_src(ns) + rcss%usl(ns) = c0 + rcss%usr(ns) = c0 + else + ! Do not treat the right boundary cell as a local extrema, but ensure + ! that the piecewise parabola is monotonic within the cell. + if ( (rcss%u_src(ns ) - rcss%uel(ns)) & + *(rcss%u_src(ns-1) - rcss%uel(ns)) > c0) then + rcss%uel(ns) = rcss%u_src(ns) + rcss%uer(ns) = rcss%u_src(ns) + rcss%usl(ns) = c0 + rcss%usr(ns) = c0 + else + s = c2*(rcss%u_src(ns-1) - rcss%u_src(ns-2)) & + /(rcss%rcgs%h_src(ns-2) + rcss%rcgs%h_src(ns-1)) + if (s > 0) then + rcss%uel(ns) = & + min(rcss%u_src(ns), & + max(rcss%uer(ns-1), & + rcss%u_src(ns) - c1_3*s*rcss%rcgs%h_src(ns))) + else + rcss%uel(ns) = & + max(rcss%u_src(ns), & + min(rcss%uer(ns-1), & + rcss%u_src(ns) - c1_3*s*rcss%rcgs%h_src(ns))) + endif + rcss%uer(ns) = c1_2*(c3*rcss%u_src(ns) - rcss%uel(ns)) + rcss%usl(ns) = c6*rcss%u_src(ns) - c4*rcss%uel(ns) - c2*rcss%uer(ns) + rcss%usr(ns) = c2*rcss%uel(ns) + c4*rcss%uer(ns) - c6*rcss%u_src(ns) + endif + endif + + end subroutine limit_pqm_non_oscillatory + + pure subroutine limit_pqm_non_oscillatory_posdef(rcss) + ! --------------------------------------------------------------------------- + ! Apply limiting to ensure a monotonic reconstruction of piecewise quartics + ! for interior grid cells. + ! --------------------------------------------------------------------------- + + type(recon_src_struct), intent(inout) :: rcss + + real(r8), dimension(rcss%rcgs%n_src_actual) :: d2, sl, sr, sc + logical, dimension(rcss%rcgs%n_src_actual) :: smooth + real(r8) :: min_u_0, a0, a1, a2, a3, b0, b1, b2, q1, q2, q3, s, xi + integer :: ns, j + logical :: inflex, incon_inflex + + ns = rcss%rcgs%n_src_actual + + ! Obtain values proportional to the second derivative of the unlimited + ! parabolas. + do j = 1, ns + d2(j) = rcss%uel(j) - c2*rcss%u_src(j) + rcss%uer(j) + enddo + + do j = 2, ns-1 + ! Set flag if the reconstruction is considered smooth, that is + ! the sign of the second derivative equals the sign of the second + ! derivatives of both the neighbouring parabolas. + smooth(j) = d2(j-1)*d2(j) >= c0 .and. d2(j)*d2(j+1) >= c0 + + if (smooth(j)) then + + ! Ensure edge values of smooth reconstruction is positive definite. + min_u_0 = min(rcss%u_src(j), c0) + rcss%uel(j) = max(rcss%uel(j), min_u_0) + rcss%uer(j) = max(rcss%uer(j), min_u_0) + + ! Slopes of a parabolic reconstruction. + sl(j) = c6*rcss%u_src(j) - c4*rcss%uel(j) - c2*rcss%uer(j) + sr(j) = c2*rcss%uel(j) + c4*rcss%uer(j) - c6*rcss%u_src(j) + + if (sl(j) < c0 .and. sr(j) > c0) then + + ! If the slopes of a parabolic reconstruction has different + ! signs, the parabolic reconstruction is chosen. If needed, + ! modify the parabola it is positive definite. + a2 = c1_2*(sr(j) - sl(j)) + if (a2*rcss%uel(j) - c1_4*sl(j)*sl(j) < a2*min_u_0) then + q1 = c3*rcss%u_src(j)/(c3*sl(j)*sr(j) + c4*a2*a2) + rcss%uel(j) = sl(j)*sl(j)*q1 + rcss%uer(j) = sr(j)*sr(j)*q1 + rcss%usl(j) = c6*rcss%u_src(j) - c4*rcss%uel(j) & + - c2*rcss%uer(j) + rcss%usr(j) = c2*rcss%uel(j) + c4*rcss%uer(j) & + - c6*rcss%u_src(j) + else + rcss%usl(j) = sl(j) + rcss%usr(j) = sr(j) + endif + + else + + ! If the quartic reconstruction has one or more inflextion + ! points, a parabolic reconstruction is chosen. + b0 = c2*( c30*rcss%u_src(j) - c18*rcss%uel(j) - c12*rcss%uer(j) & + - c9_2*rcss%usl(j) + c3_2*rcss%usr(j)) + b1 = c6*(- c60*rcss%u_src(j) + c32*rcss%uel(j) & + + c28*rcss%uer(j) + c6*rcss%usl(j) - c4*rcss%usr(j)) + b2 = c12*( c30*rcss%u_src(j) - c15*(rcss%uel(j) + rcss%uer(j)) & + - c5_2*(rcss%usl(j) - rcss%usr(j))) + q1 = b0*b2 + q2 = b1*b1 - c4*q1 + if (q2 > c0 .and. & + (b0*(b0 + b1 + b2) < c0 .or. q1 > rcss%uu_eps)) then + inflex = .true. + else + inflex = .false. + endif + if (inflex) then + rcss%usl(j) = sl(j) + rcss%usr(j) = sr(j) + endif + + endif + + else + + ! Apply limiting for unsmooth reconstruction. + sl(j) = c2*(rcss%u_src(j) - rcss%u_src(j-1))*rcss%rcgs%hi_src(j) + sr(j) = c2*(rcss%u_src(j+1) - rcss%u_src(j))*rcss%rcgs%hi_src(j) + sc(j) = (rcss%u_src(j+1) - rcss%u_src(j-1))*rcss%rcgs%hci_src(j) + sc(j) = sign(min(abs(sl(j)), abs(sr(j)), abs(sc(j))), sc(j)) + if (sl(j)*sr(j) > c0) then + if ( (rcss%u_src(j-1) - rcss%uel(j)) & + *(rcss%u_src(j ) - rcss%uel(j)) > c0) & + rcss%uel(j) = rcss%u_src(j) & + - sign(min(c1_2*rcss%rcgs%h_src(j)*abs(sc(j)), & + abs(rcss%uel(j) - rcss%u_src(j))), & + sc(j)) + if ( (rcss%u_src(j+1) - rcss%uer(j)) & + *(rcss%u_src(j ) - rcss%uer(j)) > c0) & + rcss%uer(j) = rcss%u_src(j) & + + sign(min(c1_2*rcss%rcgs%h_src(j)*abs(sc(j)), & + abs(rcss%uer(j) - rcss%u_src(j))), & + sc(j)) +! if (rcss%usl(j)*sc(j) < c0) rcss%usl(j) = sc(j) +! if (rcss%usr(j)*sc(j) < c0) rcss%usr(j) = sc(j) + if (rcss%usl(j)*sc(j) < c0) rcss%usl(j) = c0 + if (rcss%usr(j)*sc(j) < c0) rcss%usr(j) = c0 + else + rcss%uel(j) = rcss%u_src(j) + rcss%uer(j) = rcss%u_src(j) + rcss%usl(j) = c0 + rcss%usr(j) = c0 + endif + + endif + enddo + + do j = 3, ns-1 + if ( (rcss%uel(j) - rcss%uer(j-1)) & + *(rcss%u_src(j) - rcss%u_src(j-1)) < c0) then + if (smooth(j-1)) then + rcss%uel(j) = rcss%uer(j-1) + elseif (smooth(j )) then + rcss%uer(j-1) = rcss%uel(j) + else + rcss%uel(j) = c1_2*(rcss%uer(j-1) + rcss%uel(j)) + rcss%uer(j-1) = rcss%uel(j) + endif + endif + enddo + + do j = 2, ns-1 + + if (.not.smooth(j)) then + + ! Compute polynomial coefficients for 1. derivative of the + ! reconstruction. + a0 = rcss%usl(j) + a1 = c2*( c30*rcss%u_src(j) - c18*rcss%uel(j) - c12*rcss%uer(j) & + - c9_2*rcss%usl(j) + c3_2*rcss%usr(j)) + a2 = c3*(- c60*rcss%u_src(j) + c32*rcss%uel(j) + c28*rcss%uer(j) & + + c6*rcss%usl(j) - c4*rcss%usr(j)) + a3 = c4*( c30*rcss%u_src(j) - c15*(rcss%uel(j) + rcss%uer(j)) & + - c5_2*(rcss%usl(j) - rcss%usr(j))) + + ! Compute polynomial coefficients for 2. derivative of the + ! reconstruction. + b0 = a1 + b1 = c2*a2 + b2 = c3*a3 + + ! Check for inconsistent inflextion points. + incon_inflex = .false. + q1 = b0*b2 + q2 = b1*b1 - c4*q1 + if (q2 > c0) then + if (b0*(b0 + b1 + b2) < c0) then + ! One inflection point. + if (abs(b2) < rcss%u_eps) then + if (abs(b1) > rcss%u_eps) then + xi = - b0/b1 + if ((a0 + xi*(a1 + xi*(a2 + xi*a3)))*sc(j) < c0) & + incon_inflex = .true. + endif + else + q3 = c1_2/b2 + s = sqrt(q2) + xi = - (b1 + s)*q3 + if (xi > c0 .and. xi < c1) then + if ((a0 + xi*(a1 + xi*(a2 + xi*a3)))*sc(j) < c0) & + incon_inflex = .true. + else + xi = - (b1 - s)*q3 + if ((a0 + xi*(a1 + xi*(a2 + xi*a3)))*sc(j) < c0) & + incon_inflex = .true. + endif + endif + elseif (q1 > rcss%uu_eps) then ! Should imply b2 != 0 + ! Two inflection points. + q3 = c1_2/b2 + s = sqrt(q2) + xi = - (b1 + s)*q3 + if ((a0 + xi*(a1 + xi*(a2 + xi*a3)))*sc(j) < c0) then + incon_inflex = .true. + else + xi = - (b1 - s)*q3 + if ((a0 + xi*(a1 + xi*(a2 + xi*a3)))*sc(j) < c0) & + incon_inflex = .true. + endif + endif + endif + + if (incon_inflex) then + if (abs(sl(j)) < abs(sr(j))) then + rcss%usl(j) = c10_3*rcss%u_src(j) - c8_3*rcss%uel(j) & + - c2_3*rcss%uer(j) + if (rcss%usl(j)*sc(j) < c0) then + rcss%usl(j) = c0 + rcss%uer(j) = c5*rcss%u_src(j) - c4*rcss%uel(j) + rcss%usr(j) = c20*(rcss%u_src(j) - rcss%uel(j)) + else + rcss%usr(j) = c4*rcss%uel(j) + c6*rcss%uer(j) & + - c10*rcss%u_src(j) + if (rcss%usr(j)*sc(j) < c0) then + rcss%usr(j) = c0 + rcss%uel(j) = c5_2*rcss%u_src(j) - c3_2*rcss%uer(j) + rcss%usl(j) = c10_3*(rcss%uer(j) - rcss%u_src(j)) + endif + endif + else + rcss%usr(j) = c8_3*rcss%uer(j) + c2_3*rcss%uel(j) & + - c10_3*rcss%u_src(j) + if (rcss%usr(j)*sc(j) < c0) then + rcss%usr(j) = c0 + rcss%uel(j) = c5*rcss%u_src(j) - c4*rcss%uer(j) + rcss%usl(j) = c20*(rcss%uer(j) - rcss%u_src(j)) + else + rcss%usl(j) = c10*rcss%u_src(j) - c4*rcss%uer(j) & + - c6*rcss%uel(j) + if (rcss%usl(j)*sc(j) < c0) then + rcss%usl(j) = c0 + rcss%uer(j) = c5_2*rcss%u_src(j) - c3_2*rcss%uel(j) + rcss%usr(j) = c10_3*(rcss%u_src(j) - rcss%uel(j)) + endif + endif + endif + endif + + endif + + enddo + + + if (rcss%pc_left_bndr) then + ! Piecewise constant reconstruction of the left boundary cell. + rcss%uel(1) = rcss%u_src(1) + rcss%uer(1) = rcss%u_src(1) + rcss%usl(1) = c0 + rcss%usr(1) = c0 + else + ! Do not treat the left boundary cell as a local extrema, but ensure + ! that the piecewise parabola is monotonic within the cell. + if ( (rcss%u_src(2) - rcss%uer(1)) & + *(rcss%u_src(1) - rcss%uer(1)) > c0) then + rcss%uel(1) = rcss%u_src(1) + rcss%uer(1) = rcss%u_src(1) + rcss%usl(1) = c0 + rcss%usr(1) = c0 + else + s = c2*(rcss%u_src(3) - rcss%u_src(2)) & + /(rcss%rcgs%h_src(2) + rcss%rcgs%h_src(3)) + if (s > 0) then + rcss%uer(1) = & + max(rcss%u_src(1), & + min(rcss%uel(2), & + rcss%u_src(1) + c1_3*s*rcss%rcgs%h_src(1))) + rcss%uel(1) = max(min(rcss%u_src(1), c0), & + c1_2*(c3*rcss%u_src(1) - rcss%uer(1))) + rcss%uer(1) = c3*rcss%u_src(1) - c2*rcss%uel(1) + else + rcss%uer(1) = & + min(rcss%u_src(1), & + max(rcss%uel(2), & + rcss%u_src(1) + c1_3*s*rcss%rcgs%h_src(1))) + rcss%uel(1) = c1_2*(c3*rcss%u_src(1) - rcss%uer(1)) + endif + rcss%usl(1) = c6*rcss%u_src(1) - c4*rcss%uel(1) - c2*rcss%uer(1) + rcss%usr(1) = c2*rcss%uel(1) + c4*rcss%uer(1) - c6*rcss%u_src(1) + endif + endif + + if (rcss%pc_right_bndr) then + ! Piecewise constant reconstruction of the right boundary cell. + rcss%uel(ns) = rcss%u_src(ns) + rcss%uer(ns) = rcss%u_src(ns) + rcss%usl(ns) = c0 + rcss%usr(ns) = c0 + else + ! Do not treat the right boundary cell as a local extrema, but ensure + ! that the piecewise parabola is monotonic within the cell. + if ( (rcss%u_src(ns ) - rcss%uel(ns)) & + *(rcss%u_src(ns-1) - rcss%uel(ns)) > c0) then + rcss%uel(ns) = rcss%u_src(ns) + rcss%uer(ns) = rcss%u_src(ns) + rcss%usl(ns) = c0 + rcss%usr(ns) = c0 + else + s = c2*(rcss%u_src(ns-1) - rcss%u_src(ns-2)) & + /(rcss%rcgs%h_src(ns-2) + rcss%rcgs%h_src(ns-1)) + if (s > 0) then + rcss%uel(ns) = & + min(rcss%u_src(ns), & + max(rcss%uer(ns-1), & + rcss%u_src(ns) - c1_3*s*rcss%rcgs%h_src(ns))) + rcss%uer(ns) = c1_2*(c3*rcss%u_src(ns) - rcss%uel(ns)) + else + rcss%uel(ns) = & + max(rcss%u_src(ns), & + min(rcss%uer(ns-1), & + rcss%u_src(ns) - c1_3*s*rcss%rcgs%h_src(ns))) + rcss%uer(ns) = max(min(rcss%u_src(ns), c0), & + c1_2*(c3*rcss%u_src(ns) - rcss%uel(ns))) + rcss%uel(ns) = c3*rcss%u_src(ns) - c2*rcss%uer(ns) + endif + rcss%usl(ns) = c6*rcss%u_src(ns) - c4*rcss%uel(ns) - c2*rcss%uer(ns) + rcss%usr(ns) = c2*rcss%uel(ns) + c4*rcss%uer(ns) - c6*rcss%u_src(ns) + endif + endif + + end subroutine limit_pqm_non_oscillatory_posdef + + pure subroutine polycoeff_pqm(rcss) + ! --------------------------------------------------------------------------- + ! Obtain coefficients for piecewise quartics from grid cell means and left + ! and right edge and slope values. + ! --------------------------------------------------------------------------- + + type(recon_src_struct), intent(inout) :: rcss + + integer :: j + + do j = 1, rcss%rcgs%n_src_actual + rcss%polycoeff(1,j) = rcss%uel(j) + rcss%polycoeff(2,j) = rcss%usl(j) + rcss%polycoeff(3,j) = & + c30*rcss%u_src(j) - c18*rcss%uel(j) - c12*rcss%uer(j) & + - c9_2*rcss%usl(j) + c3_2*rcss%usr(j) + rcss%polycoeff(4,j) = & + - c60*rcss%u_src(j) + c32*rcss%uel(j) + c28*rcss%uer(j) & + + c6*rcss%usl(j) - c4*rcss%usr(j) + rcss%polycoeff(5,j) = & + c30*rcss%u_src(j) - c15*(rcss%uel(j) + rcss%uer(j)) & + - c5_2*(rcss%usl(j) - rcss%usr(j)) + enddo + + end subroutine polycoeff_pqm + + pure function line_intersection(pc, u, u_eps, xil, xir) result(xi) + + real(r8), dimension(2), intent(in) :: pc + real(r8), intent(in) :: u, u_eps, xil, xir + + real(r8) :: xi + + if (abs(pc(2)) < u_eps) then + xi = xil + else + xi = max(xil, min(xir, (u - pc(1))/pc(2))) + endif + + end function line_intersection + + pure function parabola_intersection(pc, u, u_eps, xil, xir) result(xi) + + real(r8), dimension(3), intent(in) :: pc + real(r8), intent(in) :: u, u_eps, xil, xir + + real(r8) :: xi + + real(r8) :: q, s, xi1, xi2, xim + + if (abs(pc(3)) < u_eps) then + xi = line_intersection(pc(1:2), u, u_eps, xil, xir) + else + q = c1_2/pc(3) + s = sqrt(max(c0, pc(2)*pc(2) - c4*pc(3)*(pc(1) - u))) + xi1 = - (pc(2) + s)*q + xi2 = - (pc(2) - s)*q + xim = c1_2*(xil + xir) + if (abs(xi1 - xim) < abs(xi2 - xim)) then + xi = xi1 + else + xi = xi2 + endif + xi = max(xil, min(xir, xi)) + endif + + end function parabola_intersection + + pure function quartic_intersection(pc, u, u_eps, xil, xir) result(xi) + + real(r8), dimension(5), intent(in) :: pc + real(r8), intent(in) :: u, u_eps, xil, xir + + real(r8) :: xi + + real(r8) :: r, drdx, xi_old + integer :: n + + if (abs(pc(4)) < u_eps .and. abs(pc(5)) < u_eps) then + xi = parabola_intersection(pc(1:3), u, u_eps, xil, xir) + else + xi = c1_2*(xil + xir) + do n = 1, 10 + r = pc(1) + (pc(2) + (pc(3) + (pc(4) + pc(5)*xi)*xi)*xi)*xi - u + drdx = pc(2) + (c2*pc(3) + (c3*pc(4) + c4*pc(5)*xi)*xi)*xi + xi_old = xi + xi = max(xil, min(xir, xi_old - r/sign(max(eps, abs(drdx)), drdx))) + if (abs(xi - xi_old) < 1.e-9_r8) return + enddo + endif + + end function quartic_intersection + + pure subroutine regrid_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), dimension(3) :: pcl, pcr + real(r8) :: umr, uml, xi, duml, dumr, uerl, uelr + 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) + + ! Find possible intersections in the first half of the first source grid + ! cell. + 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 + umr = rcss%polycoeff(1,js) & + + c1_2*rcss%polycoeff(2,js) + do + if ((u_edge_grd(jg) - umr)*u_sgn > c0) exit + xi = line_intersection(rcss%polycoeff(:,js), u_edge_grd(jg), & + rcss%u_eps, c0, c1_2) + 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 + + outer: do + + ! For the current grid edge index, find the index of the first source + ! grid cell with mid point reconstructed value larger than the grid + ! edge value. + do + uml = umr + umr = rcss%polycoeff(1,js) & + + c1_2*rcss%polycoeff(2,js) + if ((u_edge_grd(jg) - umr)*u_sgn <= c0) exit + js = js + 1 + if (js > ns) exit outer + enddo + + ! 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 + ! respective grid cells. + duml = rcss%polycoeff(2,js-1) + dumr = rcss%polycoeff(2,js ) + pcr(2) = (c4*(umr - uml) - duml - dumr)*rcss%rcgs%h_src(js) & + /(rcss%rcgs%h_src(js-1) + rcss%rcgs%h_src(js)) + pcr(1) = umr - c1_4*(dumr + pcr(2)) + if (pcr(2)*(rcss%u_src(js) - rcss%u_src(js-1)) < c0) then + ! 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 + ! is then not guaranteed. + pcr(2) = c0 + uerl = rcss%uer(js-1) + uelr = rcss%uel(js) + pcr(1) = min(max(pcr(1), min(uerl, uelr)), max(uerl, uelr)) + pcr(3) = c4*(umr - pcr(1)) + pcl(1) = c4*uml - c3*pcr(1) + pcl(2) = c2*(pcr(1) - pcl(1)) + pcl(3) = - c1_2*pcl(2) + else + pcr(3) = dumr - pcr(2) + pcl(1) = pcr(1) - duml + pcl(2) = c4*(uml - pcl(1)) - duml + pcl(3) = duml - pcl(2) + endif + + ! Find all intersections with piecewise parabola in the last half of + ! the source grid cell left of the edge. + do + if ((u_edge_grd(jg) - pcr(1))*u_sgn > c0) exit + xi = parabola_intersection(pcl, u_edge_grd(jg), & + rcss%u_eps, c1_2, c1) + x_edge_grd(jg) = rcss%rcgs%x_edge_src(js-1) & + + ( rcss%rcgs%x_edge_src(js ) & + - rcss%rcgs%x_edge_src(js-1))*xi + jg = jg + 1 + if (jg > ng) return + enddo + + ! Find all intersections with piecewise parabola in the first half of + ! the source grid cell right of the edge. + do + if ((u_edge_grd(jg) - umr)*u_sgn > c0) exit + xi = parabola_intersection(pcr, u_edge_grd(jg), & + rcss%u_eps, c0, c1_2) + 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 + + enddo outer + + ! Find possible intersections in the last half of the last source grid + ! cell. + js = ns + 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, c1_2, 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_intersections + + pure subroutine regrid_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), dimension(3) :: pcl, pcr + real(r8) :: umr, uml, xi, duml, dumr, uerl, uelr + 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) + + ! Find possible intersections in the first half of the first source grid + ! cell. + 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 + umr = rcss%polycoeff(1,js) & + + c1_2*rcss%polycoeff(2,js) & + + c1_4*rcss%polycoeff(3,js) + do + if ((u_edge_grd(jg) - umr)*u_sgn > c0) exit + xi = parabola_intersection(rcss%polycoeff(:,js), u_edge_grd(jg), & + rcss%u_eps, c0, c1_2) + 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 + + outer: do + + ! For the current grid edge index, find the index of the first source + ! grid cell with mid point reconstructed value larger than the grid + ! edge value. + do + uml = umr + umr = rcss%polycoeff(1,js) & + + c1_2*rcss%polycoeff(2,js) & + + c1_4*rcss%polycoeff(3,js) + if ((u_edge_grd(jg) - umr)*u_sgn <= c0) exit + js = js + 1 + if (js > ns) exit outer + enddo + + ! 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 + ! respective grid cells. + duml = rcss%polycoeff(2,js-1) + rcss%polycoeff(3,js-1) + dumr = rcss%polycoeff(2,js ) + rcss%polycoeff(3,js ) + pcr(2) = (c4*(umr - uml) - duml - dumr)*rcss%rcgs%h_src(js) & + /(rcss%rcgs%h_src(js-1) + rcss%rcgs%h_src(js)) + pcr(1) = umr - c1_4*(dumr + pcr(2)) + if (pcr(2)*(rcss%u_src(js) - rcss%u_src(js-1)) < c0) then + ! 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 + ! is then not guaranteed. + pcr(2) = c0 + uerl = rcss%uer(js-1) + uelr = rcss%uel(js) + pcr(1) = min(max(pcr(1), min(uerl, uelr)), max(uerl, uelr)) + pcr(3) = c4*(umr - pcr(1)) + pcl(1) = c4*uml - c3*pcr(1) + pcl(2) = c2*(pcr(1) - pcl(1)) + pcl(3) = - c1_2*pcl(2) + else + pcr(3) = dumr - pcr(2) + pcl(1) = pcr(1) - duml + pcl(2) = c4*(uml - pcl(1)) - duml + pcl(3) = duml - pcl(2) + endif + + ! Find all intersections with piecewise parabola in the last half of + ! the source grid cell left of the edge. + do + if ((u_edge_grd(jg) - pcr(1))*u_sgn > c0) exit + xi = parabola_intersection(pcl, u_edge_grd(jg), & + rcss%u_eps, c1_2, c1) + x_edge_grd(jg) = rcss%rcgs%x_edge_src(js-1) & + + ( rcss%rcgs%x_edge_src(js ) & + - rcss%rcgs%x_edge_src(js-1))*xi + jg = jg + 1 + if (jg > ng) return + enddo + + ! Find all intersections with piecewise parabola in the first half of + ! the source grid cell right of the edge. + do + if ((u_edge_grd(jg) - umr)*u_sgn > c0) exit + xi = parabola_intersection(pcr, u_edge_grd(jg), & + rcss%u_eps, c0, c1_2) + 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 + + enddo outer + + ! Find possible intersections in the last half of the last source grid + ! cell. + js = ns + 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, c1_2, 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_intersections + + pure subroutine regrid_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), dimension(3) :: pcl, pcr + real(r8) :: umr, uml, xi, duml, dumr, uerl, uelr + 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) + + ! Find possible intersections in the first half of the first source grid + ! cell. + 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 + umr = rcss%polycoeff(1,js) & + + c1_2 *rcss%polycoeff(2,js) & + + c1_4 *rcss%polycoeff(3,js) & + + c1_8 *rcss%polycoeff(4,js) & + + c1_16*rcss%polycoeff(5,js) + do + if ((u_edge_grd(jg) - umr)*u_sgn > c0) exit + xi = quartic_intersection(rcss%polycoeff(:,js), u_edge_grd(jg), & + rcss%u_eps, c0, c1_2) + 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 + + outer: do + + ! For the current grid edge index, find the index of the first source + ! grid cell with mid point reconstructed value larger than the grid + ! edge value. + do + uml = umr + umr = rcss%polycoeff(1,js) & + + c1_2 *rcss%polycoeff(2,js) & + + c1_4 *rcss%polycoeff(3,js) & + + c1_8 *rcss%polycoeff(4,js) & + + c1_16*rcss%polycoeff(5,js) + if ((u_edge_grd(jg) - umr)*u_sgn <= c0) exit + js = js + 1 + if (js > ns) exit outer + enddo + + ! 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 + ! 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) + dumr = rcss%polycoeff(2,js ) + rcss%polycoeff(3,js ) & + + c3_4*rcss%polycoeff(4,js ) + c1_2*rcss%polycoeff(5,js ) + pcr(2) = (c4*(umr - uml) - duml - dumr)*rcss%rcgs%h_src(js) & + /(rcss%rcgs%h_src(js-1) + rcss%rcgs%h_src(js)) + pcr(1) = umr - c1_4*(dumr + pcr(2)) + if (pcr(2)*(rcss%u_src(js) - rcss%u_src(js-1)) < c0) then + ! 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 + ! is then not guaranteed. + pcr(2) = c0 + uerl = rcss%uer(js-1) + uelr = rcss%uel(js) + pcr(1) = min(max(pcr(1), min(uerl, uelr)), max(uerl, uelr)) + pcr(3) = c4*(umr - pcr(1)) + pcl(1) = c4*uml - c3*pcr(1) + pcl(2) = c2*(pcr(1) - pcl(1)) + pcl(3) = - c1_2*pcl(2) + else + pcr(3) = dumr - pcr(2) + pcl(1) = pcr(1) - duml + pcl(2) = c4*(uml - pcl(1)) - duml + pcl(3) = duml - pcl(2) + endif + + ! Find all intersections with piecewise parabola in the last half of + ! the source grid cell left of the edge. + do + if ((u_edge_grd(jg) - pcr(1))*u_sgn > c0) exit + xi = parabola_intersection(pcl, u_edge_grd(jg), & + rcss%u_eps, c1_2, c1) + x_edge_grd(jg) = rcss%rcgs%x_edge_src(js-1) & + + ( rcss%rcgs%x_edge_src(js ) & + - rcss%rcgs%x_edge_src(js-1))*xi + jg = jg + 1 + if (jg > ng) return + enddo + + ! Find all intersections with piecewise parabola in the first half of + ! the source grid cell right of the edge. + do + if ((u_edge_grd(jg) - umr)*u_sgn > c0) exit + xi = parabola_intersection(pcr, u_edge_grd(jg), & + rcss%u_eps, c0, c1_2) + 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 + + enddo outer + + ! Find possible intersections in the last half of the last source grid + ! cell. + js = ns + 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, c1_2, 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_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 + + ! --------------------------------------------------------------------------- + ! Public procedures. + ! --------------------------------------------------------------------------- + + function initialize_rcgs(rcgs) result(errstat) + ! --------------------------------------------------------------------------- + ! Initialize reconstruction grid data structure. + ! --------------------------------------------------------------------------- + + type(recon_grd_struct), intent(inout) :: rcgs + + integer :: errstat + + integer :: ij_size, allocstat + + ! Check requested reconstruction method and set the required order of + ! polynomials for the piecewise reconstruction. + select case (rcgs%method) + case (hor3map_pcm) + rcgs%p_ord = 0 + case (hor3map_plm) + rcgs%p_ord = 1 + case (hor3map_ppm) + rcgs%p_ord = 2 + case (hor3map_pqm) + rcgs%p_ord = 4 + case default + errstat = hor3map_invalid_method + return + end select + + ! Allocate data arrays. + + ij_size = (rcgs%i_ubound - rcgs%i_lbound + 1) & + *(rcgs%j_ubound - rcgs%j_lbound + 1) + + allocate(rcgs%x_eps_data(ij_size), & + rcgs%x_edge_src_data(rcgs%n_src+1,ij_size), & + rcgs%h_src_data(rcgs%n_src,ij_size), & + rcgs%hi_src_data(rcgs%n_src,ij_size), & + rcgs%src_dst_index_data(rcgs%n_src,ij_size), & + rcgs%n_src_actual_data(ij_size), & + rcgs%method_actual_data(ij_size), & + rcgs%prepared_data(ij_size), & + stat = allocstat) + if (allocstat /= 0) then + errstat = hor3map_failed_to_allocate_rcgs + return + endif +#ifdef DEBUG + rcgs%x_eps_data(:) = ieee_value(1._r8, ieee_signaling_nan) + rcgs%x_edge_src_data(:,:) = ieee_value(1._r8, ieee_signaling_nan) + rcgs%h_src_data(:,:) = ieee_value(1._r8, ieee_signaling_nan) + rcgs%hi_src_data(:,:) = ieee_value(1._r8, ieee_signaling_nan) + rcgs%src_dst_index_data(:,:) = - 9999 + rcgs%n_src_actual_data(:) = - 9999 + rcgs%method_actual_data(:) = - 9999 +#endif + + if (rcgs%method /= hor3map_pcm) then + allocate(rcgs%hci_src_data(rcgs%n_src,ij_size), & + stat = allocstat) + if (allocstat /= 0) then + errstat = hor3map_failed_to_allocate_rcgs + return + endif +#ifdef DEBUG + rcgs%hci_src_data(:,:) = ieee_value(1._r8, ieee_signaling_nan) +#endif + endif + + if (rcgs%method == hor3map_ppm .or. rcgs%method == hor3map_pqm) then + allocate(rcgs%src_dst_weight_data(rcgs%n_src,ij_size), & + rcgs%tdecoeff_data(rcgs%p_ord+2,rcgs%n_src,ij_size), & + rcgs%tdscoeff_data(rcgs%p_ord+2,rcgs%n_src,ij_size), & + rcgs%lblu_data(rcgs%p_ord+2,rcgs%p_ord+2,ij_size), & + rcgs%rblu_data(rcgs%p_ord+2,rcgs%p_ord+2,ij_size), & + stat = allocstat) + if (allocstat /= 0) then + errstat = hor3map_failed_to_allocate_rcgs + return + endif +#ifdef DEBUG + rcgs%src_dst_weight_data(:,:) = ieee_value(1._r8, ieee_signaling_nan) + rcgs%tdecoeff_data(:,:,:) = ieee_value(1._r8, ieee_signaling_nan) + rcgs%tdscoeff_data(:,:,:) = ieee_value(1._r8, ieee_signaling_nan) + rcgs%lblu_data(:,:,:) = ieee_value(1._r8, ieee_signaling_nan) + rcgs%rblu_data(:,:,:) = ieee_value(1._r8, ieee_signaling_nan) +#endif + endif + + rcgs%prepared_data(:) = .false. + rcgs%initialized = .true. + + errstat = hor3map_noerr + + end function initialize_rcgs + + function initialize_rcss(rcgs, rcss) result(errstat) + ! --------------------------------------------------------------------------- + ! Initialize reconstruction source data structure. + ! --------------------------------------------------------------------------- + + type(recon_grd_struct), target, intent(inout) :: rcgs + type(recon_src_struct), target, intent(inout) :: rcss + + integer :: errstat + + integer :: ij_size, allocstat + + ij_size = (rcgs%i_ubound - rcgs%i_lbound + 1) & + *(rcgs%j_ubound - rcgs%j_lbound + 1) + + allocate(rcss%u_src_data(rcgs%n_src,ij_size), & + rcss%uel_data(rcgs%n_src,ij_size), & + rcss%uer_data(rcgs%n_src,ij_size), & + rcss%polycoeff_data(rcgs%p_ord+1,rcgs%n_src,ij_size), & + rcss%reconstructed_data(ij_size), & + stat = allocstat) + if (allocstat /= 0) then + errstat = hor3map_failed_to_allocate_rcss + return + endif +#ifdef DEBUG + rcss%u_src_data(:,:) = ieee_value(1._r8, ieee_signaling_nan) + rcss%uel_data(:,:) = ieee_value(1._r8, ieee_signaling_nan) + rcss%uer_data(:,:) = ieee_value(1._r8, ieee_signaling_nan) + rcss%polycoeff_data(:,:,:) = ieee_value(1._r8, ieee_signaling_nan) +#endif + if (rcgs%method == hor3map_pqm) then + allocate(rcss%usl_data(rcgs%n_src,ij_size), & + rcss%usr_data(rcgs%n_src,ij_size), & + stat = allocstat) + if (allocstat /= 0) then + errstat = hor3map_failed_to_allocate_rcss + return + endif +#ifdef DEBUG + rcss%usl_data(:,:) = ieee_value(1._r8, ieee_signaling_nan) + rcss%usr_data(:,:) = ieee_value(1._r8, ieee_signaling_nan) +#endif + endif + + rcss%rcgs => rcgs + rcss%rcss_dep_next => rcgs%rcss_dep_head + rcgs%rcss_dep_head => rcss + rcss%reconstructed_data(:) = .false. + rcss%initialized = .true. + + errstat = hor3map_noerr + + end function initialize_rcss + + function initialize_rms(rcgs, rms) result(errstat) + ! --------------------------------------------------------------------------- + ! Initialize remapping data structure. + ! --------------------------------------------------------------------------- + + type(recon_grd_struct), target, intent(inout) :: rcgs + type(remap_struct), target, intent(inout) :: rms + + integer :: errstat + + integer :: ij_size, allocstat + + ij_size = (rcgs%i_ubound - rcgs%i_lbound + 1) & + *(rcgs%j_ubound - rcgs%j_lbound + 1) + + allocate(rms%h_dst_data(rms%n_dst,ij_size), & + rms%hi_dst_data(rms%n_dst,ij_size), & + rms%seg_int_lim_data(rcgs%n_src+rms%n_dst,ij_size), & + rms%n_src_seg_data(rcgs%n_src,ij_size), & + rms%seg_dst_index_data(rcgs%n_src+rms%n_dst,ij_size), & + rms%prepared_data(ij_size), & + stat = allocstat) + if (allocstat /= 0) then + errstat = hor3map_failed_to_allocate_rms + return + endif +#ifdef DEBUG + rms%h_dst_data(:,:) = ieee_value(1._r8, ieee_signaling_nan) + rms%hi_dst_data(:,:) = ieee_value(1._r8, ieee_signaling_nan) + rms%seg_int_lim_data(:,:) = ieee_value(1._r8, ieee_signaling_nan) + rms%n_src_seg_data(:,:) = - 9999 + rms%seg_dst_index_data(:,:) = - 9999 +#endif + + rms%rcgs => rcgs + rms%rms_dep_next => rcgs%rms_dep_head + rcgs%rms_dep_head => rms + rms%prepared_data(:) = .false. + rms%initialized = .true. + + errstat = hor3map_noerr + + end function initialize_rms + + function prepare_reconstruction(rcgs, x_edge_src, i_index, j_index) & + result(errstat) + ! --------------------------------------------------------------------------- + ! Prepare reconstruction based on edge locations of source grid cells and + ! requested reconstruction method. Reconstruction data is stored in a + ! reconstruction grid data structure. + ! --------------------------------------------------------------------------- + + type(recon_grd_struct), intent(inout) :: rcgs + real(r8), dimension(:), intent(in) :: x_edge_src + integer, optional, intent(in) :: i_index, j_index + + integer :: errstat + + integer :: n_src, j + + errstat = hor3map_noerr + + ! Check optional arguments. + if (present(i_index)) rcgs%i_index = i_index + if (present(j_index)) rcgs%j_index = j_index + + ! Number of source grid cells. + n_src = size(x_edge_src) - 1 + + ! Check that source grid edges are monotonically increasing or decreasing. + if (x_edge_src(n_src+1) - x_edge_src(1) > c0) then + do j = 1, n_src + if (x_edge_src(j+1) < x_edge_src(j)) then + errstat = hor3map_nonmonotonic_src_edges + return + endif + enddo + else + do j = 1, n_src + if (x_edge_src(j+1) > x_edge_src(j)) then + errstat = hor3map_nonmonotonic_src_edges + return + endif + enddo + endif + + ! If needed, initialize reconstruction grid data structure. + if (.not. rcgs%initialized) then + rcgs%n_src = n_src + errstat = initialize_rcgs(rcgs) + if (errstat /= hor3map_noerr) return + elseif (rcgs%n_src /= n_src) then + if (rcgs%i_lbound == 1 .and. rcgs%i_ubound == 1 .and. & + rcgs%j_lbound == 1 .and. rcgs%j_ubound == 1) then + call free_rcgs(rcgs) + rcgs%n_src = n_src + errstat = initialize_rcgs(rcgs) + if (errstat /= hor3map_noerr) return + else + errstat = hor3map_resizing_initialized_rcgs + return + endif + endif + + ! Assign array pointers within reconstruction grid data structure. + errstat = assign_ptr_rcgs(rcgs) + if (errstat /= hor3map_noerr) return + + rcgs%prepared = .false. + + ! Set small value with same dimensions as edge locations. + rcgs%x_eps = max(abs(x_edge_src(n_src+1) - x_edge_src(1)), eps)*eps + + ! Based on the requested reconstruction method, prepare the data structure + ! for the various methods. Arrays with indices and weights are + ! constructed that will map the source data to a continuous array of + ! grid cells that are non-empty and with widths that will ensure + ! condition numbers below a specified threshold of matrices in linear + ! equation systems to be solved. If insufficient grid cells are available + ! for the requested method, lower order methods are tried. + + rcgs%method_actual = rcgs%method + + if (rcgs%method_actual == hor3map_pqm) then + call prepare_pqm(rcgs, x_edge_src) + if (rcgs%n_src_actual < 6) then + rcgs%method_actual = hor3map_ppm + else + rcgs%method_actual = hor3map_pqm + endif + endif + + if (rcgs%method_actual == hor3map_ppm) then + call prepare_ppm(rcgs, x_edge_src) + if (rcgs%n_src_actual < 4) then + rcgs%method_actual = hor3map_plm + else + rcgs%method_actual = hor3map_ppm + endif + endif + + if (rcgs%method_actual == hor3map_plm) then + call prepare_plm(rcgs, x_edge_src) + if (rcgs%n_src_actual < 2) then + rcgs%method_actual = hor3map_pcm + else + rcgs%method_actual = hor3map_plm + endif + endif + + if (rcgs%method_actual == hor3map_pcm) then + call prepare_pcm(rcgs, x_edge_src) + if (rcgs%n_src_actual == 0) then + errstat = hor3map_src_extent_too_small + return + else + rcgs%method_actual = hor3map_pcm + endif + endif + + ! Set flag to indicate the reconstruction has been prepared. + rcgs%prepared = .true. + + end function prepare_reconstruction + + function prepare_remapping(rcgs, rms, x_edge_dst, i_index, j_index) & + result(errstat) + ! --------------------------------------------------------------------------- + ! Prepare remapping based on a reconstruction data structure and edge + ! locations of destination grid cells. Remapping data is stored in a remap + ! data structure. + ! --------------------------------------------------------------------------- + + type(recon_grd_struct), target, intent(inout) :: rcgs + real(r8), dimension(:), intent(in) :: x_edge_dst + type(remap_struct), intent(inout) :: rms + integer, optional, intent(in) :: i_index, j_index + + integer :: errstat + + real(r8) :: xil + integer :: n_dst, j, js, jd, iseg + + ! Check optional arguments. + if (present(i_index)) rcgs%i_index = i_index + if (present(j_index)) rcgs%j_index = j_index + + ! Check that the reconstruction grid data structure has been initialized. + if (.not. rcgs%initialized) then + errstat = hor3map_recon_not_prepared + return + endif + + ! Number of destination grid cells. + n_dst = size(x_edge_dst) - 1 + + ! If needed, initialize remapping data structure. + if (.not. rms%initialized) then + rms%n_dst = n_dst + errstat = initialize_rms(rcgs, rms) + if (errstat /= hor3map_noerr) return + elseif (.not. associated(rms%rcgs, rcgs)) then + call free_rms(rms) + rms%n_dst = n_dst + errstat = initialize_rms(rcgs, rms) + if (errstat /= hor3map_noerr) return + elseif (rms%n_dst /= n_dst) then + if (rcgs%i_lbound == 1 .and. rcgs%i_ubound == 1 .and. & + rcgs%j_lbound == 1 .and. rcgs%j_ubound == 1) then + call free_rms(rms) + rms%n_dst = n_dst + errstat = initialize_rms(rcgs, rms) + if (errstat /= hor3map_noerr) return + else + errstat = hor3map_resizing_initialized_rms + return + endif + endif + + ! Assign array pointers within reconstruction grid and source + ! data structures. + errstat = assign_ptr_rcgs(rms%rcgs) + if (errstat /= hor3map_noerr) return + errstat = assign_ptr_rms(rms) + if (errstat /= hor3map_noerr) return + + ! Check that the reconstruction has been prepared. + if (.not. rcgs%prepared) then + errstat = hor3map_recon_not_prepared + return + endif + + rms%prepared = .false. + + ! Check for consistency between the source and destination grid range. + if (abs(rcgs%x_edge_src(1) - x_edge_dst(1)) > rcgs%x_eps .or. & + abs(rcgs%x_edge_src(rcgs%n_src_actual+1) - x_edge_dst(n_dst+1)) & + > rcgs%x_eps) then + errstat = hor3map_inconsistent_grid_range + return + endif + + ! Check that destination grid edges are monotonically increasing or + ! decreasing. + if (x_edge_dst(n_dst+1) - x_edge_dst(1) > c0) then + do j = 1, n_dst + if (x_edge_dst(j+1) < x_edge_dst(j)) then + errstat = hor3map_nonmonotonic_dst_edges + return + endif + enddo + else + do j = 1, n_dst + if (x_edge_dst(j+1) > x_edge_dst(j)) then + errstat = hor3map_nonmonotonic_dst_edges + return + endif + enddo + endif + + ! From edge locations, obtain destination grid cell widths and their + ! multiplicative inverse. + do j = 1, rms%n_dst + rms%h_dst(j) = abs(x_edge_dst(j+1) - x_edge_dst(j)) + if (rms%h_dst(j) > rcgs%x_eps) then + rms%hi_dst(j) = c1/rms%h_dst(j) + else + rms%hi_dst(j) = c0 + endif + enddo + + ! Locate all segments that require integration of the reconstructed source + ! data and obtain integration limits and destination index for the + ! accumulation of integrals. + + js = 1 + jd = 1 + do while (rms%hi_dst(jd) == c0) + jd = jd + 1 + enddo + iseg = 0 + rms%n_src_seg(js) = 0 + xil = c0 + + if (x_edge_dst(n_dst+1) - x_edge_dst(1) > c0) then + + do + iseg = iseg + 1 + rms%n_src_seg(js) = rms%n_src_seg(js) + 1 + rms%seg_dst_index(iseg) = jd + if ( abs(rcgs%x_edge_src(js+1) - x_edge_dst(jd+1)) & + <= rcgs%x_eps) then + if (rms%hi_dst(jd) == c0) then + rms%seg_int_lim(iseg) = xil + else + rms%seg_int_lim(iseg) = c1 + endif + if (js == rcgs%n_src_actual) exit + xil = c0 + js = js + 1 + jd = jd + 1 + rms%n_src_seg(js) = 0 + elseif (rcgs%x_edge_src(js+1) < x_edge_dst(jd+1)) then + rms%seg_int_lim(iseg) = c1 + xil = c0 + js = js + 1 + rms%n_src_seg(js) = 0 + else + if (rms%hi_dst(jd) == c0) then + rms%seg_int_lim(iseg) = xil + else + rms%seg_int_lim(iseg) = & + (x_edge_dst(jd+1) - rcgs%x_edge_src(js))*rcgs%hi_src(js) + xil = rms%seg_int_lim(iseg) + endif + jd = jd + 1 + endif + enddo + + else + + do + iseg = iseg + 1 + rms%n_src_seg(js) = rms%n_src_seg(js) + 1 + rms%seg_dst_index(iseg) = jd + if ( abs(rcgs%x_edge_src(js+1) - x_edge_dst(jd+1)) & + <= rcgs%x_eps) then + if (rms%hi_dst(jd) == c0) then + rms%seg_int_lim(iseg) = xil + else + rms%seg_int_lim(iseg) = c1 + endif + if (js == rcgs%n_src_actual) exit + xil = c0 + js = js + 1 + jd = jd + 1 + rms%n_src_seg(js) = 0 + elseif (rcgs%x_edge_src(js+1) > x_edge_dst(jd+1)) then + rms%seg_int_lim(iseg) = c1 + xil = c0 + js = js + 1 + rms%n_src_seg(js) = 0 + else + if (rms%hi_dst(jd) == c0) then + rms%seg_int_lim(iseg) = xil + else + rms%seg_int_lim(iseg) = & + (rcgs%x_edge_src(js) - x_edge_dst(jd+1))*rcgs%hi_src(js) + xil = rms%seg_int_lim(iseg) + endif + jd = jd + 1 + endif + enddo + + endif + + rms%prepared = .true. + + end function prepare_remapping + + function reconstruct(rcgs, rcss, u_src, i_index, j_index) result(errstat) + ! --------------------------------------------------------------------------- + ! Carry out the piecewise polynomial reconstruction of the source data with + ! desired limiting method and handling of boundaries. + ! --------------------------------------------------------------------------- + + type(recon_grd_struct), target, intent(inout) :: rcgs + real(r8), dimension(:), intent(in) :: u_src + type(recon_src_struct), intent(inout) :: rcss + integer, optional, intent(in) :: i_index, j_index + + integer :: errstat + + integer :: js, jd + + ! Check optional arguments. + if (present(i_index)) rcgs%i_index = i_index + if (present(j_index)) rcgs%j_index = j_index + + ! Check that the reconstruction grid data structure has been initialized. + if (.not. rcgs%initialized) then + errstat = hor3map_recon_not_prepared + return + endif + + ! Check consistency of number of source grid cells. + if (size(u_src) /= rcgs%n_src) then + errstat = hor3map_src_size_mismatch + return + endif + + ! If needed, initialize reconstruction source data structure. + if (.not. rcss%initialized) then + errstat = initialize_rcss(rcgs, rcss) + if (errstat /= hor3map_noerr) return + elseif (.not. associated(rcss%rcgs, rcgs)) then + call free_rcss(rcss) + errstat = initialize_rcss(rcgs, rcss) + if (errstat /= hor3map_noerr) return + endif + + ! Assign array pointers within reconstruction grid and source data + ! structures. + errstat = assign_ptr_rcgs(rcgs) + if (errstat /= hor3map_noerr) return + errstat = assign_ptr_rcss(rcss) + if (errstat /= hor3map_noerr) return + + ! Check that the reconstruction has been prepared. + if (.not. rcgs%prepared) then + errstat = hor3map_recon_not_prepared + return + endif + + ! Copy source data array to continuous array of grid cells to be used in + ! the reconstruction. + if (rcgs%method_actual == hor3map_pcm .or. & + rcgs%method_actual == hor3map_plm) then + do js = 1, rcgs%n_src + jd = rcgs%src_dst_index(js) + if (jd /= 0) rcss%u_src(jd) = u_src(js) + enddo + else + rcss%u_src(1:rcgs%n_src_actual) = c0 + do js = 1, rcgs%n_src + jd = rcgs%src_dst_index(js) + if (jd /= 0) rcss%u_src(jd) = rcss%u_src(jd) & + + rcgs%src_dst_weight(js)*u_src(js) + enddo + endif + + ! Set small value with same dimensions as source data. + rcss%u_range = abs( minval(rcss%u_src(1:rcgs%n_src_actual)) & + - maxval(rcss%u_src(1:rcgs%n_src_actual))) + rcss%u_eps = rcss%u_range*eps + rcss%uu_eps = rcss%u_range*rcss%u_eps + + + select case (rcgs%method_actual) + case (hor3map_plm) + select case (rcss%limiting) + case (hor3map_no_limiting) + call reconstruct_plm_no_limiting(rcss) + case (hor3map_monotonic, hor3map_non_oscillatory, & + hor3map_non_oscillatory_posdef) + call reconstruct_plm_monotonic(rcss) + case default + errstat = hor3map_invalid_plm_limiting + return + end select + case (hor3map_ppm) + call reconstruct_ppm_edge_values(rcss) + select case (rcss%limiting) + case (hor3map_no_limiting) + case (hor3map_monotonic) + call limit_ppm_interior_monotonic(rcss) + call limit_ppm_boundary(rcss) + case (hor3map_non_oscillatory) + call limit_ppm_interior_non_oscillatory(rcss) + call limit_ppm_boundary(rcss) + case (hor3map_non_oscillatory_posdef) + call limit_ppm_interior_non_oscillatory(rcss) + call limit_ppm_boundary(rcss) + call limit_ppm_posdef(rcss) + case default + errstat = hor3map_invalid_ppm_limiting + return + end select + call polycoeff_ppm(rcss) + case (hor3map_pqm) + call reconstruct_pqm_edge_slope_values(rcss) + select case (rcss%limiting) + case (hor3map_no_limiting) + case (hor3map_monotonic) + call limit_pqm_monotonic(rcss) + case (hor3map_non_oscillatory) + call limit_pqm_non_oscillatory(rcss) + case (hor3map_non_oscillatory_posdef) + call limit_pqm_non_oscillatory_posdef(rcss) + case default + errstat = hor3map_invalid_pqm_limiting + return + end select + call polycoeff_pqm(rcss) + end select + + rcss%reconstructed = .true. + + end function reconstruct + + function extract_polycoeff(rcss, polycoeff, i_index, j_index) result(errstat) + ! --------------------------------------------------------------------------- + ! Extract polynomial coefficients of a reconstruction. For grid cells that + ! have been merged due to potential for ill-conditioned linear systems, + ! polynomial coefficients will be constructed that are consistent with the + ! reconstruction of the merged cells. Near-empty grid cells are set to a + ! constant reconstruction. + ! --------------------------------------------------------------------------- + + type(recon_src_struct), intent(inout) :: rcss + real(r8), dimension(:,:), intent(out) :: polycoeff + integer, optional, intent(in) :: i_index, j_index + + integer :: errstat + + real(r8) :: xi0, q + integer :: js0, js, jd + + ! Check that reconstruction source data structure has been initialized. + if (.not. rcss%initialized) then + errstat = hor3map_recon_not_available + return + 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 + 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 + + ! Extract polynomial coefficients. + + polycoeff(:,:) = c0 + + select case (rcss%rcgs%method_actual) + + case (hor3map_pcm) + + js0 = 1 + do + jd = rcss%rcgs%src_dst_index(js0) + if (jd == 0) then + polycoeff(1,js0) = rcss%u_src(1) + else + polycoeff(1,js0) = rcss%u_src(jd) + exit + endif + js0 = js0 + 1 + if (js0 > rcss%rcgs%n_src) exit + enddo + do js = js0+1, rcss%rcgs%n_src + jd = rcss%rcgs%src_dst_index(js) + if (jd == 0) then + polycoeff(1,js) = polycoeff(1,js-1) + else + polycoeff(1,js) = rcss%u_src(jd) + endif + enddo + + case (hor3map_plm) + + js0 = 1 + do + jd = rcss%rcgs%src_dst_index(js0) + if (jd == 0) then + polycoeff(1,js0) = rcss%polycoeff(1,1) + else + polycoeff(1:2,js0) = rcss%polycoeff(1:2,1) + exit + endif + js0 = js0 + 1 + if (js0 > rcss%rcgs%n_src) exit + enddo + do js = js0+1, rcss%rcgs%n_src + jd = rcss%rcgs%src_dst_index(js) + if (jd == 0) then + polycoeff(1,js) = polycoeff(1,js-1) + polycoeff(2,js-1) + else + polycoeff(1:2,js) = rcss%polycoeff(1:2,jd) + endif + enddo + + case (hor3map_ppm) + + js0 = 1 + do + jd = rcss%rcgs%src_dst_index(js0) + if (jd == 0) then + polycoeff(1,js0) = rcss%polycoeff(1,1) + else + exit + endif + js0 = js0 + 1 + if (js0 > rcss%rcgs%n_src) exit + enddo + xi0 = c0 + do js = js0, rcss%rcgs%n_src + jd = rcss%rcgs%src_dst_index(js) + if (jd == 0) then + polycoeff(1,js) = polycoeff(1,js-1) & + + polycoeff(2,js-1) & + + polycoeff(3,js-1) + else + if (rcss%rcgs%src_dst_weight(js) == c1) then + polycoeff(1:3,js) = rcss%polycoeff(1:3,jd) + xi0 = c0 + else + polycoeff(1,js) = rcss%polycoeff(1,jd) & + + ( rcss%polycoeff(2,jd) & + + rcss%polycoeff(3,jd)*xi0)*xi0 + polycoeff(2,js) = ( rcss%polycoeff(2,jd) & + + c2*rcss%polycoeff(3,jd)*xi0) & + *rcss%rcgs%src_dst_weight(js) + polycoeff(3,js) = rcss%polycoeff(3,jd) & + *rcss%rcgs%src_dst_weight(js) & + *rcss%rcgs%src_dst_weight(js) + xi0 = xi0 + rcss%rcgs%src_dst_weight(js) + endif + endif + enddo + + case (hor3map_pqm) + + js0 = 1 + do + jd = rcss%rcgs%src_dst_index(js0) + if (jd == 0) then + polycoeff(1,js0) = rcss%polycoeff(1,1) + else + exit + endif + js0 = js0 + 1 + if (js0 > rcss%rcgs%n_src) exit + enddo + xi0 = c0 + do js = js0, rcss%rcgs%n_src + jd = rcss%rcgs%src_dst_index(js) + if (jd == 0) then + polycoeff(1,js) = polycoeff(1,js-1) & + + polycoeff(2,js-1) & + + polycoeff(3,js-1) & + + polycoeff(4,js-1) & + + polycoeff(5,js-1) + else + if (rcss%rcgs%src_dst_weight(js) == c1) then + polycoeff(1:5,js) = rcss%polycoeff(1:5,jd) + xi0 = c0 + else + polycoeff(1,js) = rcss%polycoeff(1,jd) & + + ( rcss%polycoeff(2,jd) & + + ( rcss%polycoeff(3,jd) & + + ( rcss%polycoeff(4,jd) & + + rcss%polycoeff(5,jd) & + *xi0)*xi0)*xi0)*xi0 + q = rcss%rcgs%src_dst_weight(js) + polycoeff(2,js) = ( rcss%polycoeff(2,jd) & + + ( c2*rcss%polycoeff(3,jd) & + + ( c3*rcss%polycoeff(4,jd) & + + c4*rcss%polycoeff(5,jd) & + *xi0)*xi0)*xi0)*q + q = q*rcss%rcgs%src_dst_weight(js) + polycoeff(3,js) = ( rcss%polycoeff(3,jd) & + + ( c3*rcss%polycoeff(4,jd) & + + c6*rcss%polycoeff(5,jd) & + *xi0)*xi0)*q + q = q*rcss%rcgs%src_dst_weight(js) + polycoeff(4,js) = ( rcss%polycoeff(4,jd) & + + c4*rcss%polycoeff(5,jd)*xi0)*q + q = q*rcss%rcgs%src_dst_weight(js) + polycoeff(5,js) = rcss%polycoeff(5,jd)*q + xi0 = xi0 + rcss%rcgs%src_dst_weight(js) + endif + endif + enddo + + end select + + end function extract_polycoeff + + function regrid(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 + 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 + 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 + 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 + 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 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 + + end function regrid2 + + function remap(rcss, rms, u_dst, i_index, j_index) result(errstat) + ! --------------------------------------------------------------------------- + ! Carry out the remapping of a piecewise polynomial reconstruction of the + ! source data to a destination grid. + ! --------------------------------------------------------------------------- + + type(recon_src_struct), intent(inout) :: rcss + type(remap_struct), intent(inout) :: rms + real(r8), dimension(:), intent(out) :: u_dst + integer, optional, intent(in) :: i_index, j_index + + integer :: errstat + + real(r8) :: xil, xir, adl, adr + integer :: ns, iseg, js, jd, i_src_seg + + errstat = hor3map_noerr + + ! Check that reconstruction source data structure has been initialized. + if (.not. rcss%initialized) then + errstat = hor3map_recon_not_available + return + endif + + ! Check optional arguments. + if (present(i_index)) rcss%rcgs%i_index = i_index + if (present(j_index)) rcss%rcgs%j_index = j_index + + ! Check that remapping data structure has been initialized. + if (.not. rms%initialized) then + errstat = hor3map_remap_not_prepared + return + endif + + ! Check that data structures have consistent associations. + if (.not. associated(rcss%rcgs, rms%rcgs)) then + errstat = hor3map_inconsistent_rcgs + return + endif + + ! 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 + errstat = assign_ptr_rms(rms) + if (errstat /= hor3map_noerr) return + + ! Check that the remapping has been prepared + if (.not. rms%prepared) then + errstat = hor3map_remap_not_prepared + return + endif + + ! Check that the reconstruction is available. + if (.not. rcss%reconstructed) then + errstat = hor3map_recon_not_available + return + endif + + if (size(u_dst) /= rms%n_dst) then + errstat = hor3map_dst_size_mismatch + return + endif + + u_dst(:) = 0._r8 + ns = rcss%rcgs%n_src_actual + iseg = 0 + + select case (rcss%rcgs%method_actual) + + case (hor3map_pcm) + + ! Integrate the required segments of each source grid cell in + ! succession, adding the integrals to the appropriate destination + ! grid cells. + do js = 1, ns + if (rms%n_src_seg(js) == 1) then + iseg = iseg + 1 + jd = rms%seg_dst_index(iseg) + u_dst(jd) = u_dst(jd) & + + rcss%u_src(js)*rcss%rcgs%h_src(js)*rms%hi_dst(jd) + else + xil = c0 + do i_src_seg = 1, rms%n_src_seg(js) + iseg = iseg + 1 + xir = rms%seg_int_lim(iseg) + jd = rms%seg_dst_index(iseg) + if (xil == xir) then + u_dst(jd) = rcss%u_src(js) + else + u_dst(jd) = u_dst(jd) & + + rcss%u_src(js)*(xir - xil) & + *rcss%rcgs%h_src(js)*rms%hi_dst(jd) + xil = xir + endif + enddo + endif + enddo + + ! Set values for any near-empty destination grid cells at the start + ! and the end of the array. + do jd = 1, rms%seg_dst_index(1)-1 + u_dst(jd) = rcss%u_src(1) + enddo + do jd = rms%seg_dst_index(iseg)+1, rms%n_dst + u_dst(jd) = rcss%u_src(ns) + enddo + + case (hor3map_plm) + + ! Integrate the required segments of each source grid cell in + ! succession, adding the integrals to the appropriate destination + ! grid cells. + do js = 1, ns + if (rms%n_src_seg(js) == 1) then + iseg = iseg + 1 + jd = rms%seg_dst_index(iseg) + u_dst(jd) = u_dst(jd) & + + rcss%u_src(js)*rcss%rcgs%h_src(js)*rms%hi_dst(jd) + else + xil = c0 + adl = c0 + do i_src_seg = 1, rms%n_src_seg(js) + iseg = iseg + 1 + xir = rms%seg_int_lim(iseg) + jd = rms%seg_dst_index(iseg) + if (xil == xir) then + u_dst(jd) = rcss%polycoeff(1,js) & + + rcss%polycoeff(2,js)*xir + else + adr = ( rcss%polycoeff(1,js) & + + c1_2*rcss%polycoeff(2,js)*xir)*xir + u_dst(jd) = u_dst(jd) & + + (adr - adl)*rcss%rcgs%h_src(js) & + *rms%hi_dst(jd) + xil = xir + adl = adr + endif + enddo + endif + enddo + + ! Set values for any near-empty destination grid cells at the start + ! and the end of the array. + do jd = 1, rms%seg_dst_index(1)-1 + u_dst(jd) = rcss%polycoeff(1,1) + enddo + if (rms%seg_dst_index(iseg) < rms%n_dst) then + jd = rms%seg_dst_index(iseg) + 1 + u_dst(jd) = rcss%polycoeff(1,ns) + rcss%polycoeff(2,ns) + do jd = rms%seg_dst_index(iseg)+2, rms%n_dst + u_dst(jd) = u_dst(rms%seg_dst_index(iseg)+1) + enddo + endif + + case (hor3map_ppm) + + ! Integrate the required segments of each source grid cell in + ! succession, adding the integrals to the appropriate destination + ! grid cells. + do js = 1, ns + if (rms%n_src_seg(js) == 1) then + iseg = iseg + 1 + jd = rms%seg_dst_index(iseg) + u_dst(jd) = u_dst(jd) & + + rcss%u_src(js)*rcss%rcgs%h_src(js)*rms%hi_dst(jd) + else + xil = c0 + adl = c0 + do i_src_seg = 1, rms%n_src_seg(js) + iseg = iseg + 1 + xir = rms%seg_int_lim(iseg) + jd = rms%seg_dst_index(iseg) + if (xil == xir) then + u_dst(jd) = rcss%polycoeff(1,js) & + + ( rcss%polycoeff(2,js) & + + rcss%polycoeff(3,js)*xir)*xir + else + adr = ( rcss%polycoeff(1,js) & + + ( c1_2*rcss%polycoeff(2,js) & + + c1_3*rcss%polycoeff(3,js)*xir)*xir)*xir + u_dst(jd) = u_dst(jd) & + + (adr - adl)*rcss%rcgs%h_src(js) & + *rms%hi_dst(jd) + xil = xir + adl = adr + endif + enddo + endif + enddo + + ! Set values for any near-empty destination grid cells at the start + ! and the end of the array. + do jd = 1, rms%seg_dst_index(1)-1 + u_dst(jd) = rcss%polycoeff(1,1) + enddo + if (rms%seg_dst_index(iseg) < rms%n_dst) then + jd = rms%seg_dst_index(iseg) + 1 + u_dst(jd) = rcss%polycoeff(1,ns) + rcss%polycoeff(2,ns) & + + rcss%polycoeff(3,ns) + do jd = rms%seg_dst_index(iseg)+2, rms%n_dst + u_dst(jd) = u_dst(rms%seg_dst_index(iseg)+1) + enddo + endif + + case (hor3map_pqm) + + ! Integrate the required segments of each source grid cell in + ! succession, adding the integrals to the appropriate destination + ! grid cells. + do js = 1, ns + if (rms%n_src_seg(js) == 1) then + iseg = iseg + 1 + jd = rms%seg_dst_index(iseg) + u_dst(jd) = u_dst(jd) & + + rcss%u_src(js)*rcss%rcgs%h_src(js)*rms%hi_dst(jd) + else + xil = c0 + adl = c0 + do i_src_seg = 1, rms%n_src_seg(js) + iseg = iseg + 1 + xir = rms%seg_int_lim(iseg) + jd = rms%seg_dst_index(iseg) + if (xil == xir) then + u_dst(jd) = rcss%polycoeff(1,js) & + + ( rcss%polycoeff(2,js) & + + ( rcss%polycoeff(3,js) & + + ( rcss%polycoeff(4,js) & + + rcss%polycoeff(5,js) & + *xir)*xir)*xir)*xir + else + adr = ( rcss%polycoeff(1,js) & + + ( c1_2*rcss%polycoeff(2,js) & + + ( c1_3*rcss%polycoeff(3,js) & + + ( c1_4*rcss%polycoeff(4,js) & + + c1_5*rcss%polycoeff(5,js) & + *xir)*xir)*xir)*xir)*xir + u_dst(jd) = u_dst(jd) & + + (adr - adl)*rcss%rcgs%h_src(js) & + *rms%hi_dst(jd) + xil = xir + adl = adr + endif + enddo + endif + enddo + + ! Set values for any near-empty destination grid cells at the start + ! and the end of the array. + do jd = 1, rms%seg_dst_index(1)-1 + u_dst(jd) = rcss%polycoeff(1,1) + enddo + if (rms%seg_dst_index(iseg) < rms%n_dst) then + jd = rms%seg_dst_index(iseg) + 1 + u_dst(jd) = rcss%polycoeff(1,ns) + rcss%polycoeff(2,ns) & + + rcss%polycoeff(3,ns) + rcss%polycoeff(4,ns) & + + rcss%polycoeff(5,ns) + do jd = rms%seg_dst_index(iseg)+2, rms%n_dst + u_dst(jd) = u_dst(rms%seg_dst_index(iseg)+1) + enddo + endif + + end select + + end function remap + + subroutine free_rcgs(rcgs) + ! --------------------------------------------------------------------------- + ! Nullify pointers, deallocate arrays and reset flags. + ! --------------------------------------------------------------------------- + + type(recon_grd_struct), intent(inout) :: rcgs + + type(recon_src_struct), pointer :: rcss_dep, rcss_dep_next + type(remap_struct), pointer :: rms_dep, rms_dep_next + + ! Free data structures that depends on this + ! reconstruction grid data structure. + rcss_dep => rcgs%rcss_dep_head + do while (associated(rcss_dep)) + rcss_dep_next => rcss_dep%rcss_dep_next + call free_rcss(rcss_dep) + rcss_dep => rcss_dep_next + enddo + rms_dep => rcgs%rms_dep_head + do while (associated(rms_dep)) + rms_dep_next => rms_dep%rms_dep_next + call free_rms(rms_dep) + rms_dep => rms_dep_next + enddo + + nullify(rcgs%x_eps, rcgs%x_edge_src, rcgs%h_src, rcgs%hi_src, & + rcgs%src_dst_index, rcgs%n_src_actual, rcgs%method_actual, & + rcgs%prepared, rcgs%rcss_dep_head, rcgs%rms_dep_head) + deallocate(rcgs%x_eps_data, rcgs%x_edge_src_data, rcgs%h_src_data, & + rcgs%hi_src_data, rcgs%src_dst_index_data, & + rcgs%n_src_actual_data, rcgs%method_actual_data, & + rcgs%prepared_data) + + if (rcgs%method /= hor3map_pcm) then + nullify(rcgs%hci_src) + deallocate(rcgs%hci_src_data) + endif + + if (rcgs%method == hor3map_ppm .or. rcgs%method == hor3map_pqm) then + nullify(rcgs%src_dst_weight, rcgs%tdecoeff, rcgs%tdscoeff, rcgs%lblu, & + rcgs%rblu) + deallocate(rcgs%src_dst_weight_data, rcgs%tdecoeff_data, & + rcgs%tdscoeff_data, rcgs%lblu_data, rcgs%rblu_data) + endif + + rcgs%i_index_curr = 0 + rcgs%j_index_curr = 0 + rcgs%initialized = .false. + + end subroutine free_rcgs + + subroutine free_rcss(rcss) + ! --------------------------------------------------------------------------- + ! Nullify pointers, deallocate arrays and reset flags. + ! --------------------------------------------------------------------------- + + type(recon_src_struct), intent(inout) :: rcss + + nullify(rcss%u_src, rcss%uel, rcss%uer, rcss%polycoeff, & + rcss%reconstructed, rcss%rcss_dep_next) + deallocate(rcss%u_src_data, rcss%uel_data, rcss%uer_data, & + rcss%polycoeff_data, rcss%reconstructed_data) + + if (rcss%rcgs%method == hor3map_pqm) then + nullify(rcss%usl, rcss%usr) + deallocate(rcss%usl_data, rcss%usr_data) + endif + + rcss%i_index_curr = 0 + rcss%j_index_curr = 0 + rcss%initialized = .false. + + end subroutine free_rcss + + subroutine free_rms(rms) + ! --------------------------------------------------------------------------- + ! Nullify pointers, deallocate arrays and reset flags. + ! --------------------------------------------------------------------------- + + type(remap_struct), intent(inout) :: rms + + nullify(rms%h_dst, rms%hi_dst, rms%seg_int_lim, rms%n_src_seg, & + rms%seg_dst_index, rms%prepared, rms%rms_dep_next) + deallocate(rms%h_dst_data, rms%hi_dst_data, rms%seg_int_lim_data, & + rms%n_src_seg_data, rms%seg_dst_index_data, rms%prepared_data) + + rms%i_index_curr = 0 + rms%j_index_curr = 0 + rms%initialized = .false. + + end subroutine free_rms + + pure function hor3map_errstr(errstat) result(errstr) + ! --------------------------------------------------------------------------- + ! Returns static reference to an error message string corresponding to a + ! HOR3MAP error status. + ! --------------------------------------------------------------------------- + + integer, intent(in) :: errstat ! Error status. + + character(len = 80) :: errstr ! Error message string. + + if (errstat > 0 .and. errstat <= hor3map_errmsg_num) then + errstr = errmsg(errstat) + else + errstr = 'Unknown error status!' + endif + + end function hor3map_errstr + +end module mod_hor3map diff --git a/phy/mod_inicon.F b/phy/mod_inicon.F index fdb8262e..70e0c371 100644 --- a/phy/mod_inicon.F +++ b/phy/mod_inicon.F @@ -1,5 +1,5 @@ ! ------------------------------------------------------------------------------ -! Copyright (C) 2008-2021 Mats Bentsen, Mehmet Ilicak, Aleksi Nummelin +! Copyright (C) 2008-2022 Mats Bentsen, Mehmet Ilicak, Aleksi Nummelin ! ! This file is part of BLOM. ! @@ -27,10 +27,15 @@ module mod_inicon c use mod_types, only: r8 use mod_config, only: expcnf - use mod_constants, only: g, epsil, onem + use mod_constants, only: g, epsilp, onem, + . L_mks2cgs, M_mks2cgs, P_mks2cgs use mod_time, only: nstep, delt1, dlt use mod_xc - use mod_grid, only: sigmar, scuy, scvx, scuyi, scvxi, depths, + use mod_vcoord, only: vcoord_type_tag, isopyc_bulkml, + . cntiso_hybrid, sigmar, + . cntiso_hybrid_regrid_direct_remap, + . remap_velocity + use mod_grid, only: scuy, scvx, scuyi, scvxi, depths, . corioq use mod_state, only: u, v, dp, dpu, dpv, temp, saln, sigma, p, pu, . pv, phi, ubflxs, vbflxs, ub, vb, pb, pbu, @@ -94,7 +99,7 @@ function getpl(th,s,phiu,phil,pup) result(plo) c --- improve the accuracy of the pressure interface by an c --- iterative procedure q=1._r8 - do while (abs(q).gt.1.e-4_r8) + do while (abs(q).gt.1.e-5_r8*P_mks2cgs) call delphi(pup,plo,th,s,dphi,alpu,alpl) q=(phil-phiu-dphi)/alpl plo=plo-q @@ -114,8 +119,12 @@ subroutine ictsz_file real, dimension(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy,kdm+1) :: z real, dimension(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy,kdm) :: dz real, dimension(itdm,jtdm) :: tmp2d + real dsig,a0,a1,a2 integer, dimension(3) :: start,count - integer i,j,k,l,status,ncid,dimid,varid + integer i,j,kdmic,k,l,status,ncid,dimid,varid,kb + real iM_mks2cgs +c + iM_mks2cgs = 1.0 / M_mks2cgs c if (mnproc.eq.1) then write (lp,'(2a)') ' reading initial condition from ', @@ -158,13 +167,30 @@ subroutine ictsz_file call xchalt('(ictsz_file)') stop '(ictsz_file)' endif - if (i.ne.itdm.or.j.ne.jtdm) then + status=nf90_inq_dimid(ncid,'z',dimid) + if (status.ne.nf90_noerr) then + write(lp,'(2a)') ' nf90_inq_dimid: z: ',nf90_strerror(status) + call xchalt('(ictsz_file)') + stop '(ictsz_file)' + endif + status=nf90_inquire_dimension(ncid,dimid,len=kdmic) + if (status.ne.nf90_noerr) then + write(lp,'(2a)') ' nf90_inquire_dimension: z: ', + . nf90_strerror(status) + call xchalt('(ictsz_file)') + stop '(ictsz_file)' + endif + if (i.ne.itdm.or.j.ne.jtdm.or. + . (kdmic.ne.kdm.and.vcoord_type_tag.ne.cntiso_hybrid).or. + . (kdmic.gt.kdm.and.vcoord_type_tag.eq.cntiso_hybrid)) then write (lp,*) 'wrong dimensions in '//trim(icfile) call xchalt('(ictsz_file)') stop '(ictsz_file)' endif c endif +c + call xcbcst(kdmic) c start(1)=1 start(2)=1 @@ -182,7 +208,7 @@ subroutine ictsz_file stop '(ictsz_file)' endif endif - do k=1,kk + do k=1,kdmic if (mnproc.eq.1) then start(3)=k status=nf90_get_var(ncid,varid,tmp2d,start,count) @@ -206,7 +232,7 @@ subroutine ictsz_file stop '(ictsz_file)' endif endif - do k=1,kk + do k=1,kdmic if (mnproc.eq.1) then start(3)=k status=nf90_get_var(ncid,varid,tmp2d,start,count) @@ -230,7 +256,7 @@ subroutine ictsz_file stop '(ictsz_file)' endif endif - do k=1,kk + do k=1,kdmic if (mnproc.eq.1) then start(3)=k status=nf90_get_var(ncid,varid,tmp2d,start,count) @@ -253,7 +279,7 @@ subroutine ictsz_file stop '(ictsz_file)' endif endif - do k=1,kk + do k=1,kdmic if (mnproc.eq.1) then start(3)=k status=nf90_get_var(ncid,varid,tmp2d,start,count) @@ -275,6 +301,45 @@ subroutine ictsz_file stop '(ictsz_file)' endif endif +c + if (vcoord_type_tag.eq.cntiso_hybrid) then +c$OMP PARALLEL DO PRIVATE(l,i,k,kb,dsig,a0,a1,a2) + do j=1,jj + do l=1,isp(j) + do i=max(1,ifp(j,l)),min(ii,ilp(j,l)) + if (mnproc.eq.ptest.and.i.eq.itest.and.j.eq.jtest) then + write(lp,*) + .'Layer reference potential densities from initial condition:' + do k=1,kdmic + write(lp,*) k,sigmar(i,j,k) + enddo + endif + do k=kdmic,2,-1 + sigmar(i,j,k+kk-kdmic)=.5_r8*(sigmar(i,j,k-1) + . +sigmar(i,j,k )) + enddo + kb=kk-kdmic+2 + dsig=sigmar(i,j,kb+1)-sigmar(i,j,kb) + a0=1./(kb-1)**2 + a1=(dsig+(2.*sigmar(i,j,kb)-dsig*kb)*kb)*a0 + a2=(dsig*(kb-1)-sigmar(i,j,kb))*a0 + a0=-a1-a2 + do k=1,kb-1 + sigmar(i,j,k)=a0+(a1+a2*k)*k + enddo + if (mnproc.eq.ptest.and.i.eq.itest.and.j.eq.jtest) then + write(lp,*) + .'Generated interface reference potential densities:' + do k=1,kk + write(lp,*) k,sigmar(i,j,k) + enddo + endif + enddo + enddo + enddo +c$OMP END PARALLEL DO + + endif c c --- Construct interface depths [cm] from layer thicknesses [m] and c --- convert unit of reference potential density from [kg/m^3] to @@ -283,39 +348,49 @@ subroutine ictsz_file do j=1,jj do l=1,isp(j) do i=max(1,ifp(j,l)),min(ii,ilp(j,l)) -c z(i,j,1)=z(i,j,1)*1.e2 +c z(i,j,1)=z(i,j,1)*L_mks2cgs z(i,j,1)=0. enddo enddo enddo c$OMP END PARALLEL DO - do k=1,kk -c$OMP PARALLEL DO PRIVATE(l,i) - do j=1,jj +c$OMP PARALLEL DO PRIVATE(k,l,i) + do j=1,jj + do k=1,kdmic do l=1,isp(j) do i=max(1,ifp(j,l)),min(ii,ilp(j,l)) - z(i,j,k+1)=min(depths(i,j)*1.e2,z(i,j,k)+dz(i,j,k)*1.e2) - sigmar(i,j,k)=sigmar(i,j,k)*1.e-3 + z(i,j,k+1)=min(depths(i,j)*L_mks2cgs, + . z(i,j,k)+dz(i,j,k)*L_mks2cgs) + enddo + enddo + enddo + do k=kdmic+1,kk + do l=1,isp(j) + do i=max(1,ifp(j,l)),min(ii,ilp(j,l)) + z(i,j,k+1)=z(i,j,kdmic+1) enddo enddo enddo -c$OMP END PARALLEL DO - enddo -c$OMP PARALLEL DO PRIVATE(k,l,i) - do j=1,jj do k=2,kk do l=1,isp(j) do i=max(1,ifp(j,l)),min(ii,ilp(j,l)) - if (z(i,j,kk+1)-z(i,j,k).lt.1.e-4) - . z(i,j,k)=depths(i,j)*1.e2 + if (z(i,j,kk+1)-z(i,j,k).lt.1.e-6*L_mks2cgs) + . z(i,j,k)=depths(i,j)*L_mks2cgs 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)=depths(i,j)*1.e2 + z(i,j,kk+1)=depths(i,j)*L_mks2cgs enddo enddo + 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 + enddo + enddo + enddo enddo c$OMP END PARALLEL DO c @@ -396,39 +471,63 @@ subroutine inicon c --- variables consistent. c --- ------------------------------------------------------------------ c - do k=1,2 - tfrz(1:ii,1:jj)=swtfrz(p(1:ii,1:jj,1),saln(1:ii,1:jj,k)) + select case (vcoord_type_tag) + + case (isopyc_bulkml) + + do k=1,2 + tfrz(1:ii,1:jj)=swtfrz(p(1:ii,1:jj,1),saln(1:ii,1:jj,k)) c$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)) - temp(i,j,k+kk)=temp(i,j,k) - saln(i,j,k+kk)=saln(i,j,k) - sigma(i,j,k)=sig(temp(i,j,k),saln(i,j,k)) - sigma(i,j,k+kk)=sigma(i,j,k) - enddo - enddo - enddo + 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)) + enddo + enddo + enddo c$OMP END PARALLEL DO - enddo - do k=3,kk - tfrz(1:ii,1:jj)=swtfrz(p(1:ii,1:jj,1),saln(1:ii,1:jj,k)) -c$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)) - temp(i,j,k+kk)=temp(i,j,k) - saln(i,j,k+kk)=saln(i,j,k) - sigma(i,j,k)=sig(temp(i,j,k),saln(i,j,k)) - sigma(i,j,k+kk)=sigma(i,j,k) enddo + do k=3,kk + tfrz(1:ii,1:jj)=swtfrz(p(1:ii,1:jj,1),saln(1:ii,1:jj,k)) +c$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)) + enddo + enddo + enddo +c$OMP END PARALLEL DO enddo - enddo + + case (cntiso_hybrid) + + do k=1,kk + tfrz(1:ii,1:jj)=swtfrz(p(1:ii,1:jj,1),saln(1:ii,1:jj,k)) +c$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)) + enddo + enddo + enddo c$OMP END PARALLEL DO - enddo + enddo + + case default + + if (mnproc.eq.1) then + write (lp,*) 'inicon: unsupported vertical coordinate!' + endif + call xcstop('(inicon)') + stop '(inicon)' + + end select c if (mnproc.eq.ptest) then write (lp,'('' sigmar(k) :'',7f9.5/(15x,7f9.5))') @@ -459,8 +558,6 @@ subroutine inicon c call xctilr(p, 1,kk+1, 2,2, halo_ps) call xctilr(phi(1-nbdy,1-nbdy,kk+1), 1,1, 1,1, halo_ps) - call xctilr(temp, 1,kk, 1,1, halo_ps) - call xctilr(saln, 1,kk, 1,1, halo_ps) c c --- ------------------------------------------------------------------ c --- Set layer thickness and bottom pressure @@ -472,7 +569,6 @@ subroutine inicon do l=1,isp(j) do i=max(0,ifp(j,l)),min(ii+1,ilp(j,l)) dp(i,j,k)=p(i,j,k+1)-p(i,j,k) - dp(i,j,k+kk)=dp(i,j,k) enddo enddo enddo @@ -533,6 +629,7 @@ subroutine inicon dpu(i,j,k)= . .5*((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)))) + pu(i,j,k+1)=pu(i,j,k)+dpu(i,j,k) enddo enddo do l=1,isv(j) @@ -541,25 +638,39 @@ subroutine inicon dpv(i,j,k)= . .5*((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)))) + pv(i,j,k+1)=pv(i,j,k)+dpv(i,j,k) enddo enddo enddo enddo c$OMP END PARALLEL DO +c + if (vcoord_type_tag.eq.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) + endif + call xctilr(temp, 1,kk, 1,1, halo_ps) + call xctilr(saln, 1,kk, 1,1, halo_ps) c c$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)) + temp(i,j,k+kk)=temp(i,j,k) + saln(i,j,k+kk)=saln(i,j,k) + sigma(i,j,k+kk)=sigma(i,j,k) + dp(i,j,k+kk)=dp(i,j,k) + enddo + enddo do l=1,isu(j) do i=max(1,ifu(j,l)),min(ii,ilu(j,l)) dpu(i,j,k+kk)=dpu(i,j,k) - pu(i,j,k+1)=pu(i,j,k)+dpu(i,j,k) enddo enddo do l=1,isv(j) do i=max(1,ifv(j,l)),min(ii,ilv(j,l)) dpv(i,j,k+kk)=dpv(i,j,k) - pv(i,j,k+1)=pv(i,j,k)+dpv(i,j,k) enddo enddo enddo @@ -770,7 +881,7 @@ subroutine inicon do i=max(1,ifp(j,l)),min(ii,ilp(j,l)) k=3 dps=0. - do while (dp(i,j,k).lt.epsil) + do while (dp(i,j,k).lt.epsilp) dps=dps+dp(i,j,k) dp(i,j,k)=0. dp(i,j,k+kk)=0. @@ -814,7 +925,8 @@ subroutine inicon j=jtest write (lp,103) nstep,i0+i,j0+j, . ' init.profile temp saln dens thkns dpth', - . (k,temp(i,j,k),saln(i,j,k),1000.*sig(temp(i,j,k),saln(i,j,k)), + . (k,temp(i,j,k),saln(i,j,k), + . M_mks2cgs*sig(temp(i,j,k),saln(i,j,k)), . dp(i,j,k)/onem,p(i,j,k+1)/onem,k=1,kk) 103 format (i9,2i5,a/(28x,i3,3f8.2,2f8.1)) endif diff --git a/phy/mod_momtum.F b/phy/mod_momtum.F index ad98f07a..9eea25bf 100644 --- a/phy/mod_momtum.F +++ b/phy/mod_momtum.F @@ -1,6 +1,6 @@ ! ------------------------------------------------------------------------------ ! Copyright (C) 2000 HYCOM Consortium and contributors -! Copyright (C) 2001-2020 Mats Bentsen, Lars Inge Enstad, Mehmet Ilicak +! Copyright (C) 2001-2022 Mats Bentsen, Lars Inge Enstad, Mehmet Ilicak ! ! This file is part of BLOM. ! @@ -26,7 +26,8 @@ module mod_momtum c --- ------------------------------------------------------------------ c use mod_types, only: r8 - use mod_constants, only: g, alpha0, epsil, spval, onem, onemm + use mod_constants, only: g, alpha0, epsilp, epsilpl, spval, + . onem, onemm use mod_time, only: delt1, dlt use mod_xc use mod_grid, only: scqx, scqy, scpx, scpy, scux, scuy, @@ -276,14 +277,14 @@ subroutine momtum(m,n,mm,nn,k1m,k1n) c do i=max(0,ifp(j,l)),min(ii,ilp(j,l)) ubot=(ubflxs_p(i ,j,n) - . /max(epsil,pbu(i ,j,n)*scuy(i ,j)) + . /max(epsilpl,pbu(i ,j,n)*scuy(i ,j)) . +ubflxs_p(i+1,j,n) - . /max(epsil,pbu(i+1,j,n)*scuy(i+1,j)))*tsfac + . /max(epsilpl,pbu(i+1,j,n)*scuy(i+1,j)))*tsfac . +util1(i,j)/thkbop vbot=(vbflxs_p(i,j ,n) - . /max(epsil,pbv(i,j ,n)*scvx(i,j )) + . /max(epsilpl,pbv(i,j ,n)*scvx(i,j )) . +vbflxs_p(i,j+1,n) - . /max(epsil,pbv(i,j+1,n)*scvx(i,j+1)))*tsfac + . /max(epsilpl,pbv(i,j+1,n)*scvx(i,j+1)))*tsfac . +util2(i,j)/thkbop ubbl=.5*sqrt(ubot*ubot+vbot*vbot) q=cb*(ubbl+cbar) @@ -445,9 +446,9 @@ subroutine momtum(m,n,mm,nn,k1m,k1n) do l=1,isu(j) do i=max(0,ifu(j,l)),min(ii+2,ilu(j,l)) wgtja(i,j)=max(0.,min(1.,(pu(i,j,k+1)-pbu(i,j-1,m)) - . /max(pu(i,j,k+1)-pu(i,j,k),epsil))) + . /max(pu(i,j,k+1)-pu(i,j,k),epsilp))) wgtjb(i,j)=max(0.,min(1.,(pu(i,j,k+1)-pbu(i,j+1,m)) - . /max(pu(i,j,k+1)-pu(i,j,k),epsil))) + . /max(pu(i,j,k+1)-pu(i,j,k),epsilp))) uja(i,j)=(1.-wgtja(i,j))*utotn(i,j-1) . +wgtja(i,j)*slip*utotn(i,j) ujb(i,j)=(1.-wgtjb(i,j))*utotn(i,j+1) @@ -464,9 +465,9 @@ subroutine momtum(m,n,mm,nn,k1m,k1n) do l=1,isv(j) do i=max(-1,ifv(j,l)),min(ii+2,ilv(j,l)) wgtia(i,j)=max(0.,min(1.,(pv(i,j,k+1)-pbv(i-1,j,m)) - . /max(pv(i,j,k+1)-pv(i,j,k),epsil))) + . /max(pv(i,j,k+1)-pv(i,j,k),epsilp))) wgtib(i,j)=max(0.,min(1.,(pv(i,j,k+1)-pbv(i+1,j,m)) - . /max(pv(i,j,k+1)-pv(i,j,k),epsil))) + . /max(pv(i,j,k+1)-pv(i,j,k),epsilp))) via(i,j)=(1.-wgtia(i,j))*vtotn(i-1,j) . +wgtia(i,j)*slip*vtotn(i,j) vib(i,j)=(1.-wgtib(i,j))*vtotn(i+1,j) diff --git a/phy/mod_mxlayr.F b/phy/mod_mxlayr.F index d8ceaa3e..fa5ebffb 100644 --- a/phy/mod_mxlayr.F +++ b/phy/mod_mxlayr.F @@ -1,5 +1,5 @@ ! ------------------------------------------------------------------------------ -! Copyright (C) 2009-2020 Mats Bentsen, Mehmet Ilicak +! Copyright (C) 2009-2022 Mats Bentsen, Mehmet Ilicak ! ! This file is part of BLOM. ! @@ -25,11 +25,13 @@ module mod_mxlayr c --- ------------------------------------------------------------------ c use mod_types, only: r8 - use mod_constants, only: g, spcifh, alpha0, epsil, spval, onem, - . tencm, onecm, onemm + use mod_constants, only: g, spcifh, alpha0, epsilp, spval, onem, + . tencm, onecm, onemm, onemu, + . L_mks2cgs, R_mks2cgs use mod_time, only: delt1 use mod_xc - use mod_grid, only: sigmar, scp2, scuxi, scvyi, coriop + use mod_vcoord, only: sigmar + use mod_grid, only: scp2, scuxi, scvyi, coriop use mod_eos, only: rho, sig, sig0, dsigdt, dsigdt0, . dsigds, dsigds0, p_alpha,p_p_alpha use mod_state, only: u, v, dp, dpu, dpv, temp, saln, sigma, @@ -88,6 +90,11 @@ module mod_mxlayr . mtkeke, ! Mixed layer TKE tendency related to kin. ! energy change [cm3 s-3]. . pbrnda ! Brine plume pressure depth [g cm-1 s-2]. +c + real(r8), parameter :: + . iL_mks2cgs = 1./L_mks2cgs, + . A_cgs2mks = 1./(L_mks2cgs*L_mks2cgs), + . V_mks2cgs = L_mks2cgs**3 c public :: rm0,rm5,ce,mlrttp,mltmin, . mtkeus,mtkeni,mtkebf,mtkers,mtkepe,mtkeke,pbrnda, @@ -147,9 +154,6 @@ subroutine mxlayr(m,n,mm,nn,k1m,k1n) real, dimension(ntr) :: trfsl,trdps integer nt #endif -c - real onemu - parameter (onemu=.09806) c c --- Parameters for Oberhuber (1993) TKE closure: c --- mu - parameter for the decay of TKE generated by surface @@ -165,7 +169,8 @@ subroutine mxlayr(m,n,mm,nn,k1m,k1n) c --- of TKE balance []. real kappa,mu,ustmin,mldjmp integer maxitr - parameter (kappa=.4,mu=2.,ustmin=.1,mldjmp=1.e-6,maxitr=20) + parameter (kappa=.4,mu=2.,ustmin=.001*L_mks2cgs, + . mldjmp=1.e-3*R_mks2cgs,maxitr=20) c c --- Parameters for the parameterization of restratification by mixed c --- layer eddies by Fox-Kemper et al. (2008): @@ -177,12 +182,12 @@ subroutine mxlayr(m,n,mm,nn,k1m,k1n) c --- ci - constant that appears when integrating the shape c --- function over the mixed layer depth []. real rtau,cori20,rlf,ci,slbg0 - parameter (rtau=1./86400.,cori20=4.9745e-5,rlf=1./5.e5, - . ci=44./63.,slbg0=0.) + parameter (rtau=1./86400.,cori20=4.9745e-5, + . rlf=1./(5.e3*L_mks2cgs),ci=44./63.,slbg0=0.) c c --- Parameters for brine plume parameterization: c --- bpdrho - density contrast between surface and brine plume depth -c --- [g/cm/s**2]. +c --- [g/cm**3]. c --- bpmndp - minimum distribution thickness of salt from sea-ice c --- freezing [g/cm/s**2]. c --- bpmxdp - maximum distribution depth below the mixed layer base @@ -192,8 +197,8 @@ subroutine mxlayr(m,n,mm,nn,k1m,k1n) c --- dsgmnr - minimum ratio of linearized density jump to target c --- density jump across a layer interface []. real bpdrho,bpmndp,bpmxdp,bpdpmn,dsgmnr - parameter (bpdrho=.4e-3,bpmndp=10.*98060.,bpmxdp=500.*98060., - . bpdpmn=1.*98060.,dsgmnr=.1) + parameter (bpdrho=.4*R_mks2cgs,bpmndp=10.*onem, + . bpmxdp=500.*onem,bpdpmn=1.*onem,dsgmnr=.1) c c --- ------------------------------------------------------------------ c --- Resolve type of mixed layer restratification time scale. @@ -335,7 +340,7 @@ subroutine mxlayr(m,n,mm,nn,k1m,k1n) beta=alpha0*dsigds0(tmxl,smxl) bfltot=g*alpha0*(alfa*surflx(i,j)/spcifh . -beta*(salflx(i,j)-brnflx(i,j))) - buoyfl(i,j)=bfltot + buoyfl(i,j,1)=bfltot bflpsw=g*alpha0*alfa*swbgfc(i,j)*sswflx(i,j)/spcifh c pmxl=pres(3) @@ -420,7 +425,8 @@ subroutine mxlayr(m,n,mm,nn,k1m,k1n) tkew=mtkeus(i,j)+mtkeni(i,j)+mtkebf(i,j)+mtkers(i,j) if (.not.(nitr.eq.1.and.pres(3)*lbi.gt.1.)) then dtke=(tkew-tkeo)/dpmxl - if (abs(dtke)<(abs(tkew)+1.e-16)/(pres(3)-pres(1))) then + if (abs(dtke)<(abs(tkew)+1.e-22*V_mks2cgs) + . /(pres(3)-pres(1))) then if (tkew.lt.0.) then dpmxl=.5*(pres(1)-pmxl) else @@ -439,9 +445,9 @@ subroutine mxlayr(m,n,mm,nn,k1m,k1n) write (lp,*) 'dpth=',pres(3)/onem,';' write (lp,*) 'pmxl=',pmxl/onem,';' write (lp,*) 'corio=',coriop(i,j),';' - write (lp,*) 'ustar=',ustar(i,j)*1.e-2,';' - write (lp,*) 'bfltot=',bfltot*1.e-4,';' - write (lp,*) 'bflpsw=',bflpsw*1.e-4,';' + write (lp,*) 'ustar=',ustar(i,j)*iL_mks2cgs,';' + write (lp,*) 'bfltot=',bfltot*A_cgs2mks,';' + write (lp,*) 'bflpsw=',bflpsw*A_cgs2mks,';' write (lp,*) 'bg2=',util1(i,j),';' write (lp,*) 'ce=',ce*sqrt(scp2(i,j))*rlf,';' write (lp,*) @@ -514,7 +520,7 @@ subroutine mxlayr(m,n,mm,nn,k1m,k1n) c kmax=1 do k=2,kk - if (delp(k).gt.epsil) kmax=k + if (delp(k).gt.epsilp) kmax=k enddo kfmax=0 c @@ -591,7 +597,7 @@ subroutine mxlayr(m,n,mm,nn,k1m,k1n) bc(k)=0. endif kfmax=k - if (bdpsum.le.epsil) then + if (bdpsum.le.epsilp) then if (dpfsl.gt.onemu) then bpmldp=min(bpmndp,dpfsl+delp(2)) q=brnflx(i,j)*delt1*g/bpmldp @@ -639,7 +645,6 @@ subroutine mxlayr(m,n,mm,nn,k1m,k1n) do while (k.lt.kmax) if (delp(k).gt.onemu) then pswlo=swbgfc(i,j)*exp(-lei*min(pradd,pres(k+1))) - q=delt1*g/delp(k) ttem(k)=ttem(k)-(pswup-pswlo)*sswflx(i,j)*delt1*g . /(spcifh*delp(k)) pswup=pswlo @@ -733,7 +738,7 @@ subroutine mxlayr(m,n,mm,nn,k1m,k1n) endif else if (delp(k).gt.onemu.and.dens(k).gt.densr(k).and. - . sigfsl.lt.densr(k)-1.e-9) then + . sigfsl.lt.densr(k)-(1.e-6*R_mks2cgs)) then dps=min(dpfsl,delp(k)*(dens(k)-densr(k)) . /(densr(k)-sigfsl)) q=1./(dps+delp(k)) @@ -860,7 +865,7 @@ subroutine mxlayr(m,n,mm,nn,k1m,k1n) do if (k.gt.kk) then exit - elseif (delp(k).lt.epsil) then + elseif (delp(k).lt.epsilp) then k=k+1 else pmxl=pres(k+1) @@ -932,7 +937,7 @@ subroutine mxlayr(m,n,mm,nn,k1m,k1n) endif if (.not.chngd) then if (abs(dtke).lt. - . (abs(tkew)+1.e-16)/delp(k)) then + . (abs(tkew)+1.e-22*V_mks2cgs)/delp(k)) then if (tkew.lt.0.) then dpmxl=.5*(pres(k)-pmxl) else @@ -955,9 +960,9 @@ subroutine mxlayr(m,n,mm,nn,k1m,k1n) write (lp,*) 'dpth=',pres(3)/onem,';' write (lp,*) 'pmxl=',pmxl/onem,';' write (lp,*) 'corio=',coriop(i,j),';' - write (lp,*) 'ustar=',ustar(i,j)*1.e-2,';' - write (lp,*) 'bfltot=',bfltot*1.e-4,';' - write (lp,*) 'bflpsw=',bflpsw*1.e-4,';' + write (lp,*) 'ustar=',ustar(i,j)*iL_mks2cgs,';' + write (lp,*) 'bfltot=',bfltot*A_cgs2mks,';' + write (lp,*) 'bflpsw=',bflpsw*A_cgs2mks,';' write (lp,*) 'bg2=',util1(i,j),';' write (lp,*) 'ce=',ce*sqrt(scp2(i,j))*rlf,';' write (lp,*) 'pres(3)=',pres(3)/onem,';' @@ -975,7 +980,7 @@ subroutine mxlayr(m,n,mm,nn,k1m,k1n) c call xchalt('(mxlayr)') c stop '(mxlayr)' endif - if (pmxl.lt.pres(k+1)-epsil.and.nitr.lt.maxitr) then + if (pmxl.lt.pres(k+1)-epsilp.and.nitr.lt.maxitr) then tdps=tdps+ttem(k)*(pmxl-pres(k)) sdps=sdps+ssal(k)*(pmxl-pres(k)) #ifdef TRC @@ -1075,7 +1080,7 @@ subroutine mxlayr(m,n,mm,nn,k1m,k1n) c kmax=1 do k=2,kk - if (delp(k).gt.epsil) kmax=k + if (delp(k).gt.epsilp) kmax=k enddo kfmax=0 c @@ -1145,7 +1150,7 @@ subroutine mxlayr(m,n,mm,nn,k1m,k1n) bc(k)=0. endif kfmax=k - if (bdpsum.le.epsil) then + if (bdpsum.le.epsilp) then ssal(2)=ssal(2)-brnflx(i,j)*delt1*g/delp(2) else if (bdpsum.lt.bpmndp) then @@ -1174,7 +1179,6 @@ subroutine mxlayr(m,n,mm,nn,k1m,k1n) do while (k.lt.kmax) if (delp(k).gt.onemu) then pswlo=swbgfc(i,j)*exp(-lei*min(pradd,pres(k+1))) - q=delt1*g/delp(k) ttem(k)=ttem(k)-(pswup-pswlo)*sswflx(i,j)*delt1*g . /(spcifh*delp(k)) pswup=pswlo @@ -1210,7 +1214,7 @@ subroutine mxlayr(m,n,mm,nn,k1m,k1n) c --- --- Define first physical layer. k=3 dps=0. - do while (delp(k).lt.epsil) + do while (delp(k).lt.epsilp) dps=dps+delp(k) delp(k)=0. k=k+1 diff --git a/phy/mod_nctools.F b/phy/mod_nctools.F index 160becb5..dc27e695 100644 --- a/phy/mod_nctools.F +++ b/phy/mod_nctools.F @@ -1,5 +1,5 @@ ! ------------------------------------------------------------------------------ -! Copyright (C) 2004-2020 Ingo Bethke, Mats Bentsen, Alok Kumar Gupta +! Copyright (C) 2004-2022 Ingo Bethke, Mats Bentsen, Alok Kumar Gupta ! ! This file is part of BLOM. ! @@ -869,8 +869,7 @@ subroutine ncread(vnm,fld,msk,mskflg,fill) character*100 :: dimname integer :: i,j,ij,k,kd,n,ndm integer, parameter :: maxdm=5, ijdm=(idm+2*nbdy)*(jdm+2*nbdy) - integer ndims,dimids(maxdm),dimlen,strind(2,maxdm), - . msk(*),mskflg + integer ndims,dimids(maxdm),dimlen,msk(*),mskflg #ifdef PNETCDF integer(kind=MPI_OFFSET_KIND) tdimlen #endif diff --git a/phy/mod_ndiff.F90 b/phy/mod_ndiff.F90 new file mode 100644 index 00000000..d31b0f34 --- /dev/null +++ b/phy/mod_ndiff.F90 @@ -0,0 +1,1172 @@ +! ------------------------------------------------------------------------------ +! Copyright (C) 2022 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_ndiff +! ------------------------------------------------------------------------------ +! 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 + use mod_time, only: delt1 + use mod_xc + use mod_grid, only: scuy, scvx, scp2, scuxi, scvyi + use mod_eos, only: drhodt, drhods, rho + use mod_state, only: dp, temp, saln, utflx, vtflx, usflx, vsflx, pu, pv + use mod_diffusion, only: difiso, utflld, vtflld, usflld, vsflld + use mod_cmnfld, only: nslpx, nslpy + use mod_hor3map, only: recon_src_struct, extract_polycoeff, & + hor3map_noerr, hor3map_errstr +#ifdef TRC + use mod_tracers, only: ntr, trc +#endif + + implicit none + + private + + real(r8), parameter :: & + rhoeps = 1.e-5_r8*R_mks2cgs, & + dpeps = 1.e-5_r8*P_mks2cgs + integer, parameter :: & + p_ord = 4, & + it = 1, & + is = 2 + + integer :: ntr_loc + + real(r8), allocatable, dimension(:,:,:,:,:), target :: & + tpc_src_rs, t_srcdi_rs + real(r8), allocatable, dimension(:,:,:,:) :: flxconv_rs + real(r8), dimension(2,kdm,1-nbdy:idm+nbdy,2), target :: & + p_srcdi_rs, drhodt_srcdi_rs, drhods_srcdi_rs + integer, dimension(1-nbdy:idm+nbdy,2) :: ksmx_rs, kdmx_rs + + public :: ndiff_init, ndiff_prep_jslice, & + ndiff_uflx_jslice, ndiff_vflx_jslice, & + ndiff_update_trc_jslice + +contains + + ! --------------------------------------------------------------------------- + ! Private procedures. + ! --------------------------------------------------------------------------- + + pure function peval(pc, x) result(f) + + real(r8), dimension(:), intent(in) :: pc + real(r8), intent(in) :: x + + real(r8) :: f + + f = pc(1) + (pc(2) + (pc(3) + (pc(4) + pc(5)*x)*x)*x)*x + + end function peval + + 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 ipeval(pc, x0, x1) result(f) + + real(r8), dimension(:), intent(in) :: pc + real(r8), intent(in) :: x0, x1 + + real(r8) :: f + + real(r8), parameter :: & + c1_2 = 1._r8/2._r8, & + c1_3 = 1._r8/3._r8, & + c1_4 = 1._r8/4._r8, & + c1_5 = 1._r8/5._r8 + + f = ( pc(1) & + + ( c1_2*pc(2) & + + ( c1_3*pc(3) & + + ( c1_4*pc(4) & + + c1_5*pc(5)*x1)*x1)*x1)*x1)*x1 & + - ( pc(1) & + + ( c1_2*pc(2) & + + ( c1_3*pc(3) & + + ( c1_4*pc(4) & + + c1_5*pc(5)*x0)*x0)*x0)*x0)*x0 + + end function ipeval + + pure function drho(t1, s1, t2, s2, drhodt, drhods) result(dr) + + real(r8), intent(in) :: t1, s1, t2, s2, drhodt, drhods + + real(r8) :: dr + + dr = drhodt*(t2 - t1) + drhods*(s2 - s1) + + end function drho + + pure function drhoroot(tpc, spc, tf, sf, & + drhodt_l, drhodt_u, drhods_l, drhods_u) result(x) + + real(r8), dimension(:), intent(in) :: tpc, spc + real(r8), intent(in) :: tf, sf, drhodt_l, drhodt_u, drhods_l, drhods_u + + real(r8) :: x + + real(r8), parameter :: & + c1_2 = 1._r8/2._r8, & + c0 = 0._r8, & + c1 = 1._r8, & + c2 = 2._r8, & + c3 = 3._r8, & + c4 = 4._r8, & + eps = 1.e-14_r8, & + x_tol = 1.e-4_r8 + + real(r8) :: ddrdtdx, ddrdsdx, dt, ds, drdt, drds, dtdx, dsdx, dr, ddrdx, & + x_old + integer :: n + + x = c1_2 + ddrdtdx = drhodt_l - drhodt_u + ddrdsdx = drhods_l - drhods_u + + do n = 1, 10 + + dt = tf - (tpc(1) + (tpc(2) + (tpc(3) + (tpc(4) + tpc(5)*x)*x)*x)*x) + ds = sf - (spc(1) + (spc(2) + (spc(3) + (spc(4) + spc(5)*x)*x)*x)*x) + drdt = drhodt_l*x + drhodt_u*(c1 - x) + drds = drhods_l*x + drhods_u*(c1 - x) + dtdx = - (tpc(2) + (c2*tpc(3) + (c3*tpc(4) + c4*tpc(5)*x)*x)*x) + dsdx = - (spc(2) + (c2*spc(3) + (c3*spc(4) + c4*spc(5)*x)*x)*x) + + dr = drdt*dt + drds*ds + ddrdx = ddrdtdx*dt + drdt*dtdx + ddrdsdx*ds + drds*dsdx + + x_old = x + x = max(c0, min(c1, x_old - dr/sign(max(eps, abs(ddrdx)), ddrdx))) + if (abs(x - x_old) < x_tol) return + + enddo + + end function drhoroot + + subroutine ndiff_flx(p_srcdi_m, t_srcdi_m, tpc_src_m, & + drhodt_srcdi_m, drhods_srcdi_m, & + p_dst_m, ksmx_m, kdmx_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, uvtflld, uvsflld, uvtflx, uvsflx, & + nslpxy, & + i_m, j_m, i_p, j_p, j_rs_m, j_rs_p, mm, nn) + + real(r8), dimension(:,:), intent(in) :: & + p_srcdi_m, drhodt_srcdi_m, drhods_srcdi_m, & + p_srcdi_p, drhodt_srcdi_p, drhods_srcdi_p + real(r8), dimension(:,:,:), intent(in) :: & + t_srcdi_m, tpc_src_m, t_srcdi_p, tpc_src_p + real(r8), dimension(:), intent(in) :: & + p_dst_m, p_dst_p + real(r8), dimension(1-nbdy:,1-nbdy:,:), intent(in) :: & + puv + real(r8), dimension(1-nbdy:,1-nbdy:,:), intent(inout) :: & + uvtflld, uvsflld, uvtflx, uvsflx + real(r8), dimension(1-nbdy:,1-nbdy:,:), intent(out) :: & + nslpxy + real(r8), intent(in) :: cdiff, cnslp + integer, intent(in) :: & + ksmx_m, ksmx_p, kdmx_m, kdmx_p, i_m, j_m, i_p, j_p, j_rs_m, j_rs_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 + real(r8), dimension(ntr_loc,2) :: t_ni_m, t_ni_p + real(r8), dimension(ntr_loc) :: t_nl_m, t_nl_p + real(r8), dimension(2) :: x_ni_m, x_ni_p, p_ni_m, p_ni_p + real(r8) :: drho_curr, p_ni_m_prev, p_ni_p_prev, & + drhodt_x0, drhodt_x1, drhods_x0, drhods_x1, & + x, drho_prev, r_m, q_m, r_p, q_p, & + dp_ni_m, dp_ni_p, q, dt, ds, & + tflx, sflx, p_ni_up, p_ni_lo, dp_ni_i, mlfrac, p_nslp_dst + integer :: nns, is_m, is_p, ks_m, ks_p, ks_m_prev, ks_p_prev, & + kd_m, kd_p, isn_m, isn_p, ksn_m, ksn_p, & + nip, nic, kuv, case_m, case_p, nt, kuvm, kd, ks + logical, dimension(kk) :: stab_src_m, stab_src_p + logical :: drho_neg, drho_pos, drho_zero, & + advance_src_m, advance_src_p, advance_dst_m, advance_dst_p, & + found_ni + + real(r8), parameter :: mval = 1.e30_r8 + + ! ------------------------------------------------------------------------ + ! Search the source columns, starting from the surface, to identify + ! neutral interfaces anchored at layer interfaces. Store information + ! about whether layers are stably stratified with current reconstruction + ! and neutral slopes. + ! ------------------------------------------------------------------------ + + p_ni_srcdi_m(:,:) = mval + p_ni_srcdi_p(:,:) = mval + stab_src_m(:) = .false. + stab_src_p(:) = .false. + + nns = 0 + + is_m = 1 + ks_m = 1 + ks_p = 1 + is_p = 1 + drho_curr = drho(t_srcdi_m(is_m,ks_m,it), & + t_srcdi_m(is_m,ks_m,is), & + t_srcdi_p(is_p,ks_p,it), & + t_srcdi_p(is_p,ks_p,is), & + .5_r8*( drhodt_srcdi_m(is_m,ks_m) & + + drhodt_srcdi_p(is_p,ks_p)), & + .5_r8*( drhods_srcdi_m(is_m,ks_m) & + + drhods_srcdi_p(is_p,ks_p))) + p_ni_m_prev = p_srcdi_m(1,1) + p_ni_p_prev = p_srcdi_p(1,1) + + search_loop1: do + + drho_neg = drho_curr <= - rhoeps + drho_pos = drho_curr >= rhoeps + drho_zero = .not. (drho_neg .or. drho_pos) + + if (is_m + ks_m > 2 .and. is_p + ks_p > 2) then + if (drho_neg) then + if (is_m == 2) then + drhodt_x0 = .5_r8*( drhodt_srcdi_m(1 ,ks_m) & + + drhodt_srcdi_p(is_p,ks_p)) + drhodt_x1 = .5_r8*( drhodt_srcdi_m(2 ,ks_m) & + + drhodt_srcdi_p(is_p,ks_p)) + drhods_x0 = .5_r8*( drhods_srcdi_m(1 ,ks_m) & + + drhods_srcdi_p(is_p,ks_p)) + drhods_x1 = .5_r8*( drhods_srcdi_m(2 ,ks_m) & + + drhods_srcdi_p(is_p,ks_p)) + x = drhoroot(tpc_src_m(:,ks_m,it), tpc_src_m(:,ks_m,is), & + t_srcdi_p(is_p,ks_p,it), & + t_srcdi_p(is_p,ks_p,is), & + drhodt_x1, drhodt_x0, & + drhods_x1, drhods_x0) + p_ni_srcdi_p(is_p,ks_p) = p_srcdi_m(2,ks_m)*x & + + p_srcdi_m(1,ks_m)*(1._r8 - x) + if (p_ni_srcdi_p(is_p,ks_p) > p_ni_m_prev) then + p_ni_m_prev = p_ni_srcdi_p(is_p,ks_p) + nns = nns + 1 + nslp_src(nns) = - cnslp*( p_srcdi_p(is_p,ks_p) & + - p_ni_srcdi_p(is_p,ks_p)) + p_nslp_src(nns) = .5_r8*( p_srcdi_p(is_p,ks_p) & + + p_ni_srcdi_p(is_p,ks_p)) + else + p_ni_srcdi_p(is_p,ks_p) = mval + endif + endif + elseif (drho_pos) then + if (is_p == 2) then + drhodt_x0 = .5_r8*( drhodt_srcdi_m(is_m,ks_m) & + + drhodt_srcdi_p(1 ,ks_p)) + drhodt_x1 = .5_r8*( drhodt_srcdi_m(is_m,ks_m) & + + drhodt_srcdi_p(2 ,ks_p)) + drhods_x0 = .5_r8*( drhods_srcdi_m(is_m,ks_m) & + + drhods_srcdi_p(1 ,ks_p)) + drhods_x1 = .5_r8*( drhods_srcdi_m(is_m,ks_m) & + + drhods_srcdi_p(2 ,ks_p)) + x = drhoroot(tpc_src_p(:,ks_p,it), tpc_src_p(:,ks_p,is), & + t_srcdi_m(is_m,ks_m,it), & + t_srcdi_m(is_m,ks_m,is), & + drhodt_x1, drhodt_x0, & + drhods_x1, drhods_x0) + p_ni_srcdi_m(is_m,ks_m) = p_srcdi_p(2,ks_p)*x & + + p_srcdi_p(1,ks_p)*(1._r8 - x) + if (p_ni_srcdi_m(is_m,ks_m) > p_ni_p_prev) then + p_ni_p_prev = p_ni_srcdi_m(is_m,ks_m) + nns = nns + 1 + nslp_src(nns) = - cnslp*( p_ni_srcdi_m(is_m,ks_m) & + - p_srcdi_m(is_m,ks_m)) + p_nslp_src(nns) = .5_r8*( p_ni_srcdi_m(is_m,ks_m) & + + p_srcdi_m(is_m,ks_m)) + else + p_ni_srcdi_m(is_m,ks_m) = mval + endif + endif + else + p_ni_srcdi_p(is_p,ks_p) = p_srcdi_m(is_m,ks_m) + p_ni_srcdi_m(is_m,ks_m) = p_srcdi_p(is_p,ks_p) + nns = nns + 1 + nslp_src(nns) = - cnslp*( p_srcdi_p(is_p,ks_p) & + - p_srcdi_m(is_m,ks_m)) + p_nslp_src(nns) = .5_r8*( p_srcdi_p(is_p,ks_p) & + + p_srcdi_m(is_m,ks_m)) + endif + endif + + if (drho_zero .or. drho_pos) then + do + drho_prev = drho_curr + if (is_m == 1) then + is_m = 2 + else + ks_m = ks_m + 1 + if (ks_m > ksmx_m) exit search_loop1 + is_m = 1 + endif + drho_curr = drho(t_srcdi_m(is_m,ks_m,it), & + t_srcdi_m(is_m,ks_m,is), & + t_srcdi_p(is_p,ks_p,it), & + t_srcdi_p(is_p,ks_p,is), & + .5_r8*( drhodt_srcdi_m(is_m,ks_m) & + + drhodt_srcdi_p(is_p,ks_p)), & + .5_r8*( drhods_srcdi_m(is_m,ks_m) & + + drhods_srcdi_p(is_p,ks_p))) + if (drho_prev - drho_curr > rhoeps) then + if (is_m == 2 .and. & + p_srcdi_m(2,ks_m) - p_srcdi_m(1,ks_m) > onemm) & + stab_src_m(ks_m) = .true. + exit + endif + if (is_m == 1) then + p_ni_srcdi_m(is_m,ks_m) = p_ni_srcdi_m(2,ks_m-1) + endif + enddo + endif + + if (drho_zero .or. drho_neg) then + do + drho_prev = drho_curr + if (is_p == 1) then + is_p = 2 + else + ks_p = ks_p + 1 + if (ks_p > ksmx_p) exit search_loop1 + is_p = 1 + endif + drho_curr = drho(t_srcdi_m(is_m,ks_m,it), & + t_srcdi_m(is_m,ks_m,is), & + t_srcdi_p(is_p,ks_p,it), & + t_srcdi_p(is_p,ks_p,is), & + .5_r8*( drhodt_srcdi_m(is_m,ks_m) & + + drhodt_srcdi_p(is_p,ks_p)), & + .5_r8*( drhods_srcdi_m(is_m,ks_m) & + + drhods_srcdi_p(is_p,ks_p))) + if (drho_curr - drho_prev > rhoeps) then + if (is_p == 2 .and. & + p_srcdi_p(2,ks_p) - p_srcdi_p(1,ks_p) > onemm) & + stab_src_p(ks_p) = .true. + exit + endif + if (is_p == 1) then + p_ni_srcdi_p(is_p,ks_p) = p_ni_srcdi_p(2,ks_p-1) + endif + enddo + endif + + enddo search_loop1 + + ! ------------------------------------------------------------------------ + ! Do another search from the surface, this time including target + ! interfaces, to identify neutral layers and compute fluxes that are added + ! to a flux convergence for the target layers. + ! ------------------------------------------------------------------------ + + is_m = 2 + ks_m = 0 + is_p = 2 + ks_p = 0 + kd_m = 1 + kd_p = 1 + advance_src_m = .true. + advance_src_p = .true. + advance_dst_m = .false. + advance_dst_p = .false. + ks_m_prev = 0 + ks_p_prev = 0 + nip = 1 + nic = 2 + p_ni_m(nip) = - mval + p_ni_p(nip) = - mval + kuv = 1 + + search_loop2: do + + ! Advance source and destination interface indices as requested. When + ! source interfaces indices are advanced, keep seperate indices for + ! next interface and next interface that is anchoring a neutral + ! interface. + + if (advance_src_m) then + do + if (is_m == 1) then + is_m = 2 + if (stab_src_m(ks_m)) exit + else + ks_m = ks_m + 1 + if (ks_m > ksmx_m) exit search_loop2 + is_m = 1 + if (stab_src_m(ks_m) .and. p_ni_srcdi_m(is_m,ks_m) /= mval) & + exit + endif + enddo + isn_m = is_m + ksn_m = ks_m + do while (p_ni_srcdi_m(isn_m,ksn_m) == mval) + if (isn_m == 1) then + isn_m = 2 + else + if (ksn_m == ksmx_m) exit + ksn_m = ksn_m + 1 + isn_m = 1 + endif + enddo + endif + + if (advance_src_p) then + do + if (is_p == 1) then + is_p = 2 + if (stab_src_p(ks_p)) exit + else + ks_p = ks_p + 1 + if (ks_p > ksmx_p) exit search_loop2 + is_p = 1 + if (stab_src_p(ks_p) .and. p_ni_srcdi_p(is_p,ks_p) /= mval) & + exit + endif + enddo + isn_p = is_p + ksn_p = ks_p + do while (p_ni_srcdi_p(isn_p,ksn_p) == mval) + if (isn_p == 1) then + isn_p = 2 + else + if (ksn_p == ksmx_p) exit + ksn_p = ksn_p + 1 + isn_p = 1 + endif + enddo + endif + + if (advance_dst_m) then + kd_m = kd_m + 1 + if (kd_m > kdmx_m) exit search_loop2 + endif + + if (advance_dst_p) then + kd_p = kd_p + 1 + if (kd_p > kdmx_p) exit search_loop2 + endif + + do while (p_dst_m(kd_m+1) & + <= max(p_srcdi_m(1,ks_m), p_ni_m(nip))) + kd_m = kd_m + 1 + if (kd_m > kdmx_m) exit search_loop2 + enddo + + do while (p_dst_p(kd_p+1) & + <= max(p_srcdi_p(1,ks_p), p_ni_p(nip))) + kd_p = kd_p + 1 + if (kd_p > kdmx_p) exit search_loop2 + enddo + + advance_src_m = .false. + advance_src_p = .false. + advance_dst_m = .false. + advance_dst_p = .false. + + ! By considering current destination interface, source interface and + ! neutral interface anchored by the neighbour column, find which of + ! those are the shallowes for each column. Whichever interfaces are + ! minimums defines cases that are considered to find the next neutral + ! interface between the columns. + + case_m = minloc([p_srcdi_m(is_m,ks_m), & + p_ni_srcdi_p(isn_p,ksn_p), & + p_dst_m(kd_m+1)], dim = 1) + case_p = minloc([p_srcdi_p(is_p,ks_p), & + p_ni_srcdi_m(isn_m,ksn_m), & + p_dst_p(kd_p+1)], dim = 1) + + found_ni = .false. + + if (case_m == 3 .and. case_p == 3) then + + if (is_p == 2 .and. is_m == 2) then + x_ni_m(nic) = (p_dst_m(kd_m+1) - p_srcdi_m(1,ks_m)) & + /(p_srcdi_m(2,ks_m) - p_srcdi_m(1,ks_m)) + p_ni_m(nic) = p_dst_m(kd_m+1) + t_ni_m(it,nic) = peval(tpc_src_m(:,ks_m,it), x_ni_m(nic)) + t_ni_m(is,nic) = peval(tpc_src_m(:,ks_m,is), x_ni_m(nic)) + x_ni_p(nic) = (p_dst_p(kd_p+1) - p_srcdi_p(1,ks_p)) & + /(p_srcdi_p(2,ks_p) - p_srcdi_p(1,ks_p)) + p_ni_p(nic) = p_dst_p(kd_p+1) + t_ni_p(it,nic) = peval(tpc_src_p(:,ks_p,it), x_ni_p(nic)) + t_ni_p(is,nic) = peval(tpc_src_p(:,ks_p,is), x_ni_p(nic)) + r_m = x_ni_m(nic) + q_m = 1._r8 - r_m + r_p = x_ni_p(nic) + q_p = 1._r8 - r_p + drho_curr = drho(t_ni_m(it,nic), t_ni_m(is,nic), & + t_ni_p(it,nic), t_ni_p(is,nic), & + .5_r8*( drhodt_srcdi_m(1,ks_m)*q_m & + + drhodt_srcdi_m(2,ks_m)*r_m & + + drhodt_srcdi_p(1,ks_p)*q_p & + + drhodt_srcdi_p(2,ks_p)*r_p), & + .5_r8*( drhods_srcdi_m(1,ks_m)*q_m & + + drhods_srcdi_m(2,ks_m)*r_m & + + drhods_srcdi_p(1,ks_p)*q_p & + + drhods_srcdi_p(2,ks_p)*r_p)) + if (drho_curr <= - rhoeps) then + drhodt_x0 = .5_r8*( drhodt_srcdi_m(1,ks_m) & + + drhodt_srcdi_p(1,ks_p)*q_p & + + drhodt_srcdi_p(2,ks_p)*r_p) + drhodt_x1 = .5_r8*( drhodt_srcdi_m(2,ks_m) & + + drhodt_srcdi_p(1,ks_p)*q_p & + + drhodt_srcdi_p(2,ks_p)*r_p) + drhods_x0 = .5_r8*( drhods_srcdi_m(1,ks_m) & + + drhods_srcdi_p(1,ks_p)*q_p & + + drhods_srcdi_p(2,ks_p)*r_p) + drhods_x1 = .5_r8*( drhods_srcdi_m(2,ks_m) & + + drhods_srcdi_p(1,ks_p)*q_p & + + drhods_srcdi_p(2,ks_p)*r_p) + x = drhoroot(tpc_src_m(:,ks_m,it), tpc_src_m(:,ks_m,is), & + t_ni_p(it,nic), t_ni_p(is,nic), & + drhodt_x1, drhodt_x0, drhods_x1, drhods_x0) + p_ni_m(nic) = p_srcdi_m(2,ks_m)*x & + + p_srcdi_m(1,ks_m)*(1._r8 - x) + if (p_ni_m(nic) > p_ni_m(nip) .and. & + p_ni_m(nic) < p_ni_srcdi_p(isn_p,ksn_p)) then + x_ni_m(nic) = x + do nt = 1, ntr_loc + t_ni_m(nt,nic) = peval(tpc_src_m(:,ks_m,nt), & + x_ni_m(nic)) + enddo + do nt = 3, ntr_loc + t_ni_p(nt,nic) = peval(tpc_src_p(:,ks_p,nt), & + x_ni_p(nic)) + enddo + found_ni = .true. + endif + advance_dst_p = .true. + elseif (drho_curr >= rhoeps) then + drhodt_x0 = .5_r8*( drhodt_srcdi_p(1,ks_p) & + + drhodt_srcdi_m(1,ks_m)*q_m & + + drhodt_srcdi_m(2,ks_m)*r_m) + drhodt_x1 = .5_r8*( drhodt_srcdi_p(2,ks_p) & + + drhodt_srcdi_m(1,ks_m)*q_m & + + drhodt_srcdi_m(2,ks_m)*r_m) + drhods_x0 = .5_r8*( drhods_srcdi_p(1,ks_p) & + + drhods_srcdi_m(1,ks_m)*q_m & + + drhods_srcdi_m(2,ks_m)*r_m) + drhods_x1 = .5_r8*( drhods_srcdi_p(2,ks_p) & + + drhods_srcdi_m(1,ks_m)*q_m & + + drhods_srcdi_m(2,ks_m)*r_m) + x = drhoroot(tpc_src_p(:,ks_p,it), tpc_src_p(:,ks_p,is), & + t_ni_m(it,nic), t_ni_m(is,nic), & + drhodt_x1, drhodt_x0, drhods_x1, drhods_x0) + p_ni_p(nic) = p_srcdi_p(2,ks_p)*x & + + p_srcdi_p(1,ks_p)*(1._r8 - x) + if (p_ni_p(nic) > p_ni_p(nip) .and. & + p_ni_p(nic) < p_ni_srcdi_m(isn_m,ksn_m)) then + x_ni_p(nic) = x + do nt = 1, ntr_loc + t_ni_p(nt,nic) = peval(tpc_src_p(:,ks_p,nt), & + x_ni_p(nic)) + enddo + do nt = 3, ntr_loc + t_ni_m(nt,nic) = peval(tpc_src_m(:,ks_m,nt), & + x_ni_m(nic)) + enddo + found_ni = .true. + endif + advance_dst_m = .true. + else + do nt = 3, ntr_loc + t_ni_m(nt,nic) = peval(tpc_src_m(:,ks_m,nt), x_ni_m(nic)) + t_ni_p(nt,nic) = peval(tpc_src_p(:,ks_p,nt), x_ni_p(nic)) + enddo + found_ni = .true. + advance_dst_m = .true. + advance_dst_p = .true. + endif + else + if (is_p /= 2) advance_dst_m = .true. + if (is_m /= 2) advance_dst_p = .true. + endif + + elseif (case_m == 3) then + + if (is_p == 2) then + x_ni_m(nic) = (p_dst_m(kd_m+1) - p_srcdi_m(1,ks_m)) & + /(p_srcdi_m(2,ks_m) - p_srcdi_m(1,ks_m)) + p_ni_m(nic) = p_dst_m(kd_m+1) + t_ni_m(it,nic) = peval(tpc_src_m(:,ks_m,it), x_ni_m(nic)) + t_ni_m(is,nic) = peval(tpc_src_m(:,ks_m,is), x_ni_m(nic)) + r_m = x_ni_m(nic) + q_m = 1._r8 - r_m + drhodt_x0 = .5_r8*( drhodt_srcdi_p(1,ks_p) & + + drhodt_srcdi_m(1,ks_m)*q_m & + + drhodt_srcdi_m(2,ks_m)*r_m) + drhodt_x1 = .5_r8*( drhodt_srcdi_p(2,ks_p) & + + drhodt_srcdi_m(1,ks_m)*q_m & + + drhodt_srcdi_m(2,ks_m)*r_m) + drhods_x0 = .5_r8*( drhods_srcdi_p(1,ks_p) & + + drhods_srcdi_m(1,ks_m)*q_m & + + drhods_srcdi_m(2,ks_m)*r_m) + drhods_x1 = .5_r8*( drhods_srcdi_p(2,ks_p) & + + drhods_srcdi_m(1,ks_m)*q_m & + + drhods_srcdi_m(2,ks_m)*r_m) + x = drhoroot(tpc_src_p(:,ks_p,it), tpc_src_p(:,ks_p,is), & + t_ni_m(it,nic), t_ni_m(is,nic), & + drhodt_x1, drhodt_x0, drhods_x1, drhods_x0) + p_ni_p(nic) = p_srcdi_p(2,ks_p)*x & + + p_srcdi_p(1,ks_p)*(1._r8 - x) + if (p_ni_p(nic) > p_ni_p(nip) .and. & + p_ni_p(nic) < p_ni_srcdi_m(isn_m,ksn_m)) then + x_ni_p(nic) = x + do nt = 1, ntr_loc + t_ni_p(nt,nic) = peval(tpc_src_p(:,ks_p,nt), x_ni_p(nic)) + enddo + do nt = 3, ntr_loc + t_ni_m(nt,nic) = peval(tpc_src_m(:,ks_m,nt), x_ni_m(nic)) + enddo + found_ni = .true. + advance_dst_m = .true. + else + if (case_p == 1 .and. p_ni_srcdi_p(is_p,ks_p) == mval) then + advance_src_p = .true. + else + advance_dst_m = .true. + endif + endif + else + advance_dst_m = .true. + endif + + elseif (case_p == 3) then + + if (is_m == 2) then + x_ni_p(nic) = (p_dst_p(kd_p+1) - p_srcdi_p(1,ks_p)) & + /(p_srcdi_p(2,ks_p) - p_srcdi_p(1,ks_p)) + p_ni_p(nic) = p_dst_p(kd_p+1) + t_ni_p(it,nic) = peval(tpc_src_p(:,ks_p,it), x_ni_p(nic)) + t_ni_p(is,nic) = peval(tpc_src_p(:,ks_p,is), x_ni_p(nic)) + r_p = x_ni_p(nic) + q_p = 1._r8 - r_p + drhodt_x0 = .5_r8*( drhodt_srcdi_m(1,ks_m) & + + drhodt_srcdi_p(1,ks_p)*q_p & + + drhodt_srcdi_p(2,ks_p)*r_p) + drhodt_x1 = .5_r8*( drhodt_srcdi_m(2,ks_m) & + + drhodt_srcdi_p(1,ks_p)*q_p & + + drhodt_srcdi_p(2,ks_p)*r_p) + drhods_x0 = .5_r8*( drhods_srcdi_m(1,ks_m) & + + drhods_srcdi_p(1,ks_p)*q_p & + + drhods_srcdi_p(2,ks_p)*r_p) + drhods_x1 = .5_r8*( drhods_srcdi_m(2,ks_m) & + + drhods_srcdi_p(1,ks_p)*q_p & + + drhods_srcdi_p(2,ks_p)*r_p) + x = drhoroot(tpc_src_m(:,ks_m,it), tpc_src_m(:,ks_m,is), & + t_ni_p(it,nic), t_ni_p(is,nic), & + drhodt_x1, drhodt_x0, drhods_x1, drhods_x0) + p_ni_m(nic) = p_srcdi_m(2,ks_m)*x & + + p_srcdi_m(1,ks_m)*(1._r8 - x) + if (p_ni_m(nic) > p_ni_m(nip) .and. & + p_ni_m(nic) < p_ni_srcdi_p(isn_p,ksn_p)) then + x_ni_m(nic) = x + do nt = 1, ntr_loc + t_ni_m(nt,nic) = peval(tpc_src_m(:,ks_m,nt), x_ni_m(nic)) + enddo + do nt = 3, ntr_loc + t_ni_p(nt,nic) = peval(tpc_src_p(:,ks_p,nt), x_ni_p(nic)) + enddo + found_ni = .true. + advance_dst_p = .true. + else + if (case_m == 1 .and. p_ni_srcdi_m(is_m,ks_m) == mval) then + advance_src_m = .true. + else + advance_dst_p = .true. + endif + endif + else + advance_dst_p = .true. + endif + + elseif (case_m == 1 .and. case_p == 1) then + + if (p_ni_srcdi_m(is_m,ks_m) /= mval .and. & + p_ni_srcdi_p(is_p,ks_p) /= mval) then + x_ni_m(nic) = real(is_m - 1, r8) + p_ni_m(nic) = p_srcdi_m(is_m,ks_m) + x_ni_p(nic) = real(is_p - 1, r8) + p_ni_p(nic) = p_srcdi_p(is_p,ks_p) + do nt = 1, ntr_loc + t_ni_m(nt,nic) = t_srcdi_m(is_m,ks_m,nt) + t_ni_p(nt,nic) = t_srcdi_p(is_p,ks_p,nt) + enddo + found_ni = .true. + advance_src_m = .true. + advance_src_p = .true. + else + if (p_ni_srcdi_m(is_m,ks_m) == mval) advance_src_m = .true. + if (p_ni_srcdi_p(is_p,ks_p) == mval) advance_src_p = .true. + endif + + elseif (case_m == 1) then + + if (p_ni_srcdi_m(is_m,ks_m) /= mval .and. & + p_ni_srcdi_m(is_m,ks_m) >= p_srcdi_p(1,ks_p)) then + x_ni_m(nic) = real(is_m - 1, r8) + p_ni_m(nic) = p_srcdi_m(is_m,ks_m) + p_ni_p(nic) = p_ni_srcdi_m(is_m,ks_m) + x_ni_p(nic) = (p_ni_p(nic) - p_srcdi_p(1,ks_p)) & + /(p_srcdi_p(2,ks_p) - p_srcdi_p(1,ks_p)) + do nt = 1, ntr_loc + t_ni_m(nt,nic) = t_srcdi_m(is_m,ks_m,nt) + t_ni_p(nt,nic) = peval(tpc_src_p(:,ks_p,nt), x_ni_p(nic)) + enddo + found_ni = .true. + endif + advance_src_m = .true. + + elseif (case_p == 1) then + + if (p_ni_srcdi_p(is_p,ks_p) /= mval .and. & + p_ni_srcdi_p(is_p,ks_p) >= p_srcdi_m(1,ks_m)) then + x_ni_p(nic) = real(is_p - 1, r8) + p_ni_p(nic) = p_srcdi_p(is_p,ks_p) + p_ni_m(nic) = p_ni_srcdi_p(is_p,ks_p) + x_ni_m(nic) = (p_ni_m(nic) - p_srcdi_m(1,ks_m)) & + /(p_srcdi_m(2,ks_m) - p_srcdi_m(1,ks_m)) + do nt = 1, ntr_loc + t_ni_p(nt,nic) = t_srcdi_p(is_p,ks_p,nt) + t_ni_m(nt,nic) = peval(tpc_src_m(:,ks_m,nt), x_ni_m(nic)) + enddo + found_ni = .true. + endif + advance_src_p = .true. + + else + write(lp,*) 'Unexpected case_m == 2 and case_p == 2!' + call xchalt('(ndiff_flx)') + stop '(ndiff_flx)' + endif + + if (found_ni) then + + ! if a neutral interface is found, check whether the current and + ! previous neutral interfaces are between same source and + ! destination layers. If so, a neutral layer, suitable for diffusive + ! flux computations, has been found. + if (ks_m == ks_m_prev .and. ks_p == ks_p_prev .and. & + p_ni_m(nip) >= p_dst_m(kd_m) .and. & + p_ni_m(nic) <= p_dst_m(kd_m+1) .and. & + p_ni_p(nip) >= p_dst_p(kd_p) .and. & + p_ni_p(nic) <= p_dst_p(kd_p+1)) then + + if (x_ni_m(nic) - x_ni_m(nip) < 1.e-12_r8) then + do nt = 1, ntr_loc + t_nl_m(nt) = t_ni_m(nt,nic) + enddo + else + q = 1._r8/(x_ni_m(nic) - x_ni_m(nip)) + do nt = 1, ntr_loc + t_nl_m(nt) = ipeval(tpc_src_m(:,ks_m,nt), & + x_ni_m(nip), x_ni_m(nic))*q + enddo + endif + if (x_ni_p(nic) - x_ni_p(nip) < 1.e-12_r8) then + do nt = 1, ntr_loc + t_nl_p(nt) = t_ni_p(nt,nic) + enddo + else + q = 1._r8/(x_ni_p(nic) - x_ni_p(nip)) + do nt = 1, ntr_loc + t_nl_p(nt) = ipeval(tpc_src_p(:,ks_p,nt), & + x_ni_p(nip), x_ni_p(nic))*q + enddo + endif + + dp_ni_m = p_ni_m(nic) - p_ni_m(nip) + dp_ni_p = p_ni_p(nic) - p_ni_p(nip) + + q = cdiff*(difiso(i_m,j_m,ks_m) + difiso(i_p,j_p,ks_p)) & + *dp_ni_m*dp_ni_p/max(dp_ni_m + dp_ni_p, 2._r8*dpeps) + + dt = t_nl_m(it) - t_nl_p(it) + ds = t_nl_m(is) - t_nl_p(is) + + if (dt*( temp(i_m,j_m,ks_m+nn) & + - temp(i_p,j_p,ks_p+nn)) >= 0._r8 .and. & + dt*( t_ni_m(it,nip) - t_ni_p(it,nip)) >= 0._r8 .and. & + dt*( t_ni_m(it,nic) - t_ni_p(it,nic)) >= 0._r8 .and. & + ds*( saln(i_m,j_m,ks_m+nn) & + - saln(i_p,j_p,ks_p+nn)) >= 0._r8 .and. & + 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 + 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 + 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) + do while (kuv <= kk) + kuvm = kuv + mm + if (puv(i_p,j_p,kuv+1) < p_ni_lo) then + mlfrac = max(0._r8, puv(i_p,j_p,kuv+1) & + - max(p_ni_up, puv(i_p,j_p,kuv))) & + *dp_ni_i + uvtflld(i_p,j_p,kuvm) = uvtflld(i_p,j_p,kuvm) & + + tflx*mlfrac + uvsflld(i_p,j_p,kuvm) = uvsflld(i_p,j_p,kuvm) & + + sflx*mlfrac + uvtflx(i_p,j_p,kuvm) = uvtflx(i_p,j_p,kuvm) + tflx*mlfrac + uvsflx(i_p,j_p,kuvm) = uvsflx(i_p,j_p,kuvm) + sflx*mlfrac + kuv = kuv + 1 + else + mlfrac = (p_ni_lo - max(p_ni_up, puv(i_p,j_p,kuv))) & + *dp_ni_i + uvtflld(i_p,j_p,kuvm) = uvtflld(i_p,j_p,kuvm) & + + tflx*mlfrac + uvsflld(i_p,j_p,kuvm) = uvsflld(i_p,j_p,kuvm) & + + sflx*mlfrac + uvtflx(i_p,j_p,kuvm) = uvtflx(i_p,j_p,kuvm) + tflx*mlfrac + uvsflx(i_p,j_p,kuvm) = uvsflx(i_p,j_p,kuvm) + sflx*mlfrac + exit + endif + enddo + endif + +#ifdef TRC + 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 +#endif + + endif + + ks_m_prev = ks_m + ks_p_prev = ks_p + nip = 3 - nip + nic = 3 - nic + + endif + + enddo search_loop2 + + ! Linearly interpolate the neutral slope estimates from the source data to + ! destination interfaces. + if (nns == 0) then + nslpxy(i_p,j_p,:) = 0._r8 + else + do kd = 1, kk + p_nslp_dst = .5_r8*(p_dst_m(kd) + p_dst_p(kd)) + if (p_nslp_dst > p_nslp_src(1)) exit + nslpxy(i_p,j_p,kd) = nslp_src(1) + enddo + ks = 1 + interp_loop: do + do while (p_nslp_dst > p_nslp_src(ks)) + if (ks == nns) exit interp_loop + ks = ks + 1 + enddo + q = (p_nslp_src(ks) - p_nslp_dst) & + /max(p_nslp_src(ks) - p_nslp_src(ks-1), epsilp) + nslpxy(i_p,j_p,kd) = q*nslp_src(ks-1) + (1._r8 - q)*nslp_src(ks) + kd = kd + 1 + if (kd > kk) exit + p_nslp_dst = .5_r8*(p_dst_m(kd) + p_dst_p(kd)) + enddo interp_loop + do kd = kd, kk + nslpxy(i_p,j_p,kd) = nslp_src(nns) + enddo + endif + + end subroutine ndiff_flx + + ! --------------------------------------------------------------------------- + ! Public procedures. + ! --------------------------------------------------------------------------- + + subroutine ndiff_init + + integer :: errstat + +#ifdef TRC + ! 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 +#endif + + ! Allocate arrays depending on the tracer count. + allocate(tpc_src_rs(p_ord+1,kdm,ntr_loc,1-nbdy:idm+nbdy,2), & + t_srcdi_rs(2,kdm,ntr_loc,1-nbdy:idm+nbdy,2), & + flxconv_rs(kdm,ntr_loc,1-nbdy:idm+nbdy,2), & + stat = errstat) + if (errstat /= 0) then + write(lp,*) 'Failed to allocate neutral diffusion arrays!' + call xchalt('(ndiff_init)') + stop '(ndiff_init)' + endif + + end subroutine ndiff_init + + subroutine ndiff_prep_jslice(p_src_rs, p_dst_rs, trc_rcss, & + i_lb, i_ub, j, j_rs, mm) + + real(r8), dimension(:,1-nbdy:,:), intent(in) :: p_src_rs, p_dst_rs + type(recon_src_struct) , dimension(:), intent(inout) :: trc_rcss + integer, intent(in) :: i_lb, i_ub, j, j_rs, 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)) + + ! Extract polynomial coefficients of the reconstructions. + do nt = 1, ntr_loc + errstat = extract_polycoeff(trc_rcss(nt), & + tpc_src_rs(:,:,nt,i,j_rs), i, j_rs) + if (errstat /= hor3map_noerr) then + write(lp,*) trim(hor3map_errstr(errstat)) + call xchalt('(ndiff_prep_jslice)') + stop '(ndiff_prep_jslice)' + endif + enddo + + ! Find index of deepest source layer with non-zero thickness. + ksmx_rs(i,j_rs) = kk + do k = kk, 1, -1 + if (p_src_rs(k,i,j_rs) == p_src_rs(kk+1,i,j_rs)) & + ksmx_rs(i,j_rs) = k - 1 + enddo + + ! Find index of deepest destination layer with non-zero thickness. + kdmx_rs(i,j_rs) = 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 + 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) + do nt = 1, ntr_loc + t_srcdi_rs(1,k,nt,i,j_rs) = peval0(tpc_src_rs(:,k,nt,i,j_rs)) + t_srcdi_rs(2,k,nt,i,j_rs) = peval1(tpc_src_rs(:,k,nt,i,j_rs)) + enddo + 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)) + enddo + + flxconv_rs(:,:,i,j_rs) = 0._r8 + + enddo + enddo + + 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)) + 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)) + vtflld(i,j,km) = 0._r8 + vsflld(i,j,km) = 0._r8 + enddo + enddo + enddo + + end subroutine ndiff_prep_jslice + + subroutine ndiff_uflx_jslice(p_dst_rs, i_lb, i_ub, j, j_rs, mm, nn) + + real(r8), dimension(:,1-nbdy:,:), target, intent(in) :: p_dst_rs + integer, intent(in) :: i_lb, i_ub, j, j_rs, mm, nn + + real(r8), dimension(:,:,:), pointer :: & + t_srcdi_m, tpc_src_m, t_srcdi_p, tpc_src_p + real(r8), dimension(:,:), pointer :: & + p_srcdi_m, drhodt_srcdi_m, drhods_srcdi_m, p_srcdi_p, drhodt_srcdi_p, drhods_srcdi_p + real(r8), dimension(:), pointer :: & + p_dst_m, p_dst_p + real(r8) :: cdiff, cnslp + 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) + cdiff = delt1*scuy(i,j)*scuxi(i,j) + cnslp = alpha0*scuxi(i,j)/g + + call ndiff_flx(p_srcdi_m, t_srcdi_m, tpc_src_m, & + drhodt_srcdi_m, drhods_srcdi_m, & + p_dst_m, ksmx_m, kdmx_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, pu, utflld, usflld, utflx, usflx, nslpx, & + i-1, j, i, j, j_rs, j_rs, mm, nn) + + enddo + enddo + + end subroutine ndiff_uflx_jslice + + subroutine ndiff_vflx_jslice(p_dst_rs, i_lb, i_ub, j, j_rs, mm, nn) + + real(r8), dimension(:,1-nbdy:,:), target, intent(in) :: p_dst_rs + integer, intent(in) :: i_lb, i_ub, j, j_rs, mm, nn + + real(r8), dimension(:,:,:), pointer :: & + t_srcdi_m, tpc_src_m, t_srcdi_p, tpc_src_p + real(r8), dimension(:,:), pointer :: & + p_srcdi_m, drhodt_srcdi_m, drhods_srcdi_m, p_srcdi_p, drhodt_srcdi_p, drhods_srcdi_p + real(r8), dimension(:), pointer :: & + p_dst_m, p_dst_p + real(r8) :: cdiff, cnslp + integer :: j_rs_m, l, i, ksmx_m, ksmx_p, kdmx_m, kdmx_p + + j_rs_m = 3 - j_rs + + 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 ) + t_srcdi_m => t_srcdi_rs(:,:,:,i,j_rs_m) + t_srcdi_p => t_srcdi_rs(:,:,:,i,j_rs ) + tpc_src_m => tpc_src_rs(:,:,:,i,j_rs_m) + tpc_src_p => tpc_src_rs(:,:,:,i,j_rs ) + drhodt_srcdi_m => drhodt_srcdi_rs(:,:,i,j_rs_m) + drhodt_srcdi_p => drhodt_srcdi_rs(:,:,i,j_rs ) + drhods_srcdi_m => drhods_srcdi_rs(:,:,i,j_rs_m) + drhods_srcdi_p => drhods_srcdi_rs(:,:,i,j_rs ) + p_dst_m => p_dst_rs(:,i,j_rs_m) + p_dst_p => p_dst_rs(:,i,j_rs ) + ksmx_m = ksmx_rs(i,j_rs_m) + ksmx_p = ksmx_rs(i,j_rs ) + kdmx_m = kdmx_rs(i,j_rs_m) + kdmx_p = kdmx_rs(i,j_rs ) + cdiff = delt1*scvx(i,j)*scvyi(i,j) + cnslp = alpha0*scvyi(i,j)/g + + call ndiff_flx(p_srcdi_m, t_srcdi_m, tpc_src_m, & + drhodt_srcdi_m, drhods_srcdi_m, & + p_dst_m, ksmx_m, kdmx_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, pv, vtflld, vsflld, vtflx, vsflx, nslpy, & + i, j-1, i, j, j_rs_m, j_rs, mm, nn) + + enddo + enddo + + end subroutine ndiff_vflx_jslice + + subroutine ndiff_update_trc_jslice(p_dst_rs, trc_rm, i_lb, i_ub, j, j_rs) + + real(r8), dimension(:,1-nbdy:,:), intent(in) :: p_dst_rs + real(r8), dimension(:,:,1-nbdy:), intent(inout) :: trc_rm + integer, intent(in) :: i_lb, i_ub, j, j_rs + + 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 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), dpeps)) + do nt = 1, ntr_loc + trc_rm(k,nt,i) = trc_rm(k,nt,i) - q*flxconv_rs(k,nt,i,j_rs) + enddo + enddo + enddo + enddo + + end subroutine ndiff_update_trc_jslice + +end module mod_ndiff diff --git a/phy/mod_pbcor.F b/phy/mod_pbcor.F index 3a350abb..b0d84df6 100644 --- a/phy/mod_pbcor.F +++ b/phy/mod_pbcor.F @@ -1,5 +1,5 @@ ! ------------------------------------------------------------------------------ -! Copyright (C) 2005-2020 Mats Bentsen, Mehmet Ilicak +! Copyright (C) 2005-2022 Mats Bentsen, Mehmet Ilicak ! ! This file is part of BLOM. ! @@ -27,7 +27,7 @@ module mod_pbcor c --- ------------------------------------------------------------------ c use mod_types, only: r8 - use mod_constants, only: epsil + use mod_constants, only: epsilp, P_mks2cgs use mod_time, only: dlt use mod_xc use mod_grid, only: scp2i @@ -54,10 +54,10 @@ module mod_pbcor c c --- Parameters: real(r8), parameter :: - . dpeps1 = 1.e-4_r8, ! Small layer pressure thickness - ! [g cm-1 s-2]. - . dpeps2 = 1.e-6_r8 ! Small layer pressure thickness - ! [g cm-1 s-2]. + . dpeps1 = 1.e-5_r8*P_mks2cgs, ! Small layer pressure thickness + ! [g cm-1 s-2]. + . dpeps2 = 1.e-7_r8*P_mks2cgs ! Small layer pressure thickness + ! [g cm-1 s-2]. c public :: bmcmth, pbcor1, pbcor2 c @@ -459,7 +459,7 @@ subroutine pbcor2(m,n,mm,nn,k1m,k1n) km=k+mm do l=1,isp(j) do i=max(0,ifp(j,l)),min(ii+1,ilp(j,l)) - dp(i,j,km)=max(0.,dp(i,j,km))+epsil + dp(i,j,km)=max(0.,dp(i,j,km))+epsilp p(i,j,k+1)=p(i,j,k)+dp(i,j,km) enddo enddo @@ -719,7 +719,7 @@ subroutine pbcor2(m,n,mm,nn,k1m,k1n) enddo #endif sigma(i,j,km)=sig(temp(i,j,km),saln(i,j,km)) - dp(i,j,km)=dp(i,j,km)-epsil + dp(i,j,km)=dp(i,j,km)-epsilp if (dp(i,j,km).lt.dpeps2) dp(i,j,km)=0. enddo enddo diff --git a/phy/mod_pgforc.F b/phy/mod_pgforc.F index c97be6f3..7fdac606 100644 --- a/phy/mod_pgforc.F +++ b/phy/mod_pgforc.F @@ -1,5 +1,5 @@ ! ------------------------------------------------------------------------------ -! Copyright (C) 2005-2020 Mats Bentsen, Mehmet Ilicak +! Copyright (C) 2005-2022 Mats Bentsen, Mehmet Ilicak ! ! This file is part of BLOM. ! @@ -25,7 +25,7 @@ module mod_pgforc c --- ------------------------------------------------------------------ c use mod_types, only: r8 - use mod_constants, only: g, epsil, spval + use mod_constants, only: g, epsilp, spval use mod_xc use mod_state, only: dp, dpu, dpv, temp, saln, p, pu, pv, phi, . pb_p, pbu_p, pbv_p, sealv @@ -140,9 +140,6 @@ subroutine pgforc(m,n,mm,nn,k1m,k1n) c --- ------------------------------------------------------------------ c --- compute the pressure gradient force c --- ------------------------------------------------------------------ -c - use mod_constants, only: g, epsil - use mod_xc c implicit none c @@ -157,11 +154,11 @@ subroutine pgforc(m,n,mm,nn,k1m,k1n) c --- compute new -dpu,dpv- field. c c$OMP PARALLEL DO PRIVATE(k,kn,l,i) - do j=0,jj+1 + do j=-2,jj+2 do k=1,kk kn=k+nn do l=1,isp(j) - do i=max(0,ifp(j,l)),min(ii+1,ilp(j,l)) + do i=max(-2,ifp(j,l)),min(ii+2,ilp(j,l)) p(i,j,k+1)=p(i,j,k)+dp(i,j,kn) enddo enddo @@ -170,11 +167,11 @@ subroutine pgforc(m,n,mm,nn,k1m,k1n) c$OMP END PARALLEL DO c c$OMP PARALLEL DO PRIVATE(k,kn,l,i,q) - do j=1,jj + 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+1,ilu(j,l)) + 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*((min(q,p(i-1,j,k+1))-min(q,p(i-1,j,k))) @@ -182,15 +179,8 @@ subroutine pgforc(m,n,mm,nn,k1m,k1n) pu(i,j,k+1)=pu(i,j,k)+dpu(i,j,kn) enddo enddo - enddo - enddo -c$OMP END PARALLEL DO -c$OMP PARALLEL DO PRIVATE(k,kn,l,i,q) - do j=1,jj+1 - do k=1,kk - kn=k+nn do l=1,isv(j) - do i=max(1,ifv(j,l)),min(ii,ilv(j,l)) + 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*((min(q,p(i,j-1,k+1))-min(q,p(i,j-1,k))) @@ -213,7 +203,7 @@ subroutine pgforc(m,n,mm,nn,k1m,k1n) kn=k+nn do l=1,isp(j) do i=max(0,ifp(j,l)),min(ii,ilp(j,l)) - if (dp(i,j,kn).lt.epsil) then + if (dp(i,j,kn).lt.epsilp) then phi (i,j,k)=phi (i,j,k+1) phip(i,j,k)=phip(i,j,k+1) else diff --git a/phy/mod_pointtest.F90 b/phy/mod_pointtest.F90 index 6f1e6722..f48b8747 100644 --- a/phy/mod_pointtest.F90 +++ b/phy/mod_pointtest.F90 @@ -1,5 +1,5 @@ ! ------------------------------------------------------------------------------ -! Copyright (C) 2020 Mats Bentsen +! Copyright (C) 2020-2021 Mats Bentsen ! ! This file is part of BLOM. ! diff --git a/phy/mod_remap.F b/phy/mod_remap.F index 3350f32a..10e19318 100644 --- a/phy/mod_remap.F +++ b/phy/mod_remap.F @@ -1,5 +1,5 @@ ! ------------------------------------------------------------------------------ -! Copyright (C) 2006-2020 Mats Bentsen, Mehmet Ilicak +! Copyright (C) 2006-2022 Mats Bentsen, Mehmet Ilicak ! ! This file is part of BLOM. ! @@ -26,6 +26,7 @@ module mod_remap c use mod_types, only: r8 use mod_xc + use mod_constants, only: P_mks2cgs #ifdef TRC use mod_tracers, only: ntr, itrtke, itrgls #endif @@ -36,8 +37,8 @@ module mod_remap c c --- Parameters: real(r8), parameter :: - . dpeps = 1.e-11_r8 ! Small layer pressure thickness (equivalent - ! to approximately 10-16 m) [g cm-1 s-2]. + . dpeps = 1.e-12_r8*P_mks2cgs ! Small layer pressure thickness (equivalent + ! to approximately 10-16 m) [g cm-1 s-2]. #if defined(TRC) && defined(ATRC) real(r8), parameter :: . treps = 1.e-14_r8 ! Small tracer concentration. @@ -1085,9 +1086,9 @@ subroutine remap_eitvel(scuy,scvx,scp2i,scp2,pbmin,pbu,pbv,plo, endif c c --- --- u-component of mass, heat and salt flux. - uflx(i,j)=fdu(i,j) - utflx(i,j)=ftu(i,j) - usflx(i,j)=fsu(i,j) + uflx(i,j)=uflx(i,j)+fdu(i,j) + utflx(i,j)=utflx(i,j)+ftu(i,j) + usflx(i,j)=usflx(i,j)+fsu(i,j) c enddo enddo @@ -2549,9 +2550,9 @@ subroutine remap_eitflx(scuy,scvx,scp2i,scp2,pbmin,pbu,pbv,plo, endif c c --- --- u-component of mass, heat and salt flux. - uflx(i,j)=fdu(i,j) - utflx(i,j)=ftu(i,j) - usflx(i,j)=fsu(i,j) + uflx(i,j)=uflx(i,j)+fdu(i,j) + utflx(i,j)=utflx(i,j)+ftu(i,j) + usflx(i,j)=usflx(i,j)+fsu(i,j) c enddo enddo diff --git a/phy/mod_state.F90 b/phy/mod_state.F90 index e78236fc..ceb22c4d 100644 --- a/phy/mod_state.F90 +++ b/phy/mod_state.F90 @@ -1,5 +1,5 @@ ! ------------------------------------------------------------------------------ -! Copyright (C) 2020 Mats Bentsen +! Copyright (C) 2020-2022 Mats Bentsen ! ! This file is part of BLOM. ! @@ -86,7 +86,7 @@ module mod_state p, pu, pv, phi, ubflxs, vbflxs, & ub, vb, pb, pbu, pbv, ubflxs_p, vbflxs_p, & pb_p, pbu_p, pbv_p, ubcors_p, vbcors_p, sealv, kfpla, & - inivar_state + inivar_state, init_fluxes contains @@ -351,4 +351,48 @@ subroutine inivar_state end subroutine inivar_state + subroutine init_fluxes(m, n, mm, nn, k1m, k1n, update_flux_halos) + ! --------------------------------------------------------------------------- + ! Reset fluxes to be accumulated over a model time step and update flux + ! halos if requested. + ! --------------------------------------------------------------------------- + + integer, intent(in) :: m, n, mm, nn, k1m, k1n + logical, intent(in) :: update_flux_halos + + integer :: i, j, k, km, l + + !$omp parallel do private(k, km, l, i) + do j = 0, jj+2 + do k = 1, kk + km = k + mm + do l=1, isu(j) + do i=max(0, ifu(j,l)), min(ii+2, ilu(j,l)) + uflx(i,j,km) = 0._r8 + utflx(i,j,km) = 0._r8 + usflx(i,j,km) = 0._r8 + enddo + enddo + do l=1, isv(j) + do i=max(0, ifv(j,l)), min(ii+2, ilv(j,l)) + vflx(i,j,km) = 0._r8 + vtflx(i,j,km) = 0._r8 + vsflx(i,j,km) = 0._r8 + enddo + enddo + enddo + enddo + !$omp end parallel do + + if (update_flux_halos) then + call xctilr(uflx (1-nbdy,1-nbdy,k1n), 1, kk, 1, 1, halo_uv) + call xctilr(utflx(1-nbdy,1-nbdy,k1n), 1, kk, 1, 1, halo_uv) + call xctilr(usflx(1-nbdy,1-nbdy,k1n), 1, kk, 1, 1, halo_uv) + call xctilr(vflx (1-nbdy,1-nbdy,k1n), 1, kk, 1, 1, halo_vv) + call xctilr(vtflx(1-nbdy,1-nbdy,k1n), 1, kk, 1, 1, halo_vv) + call xctilr(vsflx(1-nbdy,1-nbdy,k1n), 1, kk, 1, 1, halo_vv) + endif + + end subroutine init_fluxes + end module mod_state diff --git a/phy/mod_swabs.F b/phy/mod_swabs.F index 6b1b6b38..f8c57064 100644 --- a/phy/mod_swabs.F +++ b/phy/mod_swabs.F @@ -113,7 +113,7 @@ module mod_swabs . ma94z2=(/ 7.925,-6.644, 3.662,-1.815, -.218, .502/) c c --- Other parameters: -c---- swamxd: Maximum depth of shortwave radiation penetration. +c---- swamxd: Maximum depth of shortwave radiation penetration [m]. real, parameter :: . swamxd = 200. c diff --git a/phy/mod_temmin.F b/phy/mod_temmin.F index 0c54c43a..4afc9cb6 100644 --- a/phy/mod_temmin.F +++ b/phy/mod_temmin.F @@ -27,7 +27,7 @@ module mod_temmin c use mod_types, only: r8 use mod_config, only: expcnf - use mod_grid, only: sigmar + use mod_vcoord, only: vcoord_type_tag, isopyc_bulkml, sigmar use mod_xc use mod_eos, only: ap11, ap12, ap13, ap14, ap15, ap16, . ap21, ap22, ap23, ap24, ap25, ap26, atf @@ -56,7 +56,8 @@ subroutine settemmin integer i,j,k,l real salfrz,a,b,c c - if (expcnf.eq.'cesm' .or. expcnf.eq.'single_column') then + if (vcoord_type_tag.ne.isopyc_bulkml .or. + . expcnf.eq.'cesm' .or. expcnf.eq.'single_column') then c c --- - Set temmin to a constant freezing temperature for all layers c$OMP PARALLEL DO PRIVATE(k,l,i) diff --git a/phy/mod_tidaldissip.F90 b/phy/mod_tidaldissip.F90 index 2005289d..d3a61236 100644 --- a/phy/mod_tidaldissip.F90 +++ b/phy/mod_tidaldissip.F90 @@ -1,5 +1,5 @@ ! ------------------------------------------------------------------------------ -! Copyright (C) 2015-2020 Mats Bentsen +! Copyright (C) 2015-2020 Mats Bentsen, Mehmet Ilicak ! ! This file is part of BLOM. ! @@ -24,7 +24,7 @@ module mod_tidaldissip ! ------------------------------------------------------------------------------ use mod_types, only: r8 - use mod_constants, only: spval + use mod_constants, only: spval, M_mks2cgs use mod_xc use mod_checksum, only: csdiag, chksummsk use netcdf @@ -157,7 +157,7 @@ subroutine read_tidaldissip do j = 1, jj do l = 1, isp(j) do i = max(1, ifp(j, l)), min(ii, ilp(j, l)) - twedon(i, j) = twedon(i, j)*1.e3_r8 + twedon(i, j) = twedon(i, j)*M_mks2cgs enddo enddo enddo diff --git a/phy/mod_time.F90 b/phy/mod_time.F90 index 5e32c7d3..f4f0442b 100644 --- a/phy/mod_time.F90 +++ b/phy/mod_time.F90 @@ -1,5 +1,5 @@ ! ------------------------------------------------------------------------------ -! Copyright (C) 2020-2021 Mats Bentsen, Mehmet Ilicak, Aleksi Nummelin +! Copyright (C) 2020-2022 Mats Bentsen, Mehmet Ilicak, Aleksi Nummelin ! ! This file is part of BLOM. ! @@ -24,7 +24,7 @@ module mod_time use mod_types, only: r8 use mod_config, only: expcnf - use mod_constants, only: epsil + use mod_constants, only: epsilt use mod_calendar, only: date_type, daynum_diff, date_offset, & calendar_noerr, calendar_errstr use mod_xc, only: lp, mnproc, xcstop @@ -118,7 +118,7 @@ subroutine init_timevars ! Get number of baroclinic time steps per day and verify that an integer ! number of steps fits in a day. nstep_in_day = nint(86400._r8/baclin) - if (abs(86400._r8/baclin - nstep_in_day) > epsil) then + if (abs(86400._r8/baclin - nstep_in_day) > epsilt) then if (mnproc == 1) then write (lp, *) & 'init_timevars: '// & diff --git a/phy/mod_timing.F90 b/phy/mod_timing.F90 index f527d021..a3b1c824 100644 --- a/phy/mod_timing.F90 +++ b/phy/mod_timing.F90 @@ -1,5 +1,5 @@ ! ------------------------------------------------------------------------------ -! Copyright (C) 2006-2020 Mats Bentsen, Alok Kumar Gupta +! Copyright (C) 2006-2022 Mats Bentsen, Alok Kumar Gupta ! ! This file is part of BLOM. ! @@ -93,7 +93,7 @@ end subroutine init_timing real(r8) function get_time() ! --------------------------------------------------------------------------- - ! Return time in seconds since last call to either init_timer or get_time. + ! Return time in seconds since last call to either init_timing or get_time. ! --------------------------------------------------------------------------- if (mnproc == 1) then diff --git a/phy/mod_tke.F90 b/phy/mod_tke.F90 index fc5655ae..73dc2c95 100644 --- a/phy/mod_tke.F90 +++ b/phy/mod_tke.F90 @@ -1,5 +1,5 @@ ! ------------------------------------------------------------------------------ -! Copyright (C) 2013-2020 Mehmet Ilicak, Mats Bentsen +! Copyright (C) 2013-2022 Mehmet Ilicak, Mats Bentsen ! ! This file is part of BLOM. ! @@ -24,6 +24,7 @@ module mod_tke ! ------------------------------------------------------------------------------ use mod_types, only: r8 + use mod_constants, only: spval use mod_xc use mod_diffusion, only: difdia use mod_forcing, only: ustarb @@ -34,10 +35,8 @@ module mod_tke real(r8), parameter :: & gls_cmu0 = .527_r8, & ! cmu0 - Pr_t = 1._r8, & ! Turbulent Prandtl number []. - tke_min = 7.6e-4_r8, & ! Minimum TKE value [?]. + Pr_t = 1._r8, & ! Turbulent Prandtl number [non-dimensional]. zos = .0002_r8, & ! - gls_psi_min = 1.e-10_r8, & ! Minimum GLS value [?]. gls_p = 3._r8, & ! gls_m = 1.5_r8, & ! gls_n = -1._r8, & ! @@ -56,8 +55,19 @@ module mod_tke gls_Gh0 = .0329_r8, & ! gls_Ghmin = -.28_r8, & ! gls_Ghcri = .03_r8, & ! - vonKar = .4_r8, & ! - Ls_unlmt_min = 1.e-6_r8 ! + vonKar = .4_r8 ! + +#ifdef MKS + real(r8), parameter :: & + tke_min = 7.6e-8_r8, & ! Minimum TKE value [m2/s2]. + gls_psi_min = 1.e-14_r8, & ! Minimum GLS value [m2/s3]. + Ls_unlmt_min = 1.e-8_r8 ! [m] +#else + real(r8), parameter :: & + tke_min = 7.6e-4_r8, & ! Minimum TKE value [cm2/s2]. + gls_psi_min = 1.e-10_r8, & ! Minimum GLS value [cm2/s3]. + Ls_unlmt_min = 1.e-6_r8 ! [cm] +#endif real(r8), dimension(1 - nbdy:idm + nbdy, 1 - nbdy:jdm + nbdy, kdm) :: & Prod, & ! Shear production [?]. @@ -93,6 +103,18 @@ subroutine initke ! Initialize fields holding turbulent kinetic energy, generic length ! scale, and other fields used in the turbulence closure. + !$omp parallel do private(i, k) + do j = 1 - nbdy, jj + nbdy + do i = 1 - nbdy, ii + nbdy + do k = 1, kk + Prod(i ,j ,k) = spval + Buoy(i ,j ,k) = spval + Shear2(i ,j ,k) = spval + L_scale(i ,j ,k) = spval + enddo + enddo + enddo + !$omp end parallel do !$omp parallel do private(k, l, i) do j = 1 - nbdy, jj + nbdy do k = 1, 2*kdm diff --git a/phy/mod_tmsmt.F b/phy/mod_tmsmt.F index 515619c9..cf7ef21a 100644 --- a/phy/mod_tmsmt.F +++ b/phy/mod_tmsmt.F @@ -1,5 +1,5 @@ ! ------------------------------------------------------------------------------ -! Copyright (C) 2005-2020 Mats Bentsen +! Copyright (C) 2005-2022 Mats Bentsen, Mehmet Ilicak ! ! This file is part of BLOM. ! @@ -27,8 +27,9 @@ module mod_tmsmt c --- ------------------------------------------------------------------ c use mod_types, only: r8 - use mod_constants, only: epsil, spval + use mod_constants, only: epsilp, spval use mod_xc + use mod_vcoord, only: vcoord_type_tag, isopyc_bulkml use mod_state, only: dp, dpu, dpv, temp, saln, p, pb use mod_checksum, only: csdiag, chksummsk #ifdef TRC @@ -61,7 +62,7 @@ module mod_tmsmt . sold ! Salinity at old time level [g kg-1]. c public :: wuv1, wuv2, wts1, wts2, wbaro, dpold, dpuold, dpvold, - . inivar_tmsmt, tmsmt1, tmsmt2 + . inivar_tmsmt, initms, tmsmt1, tmsmt2 c contains c @@ -161,7 +162,7 @@ end subroutine inivar_tmsmt c c --- ------------------------------------------------------------------ c - subroutine tmsmt1(m,n,mm,nn,k1m,k1n) + subroutine initms(m,n,mm,nn,k1m,k1n) c c --- save old layer thickness, temperature and salinity for time c --- smoothing @@ -175,40 +176,70 @@ subroutine tmsmt1(m,n,mm,nn,k1m,k1n) integer nt #endif c - integer i,j,k,l,kn + integer i,j,k,l,km c -c$OMP PARALLEL DO PRIVATE(k,kn,l,i +c$OMP PARALLEL DO PRIVATE(k,km,l,i #ifdef TRC c$OMP+ ,nt #endif c$OMP+ ) do j=1,jj do k=1,kk - kn=k+nn + km=k+mm do l=1,isp(j) do i=max(1,ifp(j,l)),min(ii,ilp(j,l)) - dpold(i,j,kn)=dp(i,j,kn) - told(i,j,k)=temp(i,j,kn) - sold(i,j,k)=saln(i,j,kn) + dpold(i,j,km)=dp(i,j,km) + told(i,j,k)=temp(i,j,km) + sold(i,j,k)=saln(i,j,km) #ifdef TRC do nt=1,ntr - trcold(i,j,k,nt)=trc(i,j,kn,nt) + trcold(i,j,k,nt)=trc(i,j,km,nt) enddo #endif enddo enddo - do l=1,isu(j) - do i=max(1,ifu(j,l)),min(ii+1,ilu(j,l)) - dpuold(i,j,k)=dpu(i,j,kn) - enddo - enddo enddo enddo c$OMP END PARALLEL DO +c + if (csdiag) then + if (mnproc.eq.1) then + write (lp,*) 'initms:' + endif + call chksummsk(dpold,ip,2*kk,'dpold') + call chksummsk(told,ip,kk,'told') + call chksummsk(sold,ip,kk,'sold') +#ifdef TRC + do nt=1,ntr + call chksummsk(trcold(1-nbdy,1-nbdy,1,nt),ip,kk,'trcold') + enddo +#endif + endif +c + end subroutine initms +c + subroutine tmsmt1(m,n,mm,nn,k1m,k1n) +c +c --- save old layer thickness at velocity points for time smoothing in +c --- momentum equation. +c + use mod_xc +c + implicit none +c + integer m,n,mm,nn,k1m,k1n +c + integer i,j,k,l,kn +c c$OMP PARALLEL DO PRIVATE(k,kn,l,i) - do j=1,jj+1 + 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)) + dpuold(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)) dpvold(i,j,k)=dpv(i,j,kn) @@ -222,14 +253,8 @@ subroutine tmsmt1(m,n,mm,nn,k1m,k1n) if (mnproc.eq.1) then write (lp,*) 'tmsmt1:' endif - call chksummsk(dpold,ip,2*kk,'dpold') - call chksummsk(told,ip,kk,'told') - call chksummsk(sold,ip,kk,'sold') -#ifdef TRC - do nt=1,ntr - call chksummsk(trcold(1-nbdy,1-nbdy,1,nt),ip,kk,'trcold') - enddo -#endif + call chksummsk(dpuold,iu,kk,'dpuold') + call chksummsk(dpvold,iv,kk,'dpvold') endif c end subroutine tmsmt1 @@ -240,7 +265,7 @@ subroutine tmsmt2(m,n,mm,nn,k1m,k1n) c c --- time smoothing of layer thickness, temperature and salinity c - use mod_constants, only: epsil + use mod_constants, only: epsilp use mod_xc c implicit none @@ -292,21 +317,25 @@ subroutine tmsmt2(m,n,mm,nn,k1m,k1n) pmid=max(0.,dp(i,j,km)) pnew=max(0.,dp(i,j,kn)*pbfacn(i)) dp(i,j,km)=wts1*pmid+wts2*(pold+pnew) - pold=pold+epsil - pmid=pmid+epsil - pnew=pnew+epsil + dpold(i,j,km)=dp(i,j,km) + pold=pold+epsilp + pmid=pmid+epsilp + pnew=pnew+epsilp temp(i,j,km)=(wts1*pmid*temp(i,j,km) . +wts2*(pold*told(i,j,k)+pnew*temp(i,j,kn))) - . /(dp(i,j,km)+epsil) + . /(dp(i,j,km)+epsilp) + told(i,j,k)=temp(i,j,km) saln(i,j,km)=(wts1*pmid*saln(i,j,km) . +wts2*(pold*sold(i,j,k)+pnew*saln(i,j,kn))) - . /(dp(i,j,km)+epsil) + . /(dp(i,j,km)+epsilp) + sold(i,j,k)=saln(i,j,km) #ifdef TRC do nt=1,ntr trc(i,j,km,nt)=(wts1*pmid*trc(i,j,km,nt) . +wts2*(pold*trcold(i,j,k,nt) . +pnew*trc(i,j,kn,nt))) - . /(dp(i,j,km)+epsil) + . /(dp(i,j,km)+epsilp) + trcold(i,j,k,nt)=trc(i,j,km,nt) enddo #endif enddo @@ -315,43 +344,61 @@ subroutine tmsmt2(m,n,mm,nn,k1m,k1n) enddo c$OMP END PARALLEL DO c - call xctilr(dp(1-nbdy,1-nbdy,k1m), 1,kk, 3,3, halo_ps) + if (vcoord_type_tag == isopyc_bulkml) then +c + call xctilr(dp(1-nbdy,1-nbdy,k1m), 1,kk, 3,3, halo_ps) c c$OMP PARALLEL DO PRIVATE(k,l,i) - do j=-2,jj+2 - do k=1,kk - do l=1,isp(j) - do i=max(-2,ifp(j,l)),min(ii+2,ilp(j,l)) - p(i,j,k+1)=p(i,j,k)+dp(i,j,k+mm) - enddo + do j=-2,jj+2 + do k=1,kk + do l=1,isp(j) + do i=max(-2,ifp(j,l)),min(ii+2,ilp(j,l)) + p(i,j,k+1)=p(i,j,k)+dp(i,j,k+mm) + enddo + enddo enddo enddo - enddo c$OMP END PARALLEL DO c c$OMP PARALLEL DO PRIVATE(k,km,l,i,q) - do j=-1,jj+2 - do k=1,kk - km=k+mm - 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,km)= - . .5*((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,km)= - . .5*((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)))) + do j=-1,jj+2 + do k=1,kk + km=k+mm + 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,km)= + . .5*((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,km)= + . .5*((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 +c$OMP END PARALLEL DO +c + else +c +c$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)) + p(i,j,k+1)=p(i,j,k)+dp(i,j,k+mm) + enddo + enddo enddo enddo - enddo c$OMP END PARALLEL DO +c + endif c if (csdiag) then if (mnproc.eq.1) then diff --git a/phy/mod_vcoord.F90 b/phy/mod_vcoord.F90 new file mode 100644 index 00000000..f63e6cbd --- /dev/null +++ b/phy/mod_vcoord.F90 @@ -0,0 +1,1405 @@ +! ------------------------------------------------------------------------------ +! Copyright (C) 2021-2022 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_vcoord +! ------------------------------------------------------------------------------ +! This module contains parameter, variables and procedures related to the +! vertical coordinate. +! ------------------------------------------------------------------------------ + + use mod_types, only: r8 + use mod_config, only: inst_suffix + use mod_constants, only: g, epsilp, spval, onem + use mod_xc + 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 + use mod_ndiff, only: ndiff_prep_jslice, ndiff_uflx_jslice, & + ndiff_vflx_jslice, ndiff_update_trc_jslice + use mod_checksum, only: csdiag, chksummsk +#ifdef TRC + use mod_tracers, only: ntr, trc +#endif + + implicit none + + private + + ! 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. + real(r8) :: & + dpmin_surface = 1.5_r8, & + dpmin_inflation_factor = 1._r8, & + dpmin_interior = .1_r8, & + regrid_nudge_factor = .1_r8 + + ! 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. + + + 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 + + real(r8), dimension(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy,kdm) :: & + 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 + +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, i_lb, i_ub, j, j_rs, nn) + ! --------------------------------------------------------------------------- + ! Prepare vertical layer reconstruction along a j-slice of the model data. + ! --------------------------------------------------------------------------- + + real(r8), dimension(:,1-nbdy:), intent(out) :: p_src + 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)) + + 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 + + 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(i_lb, i_ub, j, j_rs, nn) + ! --------------------------------------------------------------------------- + ! Vertically reconstruct temperature, salinity and additional tracers along a + ! j-slice of the model data. + ! --------------------------------------------------------------------------- + + 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) +#ifdef TRC + do nt = 1, ntr + trc_1d(k,nt+2) = trc(i,j,kn,nt) + enddo +#endif + 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 + + 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, 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 + + integer, parameter :: & + p_ord = 4, & + it = 1, & + is = 2 + + real(r8), dimension(p_ord+1,kdm,2,1-nbdy:idm+nbdy) :: tpc_src + real(r8), dimension(2,kdm,2,1-nbdy:idm+nbdy) :: t_srcdi + real(r8), dimension(2,kdm) :: sig_srcdi + integer, dimension(1-nbdy:idm+nbdy) :: ksmx, kdmx + + real(r8), dimension(kdm+1) :: sigmar_1d, pmin, sig_pmin + real(r8) :: sig_max, dpmin_sfc, dsig, dsigdx, q + integer :: l, i, nt, k, kr, kl, klastok, kt, errstat + logical :: ok + + do l = 1, isp(j) + do i = max(i_lb, ifp(j, l)), min(i_ub, ilp(j, l)) + + ! Extract polynomial coefficients of the reconstructions. + do nt = 1, 2 + 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('(ndiff_prep_jslice)') + stop '(ndiff_prep_jslice)' + endif + 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 + + ! Store variables in dual interface arrays 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) + do nt = 1, 2 + 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 + 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) + + ! 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) + + do k = kdmx(i)+1, kk+1 + p_dst(k,i) = p_src(kk+1,i) + enddo + + 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) + + sig_pmin(1) = sig_srcdi(1,1) + kr = 2 + kl = 1 + do while (kr <= kdmx(i)) + do while (p_src(kl+1,i) < pmin(kr)) + kl = kl + 1 + enddo + sig_pmin(kr) = ( (p_src(kl+1,i) - pmin(kr))*sig_srcdi(1,kl) & + + (pmin(kr) - p_src(kl,i))*sig_srcdi(2,kl)) & + /(p_src(kl+1,i) - p_src(kl,i)) + if (sigmar_1d(kr) > sig_pmin(kr)) exit + p_dst(kr,i) = pmin(kr) + kr = kr + 1 + enddo + + klastok = kr - 1 + do k = kr, min(ksmx(i), kdmx(i)) + ok = .true. + if (sigmar_1d(k) < sig_srcdi(2,k-1) .and. & + sigmar_1d(k) < sig_srcdi(1,k )) then + dsig = (sigmar_1d(k) - sig_srcdi(2,k-1))*regrid_nudge_factor + 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)) + if (- dsig > .5_r8*dsigdx) then + dsigdx = sig_srcdi(2,k-1) - sig_srcdi(1,k-1) + if (- dsig > .5_r8*dsigdx) ok = .false. + endif + if (ok) p_dst(k,i) = p_src(k,i) & + + dsig*(p_src(k,i) - p_src(k-1,i))/dsigdx + elseif (sigmar_1d(k) > sig_srcdi(2,k-1) .and. & + sigmar_1d(k) > sig_srcdi(1,k )) then + dsig = (sigmar_1d(k) - sig_srcdi(1,k))*regrid_nudge_factor + 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)) + if (dsig > .5_r8*dsigdx) then + dsigdx = sig_srcdi(2,k) - sig_srcdi(1,k) + if (dsig > .5_r8*dsigdx) ok = .false. + endif + if (ok) p_dst(k,i) = p_src(k,i) & + + dsig*(p_src(k+1,i) - p_src(k,i))/dsigdx + else + p_dst(k,i) = p_src(k,i) + endif + if (ok) then + p_dst(k,i) = & + min(max(p_dst(k,i), pmin(k), & + p_dst(klastok,i) + (k - klastok)*dpmin_interior), & + p_src(kk+1,i)) + if (k - klastok > 1) then + q = (p_dst(k,i) - p_dst(klastok,i))/(k - klastok) + do kt = klastok+1, k-1 + p_dst(kt,i) = min(max(p_dst(kt-1,i) + q, pmin(kt)), & + p_src(kk+1,i)) + enddo + endif + klastok = k + endif + enddo + + do k = max(kr, min(ksmx(i), kdmx(i))) + 1, kdmx(i) + ok = .true. + if (sigmar_1d(k) < sig_srcdi(2,ksmx(i))) then + dsig = (sigmar_1d(k) - sig_srcdi(2,ksmx(i)))*regrid_nudge_factor + 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)) + if (- dsig > .5_r8*dsigdx) then + dsigdx = sig_srcdi(2,ksmx(i)) - sig_srcdi(1,ksmx(i)) + if (- dsig > .5_r8*dsigdx) ok = .false. + endif + if (ok) p_dst(k,i) = p_src(kk+1,i) & + + dsig*(p_src(kk+1,i) - p_src(ksmx(i),i)) & + /dsigdx + else + p_dst(k,i) = p_src(kk+1,i) + endif + if (ok) then + p_dst(k,i) = & + min(max(p_dst(k,i), pmin(k), & + p_dst(klastok,i) + (k - klastok)*dpmin_interior), & + p_src(kk+1,i)) + if (k - klastok > 1) then + q = (p_dst(k,i) - p_dst(klastok,i))/(k - klastok) + do kt = klastok+1, k-1 + p_dst(kt,i) = min(max(p_dst(kt-1,i) + q, pmin(kt)), & + p_src(kk+1,i)) + enddo + endif + klastok = k + endif + enddo + + if (kdmx(i) - klastok > 0) then + q = (p_dst(kdmx(i)+1,i) - p_dst(klastok,i))/(kdmx(i) + 1 - klastok) + do kt = klastok+1, kdmx(i) + p_dst(kt,i) = min(max(p_dst(kt-1,i) + q, pmin(kt)), & + p_src(kk+1,i)) + enddo + endif + + enddo + enddo + + end subroutine cntiso_regrid_nudge_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)) +#ifdef TRC + do nt = 1, ntr + trc(i,j,kn,nt) = trc_rm(k,nt+2,i) + enddo +#endif + 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 + logical :: fexist + + namelist /vcoord/ & + vcoord_type, reconstruction_method, & + 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_factor + + ! Read variables in the namelist group 'vcoord'. + if (mnproc == 1) then + nml_fname = 'ocn_in'//trim(inst_suffix) + inquire(file = nml_fname, exist = fexist) + if (fexist) then + open (unit = 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 (unit = nfu, file = nml_fname, status = 'old', & + action = 'read') + else + write (lp,*) 'readnml_vcoord: could not find namelist file!' + call xchalt('(readnml_vcoord)') + stop '(readnml_vcoord)' + endif + endif + read (unit = nfu, nml = vcoord, iostat = ios) + close (unit = nfu) + endif + call xcbcst(ios) + if (ios /= 0) then + if (mnproc == 1) & + 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(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_factor) + 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,*) ' 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_surface = ', dpmin_surface + write (lp,*) ' dpmin_inflation_factor = ', dpmin_inflation_factor + write (lp,*) ' dpmin_interior = ', dpmin_interior + write (lp,*) ' regrid_nudge_factor = ', regrid_nudge_factor + endif + + ! 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)' + 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 + + end subroutine readnml_vcoord + + 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 + +#ifdef TRC + ! 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 +#endif + + ! 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 = 0 + rcgs%i_ubound = ii + 1 + else + rcgs%i_ubound = ii + endif + rcgs%j_ubound = 2 + rcgs%method = reconstruction_method_tag + + ! 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 + + real(r8), dimension(kdm+1,1-nbdy:idm+nbdy,2) :: p_src_rs, p_dst_rs + real(r8), dimension(kdm,ntr_loc,1-nbdy:idm+nbdy) :: trc_rm + 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), 1, ii, j, j_rs, nn) + call recon_trc_jslice(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) +#ifdef TRC + 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 +#endif + 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), & + 0, ii+1, j+1, jp_rs, nn) + call recon_trc_jslice(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, p_dst_rs, trc_rcss, & + 0, ii+1, j+1, jp_rs, mm) + enddo + + j = 0 + call ndiff_vflx_jslice(p_dst_rs, 1, ii, j+1, 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), & + 0, ii+1, j+1, jp_rs, nn) + call recon_trc_jslice(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, p_dst_rs, trc_rcss, & + 0, ii+1, j+1, jp_rs, mm) + call ndiff_uflx_jslice(p_dst_rs, 1, ii+1, j, jm_rs, mm, nn) + call ndiff_vflx_jslice(p_dst_rs, 1, ii, j+1, 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, trc_rm, 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') +#ifdef TRC + do nt = 1, ntr + call chksummsk(trc(1-nbdy,1-nbdy,k1n,nt), ip, kk, 'trc') + enddo +#endif + 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 + + real(r8), dimension(kdm+1,1-nbdy:idm+nbdy,2) :: p_src_rs, p_dst_rs + real(r8), dimension(kdm,ntr_loc,1-nbdy:idm+nbdy) :: trc_rm + 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), 1, ii, j, j_rs, nn) + call recon_trc_jslice(1, ii, j, j_rs, nn) + call cntiso_regrid_nudge_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) +#ifdef TRC + 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 +#endif + 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), & + 0, ii+1, j+1, jp_rs, nn) + call recon_trc_jslice(0, ii+1, j+1, jp_rs, nn) + call cntiso_regrid_nudge_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, p_dst_rs, trc_rcss, & + 0, ii+1, j+1, jp_rs, mm) + enddo + + j = 0 + call ndiff_vflx_jslice(p_dst_rs, 1, ii, j+1, 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), & + 0, ii+1, j+1, jp_rs, nn) + call recon_trc_jslice(0, ii+1, j+1, jp_rs, nn) + call cntiso_regrid_nudge_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, p_dst_rs, trc_rcss, & + 0, ii+1, j+1, jp_rs, mm) + call ndiff_uflx_jslice(p_dst_rs, 1, ii+1, j, jm_rs, mm, nn) + call ndiff_vflx_jslice(p_dst_rs, 1, ii, j+1, 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, trc_rm, 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') + call chksummsk(sigmar, ip, kk, 'sigmar') +#ifdef TRC + do nt = 1, ntr + call chksummsk(trc(1-nbdy,1-nbdy,k1n,nt), ip, kk, 'trc') + enddo +#endif + 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+2 + do k = 1, kk + kn = k + nn + do l = 1, isp(j) + do i = max(-2, ifp(j,l)), min(ii+2, 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('(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) + 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') + endif + + end subroutine remap_velocity + +end module mod_vcoord diff --git a/phy/mod_vdiff.F90 b/phy/mod_vdiff.F90 new file mode 100644 index 00000000..61778a72 --- /dev/null +++ b/phy/mod_vdiff.F90 @@ -0,0 +1,356 @@ +! ------------------------------------------------------------------------------ +! Copyright (C) 2021-2022 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_vdiff +! ------------------------------------------------------------------------------ +! This module contains procedures for solving vertical diffusion equations. +! ------------------------------------------------------------------------------ + + use mod_types, only: r8 + use mod_constants, only: g, spcifh, alpha0, onem + use mod_time, only: delt1 + use mod_xc + use mod_eos, only: sig + use mod_state, only: u, v, dp, dpu, dpv, temp, saln, sigma + use mod_checksum, only: csdiag, chksummsk + use mod_diffusion, only: Kvisc_m, Kdiff_t, Kdiff_s, t_ns_nonloc, s_nonloc + use mod_forcing, only: surflx, sswflx, surrlx, salflx, salrlx, t_sw_nonloc +#ifdef TRC + use mod_tracers, only: ntr, trc, trflx +#endif + + implicit none + + private + + real(r8), parameter :: & + dpmin_vdiff = 0.1_r8*onem + + public :: cntiso_hybrid_vdifft, cntiso_hybrid_vdiffm + +contains + + subroutine cntiso_hybrid_vdifft(m, n, mm, nn, k1m, k1n) + + integer, intent(in) :: m, n, mm, nn, k1m, k1n + + real(r8), dimension(kdm) :: dp_1d, temp_1d, saln_1d, & + nut_1d, nus_1d, nutrc_1d + real(r8), dimension(2:kdm) :: fpbase, fp, gam + real(r8) :: cpi, dtg, c, bei, rhs + integer :: i, j, k, l, kn, nt +#ifdef TRC + real(r8), dimension(kdm, ntr) :: trc_1d +#endif + + cpi = 1._r8/spcifh ! Multiplicative inverse of specific heat capacity. + dtg = delt1*g + c = g*g*delt1/(alpha0*alpha0) + + do j = 1, jj + do l = 1, isp(j) + do i = max(1, ifp(j, l)), min(ii, ilp(j, l)) + + ! Copy variables into 1D arrays. + do k = 1, kk + kn = k + nn + dp_1d(k) = dp(i, j, kn) + temp_1d(k) = temp(i, j, kn) + saln_1d(k) = saln(i, j, kn) + nut_1d(k) = Kdiff_t(i, j, k) + nus_1d(k) = Kdiff_s(i, j, k) +#ifdef TRC + do nt = 1, ntr + trc_1d(k, nt) = trc(i, j, kn, nt) + enddo + nutrc_1d(k) = Kdiff_t(i, j, k) +#endif + enddo + + ! Vertical diffusion equations are solved by backward integration + ! forming a tridiagonal set of equations: + ! + ! - fp(k)*U(k-1) + (dp(k) + fp(k) + fp(k+1))*U(k) - fp(k+1)*U(k+1) + ! = dp(k)*(u(k) + Q_nonloc(k)) + ! + ! Here u and U is the variable to be diffused at old and new + ! time-level, respectively, and Q_nonloc is the divergence of + ! non-local transport of surface flux. + + ! Diffusive interface fluxes, before multiplying with diffusivity. + do k = 2, kk + fpbase(k) = c/max(dpmin_vdiff, .5_r8*(dp_1d(k - 1) + dp_1d(k))) + enddo + + ! Diffusion of potential temperature. + do k = 2, kk + fp(k) = nut_1d(k)*fpbase(k) + enddo + bei = 1._r8/(dp_1d(1) + fp(2)) + rhs = dp_1d(1)*temp_1d(1) & + - ( (1._r8 - t_ns_nonloc(i,j,2))*(surflx(i,j) - sswflx(i,j)) & + + (1._r8 - t_sw_nonloc(i,j,2))*sswflx(i,j) & + + surrlx(i,j))*dtg*cpi + temp_1d(1) = rhs*bei + do k = 2, kk - 1 + gam(k) = - fp(k)*bei + bei = 1._r8/(dp_1d(k) + fp(k)*(1._r8 + gam(k)) + fp(k + 1)) + rhs = dp_1d(k)*temp_1d(k) & + - ( (t_ns_nonloc(i,j,k) - t_ns_nonloc(i,j,k+1)) & + *(surflx(i,j) - sswflx(i,j)) & + + (t_sw_nonloc(i,j,k) - t_sw_nonloc(i,j,k+1)) & + *sswflx(i,j))*dtg*cpi + temp_1d(k) = (rhs + fp(k)*temp_1d(k - 1))*bei + enddo + gam(kk) = - fp(kk)*bei + bei = 1._r8/(dp_1d(kk) + fp(kk)*(1._r8 + gam(kk))) + rhs = dp_1d(kk)*temp_1d(kk) & + - ( (t_ns_nonloc(i,j,kk) - t_ns_nonloc(i,j,kk+1)) & + *(surflx(i,j) - sswflx(i,j)) & + + (t_sw_nonloc(i,j,kk) - t_sw_nonloc(i,j,kk+1)) & + *sswflx(i,j))*dtg*cpi + temp_1d(kk) = (rhs + fp(kk)*temp_1d(kk - 1))*bei + do k = kk - 1, 1, - 1 + temp_1d(k) = temp_1d(k) - gam(k + 1)*temp_1d(k + 1) + enddo + + ! Diffusion of salinity. + do k = 2, kk + fp(k) = nus_1d(k)*fpbase(k) + enddo + bei = 1._r8/(dp_1d(1) + fp(2)) + rhs = dp_1d(1)*saln_1d(1) & + - ((1._r8 - s_nonloc(i,j,2))*salflx(i,j) & + + salrlx(i,j))*dtg + saln_1d(1) = rhs*bei + do k = 2, kk - 1 + gam(k) = - fp(k)*bei + bei = 1._r8/(dp_1d(k) + fp(k)*(1._r8 + gam(k)) + fp(k + 1)) + rhs = dp_1d(k)*saln_1d(k) & + - (s_nonloc(i,j,k) - s_nonloc(i,j,k+1))*salflx(i,j)*dtg + saln_1d(k) = (rhs + fp(k)*saln_1d(k - 1))*bei + enddo + gam(kk) = - fp(kk)*bei + bei = 1._r8/(dp_1d(kk) + fp(kk)*(1._r8 + gam(kk))) + rhs = dp_1d(kk)*saln_1d(kk) & + - (s_nonloc(i,j,kk) - s_nonloc(i,j,kk+1))*salflx(i,j)*dtg + saln_1d(kk) = (rhs + fp(kk)*saln_1d(kk - 1))*bei + do k = kk - 1, 1, - 1 + saln_1d(k) = saln_1d(k) - gam(k + 1)*saln_1d(k + 1) + enddo + +#ifdef TRC + ! Diffusion of tracers. + do k = 2, kk + fp(k) = nutrc_1d(k)*fpbase(k) + enddo + bei = 1._r8/(dp_1d(1) + fp(2)) + do nt = 1, ntr + rhs = dp_1d(1)*trc_1d(1,nt) & + - (1._r8 - s_nonloc(i,j,2))*trflx(nt,i,j)*dtg + trc_1d(1, nt) = rhs*bei + enddo + do k = 2, kk - 1 + gam(k) = - fp(k)*bei + bei = 1._r8/(dp_1d(k) + fp(k)*(1._r8 + gam(k)) + fp(k + 1)) + do nt = 1, ntr + rhs = dp_1d(k)*trc_1d(k,nt) & + - (s_nonloc(i,j,k) - s_nonloc(i,j,k+1))*trflx(nt,i,j)*dtg + trc_1d(k, nt) = (rhs + fp(k)*trc_1d(k - 1, nt))*bei + enddo + enddo + gam(kk) = - fp(kk)*bei + bei = 1._r8/(dp_1d(kk) + fp(kk)*(1._r8 + gam(kk))) + do nt = 1, ntr + rhs = dp_1d(kk)*trc_1d(kk,nt) & + - (s_nonloc(i,j,kk) - s_nonloc(i,j,kk+1))*trflx(nt,i,j)*dtg + trc_1d(kk, nt) = (rhs + fp(kk)*trc_1d(kk - 1, nt))*bei + enddo + do k = kk - 1, 1, - 1 + do nt = 1, ntr + trc_1d(k, nt) = trc_1d(k, nt) - gam(k + 1)*trc_1d(k + 1, nt) + enddo + enddo +#endif + + ! Update 3D arrays + do k = 1, kk + kn = k + nn + temp(i, j, kn) = temp_1d(k) + saln(i, j, kn) = saln_1d(k) + sigma(i, j, kn) = sig(temp_1d(k), saln_1d(k)) +#ifdef TRC + do nt = 1,ntr + trc(i, j, kn, nt) = trc_1d(k, nt) + enddo +#endif + enddo + + enddo + enddo + enddo + + if (csdiag) then + if (mnproc == 1) then + write (lp,*) 'cntiso_hybrid_vdifft:' + endif + call chksummsk(temp, ip, 2*kk, 'temp') + call chksummsk(saln, ip, 2*kk, 'saln') + call chksummsk(sigma, ip, 2*kk, 'sigma') +#ifdef TRC + do nt = 1, ntr + call chksummsk(trc(1-nbdy, 1-nbdy, 1, nt), ip, 2*kk, 'trc') + enddo +#endif + endif + + end subroutine cntiso_hybrid_vdifft + + subroutine cntiso_hybrid_vdiffm(m, n, mm, nn, k1m, k1n) + + integer, intent(in) :: m, n, mm, nn, k1m, k1n + + real(r8), dimension(kdm) :: dp_1d, u_1d, v_1d, nuv_1d + real(r8), dimension(2:kdm) :: fpbase, fp, gam + real(r8) :: c, bei + integer :: i, j, k, l, kn + + c = g*g*delt1/(alpha0*alpha0) + + call xctilr(Kvisc_m, 1, kk, 1, 1, halo_ps) + + 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. + do k = 1, kk + kn = k + nn + dp_1d(k) = dpu(i, j, kn) + u_1d(k) = u(i, j, kn) + nuv_1d(k) = .5_r8*(Kvisc_m(i-1, j, k) + Kvisc_m(i, j, k)) + enddo + + ! Vertical diffusion equations are solved by backward integration + ! forming a tridiagonal set of equations: + ! + ! - fp(k)*U(k-1) + (dp(k) + fp(k) + fp(k+1))*U(k) - fp(k+1)*U(k+1) + ! = dp(k)*u(k) + ! + ! Here u and U is the variable to be diffused at old and new + ! time-level, respectively. + + ! Diffusive interface fluxes, before multiplying with diffusivity. + do k = 2, kk + fpbase(k) = c/max(dpmin_vdiff, .5_r8*(dp_1d(k - 1) + dp_1d(k))) + enddo + + ! Diffusion of u-component of baroclinic velocity. + do k = 2, kk + fp(k) = nuv_1d(k)*fpbase(k) + enddo + bei = 1._r8/(dp_1d(1) + fp(2)) + u_1d(1) = dp_1d(1)*u_1d(1)*bei + do k = 2, kk - 1 + gam(k) = - fp(k)*bei + bei = 1._r8/(dp_1d(k) + fp(k)*(1._r8 + gam(k)) + fp(k + 1)) + u_1d(k) = (dp_1d(k)*u_1d(k) + fp(k)*u_1d(k - 1))*bei + enddo + gam(kk) = - fp(kk)*bei + bei = 1._r8/(dp_1d(kk) + fp(kk)*(1._r8 + gam(kk))) + u_1d(kk) = (dp_1d(kk)*u_1d(kk) + fp(kk)*u_1d(kk - 1))*bei + do k = kk - 1, 1, - 1 + u_1d(k) = u_1d(k) - gam(k + 1)*u_1d(k + 1) + enddo + + ! 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. + do k = 1, kk + kn = k + nn + dp_1d(k) = dpv(i, j, kn) + v_1d(k) = v(i, j, kn) + nuv_1d(k) = .5_r8*(Kvisc_m(i, j-1, k) + Kvisc_m(i, j, k)) + enddo + + ! Vertical diffusion equations are solved by backward integration + ! forming a tridiagonal set of equations: + ! + ! - fp(k)*U(k-1) + (dp(k) + fp(k) + fp(k+1))*U(k) - fp(k+1)*U(k+1) + ! = dp(k)*u(k) + ! + ! Here u and U is the variable to be diffused at old and new + ! time-level, respectively. + + ! Diffusive interface fluxes, before multiplying with diffusivity. + do k = 2, kk + fpbase(k) = c/max(dpmin_vdiff, .5_r8*(dp_1d(k - 1) + dp_1d(k))) + enddo + + ! Diffusion of v-component of baroclinic velocity. + do k = 2, kk + fp(k) = nuv_1d(k)*fpbase(k) + enddo + bei = 1._r8/(dp_1d(1) + fp(2)) + v_1d(1) = dp_1d(1)*v_1d(1)*bei + do k = 2, kk - 1 + gam(k) = - fp(k)*bei + bei = 1._r8/(dp_1d(k) + fp(k)*(1._r8 + gam(k)) + fp(k + 1)) + v_1d(k) = (dp_1d(k)*v_1d(k) + fp(k)*v_1d(k - 1))*bei + enddo + gam(kk) = - fp(kk)*bei + bei = 1._r8/(dp_1d(kk) + fp(kk)*(1._r8 + gam(kk))) + v_1d(kk) = (dp_1d(kk)*v_1d(kk) + fp(kk)*v_1d(kk - 1))*bei + do k = kk - 1, 1, - 1 + v_1d(k) = v_1d(k) - gam(k + 1)*v_1d(k + 1) + enddo + + ! 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,*) 'cntiso_hybrid_vdiffm:' + endif + call chksummsk(u, iu, 2*kk, 'u') + call chksummsk(v, iv, 2*kk, 'v') + endif + + end subroutine cntiso_hybrid_vdiffm + +end module mod_vdiff diff --git a/phy/numerical_bounds.F90 b/phy/numerical_bounds.F90 index f4579056..a38c5b55 100644 --- a/phy/numerical_bounds.F90 +++ b/phy/numerical_bounds.F90 @@ -1,5 +1,5 @@ ! ------------------------------------------------------------------------------ -! Copyright (C) 2020 Mats Bentsen +! Copyright (C) 2020-2022 Mats Bentsen, Mehmet Ilicak ! ! This file is part of BLOM. ! @@ -23,7 +23,7 @@ subroutine numerical_bounds ! --------------------------------------------------------------------------- use mod_types, only: r8 - use mod_constants, only: g, spval + use mod_constants, only: g, spval, L_mks2cgs use mod_time, only: baclin use mod_xc use mod_grid, only: scqx, scqy, scpx, scpy, scuy, scvx, scp2, depths @@ -61,8 +61,8 @@ subroutine numerical_bounds do i = max(1, ifp(j, l)), min(ii, ilp(j, l)) btdtmx = min(btdtmx, & scpx(i, j)*scpy(i, j) & - /sqrt(g*depths(i, j)*100._r8*( scpx(i, j)*scpx(i, j) & - + scpy(i, j)*scpy(i, j)))) + /sqrt(g*depths(i, j)*L_mks2cgs*( scpx(i, j)*scpx(i, j) & + + scpy(i, j)*scpy(i, j)))) enddo enddo enddo diff --git a/phy/rdlim.F b/phy/rdlim.F index 682a242f..f4d00f76 100644 --- a/phy/rdlim.F +++ b/phy/rdlim.F @@ -1,5 +1,5 @@ ! ------------------------------------------------------------------------------ -! Copyright (C) 2008-2021 Mats Bentsen, Mehmet Ilicak, Ingo Bethke, +! Copyright (C) 2008-2022 Mats Bentsen, Mehmet Ilicak, Ingo Bethke, ! Ping-Gin Chiu, Aleksi Nummelin ! ! This file is part of BLOM. @@ -25,6 +25,7 @@ subroutine rdlim c --- ------------------------------------------------------------------ c use mod_config, only: expcnf, runid, inst_suffix + use mod_constants, only: epsilt use mod_calendar, only: date_type, daynum_diff, calendar_errstr, . calendar_noerr, operator(==), operator(<), . operator(/=) @@ -46,17 +47,18 @@ subroutine rdlim . trxday, srxday, trxdpt, srxdpt, trxlim, . srxlim, srxbal, sprfac use mod_swabs, only: swamth, jwtype, chlopt, ccfile - use mod_diffusion, only: egc, eggam, eglsmn, egmndf, egmxdf, - . egidfq, ri0, bdmc1, bdmc2, tkepf, bdmtyp, - . edsprs, eitmth, edritp, edwmth + use mod_diffusion, only: readnml_diffusion use mod_mxlayr, only: rm0, rm5, ce, mlrttp use mod_niw, only: niwgf, niwbf, niwlf use mod_tidaldissip, only: tdfile use mod_dia use mod_ben02, only: atm_path, atm_path_len + use mod_vcoord, only: vcoord_type_tag, isopyc_bulkml, + . cntiso_hybrid, readnml_vcoord use mod_cesm, only: runid_cesm, ocn_cpl_dt_cesm, nstep_in_cpl, . smtfrc use mod_pointtest, only: itest, jtest + use mod_budget, only: cnsvdi use mod_checksum, only: csdiag c implicit none @@ -70,20 +72,21 @@ subroutine rdlim . grfile,icfile,pref,baclin,batrop, . mdv2hi,mdv2lo,mdv4hi,mdv4lo,mdc2hi,mdc2lo, . vsc2hi,vsc2lo,vsc4hi,vsc4lo,cbar,cb,cwbdts,cwbdls, - . mommth,eitmth,edritp,bmcmth,rmpmth,edwmth,mlrttp, - . edsprs,egc,eggam,eglsmn,egmndf,egmxdf,egidfq,ri0, - . rm0,rm5,ce,bdmtyp,bdmc1,bdmc2,tdfile,tkepf,niwgf,niwbf,niwlf, + . mommth,bmcmth,rmpmth,mlrttp, + . rm0,rm5,ce,tdfile,niwgf,niwbf,niwlf, . swamth,jwtype,chlopt,ccfile, . trxday,srxday,trxdpt,srxdpt,trxlim,srxlim, . aptflx,apsflx,ditflx,disflx,srxbal,scfile,smtfrc,sprfac, . atm_path, . itest,jtest, + . cnsvdi, + . csdiag, . rstfrq,rstfmt,rstcmp,iotype c -c --- read limits and diaphy namelists +c --- read limits namelist +c if (mnproc.eq.1) then c - GLB_AVEPERIO=-999 nlfnm='ocn_in'//trim(inst_suffix) inquire(file=nlfnm,exist=fexist) if (fexist) then @@ -101,7 +104,6 @@ subroutine rdlim endif endif read (unit=nfu,nml=LIMITS) - read (unit=nfu,nml=DIAPHY) close (unit=nfu) c c --- - print limits namelist to stdout @@ -134,27 +136,12 @@ subroutine rdlim write (lp,*) 'CWBDTS',CWBDTS write (lp,*) 'CWBDLS',CWBDLS write (lp,*) 'MOMMTH ',trim(MOMMTH) - write (lp,*) 'EITMTH ',trim(EITMTH) - write (lp,*) 'EDRITP ',trim(EDRITP) write (lp,*) 'BMCMTH ',trim(BMCMTH) write (lp,*) 'RMPMTH ',trim(RMPMTH) - write (lp,*) 'EDWMTH ',trim(EDWMTH) - write (lp,*) 'EDSPRS ',EDSPRS - write (lp,*) 'EGC',EGC - write (lp,*) 'EGGAM',EGGAM - write (lp,*) 'EGLSMN',EGLSMN - write (lp,*) 'EGMNDF',EGMNDF - write (lp,*) 'EGMXDF',EGMXDF - write (lp,*) 'EGIDFQ',EGIDFQ - write (lp,*) 'RI0',RI0 write (lp,*) 'RM0',RM0 write (lp,*) 'RM5',RM5 write (lp,*) 'CE',CE - write (lp,*) 'BDMTYP',BDMTYP - write (lp,*) 'BDMC1',BDMC1 - write (lp,*) 'BDMC2',BDMC2 write (lp,*) 'TDFILE',trim(TDFILE) - write (lp,*) 'TKEPF',TKEPF write (lp,*) 'NIWGF',NIWGF write (lp,*) 'NIWBF',NIWBF write (lp,*) 'NIWLF',NIWLF @@ -179,22 +166,137 @@ subroutine rdlim write (lp,*) 'ATM_PATH ',trim(ATM_PATH) write (lp,*) 'ITEST',ITEST write (lp,*) 'JTEST',JTEST + write (lp,*) 'CNSVDI',CNSVDI + write (lp,*) 'CSDIAG',CSDIAG write (lp,*) 'RSTFRQ',RSTFRQ write (lp,*) 'RSTFMT',RSTFMT write (lp,*) 'RSTCMP',RSTCMP write (lp,*) 'IOTYPE',IOTYPE + write (lp,*) +c + endif +c +c --- broadcast variables set by limits namelist +c + call xcbcst(nday1) + call xcbcst(nday2) + call xcbcst(idate) + call xcbcst(idate0) + call xcbcst(runid) + call xcbcst(expcnf) + call xcbcst(runtyp) + call xcbcst(grfile) + call xcbcst(icfile) + call xcbcst(pref) + call xcbcst(baclin) + call xcbcst(batrop) + call xcbcst(mdv2hi) + call xcbcst(mdv2lo) + call xcbcst(mdv4hi) + call xcbcst(mdv4lo) + call xcbcst(mdc2hi) + call xcbcst(mdc2lo) + call xcbcst(vsc2hi) + call xcbcst(vsc2lo) + call xcbcst(vsc4hi) + call xcbcst(vsc4lo) + call xcbcst(cbar) + call xcbcst(cb) + call xcbcst(cwbdts) + call xcbcst(cwbdls) + call xcbcst(mommth) + call xcbcst(bmcmth) + call xcbcst(rmpmth) + call xcbcst(mlrttp) + call xcbcst(rm0) + call xcbcst(rm5) + call xcbcst(ce) + call xcbcst(tdfile) + call xcbcst(niwgf) + call xcbcst(niwbf) + call xcbcst(niwlf) + call xcbcst(swamth) + call xcbcst(jwtype) + call xcbcst(chlopt) + call xcbcst(ccfile) + call xcbcst(trxday) + call xcbcst(srxday) + call xcbcst(trxdpt) + call xcbcst(srxdpt) + call xcbcst(trxlim) + call xcbcst(srxlim) + call xcbcst(aptflx) + call xcbcst(apsflx) + call xcbcst(ditflx) + call xcbcst(disflx) + call xcbcst(srxbal) + call xcbcst(scfile) + call xcbcst(smtfrc) + call xcbcst(sprfac) + call xcbcst(atm_path) + call xcbcst(itest) + call xcbcst(jtest) + call xcbcst(cnsvdi) + call xcbcst(csdiag) + call xcbcst(rstfrq) + call xcbcst(rstfmt) + call xcbcst(rstcmp) + call xcbcst(iotype) +c +c --- read vertical coordinate namelist variables + call readnml_vcoord +c +c --- read diffusion namelist variables + call readnml_diffusion +c +c --- read diaphy namelist c -c --- - determine number of io groups and print diaphy namelist + if (mnproc.eq.1) then +c + GLB_AVEPERIO(:)=-999 + open (unit=nfu,file=nlfnm,status='old',action='read',recl=80) + read (unit=nfu,nml=DIAPHY,iostat=ios) + close (unit=nfu) +c +c --- - determine number of io groups nphy=0 do n=1,nphymax if (GLB_AVEPERIO(n).ne.-999) nphy=nphy+1 enddo +c +c --- - modify diaphy namelist variables based on dependency with other +c --- - variables set in namelists + select case (vcoord_type_tag) + case (isopyc_bulkml) + LYR_DIFVMO(1:nphy)=0 + LYR_DIFVHO(1:nphy)=0 + LYR_DIFVSO(1:nphy)=0 + LVL_DIFVMO(1:nphy)=0 + LVL_DIFVHO(1:nphy)=0 + LVL_DIFVSO(1:nphy)=0 + case (cntiso_hybrid) + H2D_IDKEDT(1:nphy)=0 + H2D_MTKEUS(1:nphy)=0 + H2D_MTKENI(1:nphy)=0 + H2D_MTKEBF(1:nphy)=0 + H2D_MTKERS(1:nphy)=0 + H2D_MTKEPE(1:nphy)=0 + 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.eq.0.) then H2D_SURRLX(1:nphy)=0 endif if (srxday.eq.0.) then H2D_SALRLX(1:nphy)=0 endif +c +c --- - print diaphy namelist write (lp,*) write (lp,*) 'rdlim: BLOM DIAPHY NAMELIST GROUP:' write (lp,*) 'GLB_FNAMETAG',GLB_FNAMETAG(1:nphy) @@ -219,8 +321,6 @@ subroutine rdlim write (lp,*) 'H2D_LIP ',H2D_LIP(1:nphy) write (lp,*) 'H2D_MAXMLD ',H2D_MAXMLD(1:nphy) write (lp,*) 'H2D_MLD ',H2D_MLD(1:nphy) - write (lp,*) 'H2D_MLDU ',H2D_MLDU(1:nphy) - write (lp,*) 'H2D_MLDV ',H2D_MLDV(1:nphy) write (lp,*) 'H2D_MLTS ',H2D_MLTS(1:nphy) write (lp,*) 'H2D_MLTSMN ',H2D_MLTSMN(1:nphy) write (lp,*) 'H2D_MLTSMX ',H2D_MLTSMX(1:nphy) @@ -232,8 +332,6 @@ subroutine rdlim write (lp,*) 'H2D_MTKEPE ',H2D_MTKEPE(1:nphy) write (lp,*) 'H2D_MTKEKE ',H2D_MTKEKE(1:nphy) write (lp,*) 'H2D_MTY ',H2D_MTY(1:nphy) - write (lp,*) 'H2D_MXLU ',H2D_MXLU(1:nphy) - write (lp,*) 'H2D_MXLV ',H2D_MXLV(1:nphy) write (lp,*) 'H2D_NSF ',H2D_NSF(1:nphy) write (lp,*) 'H2D_PBOT ',H2D_PBOT(1:nphy) write (lp,*) 'H2D_PSRF ',H2D_PSRF(1:nphy) @@ -269,9 +367,14 @@ subroutine rdlim write (lp,*) 'H2D_ZTX ',H2D_ZTX(1:nphy) write (lp,*) 'LYR_BFSQ ',LYR_BFSQ(1:nphy) write (lp,*) 'LYR_DIFDIA ',LYR_DIFDIA(1:nphy) + write (lp,*) 'LYR_DIFVMO ',LYR_DIFVMO(1:nphy) + write (lp,*) 'LYR_DIFVHO ',LYR_DIFVHO(1:nphy) + write (lp,*) 'LYR_DIFVSO ',LYR_DIFVSO(1:nphy) write (lp,*) 'LYR_DIFINT ',LYR_DIFINT(1:nphy) write (lp,*) 'LYR_DIFISO ',LYR_DIFISO(1:nphy) write (lp,*) 'LYR_DP ',LYR_DP(1:nphy) + write (lp,*) 'LYR_DPU ',LYR_DPU(1:nphy) + write (lp,*) 'LYR_DPV ',LYR_DPV(1:nphy) write (lp,*) 'LYR_DZ ',LYR_DZ(1:nphy) write (lp,*) 'LYR_SALN ',LYR_SALN(1:nphy) write (lp,*) 'LYR_TEMP ',LYR_TEMP(1:nphy) @@ -301,6 +404,14 @@ subroutine rdlim write (lp,*) 'LYR_GLS_PSI ',LYR_GLS_PSI(1:nphy) write (lp,*) 'LYR_IDLAGE ',LYR_IDLAGE(1:nphy) write (lp,*) 'LVL_BFSQ ',LVL_BFSQ(1:nphy) + write (lp,*) 'LVL_DIFDIA ',LVL_DIFDIA(1:nphy) + write (lp,*) 'LVL_DIFVMO ',LVL_DIFVMO(1:nphy) + write (lp,*) 'LVL_DIFVHO ',LVL_DIFVHO(1:nphy) + write (lp,*) 'LVL_DIFVSO ',LVL_DIFVSO(1:nphy) + write (lp,*) 'LVL_DIFINT ',LVL_DIFINT(1:nphy) + write (lp,*) 'LVL_DIFISO ',LVL_DIFISO(1:nphy) + write (lp,*) 'LVL_DIFISO ',LVL_DIFISO(1:nphy) + write (lp,*) 'LVL_DZ ',LVL_DZ(1:nphy) write (lp,*) 'LVL_SALN ',LVL_SALN(1:nphy) write (lp,*) 'LVL_TEMP ',LVL_TEMP(1:nphy) write (lp,*) 'LVL_TRC ',LVL_TRC(1:nphy) @@ -349,85 +460,7 @@ subroutine rdlim c endif c -c --- broadcast variables set by limits and diaphy namelists -c - call xcbcst(nday1) - call xcbcst(nday2) - call xcbcst(idate) - call xcbcst(idate0) - call xcbcst(runid) - call xcbcst(expcnf) - call xcbcst(runtyp) - call xcbcst(grfile) - call xcbcst(icfile) - call xcbcst(pref) - call xcbcst(baclin) - call xcbcst(batrop) - call xcbcst(mdv2hi) - call xcbcst(mdv2lo) - call xcbcst(mdv4hi) - call xcbcst(mdv4lo) - call xcbcst(mdc2hi) - call xcbcst(mdc2lo) - call xcbcst(vsc2hi) - call xcbcst(vsc2lo) - call xcbcst(vsc4hi) - call xcbcst(vsc4lo) - call xcbcst(cbar) - call xcbcst(cb) - call xcbcst(cwbdts) - call xcbcst(cwbdls) - call xcbcst(mommth) - call xcbcst(eitmth) - call xcbcst(edritp) - call xcbcst(bmcmth) - call xcbcst(rmpmth) - call xcbcst(edwmth) - call xcbcst(mlrttp) - call xcbcst(edsprs) - call xcbcst(egc) - call xcbcst(eggam) - call xcbcst(eglsmn) - call xcbcst(egmndf) - call xcbcst(egmxdf) - call xcbcst(egidfq) - call xcbcst(ri0) - call xcbcst(rm0) - call xcbcst(rm5) - call xcbcst(ce) - call xcbcst(bdmtyp) - call xcbcst(bdmc1) - call xcbcst(bdmc2) - call xcbcst(tdfile) - call xcbcst(tkepf) - call xcbcst(niwgf) - call xcbcst(niwbf) - call xcbcst(niwlf) - call xcbcst(swamth) - call xcbcst(jwtype) - call xcbcst(chlopt) - call xcbcst(ccfile) - call xcbcst(trxday) - call xcbcst(srxday) - call xcbcst(trxdpt) - call xcbcst(srxdpt) - call xcbcst(trxlim) - call xcbcst(srxlim) - call xcbcst(aptflx) - call xcbcst(apsflx) - call xcbcst(ditflx) - call xcbcst(disflx) - call xcbcst(srxbal) - call xcbcst(scfile) - call xcbcst(smtfrc) - call xcbcst(sprfac) - call xcbcst(atm_path) - call xcbcst(itest) - call xcbcst(jtest) - call xcbcst(rstfrq) - call xcbcst(rstfmt) - call xcbcst(rstcmp) - call xcbcst(iotype) +c --- broadcast variables set by diaphy namelist c call xcbcst(H2D_ABSWND) call xcbcst(H2D_ALB) @@ -446,8 +479,6 @@ subroutine rdlim call xcbcst(H2D_LIP) call xcbcst(H2D_MAXMLD) call xcbcst(H2D_MLD) - call xcbcst(H2D_MLDU) - call xcbcst(H2D_MLDV) call xcbcst(H2D_MLTS) call xcbcst(H2D_MLTSMN) call xcbcst(H2D_MLTSMX) @@ -459,8 +490,6 @@ subroutine rdlim call xcbcst(H2D_MTKEPE) call xcbcst(H2D_MTKEKE) call xcbcst(H2D_MTY) - call xcbcst(H2D_MXLU) - call xcbcst(H2D_MXLV) call xcbcst(H2D_NSF) call xcbcst(H2D_PBOT) call xcbcst(H2D_PSRF) @@ -496,6 +525,9 @@ subroutine rdlim call xcbcst(H2D_ZTX) call xcbcst(LYR_BFSQ) call xcbcst(LYR_DIFDIA) + call xcbcst(LYR_DIFVMO) + call xcbcst(LYR_DIFVHO) + call xcbcst(LYR_DIFVSO) call xcbcst(LYR_DIFINT) call xcbcst(LYR_DIFISO) call xcbcst(LYR_DP) @@ -531,6 +563,9 @@ subroutine rdlim call xcbcst(LYR_IDLAGE) call xcbcst(LVL_BFSQ) call xcbcst(LVL_DIFDIA) + call xcbcst(LVL_DIFVMO) + call xcbcst(LVL_DIFVHO) + call xcbcst(LVL_DIFVSO) call xcbcst(LVL_DIFINT) call xcbcst(LVL_DIFISO) call xcbcst(LVL_DZ) @@ -698,7 +733,7 @@ subroutine rdlim c c --- - verify integer number of baroclinic time steps per coupling c --- - interval - if (mod(ocn_cpl_dt_cesm+epsil,baclin).gt.2.*epsil) then + if (mod(ocn_cpl_dt_cesm+epsilt,baclin).gt.2.*epsilt) then if (mnproc.eq.1) then write (lp,*) 'rdlim: must have an integer number of '// . 'baroclinic time steps in a coupling' diff --git a/phy/restart_rd.F b/phy/restart_rd.F index ef8d7deb..4a9edc36 100644 --- a/phy/restart_rd.F +++ b/phy/restart_rd.F @@ -1,5 +1,5 @@ ! ------------------------------------------------------------------------------ -! Copyright (C) 2006-2021 Mats Bentsen, Mehmet Ilicak, Alok Kumar Gupta, +! Copyright (C) 2006-2022 Mats Bentsen, Mehmet Ilicak, Alok Kumar Gupta, ! Jerry Tjiputra, Ping-Gin Chiu, Aleksi Nummelin, ! Jörg Schwinger ! @@ -25,12 +25,14 @@ subroutine restart_rd c --- Read initial conditions from restart file c --- ------------------------------------------------------------------ c - use mod_config, only: expcnf, runid, inst_suffix + use mod_config, only: expcnf, runid, inst_suffix, resume_flag use mod_calendar, only: date_type, daynum_diff, operator(/=) use mod_time, only: date0, date, nday1, nstep0, nstep1 use mod_xc + use mod_vcoord, only: vcoord_type_tag, isopyc_bulkml, + . cntiso_hybrid use mod_inicon, only: icfile - use mod_state, only: u, v, dp, temp, saln, sigma, + use mod_state, only: u, v, dp, dpu, dpv, temp, saln, sigma, . uflx, vflx, utflx, vtflx, usflx, vsflx, . phi, ubflxs, vbflxs, . ub, vb, pb, pbu, pbv, ubflxs_p, vbflxs_p, @@ -46,6 +48,8 @@ subroutine restart_rd . prfac, eiacc, pracc, . flxco2, flxdms, flxbrf, ustarb, buoyfl use mod_niw, only: uml, vml, umlres, vmlres + use mod_difest, only: OBLdepth + use mod_diffusion, only: difiso, Kvisc_m, Kdiff_t, Kdiff_s 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, ustarw_da, @@ -79,7 +83,7 @@ subroutine restart_rd c c --- open restart file and adjust time information if needed c - if (nday1+nint(time0).eq.0) then + if (nday1+nint(time0).eq.0 .and. (.not.resume_flag)) then c c --- - open restart file for initial conditions and adjust integration c --- - time corresponding to start date @@ -397,7 +401,6 @@ subroutine restart_rd call ncread('phi',phi(1-nbdy,1-nbdy,kk+1),ip,1,0.) call ncread('sealv',sealv,ip,1,0.) call ncread('ustar',ustar,ip,1,0.) - call ncread('buoyfl',buoyfl,ip,1,0.) call ncread('kfpla',rkfpla,ip,1,0.) call ncread('ficem',ficem,ip,1,0.) c @@ -444,6 +447,17 @@ subroutine restart_rd write (lp,*) . 'will be initialized to zero.' endif +c + if (vcoord_type_tag.eq.isopyc_bulkml) then + call ncread('buoyfl',buoyfl,ip,1,0.) + endif +c + if (vcoord_type_tag.eq.cntiso_hybrid) then + call ncread('dpu',dpu,iu,1,0.) + call ncread('dpv',dpv,iv,1,0.) + call ncread('difiso',difiso,ip,1,0.) + call ncread('OBLdepth',OBLdepth,ip,1,0.) + endif c if (sprfac) then vexist=ncinqa('prfac') @@ -663,14 +677,6 @@ subroutine restart_rd . phyh2d(1-nbdy,1-nbdy,ACC_TAUX(n)),iuu,1,0.) if (ACC_TAUY(n).ne.0) call ncread('tauy_phy'//c2, . phyh2d(1-nbdy,1-nbdy,ACC_TAUY(n)),ivv,1,0.) - if (ACC_MXLU(n).ne.0) call ncread('mxlu_phy'//c2, - . phyh2d(1-nbdy,1-nbdy,ACC_MXLU(n)),iuu,1,0.) - if (ACC_MXLV(n).ne.0) call ncread('mxlv_phy'//c2, - . phyh2d(1-nbdy,1-nbdy,ACC_MXLV(n)),ivv,1,0.) - if (ACC_MLDU(n).ne.0) call ncread('mldu_phy'//c2, - . phyh2d(1-nbdy,1-nbdy,ACC_MLDU(n)),iuu,1,0.) - if (ACC_MLDV(n).ne.0) call ncread('mldv_phy'//c2, - . phyh2d(1-nbdy,1-nbdy,ACC_MLDV(n)),ivv,1,0.) if (ACC_UICE(n).ne.0) call ncread('uice_phy'//c2, . phyh2d(1-nbdy,1-nbdy,ACC_UICE(n)),iuu,1,0.) if (ACC_VICE(n).ne.0) call ncread('vice_phy'//c2, @@ -949,7 +955,7 @@ subroutine restart_rd call settemmin c #ifdef TRC - call restart_trcrd(rstfnm) + if (.not.resume_flag) call restart_trcrd(rstfnm) #endif c if (ditflx) then diff --git a/phy/restart_wt.F b/phy/restart_wt.F index 00601297..b843888e 100644 --- a/phy/restart_wt.F +++ b/phy/restart_wt.F @@ -1,5 +1,5 @@ ! ------------------------------------------------------------------------------ -! Copyright (C) 2006-2021 Mats Bentsen, Mehmet Ilicak, Alok Kumar Gupta, +! Copyright (C) 2006-2022 Mats Bentsen, Mehmet Ilicak, Alok Kumar Gupta, ! Ingo Bethke, Jerry Tjiputra, Ping-Gin Chiu, ! Aleksi Nummelin, Jörg Schwinger ! @@ -28,7 +28,9 @@ subroutine restart_wt use mod_config, only: expcnf, runid, inst_suffix use mod_time, only: date0, date, nstep, nstep_in_day, nday_of_year use mod_xc - use mod_state, only: u, v, dp, temp, saln, sigma, + use mod_vcoord, only: vcoord_type_tag, isopyc_bulkml, + . cntiso_hybrid + use mod_state, only: u, v, dp, dpu, dpv, temp, saln, sigma, . uflx, vflx, utflx, vtflx, usflx, vsflx, . phi, ubflxs, vbflxs, . ub, vb, pb, pbu, pbv, ubflxs_p, vbflxs_p, @@ -44,6 +46,8 @@ subroutine restart_wt . prfac, eiacc, pracc, . flxco2, flxdms, ustarb, buoyfl,flxbrf use mod_niw, only: uml, vml, umlres, vmlres + use mod_difest, only: OBLdepth + use mod_diffusion, only: difiso, Kvisc_m, Kdiff_t, Kdiff_s 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, ustarw_da, @@ -187,6 +191,7 @@ subroutine restart_wt call ncdims('k3',3) call ncdims('k4',4) call ncdims('kk',kk) + call ncdims('kkp1',kk+1) call ncdims('kk2',2*kk) call ncdims('plev',ddm) call ncputr('plev',depthslev) @@ -278,13 +283,23 @@ subroutine restart_wt call wrtrst('phi',trim(c5p)//' time',phi(1-nbdy,1-nbdy,kk+1),ip) call wrtrst('sealv',trim(c5p)//' time',sealv,ip) call wrtrst('ustar',trim(c5p)//' time',ustar,ip) - call wrtrst('buoyfl',trim(c5p)//' time',buoyfl,ip) call wrtrst('kfpla',trim(c5p)//' k2 time',rkfpla,ip) call wrtrst('ficem',trim(c5p)//' time',ficem,ip) call wrtrst('uml',trim(c5u)//' k4 time',uml,iuu) call wrtrst('vml',trim(c5v)//' k4 time',vml,ivv) call wrtrst('umlres',trim(c5u)//' k2 time',umlres,iuu) call wrtrst('vmlres',trim(c5v)//' k2 time',vmlres,ivv) +c + if (vcoord_type_tag.eq.isopyc_bulkml) then + call wrtrst('buoyfl',trim(c5p)//' time',buoyfl,ip) + endif +c + if (vcoord_type_tag.eq.cntiso_hybrid) then + call wrtrst('dpu',trim(c5p)//' kk2 time',dpu,iu) + call wrtrst('dpv',trim(c5p)//' kk2 time',dpv,iv) + call wrtrst('difiso',trim(c5p)//' kk time',difiso,ip) + call wrtrst('OBLdepth',trim(c5p)//' time',OBLdepth,ip) + endif c if (sprfac) then call wrtrst('eiacc',trim(c5p)//' time',eiacc,ip) @@ -382,14 +397,6 @@ subroutine restart_wt . trim(c5u)//' time',phyh2d(1-nbdy,1-nbdy,ACC_TAUX(n)),iuu) if (ACC_TAUY(n) .ne.0) call wrtrst('tauy_phy'//c2, . trim(c5v)//' time',phyh2d(1-nbdy,1-nbdy,ACC_TAUY(n)),ivv) - if (ACC_MXLU(n) .ne.0) call wrtrst('mxlu_phy'//c2, - . trim(c5u)//' time',phyh2d(1-nbdy,1-nbdy,ACC_MXLU(n)),iuu) - if (ACC_MXLV(n) .ne.0) call wrtrst('mxlv_phy'//c2, - . trim(c5v)//' time',phyh2d(1-nbdy,1-nbdy,ACC_MXLV(n)),ivv) - if (ACC_MLDU(n) .ne.0) call wrtrst('mldu_phy'//c2, - . trim(c5u)//' time',phyh2d(1-nbdy,1-nbdy,ACC_MLDU(n)),iuu) - if (ACC_MLDV(n) .ne.0) call wrtrst('mldv_phy'//c2, - . trim(c5v)//' time',phyh2d(1-nbdy,1-nbdy,ACC_MLDV(n)),ivv) if (ACC_UICE(n) .ne.0) call wrtrst('uice_phy'//c2, . trim(c5u)//' time',phyh2d(1-nbdy,1-nbdy,ACC_UICE(n)),iuu) if (ACC_VICE(n) .ne.0) call wrtrst('vice_phy'//c2, @@ -880,13 +887,23 @@ subroutine defvar_restart(c5p,c5u,c5v,c5q) call defvarrst('phi',trim(c5p)//' time') call defvarrst('sealv',trim(c5p)//' time') call defvarrst('ustar',trim(c5p)//' time') - call defvarrst('buoyfl',trim(c5p)//' time') call defvarrst('kfpla',trim(c5p)//' k2 time') call defvarrst('ficem',trim(c5p)//' time') call defvarrst('uml',trim(c5u)//' k4 time') call defvarrst('vml',trim(c5v)//' k4 time') call defvarrst('umlres',trim(c5u)//' k2 time') call defvarrst('vmlres',trim(c5v)//' k2 time') +c + if (vcoord_type_tag.eq.isopyc_bulkml) then + call defvarrst('buoyfl',trim(c5p)//' time') + endif +c + if (vcoord_type_tag.eq.cntiso_hybrid) then + call defvarrst('dpu',trim(c5p)//' kk2 time') + call defvarrst('dpv',trim(c5p)//' kk2 time') + call defvarrst('difiso',trim(c5p)//' kk time') + call defvarrst('OBLdepth',trim(c5p)//' time') + endif c if (sprfac) then call defvarrst('eiacc',trim(c5p)//' time') @@ -980,14 +997,6 @@ subroutine defvar_restart(c5p,c5u,c5v,c5q) if (ACC_TAUX(n) .ne.0) call defvarrst('taux_phy'//c2, . trim(c5u)//' time') if (ACC_TAUY(n) .ne.0) call defvarrst('tauy_phy'//c2, - . trim(c5v)//' time') - if (ACC_MXLU(n) .ne.0) call defvarrst('mxlu_phy'//c2, - . trim(c5u)//' time') - if (ACC_MXLV(n) .ne.0) call defvarrst('mxlv_phy'//c2, - . trim(c5v)//' time') - if (ACC_MLDU(n) .ne.0) call defvarrst('mldu_phy'//c2, - . trim(c5u)//' time') - if (ACC_MLDV(n) .ne.0) call defvarrst('mldv_phy'//c2, . trim(c5v)//' time') if (ACC_UICE(n) .ne.0) call defvarrst('uice_phy'//c2, . trim(c5u)//' time') diff --git a/phy/sfcstr.F90 b/phy/sfcstr.F90 index 89434855..edf3423c 100644 --- a/phy/sfcstr.F90 +++ b/phy/sfcstr.F90 @@ -22,8 +22,8 @@ subroutine sfcstr(m, n, mm, nn, k1m, k1n) ! Get surface stress. ! --------------------------------------------------------------------------- - use mod_config, only: expcnf - use mod_xc, only: lp, mnproc, xcstop + use mod_config, only: expcnf + use mod_xc, only: lp, mnproc, xcstop implicit none diff --git a/pkgs/CVMix-src b/pkgs/CVMix-src new file mode 160000 index 00000000..9423197f --- /dev/null +++ b/pkgs/CVMix-src @@ -0,0 +1 @@ +Subproject commit 9423197f894112edfcb1502245f7d7b873d551f9 diff --git a/pkgs/meson.build b/pkgs/meson.build new file mode 100644 index 00000000..3b8fd0fa --- /dev/null +++ b/pkgs/meson.build @@ -0,0 +1,10 @@ +sources += files('CVMix-src/src/shared/cvmix_background.F90', +'CVMix-src/src/shared/cvmix_convection.F90', +'CVMix-src/src/shared/cvmix_ddiff.F90', +'CVMix-src/src/shared/cvmix_kinds_and_types.F90', +'CVMix-src/src/shared/cvmix_kpp.F90', +'CVMix-src/src/shared/cvmix_math.F90', +'CVMix-src/src/shared/cvmix_put_get.F90', +'CVMix-src/src/shared/cvmix_shear.F90', +'CVMix-src/src/shared/cvmix_tidal.F90', +'CVMix-src/src/shared/cvmix_utils.F90') diff --git a/single_column/mod_single_column.F90 b/single_column/mod_single_column.F90 index 50d95d33..6017c0d9 100644 --- a/single_column/mod_single_column.F90 +++ b/single_column/mod_single_column.F90 @@ -1,5 +1,5 @@ ! ------------------------------------------------------------------------------ -! Copyright (C) 2021 Mehmet Ilicak, Mats Bentsen +! Copyright (C) 2021-2022 Mehmet Ilicak, Mats Bentsen ! ! This file is part of BLOM. ! @@ -24,9 +24,10 @@ module mod_single_column ! ---------------------------------------------------------------------- use mod_types, only: r8 + use mod_constants, only: L_mks2cgs use mod_xc - use mod_grid, only: sigmar, & - qclon, qclat, pclon, pclat, uclon, uclat, vclon, vclat, & + use mod_vcoord, only: 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, & qlon, qlat, plon, plat, ulon, ulat, vlon, vlat, & @@ -64,13 +65,13 @@ subroutine geoenv_single_column uclat = 0._r8 vclon = 0._r8 vclat = 0._r8 - scqx = 1100000.0_r8 - scqy = 1100000.0_r8 - scpx = 1100000.0_r8 - scpy = 1100000.0_r8 - scux = 1100000.0_r8 - scuy = 1100000.0_r8 - scvx = 1100000.0_r8 + scqx = 11000.0_r8*L_mks2cgs + scqy = 11000.0_r8*L_mks2cgs + scpx = 11000.0_r8*L_mks2cgs + scpy = 11000.0_r8*L_mks2cgs + scux = 11000.0_r8*L_mks2cgs + scuy = 11000.0_r8*L_mks2cgs + scvx = 11000.0_r8*L_mks2cgs scvy = scuy scq2 = scqx*scqy scp2 = scpx*scpy diff --git a/tests/fuk95/limits b/tests/fuk95/limits index 3942bbad..b2dc21d5 100644 --- a/tests/fuk95/limits +++ b/tests/fuk95/limits @@ -34,48 +34,21 @@ ! 'enscon' (Sadourny (1975) enstrophy conserving), 'enecon' ! (Sadourny (1975) energy conserving), 'enedis' (Sadourny ! (1975) energy conserving with some dissipation) (a) -! EITMTH : Eddy-induced transport parameterization method. Valid -! methods: 'intdif', 'gm' (a) -! EDRITP : Type of Richardson number used in eddy diffusivity -! computation. Valid types: 'shear', 'large scale' (a) ! BMCMTH : Baroclinic mass flux correction method. Valid methods: ! 'uc' (upstream column), 'dluc' (depth limited upstream ! column) (a) ! RMPMTH : Method of applying eddy-induced transport in the remap ! transport algorithm. Valid methods: 'eitvel', 'eitflx' (a) -! EDWMTH : Method to estimate eddy diffusivity weight as a function of -! the ration of Rossby radius of deformation to the -! horizontal grid spacing. Valid methods: 'smooth', 'step' (a) ! MLRTTP : Type of mixed layer restratification time scale. Valid ! types: 'variable', 'constant', 'limited' (a) -! EDSPRS : Apply eddy mixing suppression away from steering level (l) -! EGC : Parameter c in Eden and Greatbatch (2008) parameterization (f) -! EGGAM : Parameter gamma in E. & G. (2008) param. (f) -! EGLSMN : Minimum eddy length scale in E. & G. (2008) param. (cm) (f) -! EGMNDF : Minimum diffusivity in E. & G. (2008) param. (cm**2/s) (f) -! EGMXDF : Maximum diffusivity in E. & G. (2008) param. (cm**2/s) (f) -! EGIDFQ : Factor relating the isopycnal diffusivity to the layer -! interface diffusivity in the Eden and Greatbatch (2008) -! parameterization. egidfq=difint/difiso () (f) -! RI0 : Critical gradient richardson number for shear driven -! vertical mixing () (f) ! RM0 : Efficiency factor of wind TKE generation in the Oberhuber ! (1993) TKE closure () (f) ! RM5 : Efficiency factor of TKE generation by momentum ! entrainment in the Oberhuber (1993) TKE closure () (f) ! CE : Efficiency factor for the restratification by mixed layer ! eddies (Fox-Kemper et al., 2008) () (f) -! BDMTYP : Type of background diapycnal mixing. If bdmtyp=1 the -! background diffusivity is a constant divided by the -! Brunt-Vaisala frequency, if bdmtyp=2 the background -! diffusivity is constant () (i) -! BDMC1 : Background diapycnal diffusivity times buoyancy frequency -! frequency (cm**2/s**2) (f) -! BDMC2 : Background diapycnal diffusivity (cm**2/s) (f) ! TDFILE : Name of file containing tidal wave energy dissipation ! divided by by bottom buoyancy frequency (a) -! TKEPF : Fraction of surface TKE that penetrates beneath mixed layer -! () (f) ! NIWGF : Global factor applied to the energy input by near-intertial ! motions () (f) ! NIWBF : Fraction of near-inertial energy dissipated in the boundary @@ -106,6 +79,8 @@ ! 'ben02syn' (a) ! ITEST : Global i-index of point diagnostics (i) ! JTEST : Global j-index of point diagnostics (i) +! CNSVDI : Conservation diagnostics flag (l) +! CSDIAG : Checksum diagnostics flag (l) ! RSTFRQ : Restart frequency in days (30=1month,365=1year) (i) ! RSTFMT : Format of restart file (valid arguments are 0 for classic, ! 1 for 64-bit offset and 2 for netcdf4/hdf5 format) (i) @@ -139,28 +114,13 @@ CWBDTS = 0. CWBDLS = 25. MOMMTH = 'enscon' - EITMTH = 'gm' - EDRITP = 'large scale' BMCMTH = 'uc' RMPMTH = 'eitvel' - EDWMTH = 'smooth' MLRTTP = 'constant' - EDSPRS = .true. - EGC = 0. - EGGAM = 200. - EGLSMN = 4000.e2 - EGMNDF = 0. - EGMXDF = 1500.e4 - EGIDFQ = 1. - RI0 = 1.2 RM0 = 1.2 RM5 = 0. CE = 0. - BDMTYP = 2 - BDMC1 = 5.e-4 - BDMC2 = .15 TDFILE = 'unset' - TKEPF = 0. NIWGF = 0. NIWBF = .35 NIWLF = .5 @@ -191,6 +151,60 @@ IOTYPE = 0 / +! NAMELIST FOR DIFFUSION PARAMETERS +! +! CONTENTS: +! +! EITMTH : Eddy-induced transport parameterization method. Valid +! methods: 'intdif', 'gm' (a) +! EDRITP : Type of Richardson number used in eddy diffusivity +! computation. Valid types: 'shear', 'large scale' (a) +! EDWMTH : Method to estimate eddy diffusivity weight as a function of +! the ration of Rossby radius of deformation to the +! horizontal grid spacing. Valid methods: 'smooth', 'step' (a) +! MLRTTP : Type of mixed layer restratification time scale. Valid +! types: 'variable', 'constant', 'limited' (a) +! EDSPRS : Apply eddy mixing suppression away from steering level (l) +! EGC : Parameter c in Eden and Greatbatch (2008) parameterization (f) +! EGGAM : Parameter gamma in E. & G. (2008) param. (f) +! EGLSMN : Minimum eddy length scale in E. & G. (2008) param. (cm) (f) +! EGMNDF : Minimum diffusivity in E. & G. (2008) param. (cm**2/s) (f) +! EGMXDF : Maximum diffusivity in E. & G. (2008) param. (cm**2/s) (f) +! EGIDFQ : Factor relating the isopycnal diffusivity to the layer +! interface diffusivity in the Eden and Greatbatch (2008) +! parameterization. egidfq=difint/difiso () (f) +! RI0 : Critical gradient richardson number for shear driven +! vertical mixing () (f) +! BDMTYP : Type of background diapycnal mixing. If bdmtyp=1 the +! background diffusivity is a constant divided by the +! Brunt-Vaisala frequency, if bdmtyp=2 the background +! diffusivity is constant () (i) +! BDMC1 : Background diapycnal diffusivity times buoyancy frequency +! frequency (cm**2/s**2) (f) +! BDMC2 : Background diapycnal diffusivity (cm**2/s) (f) +! TKEPF : Fraction of surface TKE that penetrates beneath mixed layer +! () (f) +! LTEDTP : Type of lateral tracer eddy diffusion: Valid methods: +! 'layer', 'neutral'. +&DIFFUSION + EITMTH = 'gm' + EDRITP = 'large scale' + EDWMTH = 'smooth' + EDSPRS = .true. + EGC = 0. + EGGAM = 200. + EGLSMN = 4000.e2 + EGMNDF = 0. + EGMXDF = 1500.e4 + EGIDFQ = 1. + RI0 = 1.2 + BDMTYP = 2 + BDMC1 = 5.e-4 + BDMC2 = .15 + TKEPF = 0. + LTEDTP = 'layer' +/ + ! NAMELIST FOR CHANNEL WIDTH MODIFICATIONS ! ! CONTENTS: @@ -307,8 +321,6 @@ ! LIP - liquid precipitation [kg m-2 s-1] ! MAXMLD - maximum mixed layer depth [m] ! MLD - mixed layer depth [m] -! MLDU - mixed layer depth at u-point [m] -! MLDV - mixed layer depth at v-point [m] ! MLTS - mixed layer thickness using "sigma-t" criterion [m] ! MLTSMN - minimum mixed layer thickness using "sigma-t" criterion [m] ! MLTSMX - maximum mixed layer thickness using "sigma-t" criterion [m] @@ -320,8 +332,6 @@ ! MTKEPE - mixed layer TKE tendency related to pot. energy change [kg s-3] ! MTKEKE - mixed layer TKE tendency related to kin. energy change [kg s-3] ! MTY - wind stress y-component [N m-2] -! MXLU - mixed layer velocity x-component [m s-1] -! MXLV - mixed layer velocity y-component [m s-1] ! NSF - non-solar heat flux [W m-2] ! PBOT - bottom pressure [Pa] ! PSRF - surface pressure [Pa] @@ -356,7 +366,10 @@ ! VICE - ice velocity y-component [m s-1] ! ZTX - wind stress x-component [N m-2] ! BFSQ - buoyancy frequency squared [s-1] -! DIFDIA - diapycnal diffusivity [log10(m2 s-1)] +! DIFDIA - vertical diffusivity [log10(m2 s-1)|m2 s-1] +! DIFVMO - vertical momentum diffusivity [log10(m2 s-1)|m2 s-1] +! DIFVHO - vertical heat diffusivity [log10(m2 s-1)|m2 s-1] +! DIFVSO - vertical salt diffusivity [log10(m2 s-1)|m2 s-1] ! DIFINT - layer interface diffusivity [log10(m2 s-1)] ! DIFISO - isopycnal diffusivity [log10(m2 s-1)] ! DP - layer pressure thickness [Pa] @@ -429,8 +442,6 @@ H2D_LIP = 0, 0 H2D_MAXMLD = 4, 4 H2D_MLD = 0, 4 - H2D_MLDU = 0, 0 - H2D_MLDV = 0, 0 H2D_MLTS = 0, 4 H2D_MLTSMN = 0, 4 H2D_MLTSMX = 0, 4 @@ -442,8 +453,6 @@ H2D_MTKEPE = 0, 4 H2D_MTKEKE = 0, 4 H2D_MTY = 0, 0 - H2D_MXLU = 4, 4 - H2D_MXLV = 4, 4 H2D_NSF = 0, 0 H2D_PBOT = 0, 4 H2D_PSRF = 0, 0 @@ -479,6 +488,9 @@ H2D_ZTX = 0, 0 LYR_BFSQ = 0, 4 LYR_DIFDIA = 0, 4 + LYR_DIFVMO = 0, 4 + LYR_DIFVHO = 0, 4 + LYR_DIFVSO = 0, 0 LYR_DIFINT = 0, 0 LYR_DIFISO = 0, 0 LYR_DP = 0, 4 @@ -512,6 +524,9 @@ LYR_IDLAGE = 0, 4 LVL_BFSQ = 0, 4 LVL_DIFDIA = 0, 4 + LVL_DIFVMO = 0, 4 + LVL_DIFVHO = 0, 4 + LVL_DIFVSO = 0, 0 LVL_DIFINT = 0, 0 LVL_DIFISO = 0, 0 LVL_DZ = 0, 4 diff --git a/trc/mod_tracers.F90 b/trc/mod_tracers.F90 index f539bd23..6952fa40 100644 --- a/trc/mod_tracers.F90 +++ b/trc/mod_tracers.F90 @@ -1,5 +1,5 @@ ! ------------------------------------------------------------------------------ -! Copyright (C) 2007-2020 Mats Bentsen, Jörg Schwinger, Jerry Tjiputra, +! Copyright (C) 2007-2021 Mats Bentsen, Jörg Schwinger, Jerry Tjiputra, ! Alok Kumar Gupta ! ! This file is part of BLOM. From c54de5f48a682c14300a55cfd4bfa632acb3eb9b Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Mon, 20 Mar 2023 17:22:06 +0100 Subject: [PATCH 272/366] Introducing coupling fields in BLOM and iHAMOCC --- hamocc/carchm.F90 | 4 ++-- hamocc/hamocc4bcm.F90 | 52 ++++++++++++++++++++++++++++++++++++++++-- hamocc/hamocc_step.F90 | 5 ++-- phy/mod_forcing.F90 | 13 ++++++++++- 4 files changed, 67 insertions(+), 7 deletions(-) diff --git a/hamocc/carchm.F90 b/hamocc/carchm.F90 index cc3f7cf1..834db30e 100644 --- a/hamocc/carchm.F90 +++ b/hamocc/carchm.F90 @@ -580,7 +580,7 @@ SUBROUTINE CARCHM(kpie,kpje,kpke,kbnd, & atmflx(i,j,iatmco2)=fluxu-fluxd atmflx(i,j,iatmo2)=oxflux atmflx(i,j,iatmn2)=niflux - atmflx(i,j,iatmn2o)=n2oflux + atmflx(i,j,iatmn2o)=n2oflux ! positive to atmosphere [kmol N2O m-2 timestep-1] atmflx(i,j,iatmdms)=dmsflux ! positive to atmosphere [kmol dms m-2 timestep-1] #ifdef cisonew atmflx(i,j,iatmc13)=flux13u-flux13d @@ -598,7 +598,7 @@ SUBROUTINE CARCHM(kpie,kpje,kpke,kbnd, & atmflx(i,j,iatmbromo)=-flx_bromo #endif #ifdef extNcycle - atmflx(i,j,iatmnh3)=-flx_nh3 + atmflx(i,j,iatmnh3)=-flx_nh3 ! positive to atmosphere [kmol NH3 m-2 timestep-1] #endif ! Save up- and downward components of carbon fluxes for output diff --git a/hamocc/hamocc4bcm.F90 b/hamocc/hamocc4bcm.F90 index 48391522..2b2fafcc 100644 --- a/hamocc/hamocc4bcm.F90 +++ b/hamocc/hamocc4bcm.F90 @@ -19,9 +19,10 @@ SUBROUTINE HAMOCC4BCM(kpie,kpje,kpke,kbnd,kplyear,kplmon,kplday,kldtday,& pdlxp,pdlyp,pddpo,prho,pglat,omask, & - dust,rivin,ndep,oafx,pi_ph, & + dust,rivin,ndep,oafx,pi_ph, & pfswr,psicomo,ppao,pfu10,ptho,psao, & - patmco2,pflxco2,pflxdms,patmbromo,pflxbromo) + patmco2,pflxco2,pflxdms,patmbromo,pflxbromo, & + patmn2o,pflxn2o,patmnh3,pflxnh3) !****************************************************************************** ! ! HAMOCC4BGC - main routine of iHAMOCC. @@ -80,6 +81,12 @@ SUBROUTINE HAMOCC4BCM(kpie,kpje,kpke,kbnd,kplyear,kplmon,kplday,kldtday,& ! *REAL* *patmbromo* - atmospheric bromoform concentration [ppt] used in ! fully coupled mode. ! *REAL* *pflxbromo* - Bromoform flux [kg/m^2/s]. +! *REAL* *patmn2o* - atmospheric nitrous oxide concentration [ppt] used in +! fully coupled mode. +! *REAL* *pflxn2o* - Nitrous oxide flux [kg N2O /m^2/s]. +! *REAL* *patmnh3* - atmospheric ammonia concentration [ppt] used in +! fully coupled mode. +! *REAL* *pflxnh3* - Ammonia flux [kg NH3 /m^2/s]. ! !****************************************************************************** use mod_xc, only: mnproc @@ -101,6 +108,9 @@ SUBROUTINE HAMOCC4BCM(kpie,kpje,kpke,kbnd,kplyear,kplmon,kplday,kldtday,& #endif #ifdef CFC use mo_carbch, only: atm_cfc11_nh,atm_cfc11_sh,atm_cfc12_nh,atm_cfc12_sh,atm_sf6_nh,atm_sf6_sh +#endif +#ifdef extNcycle + use mo_param1_bgc, only: iatmn2o,iatmnh3 #endif implicit none @@ -128,6 +138,10 @@ SUBROUTINE HAMOCC4BCM(kpie,kpje,kpke,kbnd,kplyear,kplmon,kplday,kldtday,& REAL, intent(out) :: pflxdms(1-kbnd:kpie+kbnd,1-kbnd:kpje+kbnd) REAL, intent(in) :: patmbromo(1-kbnd:kpie+kbnd,1-kbnd:kpje+kbnd) REAL, intent(out) :: pflxbromo(1-kbnd:kpie+kbnd,1-kbnd:kpje+kbnd) + REAL, intent(in) :: patmn2o(1-kbnd:kpie+kbnd,1-kbnd:kpje+kbnd) + REAL, intent(out) :: pflxn2o(1-kbnd:kpie+kbnd,1-kbnd:kpje+kbnd) + REAL, intent(in) :: patmnh3(1-kbnd:kpie+kbnd,1-kbnd:kpje+kbnd) + REAL, intent(out) :: pflxnh3(1-kbnd:kpie+kbnd,1-kbnd:kpje+kbnd) INTEGER :: i,j,k,l INTEGER :: nspin,it @@ -195,6 +209,24 @@ SUBROUTINE HAMOCC4BCM(kpie,kpje,kpke,kbnd,kplyear,kplmon,kplday,kldtday,& if (mnproc.eq.1) write (io_stdo_bgc,*) 'iHAMOCC: getting bromoform from atm' #endif +#ifdef extNcycle +!$OMP PARALLEL DO PRIVATE(i) + DO j=1,kpje + DO i=1,kpie + IF (patmn2o(i,j).gt.0.) THEN + atm(i,j,iatmn2o)=patmn2o(i,j) + ENDIF + IF (patmnh3(i,j).gt.0.) THEN + atm(i,j,iatmnh3)=patmnh3(i,j) + ENDIF + ENDDO + ENDDO +!$OMP END PARALLEL DO + if (mnproc.eq.1) write (io_stdo_bgc,*) 'iHAMOCC: getting N2O and NH3 from atm' +#endif + + + !-------------------------------------------------------------------- ! Read atmospheric cfc concentrations ! @@ -426,6 +458,22 @@ SUBROUTINE HAMOCC4BCM(kpie,kpje,kpke,kbnd,kplyear,kplmon,kplday,kldtday,& ENDDO ENDDO !$OMP END PARALLEL DO +!-------------------------------------------------------------------- +! Pass nitrous oxide and ammonia fluxes. Convert unit from kmol N2O (NH3)/m2/Delta t to kg/m2/s +! negative values to the atmosphere +!$OMP PARALLEL DO PRIVATE(i) + DO j=1,kpje + DO i=1,kpie +#ifdef extNcycle + if(omask(i,j) .gt. 0.5) pflxn2o(i,j)=-44.013*atmflx(i,j,iatmn2o)/dtbgc ! CONVERSION factor digits ?????? + if(omask(i,j) .gt. 0.5) pflxnh3(i,j)=-17.031*atmflx(i,j,iatmnh3)/dtbgc ! CONVERSION factor digits ?????? +#else + if(omask(i,j) .gt. 0.5) pflxn2o(i,j)=0.0 + if(omask(i,j) .gt. 0.5) pflxnh3(i,j)=0.0 +#endif + ENDDO + ENDDO +!$OMP END PARALLEL DO !-------------------------------------------------------------------- RETURN END diff --git a/hamocc/hamocc_step.F90 b/hamocc/hamocc_step.F90 index 74e12c8b..20913fd6 100644 --- a/hamocc/hamocc_step.F90 +++ b/hamocc/hamocc_step.F90 @@ -27,7 +27,7 @@ subroutine hamocc_step(m,n,mm,nn,k1m,k1n) use mod_grid, only: plat use mod_state, only: temp,saln use mod_forcing, only: swa,slp,abswnd,atmco2,flxco2,flxdms, & - & atmbrf,flxbrf + & atmbrf,flxbrf,atmn2o,flxn2o,atmnh3,flxnh3 use mod_seaice, only: ficem use mo_bgcmean, only: nbgc,bgcwrt, diagfq_bgc,diagmon_bgc, & & diagann_bgc @@ -75,7 +75,8 @@ subroutine hamocc_step(m,n,mm,nn,k1m,k1n) & dust,rivflx,ndep,oafx,pi_ph, & & swa,ficem,slp,abswnd, & & temp(1-nbdy,1-nbdy,1+nn),saln(1-nbdy,1-nbdy,1+nn), & - & atmco2,flxco2,flxdms,atmbrf,flxbrf) + & atmco2,flxco2,flxdms,atmbrf,flxbrf, & + & atmn2o,flxn2o,atmnh3,flxnh3) ! ! --- accumulate fields and write output diff --git a/phy/mod_forcing.F90 b/phy/mod_forcing.F90 index 64b546b3..ac9a7be6 100644 --- a/phy/mod_forcing.F90 +++ b/phy/mod_forcing.F90 @@ -114,7 +114,11 @@ module mod_forcing flxco2, & ! Air-sea CO2 flux [kg m-2 s-1]. flxdms, & ! Sea-air DMS flux [kg m-2 s-1]. flxbrf, & ! sea-air bromoform flux - atmbrf ! atmospheric bromoform concentration + atmbrf, & ! atmospheric bromoform concentration + flxn2o, & ! sea-air nitrous oxide flux [kg N2O m-2 s-1] + atmn2o, & ! atmospheric nitrous oxide concentration [pptv] + flxnh3, & ! sea-air ammonia flux [kg NH3 m-2 s-1] + atmnh3 ! atmospheric ammonia concentration [pptv] real(r8), dimension(1 - nbdy:idm + nbdy,1 - nbdy:jdm + nbdy) :: & @@ -144,6 +148,7 @@ module mod_forcing swa, nsf, hmltfz, lip, sop, eva, rnf, rfi, fmltfz, sfl, ztx, mty, & ustarw, slp, abswnd, lamult, lasl, ustokes, vstokes, & atmco2, flxco2, flxdms, flxbrf, atmbrf, & + atmn2o,flxn2o,atmnh3,flxnh3, & surflx, surrlx, sswflx, salflx, brnflx, salrlx, taux, tauy, & ustar, ustarb, ustar3, buoyfl, t_sw_nonloc, & inivar_forcing, fwbbal @@ -186,6 +191,10 @@ subroutine inivar_forcing flxdms(i, j) = spval atmbrf(i, j) = spval flxbrf(i, j) = spval + atmn2o(i, j) = spval + flxn2o(i, j) = spval + atmnh3(i, j) = spval + flxnh3(i, j) = spval surflx(i, j) = spval surrlx(i, j) = spval sswflx(i, j) = spval @@ -218,6 +227,8 @@ subroutine inivar_forcing flxco2(i, j) = 0._r8 flxdms(i, j) = 0._r8 flxbrf(i, j) = 0._r8 + flxn2o(i, j) = 0._r8 + flxnh3(i, j) = 0._r8 ustar (i, j) = 0._r8 ustarb(i, j) = 0._r8 enddo From 6cc3d38e5085ee62a461a9bdbf3d9982792972a0 Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Mon, 20 Mar 2023 17:40:37 +0100 Subject: [PATCH 273/366] Read and write fluxes in restart files --- phy/restart_rd.F | 23 ++++++++++++++++++++++- phy/restart_wt.F | 7 ++++++- 2 files changed, 28 insertions(+), 2 deletions(-) diff --git a/phy/restart_rd.F b/phy/restart_rd.F index 4a9edc36..7fe13504 100644 --- a/phy/restart_rd.F +++ b/phy/restart_rd.F @@ -46,7 +46,8 @@ subroutine restart_rd use mod_forcing, only: ditflx, disflx, sprfac, . tflxdi, sflxdi, nflxdi, . prfac, eiacc, pracc, - . flxco2, flxdms, flxbrf, ustarb, buoyfl + . flxco2, flxdms, flxbrf,flxn2o,flxnh3, + . ustarb, buoyfl use mod_niw, only: uml, vml, umlres, vmlres use mod_difest, only: OBLdepth use mod_diffusion, only: difiso, Kvisc_m, Kdiff_t, Kdiff_s @@ -572,6 +573,26 @@ subroutine restart_rd write (lp,*) . 'Warning: bromoform flux is not read from restart file and' write (lp,*) + . 'will be initialized to zero.' + endif + vexist=ncinqv('flxn2o') +! call xcbcst(vexist) + if (vexist) then + call ncread('flxn2o',flxn2o,ip,1,0.) + elseif (mnproc.eq.1) then + write (lp,*) + . 'Warning: N2O flux is not read from restart file and' + write (lp,*) + . 'will be initialized to zero.' + endif + vexist=ncinqv('flxnh3') +! call xcbcst(vexist) + if (vexist) then + call ncread('flxnh3',flxnh3,ip,1,0.) + elseif (mnproc.eq.1) then + write (lp,*) + . 'Warning: Ammonia flux is not read from restart file and' + write (lp,*) . 'will be initialized to zero.' endif endif diff --git a/phy/restart_wt.F b/phy/restart_wt.F index b843888e..8df96755 100644 --- a/phy/restart_wt.F +++ b/phy/restart_wt.F @@ -44,7 +44,8 @@ subroutine restart_wt use mod_forcing, only: ditflx, disflx, sprfac, . tflxdi, sflxdi, nflxdi, . prfac, eiacc, pracc, - . flxco2, flxdms, ustarb, buoyfl,flxbrf + . flxco2, flxdms,flxbrf,flxn2o,flxnh3, + . ustarb, buoyfl use mod_niw, only: uml, vml, umlres, vmlres use mod_difest, only: OBLdepth use mod_diffusion, only: difiso, Kvisc_m, Kdiff_t, Kdiff_s @@ -358,6 +359,10 @@ subroutine restart_wt call wrtrst('flxdms',trim(c5p)//' time',flxdms,ip) #ifdef BROMO call wrtrst('flxbrf',trim(c5p)//' time',flxbrf,ip) +#endif +#ifdef extNcycle + call wrtrst('flxn2o',trim(c5p)//' time',flxn2o,ip) + call wrtrst('flxnh3',trim(c5p)//' time',flxnh3,ip) #endif endif c From 7be3e1d0c2cd842032843f2c2a13a686e2c0b6da Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Mon, 20 Mar 2023 18:07:43 +0100 Subject: [PATCH 274/366] Introduce atmospheric N2O and NH3 cesm fields for coupling --- cesm/mod_cesm.F90 | 21 +++++++++++++++++---- 1 file changed, 17 insertions(+), 4 deletions(-) diff --git a/cesm/mod_cesm.F90 b/cesm/mod_cesm.F90 index cc371c18..10b68da7 100644 --- a/cesm/mod_cesm.F90 +++ b/cesm/mod_cesm.F90 @@ -29,7 +29,8 @@ module mod_cesm use mod_xc use mod_forcing, only: trxday, srxday, swa, nsf, lip, sop, eva, rnf, rfi, & fmltfz, sfl, ztx, mty, ustarw, slp, abswnd, & - lamult, lasl, ustokes, vstokes, atmco2, atmbrf + lamult, lasl, ustokes, vstokes, atmco2, atmbrf, & + atmn2o,atmnh3 use mod_ben02, only: initai, rdcsic, rdctsf, fnlzai use mod_seaice, only: ficem use mod_checksum, only: csdiag, chksummsk @@ -76,7 +77,9 @@ module mod_cesm ustokes_da, & ! u-component of surface Stokes drift [m s-1]. vstokes_da, & ! v-component of surface Stokes drift [m s-1]. atmco2_da, & ! Atmospheric CO2 concentration [ppm]. - atmbrf_da ! Atmospheric bromoform concentration [ppt]. + atmbrf_da, & ! Atmospheric bromoform concentration [ppt]. + atmn2o_da, & ! Atmospheric nitrous oxide concentration [ppt]. + atmnh3_da ! Atmopsheric ammonia concentration [ppt] logical :: & smtfrc ! If true, time smooth CESM forcing fields. @@ -88,8 +91,8 @@ module mod_cesm 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, ustarw_da, & slp_da, abswnd_da, ficem_da, lamult_da, lasl_da, & - ustokes_da, vstokes_da, atmco2_da, atmbrf_da, smtfrc, l1ci, l2ci, & - inicon_cesm, inifrc_cesm, getfrc_cesm + ustokes_da, vstokes_da, atmco2_da, atmbrf_da,atmn2o_da,atmnh3_da,& + smtfrc, l1ci, l2ci,inicon_cesm, inifrc_cesm, getfrc_cesm contains @@ -189,6 +192,8 @@ subroutine getfrc_cesm vstokes(i, j) = w1*vstokes_da(i, j, l1ci) + w2*vstokes_da(i, j, l2ci) atmco2(i, j) = w1*atmco2_da(i, j, l1ci) + w2*atmco2_da(i, j, l2ci) atmbrf(i, j) = w1*atmbrf_da(i, j, l1ci) + w2*atmbrf_da(i, j, l2ci) + atmn2o(i, j) = w1*atmn2o_da(i, j, l1ci) + w2*atmn2o_da(i, j, l2ci) + atmnh3(i, j) = w1*atmnh3_da(i, j, l1ci) + w2*atmnh3_da(i, j, l2ci) enddo enddo do l = 1, isu(j) @@ -228,6 +233,8 @@ subroutine getfrc_cesm call ncdefvar('vstokes_da', 'x y', ndouble, 8) call ncdefvar('atmco2_da', 'x y', ndouble, 8) call ncdefvar('atmbrf_da', 'x y', ndouble, 8) + call ncdefvar('atmn2o_da', 'x y', ndouble, 8) + call ncdefvar('atmnh3_da', 'x y', ndouble, 8) call ncdefvar('ztx_da', 'x y', ndouble, 8) call ncdefvar('mty_da', 'x y', ndouble, 8) call ncedef @@ -272,6 +279,10 @@ subroutine getfrc_cesm ip, 1, 1._r8, 0._r8, 8) call ncwrtr('atmbrf_da', 'x y', atmbrf_da(1 - nbdy, 1 - nbdy, l2ci), & ip, 1, 1._r8, 0._r8, 8) + call ncwrtr('atmn2o_da', 'x y', atmn2o_da(1 - nbdy, 1 - nbdy, l2ci), & + ip, 1, 1._r8, 0._r8, 8) + call ncwrtr('atmnh3_da', 'x y', atmnh3_da(1 - nbdy, 1 - nbdy, l2ci), & + ip, 1, 1._r8, 0._r8, 8) call ncwrtr('ztx_da', 'x y', ztx_da(1 - nbdy, 1 - nbdy, l2ci), & iu, 1, 1._r8, 0._r8, 8) call ncwrtr('mty_da', 'x y', mty_da(1 - nbdy, 1 - nbdy, l2ci), & @@ -307,6 +318,8 @@ subroutine getfrc_cesm call chksummsk(vstokes, ip, 1, 'vstokes') call chksummsk(atmco2, ip, 1, 'atmco2') call chksummsk(atmbrf, ip, 1, 'atmbrf') + call chksummsk(atmn2o, ip, 1, 'atmn2o') + call chksummsk(atmnh3, ip, 1, 'atmnh3') endif end subroutine getfrc_cesm From 0fbba925f16262fb489c668fec230f359ff56dcf Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Mon, 20 Mar 2023 18:33:11 +0100 Subject: [PATCH 275/366] Write atmospheric X_da to restart file, fix missing flx nc-init for resrat file writing --- phy/restart_wt.F | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/phy/restart_wt.F b/phy/restart_wt.F index 8df96755..7880bd48 100644 --- a/phy/restart_wt.F +++ b/phy/restart_wt.F @@ -53,6 +53,7 @@ subroutine restart_wt . lip_da, sop_da, eva_da, rnf_da, rfi_da, . fmltfz_da, sfl_da, ztx_da, mty_da, ustarw_da, . slp_da, abswnd_da, atmco2_da, atmbrf_da, + . atmn2o_da, atmnh3_da, . ficem_da, l2ci use mod_ben02, only: cd_d, ch_d, ce_d, wg2_d, cd_m, ch_m, ce_m, . wg2_m, rhoa, tsi_tda, tml_tda, sml_tda, @@ -353,6 +354,8 @@ subroutine restart_wt call wrtrst('abswnd_da',trim(c5p)//' k2 time',abswnd_da,ip) call wrtrst('atmco2_da',trim(c5p)//' k2 time',atmco2_da,ip) call wrtrst('atmbrf_da',trim(c5p)//' k2 time',atmbrf_da,ip) ! not read in restart_rd, necesarry? + call wrtrst('atmn2o_da',trim(c5p)//' k2 time',atmn2o_da,ip) ! not read in restart_rd, necesarry? + call wrtrst('atmnh3_da',trim(c5p)//' k2 time',atmnh3_da,ip) ! not read in restart_rd, necesarry? call wrtrst('frzpot',trim(c5p)//' time',frzpot,ip) call wrtrst('mltpot',trim(c5p)//' time',mltpot,ip) call wrtrst('flxco2',trim(c5p)//' time',flxco2,ip) @@ -961,12 +964,18 @@ subroutine defvar_restart(c5p,c5u,c5v,c5q) call defvarrst('abswnd_da',trim(c5p)//' k2 time') call defvarrst('atmco2_da',trim(c5p)//' k2 time') call defvarrst('atmbrf_da',trim(c5p)//' k2 time') + call defvarrst('atmn2o_da',trim(c5p)//' k2 time') + call defvarrst('atmnh3_da',trim(c5p)//' k2 time') call defvarrst('frzpot',trim(c5p)//' time') call defvarrst('mltpot',trim(c5p)//' time') call defvarrst('flxco2',trim(c5p)//' time') call defvarrst('flxdms',trim(c5p)//' time') #ifdef BROMO call defvarrst('flxbrf',trim(c5p)//' time') +#endif +#ifdef extNcycle + call defvarrst('flxn2o',trim(c5p)//' time') + call defvarrst('flxnh3',trim(c5p)//' time') #endif endif c From ac6e031ae48d9e37f3e0ffb92ca526ff2a078a1b Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Tue, 21 Mar 2023 19:24:05 +0100 Subject: [PATCH 276/366] Introduce indices and fields of N2O and NH3 for the mct coupler --- drivers/mct/blom_cpl_indices.F90 | 8 ++++ drivers/mct/export_mct.F | 37 ++++++++++++++++ drivers/mct/import_mct.F | 75 +++++++++++++++++++++++++++++++- drivers/mct/sumsbuff_mct.F | 27 +++++++++++- 4 files changed, 145 insertions(+), 2 deletions(-) diff --git a/drivers/mct/blom_cpl_indices.F90 b/drivers/mct/blom_cpl_indices.F90 index 1bd51032..d63d44f0 100644 --- a/drivers/mct/blom_cpl_indices.F90 +++ b/drivers/mct/blom_cpl_indices.F90 @@ -44,6 +44,8 @@ module blom_cpl_indices integer :: index_o2x_Faoo_fco2_ocn integer :: index_o2x_Faoo_fdms_ocn integer :: index_o2x_Faoo_fbrf_ocn + integer :: index_o2x_Faoo_fn2o_ocn + integer :: index_o2x_Faoo_fnh3_ocn ! drv -> ocn @@ -53,6 +55,8 @@ module blom_cpl_indices integer :: index_x2o_Sa_co2prog ! bottom atm level prognostic CO2 integer :: index_x2o_Sa_co2diag ! bottom atm level diagnostic CO2 integer :: index_x2o_Sa_brfprog ! bottom atm level prognostic bromoform (ppt) + integer :: index_x2o_Sa_n2oprog ! bottom atm level prognostic nitrous oxide (ppt) + integer :: index_x2o_Sa_nh3prog ! bottom atm level prognostic ammonia (ppt) integer :: index_x2o_Faxa_nhx ! nitrogen deposition (nhx) flux from atm (kgNm2/sec) integer :: index_x2o_Faxa_noy ! nitrogen deposition (noy) flux from atm (kgNm2/sec) @@ -129,6 +133,8 @@ subroutine blom_cpl_indices_set( ) index_o2x_Faoo_fco2_ocn = mct_avect_indexra(o2x,'Faoo_fco2_ocn',perrWith='quiet') index_o2x_Faoo_fdms_ocn = mct_avect_indexra(o2x,'Faoo_fdms_ocn',perrWith='quiet') index_o2x_Faoo_fbrf_ocn = mct_avect_indexra(o2x,'Faoo_fbrf_ocn',perrWith='quiet') + index_o2x_Faoo_fn2o_ocn = mct_avect_indexra(o2x,'Faoo_fn2o_ocn',perrWith='quiet') + index_o2x_Faoo_fnh3_ocn = mct_avect_indexra(o2x,'Faoo_fnh3_ocn',perrWith='quiet') index_x2o_Si_ifrac = mct_avect_indexra(x2o,'Si_ifrac') index_x2o_Sa_pslv = mct_avect_indexra(x2o,'Sa_pslv') index_x2o_So_duu10n = mct_avect_indexra(x2o,'So_duu10n') @@ -173,6 +179,8 @@ subroutine blom_cpl_indices_set( ) index_x2o_Sa_co2prog = mct_avect_indexra(x2o,'Sa_co2prog',perrWith='quiet') index_x2o_Sa_co2diag = mct_avect_indexra(x2o,'Sa_co2diag',perrWith='quiet') index_x2o_Sa_brfprog = mct_avect_indexra(x2o,'Sa_brfprog',perrWith='quiet') + index_x2o_Sa_n2oprog = mct_avect_indexra(x2o,'Sa_n2oprog',perrWith='quiet') + index_x2o_Sa_nh3prog = mct_avect_indexra(x2o,'Sa_nh3prog',perrWith='quiet') index_x2o_Faxa_nhx = mct_avect_indexra(x2o,'Faxa_nhx',perrWith='quiet') index_x2o_Faxa_noy = mct_avect_indexra(x2o,'Faxa_noy',perrWith='quiet') diff --git a/drivers/mct/export_mct.F b/drivers/mct/export_mct.F index cff6c4c2..fc807294 100644 --- a/drivers/mct/export_mct.F +++ b/drivers/mct/export_mct.F @@ -169,6 +169,43 @@ subroutine export_mct(o2x_o, lsize, perm, jjcpl, nsend, sbuff, . write (lp,*) 'export_mct: bromoform flux not sent to coupler' endif + ! ---------------------------------------------------------------- + ! Pack nitrous oxide flux (kg N2O/m^2/s), if requested + ! ---------------------------------------------------------------- + + if (index_o2x_Faoo_fn2o_ocn > 0) then + n = 0 + do j = 1, jjcpl + do i = 1, ii + n = n + 1 + o2x_o%rAttr(index_o2x_Faoo_fn2o_ocn,n) = + . sbuff(i,j,index_o2x_Faoo_fn2o_ocn)*tfac + enddo + enddo + else + if (mnproc.eq.1) + . write (lp,*) 'export_mct: nitrous oxide flux not sent to coupler' + endif + + ! ---------------------------------------------------------------- + ! Pack ammonia flux (kg NH3/m^2/s), if requested + ! ---------------------------------------------------------------- + + if (index_o2x_Faoo_fnh3_ocn > 0) then + n = 0 + do j = 1, jjcpl + do i = 1, ii + n = n + 1 + o2x_o%rAttr(index_o2x_Faoo_fnh3_ocn,n) = + . sbuff(i,j,index_o2x_Faoo_fnh3_ocn)*tfac + enddo + enddo + else + if (mnproc.eq.1) + . write (lp,*) 'export_mct: ammonia flux not sent to coupler' + endif + + tlast_coupled = 0._r8 !----------------------------------------------------------------- diff --git a/drivers/mct/import_mct.F b/drivers/mct/import_mct.F index 28a41f7a..caf45e52 100644 --- a/drivers/mct/import_mct.F +++ b/drivers/mct/import_mct.F @@ -30,7 +30,8 @@ subroutine import_mct(x2o_o, lsize, perm, jjcpl) use mod_cesm, only: swa_da, nsf_da, hmlt_da, lip_da, sop_da, . eva_da, rnf_da, rfi_da, fmltfz_da, sfl_da, . ztx_da, mty_da, ustarw_da, slp_da, abswnd_da, - . atmco2_da, atmbrf_da, ficem_da, l1ci, l2ci + . atmco2_da, atmbrf_da,atmn2o_da,atmnh3_da, + . ficem_da, l1ci, l2ci use mod_utility, only: util1, util2 use mod_checksum, only: csdiag, chksummsk use blom_cpl_indices @@ -344,6 +345,76 @@ subroutine import_mct(x2o_o, lsize, perm, jjcpl) . write (lp,*) 'import_mct: prog. atmospheric bromoform not read' endif + + if (index_x2o_Sa_n2oprog > 0) then + n = 0 + do j = 1, jjcpl + do i = 1, ii + n = n + 1 + if (ip(i,j) == 0) then + atmn2o_da(i,j,l2ci) = mval + elseif (cplmsk(i,j) == 0) then + atmn2o_da(i,j,l2ci) = fval + else + ! Atmospheric nitrous oxide concentration [ppt] + atmn2o_da(i,j,l2ci) = + . x2o_o%rAttr(index_x2o_Sa_n2oprog,n) + endif + enddo + enddo + call fill_global(mval, fval, halo_ps, + . atmn2o_da(1-nbdy,1-nbdy,l2ci)) + if (mnproc.eq.1) + . write (lp,*) 'import_mct: prog. atmospheric nitrous oxide read' + else + do j = 1, jj + do i = 1, ii + if (ip(i,j) == 0) then + atmn2o_da(i,j,l2ci) = mval + else + atmn2o_da(i,j,l2ci) = -1 + endif + enddo + enddo + if (mnproc.eq.1) + . write (lp,*) 'import_mct: prog. atmospheric nitrous oxide not read' + endif + + if (index_x2o_Sa_nh3prog > 0) then + n = 0 + do j = 1, jjcpl + do i = 1, ii + n = n + 1 + if (ip(i,j) == 0) then + atmnh3_da(i,j,l2ci) = mval + elseif (cplmsk(i,j) == 0) then + atmnh3_da(i,j,l2ci) = fval + else + ! Atmospheric nitrous oxide concentration [ppt] + atmnh3_da(i,j,l2ci) = + . x2o_o%rAttr(index_x2o_Sa_nh3prog,n) + endif + enddo + enddo + call fill_global(mval, fval, halo_ps, + . atmnh3_da(1-nbdy,1-nbdy,l2ci)) + if (mnproc.eq.1) + . write (lp,*) 'import_mct: prog. atmospheric ammonia read' + else + do j = 1, jj + do i = 1, ii + if (ip(i,j) == 0) then + atmnh3_da(i,j,l2ci) = mval + else + atmnh3_da(i,j,l2ci) = -1 + endif + enddo + enddo + if (mnproc.eq.1) + . write (lp,*) 'import_mct: prog. atmospheric ammonia not read' + endif + + if (csdiag) then if (mnproc.eq.1) then write (lp,*) 'import_mct:' @@ -366,6 +437,8 @@ subroutine import_mct(x2o_o, lsize, perm, jjcpl) call chksummsk(abswnd_da(1-nbdy,1-nbdy,l2ci),ip,1,'abswnd') call chksummsk(atmco2_da(1-nbdy,1-nbdy,l2ci),ip,1,'atmco2') call chksummsk(atmbrf_da(1-nbdy,1-nbdy,l2ci),ip,1,'atmbrf') + call chksummsk(atmn2o_da(1-nbdy,1-nbdy,l2ci),ip,1,'atmn2o') + call chksummsk(atmnh3_da(1-nbdy,1-nbdy,l2ci),ip,1,'atmnh3') endif end subroutine import_mct diff --git a/drivers/mct/sumsbuff_mct.F b/drivers/mct/sumsbuff_mct.F index 03cf099d..b7721f0f 100644 --- a/drivers/mct/sumsbuff_mct.F +++ b/drivers/mct/sumsbuff_mct.F @@ -27,7 +27,7 @@ subroutine sumsbuff_mct(nsend, sbuff, tlast_coupled) use mod_grid, only: scuy, scvx, scuxi, scvyi use mod_state, only: u, v, temp, saln, pbu, pbv, ubflxs, vbflxs, . sealv - use mod_forcing, only: flxco2, flxdms, flxbrf + use mod_forcing, only: flxco2, flxdms, flxbrf,flxn2o,flxnh3 use mod_cesm, only: frzpot use blom_cpl_indices @@ -153,6 +153,31 @@ subroutine sumsbuff_mct(nsend, sbuff, tlast_coupled) enddo endif + if (index_o2x_Faoo_fn2o_ocn > 0) then + do j = 1, jj + do l = 1, isp(j) + do i = max(1,ifp(j,l)), min(ii,ilp(j,l)) + sbuff(i,j,index_o2x_Faoo_fn2o_ocn) = + . sbuff(i,j,index_o2x_Faoo_fn2o_ocn) + . + flxn2o(i,j)*baclin + enddo + enddo + enddo + endif + + if (index_o2x_Faoo_fnh3_ocn > 0) then + do j = 1, jj + do l = 1, isp(j) + do i = max(1,ifp(j,l)), min(ii,ilp(j,l)) + sbuff(i,j,index_o2x_Faoo_fnh3_ocn) = + . sbuff(i,j,index_o2x_Faoo_fnh3_ocn) + . + flxnh3(i,j)*baclin + enddo + enddo + enddo + endif + + !----------------------------------------------------------------- ! Increment time since last coupling From 35f52e6f6d9834f688bf8497e7e2e085c5e683b1 Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Wed, 22 Mar 2023 17:49:23 +0100 Subject: [PATCH 277/366] Adjusted mol->kg conversion factor --- hamocc/hamocc4bcm.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/hamocc/hamocc4bcm.F90 b/hamocc/hamocc4bcm.F90 index 2b2fafcc..2fa80d61 100644 --- a/hamocc/hamocc4bcm.F90 +++ b/hamocc/hamocc4bcm.F90 @@ -465,8 +465,8 @@ SUBROUTINE HAMOCC4BCM(kpie,kpje,kpke,kbnd,kplyear,kplmon,kplday,kldtday,& DO j=1,kpje DO i=1,kpie #ifdef extNcycle - if(omask(i,j) .gt. 0.5) pflxn2o(i,j)=-44.013*atmflx(i,j,iatmn2o)/dtbgc ! CONVERSION factor digits ?????? - if(omask(i,j) .gt. 0.5) pflxnh3(i,j)=-17.031*atmflx(i,j,iatmnh3)/dtbgc ! CONVERSION factor digits ?????? + if(omask(i,j) .gt. 0.5) pflxn2o(i,j)=-44.012880*atmflx(i,j,iatmn2o)/dtbgc ! conversion factor checked against CAM + if(omask(i,j) .gt. 0.5) pflxnh3(i,j)=-17.028940*atmflx(i,j,iatmnh3)/dtbgc ! conversion factor checked against CAM #else if(omask(i,j) .gt. 0.5) pflxn2o(i,j)=0.0 if(omask(i,j) .gt. 0.5) pflxnh3(i,j)=0.0 From 4435333308929bc9c9a5f804accf7b5b2ee702e1 Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Wed, 22 Mar 2023 19:14:11 +0100 Subject: [PATCH 278/366] add compsets for coupled N2O and NH3 fluxes --- cime_config/buildcpp | 6 ++++++ cime_config/config_component.xml | 25 ++++++++++++++++++++++++- 2 files changed, 30 insertions(+), 1 deletion(-) diff --git a/cime_config/buildcpp b/cime_config/buildcpp index c1e21a45..a6d32316 100644 --- a/cime_config/buildcpp +++ b/cime_config/buildcpp @@ -84,6 +84,8 @@ def buildcpp(case): co2type = case.get_value("OCN_CO2_TYPE") hamocc_cfc = case.get_value("HAMOCC_CFC") hamocc_extNcycle = case.get_value("HAMOCC_EXTNCYCLE") + hamocc_N2OC = case.get_value("HAMOCC_N2OC") + hamocc_NH3C = case.get_value("HAMOCC_NH3C") hamocc_debug = case.get_value("HAMOCC_DEBUG") hamocc_nattrc = case.get_value("HAMOCC_NATTRC") hamocc_sedbypass = case.get_value("HAMOCC_SEDBYPASS") @@ -133,6 +135,10 @@ def buildcpp(case): blom_cppdefs = blom_cppdefs + " -DCFC" if hamocc_extNcycle: blom_cppdefs = blom_cppdefs + " -DextNcycle" + if hamocc_N2OC: + blom_cppdefs = blom_cppdefs + " -DextNcycle" + if hamocc_NH3C: + blom_cppdefs = blom_cppdefs + " -DextNcycle" if hamocc_debug: blom_cppdefs = blom_cppdefs + " -DPBGC_OCNP_TIMESTEP -DPBGC_CK_TIMESTEP" if hamocc_nattrc: diff --git a/cime_config/config_component.xml b/cime_config/config_component.xml index f1caf12b..a851ac00 100644 --- a/cime_config/config_component.xml +++ b/cime_config/config_component.xml @@ -205,7 +205,30 @@ env_build.xml Set preprocessor option to activate the extended nitrogen cycle code. Requires module ecosys - + + + logical + TRUE,FALSE + FALSE + + TRUE + + build_component_blom + env_build.xml + Set preprocessor option to activate the N2O coupling code. Requires module ecosys and EXTNCYCLE + + + logical + TRUE,FALSE + FALSE + + TRUE + + build_component_blom + env_build.xml + Set preprocessor option to activate the NH3 coupling code. Requires module ecosys and EXTNCYCLE + + logical TRUE,FALSE From 584c665d778c0fe090dee58e20e57ed5b7ad2b0e Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Thu, 23 Mar 2023 17:25:43 +0100 Subject: [PATCH 279/366] Fix powach --- hamocc/powach.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/hamocc/powach.F90 b/hamocc/powach.F90 index 6251e7a4..2a4f68f0 100644 --- a/hamocc/powach.F90 +++ b/hamocc/powach.F90 @@ -155,7 +155,7 @@ subroutine powach(kpie,kpje,kpke,kbnd,prho,omask,psao,ptho,lspin) anaerob(i,k)= 0. #else ex_ddic(i,k)=0. - ex_dalk(i,j)=0. + ex_dalk(i,k)=0. #endif aerob(i,k) = 0. sulf(i,k) = 0. From ed4a9ef39883eb322898c19d99c3bcb3869fc9b2 Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Thu, 23 Mar 2023 17:34:49 +0100 Subject: [PATCH 280/366] Fix powach --- hamocc/powach.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/hamocc/powach.F90 b/hamocc/powach.F90 index 6251e7a4..2a4f68f0 100644 --- a/hamocc/powach.F90 +++ b/hamocc/powach.F90 @@ -155,7 +155,7 @@ subroutine powach(kpie,kpje,kpke,kbnd,prho,omask,psao,ptho,lspin) anaerob(i,k)= 0. #else ex_ddic(i,k)=0. - ex_dalk(i,j)=0. + ex_dalk(i,k)=0. #endif aerob(i,k) = 0. sulf(i,k) = 0. From b2f5014a618fc59854add8dbfee1c704eda00460 Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Fri, 24 Mar 2023 15:39:08 +0100 Subject: [PATCH 281/366] Express atmospheric N2O concentration in ppt (not in mol/mol mixing ratio) --- hamocc/beleg_parm.F90 | 2 +- hamocc/carchm.F90 | 2 +- hamocc/mo_chemcon.F90 | 4 ++-- 3 files changed, 4 insertions(+), 4 deletions(-) diff --git a/hamocc/beleg_parm.F90 b/hamocc/beleg_parm.F90 index 224d55ee..eaaf8e6b 100644 --- a/hamocc/beleg_parm.F90 +++ b/hamocc/beleg_parm.F90 @@ -71,7 +71,7 @@ SUBROUTINE BELEG_PARM(kpie,kpje) #ifdef extNcycle use mo_param1_bgc, only: iatmnh3,iatmn2o use mo_carbch, only: atm_nh3,atm_n2o - use mo_chemcon, only: atn2o !fixed mixing ratio of N2O at 1980, 300ppb = 3e-7 + use mo_chemcon, only: atn2o !fixed mixing ratio of N2O at 1980, 300ppb = 300e3ppt = 3e-7 mol/mol use mo_extNbioproc, only: extNbioparam_init use mo_extNsediment,only: extNsediment_param_init #endif diff --git a/hamocc/carchm.F90 b/hamocc/carchm.F90 index 834db30e..4dc48835 100644 --- a/hamocc/carchm.F90 +++ b/hamocc/carchm.F90 @@ -510,7 +510,7 @@ SUBROUTINE CARCHM(kpie,kpje,kpke,kbnd, & niflux=kwn2*dtbgc*(ocetra(i,j,1,igasnit)-anisa*(atn2/802000)*rpp0) ocetra(i,j,1,igasnit)=ocetra(i,j,1,igasnit)-niflux/pddpo(i,j,1) ! Surface flux of laughing gas (same piston velocity as for O2 and N2) - n2oflux=kwn2o*dtbgc*(ocetra(i,j,1,ian2o)-satn2o(i,j)*atn2ov*rpp0) + n2oflux=kwn2o*dtbgc*(ocetra(i,j,1,ian2o)-satn2o(i,j)*atn2ov*1e-12*rpp0) ! pN2O under moist air assumption at normal pressure pn2om(i,j) = 1e9 * ocetra(i,j,1,ian2o)/satn2o(i,j) ocetra(i,j,1,ian2o)=ocetra(i,j,1,ian2o)-n2oflux/pddpo(i,j,1) diff --git a/hamocc/mo_chemcon.F90 b/hamocc/mo_chemcon.F90 index bf722b54..367b1a18 100644 --- a/hamocc/mo_chemcon.F90 +++ b/hamocc/mo_chemcon.F90 @@ -170,9 +170,9 @@ MODULE mo_chemcon ! ----------------------------------------------------------------- -! Atmospheric mixing ratio of N2O around 1980 300 ppb +! Atmospheric mixing ratio of N2O around 1980 300 ppb, here provided in ppt ! - real, parameter :: atn2o=3.e-7 + real, parameter :: atn2o=300e3 #ifdef extNcycle ! Tsilingiris 2008 From c42111cded3a83a83aeccf718228bc5a1567be81 Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Mon, 27 Mar 2023 11:01:06 +0200 Subject: [PATCH 282/366] Add output for atmospheric NH3 and N2O for coupler check --- cime_config/buildnml | 9 +++++++++ hamocc/accfields.F90 | 4 +++- hamocc/mo_bgcmean.F90 | 16 +++++++++++++--- hamocc/ncout_hamocc.F90 | 14 ++++++++++++-- 4 files changed, 37 insertions(+), 6 deletions(-) diff --git a/cime_config/buildnml b/cime_config/buildnml index 414850d5..d60723a3 100755 --- a/cime_config/buildnml +++ b/cime_config/buildnml @@ -477,6 +477,8 @@ set SRF_PN2OM = '0, 2, 2' set SRF_N2OFX = '0, 0, 2' set SRF_PNH3 = '0, 2, 2' set SRF_ANH3FX = '0, 0, 2' +set SRF_ATMNH3 = '0, 2, 2' +set SRF_ATMN2O = '0, 2, 2' set SRF_DMSFLUX = '0, 2, 2' set SRF_DMS = '0, 2, 2' set SRF_DMSPROD = '0, 2, 2' @@ -498,6 +500,7 @@ set SRF_CFC11 = '0, 2, 2' set SRF_CFC12 = '0, 2, 2' set SRF_SF6 = '0, 2, 2' set SRF_BROMO = '0, 2, 2' +set SRF_ATMBROMO = '0, 0, 2' set SRF_BROMOFX = '0, 2, 2' set INT_BROMOPRO = '0, 2, 2' set INT_BROMOUV = '0, 2, 2' @@ -1807,6 +1810,9 @@ cat >>! $RUNDIR/ocn_in$inststr << EOF ! N2OFX - Nitrous oxide flux [mol N2O m-2 s-1] ! PNH3 - Surface pNH3 under moist air [natm] ! ANH3FX - Ammonia flux [mol NH3 m-2 s-1] +! ATMNH3 - Atmospheric NH3 [ppt] +! ATMN2O - Atmospheric N2O [ppt] +! ATMBROMO - Atmospheric bromoform [ppt] ! DMSFLUX - DMS flux (dmsflux) [mol DMS m-2 s-1] ! DMS - surface DMS concentration (dms) [mol DMS m-3] ! DMSPROD - DMS production (dmsprod) [mol DMS m-2 s-1] @@ -1922,6 +1928,9 @@ cat >>! $RUNDIR/ocn_in$inststr << EOF SRF_N2OFX = $SRF_N2OFX SRF_PNH3 = $SRF_PNH3 SRF_ANH3FX = $SRF_ANH3FX + SRF_ATMNH3 = $SRF_ATMNH3 + SRF_ATMN2O = $SRF_ATMN2O + SRF_ATMBROMO = $SRF_ATMBROMO SRF_DMSFLUX = $SRF_DMSFLUX SRF_DMS = $SRF_DMS SRF_DMSPROD = $SRF_DMSPROD diff --git a/hamocc/accfields.F90 b/hamocc/accfields.F90 index f9e21b2d..c2f7b367 100644 --- a/hamocc/accfields.F90 +++ b/hamocc/accfields.F90 @@ -124,7 +124,7 @@ SUBROUTINE ACCFIELDS(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask) & jDNRA_NO2,janmx_N2_prod,janmx_OM_prod,jphosy_NH4,jphosy_NO3,jremin_aerob,jremin_sulf, & & jpownh4,jpown2o,jpowno2,jsdm_nitr_NH4,jsdm_nitr_NO2,jsdm_nitr_N2O_prod,jsdm_nitr_NH4_OM, & & jsdm_nitr_NO2_OM,jsdm_denit_NO3,jsdm_denit_NO2,jsdm_denit_N2O,jsdm_DNRA_NO2,jsdm_anmx_N2_prod, & - & jsdm_anmx_OM_prod,jsdm_remin_aerob,jsdm_remin_sulf,jsediffnh4,jsediffn2o,jsediffno2 + & jsdm_anmx_OM_prod,jsdm_remin_aerob,jsdm_remin_sulf,jsediffnh4,jsediffn2o,jsediffno2,jatmn2o,jatmnh3 use mo_biomod, only: nitr_NH4,nitr_NO2,nitr_N2O_prod,nitr_NH4_OM,nitr_NO2_OM,denit_NO3,denit_NO2,denit_N2O,DNRA_NO2, & & anmx_N2_prod,anmx_OM_prod,phosy_NH4,phosy_NO3,remin_aerob,remin_sulf use mo_extNsediment,only: extNsed_diagnostics,ised_nitr_NH4,ised_nitr_NO2,ised_nitr_N2O_prod,ised_nitr_NH4_OM, & @@ -243,6 +243,8 @@ SUBROUTINE ACCFIELDS(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask) #endif #ifdef extNcycle call accsrf(janh3fx,atmflx(1,1,iatmnh3),omask,0) + call accsrf(jatmnh3,atm(1,1,iatmnh3),omask,0) + call accsrf(jatmn2o,atm(1,1,iatmn2o),omask,0) #endif ! Save up and downward fluxes for CO2 seperately diff --git a/hamocc/mo_bgcmean.F90 b/hamocc/mo_bgcmean.F90 index 32918abd..7278cb40 100644 --- a/hamocc/mo_bgcmean.F90 +++ b/hamocc/mo_bgcmean.F90 @@ -93,7 +93,8 @@ MODULE mo_bgcmean & SRF_NATCO2FX =0 ,SRF_NATPH =0 , & & SRF_ATMBROMO =0 ,SRF_BROMO =0 ,SRF_BROMOFX =0 , & & SRF_ANH4 =0 ,SRF_ANO2 =0 ,SRF_ANH3FX =0 , & - & SRF_PN2OM =0 ,SRF_PNH3 =0 , & + & SRF_PN2OM =0 ,SRF_PNH3 =0 ,SRF_ATMNH3 =0 , & + & SRF_ATMN2O =0 , & & INT_BROMOPRO =0 ,INT_BROMOUV =0 , & & INT_PHOSY =0 ,INT_NFIX =0 ,INT_DNIT =0 , & & FLX_CAR0100 =0 ,FLX_CAR0500 =0 ,FLX_CAR1000 =0 , & @@ -207,7 +208,8 @@ MODULE mo_bgcmean & SRF_NATCO2FX ,SRF_NATPH , & & SRF_ATMBROMO ,SRF_BROMO ,SRF_BROMOFX , & & SRF_ANH4 ,SRF_ANO2 ,SRF_ANH3FX , & - & SRF_PN2OM ,SRF_PNH3 , & + & SRF_PN2OM ,SRF_PNH3 ,SRF_ATMNH3 , & + & SRF_ATMN2O , & & INT_BROMOPRO ,INT_BROMOUV , & & INT_PHOSY ,INT_NFIX ,INT_DNIT , & & FLX_CAR0100 ,FLX_CAR0500 ,FLX_CAR1000 , & @@ -428,7 +430,9 @@ MODULE mo_bgcmean & jatmn2 = 0 , & & jatmc13 = 0 , & & jatmc14 = 0 , & - & jatmbromo= 0 + & jatmbromo= 0 , & + & jatmnh3 = 0 , & + & jatmn2o = 0 INTEGER, SAVE :: nbgcm2d @@ -938,6 +942,12 @@ SUBROUTINE ALLOC_MEM_BGCMEAN(kpie,kpje,kpke) #if defined(BROMO) IF (SRF_ATMBROMO(n).GT.0) i_atm_m2d=i_atm_m2d+1 jatmbromo(n)=i_atm_m2d*min(1,SRF_ATMBROMO(n)) +#endif +#ifdef extNcycle + IF (SRF_ATMNH3(n).GT.0) i_atm_m2d=i_atm_m2d+1 + jatmnh3(n)=i_atm_m2d*min(1,SRF_ATMNH3(n)) + IF (SRF_ATMN2O(n).GT.0) i_atm_m2d=i_atm_m2d+1 + jatmn2o(n)=i_atm_m2d*min(1,SRF_ATMN2O(n)) #endif ENDDO i_atm_m2d=i_atm_m2d-i_bsc_m2d diff --git a/hamocc/ncout_hamocc.F90 b/hamocc/ncout_hamocc.F90 index 782bcc9a..90280e57 100644 --- a/hamocc/ncout_hamocc.F90 +++ b/hamocc/ncout_hamocc.F90 @@ -210,7 +210,8 @@ subroutine ncwrt_bgc(iogrp) & jlvl_denit_NO2,jlvl_denit_N2O,jlvl_DNRA_NO2, & & jlvl_anmx_N2_prod,jlvl_anmx_OM_prod, & & jlvl_phosy_NH4,jlvl_phosy_NO3, & - & jlvl_remin_aerob,jlvl_remin_sulf + & jlvl_remin_aerob,jlvl_remin_sulf,jatmnh3,jatmn2o, & + & srf_atmnh3,srf_atmn2o #endif #if defined(extNcycle) && ! defined(sedbypass) use mo_bgcmean, only: jpownh4,jpown2o,jpowno2,jsdm_nitr_NH4,jsdm_nitr_NO2, & @@ -628,6 +629,8 @@ subroutine ncwrt_bgc(iogrp) call wrtsrf(jsrfpnh3(iogrp), SRF_PNH3(iogrp), rnacc, 0.,cmpflg,'pnh3') call wrtsrf(jsrfano2(iogrp), SRF_ANO2(iogrp), rnacc*1e3, 0.,cmpflg,'srfno2') call wrtsrf(janh3fx(iogrp), SRF_ANH3FX(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'nh3flux') + call wrtsrf(jatmnh3(iogrp), SRF_ATMNH3(iogrp), rnacc, 0.,cmpflg,'atmnh3') + call wrtsrf(jatmn2o(iogrp), SRF_ATMN2O(iogrp), rnacc, 0.,cmpflg,'atmn2o') #endif ! --- Store 3d layer fields @@ -968,6 +971,8 @@ subroutine ncwrt_bgc(iogrp) call inisrf(jsrfpnh3(iogrp),0.) call inisrf(jsrfano2(iogrp),0.) call inisrf(janh3fx(iogrp),0.) + call inisrf(jatmnh3(iogrp),0.) + call inisrf(jatmn2o(iogrp),0.) #endif #if defined(extNcycle) && ! defined(sedbypass) call inisrf(jsediffnh4(iogrp),0.) @@ -1304,7 +1309,8 @@ subroutine hamoccvardef(iogrp,timeunits,calendar,cmpflg) & jlvl_denit_NO2,jlvl_denit_N2O,jlvl_DNRA_NO2, & & jlvl_anmx_N2_prod,jlvl_anmx_OM_prod, & & jlvl_phosy_NH4,jlvl_phosy_NO3, & - & jlvl_remin_aerob,jlvl_remin_sulf + & jlvl_remin_aerob,jlvl_remin_sulf,srf_atmnh3, & + & srf_atmn2o #endif #if defined(extNcycle) && ! defined(sedbypass) use mo_bgcmean, only: jpownh4,jpown2o,jpowno2,jsdm_nitr_NH4,jsdm_nitr_NO2, & @@ -1556,6 +1562,10 @@ subroutine hamoccvardef(iogrp,timeunits,calendar,cmpflg) & 'Surface nitrite',' ','mol N m-3',0) call ncdefvar3d(SRF_ANH3FX(iogrp),cmpflg,'p','nh3flux', & & 'NH3 flux',' ','mol NH3 m-2 s-1',0) + call ncdefvar3d(SRF_ATMNH3(iogrp),cmpflg,'p', & + & 'atmnh3','Atmospheric ammonia',' ','ppt',0) + call ncdefvar3d(SRF_ATMN2O(iogrp),cmpflg,'p', & + & 'atmn2o','Atmospheric nitrous oxide',' ','ppt',0) #endif ! --- define 3d layer fields call ncdefvar3d(LYR_DP(iogrp),cmpflg,'p', & From 4dc5ac699da7ae8debe3e323b9af763fb0707580 Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Mon, 27 Mar 2023 15:47:42 +0200 Subject: [PATCH 283/366] Change output frequency for fluxes of NH3 and N2O to monthly mean --- cime_config/buildnml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/cime_config/buildnml b/cime_config/buildnml index d60723a3..ab130f33 100755 --- a/cime_config/buildnml +++ b/cime_config/buildnml @@ -474,9 +474,9 @@ set SRF_CO2FXU = '4, 2, 2' set SRF_OXFLUX = '0, 2, 2' set SRF_NIFLUX = '0, 2, 2' set SRF_PN2OM = '0, 2, 2' -set SRF_N2OFX = '0, 0, 2' +set SRF_N2OFX = '0, 2, 2' set SRF_PNH3 = '0, 2, 2' -set SRF_ANH3FX = '0, 0, 2' +set SRF_ANH3FX = '0, 2, 2' set SRF_ATMNH3 = '0, 2, 2' set SRF_ATMN2O = '0, 2, 2' set SRF_DMSFLUX = '0, 2, 2' From 62f67c7f9c295146005d8bfaa2cbc7d259a41d83 Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Mon, 27 Mar 2023 18:35:18 +0200 Subject: [PATCH 284/366] Fix restart file reading for extended nitrogen cycle pore water tracers Only read N-cycle pore water tracers, when N-cycle was switched on before (NH4 present in water column) --- hamocc/aufr_bgc.F90 | 2 ++ 1 file changed, 2 insertions(+) diff --git a/hamocc/aufr_bgc.F90 b/hamocc/aufr_bgc.F90 index b9e5f410..04218704 100644 --- a/hamocc/aufr_bgc.F90 +++ b/hamocc/aufr_bgc.F90 @@ -521,9 +521,11 @@ SUBROUTINE AUFR_BGC(kpie,kpje,kpke,ntr,ntrbgc,itrbgc,trc, & ENDIF #endif #ifdef extNcycle + IF(lread_extn) THEN CALL read_netcdf_var(ncid,'pownh4',powtra2(1,1,1,ipownh4),2*ks,0,iotype) CALL read_netcdf_var(ncid,'pown2o',powtra2(1,1,1,ipown2o),2*ks,0,iotype) CALL read_netcdf_var(ncid,'powno2',powtra2(1,1,1,ipowno2),2*ks,0,iotype) + ENDIF #endif #endif From 0a27101e51afa9397e010235f5630bc742fae4f2 Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Mon, 27 Mar 2023 19:39:26 +0200 Subject: [PATCH 285/366] Preparing fields for online noy and nhx deposition --- cesm/mod_cesm.F90 | 17 ++++++++-- drivers/mct/import_mct.F | 71 +++++++++++++++++++++++++++++++++++++++- phy/mod_forcing.F90 | 15 ++++++--- 3 files changed, 95 insertions(+), 8 deletions(-) diff --git a/cesm/mod_cesm.F90 b/cesm/mod_cesm.F90 index 10b68da7..191509ae 100644 --- a/cesm/mod_cesm.F90 +++ b/cesm/mod_cesm.F90 @@ -30,7 +30,7 @@ module mod_cesm use mod_forcing, only: trxday, srxday, swa, nsf, lip, sop, eva, rnf, rfi, & fmltfz, sfl, ztx, mty, ustarw, slp, abswnd, & lamult, lasl, ustokes, vstokes, atmco2, atmbrf, & - atmn2o,atmnh3 + atmn2o,atmnh3,atmnhxdep,atmnoydep use mod_ben02, only: initai, rdcsic, rdctsf, fnlzai use mod_seaice, only: ficem use mod_checksum, only: csdiag, chksummsk @@ -79,7 +79,9 @@ module mod_cesm atmco2_da, & ! Atmospheric CO2 concentration [ppm]. atmbrf_da, & ! Atmospheric bromoform concentration [ppt]. atmn2o_da, & ! Atmospheric nitrous oxide concentration [ppt]. - atmnh3_da ! Atmopsheric ammonia concentration [ppt] + atmnh3_da, & ! Atmopsheric ammonia concentration [ppt]. + atmnhxdep_da, & ! Atmospheric nhx deposition field [kgN/m2/s]. + atmnoydep_da ! Atmospheric noy deposition field [kgN/m2/s]. logical :: & smtfrc ! If true, time smooth CESM forcing fields. @@ -92,6 +94,7 @@ module mod_cesm rnf_da, rfi_da, fmltfz_da, sfl_da, ztx_da, mty_da, ustarw_da, & slp_da, abswnd_da, ficem_da, lamult_da, lasl_da, & ustokes_da, vstokes_da, atmco2_da, atmbrf_da,atmn2o_da,atmnh3_da,& + atmnhxdep_da,atmnoydep_da, & smtfrc, l1ci, l2ci,inicon_cesm, inifrc_cesm, getfrc_cesm contains @@ -194,6 +197,8 @@ subroutine getfrc_cesm atmbrf(i, j) = w1*atmbrf_da(i, j, l1ci) + w2*atmbrf_da(i, j, l2ci) atmn2o(i, j) = w1*atmn2o_da(i, j, l1ci) + w2*atmn2o_da(i, j, l2ci) atmnh3(i, j) = w1*atmnh3_da(i, j, l1ci) + w2*atmnh3_da(i, j, l2ci) + atmnhxdep(i, j) = w1*atmnhxdep_da(i, j, l1ci) + w2*atmnhxdep_da(i, j, l2ci) + atmnoydep(i, j) = w1*atmnoydep_da(i, j, l1ci) + w2*atmnoydep_da(i, j, l2ci) enddo enddo do l = 1, isu(j) @@ -235,6 +240,8 @@ subroutine getfrc_cesm call ncdefvar('atmbrf_da', 'x y', ndouble, 8) call ncdefvar('atmn2o_da', 'x y', ndouble, 8) call ncdefvar('atmnh3_da', 'x y', ndouble, 8) + call ncdefvar('atmnoydep_da', 'x y', ndouble, 8) + call ncdefvar('atmnoydep_da', 'x y', ndouble, 8) call ncdefvar('ztx_da', 'x y', ndouble, 8) call ncdefvar('mty_da', 'x y', ndouble, 8) call ncedef @@ -283,6 +290,10 @@ subroutine getfrc_cesm ip, 1, 1._r8, 0._r8, 8) call ncwrtr('atmnh3_da', 'x y', atmnh3_da(1 - nbdy, 1 - nbdy, l2ci), & ip, 1, 1._r8, 0._r8, 8) + call ncwrtr('atmnhxdep_da', 'x y', atmnhxdep_da(1 - nbdy, 1 - nbdy, l2ci), & + ip, 1, 1._r8, 0._r8, 8) + call ncwrtr('atmnoydep_da', 'x y', atmnoydep_da(1 - nbdy, 1 - nbdy, l2ci), & + ip, 1, 1._r8, 0._r8, 8) call ncwrtr('ztx_da', 'x y', ztx_da(1 - nbdy, 1 - nbdy, l2ci), & iu, 1, 1._r8, 0._r8, 8) call ncwrtr('mty_da', 'x y', mty_da(1 - nbdy, 1 - nbdy, l2ci), & @@ -320,6 +331,8 @@ subroutine getfrc_cesm call chksummsk(atmbrf, ip, 1, 'atmbrf') call chksummsk(atmn2o, ip, 1, 'atmn2o') call chksummsk(atmnh3, ip, 1, 'atmnh3') + call chksummsk(atmnhxdep, ip, 1, 'atmnhxdep') + call chksummsk(atmnoydep, ip, 1, 'atmnoydep') endif end subroutine getfrc_cesm diff --git a/drivers/mct/import_mct.F b/drivers/mct/import_mct.F index caf45e52..0de281b4 100644 --- a/drivers/mct/import_mct.F +++ b/drivers/mct/import_mct.F @@ -30,7 +30,8 @@ subroutine import_mct(x2o_o, lsize, perm, jjcpl) use mod_cesm, only: swa_da, nsf_da, hmlt_da, lip_da, sop_da, . eva_da, rnf_da, rfi_da, fmltfz_da, sfl_da, . ztx_da, mty_da, ustarw_da, slp_da, abswnd_da, - . atmco2_da, atmbrf_da,atmn2o_da,atmnh3_da, + . atmco2_da, atmbrf_da,atmn2o_da,atmnh3_da, + . atmnhxdep_da,atmnoydep_da . ficem_da, l1ci, l2ci use mod_utility, only: util1, util2 use mod_checksum, only: csdiag, chksummsk @@ -413,6 +414,72 @@ subroutine import_mct(x2o_o, lsize, perm, jjcpl) if (mnproc.eq.1) . write (lp,*) 'import_mct: prog. atmospheric ammonia not read' endif + if (index_x2o_Faxa_nhx > 0) then + n = 0 + do j = 1, jjcpl + do i = 1, ii + n = n + 1 + if (ip(i,j) == 0) then + atmnhxdep_da(i,j,l2ci) = mval + elseif (cplmsk(i,j) == 0) then + atmnhxdep_da(i,j,l2ci) = fval + else + ! Atmospheric nhx deposition [kgN/m2/sec] + atmnhxdep_da(i,j,l2ci) = + . x2o_o%rAttr(index_x2o_Faxa_nhx,n) + endif + enddo + enddo + call fill_global(mval, fval, halo_ps, + . atmnhxdep_da(1-nbdy,1-nbdy,l2ci)) + if (mnproc.eq.1) + . write (lp,*) 'import_mct: atmospheric nhx deposition read' + else + do j = 1, jj + do i = 1, ii + if (ip(i,j) == 0) then + atmnhxdep_da(i,j,l2ci) = mval + else + atmnhxdep_da(i,j,l2ci) = -1 + endif + enddo + enddo + if (mnproc.eq.1) + . write (lp,*) 'import_mct: atmospheric nhx deposition not read' + endif + if (index_x2o_Faxa_noy > 0) then + n = 0 + do j = 1, jjcpl + do i = 1, ii + n = n + 1 + if (ip(i,j) == 0) then + atmnoydep_da(i,j,l2ci) = mval + elseif (cplmsk(i,j) == 0) then + atmnoydep_da(i,j,l2ci) = fval + else + ! Atmospheric noy deposition [kgN/m2/sec] + atmnoydep_da(i,j,l2ci) = + . x2o_o%rAttr(index_x2o_Faxa_noy,n) + endif + enddo + enddo + call fill_global(mval, fval, halo_ps, + . atmnoydep_da(1-nbdy,1-nbdy,l2ci)) + if (mnproc.eq.1) + . write (lp,*) 'import_mct: atmospheric noy deposition read' + else + do j = 1, jj + do i = 1, ii + if (ip(i,j) == 0) then + atmnoydep_da(i,j,l2ci) = mval + else + atmnoydep_da(i,j,l2ci) = -1 + endif + enddo + enddo + if (mnproc.eq.1) + . write (lp,*) 'import_mct: atmospheric noy deposition not read' + endif if (csdiag) then @@ -439,6 +506,8 @@ subroutine import_mct(x2o_o, lsize, perm, jjcpl) call chksummsk(atmbrf_da(1-nbdy,1-nbdy,l2ci),ip,1,'atmbrf') call chksummsk(atmn2o_da(1-nbdy,1-nbdy,l2ci),ip,1,'atmn2o') call chksummsk(atmnh3_da(1-nbdy,1-nbdy,l2ci),ip,1,'atmnh3') + call chksummsk(atmnhxdep_da(1-nbdy,1-nbdy,l2ci),ip,1,'atmnhxdep') + call chksummsk(atmnoydep_da(1-nbdy,1-nbdy,l2ci),ip,1,'atmnoydep') endif end subroutine import_mct diff --git a/phy/mod_forcing.F90 b/phy/mod_forcing.F90 index ac9a7be6..a0ef31c2 100644 --- a/phy/mod_forcing.F90 +++ b/phy/mod_forcing.F90 @@ -118,8 +118,9 @@ module mod_forcing flxn2o, & ! sea-air nitrous oxide flux [kg N2O m-2 s-1] atmn2o, & ! atmospheric nitrous oxide concentration [pptv] flxnh3, & ! sea-air ammonia flux [kg NH3 m-2 s-1] - atmnh3 ! atmospheric ammonia concentration [pptv] - + atmnh3, & ! atmospheric ammonia concentration [pptv] + atmnhxdep,& ! atmospheric nhx deposition [kgN/m2/s] + atmnoydep ! atmospheric noy deposition [kgN/m2/s] real(r8), dimension(1 - nbdy:idm + nbdy,1 - nbdy:jdm + nbdy) :: & surflx, & ! Surface thermal energy flux [W cm-2]. @@ -148,7 +149,7 @@ module mod_forcing swa, nsf, hmltfz, lip, sop, eva, rnf, rfi, fmltfz, sfl, ztx, mty, & ustarw, slp, abswnd, lamult, lasl, ustokes, vstokes, & atmco2, flxco2, flxdms, flxbrf, atmbrf, & - atmn2o,flxn2o,atmnh3,flxnh3, & + atmn2o,flxn2o,atmnh3,flxnh3, atmnhxdep,atmnoydep, & surflx, surrlx, sswflx, salflx, brnflx, salrlx, taux, tauy, & ustar, ustarb, ustar3, buoyfl, t_sw_nonloc, & inivar_forcing, fwbbal @@ -191,10 +192,12 @@ subroutine inivar_forcing flxdms(i, j) = spval atmbrf(i, j) = spval flxbrf(i, j) = spval - atmn2o(i, j) = spval + atmn2o(i, j) = -spval flxn2o(i, j) = spval - atmnh3(i, j) = spval + atmnh3(i, j) = -spval flxnh3(i, j) = spval + atmnhxdep(i, j) = spval + atmnoydep(i, j) = spval surflx(i, j) = spval surrlx(i, j) = spval sswflx(i, j) = spval @@ -229,6 +232,8 @@ subroutine inivar_forcing flxbrf(i, j) = 0._r8 flxn2o(i, j) = 0._r8 flxnh3(i, j) = 0._r8 + atmnhxdep(i, j) = 0._r8 + atmnoydep(i, j) = 0._r8 ustar (i, j) = 0._r8 ustarb(i, j) = 0._r8 enddo From 6a0b4b153c30e04f89ac1968a2e5c1940893ba28 Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Tue, 28 Mar 2023 17:57:40 +0200 Subject: [PATCH 286/366] Applying atmospherically provided N-deposition fluxes --- hamocc/accfields.F90 | 14 +++++++++----- hamocc/hamocc4bcm.F90 | 35 +++++++++++++++++++++++++++++------ hamocc/hamocc_init.F90 | 5 +++-- hamocc/hamocc_step.F90 | 11 ++++++----- hamocc/inventory_bgc.F90 | 34 +++++++++++++++++++++++++--------- hamocc/mo_apply_ndep.F90 | 28 ++++++++++++++++++++-------- hamocc/mo_bgcmean.F90 | 5 +++-- hamocc/mo_carbch.F90 | 22 +++++++++++++++++----- hamocc/mo_control_bgc.F90 | 1 + hamocc/mo_read_ndep.F90 | 17 +++++++++++++---- hamocc/ncout_hamocc.F90 | 2 +- 11 files changed, 127 insertions(+), 47 deletions(-) diff --git a/hamocc/accfields.F90 b/hamocc/accfields.F90 index c2f7b367..c9388452 100644 --- a/hamocc/accfields.F90 +++ b/hamocc/accfields.F90 @@ -46,7 +46,7 @@ SUBROUTINE ACCFIELDS(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask) !********************************************************************** use mod_xc, only: mnproc use mod_dia, only: ddm - use mo_carbch, only: atm,atmflx,co2fxd,co2fxu,co3,hi,kwco2sol,ndepflx,rivinflx,ocetra,omegaa,omegac,pco2d,satoxy, & + use mo_carbch, only: atm,atmflx,co2fxd,co2fxu,co3,hi,kwco2sol,ndepnoyflx,rivinflx,ocetra,omegaa,omegac,pco2d,satoxy, & & sedfluxo,sedfluxb,pco2m,kwco2d,co2sold,co2solm,pn2om use mo_biomod, only: bsiflx_bot,bsiflx0100,bsiflx0500,bsiflx1000,bsiflx2000,bsiflx4000,calflx_bot,calflx0100,calflx0500,& & calflx1000,calflx2000,calflx4000,carflx_bot,carflx0100,carflx0500,carflx1000,carflx2000,carflx4000,& @@ -64,7 +64,7 @@ SUBROUTINE ACCFIELDS(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask) & jlvlnatdic,jlvlnatomegaa,jlvlnatomegac,jlvlnos,jlvlo2sat,jlvlomegaa,jlvlomegac,jlvlopal,jlvloxygen,& & jlvlph,jlvlphosph,jlvlphosy,jlvlphyto,jlvlphyto13,jlvlpoc,jlvlpoc13,jlvlprefalk,jlvlprefdic, & & jlvlprefo2,jlvlprefpo4,jlvlsf6,jlvlsilica,jlvlwnos,jlvlwphy,jn2flux,jn2o,jn2oflux,jn2ofx, & - & jprorca,jprcaca,jsilpro,jpodiic,jpodial,jpodiph,jpodiox,jpodin2,jpodino3,jpodisi,jndep, & + & jprorca,jprcaca,jsilpro,jpodiic,jpodial,jpodiph,jpodiox,jpodin2,jpodino3,jpodisi,jndepnoy,jndepnhx,& & jniflux,jnos,jo2flux,jo2sat,jomegaa,jomegac,jopal,joxflux,joxygen,jpco2,jpco2m,jkwco2khm,jco2khm, & & jco2kh,jph,jphosph,jphosy,jphyto,jpoc,jprefalk,jprefdic,jprefo2,jprefpo4,jsilica,jsrfalkali, & & jsrfano3,jsrfdic,jsrfiron,jsrfoxygen,jsrfphosph,jsrfphyto,jsrfsilica,jsrfph,jwnos,jwphy, & @@ -117,7 +117,7 @@ SUBROUTINE ACCFIELDS(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask) & jpowno3,jsssc12,jssso12,jssssil,jssster,accbur,accsdm #endif #ifdef extNcycle - use mo_carbch, only: pnh3 + use mo_carbch, only: pnh3,ndepnhxflx use mo_param1_bgc, only: iatmnh3,ianh4,iano2,ipownh4,ipown2o,ipowno2 use mo_bgcmean, only: jnh3flux,janh3fx,janh4,jano2,jsrfanh4,jsrfano2,jsrfpnh3, & & jnitr_NH4,jnitr_NO2,jnitr_N2O_prod,jnitr_NH4_OM,jnitr_NO2_OM,jdenit_NO3,jdenit_NO2,jdenit_N2O, & @@ -185,6 +185,7 @@ SUBROUTINE ACCFIELDS(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask) bgct2d(i,j,jn2oflux) = bgct2d(i,j,jn2oflux) + atmflx(i,j,iatmn2o)/2.0 #ifdef extNcycle bgct2d(i,j,jnh3flux) = bgct2d(i,j,jnh3flux) + atmflx(i,j,iatmnh3)/2.0 + bgct2d(i,j,jndepnhx) = bgct2d(i,j,jndepnhx) + ndepnhxflx(i,j)/2.0 #endif ! Particle fluxes between water-column and sediment bgct2d(i,j,jprorca) = bgct2d(i,j,jprorca) + carflx_bot(i,j)/2.0 @@ -201,7 +202,7 @@ SUBROUTINE ACCFIELDS(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask) bgct2d(i,j,jpodisi) = bgct2d(i,j,jpodisi) + sedfluxo(i,j,ipowasi)/2.0 #endif ! N-deposition and riverine input fluxes - bgct2d(i,j,jndep) = bgct2d(i,j,jndep) + ndepflx(i,j)/2.0 + bgct2d(i,j,jndepnoy) = bgct2d(i,j,jndepnoy) + ndepnoyflx(i,j)/2.0 bgct2d(i,j,jirdin) = bgct2d(i,j,jirdin) + rivinflx(i,j,irdin)/2.0 bgct2d(i,j,jirdip) = bgct2d(i,j,jirdip) + rivinflx(i,j,irdip)/2.0 bgct2d(i,j,jirsi) = bgct2d(i,j,jirsi) + rivinflx(i,j,irsi)/2.0 @@ -612,8 +613,11 @@ SUBROUTINE ACCFIELDS(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask) ENDDO atmflx=0. ! nullifying atm flux here to have zero fluxes for stepwise inventory fluxes - ndepflx=0. + ndepnoyflx=0. rivinflx=0. +#ifdef extNcycle + ndepnhxflx=0. +#endif RETURN END diff --git a/hamocc/hamocc4bcm.F90 b/hamocc/hamocc4bcm.F90 index 2fa80d61..fcd00a21 100644 --- a/hamocc/hamocc4bcm.F90 +++ b/hamocc/hamocc4bcm.F90 @@ -22,7 +22,7 @@ SUBROUTINE HAMOCC4BCM(kpie,kpje,kpke,kbnd,kplyear,kplmon,kplday,kldtday,& dust,rivin,ndep,oafx,pi_ph, & pfswr,psicomo,ppao,pfu10,ptho,psao, & patmco2,pflxco2,pflxdms,patmbromo,pflxbromo, & - patmn2o,pflxn2o,patmnh3,pflxnh3) + patmn2o,pflxn2o,patmnh3,pflxnh3,patmnhxdep,patmnoydep) !****************************************************************************** ! ! HAMOCC4BGC - main routine of iHAMOCC. @@ -87,13 +87,16 @@ SUBROUTINE HAMOCC4BCM(kpie,kpje,kpke,kbnd,kplyear,kplmon,kplday,kldtday,& ! *REAL* *patmnh3* - atmospheric ammonia concentration [ppt] used in ! fully coupled mode. ! *REAL* *pflxnh3* - Ammonia flux [kg NH3 /m^2/s]. +! *REAL* *patmnhxdep* - Atmospheric NHx deposition kgN/m2/s +! *REAL* *patmnoydep* - Atmospheric NOy deposition kgN/m2/s ! !****************************************************************************** use mod_xc, only: mnproc use mo_carbch, only: atmflx,ocetra,atm use mo_biomod, only: strahl use mo_control_bgc, only: ldtrunbgc,dtbgc,ldtbgc,io_stdo_bgc,dtbgc,ndtdaybgc, & - do_sedspinup,sedspin_yr_s,sedspin_yr_e,sedspin_ncyc + do_sedspinup,sedspin_yr_s,sedspin_yr_e,sedspin_ncyc,& + do_ndep_coupled use mo_param1_bgc, only: iatmco2,iatmdms,nocetra,nriv use mo_vgrid, only: set_vgrid use mo_apply_fedep, only: apply_fedep @@ -124,7 +127,7 @@ SUBROUTINE HAMOCC4BCM(kpie,kpje,kpke,kbnd,kplyear,kplmon,kplday,kldtday,& REAL, intent(in) :: omask (kpie,kpje) REAL, intent(in) :: dust (kpie,kpje) REAL, intent(in) :: rivin (kpie,kpje,nriv) - REAL, intent(in) :: ndep (kpie,kpje) + REAL, intent(inout):: ndep (kpie,kpje,2) REAL, intent(in) :: oafx (kpie,kpje) REAL, intent(in) :: pi_ph (kpie,kpje) REAL, intent(in) :: pfswr (1-kbnd:kpie+kbnd,1-kbnd:kpje+kbnd) @@ -142,10 +145,13 @@ SUBROUTINE HAMOCC4BCM(kpie,kpje,kpke,kbnd,kplyear,kplmon,kplday,kldtday,& REAL, intent(out) :: pflxn2o(1-kbnd:kpie+kbnd,1-kbnd:kpje+kbnd) REAL, intent(in) :: patmnh3(1-kbnd:kpie+kbnd,1-kbnd:kpje+kbnd) REAL, intent(out) :: pflxnh3(1-kbnd:kpie+kbnd,1-kbnd:kpje+kbnd) + REAL, intent(in) :: patmnhxdep(1-kbnd:kpie+kbnd,1-kbnd:kpje+kbnd) + REAL, intent(in) :: patmnoydep(1-kbnd:kpie+kbnd,1-kbnd:kpje+kbnd) INTEGER :: i,j,k,l INTEGER :: nspin,it LOGICAL :: lspin + REAL :: fatmndep IF (mnproc.eq.1) THEN write(io_stdo_bgc,*) 'iHAMOCC',KLDTDAY,LDTRUNBGC,NDTDAYBGC @@ -222,11 +228,28 @@ SUBROUTINE HAMOCC4BCM(kpie,kpje,kpke,kbnd,kplyear,kplmon,kplday,kldtday,& ENDDO ENDDO !$OMP END PARALLEL DO - if (mnproc.eq.1) write (io_stdo_bgc,*) 'iHAMOCC: getting N2O and NH3 from atm' + if (mnproc.eq.1) write (io_stdo_bgc,*) 'iHAMOCC: getting N2O and NH3 conc. from atm' + + IF(do_ndep_coupled) THEN + fatmndep = 365.*86400./14.00674 + ndep(:,:,:) = 0. +!$OMP PARALLEL DO PRIVATE(i) + DO j=1,kpje + DO i=1,kpie + ! convert from kgN/m2/s to climatological input file units: kmolN/m2/yr + IF (patmnoydep(i,j).gt.0.) THEN + ndep(i,j,1) = patmnoydep(i,j)*fatmndep + ENDIF + IF (patmnhxdep(i,j).gt.0.) THEN + ndep(i,j,2) = patmnhxdep(i,j)*fatmndep + ENDIF + ENDDO + ENDDO +!$OMP END PARALLEL DO + if (mnproc.eq.1) write (io_stdo_bgc,*) 'iHAMOCC: getting NOy and NHx deposition from atm' + ENDIF #endif - - !-------------------------------------------------------------------- ! Read atmospheric cfc concentrations ! diff --git a/hamocc/hamocc_init.F90 b/hamocc/hamocc_init.F90 index 40d831a5..147e1769 100644 --- a/hamocc/hamocc_init.F90 +++ b/hamocc/hamocc_init.F90 @@ -46,7 +46,8 @@ subroutine hamocc_init(read_rest,rstfnm_hamocc) & do_ndep,do_rivinpt,do_oalk,do_sedspinup, & & sedspin_yr_s,sedspin_yr_e,sedspin_ncyc, & & dtb,dtbgc,io_stdo_bgc,ldtbgc, & - & ldtrunbgc,ndtdaybgc,with_dmsph,l_3Dvarsedpor,lm4ago + & ldtrunbgc,ndtdaybgc,with_dmsph,l_3Dvarsedpor,lm4ago,& + & do_ndep_coupled use mo_param1_bgc, only: ks,init_por2octra_mapping use mo_carbch, only: alloc_mem_carbch,ocetra,atm,atm_co2 use mo_biomod, only: alloc_mem_biomod @@ -88,7 +89,7 @@ subroutine hamocc_init(read_rest,rstfnm_hamocc) & sedspin_yr_e,sedspin_ncyc, & & inidic,inialk,inipo4,inioxy,inino3,inisil, & & inid13c,inid14c,swaclimfile, & - & with_dmsph,pi_ph_file,l_3Dvarsedpor,sedporfile,lm4ago + & with_dmsph,pi_ph_file,l_3Dvarsedpor,sedporfile,lm4ago,do_ndep_coupled ! ! --- Set io units and some control parameters ! diff --git a/hamocc/hamocc_step.F90 b/hamocc/hamocc_step.F90 index 20913fd6..0dc73678 100644 --- a/hamocc/hamocc_step.F90 +++ b/hamocc/hamocc_step.F90 @@ -27,7 +27,8 @@ subroutine hamocc_step(m,n,mm,nn,k1m,k1n) use mod_grid, only: plat use mod_state, only: temp,saln use mod_forcing, only: swa,slp,abswnd,atmco2,flxco2,flxdms, & - & atmbrf,flxbrf,atmn2o,flxn2o,atmnh3,flxnh3 + & atmbrf,flxbrf,atmn2o,flxn2o,atmnh3,flxnh3,atmnhxdep,& + & atmnoydep use mod_seaice, only: ficem use mo_bgcmean, only: nbgc,bgcwrt, diagfq_bgc,diagmon_bgc, & & diagann_bgc @@ -38,14 +39,14 @@ subroutine hamocc_step(m,n,mm,nn,k1m,k1n) use mo_read_ndep, only: get_ndep use mo_read_oafx, only: get_oafx use mo_read_pi_ph, only: get_pi_ph,pi_ph - use mo_control_bgc, only: with_dmsph + use mo_control_bgc, only: with_dmsph,do_ndep_coupled implicit none integer, intent(in) :: m,n,mm,nn,k1m,k1n integer :: l,ldtday - real :: ndep(idm,jdm) + real :: ndep(idm,jdm,2) ! 1=NO3, 2=NH4 (in case of extNcycle) real :: dust(idm,jdm) real :: oafx(idm,jdm) @@ -65,7 +66,7 @@ subroutine hamocc_step(m,n,mm,nn,k1m,k1n) enddo call get_fedep(idm,jdm,date%month,dust) - call get_ndep(idm,jdm,date%year,date%month,omask,ndep) + if (.not. do_ndep_coupled) call get_ndep(idm,jdm,date%year,date%month,omask,ndep) call get_oafx(idm,jdm,date%year,date%month,omask,oafx) if(with_dmsph) call get_pi_ph(idm,jdm,date%month) @@ -76,7 +77,7 @@ subroutine hamocc_step(m,n,mm,nn,k1m,k1n) & swa,ficem,slp,abswnd, & & temp(1-nbdy,1-nbdy,1+nn),saln(1-nbdy,1-nbdy,1+nn), & & atmco2,flxco2,flxdms,atmbrf,flxbrf, & - & atmn2o,flxn2o,atmnh3,flxnh3) + & atmn2o,flxn2o,atmnh3,flxnh3,atmnhxdep,atmnoydep) ! ! --- accumulate fields and write output diff --git a/hamocc/inventory_bgc.F90 b/hamocc/inventory_bgc.F90 index f8b41d3a..8a491826 100644 --- a/hamocc/inventory_bgc.F90 +++ b/hamocc/inventory_bgc.F90 @@ -53,11 +53,12 @@ SUBROUTINE INVENTORY_BGC(kpie,kpje,kpke,dlxp,dlyp,ddpo,omask,iogrp) ! !********************************************************************** use mod_xc, only: mnproc,ips,nbdy,xcsum - use mo_carbch, only: atm,atmflx,co3,hi,ndepflx,rivinflx,ocetra,sedfluxo + use mo_carbch, only: atm,atmflx,co3,hi,ndepnoyflx,rivinflx,ocetra,sedfluxo use mo_sedmnt, only: prcaca,prorca,silpro use mo_biomod, only: expoor,expoca,exposi,rcar,rnit use mo_control_bgc, only: do_ndep,do_rivinpt,io_stdo_bgc - use mo_bgcmean, only: bgct2d,jco2flux,jirdin,jn2flux,jn2oflux,jndep,jo2flux,jprcaca,jprorca,jsilpro,nbgcmax,glb_inventory + use mo_bgcmean, only: bgct2d,jco2flux,jirdin,jn2flux,jn2oflux,jndepnoy,jndepnhx,jo2flux,jprcaca,jprorca,jsilpro,nbgcmax, & + & glb_inventory use mo_param1_bgc, only: ialkali,ian2o,iano3,iatmco2,iatmn2,iatmn2o,iatmo2,icalc,idet,idoc,igasnit,iopal,ioxygen,iphosph, & & iphy,ipowaic,ipowaox,ipowaph,ipowasi,ipown2,ipowno3,isco212,isilica,isssc12,issso12,issssil,izoo, & & irdin,irdip,irsi,iralk,irdoc,irdet,nocetra,npowtra,nsedtra,nriv @@ -68,6 +69,7 @@ SUBROUTINE INVENTORY_BGC(kpie,kpje,kpke,dlxp,dlyp,ddpo,omask,iogrp) use mo_sedmnt, only: porwat,seddw,sedlay,burial,sedhpl,powtra,porsol #endif #ifdef extNcycle + use mo_carbch, only: ndepnhxflx use mo_param1_bgc, only: ianh4,iano2,iatmnh3,ipownh4,ipown2o,ipowno2 use mo_bgcmean, only: jnh3flux #endif @@ -116,7 +118,8 @@ SUBROUTINE INVENTORY_BGC(kpie,kpje,kpke,dlxp,dlyp,ddpo,omask,iogrp) !--- river fluxes real :: srivflux(nriv) ! sum of riverfluxes !--- atmosphere flux and atmospheric CO2 - real :: sndepflux ! sum of N dep fluxes + real :: sndepnoyflux ! sum of N dep fluxes + real :: sndepnhxflux ! sum of N dep fluxes real :: zatmco2,zatmo2,zatmn2 real :: co2flux,so2flux,sn2flux,sn2oflux,snh3flux real :: zprorca,zprcaca,zsilpro @@ -288,7 +291,8 @@ SUBROUTINE INVENTORY_BGC(kpie,kpje,kpke,dlxp,dlyp,ddpo,omask,iogrp) sn2flux =0. sn2oflux =0. snh3flux =0. - sndepflux=0. + sndepnoyflux=0. + sndepnhxflux=0. srivflux =0. zatmco2 =0. zatmo2 =0. @@ -314,7 +318,10 @@ SUBROUTINE INVENTORY_BGC(kpie,kpje,kpke,dlxp,dlyp,ddpo,omask,iogrp) ! nitrogen deposition if(do_ndep) then - sndepflux = sum2d(ndepflx) + sndepnoyflux = sum2d(ndepnoyflx) +#ifdef extNcycle + sndepnhxflux = sum2d(ndepnhxflx) +#endif endif ! river fluxes @@ -333,7 +340,10 @@ SUBROUTINE INVENTORY_BGC(kpie,kpje,kpke,dlxp,dlyp,ddpo,omask,iogrp) ! nitrogen deposition fluxes if(do_ndep) then - sndepflux = sum2d(bgct2d(:,:,jndep)) + sndepnoyflux = sum2d(bgct2d(:,:,jndepnoy)) +#ifdef extNcycle + sndepnhxflux = sum2d(bgct2d(:,:,jndepnhx)) +#endif endif ! River fluxes @@ -379,10 +389,11 @@ SUBROUTINE INVENTORY_BGC(kpie,kpje,kpke,dlxp,dlyp,ddpo,omask,iogrp) & +zpowtratot(ipowno3)+zpowtratot(ipown2)*2 & & +zsedlayto(issso12)*rnit+zburial(issso12)*rnit & & +zocetratot(ian2o)*2 & - & - sndepflux & + & - sndepnoyflux & & +zprorca*rnit & #ifdef extNcycle & +zocetratot(ianh4)+zocetratot(iano2)+snh3flux & + & - sndepnhxflux & & +zpowtratot(ipownh4)+zpowtratot(ipown2o)*2+zpowtratot(ipowno2) & #endif #if defined(BOXATM) @@ -413,7 +424,7 @@ SUBROUTINE INVENTORY_BGC(kpie,kpje,kpke,dlxp,dlyp,ddpo,omask,iogrp) ! & +zburial(issso12)*(-24.) + zburial(isssc12) & & +zpowtratot(ipowno3)*1.5+zpowtratot(ipowaic) & & +zpowtratot(ipowaox)+zpowtratot(ipowaph)*2 & - & - sndepflux*1.5 & + & - sndepnoyflux*1.5 & & +zprorca*(-24.)+zprcaca & #ifdef extNcycle & +zocetratot(iano2) & @@ -617,7 +628,12 @@ subroutine write_stdout ! & zprorca, zprcaca, zsilpro ! WRITE(io_stdo_bgc,*) ' ' - IF(do_ndep) WRITE(io_stdo_bgc,*) 'NdepFlux :',sndepflux + IF(do_ndep) THEN + WRITE(io_stdo_bgc,*) 'NdepNOyFlux :',sndepnoyflux +#ifdef extNcycle + WRITE(io_stdo_bgc,*) 'NdepNHxFlux :',sndepnhxflux +#endif + ENDIF ! riverine fluxes !------------------------------------------------------------------ diff --git a/hamocc/mo_apply_ndep.F90 b/hamocc/mo_apply_ndep.F90 index 36d7159b..24c85e72 100644 --- a/hamocc/mo_apply_ndep.F90 +++ b/hamocc/mo_apply_ndep.F90 @@ -86,15 +86,19 @@ subroutine apply_ndep(kpie,kpje,kpke,pddpo,omask,ndep) !****************************************************************************** use mod_xc, only: mnproc use mo_control_bgc, only: io_stdo_bgc,dtb,do_ndep - use mo_carbch, only: ocetra,ndepflx + use mo_carbch, only: ocetra,ndepnoyflx use mo_param1_bgc, only: iano3,ialkali,inatalkali +#ifdef extNcycle + use mo_carbch, only: ndepnhxflx + use mo_param1_bgc, only: ianh4 +#endif implicit none integer, intent(in) :: kpie,kpje,kpke real, intent(in) :: pddpo(kpie,kpje,kpke) real, intent(in) :: omask(kpie,kpje) - real, intent(in) :: ndep(kpie,kpje) + real, intent(in) :: ndep(kpie,kpje,2) ! local variables integer :: i,j @@ -102,19 +106,27 @@ subroutine apply_ndep(kpie,kpje,kpke,pddpo,omask,ndep) ! ndepflx stores the applied n-deposition flux for inventory calculations ! and output - ndepflx(:,:)=0.0 - + ndepnoyflx(:,:)=0.0 +#ifdef extNcycle + ndepnhxflx(:,:)=0.0 +#endif if (.not. do_ndep) return ! deposite N in topmost layer do j=1,kpje do i=1,kpie if (omask(i,j).gt.0.5) then - ndepflx(i,j) = ndep(i,j)*dtb/365. - ocetra(i,j,1,iano3)=ocetra(i,j,1,iano3)+ndepflx(i,j)/pddpo(i,j,1) - ocetra(i,j,1,ialkali)=ocetra(i,j,1,ialkali)-ndepflx(i,j)/pddpo(i,j,1) + ndepnoyflx(i,j) = ndep(i,j,1)*dtb/365. + ocetra(i,j,1,iano3)=ocetra(i,j,1,iano3)+ndepnoyflx(i,j)/pddpo(i,j,1) + ocetra(i,j,1,ialkali)=ocetra(i,j,1,ialkali)-ndepnoyflx(i,j)/pddpo(i,j,1) #ifdef natDIC - ocetra(i,j,1,inatalkali)=ocetra(i,j,1,inatalkali)-ndepflx(i,j)/pddpo(i,j,1) + ocetra(i,j,1,inatalkali)=ocetra(i,j,1,inatalkali)-ndepnoyflx(i,j)/pddpo(i,j,1) +#endif +#ifdef extNcycle + ndepnhxflx(i,j) = ndep(i,j,2)*dtb/365. + ocetra(i,j,1,ianh4)=ocetra(i,j,1,iano3)+ndepnhxflx(i,j)/pddpo(i,j,1) + ! correct???????? + ocetra(i,j,1,ialkali)=ocetra(i,j,1,ialkali)+ndepnhxflx(i,j)/pddpo(i,j,1) #endif endif enddo diff --git a/hamocc/mo_bgcmean.F90 b/hamocc/mo_bgcmean.F90 index 7278cb40..b413f0ed 100644 --- a/hamocc/mo_bgcmean.F90 +++ b/hamocc/mo_bgcmean.F90 @@ -316,7 +316,7 @@ MODULE mo_bgcmean & jpodin2 =12, & & jpodino3 =13, & & jpodisi =14, & - & jndep =15, & + & jndepnoy =15, & & jirdin =16, & & jirdip =17, & & jirsi =18, & @@ -325,7 +325,8 @@ MODULE mo_bgcmean & jirdoc =21, & & jirdet =22, & & jnh3flux =23, & - & nbgct2d =23 + & jndepnhx =24, & + & nbgct2d =24 !---------------------------------------------------------------- INTEGER, SAVE :: i_bsc_m2d diff --git a/hamocc/mo_carbch.F90 b/hamocc/mo_carbch.F90 index 8c887ee6..c8ef48d2 100644 --- a/hamocc/mo_carbch.F90 +++ b/hamocc/mo_carbch.F90 @@ -58,7 +58,8 @@ MODULE mo_carbch REAL, DIMENSION (:,:,:,:), ALLOCATABLE :: ocetra REAL, DIMENSION (:,:,:), ALLOCATABLE :: atm REAL, DIMENSION (:,:,:), ALLOCATABLE :: atmflx - REAL, DIMENSION (:,:), ALLOCATABLE :: ndepflx + REAL, DIMENSION (:,:), ALLOCATABLE :: ndepnoyflx + REAL, DIMENSION (:,:), ALLOCATABLE :: ndepnhxflx REAL, DIMENSION (:,:,:), ALLOCATABLE :: rivinflx REAL, DIMENSION (:,:,:), ALLOCATABLE :: co3 REAL, DIMENSION (:,:,:), ALLOCATABLE :: co2star @@ -333,15 +334,15 @@ SUBROUTINE ALLOC_MEM_CARBCH(kpie,kpje,kpke) ! Allocate field to hold N-deposition fluxes per timestep for inventory caluclations IF (mnproc.eq.1) THEN - WRITE(io_stdo_bgc,*)'Memory allocation for variable ndepflx ...' + WRITE(io_stdo_bgc,*)'Memory allocation for variable ndepnoyflx ...' WRITE(io_stdo_bgc,*)'First dimension : ',kpie WRITE(io_stdo_bgc,*)'Second dimension : ',kpje !WRITE(io_stdo_bgc,*)'Third dimension : ',natm ENDIF - ALLOCATE (ndepflx(kpie,kpje),stat=errstat) - if(errstat.ne.0) stop 'not enough memory ndepflx' - ndepflx(:,:) = 0.0 + ALLOCATE (ndepnoyflx(kpie,kpje),stat=errstat) + if(errstat.ne.0) stop 'not enough memory ndepnoyflx' + ndepnoyflx(:,:) = 0.0 ! Allocate field to hold riverine fluxes per timestep for inventory caluclations IF (mnproc.eq.1) THEN @@ -455,6 +456,17 @@ SUBROUTINE ALLOC_MEM_CARBCH(kpie,kpje,kpke) ALLOCATE (pnh3(kpie,kpje),stat=errstat) if(errstat.ne.0) stop 'not enough memory pnh3' pnh3(:,:) = 0.0 + + ! Allocate field to hold N-deposition NHx fluxes per timestep for inventory caluclations + IF (mnproc.eq.1) THEN + WRITE(io_stdo_bgc,*)'Memory allocation for variable ndepnhxflx ...' + WRITE(io_stdo_bgc,*)'First dimension : ',kpie + WRITE(io_stdo_bgc,*)'Second dimension : ',kpje + ENDIF + + ALLOCATE (ndepnhxflx(kpie,kpje),stat=errstat) + if(errstat.ne.0) stop 'not enough memory ndepnhxflx' + ndepnhxflx(:,:) = 0.0 #endif !****************************************************************************** diff --git a/hamocc/mo_control_bgc.F90 b/hamocc/mo_control_bgc.F90 index e3f7708e..ce1965a4 100644 --- a/hamocc/mo_control_bgc.F90 +++ b/hamocc/mo_control_bgc.F90 @@ -61,6 +61,7 @@ MODULE mo_control_bgc ! Logical switches set via namelist LOGICAL, save :: l_3Dvarsedpor = .false. ! apply lon-lat-depth variable sediment porosity via input file LOGICAL, save :: do_ndep =.true. ! apply n-deposition + LOGICAL, save :: do_ndep_coupled = .false. ! for coupled simulations, use field provided by atmosphere LOGICAL, save :: do_rivinpt =.true. ! apply riverine input LOGICAL, save :: do_sedspinup=.false. ! apply sediment spin-up LOGICAL, save :: do_oalk =.false. ! apply ocean alkalinization diff --git a/hamocc/mo_read_ndep.F90 b/hamocc/mo_read_ndep.F90 index 191dac74..f4b8bb08 100644 --- a/hamocc/mo_read_ndep.F90 +++ b/hamocc/mo_read_ndep.F90 @@ -198,16 +198,16 @@ subroutine get_ndep(kpie,kpje,kplyear,kplmon,omask,ndep) integer, intent(in) :: kpie,kpje,kplyear,kplmon real, intent(in) :: omask(kpie,kpje) - real, intent(out) :: ndep(kpie,kpje) + real, intent(out) :: ndep(kpie,kpje,2) ! local variables - integer :: month_in_file,ncstat,ncid + integer :: month_in_file,ncstat,ncid,i,j integer, save :: oldmonth=0 ! if N-deposition is switched off set ndep to zero and return if (.not. do_ndep) then - ndep(:,:) = 0.0 + ndep(:,:,:) = 0.0 return endif @@ -225,7 +225,16 @@ subroutine get_ndep(kpie,kpje,kplyear,kplmon,omask,ndep) oldmonth=kplmon endif - ndep(:,:) = ndepread +!$OMP PARALLEL DO PRIVATE(i) + ! 1 = NO3; 2 = NH4 + ! needs further preparation (split of climatological input data + sep. reading) + DO j=1,kpje + DO i=1,kpie + ndep(i,j,1) = ndepread(i,j) + ndep(i,j,2) = 0. + ENDDO + ENDDO +!$OMP END PARALLEL DO !****************************************************************************** end subroutine get_ndep diff --git a/hamocc/ncout_hamocc.F90 b/hamocc/ncout_hamocc.F90 index 90280e57..598294a8 100644 --- a/hamocc/ncout_hamocc.F90 +++ b/hamocc/ncout_hamocc.F90 @@ -77,7 +77,7 @@ subroutine ncwrt_bgc(iogrp) & jlvlpoc13,jlvlprefalk,jlvlprefdic, & & jlvlprefo2,jlvlprefpo4,jlvlsf6,jlvlsilica, & & jlvlwnos,jlvlwphy,jn2flux,jn2o,jsrfpn2om,jn2oflux, & - & jn2ofx,jndep,jniflux,jnos,jo2flux,jo2sat, & + & jn2ofx,jndepnoy,jniflux,jnos,jo2flux,jo2sat, & & jomegaa,jomegac,jopal,joxflux,joxygen,jpco2, & & jpco2m,jkwco2khm,jco2kh,jco2khm, & & jph,jphosph,jphosy,jphyto,jpoc,jprefalk, & From 0e8ab8ff7a36dc141c3afbdcc3ab2fffca73a22f Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Tue, 28 Mar 2023 18:00:54 +0200 Subject: [PATCH 287/366] Add switch for atm N-dep to namlelist and set it dependent on compset --- cime_config/buildnml | 14 +++++++++++++- cime_config/config_component.xml | 12 ++++++++++++ 2 files changed, 25 insertions(+), 1 deletion(-) diff --git a/cime_config/buildnml b/cime_config/buildnml index ab130f33..4ba1f758 100755 --- a/cime_config/buildnml +++ b/cime_config/buildnml @@ -19,6 +19,7 @@ set RUNDIR = `./xmlquery RUNDIR --value` set BLOM_TRACER_MODULES = `./xmlquery BLOM_TRACER_MODULES --value` set BLOM_RIVER_NUTRIENTS = `./xmlquery BLOM_RIVER_NUTRIENTS --value` set BLOM_N_DEPOSITION = `./xmlquery BLOM_N_DEPOSITION --value` +set ATM_N_DEPOSITION = `./xmlquery HAMOCC_ATMNDEPC --value` set BLOM_NDEP_SCENARIO = `./xmlquery BLOM_NDEP_SCENARIO --value` set HAMOCC_VSLS = `./xmlquery HAMOCC_VSLS --value` set HAMOCC_CISO = `./xmlquery HAMOCC_CISO --value` @@ -244,6 +245,15 @@ else set DO_NDEP = .false. set NDEPFNAME = "''" endif + +if (ATM_N_DEPOSITION == TRUE) then + set DO_NDEP = .true. + set DO_NDEP_COUPLED = .true. + set NDEPFNAME = "''" +else + set DO_NDEP_COUPLED = .false. +endif + if ($HAMOCC_SEDSPINUP == TRUE) then set DO_SEDSPINUP = .true. set SEDSPIN_YR_S = $HAMOCC_SEDSPINUP_YR_START @@ -1611,7 +1621,8 @@ cat >>! $RUNDIR/ocn_in$inststr << EOF ! if bromoform scheme is activated) ! DO_RIVINPT : Logical switch to activate riverine input ! RIVINFILE : File name (incl. full path) for riverine input data -! DO_NDEP : Logical switch to activate N-deposition +! DO_NDEP : Logical switch to activate N-deposition (climatological or atm) +! DO_NDEP_COUPLED: Logical to apply N-deposition fluxes received from the atmosphere (true=atm, false=clim) ! NDEPFILE : File name (incl. full path) for atmopheric N-deposition data ! DO_SEDSPINUP: Logical switch to activate sediment spin-up ! SEDSPIN_YR_S: Start year for sediment spinup @@ -1631,6 +1642,7 @@ cat >>! $RUNDIR/ocn_in$inststr << EOF DO_RIVINPT = $DO_RIVINPT RIVINFILE = $RIVINFILE DO_NDEP = $DO_NDEP + DO_NDEP_COUPLED = $DO_NDEP_COUPLED NDEPFILE = $NDEPFILE DO_SEDSPINUP = $DO_SEDSPINUP SEDSPIN_YR_S = $SEDSPIN_YR_S diff --git a/cime_config/config_component.xml b/cime_config/config_component.xml index a851ac00..3cfaddec 100644 --- a/cime_config/config_component.xml +++ b/cime_config/config_component.xml @@ -228,6 +228,18 @@ env_build.xml Set preprocessor option to activate the NH3 coupling code. Requires module ecosys and EXTNCYCLE + + logical + TRUE,FALSE + FALSE + + TRUE + + build_component_blom + env_build.xml + Set namelist do_ndep_coupled to true for depoistion from atm. Requires module ecosys and EXTNCYCLE + + logical From bf5a83087919a6877104ae5383eb089bc64981bc Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Wed, 29 Mar 2023 14:47:23 +0200 Subject: [PATCH 288/366] fix missing comma --- drivers/mct/import_mct.F | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/drivers/mct/import_mct.F b/drivers/mct/import_mct.F index 0de281b4..8b204e55 100644 --- a/drivers/mct/import_mct.F +++ b/drivers/mct/import_mct.F @@ -31,7 +31,7 @@ subroutine import_mct(x2o_o, lsize, perm, jjcpl) . eva_da, rnf_da, rfi_da, fmltfz_da, sfl_da, . ztx_da, mty_da, ustarw_da, slp_da, abswnd_da, . atmco2_da, atmbrf_da,atmn2o_da,atmnh3_da, - . atmnhxdep_da,atmnoydep_da + . atmnhxdep_da,atmnoydep_da, . ficem_da, l1ci, l2ci use mod_utility, only: util1, util2 use mod_checksum, only: csdiag, chksummsk From 027c596f2fdf0d58626924336bdafca7c3d47eb8 Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Wed, 29 Mar 2023 16:09:46 +0200 Subject: [PATCH 289/366] fix missing $ --- cime_config/buildnml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/cime_config/buildnml b/cime_config/buildnml index 4ba1f758..4aa3b7ee 100755 --- a/cime_config/buildnml +++ b/cime_config/buildnml @@ -246,7 +246,7 @@ else set NDEPFNAME = "''" endif -if (ATM_N_DEPOSITION == TRUE) then +if ($ATM_N_DEPOSITION == TRUE) then set DO_NDEP = .true. set DO_NDEP_COUPLED = .true. set NDEPFNAME = "''" From 33d48311bc36ce7b517fa7dcd7abef9b2256f74d Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Wed, 29 Mar 2023 16:15:32 +0200 Subject: [PATCH 290/366] fix missing & --- hamocc/mo_bgcmean.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/hamocc/mo_bgcmean.F90 b/hamocc/mo_bgcmean.F90 index 26a6b1d0..d97683fe 100644 --- a/hamocc/mo_bgcmean.F90 +++ b/hamocc/mo_bgcmean.F90 @@ -324,7 +324,7 @@ MODULE mo_bgcmean & jiralk =20, & & jiriron =21, & & jirdoc =22, & - & jirdet =23, + & jirdet =23, & & jnh3flux =24, & & nbgct2d =24 From f8e0c0283b0682898378e85c24ca88a257a33ebd Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Wed, 29 Mar 2023 16:42:08 +0200 Subject: [PATCH 291/366] return from ini_read_ndep in case of interactive N-deposition --- hamocc/mo_read_ndep.F90 | 9 ++++++++- 1 file changed, 8 insertions(+), 1 deletion(-) diff --git a/hamocc/mo_read_ndep.F90 b/hamocc/mo_read_ndep.F90 index f4b8bb08..5134c587 100644 --- a/hamocc/mo_read_ndep.F90 +++ b/hamocc/mo_read_ndep.F90 @@ -100,7 +100,7 @@ subroutine ini_read_ndep(kpie,kpje) ! !****************************************************************************** use mod_xc, only: mnproc,xchalt - use mo_control_bgc, only: io_stdo_bgc,do_ndep + use mo_control_bgc, only: io_stdo_bgc,do_ndep,do_ndep_coupled use mod_dia, only: iotype use mod_nctools, only: ncfopn,ncgeti,ncfcls @@ -120,6 +120,13 @@ subroutine ini_read_ndep(kpie,kpje) endif return end if + if (do_ndep_coupled) then + if (mnproc.eq.1) then + write(io_stdo_bgc,*) '' + write(io_stdo_bgc,*) 'ini_read_ndep: N deposition in interactive mode.' + endif + return + end if ! Initialise the module if (.not. lini) then From b285dc9bed19b3636fcf6dc53b625e7c18d0f1cb Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Wed, 29 Mar 2023 20:48:47 +0200 Subject: [PATCH 292/366] formatting changes --- hamocc/hamocc4bcm.F90 | 2 +- hamocc/hamocc_init.F90 | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/hamocc/hamocc4bcm.F90 b/hamocc/hamocc4bcm.F90 index 48391522..e0bd6fbd 100644 --- a/hamocc/hamocc4bcm.F90 +++ b/hamocc/hamocc4bcm.F90 @@ -19,7 +19,7 @@ SUBROUTINE HAMOCC4BCM(kpie,kpje,kpke,kbnd,kplyear,kplmon,kplday,kldtday,& pdlxp,pdlyp,pddpo,prho,pglat,omask, & - dust,rivin,ndep,oafx,pi_ph, & + dust,rivin,ndep,oafx,pi_ph, & pfswr,psicomo,ppao,pfu10,ptho,psao, & patmco2,pflxco2,pflxdms,patmbromo,pflxbromo) !****************************************************************************** diff --git a/hamocc/hamocc_init.F90 b/hamocc/hamocc_init.F90 index 75268e07..b862c1c4 100644 --- a/hamocc/hamocc_init.F90 +++ b/hamocc/hamocc_init.F90 @@ -84,7 +84,7 @@ subroutine hamocc_init(read_rest,rstfnm_hamocc) real :: sed_por(idm,jdm,ks) = 0. namelist /bgcnml/ atm_co2,fedepfile,do_rivinpt,rivinfile,do_ndep,ndepfile, & - & do_oalk,do_sedspinup,sedspin_yr_s, & + & do_oalk,do_sedspinup,sedspin_yr_s, & & sedspin_yr_e,sedspin_ncyc, & & inidic,inialk,inipo4,inioxy,inino3,inisil, & & inid13c,inid14c,swaclimfile, & From 6296a23fb7ec7fb8d5bd747da9ddf2ee4ae7d2a5 Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Wed, 29 Mar 2023 22:45:05 +0200 Subject: [PATCH 293/366] fix buildnml --- cime_config/buildnml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/cime_config/buildnml b/cime_config/buildnml index ded92aee..b3fc4aa0 100755 --- a/cime_config/buildnml +++ b/cime_config/buildnml @@ -1,4 +1,4 @@ - #!/bin/csh -f +#!/bin/csh -f #------------------------------------------------------------------------------ # Get variables from Case XML-files From 683a614f523f8c50568b710792ee6281722358ef Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Thu, 30 Mar 2023 11:21:28 +0200 Subject: [PATCH 294/366] add NHx deposition output --- cime_config/buildnml | 5 ++++- hamocc/accfields.F90 | 6 ++++-- hamocc/mo_bgcmean.F90 | 7 +++++-- hamocc/ncout_hamocc.F90 | 8 ++++++-- 4 files changed, 19 insertions(+), 7 deletions(-) diff --git a/cime_config/buildnml b/cime_config/buildnml index b3fc4aa0..1f68646b 100755 --- a/cime_config/buildnml +++ b/cime_config/buildnml @@ -542,6 +542,7 @@ set FLX_NDEPNOY = '0, 2, 2' else set FLX_NDEPNOY = '0, 0, 0' endif +set FLX_NDEPNHX = '0, 2, 2' set FLX_OALK = '0, 0, 0' set FLX_CAR0100 = '0, 2, 2' set FLX_CAR0500 = '0, 2, 2' @@ -1916,7 +1917,8 @@ cat >>! $RUNDIR/ocn_in$inststr << EOF ! ! Particle fluxes (FLX, e.g CARFLX****, where ****=0100,0500,1000,2000,4000, or _BOT), ! diffusive fluxes at the sediment - water-column interface (SEDIFF*), and other fluxes -! NDEP - Nitrogen deposition flux [mol N m-2 s-1] +! NDEPNOY - Nitrogen NOy deposition flux [mol N m-2 s-1] +! NDEPNHx - Nitrogen NHx deposition flux [mol N m-2 s-1] ! OALK - Flux of alkalinity due to ocean alkalinization [mol N m-2 s-1] ! CARFLX**** - POC flux at **** metres depth [mol C m-2 s-1] ! BSIFLX**** - Biogenic silica flux at **** metres depth [mol Si m-2 s-1] @@ -2039,6 +2041,7 @@ cat >>! $RUNDIR/ocn_in$inststr << EOF INT_NFIX = $INT_NFIX INT_DNIT = $INT_DNIT FLX_NDEPNOY = $FLX_NDEPNOY + FLX_NDEPNHX = $FLX_NDEPNHX FLX_OALK = $FLX_OALK FLX_CAR0100 = $FLX_CAR0100 FLX_CAR0500 = $FLX_CAR0500 diff --git a/hamocc/accfields.F90 b/hamocc/accfields.F90 index 11677e71..4733cbe8 100644 --- a/hamocc/accfields.F90 +++ b/hamocc/accfields.F90 @@ -125,9 +125,10 @@ SUBROUTINE ACCFIELDS(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask) & jDNRA_NO2,janmx_N2_prod,janmx_OM_prod,jphosy_NH4,jphosy_NO3,jremin_aerob,jremin_sulf, & & jpownh4,jpown2o,jpowno2,jsdm_nitr_NH4,jsdm_nitr_NO2,jsdm_nitr_N2O_prod,jsdm_nitr_NH4_OM, & & jsdm_nitr_NO2_OM,jsdm_denit_NO3,jsdm_denit_NO2,jsdm_denit_N2O,jsdm_DNRA_NO2,jsdm_anmx_N2_prod, & - & jsdm_anmx_OM_prod,jsdm_remin_aerob,jsdm_remin_sulf,jsediffnh4,jsediffn2o,jsediffno2,jatmn2o,jatmnh3 + & jsdm_anmx_OM_prod,jsdm_remin_aerob,jsdm_remin_sulf,jsediffnh4,jsediffn2o,jsediffno2,jatmn2o,jatmnh3,& + & jndepnhxfx use mo_biomod, only: nitr_NH4,nitr_NO2,nitr_N2O_prod,nitr_NH4_OM,nitr_NO2_OM,denit_NO3,denit_NO2,denit_N2O,DNRA_NO2, & - & anmx_N2_prod,anmx_OM_prod,phosy_NH4,phosy_NO3,remin_aerob,remin_sulf + & anmx_N2_prod,anmx_OM_prod,phosy_NH4,phosy_NO3,remin_aerob,remin_sulf use mo_extNsediment,only: extNsed_diagnostics,ised_nitr_NH4,ised_nitr_NO2,ised_nitr_N2O_prod,ised_nitr_NH4_OM, & & ised_nitr_NO2_OM,ised_denit_NO3,ised_denit_NO2,ised_denit_N2O,ised_DNRA_NO2,ised_anmx_N2_prod, & & ised_anmx_OM_prod,ised_remin_aerob,ised_remin_sulf @@ -307,6 +308,7 @@ SUBROUTINE ACCFIELDS(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask) call accsrf(jsrfanh4,ocetra(1,1,1,ianh4),omask,0) call accsrf(jsrfpnh3,pnh3,omask,0) call accsrf(jsrfano2,ocetra(1,1,1,iano2),omask,0) + call accsrf(jndepnhxfx,ndepnhxflx,omask,0) #endif ! Accumulate the diagnostic mass sinking field diff --git a/hamocc/mo_bgcmean.F90 b/hamocc/mo_bgcmean.F90 index bdbcad33..d4def531 100644 --- a/hamocc/mo_bgcmean.F90 +++ b/hamocc/mo_bgcmean.F90 @@ -97,7 +97,7 @@ MODULE mo_bgcmean & SRF_ATMN2O =0 , & & INT_BROMOPRO =0 ,INT_BROMOUV =0 , & & INT_PHOSY =0 ,INT_NFIX =0 ,INT_DNIT =0 , & - & FLX_NDEPNOY =0 ,FLX_OALK =0 , & + & FLX_NDEPNOY =0 ,FLX_NDEPNHX =0 ,FLX_OALK =0 , & & FLX_CAR0100 =0 ,FLX_CAR0500 =0 ,FLX_CAR1000 =0 , & & FLX_CAR2000 =0 ,FLX_CAR4000 =0 ,FLX_CAR_BOT =0 , & & FLX_BSI0100 =0 ,FLX_BSI0500 =0 ,FLX_BSI1000 =0 , & @@ -213,7 +213,7 @@ MODULE mo_bgcmean & SRF_ATMN2O , & & INT_BROMOPRO ,INT_BROMOUV , & & INT_PHOSY ,INT_NFIX ,INT_DNIT , & - & FLX_NDEPNOY ,FLX_OALK , & + & FLX_NDEPNOY ,FLX_NDEPNHX ,FLX_OALK , & & FLX_CAR0100 ,FLX_CAR0500 ,FLX_CAR1000 , & & FLX_CAR2000 ,FLX_CAR4000 ,FLX_CAR_BOT , & & FLX_BSI0100 ,FLX_BSI0500 ,FLX_BSI1000 , & @@ -373,6 +373,7 @@ MODULE mo_bgcmean & jintnfix = 0 , & & jintdnit = 0 , & & jndepnoyfx = 0 , & + & jndepnhxfx = 0 , & & joalkfx = 0 , & & jcarflx0100= 0 , & & jcarflx0500= 0 , & @@ -872,6 +873,8 @@ SUBROUTINE ALLOC_MEM_BGCMEAN(kpie,kpje,kpke) jsediffn2o(n)=i_bsc_m2d*min(1,FLX_SEDIFFN2O(n)) IF (FLX_SEDIFFNO2(n).GT.0) i_bsc_m2d=i_bsc_m2d+1 jsediffno2(n)=i_bsc_m2d*min(1,FLX_SEDIFFNO2(n)) + IF (FLX_NDEPNHX(n).GT.0) i_bsc_m2d=i_bsc_m2d+1 + jndepnhxfx(n)=i_bsc_m2d*min(1,FLX_NDEPNHX(n)) #endif #ifdef cisonew IF (SRF_CO213FXD(n).GT.0) i_bsc_m2d=i_bsc_m2d+1 diff --git a/hamocc/ncout_hamocc.F90 b/hamocc/ncout_hamocc.F90 index ee9490fa..ecb35f34 100644 --- a/hamocc/ncout_hamocc.F90 +++ b/hamocc/ncout_hamocc.F90 @@ -211,7 +211,7 @@ subroutine ncwrt_bgc(iogrp) & jlvl_anmx_N2_prod,jlvl_anmx_OM_prod, & & jlvl_phosy_NH4,jlvl_phosy_NO3, & & jlvl_remin_aerob,jlvl_remin_sulf,jatmnh3,jatmn2o, & - & srf_atmnh3,srf_atmn2o + & srf_atmnh3,srf_atmn2o,flx_ndepnhx,jndepnhxfx #endif #if defined(extNcycle) && ! defined(sedbypass) use mo_bgcmean, only: jpownh4,jpown2o,jpowno2,jsdm_nitr_NH4,jsdm_nitr_NO2, & @@ -633,6 +633,7 @@ subroutine ncwrt_bgc(iogrp) call wrtsrf(janh3fx(iogrp), SRF_ANH3FX(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'nh3flux') call wrtsrf(jatmnh3(iogrp), SRF_ATMNH3(iogrp), rnacc, 0.,cmpflg,'atmnh3') call wrtsrf(jatmn2o(iogrp), SRF_ATMN2O(iogrp), rnacc, 0.,cmpflg,'atmn2o') + call wrtsrf(jndepnhxfx(iogrp), FLX_NDEPNHX(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'ndepnhx') #endif ! --- Store 3d layer fields @@ -977,6 +978,7 @@ subroutine ncwrt_bgc(iogrp) call inisrf(janh3fx(iogrp),0.) call inisrf(jatmnh3(iogrp),0.) call inisrf(jatmn2o(iogrp),0.) + call inisrf(jndepnhxfx(iogrp),0.) #endif #if defined(extNcycle) && ! defined(sedbypass) call inisrf(jsediffnh4(iogrp),0.) @@ -1315,7 +1317,7 @@ subroutine hamoccvardef(iogrp,timeunits,calendar,cmpflg) & jlvl_anmx_N2_prod,jlvl_anmx_OM_prod, & & jlvl_phosy_NH4,jlvl_phosy_NO3, & & jlvl_remin_aerob,jlvl_remin_sulf,srf_atmnh3, & - & srf_atmn2o + & srf_atmn2o,flx_ndepnhx #endif #if defined(extNcycle) && ! defined(sedbypass) use mo_bgcmean, only: jpownh4,jpown2o,jpowno2,jsdm_nitr_NH4,jsdm_nitr_NO2, & @@ -1575,6 +1577,8 @@ subroutine hamoccvardef(iogrp,timeunits,calendar,cmpflg) & 'atmnh3','Atmospheric ammonia',' ','ppt',0) call ncdefvar3d(SRF_ATMN2O(iogrp),cmpflg,'p', & & 'atmn2o','Atmospheric nitrous oxide',' ','ppt',0) + call ncdefvar3d(FLX_NDEPNHX(iogrp),cmpflg,'p','ndepnhx', & + & 'Nitrogen NHx deposition flux',' ','mol N m-2 s-1',0) #endif ! --- define 3d layer fields From 33e5a3fff8abac7a683bea9e9981d0ad39f3b9cd Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Thu, 30 Mar 2023 14:07:24 +0200 Subject: [PATCH 295/366] fix placement of ndepnhx --- hamocc/mo_bgcmean.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/hamocc/mo_bgcmean.F90 b/hamocc/mo_bgcmean.F90 index d4def531..addd4519 100644 --- a/hamocc/mo_bgcmean.F90 +++ b/hamocc/mo_bgcmean.F90 @@ -873,8 +873,6 @@ SUBROUTINE ALLOC_MEM_BGCMEAN(kpie,kpje,kpke) jsediffn2o(n)=i_bsc_m2d*min(1,FLX_SEDIFFN2O(n)) IF (FLX_SEDIFFNO2(n).GT.0) i_bsc_m2d=i_bsc_m2d+1 jsediffno2(n)=i_bsc_m2d*min(1,FLX_SEDIFFNO2(n)) - IF (FLX_NDEPNHX(n).GT.0) i_bsc_m2d=i_bsc_m2d+1 - jndepnhxfx(n)=i_bsc_m2d*min(1,FLX_NDEPNHX(n)) #endif #ifdef cisonew IF (SRF_CO213FXD(n).GT.0) i_bsc_m2d=i_bsc_m2d+1 @@ -925,6 +923,8 @@ SUBROUTINE ALLOC_MEM_BGCMEAN(kpie,kpje,kpke) jsrfanh4(n)=i_bsc_m2d*min(1,SRF_ANH4(n)) IF (SRF_ANO2(n).GT.0) i_bsc_m2d=i_bsc_m2d+1 jsrfano2(n)=i_bsc_m2d*min(1,SRF_ANO2(n)) + IF (FLX_NDEPNHX(n).GT.0) i_bsc_m2d=i_bsc_m2d+1 + jndepnhxfx(n)=i_bsc_m2d*min(1,FLX_NDEPNHX(n)) #endif ENDDO From 3bf5eaa69f3fb618f064937ea37d7234018fef31 Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Mon, 17 Apr 2023 11:36:27 +0200 Subject: [PATCH 296/366] add POM Q10 and Tref to M4AGO - sediment makes use of it --- hamocc/mo_m4ago.F90 | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/hamocc/mo_m4ago.F90 b/hamocc/mo_m4ago.F90 index 597f9df6..774e661c 100644 --- a/hamocc/mo_m4ago.F90 +++ b/hamocc/mo_m4ago.F90 @@ -85,7 +85,8 @@ !===================================================================================== m4ago_init_params SUBROUTINE init_m4ago_nml_params - + POM_remin_q10 = 2.1 ! Bidle et al. 2002: Regulation of Oceanic Silicon... + POM_remin_Tref = 10. END SUBROUTINE init_m4ago_nml_params SUBROUTINE init_m4ago_params From 7235cd4c7b170258ce51356c904fb830d57d4b20 Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Mon, 17 Jul 2023 18:39:43 +0200 Subject: [PATCH 297/366] Fix merging issue --- hamocc/mo_carbch.F90 | 1 - 1 file changed, 1 deletion(-) diff --git a/hamocc/mo_carbch.F90 b/hamocc/mo_carbch.F90 index c5c70a17..aa4e5254 100644 --- a/hamocc/mo_carbch.F90 +++ b/hamocc/mo_carbch.F90 @@ -61,7 +61,6 @@ MODULE mo_carbch REAL, DIMENSION (:,:), ALLOCATABLE :: ndepnoyflx REAL, DIMENSION (:,:), ALLOCATABLE :: ndepnhxflx REAL, DIMENSION (:,:), ALLOCATABLE :: oalkflx - REAL, DIMENSION (:,:), ALLOCATABLE :: oalkflx REAL, DIMENSION (:,:,:), ALLOCATABLE :: rivinflx REAL, DIMENSION (:,:,:), ALLOCATABLE :: co3 REAL, DIMENSION (:,:,:), ALLOCATABLE :: co2star From 5faf755a6c2717217a661e5d6362c9d405757964 Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Tue, 18 Jul 2023 11:30:39 +0200 Subject: [PATCH 298/366] Fix applying climatological N-deposition --- hamocc/mo_apply_ndep.F90 | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) diff --git a/hamocc/mo_apply_ndep.F90 b/hamocc/mo_apply_ndep.F90 index 24c85e72..f3420a5a 100644 --- a/hamocc/mo_apply_ndep.F90 +++ b/hamocc/mo_apply_ndep.F90 @@ -123,10 +123,9 @@ subroutine apply_ndep(kpie,kpje,kpke,pddpo,omask,ndep) ocetra(i,j,1,inatalkali)=ocetra(i,j,1,inatalkali)-ndepnoyflx(i,j)/pddpo(i,j,1) #endif #ifdef extNcycle - ndepnhxflx(i,j) = ndep(i,j,2)*dtb/365. - ocetra(i,j,1,ianh4)=ocetra(i,j,1,iano3)+ndepnhxflx(i,j)/pddpo(i,j,1) - ! correct???????? - ocetra(i,j,1,ialkali)=ocetra(i,j,1,ialkali)+ndepnhxflx(i,j)/pddpo(i,j,1) + ndepnhxflx(i,j) = ndep(i,j,2)*dtb/365. + ocetra(i,j,1,ianh4) = ocetra(i,j,1,ianh4) + ndepnhxflx(i,j)/pddpo(i,j,1) + ocetra(i,j,1,ialkali) = ocetra(i,j,1,ialkali) + ndepnhxflx(i,j)/pddpo(i,j,1) #endif endif enddo From 204eae5a5b68a7054ddaa4602c5b6a11ec50b74a Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Tue, 18 Jul 2023 12:27:48 +0200 Subject: [PATCH 299/366] Introduce switch to enable running bluefix/cyanos only in the euphotic zone --- hamocc/cyano.F90 | 5 +++-- hamocc/hamocc_init.F90 | 5 +++-- hamocc/mo_control_bgc.F90 | 1 + 3 files changed, 7 insertions(+), 4 deletions(-) diff --git a/hamocc/cyano.F90 b/hamocc/cyano.F90 index 2a113655..32996c24 100644 --- a/hamocc/cyano.F90 +++ b/hamocc/cyano.F90 @@ -64,7 +64,8 @@ SUBROUTINE CYANO(kpie,kpje,kpke,kbnd,pddpo,omask,ptho) use mo_carbch, only: ocetra use mo_biomod, only: bluefix,intnfix,rnit,tf0,tf1,tf2,tff use mo_param1_bgc, only: ialkali,iano3,igasnit,iphosph,ioxygen - use mo_vgrid, only: kmle + use mo_vgrid, only: kmle,kwrbioz + use mo_control_bgc,only: leuphotic_cya #ifdef natDIC use mo_param1_bgc, only: inatalkali #endif @@ -94,7 +95,7 @@ SUBROUTINE CYANO(kpie,kpje,kpke,kbnd,pddpo,omask,ptho) DO j=1,kpje DO i=1,kpie IF(omask(i,j).gt.0.5) THEN - DO k=1,kmle(i,j) + DO k=1,merge(kwrbioz(i,j),kmle(i,j),leuphotic_cya) ! if leuphotic_cya=.true., do bluefix only in euphotic zone #ifdef extNcycle ! assuming nitrate and ammonium required for cyanobacteria growth (as bulk PP) anavail = ocetra(i,j,k,iano3)+ocetra(i,j,k,ianh4) diff --git a/hamocc/hamocc_init.F90 b/hamocc/hamocc_init.F90 index 62ba9c5c..53a45163 100644 --- a/hamocc/hamocc_init.F90 +++ b/hamocc/hamocc_init.F90 @@ -47,7 +47,7 @@ subroutine hamocc_init(read_rest,rstfnm_hamocc) & sedspin_yr_s,sedspin_yr_e,sedspin_ncyc, & & dtb,dtbgc,io_stdo_bgc,ldtbgc, & & ldtrunbgc,ndtdaybgc,with_dmsph,l_3Dvarsedpor,lm4ago,& - & do_ndep_coupled + & do_ndep_coupled,leuphotic_cya use mo_param1_bgc, only: ks,init_por2octra_mapping use mo_carbch, only: alloc_mem_carbch,ocetra,atm,atm_co2 use mo_biomod, only: alloc_mem_biomod @@ -89,7 +89,8 @@ subroutine hamocc_init(read_rest,rstfnm_hamocc) & sedspin_yr_e,sedspin_ncyc, & & inidic,inialk,inipo4,inioxy,inino3,inisil, & & inid13c,inid14c,swaclimfile, & - & with_dmsph,pi_ph_file,l_3Dvarsedpor,sedporfile,lm4ago,do_ndep_coupled + & with_dmsph,pi_ph_file,l_3Dvarsedpor,sedporfile,lm4ago,leuphotic_cya, & + & do_ndep_coupled ! ! --- Set io units and some control parameters ! diff --git a/hamocc/mo_control_bgc.F90 b/hamocc/mo_control_bgc.F90 index ce1965a4..f5581b04 100644 --- a/hamocc/mo_control_bgc.F90 +++ b/hamocc/mo_control_bgc.F90 @@ -67,6 +67,7 @@ MODULE mo_control_bgc LOGICAL, save :: do_oalk =.false. ! apply ocean alkalinization logical, save :: with_dmsph =.false. ! apply DMS with pH dependence LOGICAL, save :: lm4ago =.false. ! run with M4AGO settling scheme + LOGICAL, save :: leuphotic_cya=.false. ! allow cyanobacteria to grow only in euphotic zone contains subroutine get_bgc_namelist From 4076786f363bee7f7e1162359fa23f96ce293541 Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Thu, 31 Aug 2023 13:33:39 +0200 Subject: [PATCH 300/366] add relevant information of output variables --- cime_config/ocn_in.readme | 61 +++++++++++++++++++++++++++++++++++++-- 1 file changed, 59 insertions(+), 2 deletions(-) diff --git a/cime_config/ocn_in.readme b/cime_config/ocn_in.readme index 05f933e6..f35f107b 100644 --- a/cime_config/ocn_in.readme +++ b/cime_config/ocn_in.readme @@ -363,6 +363,7 @@ ! DO_RIVINPT : Logical switch to activate riverine input ! RIVINFILE : File name (incl. full path) for riverine input data ! DO_NDEP : Logical switch to activate N-deposition +! DO_NDEP_COUPLED: Logical to apply N-deposition fluxes received from the atmosphere (true=atm, false=clim) ! NDEPFILE : File name (incl. full path) for atmopheric N-deposition data ! DO_SEDSPINUP: Logical switch to activate sediment spin-up ! SEDSPIN_YR_S: Start year for sediment spinup @@ -372,6 +373,7 @@ ! OXY, NO3, SIL, D13C, and D14C ! WITH_DMSPH : Logical switch to activate DMS calculation as function of pH ! PI_PH_FILE : File name (incl. full path) for surface PI pH input data. +! LM4AGO : Switch for M4AGO settling scheme ! L_3DVARSEDPOR : Logical switch to enable lon-lat-depth variable sediment porosity (as opposed to default: only depth) ! SEDPORFILE : File name (incl. full path) for sediment porosity ! @@ -458,6 +460,33 @@ ! PHOSY - Primary production (pp) [mol C m-3 s-1] ! CO3 - Carbonate ions (co3) [mol C m-3] ! N2O - Nitrous oxide concentration [mol N2O m-3] +! NITR_NH4 - nitrification rate on NH4 [mol NH4 m-3 s-1] - extended N cycle only +! NITR_NO2 - nitrification rate on NO2 [mol NO2 m-3 s-1] - extended N cycle only +! NITR_N2O_PROD - N2O production rate during nitrification on NH4 [mol N2O m-3 s-1] - ext. N cycle only +! NITR_NH4_OM - detritus production during nitrification on NH4 [mol P m-3 s-1] - ext. N cycle only +! NITR_NO2_OM - detritus production during nitrification on NO2 [mol P m-3 s-1] - ext. N cycle only +! DENIT_NO3 - denitrification rate on NO3 [mol NO3 m-3 s-1] - ext. N cycle only +! DENIT_NO2 - denitrification rate on NO2 [mol NO2 m-3 s-1] - ext. N cycle only +! DENIT_N2O - denitrification rate on N20 [mol N20 m-3 s-1] - ext. N cycle only +! DNRA_NO2 - DNRA on NO2 [mol NO2 m-3 s-1] - ext. N cycle only +! ANMX_N2_PROD - anammox N2 production [mol N2 m-3 s-1] - ext. N cycle only +! ANMX_OM_PROD - anammox detritus production [mol P m-3 s-1] - ext. N cycle only +! PHOSY_NH4 - PP consumption of NH4 [mol NH4 m-3 s-1] - ext. N cycle only +! PHOSY_NO3 - PP consumption of NH4 [mol NH4 m-3 s-1] - ext. N cycle only +! REMIN_AEROB - aerob remineralization rate (sev. sources) [mol NH4 m-3 s-1] - ext. N cycle only +! REMIN_SULF - sulfate-based remin rate on det [mol P m-3 s-1] - ext. N cycle only +! AGG_WS - M4AGO aggregate mean settling velocity [m/d] +! DYNVIS - molecular dynamic viscosity of sea water [kg m-1 s-1] +! AGG_STICK - mean stickiness of marine aggregates [-] +! AGG_STICKF - stickiness of opal frustule [-] +! AGG_DMAX - maximum aggregate diameter [m] +! AGG_AVDP - mean primary particle diameter [m] +! AGG_AVRHOP - mean primary particle density [kg/m3] +! AGG_AVDC - concentration weighted mean diameter of aggregates [m] +! AGG_DF - fractal dimension of aggregates [-] +! AGG_B - slope of aggregate number distribution [-] +! AGG_VRHOF - Volume-weighted mean aggregate density [kg m-3] +! AGG_VPOR - Volume weighted mean aggregate porosity [-] ! OMEGAA - Aragonite saturation state (omegaa) [1] ! OMEGAC - Calcite saturation state (omegac) [1] ! NATDIC - Natural dissolved carbon (natdissic) [mol C m-3] @@ -499,7 +528,13 @@ ! CO2FXU - Upward CO2 flux (co2fxu) [kg C m-2 s-1] ! NIFLUX - Nitrogen flux (fgn2) [mol N2 m-2 s-1] ! OXFLUX - Oxygen flux (fgo2) [mol O2 m-2 s-1] +! PN2OM - Surface pN2O under moist air [uatm] ! N2OFX - Nitrous oxide flux [mol N2O m-2 s-1] +! PNH3 - Surface pNH3 under moist air [natm] +! ANH3FX - Ammonia flux [mol NH3 m-2 s-1] +! ATMNH3 - Atmospheric NH3 [ppt] +! ATMN2O - Atmospheric N2O [ppt] +! ATMBROMO - Atmospheric bromoform [ppt] ! DMSFLUX - DMS flux (dmsflux) [mol DMS m-2 s-1] ! DMS - surface DMS concentration (dms) [mol DMS m-3] ! DMSPROD - DMS production (dmsprod) [mol DMS m-2 s-1] @@ -537,6 +572,10 @@ ! SEDIFFN2 - sediment - water-column diffusive flux of N2 [mol N2 m-2 s-1] ! SEDIFFNO3 - sediment - water-column diffusive flux of nitrate [mol NO3 m-2 s-1] ! SEDIFFSI - sediment - water-column diffusive flux of silica [mol Si m-2 s-1] +! FLX_BURSSO12 - burial fluxes organic carbon [mol P m-2 s-1] +! FLX_BURSSSC12 - burial fluxes of calcium carbonate [mol Ca m-2 s-1] +! FLX_BURSSSSIL - burial fluxes of silicate [mol Si m-2 s-1] +! FLX_BURSSSTER - burial fluxes of clay [g m-2 s-1] ! ! Sediment fields (SDM) ! POWAIC - (powdic) [mol C m-3] @@ -546,15 +585,33 @@ ! POWN2 - (pown2) [mol N2 m-3] ! POWNO3 - (powno3)[mol N m-3] ! POWASI - (powsi) [mol Si m-3] +! POWNH4 - (pownh4) [mol NH4 m-3] - extended N cycle only +! POWN2O - (pown2o) [mol N2O m-3] - extended N cycle only +! POWNO2 - (powno2) [mol NO2 m-3] - extended N cycle only +! NITR_NH4 - nitrification rate on NH4 [mol NH4 m-3 s-1] - extended N cycle only +! NITR_NO2 - nitrification rate on NO2 [mol NO2 m-3 s-1] - extended N cycle only +! NITR_N2O_PROD - N2O production rate during nitrification on NH4 [mol N2O m-3 s-1] - ext. N cycle only +! NITR_NH4_OM - detritus production during nitrification on NH4 [mol P m-3 s-1] - ext. N cycle only +! NITR_NO2_OM - detritus production during nitrification on NO2 [mol P m-3 s-1] - ext. N cycle only +! DENIT_NO3 - denitrification rate on NO3 [mol NO3 m-3 s-1] - ext. N cycle only +! DENIT_NO2 - denitrification rate on NO2 [mol NO2 m-3 s-1] - ext. N cycle only +! DENIT_N2O - denitrification rate on N20 [mol N20 m-3 s-1] - ext. N cycle only +! DNRA_NO2 - DNRA on NO2 [mol NO2 m-3 s-1] - ext. N cycle only +! ANMX_N2_PROD - anammox N2 production [mol N2 m-3 s-1] - ext. N cycle only +! ANMX_OM_PROD - anammox detritus production [mol P m-3 s-1] - ext. N cycle only +! PHOSY_NH4 - PP consumption of NH4 [mol NH4 m-3 s-1] - ext. N cycle only +! PHOSY_NO3 - PP consumption of NH4 [mol NH4 m-3 s-1] - ext. N cycle only +! REMIN_AEROB - aerob remineralization rate (sev. sources) [mol NH4 m-3 s-1] - ext. N cycle only +! REMIN_SULF - sulfate-based remin rate on det [mol P m-3 s-1] - ext. N cycle only ! SSSO12 - (ssso12) [mol m-3] ! SSSSIL - (ssssil) [mol Si m-3] ! SSSC12 - (sssc12) [mol C m-3] -! SSSTER - (ssster) [mol m-3] +! SSSTER - (ssster) [kg m-3] ! ! Burial fields (BUR) ! SSSO12 - Solid sediment organic carbon [mol P m-2] ! SSSSIL - Solid sediment silica [mol Si m-2] ! SSSC12 - Solid sediment inorganic carbon [mol C m-2] -! SSSTER - +! SSSTER - Solid sediment mineral component [kg m-2] ! !=========================================================================== From 04601e6ab3fa09d2814fd73d7459e072e7fc0b01 Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Thu, 31 Aug 2023 13:34:42 +0200 Subject: [PATCH 301/366] fix missing "" in buldnml --- cime_config/buildnml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/cime_config/buildnml b/cime_config/buildnml index 7316c858..feb6fe0e 100755 --- a/cime_config/buildnml +++ b/cime_config/buildnml @@ -268,7 +268,7 @@ else set NDEPFNAME = "''" endif -if ($ATM_N_DEPOSITION == TRUE) then +if ("$ATM_N_DEPOSITION" == TRUE) then set DO_NDEP = .true. set DO_NDEP_COUPLED = .true. set NDEPFNAME = "''" From a7cc835274bd903154fc98acc58abb3b97d12802 Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Thu, 31 Aug 2023 14:38:28 +0200 Subject: [PATCH 302/366] Re-introduce M4AGO parameter and N-cycle parameter initialization --- hamocc/mo_param_bgc.F90 | 50 ++++++++++++++++++++++++++++++++++++----- 1 file changed, 45 insertions(+), 5 deletions(-) diff --git a/hamocc/mo_param_bgc.F90 b/hamocc/mo_param_bgc.F90 index 14319d83..0086b52d 100644 --- a/hamocc/mo_param_bgc.F90 +++ b/hamocc/mo_param_bgc.F90 @@ -47,12 +47,12 @@ module mo_param_bgc use mo_biomod, only: atten_c,atten_f,atten_uv,atten_w,bkopal,bkphy,bkopal,bkzoo,bluefix,ctochl,dremn2o,dremopal, & & drempoc,dremsul,dyphy,ecan,epsher,fesoly,fetune,gammap,gammaz,grami,grazra,perc_diron,phytomi, & & pi_alpha,rcalc,rcar, rdn2o1,rdn2o2,rdnit0,rdnit1,rdnit2,relaxfe,remido,riron,rnit,rnoi,ro2ut, & - & ropal,spemor,tf0,tf1,tf2,tff,wcal,wdust,wopal,wpoc,zinges + & ropal,spemor,tf0,tf1,tf2,tff,wcal,wdust,wopal,wpoc,zinges,drempoc_anaerob,bkox_drempoc use mo_sedmnt, only: claydens,o2ut,rno3 - use mo_control_bgc, only: io_stdo_bgc,bgc_namelist + use mo_control_bgc, only: io_stdo_bgc,bgc_namelist,lm4ago use mo_param1_bgc, only: iatmco2,iatmnco2,iatmo2,iatmn2,iatmc13,iatmc14,iatmbromo use mod_xc, only: mnproc - + use mo_m4ago, only: init_m4ago_nml_params, init_m4ago_params #ifdef AGG use mo_biomod, only: alar1,alar2,alar3,alow1,alow2,alow3,calmax,cellmass,cellsink,dustd1,dustd2,dustd3,dustsink, & & fractdim,fse,fsh,nmldmin,plower,pupper,safe,sinkexp,stick,tmfac,tsfac,vsmall,zdis @@ -70,6 +70,13 @@ module mo_param_bgc #ifdef natDIC use mo_carbch, only: atm_co2_nat #endif +#ifdef extNcycle + use mo_param1_bgc, only: iatmnh3,iatmn2o + use mo_carbch, only: atm_nh3,atm_n2o + use mo_chemcon, only: atn2o !fixed mixing ratio of N2O at 1980, 300ppb = 300e3ppt = 3e-7 mol/mol + use mo_extNbioproc, only: extNbioparam_init + use mo_extNsediment,only: extNsediment_param_init +#endif implicit none @@ -112,6 +119,7 @@ subroutine ini_parambgc(kpie,kpje) call ini_fields_atm(kpie,kpje) ! initialize atmospheric fields with (updated) parameter values call readjust_param() ! potentially readjust namlist parameter-dependent parameters call rates_2_timestep() ! Converting rates from /d... to /dtb + call init_m4ago_params() ! Initialize M4AGO parameters relying on nml parameters call write_parambgc() ! write out used parameters and calculate back rates from /dtb to /d.. end subroutine @@ -141,6 +149,13 @@ subroutine ini_param_atm() prei13 = -6.5 prei14 = 0. #endif cisonew +#ifdef extNcycle + ! Six & Mikolajewicz 2022: less than 1nmol m¿3 + atm_nh3 = 0. + ! for now initializing the atmosphereic mixing ratio for N2O with fixed value + ! - later to be revereted to namelist parameter + atm_n2o = atn2o +#endif end subroutine @@ -191,6 +206,10 @@ subroutine ini_fields_atm(kpie,kpje) #endif #ifdef BROMO atm(i,j,iatmbromo)= atm_bromo +#endif +#ifdef extNcycle + atm(i,j,iatmnh3) = atm_nh3 + atm(i,j,iatmn2o) = atm_n2o #endif ENDDO ENDDO @@ -318,10 +337,26 @@ subroutine ini_param_biol() remido = 0.004 !1/d -remineralization rate (of DOM) ! deep sea remineralisation constants drempoc = 0.025 !1/d Aerob remineralization rate detritus + drempoc_anaerob = 0.05*drempoc ! remin in sub-/anoxic environm. - not be overwritten by lm4ago + bkox_drempoc = 1e-7 ! half-saturation constant for oxygen for ammonification (aerobic remin via drempoc) dremopal = 0.003 !1/d Dissolution rate for opal dremn2o = 0.01 !1/d Remineralization rate of detritus on N2O dremsul = 0.005 !1/d Remineralization rate for sulphate reduction - + if(lm4ago)then + ! reset drempoc and dremopal for T-dep remin/dissolution + drempoc = 0.12 + dremopal = 0.023 + endif + + ! M4AGO parameters + call init_m4ago_nml_params() +#ifdef extNcycle + ! initialize the extended nitrogen cycle parameters - first water column, then sediment, + ! since sediment relies on water column parameters for the extended nitrogen cycle + ! Sediment also relies on M4AGO being initialized (POM_remin_q10 and POM_remin_Tref) + call extNbioparam_init() + call extNsediment_param_init() +#endif ! Set constants for calculation of dms ( mo_carbch ) ! Parameters are a result from kettle optimisation 02.03.04 dmspar(6)=0.100000000E-07 !0 half saturation microbial @@ -358,6 +393,7 @@ subroutine ini_param_biol() !******************************************************************** ! Sinking parameters !******************************************************************** + wpoc = 5. !m/d Sinking speed of detritus iris : 5. wcal = 30. !m/d Sinking speed of CaCO3 shell material wopal = 30. !m/d Sinking speed of opal iris : 60 @@ -451,6 +487,7 @@ subroutine rates_2_timestep() remido = remido*dtb !1/d -remineralization rate (of DOM) ! deep sea remineralisation constants drempoc = drempoc*dtb !1/d Aerob remineralization rate of detritus + drempoc_anaerob = drempoc_anaerob*dtb ! 1/d Anaerob remin rate of detritus dremopal = dremopal*dtb !1/d Dissolution rate of opal dremn2o = dremn2o*dtb !1/d Remineralization rate of detritus on N2O dremsul = dremsul*dtb !1/d Remineralization rate for sulphate reduction @@ -571,7 +608,10 @@ subroutine write_parambgc() WRITE(io_stdo_bgc,*) '* c14fac = ',c14fac #endif WRITE(io_stdo_bgc,*) '* atm_o2 = ',atm_o2 - WRITE(io_stdo_bgc,*) '* atm_n2 = ',atm_n2 + WRITE(io_stdo_bgc,*) '* atm_n2 = ',atm_n2 +#ifdef extNcycle + WRITE(io_stdo_bgc,*) '* atm_nh3 = ',atm_nh3 +#endif WRITE(io_stdo_bgc,*) '* phytomi = ',phytomi WRITE(io_stdo_bgc,*) '* grami = ',grami WRITE(io_stdo_bgc,*) '* remido = ',remido*dtbinv From 1168faab6b60dd5a5b7151e9e13187f475511017 Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Thu, 31 Aug 2023 16:52:58 +0200 Subject: [PATCH 303/366] fix utf-8 from copying --- hamocc/mo_param_bgc.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/hamocc/mo_param_bgc.F90 b/hamocc/mo_param_bgc.F90 index 0086b52d..01f8aa63 100644 --- a/hamocc/mo_param_bgc.F90 +++ b/hamocc/mo_param_bgc.F90 @@ -150,7 +150,7 @@ subroutine ini_param_atm() prei14 = 0. #endif cisonew #ifdef extNcycle - ! Six & Mikolajewicz 2022: less than 1nmol m¿3 + ! Six & Mikolajewicz 2022: less than 1nmol m-3 atm_nh3 = 0. ! for now initializing the atmosphereic mixing ratio for N2O with fixed value ! - later to be revereted to namelist parameter From 6c134252e374074870df4f0b14bf7ae420d8c4e2 Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Thu, 7 Sep 2023 17:28:24 +0200 Subject: [PATCH 304/366] only renaming file --- hamocc/{mo_extNbioproc.F90 => mo_extNwatercol.F90} | 0 1 file changed, 0 insertions(+), 0 deletions(-) rename hamocc/{mo_extNbioproc.F90 => mo_extNwatercol.F90} (100%) diff --git a/hamocc/mo_extNbioproc.F90 b/hamocc/mo_extNwatercol.F90 similarity index 100% rename from hamocc/mo_extNbioproc.F90 rename to hamocc/mo_extNwatercol.F90 From 480ad49672c016fe6f83d6707aaa86afbb90432c Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Thu, 7 Sep 2023 17:34:27 +0200 Subject: [PATCH 305/366] adjust use statements to renamed file/module --- hamocc/meson.build | 2 +- hamocc/mo_extNsediment.F90 | 18 +++++++++--------- hamocc/mo_extNwatercol.F90 | 2 +- hamocc/mo_param_bgc.F90 | 2 +- hamocc/ocprod.F90 | 4 ++-- hamocc/powach.F90 | 2 +- 6 files changed, 15 insertions(+), 15 deletions(-) diff --git a/hamocc/meson.build b/hamocc/meson.build index 3aa12a7a..7f86dccf 100644 --- a/hamocc/meson.build +++ b/hamocc/meson.build @@ -49,6 +49,6 @@ sources += files( 'sedshi.F90', 'trc_limitc.F90', 'write_netcdf_var.F90', - 'mo_extNbioproc.F90', + 'mo_extNwatercol.F90', 'mo_extNsediment.F90', 'mo_m4ago.F90') diff --git a/hamocc/mo_extNsediment.F90 b/hamocc/mo_extNsediment.F90 index 8e358254..af277b30 100644 --- a/hamocc/mo_extNsediment.F90 +++ b/hamocc/mo_extNsediment.F90 @@ -42,12 +42,12 @@ MODULE mo_extNsediment ! nitrogen cycle is handled inside powach.F90. ! !********************************************************************** - use mo_param1_bgc, only: issso12,ipowaic,ipowaal,ipowaph,ipowaox,ipown2,ipowno3,ipownh4,ipown2o,ipowno2,ks - use mo_vgrid, only: kbo - use mo_biomod, only: rnit,rcar,rnoi - use mo_control_bgc,only: dtb - use mo_sedmnt, only: powtra,sedlay,porsol,porwat - use mo_extNbioproc,only: rc2n,ro2utammo,ro2nnit,rnoxp,rnoxpi,rno2anmx,rno2anmxi,rnh4anmx, & + use mo_param1_bgc, only: issso12,ipowaic,ipowaal,ipowaph,ipowaox,ipown2,ipowno3,ipownh4,ipown2o,ipowno2,ks + use mo_vgrid, only: kbo + use mo_biomod, only: rnit,rcar,rnoi + use mo_control_bgc, only: dtb + use mo_sedmnt, only: powtra,sedlay,porsol,porwat + use mo_extNwatercol,only: rc2n,ro2utammo,ro2nnit,rnoxp,rnoxpi,rno2anmx,rno2anmxi,rnh4anmx, & & rnh4anmxi,rno2dnra,rno2dnrai,rnh4dnra,rnh4dnrai,rnm1 implicit none @@ -121,15 +121,15 @@ end subroutine alloc_mem_extNsediment_diag ! ================================================================================================================================ subroutine extNsediment_param_init() - use mo_extNbioproc,only: q10ano3denit,sc_ano3denit,Trefano3denit,bkano3denit, & + use mo_extNwatercol,only: q10ano3denit,sc_ano3denit,Trefano3denit,bkano3denit, & & q10anmx,Trefanmx,alphaanmx,bkoxanmx,bkano2anmx, & & q10ano2denit,Trefano2denit,bkoxano2denit,bkano2denit, & & q10an2odenit,Trefan2odenit,bkoxan2odenit,bkan2odenit, & & q10dnra,Trefdnra,bkoxdnra,bkdnra, & & q10anh4nitr,Trefanh4nitr,bkoxamox,bkanh4nitr,bkamoxn2o,bkyamox,n2omaxy,n2oybeta, & & q10ano2nitr,Trefano2nitr,bkoxnitr,bkano2nitr,NOB2AOAy,rno2anmx,rnh4anmx - use mo_m4ago, only: POM_remin_q10,POM_remin_Tref - use mo_biomod, only: bkox_drempoc + use mo_m4ago, only: POM_remin_q10,POM_remin_Tref + use mo_biomod, only: bkox_drempoc implicit none diff --git a/hamocc/mo_extNwatercol.F90 b/hamocc/mo_extNwatercol.F90 index be34dd0c..fae66f13 100644 --- a/hamocc/mo_extNwatercol.F90 +++ b/hamocc/mo_extNwatercol.F90 @@ -15,7 +15,7 @@ ! You should have received a copy of the GNU Lesser General Public License ! along with BLOM. If not, see https://www.gnu.org/licenses/. - MODULE mo_extNbioproc + MODULE mo_extNwatercol !**************************************************************** ! ! MODULE mo_extNbioproc - (microbial) biological processes of the diff --git a/hamocc/mo_param_bgc.F90 b/hamocc/mo_param_bgc.F90 index 01f8aa63..b4a684d3 100644 --- a/hamocc/mo_param_bgc.F90 +++ b/hamocc/mo_param_bgc.F90 @@ -74,7 +74,7 @@ module mo_param_bgc use mo_param1_bgc, only: iatmnh3,iatmn2o use mo_carbch, only: atm_nh3,atm_n2o use mo_chemcon, only: atn2o !fixed mixing ratio of N2O at 1980, 300ppb = 300e3ppt = 3e-7 mol/mol - use mo_extNbioproc, only: extNbioparam_init + use mo_extNwatercol,only: extNbioparam_init use mo_extNsediment,only: extNsediment_param_init #endif diff --git a/hamocc/ocprod.F90 b/hamocc/ocprod.F90 index 6e6173e7..7bc158bb 100644 --- a/hamocc/ocprod.F90 +++ b/hamocc/ocprod.F90 @@ -126,8 +126,8 @@ subroutine ocprod(kpie,kpje,kpke,kbnd,pdlxp,pdlyp,pddpo,omask,ptho,pi_ph, psao, use mo_biomod, only: abs_oce,atten_f #endif #ifdef extNcycle - use mo_extNbioproc, only: nitrification,denit_NO3_to_NO2,anammox,denit_dnra,extN_inv_check - use mo_extNbioproc, only: bkphyanh4,bkphyano3,bkphosph,bkiron,ro2utammo + use mo_extNwatercol,only: nitrification,denit_NO3_to_NO2,anammox,denit_dnra,extN_inv_check + use mo_extNwatercol,only: bkphyanh4,bkphyano3,bkphosph,bkiron,ro2utammo use mo_param1_bgc, only: ianh4 use mo_biomod, only: phosy_NH4, phosy_NO3, remin_aerob,remin_sulf #endif diff --git a/hamocc/powach.F90 b/hamocc/powach.F90 index 67eb18f3..544146bf 100644 --- a/hamocc/powach.F90 +++ b/hamocc/powach.F90 @@ -76,7 +76,7 @@ subroutine powach(kpie,kpje,kpke,kbnd,prho,omask,psao,ptho,lspin) #endif #ifdef extNcycle use mo_param1_bgc, only: ipownh4 - use mo_extNbioproc, only: ro2utammo + use mo_extNwatercol, only: ro2utammo use mo_extNsediment, only: extNsediment_param_init,sed_nitrification,sed_denit_NO3_to_NO2,sed_anammox,sed_denit_DNRA, & & extNsed_diagnostics,ised_remin_aerob,ised_remin_sulf,POM_remin_q10_sed,POM_remin_Tref_sed, & & bkox_drempoc_sed From d224e7989908c659fcd4da6eb03e2f8093c8626b Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Thu, 7 Sep 2023 17:43:38 +0200 Subject: [PATCH 306/366] rename subroutine --- hamocc/mo_extNwatercol.F90 | 7 +++---- hamocc/mo_param_bgc.F90 | 4 ++-- 2 files changed, 5 insertions(+), 6 deletions(-) diff --git a/hamocc/mo_extNwatercol.F90 b/hamocc/mo_extNwatercol.F90 index fae66f13..bc8ccf1a 100644 --- a/hamocc/mo_extNwatercol.F90 +++ b/hamocc/mo_extNwatercol.F90 @@ -62,7 +62,7 @@ MODULE mo_extNwatercol private ! public functions - public :: extNbioparam_init,nitrification,denit_NO3_to_NO2,& + public :: extNwatercol_param_init,nitrification,denit_NO3_to_NO2,& & anammox,denit_dnra,extN_inv_check ! public parameters for primary production @@ -102,7 +102,7 @@ MODULE mo_extNwatercol CONTAINS !================================================================================================================================== - subroutine extNbioparam_init() + subroutine extNwatercol_param_init() !=========================================================================== ! Initialization of model parameters for the extended nitrogen cycle rc2n = rcar/rnit ! iHAMOCC C:N ratio @@ -204,8 +204,7 @@ subroutine extNbioparam_init() ran2odenit = 0.0012*dtb ! Maximum growth rate denitrification on N2O at reference T (1/d -> 1/dt) rdnra = 0.001*dtb ! Maximum growth rate DNRA on NO2 at reference T (1/d -> 1/dt) - end subroutine extNbioparam_init - + end subroutine extNwatercol_param_init !================================================================================================================================== subroutine nitrification(kpie,kpje,kpke,kbnd,pddpo,omask,ptho) ! Nitrification processes (NH4 -> NO2, NO2 -> NO3) accompanied diff --git a/hamocc/mo_param_bgc.F90 b/hamocc/mo_param_bgc.F90 index b4a684d3..cf5a6894 100644 --- a/hamocc/mo_param_bgc.F90 +++ b/hamocc/mo_param_bgc.F90 @@ -74,7 +74,7 @@ module mo_param_bgc use mo_param1_bgc, only: iatmnh3,iatmn2o use mo_carbch, only: atm_nh3,atm_n2o use mo_chemcon, only: atn2o !fixed mixing ratio of N2O at 1980, 300ppb = 300e3ppt = 3e-7 mol/mol - use mo_extNwatercol,only: extNbioparam_init + use mo_extNwatercol,only: extNwatercol_param_init use mo_extNsediment,only: extNsediment_param_init #endif @@ -354,7 +354,7 @@ subroutine ini_param_biol() ! initialize the extended nitrogen cycle parameters - first water column, then sediment, ! since sediment relies on water column parameters for the extended nitrogen cycle ! Sediment also relies on M4AGO being initialized (POM_remin_q10 and POM_remin_Tref) - call extNbioparam_init() + call extNwatercol_param_init() call extNsediment_param_init() #endif ! Set constants for calculation of dms ( mo_carbch ) From 8a994177d5249cb3d730fcf822a36cd23d16f3e5 Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Thu, 7 Sep 2023 19:06:18 +0200 Subject: [PATCH 307/366] Make N-cyle water column parameters available for nml --- hamocc/mo_extNwatercol.F90 | 113 ++++++++++++++++++++++++++++++++----- hamocc/mo_param_bgc.F90 | 20 +++++-- 2 files changed, 116 insertions(+), 17 deletions(-) diff --git a/hamocc/mo_extNwatercol.F90 b/hamocc/mo_extNwatercol.F90 index bc8ccf1a..d8ccd9d0 100644 --- a/hamocc/mo_extNwatercol.F90 +++ b/hamocc/mo_extNwatercol.F90 @@ -63,7 +63,7 @@ MODULE mo_extNwatercol ! public functions public :: extNwatercol_param_init,nitrification,denit_NO3_to_NO2,& - & anammox,denit_dnra,extN_inv_check + & anammox,denit_dnra,extN_inv_check,extNwatercol_param_update,extNwatercol_param_write ! public parameters for primary production public :: bkphyanh4,bkphyano3,bkphosph,bkiron,ro2utammo @@ -128,7 +128,7 @@ subroutine extNwatercol_param_init() ! === Denitrification step NO3 -> NO2: !rano3denit = 0.15*dtb ! Maximum growth rate denitrification on NO3 at reference T (1/d -> 1/dt) - rano3denit = 0.05*dtb ! Maximum growth rate denitrification on NO3 at reference T (1/d -> 1/dt) + rano3denit = 0.05 ! Maximum growth rate denitrification on NO3 at reference T (1/d -> 1/dt) q10ano3denit = 2. ! Q10 factor for denitrification on NO3 (-) Trefano3denit = 10. ! Reference temperature for denitrification on NO3 (degr C) !sc_ano3denit = 0.05e6 ! Shape factor for NO3 denitrification oxygen inhibition function (m3/kmol) @@ -136,7 +136,7 @@ subroutine extNwatercol_param_init() bkano3denit = 5.e-6 ! Half-saturation constant for NO3 denitrification (kmol/m3) ! === Anammox - rano2anmx = 0.05*dtb ! Maximum growth rate for anammox at reference T (1/d -> 1/dt) + rano2anmx = 0.05 ! Maximum growth rate for anammox at reference T (1/d -> 1/dt) q10anmx = 1.6 ! Q10 factor for anammox (-) Trefanmx = 10. ! Reference temperature for anammox (degr C) alphaanmx = 0.45e6 ! Shape factor for anammox oxygen inhibition function (m3/kmol) @@ -145,28 +145,28 @@ subroutine extNwatercol_param_init() bkanh4anmx = bkano2anmx * rnh4anmx/rno2anmx !Half-saturation constant for NH4 limitation of anammox (kmol/m3) ! === Denitrification step NO2 -> N2O - rano2denit = 0.12*dtb ! Maximum growth rate denitrification on NO2 at reference T (1/d -> 1/dt) + rano2denit = 0.12 ! Maximum growth rate denitrification on NO2 at reference T (1/d -> 1/dt) q10ano2denit = 2.0 ! Q10 factor for denitrification on NO2 (-) Trefano2denit = 10. ! Reference temperature for denitrification on NO2 (degr C) bkoxano2denit = 2.e-6 ! Half-saturation constant for (quadratic) oxygen inhibition function of denitrification on NO2 (kmol/m3) bkano2denit = 5.6e-6 ! Half-saturation constant for denitrification on NO2 (kmol/m3) ! === Denitrification step N2O -> N2 - ran2odenit = 0.16*dtb ! Maximum growth rate denitrification on N2O at reference T (1/d -> 1/dt) + ran2odenit = 0.16 ! Maximum growth rate denitrification on N2O at reference T (1/d -> 1/dt) q10an2odenit = 3. ! Q1- factor for denitrificationj on N2O (-) Trefan2odenit = 10. ! Reference temperature for denitrification on N2O (degr C) bkoxan2odenit = 5.e-6 ! Half-saturation constant for (quadratic) oxygen inhibition function of denitrification on N2O (kmol/m3) bkan2odenit = 1.e-6 ! Half-saturation constant for denitrification on N2O (kmol/m3) ! === DNRA NO2 -> NH4 - rdnra = 0.1*dtb ! Maximum growth rate DNRA on NO2 at reference T (1/d -> 1/dt) + rdnra = 0.1 ! Maximum growth rate DNRA on NO2 at reference T (1/d -> 1/dt) q10dnra = 2. ! Q10 factor for DNRA on NO2 (-) Trefdnra = 10. ! Reference temperature for DNRA (degr C) bkoxdnra = 2.5e-6 ! Half saturation constant for (quadratic) oxygen inhibition function of DNRA on NO2 (kmol/m3) bkdnra = 0.05e-6 ! Half-saturation constant for DNRA on NO2 (kmol/m3) ! === Nitrification on NH4 - ranh4nitr = 1.*dtb ! Maximum growth rate nitrification on NH4 at reference T (1/d -> 1/dt) + ranh4nitr = 1. ! Maximum growth rate nitrification on NH4 at reference T (1/d -> 1/dt) q10anh4nitr = 3.3 ! Q10 factor for nitrification on NH4 (-) Trefanh4nitr = 20. ! Reference temperature for nitrification on NH4 (degr C) bkoxamox = 0.333e-6 ! Half-saturation constant for oxygen limitation of nitrification on NH4 (kmol/m3) @@ -186,7 +186,7 @@ subroutine extNwatercol_param_init() bkyamox = 0.333e-6 ! Half saturation constant for pathway splitting function OM-yield for nitrification on NH4 (kmol/m3) ! === Nitrification on NO2 - rano2nitr = 1.54*dtb ! Maximum growth rate nitrification on NO2 at reference T (1/d -> 1/dt) + rano2nitr = 1.54 ! Maximum growth rate nitrification on NO2 at reference T (1/d -> 1/dt) q10ano2nitr = 2.7 ! Q10 factor for nitrification on NO2 (-) Trefano2nitr = 20. ! Reference temperature for nitrification on NO2 (degr C) bkoxnitr = 0.788e-6 ! Half-saturation constant for oxygen limitation of nitrification on NO2 (kmol/m3) @@ -198,13 +198,100 @@ subroutine extNwatercol_param_init() !=========================================================================== ! Tweaked parameters: - rano3denit = 0.0005*dtb ! Maximum growth rate denitrification on NO3 at reference T (1/d -> 1/dt) - rano2anmx = 0.001*dtb ! Maximum growth rate for anammox at reference T (1/d -> 1/dt) - rano2denit = 0.001*dtb ! Maximum growth rate denitrification on NO2 at reference T (1/d -> 1/dt) - ran2odenit = 0.0012*dtb ! Maximum growth rate denitrification on N2O at reference T (1/d -> 1/dt) - rdnra = 0.001*dtb ! Maximum growth rate DNRA on NO2 at reference T (1/d -> 1/dt) + rano3denit = 0.0005 ! Maximum growth rate denitrification on NO3 at reference T (1/d -> 1/dt) + rano2anmx = 0.001 ! Maximum growth rate for anammox at reference T (1/d -> 1/dt) + rano2denit = 0.001 ! Maximum growth rate denitrification on NO2 at reference T (1/d -> 1/dt) + ran2odenit = 0.0012 ! Maximum growth rate denitrification on N2O at reference T (1/d -> 1/dt) + rdnra = 0.001 ! Maximum growth rate DNRA on NO2 at reference T (1/d -> 1/dt) end subroutine extNwatercol_param_init + +!================================================================================================================================== + subroutine extNwatercol_param_update() + + rano3denit = rano3denit *dtb ! Maximum growth rate denitrification on NO3 at reference T (1/d -> 1/dt) + rano2anmx = rano2anmx *dtb ! Maximum growth rate for anammox at reference T (1/d -> 1/dt) + rano2denit = rano2denit *dtb ! Maximum growth rate denitrification on NO2 at reference T (1/d -> 1/dt) + ran2odenit = ran2odenit *dtb ! Maximum growth rate denitrification on N2O at reference T (1/d -> 1/dt) + rdnra = rdnra *dtb ! Maximum growth rate DNRA on NO2 at reference T (1/d -> 1/dt) + ranh4nitr = ranh4nitr *dtb ! Maximum growth rate nitrification on NH4 at reference T (1/d -> 1/dt) + rano2nitr = rano2nitr *dtb ! Maximum growth rate nitrification on NO2 at reference T (1/d -> 1/dt) + + end subroutine extNwatercol_param_update + +!================================================================================================================================== + subroutine extNwatercol_param_write() + + REAL :: dtbinv + dtbinv = 1./dtb + WRITE(io_stdo_bgc,*) '****************************************************************' + WRITE(io_stdo_bgc,*) '* HAMOCC extended nitrogen cycle +parameters water column:' + WRITE(io_stdo_bgc,*) '* rc2n = ',rc2n + WRITE(io_stdo_bgc,*) '* ro2utammo = ',ro2utammo + WRITE(io_stdo_bgc,*) '* ro2nnit = ',ro2nnit + WRITE(io_stdo_bgc,*) '* rnoxp = ',rnoxp + WRITE(io_stdo_bgc,*) '* rnoxpi = ',rnoxpi + WRITE(io_stdo_bgc,*) '* rno2anmx = ',rno2anmx + WRITE(io_stdo_bgc,*) '* rno2anmxi = ',rno2anmxi + WRITE(io_stdo_bgc,*) '* rnh4anmx = ',rnh4anmx + WRITE(io_stdo_bgc,*) '* rnh4anmxi = ',rnh4anmxi + WRITE(io_stdo_bgc,*) '* rno2dnra = ',rno2dnra + WRITE(io_stdo_bgc,*) '* rno2dnrai = ',rno2dnrai + WRITE(io_stdo_bgc,*) '* rnh4dnra = ',rnh4dnra + WRITE(io_stdo_bgc,*) '* rnh4dnrai = ',rnh4dnrai + WRITE(io_stdo_bgc,*) '* rnm1 = ',rnm1 + WRITE(io_stdo_bgc,*) '* bkphyanh4 = ',bkphyanh4 + WRITE(io_stdo_bgc,*) '* bkphyano3 = ',bkphyano3 + WRITE(io_stdo_bgc,*) '* bkphosph = ',bkphosph + WRITE(io_stdo_bgc,*) '* bkiron = ',bkiron + WRITE(io_stdo_bgc,*) '* rano3denit = ',rano3denit *dtbinv + WRITE(io_stdo_bgc,*) '* q10ano3denit = ',q10ano3denit + WRITE(io_stdo_bgc,*) '* Trefano3denit = ',Trefano3denit + WRITE(io_stdo_bgc,*) '* sc_ano3denit = ',sc_ano3denit + WRITE(io_stdo_bgc,*) '* bkano3denit = ',bkano3denit + WRITE(io_stdo_bgc,*) '* rano2anmx = ',rano2anmx *dtbinv + WRITE(io_stdo_bgc,*) '* q10anmx = ',q10anmx + WRITE(io_stdo_bgc,*) '* Trefanmx = ',Trefanmx + WRITE(io_stdo_bgc,*) '* alphaanmx = ',alphaanmx + WRITE(io_stdo_bgc,*) '* bkoxanmx = ',bkoxanmx + WRITE(io_stdo_bgc,*) '* bkano2anmx = ',bkano2anmx + WRITE(io_stdo_bgc,*) '* bkanh4anmx = ',bkanh4anmx + WRITE(io_stdo_bgc,*) '* rano2denit = ',rano2denit *dtbinv + WRITE(io_stdo_bgc,*) '* q10ano2denit = ',q10ano2denit + WRITE(io_stdo_bgc,*) '* Trefano2denit = ',Trefano2denit + WRITE(io_stdo_bgc,*) '* bkoxano2denit = ',bkoxano2denit + WRITE(io_stdo_bgc,*) '* bkano2denit = ',bkano2denit + WRITE(io_stdo_bgc,*) '* ran2odenit = ',ran2odenit *dtbinv + WRITE(io_stdo_bgc,*) '* q10an2odenit = ',q10an2odenit + WRITE(io_stdo_bgc,*) '* Trefan2odenit = ',Trefan2odenit + WRITE(io_stdo_bgc,*) '* bkoxan2odenit = ',bkoxan2odenit + WRITE(io_stdo_bgc,*) '* bkan2odenit = ',bkan2odenit + WRITE(io_stdo_bgc,*) '* rdnra = ',rdnra *dtbinv + WRITE(io_stdo_bgc,*) '* q10dnra = ',q10dnra + WRITE(io_stdo_bgc,*) '* Trefdnra = ',Trefdnra + WRITE(io_stdo_bgc,*) '* bkoxdnra = ',bkoxdnra + WRITE(io_stdo_bgc,*) '* bkdnra = ',bkdnra + WRITE(io_stdo_bgc,*) '* ranh4nitr = ',ranh4nitr *dtbinv + WRITE(io_stdo_bgc,*) '* q10anh4nitr = ',q10anh4nitr + WRITE(io_stdo_bgc,*) '* Trefanh4nitr = ',Trefanh4nitr + WRITE(io_stdo_bgc,*) '* bkoxamox = ',bkoxamox + WRITE(io_stdo_bgc,*) '* bkanh4nitr = ',bkanh4nitr + WRITE(io_stdo_bgc,*) '* bkamoxn2o = ',bkamoxn2o + WRITE(io_stdo_bgc,*) '* mufn2o = ',mufn2o + WRITE(io_stdo_bgc,*) '* bn2o = ',bn2o + WRITE(io_stdo_bgc,*) '* n2omaxy = ',n2omaxy + WRITE(io_stdo_bgc,*) '* n2oybeta = ',n2oybeta + WRITE(io_stdo_bgc,*) '* bkyamox = ',bkyamox + WRITE(io_stdo_bgc,*) '* rano2nitr = ',rano2nitr *dtbinv + WRITE(io_stdo_bgc,*) '* q10ano2nitr = ',q10ano2nitr + WRITE(io_stdo_bgc,*) '* Trefano2nitr = ',Trefano2nitr + WRITE(io_stdo_bgc,*) '* bkoxnitr = ',bkoxnitr + WRITE(io_stdo_bgc,*) '* bkano2nitr = ',bkano2nitr + WRITE(io_stdo_bgc,*) '* NOB2AOAy = ',NOB2AOAy + + end subroutine extNwatercol_param_write + !================================================================================================================================== subroutine nitrification(kpie,kpje,kpke,kbnd,pddpo,omask,ptho) ! Nitrification processes (NH4 -> NO2, NO2 -> NO3) accompanied diff --git a/hamocc/mo_param_bgc.F90 b/hamocc/mo_param_bgc.F90 index cf5a6894..5d9fe139 100644 --- a/hamocc/mo_param_bgc.F90 +++ b/hamocc/mo_param_bgc.F90 @@ -74,7 +74,8 @@ module mo_param_bgc use mo_param1_bgc, only: iatmnh3,iatmn2o use mo_carbch, only: atm_nh3,atm_n2o use mo_chemcon, only: atn2o !fixed mixing ratio of N2O at 1980, 300ppb = 300e3ppt = 3e-7 mol/mol - use mo_extNwatercol,only: extNwatercol_param_init + use mo_extNwatercol,only: extNwatercol_param_init,extNwatercol_param_update,extNwatercol_param_write, & + rano3denit,rano2anmx,rano2denit,ran2odenit,rdnra,ranh4nitr,rano2nitr use mo_extNsediment,only: extNsediment_param_init #endif @@ -118,7 +119,7 @@ subroutine ini_parambgc(kpie,kpje) call calc_param_atm() ! calculate atmospheric parameters after updating parameters via nml call ini_fields_atm(kpie,kpje) ! initialize atmospheric fields with (updated) parameter values call readjust_param() ! potentially readjust namlist parameter-dependent parameters - call rates_2_timestep() ! Converting rates from /d... to /dtb + call rates_2_timestep() ! Converting rates from /d... to /dtb call init_m4ago_params() ! Initialize M4AGO parameters relying on nml parameters call write_parambgc() ! write out used parameters and calculate back rates from /dtb to /d.. @@ -426,7 +427,11 @@ subroutine read_bgcnamelist() & remido,drempoc,dremopal,dremn2o,dremsul,fetune,relaxfe,wpoc, & #if defined(WLIN) && ! defined(AGG) & wmin,wmax,wlin, & -#endif +#endif +#ifdef extNcycle + & rano3denit,rano2anmx,rano2denit,ran2odenit,rdnra,ranh4nitr,rano2nitr, & + +#endif & wcal,wopal open (newunit=iounit, file=bgc_namelist, status='old',action='read') @@ -512,6 +517,10 @@ subroutine rates_2_timestep() #ifndef AGG wdust = wdust*dtb !m/d dust sinking speed #endif +#ifdef extNcycle + call extNwatercol_param_update() +#endif + end subroutine !--------------------------------------------------------------------------------------------------------------------------------- @@ -720,7 +729,10 @@ subroutine write_parambgc() write(io_stdo_bgc,*) '****************************************************************' #endif WRITE(io_stdo_bgc,*) '* claydens = ',claydens - WRITE(io_stdo_bgc,*) '****************************************************************' + WRITE(io_stdo_bgc,*) '****************************************************************' +#ifdef extNcycle + call extNwatercol_param_write() +#endif ENDIF end subroutine end module mo_param_bgc From f9fb3a5b3dd139fac7b721c45a5b47898b92434e Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Thu, 7 Sep 2023 19:06:43 +0200 Subject: [PATCH 308/366] Make N-cyle sediment parameters available for nml --- hamocc/mo_extNsediment.F90 | 94 ++++++++++++++++++++++++++++++++++---- hamocc/mo_param_bgc.F90 | 9 +++- 2 files changed, 91 insertions(+), 12 deletions(-) diff --git a/hamocc/mo_extNsediment.F90 b/hamocc/mo_extNsediment.F90 index af277b30..66274894 100644 --- a/hamocc/mo_extNsediment.F90 +++ b/hamocc/mo_extNsediment.F90 @@ -45,7 +45,7 @@ MODULE mo_extNsediment use mo_param1_bgc, only: issso12,ipowaic,ipowaal,ipowaph,ipowaox,ipown2,ipowno3,ipownh4,ipown2o,ipowno2,ks use mo_vgrid, only: kbo use mo_biomod, only: rnit,rcar,rnoi - use mo_control_bgc, only: dtb + use mo_control_bgc, only: io_stdo_bgc,dtb use mo_sedmnt, only: powtra,sedlay,porsol,porwat use mo_extNwatercol,only: rc2n,ro2utammo,ro2nnit,rnoxp,rnoxpi,rno2anmx,rno2anmxi,rnh4anmx, & & rnh4anmxi,rno2dnra,rno2dnrai,rnh4dnra,rnh4dnrai,rnm1 @@ -55,12 +55,15 @@ MODULE mo_extNsediment private ! public functions - public :: extNsediment_param_init,sed_nitrification,sed_denit_NO3_to_NO2,sed_anammox,sed_denit_DNRA,alloc_mem_extNsediment_diag + public :: extNsediment_param_init,sed_nitrification,sed_denit_NO3_to_NO2,sed_anammox,sed_denit_DNRA,alloc_mem_extNsediment_diag, & + extNsediment_param_update,extNsediment_param_write ! public parameters and fields public :: ised_nitr_NH4,ised_nitr_NO2,ised_nitr_N2O_prod,ised_nitr_NH4_OM,ised_nitr_NO2_OM,ised_denit_NO3,ised_denit_NO2, & ised_denit_N2O,ised_DNRA_NO2,ised_anmx_N2_prod,ised_anmx_OM_prod,ised_remin_aerob,ised_remin_sulf,extNsed_diagnostics, & - POM_remin_q10_sed, POM_remin_Tref_sed,bkox_drempoc_sed + POM_remin_q10_sed, POM_remin_Tref_sed,bkox_drempoc_sed, & + rano3denit_sed,rano2anmx_sed,rano2denit_sed,ran2odenit_sed,rdnra_sed,ranh4nitr_sed,rano2nitr_sed + ! extended nitrogen cycle sediment parameters real :: q10ano3denit_sed,sc_ano3denit_sed,Trefano3denit_sed,rano3denit_sed,bkano3denit_sed, & @@ -140,7 +143,7 @@ subroutine extNsediment_param_init() ! === Denitrification step NO3 -> NO2: !rano3denit_sed = 0.15*dtb ! Maximum growth rate denitrification on NO3 at reference T (1/d -> 1/dt) - rano3denit_sed = 0.05*dtb ! Maximum growth rate denitrification on NO3 at reference T (1/d -> 1/dt) + rano3denit_sed = 0.05 ! Maximum growth rate denitrification on NO3 at reference T (1/d -> 1/dt) q10ano3denit_sed = q10ano3denit ! Q10 factor for denitrification on NO3 (-) Trefano3denit_sed = Trefano3denit ! Reference temperature for denitrification on NO3 (degr C) !sc_ano3denit_sed = 0.05e6 ! Shape factor for NO3 denitrification oxygen inhibition function (m3/kmol) @@ -148,7 +151,7 @@ subroutine extNsediment_param_init() bkano3denit_sed = bkano3denit ! Half-saturation constant for NO3 denitrification (kmol/m3) ! === Anammox - rano2anmx_sed = 0.05*dtb ! Maximum growth rate for anammox at reference T (1/d -> 1/dt) + rano2anmx_sed = 0.05 ! Maximum growth rate for anammox at reference T (1/d -> 1/dt) q10anmx_sed = q10anmx ! Q10 factor for anammox (-) Trefanmx_sed = Trefanmx ! Reference temperature for anammox (degr C) alphaanmx_sed = alphaanmx ! Shape factor for anammox oxygen inhibition function (m3/kmol) @@ -157,28 +160,28 @@ subroutine extNsediment_param_init() bkanh4anmx_sed = bkano2anmx_sed * rnh4anmx/rno2anmx !Half-saturation constant for NH4 limitation of anammox (kmol/m3) ! === Denitrification step NO2 -> N2O - rano2denit_sed = 0.12*dtb ! Maximum growth rate denitrification on NO2 at reference T (1/d -> 1/dt) + rano2denit_sed = 0.12 ! Maximum growth rate denitrification on NO2 at reference T (1/d -> 1/dt) q10ano2denit_sed = q10ano2denit ! Q10 factor for denitrification on NO2 (-) Trefano2denit_sed = Trefano2denit ! Reference temperature for denitrification on NO2 (degr C) bkoxano2denit_sed = bkoxano2denit ! Half-saturation constant for (quadratic) oxygen inhibition function of denitrification on NO2 (kmol/m3) bkano2denit_sed = bkano2denit ! Half-saturation constant for denitrification on NO2 (kmol/m3) ! === Denitrification step N2O -> N2 - ran2odenit_sed = 0.16*dtb ! Maximum growth rate denitrification on N2O at reference T (1/d -> 1/dt) + ran2odenit_sed = 0.16 ! Maximum growth rate denitrification on N2O at reference T (1/d -> 1/dt) q10an2odenit_sed = q10an2odenit ! Q1- factor for denitrificationj on N2O (-) Trefan2odenit_sed = Trefan2odenit ! Reference temperature for denitrification on N2O (degr C) bkoxan2odenit_sed = bkoxan2odenit ! Half-saturation constant for (quadratic) oxygen inhibition function of denitrification on N2O (kmol/m3) bkan2odenit_sed = bkan2odenit ! Half-saturation constant for denitrification on N2O (kmol/m3) ! === DNRA NO2 -> NH4 - rdnra_sed = 0.1*dtb ! Maximum growth rate DNRA on NO2 at reference T (1/d -> 1/dt) + rdnra_sed = 0.1 ! Maximum growth rate DNRA on NO2 at reference T (1/d -> 1/dt) q10dnra_sed = q10dnra ! Q10 factor for DNRA on NO2 (-) Trefdnra_sed = Trefdnra ! Reference temperature for DNRA (degr C) bkoxdnra_sed = bkoxdnra ! Half saturation constant for (quadratic) oxygen inhibition function of DNRA on NO2 (kmol/m3) bkdnra_sed = bkdnra ! Half-saturation constant for DNRA on NO2 (kmol/m3) ! === Nitrification on NH4 - ranh4nitr_sed = 1.*dtb ! Maximum growth rate nitrification on NH4 at reference T (1/d -> 1/dt) + ranh4nitr_sed = 1. ! Maximum growth rate nitrification on NH4 at reference T (1/d -> 1/dt) q10anh4nitr_sed = q10anh4nitr ! Q10 factor for nitrification on NH4 (-) Trefanh4nitr_sed = Trefanh4nitr ! Reference temperature for nitrification on NH4 (degr C) bkoxamox_sed = bkoxamox ! Half-saturation constant for oxygen limitation of nitrification on NH4 (kmol/m3) @@ -198,7 +201,7 @@ subroutine extNsediment_param_init() bkyamox_sed = bkyamox ! Half saturation constant for pathway splitting function OM-yield for nitrification on NH4 (kmol/m3) ! === Nitrification on NO2 - rano2nitr_sed = 1.54*dtb ! Maximum growth rate nitrification on NO2 at reference T (1/d -> 1/dt) + rano2nitr_sed = 1.54 ! Maximum growth rate nitrification on NO2 at reference T (1/d -> 1/dt) q10ano2nitr_sed = q10ano2nitr ! Q10 factor for nitrification on NO2 (-) Trefano2nitr_sed = Trefano2nitr ! Reference temperature for nitrification on NO2 (degr C) bkoxnitr_sed = bkoxnitr ! Half-saturation constant for oxygen limitation of nitrification on NO2 (kmol/m3) @@ -209,6 +212,77 @@ subroutine extNsediment_param_init() minlim = 1.e-9 ! minimum for limitation functions (e.g. nutlim or oxlim/inh can only decrease to minlim) end subroutine extNsediment_param_init + ! ================================================================================================================================ + subroutine extNsediment_param_update() + + rano3denit_sed = rano3denit_sed *dtb ! Maximum growth rate denitrification on NO3 at reference T (1/d -> 1/dt) + rano2anmx_sed = rano2anmx_sed *dtb ! Maximum growth rate for anammox at reference T (1/d -> 1/dt) + rano2denit_sed = rano2denit_sed *dtb ! Maximum growth rate denitrification on NO2 at reference T (1/d -> 1/dt) + ran2odenit_sed = ran2odenit_sed *dtb ! Maximum growth rate denitrification on N2O at reference T (1/d -> 1/dt) + rdnra_sed = rdnra_sed *dtb ! Maximum growth rate DNRA on NO2 at reference T (1/d -> 1/dt) + ranh4nitr_sed = ranh4nitr_sed *dtb ! Maximum growth rate nitrification on NH4 at reference T (1/d -> 1/dt) + rano2nitr_sed = rano2nitr_sed *dtb ! Maximum growth rate nitrification on NO2 at reference T (1/d -> 1/dt) + + end subroutine extNsediment_param_update + + ! ================================================================================================================================ + subroutine extNsediment_param_write() + + REAL :: dtbinv + dtbinv = 1./dtb + + WRITE(io_stdo_bgc,*) '****************************************************************' + WRITE(io_stdo_bgc,*) '* HAMOCC extended nitrogen cycle parameters sediment:' + WRITE(io_stdo_bgc,*) '* POM_remin_q10_sed = ', POM_remin_q10_sed + WRITE(io_stdo_bgc,*) '* POM_remin_Tref_sed= ', POM_remin_Tref_sed + WRITE(io_stdo_bgc,*) '* bkox_drempoc_sed = ', bkox_drempoc_sed + WRITE(io_stdo_bgc,*) '* rano3denit_sed = ',rano3denit_sed *dtbinv + WRITE(io_stdo_bgc,*) '* q10ano3denit_sed = ',q10ano3denit_sed + WRITE(io_stdo_bgc,*) '* Trefano3denit_sed = ',Trefano3denit_sed + WRITE(io_stdo_bgc,*) '* sc_ano3denit_sed = ',sc_ano3denit_sed + WRITE(io_stdo_bgc,*) '* bkano3denit_sed = ',bkano3denit_sed + WRITE(io_stdo_bgc,*) '* rano2anmx_sed = ',rano2anmx_sed *dtbinv + WRITE(io_stdo_bgc,*) '* q10anmx_sed = ',q10anmx_sed + WRITE(io_stdo_bgc,*) '* Trefanmx_sed = ',Trefanmx_sed + WRITE(io_stdo_bgc,*) '* alphaanmx_sed = ',alphaanmx_sed + WRITE(io_stdo_bgc,*) '* bkoxanmx_sed = ',bkoxanmx_sed + WRITE(io_stdo_bgc,*) '* bkano2anmx_sed = ',bkano2anmx_sed + WRITE(io_stdo_bgc,*) '* bkanh4anmx_sed = ',bkanh4anmx_sed + WRITE(io_stdo_bgc,*) '* rano2denit_sed = ',rano2denit_sed *dtbinv + WRITE(io_stdo_bgc,*) '* q10ano2denit_sed = ',q10ano2denit_sed + WRITE(io_stdo_bgc,*) '* Trefano2denit_sed = ',Trefano2denit_sed + WRITE(io_stdo_bgc,*) '* bkoxano2denit_sed = ',bkoxano2denit_sed + WRITE(io_stdo_bgc,*) '* bkano2denit_sed = ',bkano2denit_sed + WRITE(io_stdo_bgc,*) '* ran2odenit_sed = ',ran2odenit_sed *dtbinv + WRITE(io_stdo_bgc,*) '* q10an2odenit_sed = ',q10an2odenit_sed + WRITE(io_stdo_bgc,*) '* Trefan2odenit_sed = ',Trefan2odenit_sed + WRITE(io_stdo_bgc,*) '* bkoxan2odenit_sed = ',bkoxan2odenit_sed + WRITE(io_stdo_bgc,*) '* bkan2odenit_sed = ',bkan2odenit_sed + WRITE(io_stdo_bgc,*) '* rdnra_sed = ',rdnra_sed *dtbinv + WRITE(io_stdo_bgc,*) '* q10dnra_sed = ',q10dnra_sed + WRITE(io_stdo_bgc,*) '* Trefdnra_sed = ',Trefdnra_sed + WRITE(io_stdo_bgc,*) '* bkoxdnra_sed = ',bkoxdnra_sed + WRITE(io_stdo_bgc,*) '* bkdnra_sed = ',bkdnra_sed + WRITE(io_stdo_bgc,*) '* ranh4nitr_sed = ',ranh4nitr_sed *dtbinv + WRITE(io_stdo_bgc,*) '* q10anh4nitr_sed = ',q10anh4nitr_sed + WRITE(io_stdo_bgc,*) '* Trefanh4nitr_sed = ',Trefanh4nitr_sed + WRITE(io_stdo_bgc,*) '* bkoxamox_sed = ',bkoxamox_sed + WRITE(io_stdo_bgc,*) '* bkanh4nitr_sed = ',bkanh4nitr_sed + WRITE(io_stdo_bgc,*) '* bkamoxn2o_sed = ',bkamoxn2o_sed + WRITE(io_stdo_bgc,*) '* mufn2o_sed = ',mufn2o_sed + WRITE(io_stdo_bgc,*) '* bn2o_sed = ',bn2o_sed + WRITE(io_stdo_bgc,*) '* n2omaxy_sed = ',n2omaxy_sed + WRITE(io_stdo_bgc,*) '* n2oybeta_sed = ',n2oybeta_sed + WRITE(io_stdo_bgc,*) '* bkyamox_sed = ',bkyamox_sed + WRITE(io_stdo_bgc,*) '* rano2nitr_sed = ',rano2nitr_sed *dtbinv + WRITE(io_stdo_bgc,*) '* q10ano2nitr_sed = ',q10ano2nitr_sed + WRITE(io_stdo_bgc,*) '* Trefano2nitr_sed = ',Trefano2nitr_sed + WRITE(io_stdo_bgc,*) '* bkoxnitr_sed = ',bkoxnitr_sed + WRITE(io_stdo_bgc,*) '* bkano2nitr_sed = ',bkano2nitr_sed + WRITE(io_stdo_bgc,*) '* NOB2AOAy_sed = ',NOB2AOAy_sed + + end subroutine extNsediment_param_write + ! ================================================================================================================================ subroutine sed_nitrification(j,kpie,kpje,kpke,kbnd,ptho,omask,ex_ddic,ex_dalk) integer, intent(in) :: j,kpie,kpje,kpke,kbnd diff --git a/hamocc/mo_param_bgc.F90 b/hamocc/mo_param_bgc.F90 index 5d9fe139..78f03293 100644 --- a/hamocc/mo_param_bgc.F90 +++ b/hamocc/mo_param_bgc.F90 @@ -76,7 +76,9 @@ module mo_param_bgc use mo_chemcon, only: atn2o !fixed mixing ratio of N2O at 1980, 300ppb = 300e3ppt = 3e-7 mol/mol use mo_extNwatercol,only: extNwatercol_param_init,extNwatercol_param_update,extNwatercol_param_write, & rano3denit,rano2anmx,rano2denit,ran2odenit,rdnra,ranh4nitr,rano2nitr - use mo_extNsediment,only: extNsediment_param_init + use mo_extNsediment,only: extNsediment_param_init,extNsediment_param_update,extNsediment_param_write, & + rano3denit_sed,rano2anmx_sed,rano2denit_sed,ran2odenit_sed,rdnra_sed,ranh4nitr_sed,rano2nitr_sed + #endif implicit none @@ -430,6 +432,7 @@ subroutine read_bgcnamelist() #endif #ifdef extNcycle & rano3denit,rano2anmx,rano2denit,ran2odenit,rdnra,ranh4nitr,rano2nitr, & + & rano3denit_sed,rano2anmx_sed,rano2denit_sed,ran2odenit_sed,rdnra_sed,ranh4nitr_sed,rano2nitr_sed, & #endif & wcal,wopal @@ -519,6 +522,7 @@ subroutine rates_2_timestep() #endif #ifdef extNcycle call extNwatercol_param_update() + call extNsediment_param_update() #endif end subroutine @@ -729,10 +733,11 @@ subroutine write_parambgc() write(io_stdo_bgc,*) '****************************************************************' #endif WRITE(io_stdo_bgc,*) '* claydens = ',claydens - WRITE(io_stdo_bgc,*) '****************************************************************' #ifdef extNcycle call extNwatercol_param_write() + call extNsediment_param_write() #endif + WRITE(io_stdo_bgc,*) '****************************************************************' ENDIF end subroutine end module mo_param_bgc From fa12ebb7ddfbe157e10d9a20b6ddfc927fee0021 Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Thu, 7 Sep 2023 19:14:53 +0200 Subject: [PATCH 309/366] fix line wrap... --- hamocc/mo_extNwatercol.F90 | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/hamocc/mo_extNwatercol.F90 b/hamocc/mo_extNwatercol.F90 index d8ccd9d0..ce618b3e 100644 --- a/hamocc/mo_extNwatercol.F90 +++ b/hamocc/mo_extNwatercol.F90 @@ -225,8 +225,7 @@ subroutine extNwatercol_param_write() REAL :: dtbinv dtbinv = 1./dtb WRITE(io_stdo_bgc,*) '****************************************************************' - WRITE(io_stdo_bgc,*) '* HAMOCC extended nitrogen cycle -parameters water column:' + WRITE(io_stdo_bgc,*) '* HAMOCC extended nitrogen cycle parameters water column:' WRITE(io_stdo_bgc,*) '* rc2n = ',rc2n WRITE(io_stdo_bgc,*) '* ro2utammo = ',ro2utammo WRITE(io_stdo_bgc,*) '* ro2nnit = ',ro2nnit From 66ad720447290081b9938e72ec9cb37ff94c8b04 Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Mon, 18 Sep 2023 18:21:39 +0200 Subject: [PATCH 310/366] add NHx deposition read for input file --- hamocc/mo_read_ndep.F90 | 36 +++++++++++++++++++++++++++++++++++- 1 file changed, 35 insertions(+), 1 deletion(-) diff --git a/hamocc/mo_read_ndep.F90 b/hamocc/mo_read_ndep.F90 index 5134c587..7d7de3a6 100644 --- a/hamocc/mo_read_ndep.F90 +++ b/hamocc/mo_read_ndep.F90 @@ -72,6 +72,8 @@ module mo_read_ndep character(len=512), save :: ndepfile='' real, allocatable, save :: ndepread(:,:) + real, allocatable, save :: noydepread(:,:) + real, allocatable, save :: nhxdepread(:,:) integer, save :: startyear,endyear logical, save :: lini = .false. @@ -147,6 +149,28 @@ subroutine ini_read_ndep(kpie,kpje) stop '(ini_read_ndep)' endif +#ifdef extNcycle + ! Allocate field to hold N-deposition fluxes + IF (mnproc.eq.1) THEN + WRITE(io_stdo_bgc,*)'Memory allocation for variable nhxdepread ...' + WRITE(io_stdo_bgc,*)'First dimension : ',kpie + WRITE(io_stdo_bgc,*)'Second dimension : ',kpje + ENDIF + + ALLOCATE (nhxdepread(kpie,kpje),stat=errstat) + if(errstat.ne.0) stop 'not enough memory nhxdepread' + nhxdepread(:,:) = 0.0 + + IF (mnproc.eq.1) THEN + WRITE(io_stdo_bgc,*)'Memory allocation for variable noydepread ...' + WRITE(io_stdo_bgc,*)'First dimension : ',kpie + WRITE(io_stdo_bgc,*)'Second dimension : ',kpje + ENDIF + + ALLOCATE (noydepread(kpie,kpje),stat=errstat) + if(errstat.ne.0) stop 'not enough memory noydepread' + noydepread(:,:) = 0.0 +#else ! Allocate field to hold N-deposition fluxes IF (mnproc.eq.1) THEN WRITE(io_stdo_bgc,*)'Memory allocation for variable ndepread ...' @@ -157,6 +181,7 @@ subroutine ini_read_ndep(kpie,kpje) ALLOCATE (ndepread(kpie,kpje),stat=errstat) if(errstat.ne.0) stop 'not enough memory ndep' ndepread(:,:) = 0.0 +#endif ! read start and end year of n-deposition file call ncfopn(trim(ndepfile),'r',' ',1,iotype) @@ -227,18 +252,27 @@ subroutine get_ndep(kpie,kpje,kplyear,kplmon,omask,ndep) ' from file ',trim(ndepfile) endif ncstat=nf90_open(trim(ndepfile),nf90_nowrite,ncid) +#ifdef extNcycle + call read_netcdf_var(ncid,'nhxdep',nhxdepread,1,month_in_file,0) + call read_netcdf_var(ncid,'noydep',noydepread,1,month_in_file,0) +#else call read_netcdf_var(ncid,'ndep',ndepread,1,month_in_file,0) +#endif ncstat=nf90_close(ncid) oldmonth=kplmon endif !$OMP PARALLEL DO PRIVATE(i) ! 1 = NO3; 2 = NH4 - ! needs further preparation (split of climatological input data + sep. reading) DO j=1,kpje DO i=1,kpie +#ifdef extNcycle + ndep(i,j,1) = noydepread(i,j) + ndep(i,j,2) = nhxdepread(i,j) +#else ndep(i,j,1) = ndepread(i,j) ndep(i,j,2) = 0. +#endif ENDDO ENDDO !$OMP END PARALLEL DO From 8cec0d5d99c3b63209d98363a4c12b5d028d6c6b Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Mon, 18 Sep 2023 18:22:25 +0200 Subject: [PATCH 311/366] Replace hard coded index numbers by parameters --- hamocc/hamocc4bcm.F90 | 10 +++++----- hamocc/hamocc_step.F90 | 3 ++- hamocc/mo_apply_ndep.F90 | 12 ++++++------ hamocc/mo_param1_bgc.F90 | 9 +++++++++ hamocc/mo_read_ndep.F90 | 13 ++++++++----- 5 files changed, 30 insertions(+), 17 deletions(-) diff --git a/hamocc/hamocc4bcm.F90 b/hamocc/hamocc4bcm.F90 index 5cc04b66..d0ff0a07 100644 --- a/hamocc/hamocc4bcm.F90 +++ b/hamocc/hamocc4bcm.F90 @@ -97,7 +97,7 @@ SUBROUTINE HAMOCC4BCM(kpie,kpje,kpke,kbnd,kplyear,kplmon,kplday,kldtday,& use mo_control_bgc, only: ldtrunbgc,dtbgc,ldtbgc,io_stdo_bgc,dtbgc,ndtdaybgc, & do_sedspinup,sedspin_yr_s,sedspin_yr_e,sedspin_ncyc,& do_ndep_coupled - use mo_param1_bgc, only: iatmco2,iatmdms,nocetra,nriv + use mo_param1_bgc, only: iatmco2,iatmdms,nocetra,nriv,nndep,idepnoy use mo_vgrid, only: set_vgrid use mo_apply_fedep, only: apply_fedep use mo_apply_rivin, only: apply_rivin @@ -113,7 +113,7 @@ SUBROUTINE HAMOCC4BCM(kpie,kpje,kpke,kbnd,kplyear,kplmon,kplday,kldtday,& use mo_carbch, only: atm_cfc11_nh,atm_cfc11_sh,atm_cfc12_nh,atm_cfc12_sh,atm_sf6_nh,atm_sf6_sh #endif #ifdef extNcycle - use mo_param1_bgc, only: iatmn2o,iatmnh3 + use mo_param1_bgc, only: iatmn2o,iatmnh3,idepnhx #endif implicit none @@ -127,7 +127,7 @@ SUBROUTINE HAMOCC4BCM(kpie,kpje,kpke,kbnd,kplyear,kplmon,kplday,kldtday,& REAL, intent(in) :: omask (kpie,kpje) REAL, intent(in) :: dust (kpie,kpje) REAL, intent(in) :: rivin (kpie,kpje,nriv) - REAL, intent(inout):: ndep (kpie,kpje,2) + REAL, intent(inout):: ndep (kpie,kpje,nndep) REAL, intent(in) :: oafx (kpie,kpje) REAL, intent(in) :: pi_ph (kpie,kpje) REAL, intent(in) :: pfswr (1-kbnd:kpie+kbnd,1-kbnd:kpje+kbnd) @@ -238,10 +238,10 @@ SUBROUTINE HAMOCC4BCM(kpie,kpje,kpke,kbnd,kplyear,kplmon,kplday,kldtday,& DO i=1,kpie ! convert from kgN/m2/s to climatological input file units: kmolN/m2/yr IF (patmnoydep(i,j).gt.0.) THEN - ndep(i,j,1) = patmnoydep(i,j)*fatmndep + ndep(i,j,idepnoy) = patmnoydep(i,j)*fatmndep ENDIF IF (patmnhxdep(i,j).gt.0.) THEN - ndep(i,j,2) = patmnhxdep(i,j)*fatmndep + ndep(i,j,idepnhx) = patmnhxdep(i,j)*fatmndep ENDIF ENDDO ENDDO diff --git a/hamocc/hamocc_step.F90 b/hamocc/hamocc_step.F90 index 0dc73678..349c19ca 100644 --- a/hamocc/hamocc_step.F90 +++ b/hamocc/hamocc_step.F90 @@ -40,13 +40,14 @@ subroutine hamocc_step(m,n,mm,nn,k1m,k1n) use mo_read_oafx, only: get_oafx use mo_read_pi_ph, only: get_pi_ph,pi_ph use mo_control_bgc, only: with_dmsph,do_ndep_coupled + use mo_param1_bgc, only: nndep implicit none integer, intent(in) :: m,n,mm,nn,k1m,k1n integer :: l,ldtday - real :: ndep(idm,jdm,2) ! 1=NO3, 2=NH4 (in case of extNcycle) + real :: ndep(idm,jdm,nndep) real :: dust(idm,jdm) real :: oafx(idm,jdm) diff --git a/hamocc/mo_apply_ndep.F90 b/hamocc/mo_apply_ndep.F90 index f3420a5a..9000006e 100644 --- a/hamocc/mo_apply_ndep.F90 +++ b/hamocc/mo_apply_ndep.F90 @@ -87,10 +87,10 @@ subroutine apply_ndep(kpie,kpje,kpke,pddpo,omask,ndep) use mod_xc, only: mnproc use mo_control_bgc, only: io_stdo_bgc,dtb,do_ndep use mo_carbch, only: ocetra,ndepnoyflx - use mo_param1_bgc, only: iano3,ialkali,inatalkali + use mo_param1_bgc, only: iano3,ialkali,inatalkali,nndep,idepnoy #ifdef extNcycle use mo_carbch, only: ndepnhxflx - use mo_param1_bgc, only: ianh4 + use mo_param1_bgc, only: ianh4,idepnhx #endif implicit none @@ -98,7 +98,7 @@ subroutine apply_ndep(kpie,kpje,kpke,pddpo,omask,ndep) integer, intent(in) :: kpie,kpje,kpke real, intent(in) :: pddpo(kpie,kpje,kpke) real, intent(in) :: omask(kpie,kpje) - real, intent(in) :: ndep(kpie,kpje,2) + real, intent(in) :: ndep(kpie,kpje,nndep) ! local variables integer :: i,j @@ -112,18 +112,18 @@ subroutine apply_ndep(kpie,kpje,kpke,pddpo,omask,ndep) #endif if (.not. do_ndep) return - ! deposite N in topmost layer + ! deposit N in topmost layer do j=1,kpje do i=1,kpie if (omask(i,j).gt.0.5) then - ndepnoyflx(i,j) = ndep(i,j,1)*dtb/365. + ndepnoyflx(i,j) = ndep(i,j,idepnoy)*dtb/365. ocetra(i,j,1,iano3)=ocetra(i,j,1,iano3)+ndepnoyflx(i,j)/pddpo(i,j,1) ocetra(i,j,1,ialkali)=ocetra(i,j,1,ialkali)-ndepnoyflx(i,j)/pddpo(i,j,1) #ifdef natDIC ocetra(i,j,1,inatalkali)=ocetra(i,j,1,inatalkali)-ndepnoyflx(i,j)/pddpo(i,j,1) #endif #ifdef extNcycle - ndepnhxflx(i,j) = ndep(i,j,2)*dtb/365. + ndepnhxflx(i,j) = ndep(i,j,idepnhx)*dtb/365. ocetra(i,j,1,ianh4) = ocetra(i,j,1,ianh4) + ndepnhxflx(i,j)/pddpo(i,j,1) ocetra(i,j,1,ialkali) = ocetra(i,j,1,ialkali) + ndepnhxflx(i,j)/pddpo(i,j,1) #endif diff --git a/hamocc/mo_param1_bgc.F90 b/hamocc/mo_param1_bgc.F90 index 5202811a..3d833e89 100644 --- a/hamocc/mo_param1_bgc.F90 +++ b/hamocc/mo_param1_bgc.F90 @@ -208,6 +208,15 @@ MODULE mo_param1_bgc ! total number of atmosphere tracers INTEGER, PARAMETER :: natm=i_base_atm+i_iso_atm+i_cfc_atm+i_ndic_atm+i_bromo_atm+i_nh3_atm +! N-deposition +#ifdef extNcycle + integer, parameter :: nndep = 2 ! size of N-deposition input field + integer, parameter :: idepnoy = 1, & ! index for NOy deposition + idepnhx = 2 ! index for NHx deposition +#else + integer, parameter :: nndep = 1 + integer, parameter :: idepnoy = 1 +#endif ! rivers integer, parameter :: nriv =7 ! size of river input field diff --git a/hamocc/mo_read_ndep.F90 b/hamocc/mo_read_ndep.F90 index 7d7de3a6..db80afa1 100644 --- a/hamocc/mo_read_ndep.F90 +++ b/hamocc/mo_read_ndep.F90 @@ -225,12 +225,16 @@ subroutine get_ndep(kpie,kpje,kplyear,kplmon,omask,ndep) use mod_xc, only: mnproc use netcdf, only: nf90_open,nf90_close,nf90_nowrite use mo_control_bgc, only: io_stdo_bgc,do_ndep + use mo_param1_bgc, only: nndep,idepnoy +#ifdef extNcycle + use mo_param1_bgc, only: idepnhx +#endif implicit none integer, intent(in) :: kpie,kpje,kplyear,kplmon real, intent(in) :: omask(kpie,kpje) - real, intent(out) :: ndep(kpie,kpje,2) + real, intent(out) :: ndep(kpie,kpje,nndep) ! local variables integer :: month_in_file,ncstat,ncid,i,j @@ -267,11 +271,10 @@ subroutine get_ndep(kpie,kpje,kplyear,kplmon,omask,ndep) DO j=1,kpje DO i=1,kpie #ifdef extNcycle - ndep(i,j,1) = noydepread(i,j) - ndep(i,j,2) = nhxdepread(i,j) + ndep(i,j,idepnoy) = noydepread(i,j) + ndep(i,j,idepnhx) = nhxdepread(i,j) #else - ndep(i,j,1) = ndepread(i,j) - ndep(i,j,2) = 0. + ndep(i,j,idepnoy) = ndepread(i,j) #endif ENDDO ENDDO From 21b9b7db81455831b23e56e328a9e613e9d52515 Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Mon, 18 Sep 2023 18:45:55 +0200 Subject: [PATCH 312/366] Introduce parameter for CAM mol weight of nitrogen --- hamocc/hamocc4bcm.F90 | 3 ++- hamocc/mo_chemcon.F90 | 2 ++ 2 files changed, 4 insertions(+), 1 deletion(-) diff --git a/hamocc/hamocc4bcm.F90 b/hamocc/hamocc4bcm.F90 index d0ff0a07..7a73fd35 100644 --- a/hamocc/hamocc4bcm.F90 +++ b/hamocc/hamocc4bcm.F90 @@ -114,6 +114,7 @@ SUBROUTINE HAMOCC4BCM(kpie,kpje,kpke,kbnd,kplyear,kplmon,kplday,kldtday,& #endif #ifdef extNcycle use mo_param1_bgc, only: iatmn2o,iatmnh3,idepnhx + use mo_chemcon, only: mw_nitrogen #endif implicit none @@ -231,7 +232,7 @@ SUBROUTINE HAMOCC4BCM(kpie,kpje,kpke,kbnd,kplyear,kplmon,kplday,kldtday,& if (mnproc.eq.1) write (io_stdo_bgc,*) 'iHAMOCC: getting N2O and NH3 conc. from atm' IF(do_ndep_coupled) THEN - fatmndep = 365.*86400./14.00674 + fatmndep = 365.*86400./mw_nitrogen ndep(:,:,:) = 0. !$OMP PARALLEL DO PRIVATE(i) DO j=1,kpje diff --git a/hamocc/mo_chemcon.F90 b/hamocc/mo_chemcon.F90 index 367b1a18..c356d7a5 100644 --- a/hamocc/mo_chemcon.F90 +++ b/hamocc/mo_chemcon.F90 @@ -196,6 +196,8 @@ MODULE mo_chemcon real, parameter :: Vb_nh3 = 20.7 ! Johnson 2010 real, parameter :: M_nh3 = (1./Ma_air + 1./Mb_nh3)**0.5 / (Va_air**(1./3.)+Vb_nh3**(1./3.))**2. real, parameter :: kappa = 0.4 ! von Karman constant + + real, parameter :: mw_nitrogen = 14.00674 ! [g/mol N] nitrogen mol-weight as defined by CAM #endif From 97994a3eca96f52525762149a7d81756e52d30d5 Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Tue, 19 Sep 2023 17:45:05 +0200 Subject: [PATCH 313/366] Update pressure calculation in M4AGO --- hamocc/mo_m4ago.F90 | 26 ++++++++++++-------------- 1 file changed, 12 insertions(+), 14 deletions(-) diff --git a/hamocc/mo_m4ago.F90 b/hamocc/mo_m4ago.F90 index b8156c4e..19a89628 100644 --- a/hamocc/mo_m4ago.F90 +++ b/hamocc/mo_m4ago.F90 @@ -124,7 +124,7 @@ MODULE mo_m4ago & N_agg(:,:,:), & ! Number of aggregates & av_d_C(:,:,:), & ! concentration-weighted mean diameter of aggs & dyn_vis(:,:,:), & ! molecular dynamic viscosity - & m4ago_ppo(:,:,:) ! in situ pressure - potentially to replace by BLOM pressure + & m4ago_ppo(:,:,:) ! pressure INTEGER, PARAMETER :: & kav_dp = 1, & @@ -324,30 +324,28 @@ SUBROUTINE cleanup_mem_m4ago END SUBROUTINE cleanup_mem_m4ago !===================================================================================== pressure - SUBROUTINE calc_pressure(kpie, kpje, kpke,kbnd, pddpo,omask, ppao, prho) + SUBROUTINE calc_pressure(kpie, kpje, kpke,kbnd, pddpo,omask) + + use mo_vgrid, only: ptiestu + IMPLICIT NONE INTEGER, INTENT(in) :: kpie !< 1st REAL of model grid. INTEGER, INTENT(in) :: kpje !< 2nd REAL of model grid. INTEGER, INTENT(in) :: kpke !< 3rd (vertical) REAL of model grid. INTEGER, INTENT(in) :: kbnd - REAL, INTENT(in) :: pddpo(kpie,kpje,kpke) !< size of scalar grid cell (3rd dimension) [m] - REAL, INTENT(in) :: omask(kpie,kpje) - REAL, INTENT(in) :: ppao (1-kbnd:kpie+kbnd,1-kbnd:kpje+kbnd) !< pressure at sea level [Pa]. - REAL, INTENT(in) :: prho (kpie,kpje,kpke) !< density [g/cm3] + REAL, INTENT(in) :: pddpo(kpie,kpje,kpke) !< size of scalar grid cell (3rd dimension) [m] + REAL, INTENT(in) :: omask(kpie,kpje) !< mask !$OMP PARALLEL DO PRIVATE(i,j,k) + do k = 1,kpke do j = 1,kpje do i = 1,kpie - if(omask(i,j) > 0.5) then - m4ago_ppo(i,j,1) = ppao(i,j) + 1000.0*prho(i,j,1)*grav_acc_const*pddpo(i,j,1) - do k = 2,kpke - if(pddpo(i,j,k) > dp_min) then - m4ago_ppo(i,j,k) = m4ago_ppo(i,j,k-1) + 1000.0*prho(i,j,k)*grav_acc_const*pddpo(i,j,k) - endif - enddo + if(omask(i,j) > 0.5 .and. pddpo(i,j,k).gt.dp_min) then + m4ago_ppo(i,j,k) = 1e5 * ptiestu(i,j,k)*98060.*1.027e-6 ! pressure in unit Pa, 98060 = onem endif enddo + enddo enddo !$OMP END PARALLEL DO END SUBROUTINE calc_pressure @@ -373,7 +371,7 @@ SUBROUTINE mean_aggregate_sinking_speed(kpie, kpje, kpke, kbnd, pddpo, omask, pt REAL, INTENT(in) :: ppao (1-kbnd:kpie+kbnd,1-kbnd:kpje+kbnd) !< pressure at sea level [Pa]. REAL, INTENT(in) :: prho (kpie,kpje,kpke) !< density [g/cm3] - CALL calc_pressure(kpie, kpje, kpke,kbnd, pddpo, omask, ppao, prho) + CALL calc_pressure(kpie, kpje, kpke,kbnd, pddpo, omask) ! molecular dynamic viscosity CALL dynvis(kpie, kpje, kpke, kbnd, pddpo, omask, ptho, psao, m4ago_ppo) From 83700862023f20971dd85e1b114964379d5aa98b Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Wed, 27 Sep 2023 16:56:33 +0200 Subject: [PATCH 314/366] Make atmospheric NH3 and N2O a namelist parameter --- hamocc/carchm.F90 | 8 ++++---- hamocc/mo_carbch.F90 | 8 ++++---- hamocc/mo_chemcon.F90 | 6 ------ hamocc/mo_param_bgc.F90 | 15 ++++++--------- 4 files changed, 14 insertions(+), 23 deletions(-) diff --git a/hamocc/carchm.F90 b/hamocc/carchm.F90 index 3bd1d098..71386673 100644 --- a/hamocc/carchm.F90 +++ b/hamocc/carchm.F90 @@ -95,8 +95,8 @@ SUBROUTINE CARCHM(kpie,kpje,kpke,kbnd, & ! !********************************************************************** use mo_carbch, only: atm,atmflx,co2fxd,co2fxu,co2star,co3,hi,keqb,kwco2sol,ocetra,omegaa,omegac,pco2d,satn2o,satoxy, & - pco2m,kwco2d,co2sold,co2solm,pn2om - use mo_chemcon, only: al1,al2,al3,al4,an0,an1,an2,an3,an4,an5,an6,atn2o,bl1,bl2,bl3,calcon,ox0,ox1,ox2,ox3,ox4,ox5,ox6, & + pco2m,kwco2d,co2sold,co2solm,pn2om,atm_n2o + use mo_chemcon, only: al1,al2,al3,al4,an0,an1,an2,an3,an4,an5,an6,bl1,bl2,bl3,calcon,ox0,ox1,ox2,ox3,ox4,ox5,ox6, & & oxyco,tzero use mo_control_bgc, only: dtbgc use mo_param1_bgc, only: ialkali,iatmo2,iatmco2,iatmdms,iatmn2,iatmn2o,ian2o,icalc,idicsat,idms,igasnit,ioxygen,iphosph, & @@ -448,10 +448,10 @@ SUBROUTINE CARCHM(kpie,kpje,kpke,kbnd, & atbrf = atm(i,j,iatmbromo) #endif #ifdef extNcycle - atnh3 = atm(i,j,iatmnh3) + atnh3 = atm(i,j,iatmnh3) atn2ov = atm(i,j,iatmn2o) #else - atn2ov = atn2o + atn2ov = atm_n2o #endif ! Ratio P/P_0, where P is the local SLP and P_0 is standard pressure (1 atm). This is diff --git a/hamocc/mo_carbch.F90 b/hamocc/mo_carbch.F90 index aa4e5254..bebdec0a 100644 --- a/hamocc/mo_carbch.F90 +++ b/hamocc/mo_carbch.F90 @@ -100,7 +100,7 @@ MODULE mo_carbch REAL, DIMENSION (:,:,:), ALLOCATABLE :: natOmegaA REAL, DIMENSION (:,:,:), ALLOCATABLE :: natOmegaC #endif - REAL :: atm_co2, atm_o2, atm_n2 + REAL :: atm_co2, atm_o2, atm_n2, atm_n2o REAL :: atm_c13, atm_c14 #ifdef cisonew REAL :: c14_t_half, c14dec @@ -115,7 +115,7 @@ MODULE mo_carbch #endif #ifdef extNcycle REAL, DIMENSION (:,:), ALLOCATABLE :: pnh3 - REAL :: atm_nh3,atm_n2o + REAL :: atm_nh3 #endif CONTAINS @@ -130,7 +130,7 @@ SUBROUTINE ALLOC_MEM_CARBCH(kpie,kpje,kpke) INTEGER, intent(in) :: kpie,kpje,kpke INTEGER :: errstat - + IF (mnproc.eq.1) THEN WRITE(io_stdo_bgc,*)' ' @@ -277,7 +277,7 @@ SUBROUTINE ALLOC_MEM_CARBCH(kpie,kpje,kpke) ALLOCATE (satn2o(kpie,kpje),stat=errstat) if(errstat.ne.0) stop 'not enough memory satn2o' satn2o(:,:) = 0.0 - + IF (mnproc.eq.1) THEN WRITE(io_stdo_bgc,*)'Memory allocation for variable pn2om ...' WRITE(io_stdo_bgc,*)'First dimension : ',kpie diff --git a/hamocc/mo_chemcon.F90 b/hamocc/mo_chemcon.F90 index c356d7a5..d4736257 100644 --- a/hamocc/mo_chemcon.F90 +++ b/hamocc/mo_chemcon.F90 @@ -168,12 +168,6 @@ MODULE mo_chemcon real, parameter :: bl2= 0.031619 real, parameter :: bl3= -0.0048472 - -! ----------------------------------------------------------------- -! Atmospheric mixing ratio of N2O around 1980 300 ppb, here provided in ppt -! - real, parameter :: atn2o=300e3 - #ifdef extNcycle ! Tsilingiris 2008 ! moist air dynamic viscosity parameters diff --git a/hamocc/mo_param_bgc.F90 b/hamocc/mo_param_bgc.F90 index 78f03293..261182b7 100644 --- a/hamocc/mo_param_bgc.F90 +++ b/hamocc/mo_param_bgc.F90 @@ -43,7 +43,7 @@ module mo_param_bgc ! !****************************************************************************** - use mo_carbch, only: atm,atm_co2,atm_n2,atm_o2,dmspar + use mo_carbch, only: atm,atm_co2,atm_n2,atm_n2o,atm_o2,dmspar use mo_biomod, only: atten_c,atten_f,atten_uv,atten_w,bkopal,bkphy,bkopal,bkzoo,bluefix,ctochl,dremn2o,dremopal, & & drempoc,dremsul,dyphy,ecan,epsher,fesoly,fetune,gammap,gammaz,grami,grazra,perc_diron,phytomi, & & pi_alpha,rcalc,rcar, rdn2o1,rdn2o2,rdnit0,rdnit1,rdnit2,relaxfe,remido,riron,rnit,rnoi,ro2ut, & @@ -72,13 +72,11 @@ module mo_param_bgc #endif #ifdef extNcycle use mo_param1_bgc, only: iatmnh3,iatmn2o - use mo_carbch, only: atm_nh3,atm_n2o - use mo_chemcon, only: atn2o !fixed mixing ratio of N2O at 1980, 300ppb = 300e3ppt = 3e-7 mol/mol + use mo_carbch, only: atm_nh3 use mo_extNwatercol,only: extNwatercol_param_init,extNwatercol_param_update,extNwatercol_param_write, & rano3denit,rano2anmx,rano2denit,ran2odenit,rdnra,ranh4nitr,rano2nitr use mo_extNsediment,only: extNsediment_param_init,extNsediment_param_update,extNsediment_param_write, & rano3denit_sed,rano2anmx_sed,rano2denit_sed,ran2odenit_sed,rdnra_sed,ranh4nitr_sed,rano2nitr_sed - #endif implicit none @@ -135,6 +133,7 @@ subroutine ini_param_atm() ! atm_o2 = 196800. atm_n2 = 802000. + atm_n2o = 300e3 !Atmospheric mixing ratio of N2O around 1980 300 ppb,provided in ppt,300ppb = 300e3ppt = 3e-7 mol/mol #ifdef natDIC atm_co2_nat = 284.32 ! CMIP6 pre-industrial reference @@ -155,9 +154,6 @@ subroutine ini_param_atm() #ifdef extNcycle ! Six & Mikolajewicz 2022: less than 1nmol m-3 atm_nh3 = 0. - ! for now initializing the atmosphereic mixing ratio for N2O with fixed value - ! - later to be revereted to namelist parameter - atm_n2o = atn2o #endif end subroutine @@ -433,9 +429,9 @@ subroutine read_bgcnamelist() #ifdef extNcycle & rano3denit,rano2anmx,rano2denit,ran2odenit,rdnra,ranh4nitr,rano2nitr, & & rano3denit_sed,rano2anmx_sed,rano2denit_sed,ran2odenit_sed,rdnra_sed,ranh4nitr_sed,rano2nitr_sed, & - + & atm_nh3, & #endif - & wcal,wopal + & wcal,wopal,atm_n2o open (newunit=iounit, file=bgc_namelist, status='old',action='read') read (unit=iounit, nml=BGCPARAMS) @@ -625,6 +621,7 @@ subroutine write_parambgc() #ifdef extNcycle WRITE(io_stdo_bgc,*) '* atm_nh3 = ',atm_nh3 #endif + WRITE(io_stdo_bgc,*) '* atm_n2o = ',atm_n2o WRITE(io_stdo_bgc,*) '* phytomi = ',phytomi WRITE(io_stdo_bgc,*) '* grami = ',grami WRITE(io_stdo_bgc,*) '* remido = ',remido*dtbinv From f6ca3768973e2ea4d1c93771ba5590d26c10d8f7 Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Thu, 28 Sep 2023 21:23:05 +0200 Subject: [PATCH 315/366] Add switch for bluefix to buildnml --- cime_config/buildnml | 2 ++ cime_config/ocn_in.readme | 1 + 2 files changed, 3 insertions(+) diff --git a/cime_config/buildnml b/cime_config/buildnml index feb6fe0e..c927e9b9 100755 --- a/cime_config/buildnml +++ b/cime_config/buildnml @@ -296,6 +296,7 @@ endif # For the following options, there are currently no switches in Case-XML files. # These options can be activated by expert users via user namelist. set LM4AGO = .false. +set LEUPHOTIC_CYA = .false. set DO_OALK = .false. set BGCOAFX_OALKSCEN = "''" set BGCOAFX_OALKFILE = "''" @@ -1455,6 +1456,7 @@ cat >>! $RUNDIR/ocn_in$inststr << EOF SEDSPIN_YR_E = $SEDSPIN_YR_E SEDSPIN_NCYC = $SEDSPIN_NCYC LM4AGO = $LM4AGO + LEUPHOTIC_CYA = $LEUPHOTIC_CYA INIDIC = $INIDIC INIALK = $INIALK INIPO4 = $INIPO4 diff --git a/cime_config/ocn_in.readme b/cime_config/ocn_in.readme index f35f107b..02794228 100644 --- a/cime_config/ocn_in.readme +++ b/cime_config/ocn_in.readme @@ -374,6 +374,7 @@ ! WITH_DMSPH : Logical switch to activate DMS calculation as function of pH ! PI_PH_FILE : File name (incl. full path) for surface PI pH input data. ! LM4AGO : Switch for M4AGO settling scheme +! LEUPHOTIC_CYA : Switch to perform bluefix (cyanobacteria) only in the euphotic zone ! L_3DVARSEDPOR : Logical switch to enable lon-lat-depth variable sediment porosity (as opposed to default: only depth) ! SEDPORFILE : File name (incl. full path) for sediment porosity ! From 71bf2ecc0842a9085348e628f95431b03ae9e40c Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Wed, 4 Oct 2023 15:23:32 +0200 Subject: [PATCH 316/366] Add switch for N2O and NH3 air-sea gas exchange coupling to avoid log-file printing of message in hamocc4bgm, while the coupling fields are not really read --- cime_config/buildnml | 8 ++++++++ hamocc/hamocc4bcm.F90 | 28 +++++++++++++++------------- hamocc/hamocc_init.F90 | 4 ++-- hamocc/mo_control_bgc.F90 | 1 + 4 files changed, 26 insertions(+), 15 deletions(-) diff --git a/cime_config/buildnml b/cime_config/buildnml index c927e9b9..1f63a651 100755 --- a/cime_config/buildnml +++ b/cime_config/buildnml @@ -20,6 +20,7 @@ set BLOM_TRACER_MODULES = `./xmlquery BLOM_TRACER_MODULES --value` set BLOM_RIVER_NUTRIENTS = `./xmlquery BLOM_RIVER_NUTRIENTS --value` set BLOM_N_DEPOSITION = `./xmlquery BLOM_N_DEPOSITION --value` set ATM_N_DEPOSITION = `./xmlquery HAMOCC_ATMNDEPC --value` +set ATM_N2ONH3_COUPLED = `./xmlquery HAMOCC_N2OC --value` set BLOM_NDEP_SCENARIO = `./xmlquery BLOM_NDEP_SCENARIO --value` set HAMOCC_VSLS = `./xmlquery HAMOCC_VSLS --value` set HAMOCC_CISO = `./xmlquery HAMOCC_CISO --value` @@ -276,6 +277,12 @@ else set DO_NDEP_COUPLED = .false. endif +if ("ATM_N2ONH3_COUPLED" == TRUE) then + set DO_N2ONH3_COUPLED = .true. +else + set DO_N2ONH3_COUPLED = .false. +endif + if ("$HAMOCC_SEDSPINUP" == TRUE) then set DO_SEDSPINUP = .true. set SEDSPIN_YR_S = $HAMOCC_SEDSPINUP_YR_START @@ -1449,6 +1456,7 @@ cat >>! $RUNDIR/ocn_in$inststr << EOF RIVINFILE = $RIVINFILE DO_NDEP = $DO_NDEP DO_NDEP_COUPLED = $DO_NDEP_COUPLED + DO_N2ONH3_COUPLED = $DO_N2ONH3_COUPLED NDEPFILE = $NDEPFILE DO_OALK = $DO_OALK DO_SEDSPINUP = $DO_SEDSPINUP diff --git a/hamocc/hamocc4bcm.F90 b/hamocc/hamocc4bcm.F90 index 7a73fd35..51930541 100644 --- a/hamocc/hamocc4bcm.F90 +++ b/hamocc/hamocc4bcm.F90 @@ -96,7 +96,7 @@ SUBROUTINE HAMOCC4BCM(kpie,kpje,kpke,kbnd,kplyear,kplmon,kplday,kldtday,& use mo_biomod, only: strahl use mo_control_bgc, only: ldtrunbgc,dtbgc,ldtbgc,io_stdo_bgc,dtbgc,ndtdaybgc, & do_sedspinup,sedspin_yr_s,sedspin_yr_e,sedspin_ncyc,& - do_ndep_coupled + do_ndep_coupled,do_n2onh3_coupled use mo_param1_bgc, only: iatmco2,iatmdms,nocetra,nriv,nndep,idepnoy use mo_vgrid, only: set_vgrid use mo_apply_fedep, only: apply_fedep @@ -218,19 +218,21 @@ SUBROUTINE HAMOCC4BCM(kpie,kpje,kpke,kbnd,kplyear,kplmon,kplday,kldtday,& #ifdef extNcycle !$OMP PARALLEL DO PRIVATE(i) - DO j=1,kpje - DO i=1,kpie - IF (patmn2o(i,j).gt.0.) THEN - atm(i,j,iatmn2o)=patmn2o(i,j) - ENDIF - IF (patmnh3(i,j).gt.0.) THEN - atm(i,j,iatmnh3)=patmnh3(i,j) - ENDIF - ENDDO - ENDDO + IF(do_n2onh3_coupled) THEN + DO j=1,kpje + DO i=1,kpie + IF (patmn2o(i,j).gt.0.) THEN + atm(i,j,iatmn2o)=patmn2o(i,j) + ENDIF + IF (patmnh3(i,j).gt.0.) THEN + atm(i,j,iatmnh3)=patmnh3(i,j) + ENDIF + ENDDO + ENDDO !$OMP END PARALLEL DO - if (mnproc.eq.1) write (io_stdo_bgc,*) 'iHAMOCC: getting N2O and NH3 conc. from atm' - + if (mnproc.eq.1) write (io_stdo_bgc,*) 'iHAMOCC: getting N2O and NH3 conc. from atm' + ENDIF + IF(do_ndep_coupled) THEN fatmndep = 365.*86400./mw_nitrogen ndep(:,:,:) = 0. diff --git a/hamocc/hamocc_init.F90 b/hamocc/hamocc_init.F90 index 4dde943c..aadf9889 100644 --- a/hamocc/hamocc_init.F90 +++ b/hamocc/hamocc_init.F90 @@ -47,7 +47,7 @@ subroutine hamocc_init(read_rest,rstfnm_hamocc) & sedspin_yr_s,sedspin_yr_e,sedspin_ncyc, & & dtb,dtbgc,io_stdo_bgc,ldtbgc, & & ldtrunbgc,ndtdaybgc,with_dmsph,l_3Dvarsedpor,lm4ago,& - & do_ndep_coupled,leuphotic_cya + & do_ndep_coupled,leuphotic_cya,do_n2onh3_coupled use mo_param1_bgc, only: ks,init_por2octra_mapping use mo_param_bgc, only: ini_parambgc use mo_carbch, only: alloc_mem_carbch,ocetra,atm,atm_co2 @@ -91,7 +91,7 @@ subroutine hamocc_init(read_rest,rstfnm_hamocc) & inidic,inialk,inipo4,inioxy,inino3,inisil, & & inid13c,inid14c,swaclimfile, & & with_dmsph,pi_ph_file,l_3Dvarsedpor,sedporfile,lm4ago,leuphotic_cya, & - & do_ndep_coupled + & do_ndep_coupled,do_n2onh3_coupled ! ! --- Set io units and some control parameters ! diff --git a/hamocc/mo_control_bgc.F90 b/hamocc/mo_control_bgc.F90 index f5581b04..2f764d8b 100644 --- a/hamocc/mo_control_bgc.F90 +++ b/hamocc/mo_control_bgc.F90 @@ -62,6 +62,7 @@ MODULE mo_control_bgc LOGICAL, save :: l_3Dvarsedpor = .false. ! apply lon-lat-depth variable sediment porosity via input file LOGICAL, save :: do_ndep =.true. ! apply n-deposition LOGICAL, save :: do_ndep_coupled = .false. ! for coupled simulations, use field provided by atmosphere + LOGICAL, save :: do_n2onh3_coupled = .false. ! for coupled simulations, use field provided by atmosphere LOGICAL, save :: do_rivinpt =.true. ! apply riverine input LOGICAL, save :: do_sedspinup=.false. ! apply sediment spin-up LOGICAL, save :: do_oalk =.false. ! apply ocean alkalinization From b2b46fee53caf0489bb357c8892bee2d2868c0b4 Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Thu, 5 Oct 2023 11:20:07 +0200 Subject: [PATCH 317/366] Change default write format for N2O_LYR --- cime_config/buildnml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/cime_config/buildnml b/cime_config/buildnml index 1f63a651..0397f1c7 100755 --- a/cime_config/buildnml +++ b/cime_config/buildnml @@ -687,7 +687,7 @@ set LYR_POC = '0, 0, 2' set LYR_CALC = '0, 0, 2' set LYR_OPAL = '0, 0, 2' set LYR_CO3 = '0, 0, 2' -set LYR_N2O = '0, 0, 0' +set LYR_N2O = '0, 0, 2' set LYR_PH = '0, 0, 2' set LYR_OMEGAC = '0, 0, 2' set LYR_OMEGAA = '0, 0, 2' From 702a98feb45c517b749621c14c9bc9b6e91469d2 Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Mon, 16 Oct 2023 17:48:19 +0200 Subject: [PATCH 318/366] Enable switching on and off N-cycle coupling of N2O and NH3 fluxes in coupled mode Add switches to the log file writing --- hamocc/hamocc4bcm.F90 | 17 +++++++++++------ hamocc/mo_chemcon.F90 | 4 +++- hamocc/mo_param_bgc.F90 | 17 +++++++++++++++-- 3 files changed, 29 insertions(+), 9 deletions(-) diff --git a/hamocc/hamocc4bcm.F90 b/hamocc/hamocc4bcm.F90 index 51930541..c673b0ed 100644 --- a/hamocc/hamocc4bcm.F90 +++ b/hamocc/hamocc4bcm.F90 @@ -114,7 +114,7 @@ SUBROUTINE HAMOCC4BCM(kpie,kpje,kpke,kbnd,kplyear,kplmon,kplday,kldtday,& #endif #ifdef extNcycle use mo_param1_bgc, only: iatmn2o,iatmnh3,idepnhx - use mo_chemcon, only: mw_nitrogen + use mo_chemcon, only: mw_nitrogen,mw_nh3,mw_n2o #endif implicit none @@ -234,12 +234,12 @@ SUBROUTINE HAMOCC4BCM(kpie,kpje,kpke,kbnd,kplyear,kplmon,kplday,kldtday,& ENDIF IF(do_ndep_coupled) THEN - fatmndep = 365.*86400./mw_nitrogen + fatmndep = 365.*86400./mw_nitrogen ndep(:,:,:) = 0. !$OMP PARALLEL DO PRIVATE(i) DO j=1,kpje DO i=1,kpie - ! convert from kgN/m2/s to climatological input file units: kmolN/m2/yr + ! convert from kgN/m2/s to climatological input file units: kmolN/m2/yr IF (patmnoydep(i,j).gt.0.) THEN ndep(i,j,idepnoy) = patmnoydep(i,j)*fatmndep ENDIF @@ -497,13 +497,18 @@ SUBROUTINE HAMOCC4BCM(kpie,kpje,kpke,kbnd,kplyear,kplmon,kplday,kldtday,& !$OMP END PARALLEL DO !-------------------------------------------------------------------- ! Pass nitrous oxide and ammonia fluxes. Convert unit from kmol N2O (NH3)/m2/Delta t to kg/m2/s -! negative values to the atmosphere +! negative values to the atmosphere !$OMP PARALLEL DO PRIVATE(i) DO j=1,kpje DO i=1,kpie #ifdef extNcycle - if(omask(i,j) .gt. 0.5) pflxn2o(i,j)=-44.012880*atmflx(i,j,iatmn2o)/dtbgc ! conversion factor checked against CAM - if(omask(i,j) .gt. 0.5) pflxnh3(i,j)=-17.028940*atmflx(i,j,iatmnh3)/dtbgc ! conversion factor checked against CAM + if (do_n2onh3_coupled) then + if(omask(i,j) .gt. 0.5) pflxn2o(i,j)=-mw_n2o*atmflx(i,j,iatmn2o)/dtbgc ! conversion factor checked against CAM + if(omask(i,j) .gt. 0.5) pflxnh3(i,j)=-mw_nh3*atmflx(i,j,iatmnh3)/dtbgc ! conversion factor checked against CAM + else + if(omask(i,j) .gt. 0.5) pflxn2o(i,j)=0.0 + if(omask(i,j) .gt. 0.5) pflxnh3(i,j)=0.0 + endif #else if(omask(i,j) .gt. 0.5) pflxn2o(i,j)=0.0 if(omask(i,j) .gt. 0.5) pflxnh3(i,j)=0.0 diff --git a/hamocc/mo_chemcon.F90 b/hamocc/mo_chemcon.F90 index d4736257..7071002e 100644 --- a/hamocc/mo_chemcon.F90 +++ b/hamocc/mo_chemcon.F90 @@ -191,7 +191,9 @@ MODULE mo_chemcon real, parameter :: M_nh3 = (1./Ma_air + 1./Mb_nh3)**0.5 / (Va_air**(1./3.)+Vb_nh3**(1./3.))**2. real, parameter :: kappa = 0.4 ! von Karman constant - real, parameter :: mw_nitrogen = 14.00674 ! [g/mol N] nitrogen mol-weight as defined by CAM + real, parameter :: mw_nitrogen = 14.00674 ! [g/mol N] nitrogen mol-weight as defined by CAM + real, parameter :: mw_nh3 = 17.028940 ! [g/mol NH3] ammonia mol-weight as defined by CAM + real, parameter :: mw_n2o = 44.012880 ! [g/mol N2O] nitrous oxide mol-weight as defined by CAM #endif diff --git a/hamocc/mo_param_bgc.F90 b/hamocc/mo_param_bgc.F90 index 261182b7..15866543 100644 --- a/hamocc/mo_param_bgc.F90 +++ b/hamocc/mo_param_bgc.F90 @@ -49,7 +49,8 @@ module mo_param_bgc & pi_alpha,rcalc,rcar, rdn2o1,rdn2o2,rdnit0,rdnit1,rdnit2,relaxfe,remido,riron,rnit,rnoi,ro2ut, & & ropal,spemor,tf0,tf1,tf2,tff,wcal,wdust,wopal,wpoc,zinges,drempoc_anaerob,bkox_drempoc use mo_sedmnt, only: claydens,o2ut,rno3 - use mo_control_bgc, only: io_stdo_bgc,bgc_namelist,lm4ago + use mo_control_bgc, only: io_stdo_bgc,bgc_namelist,lm4ago,l_3Dvarsedpor,do_ndep,do_rivinpt,do_sedspinup,do_oalk,with_dmsph, & + & leuphotic_cya use mo_param1_bgc, only: iatmco2,iatmnco2,iatmo2,iatmn2,iatmc13,iatmc14,iatmbromo use mod_xc, only: mnproc use mo_m4ago, only: init_m4ago_nml_params, init_m4ago_params @@ -71,6 +72,7 @@ module mo_param_bgc use mo_carbch, only: atm_co2_nat #endif #ifdef extNcycle + use mo_control_bgc, only: do_ndep_coupled,do_n2onh3_coupled use mo_param1_bgc, only: iatmnh3,iatmn2o use mo_carbch, only: atm_nh3 use mo_extNwatercol,only: extNwatercol_param_init,extNwatercol_param_update,extNwatercol_param_write, & @@ -596,7 +598,16 @@ subroutine write_parambgc() IF (mnproc.eq.1) THEN WRITE(io_stdo_bgc,*) '****************************************************************' WRITE(io_stdo_bgc,*) '* ' - WRITE(io_stdo_bgc,*) '* Values of MO_PARAM_BGC variables : ' + WRITE(io_stdo_bgc,*) '* Values of MO_PARAM_BGC variables and switches: ' + WRITE(io_stdo_bgc,*) '* do_rivinpt = ',do_rivinpt + WRITE(io_stdo_bgc,*) '* do_sedspinup = ',do_sedspinup + WRITE(io_stdo_bgc,*) '* do_oalk = ',do_oalk + WRITE(io_stdo_bgc,*) '* with_dmsph = ',with_dmsph + WRITE(io_stdo_bgc,*) '* leuphotic_cya= ',leuphotic_cya + WRITE(io_stdo_bgc,*) '* do_ndep = ',do_ndep + WRITE(io_stdo_bgc,*) '* l_3Dvarsedpor= ',l_3Dvarsedpor + WRITE(io_stdo_bgc,*) '* lm4ago = ',lm4ago + WRITE(io_stdo_bgc,*) '*---------------------------------------------------------------' WRITE(io_stdo_bgc,*) '* atm_co2 = ',atm_co2 #ifdef cisonew WRITE(io_stdo_bgc,*) '* atm_c13 = ',atm_c13 @@ -620,6 +631,8 @@ subroutine write_parambgc() WRITE(io_stdo_bgc,*) '* atm_n2 = ',atm_n2 #ifdef extNcycle WRITE(io_stdo_bgc,*) '* atm_nh3 = ',atm_nh3 + WRITE(io_stdo_bgc,*) '* do_ndep_coupled = ',do_ndep_coupled + WRITE(io_stdo_bgc,*) '* do_n2onh3_coupled = ',do_n2onh3_coupled #endif WRITE(io_stdo_bgc,*) '* atm_n2o = ',atm_n2o WRITE(io_stdo_bgc,*) '* phytomi = ',phytomi From 3d76f750cba28f95937b468d806ec584200788af Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Mon, 23 Oct 2023 18:48:50 +0200 Subject: [PATCH 319/366] Introduce preformed silicate tracer --- cime_config/buildnml | 4 ++++ hamocc/accfields.F90 | 8 ++++++-- hamocc/aufr_bgc.F90 | 26 +++++++++++++++++++++++--- hamocc/aufw_bgc.F90 | 7 ++++++- hamocc/beleg_vars.F90 | 4 +++- hamocc/mo_bgcmean.F90 | 10 ++++++++++ hamocc/mo_param1_bgc.F90 | 5 +++-- hamocc/ncout_hamocc.F90 | 16 ++++++++++++++++ hamocc/preftrc.F90 | 3 ++- 9 files changed, 73 insertions(+), 10 deletions(-) diff --git a/cime_config/buildnml b/cime_config/buildnml index 0397f1c7..c6884ea2 100755 --- a/cime_config/buildnml +++ b/cime_config/buildnml @@ -694,6 +694,7 @@ set LYR_OMEGAA = '0, 0, 2' set LYR_PREFO2 = '0, 0, 4' set LYR_O2SAT = '0, 0, 4' set LYR_PREFPO4 = '0, 0, 2' +set LYR_PREFSILICA = '0, 0, 4' set LYR_PREFALK = '0, 0, 2' set LYR_PREFDIC = '0, 0, 2' set LYR_DICSAT = '0, 0, 2' @@ -775,6 +776,7 @@ set LVL_OMEGAA = '0, 2, 2' set LVL_PREFO2 = '0, 4, 4' set LVL_O2SAT = '0, 4, 4' set LVL_PREFPO4 = '0, 2, 2' +set LVL_PREFSILICA = '0, 4, 4' set LVL_PREFALK = '0, 2, 2' set LVL_PREFDIC = '0, 2, 2' set LVL_DICSAT = '0, 2, 2' @@ -1629,6 +1631,7 @@ cat >>! $RUNDIR/ocn_in$inststr << EOF LYR_PREFO2 = $LYR_PREFO2 LYR_O2SAT = $LYR_O2SAT LYR_PREFPO4 = $LYR_PREFPO4 + LYR_PREFSILICA = $LYR_PREFSILICA LYR_PREFALK = $LYR_PREFALK LYR_PREFDIC = $LYR_PREFDIC LYR_DICSAT = $LYR_DICSAT @@ -1710,6 +1713,7 @@ cat >>! $RUNDIR/ocn_in$inststr << EOF LVL_PREFO2 = $LVL_PREFO2 LVL_O2SAT = $LVL_O2SAT LVL_PREFPO4 = $LVL_PREFPO4 + LVL_PREFSILICA = $LVL_PREFSILICA LVL_PREFALK = $LVL_PREFALK LVL_PREFDIC = $LVL_PREFDIC LVL_DICSAT = $LVL_DICSAT diff --git a/hamocc/accfields.F90 b/hamocc/accfields.F90 index 8ab47758..578a67e9 100644 --- a/hamocc/accfields.F90 +++ b/hamocc/accfields.F90 @@ -76,11 +76,12 @@ SUBROUTINE ACCFIELDS(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask) & jlvl_remin_aerob,jlvl_remin_sulf, & & jagg_ws,jdynvis,jagg_stick,jagg_stickf,jagg_dmax,jagg_avdp,jagg_avrhop,jagg_avdC,jagg_df,jagg_b, & & jagg_Vrhof,jagg_Vpor,jlvl_agg_ws,jlvl_dynvis,jlvl_agg_stick,jlvl_agg_stickf,jlvl_agg_dmax, & - & jlvl_agg_avdp,jlvl_agg_avrhop,jlvl_agg_avdC,jlvl_agg_df,jlvl_agg_b,jlvl_agg_Vrhof,jlvl_agg_Vpor + & jlvl_agg_avdp,jlvl_agg_avrhop,jlvl_agg_avdC,jlvl_agg_df,jlvl_agg_b,jlvl_agg_Vrhof,jlvl_agg_Vpor, & + & jprefsilica,jlvlprefsilica use mo_control_bgc, only: io_stdo_bgc use mo_param1_bgc, only: ialkali,ian2o,iano3,iatmco2,iatmdms,iatmn2,iatmn2o,iatmo2,icalc,idet,idms,idicsat,idoc,iiron,iopal,& & ioxygen,iphosph,iphy,iprefalk,iprefdic,iprefpo4,iprefo2,isco212,isilica,izoo, & - & irdin,irdip,irsi,iralk,iriron,irdoc,irdet,issso12,isssc12,issssil,issster + & irdin,irdip,irsi,iralk,iriron,irdoc,irdet,issso12,isssc12,issssil,issster,iprefsilica use mo_m4ago, only: aggregate_diagnostics,kav_dp,kav_rho_p,kav_d_C,kws_agg,kdf_agg,kstickiness_agg,kb_agg, & & kstickiness_frustule,kLmax_agg,kdynvis,kav_rhof_V,kav_por_V #ifdef AGG @@ -377,6 +378,7 @@ SUBROUTINE ACCFIELDS(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask) call acclyr(jo2sat,satoxy,pddpo,1) call acclyr(jprefo2,ocetra(1,1,1,iprefo2),pddpo,1) call acclyr(jprefpo4,ocetra(1,1,1,iprefpo4),pddpo,1) + call acclyr(jprefsilica,ocetra(1,1,1,iprefsilica),pddpo,1) call acclyr(jprefalk,ocetra(1,1,1,iprefalk),pddpo,1) call acclyr(jprefdic,ocetra(1,1,1,iprefdic),pddpo,1) call acclyr(jdicsat,ocetra(1,1,1,idicsat),pddpo,1) @@ -454,6 +456,7 @@ SUBROUTINE ACCFIELDS(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask) & jlvlano3+jlvlalkali+jlvlsilica+jlvldic+jlvldoc+jlvlpoc+jlvlcalc+& & jlvlopal+jlvln2o+jlvlco3+jlvlph+jlvlomegaa+jlvlomegac+jlvlphosy+& & jlvlo2sat+jlvlprefo2+jlvlprefpo4+jlvlprefalk+jlvlprefdic+ & + & jlvlprefsilica+ & & jlvldicsat+jlvlnatdic+jlvlnatalkali+jlvlnatcalc+jlvlnatco3+ & & jlvlnatomegaa+jlvlnatomegac+jlvldic13+jlvldic14+jlvld13c+ & & jlvld14c+jlvlbigd14c+jlvlpoc13+jlvldoc13+jlvlcalc13+jlvlphyto13+& @@ -491,6 +494,7 @@ SUBROUTINE ACCFIELDS(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask) call acclvl(jlvlo2sat,satoxy,k,ind1,ind2,wghts) call acclvl(jlvlprefo2,ocetra(1,1,1,iprefo2),k,ind1,ind2,wghts) call acclvl(jlvlprefpo4,ocetra(1,1,1,iprefpo4),k,ind1,ind2,wghts) + call acclvl(jlvlprefsilica,ocetra(1,1,1,iprefsilica),k,ind1,ind2,wghts) call acclvl(jlvlprefalk,ocetra(1,1,1,iprefalk),k,ind1,ind2,wghts) call acclvl(jlvlprefdic,ocetra(1,1,1,iprefdic),k,ind1,ind2,wghts) call acclvl(jlvldicsat,ocetra(1,1,1,idicsat),k,ind1,ind2,wghts) diff --git a/hamocc/aufr_bgc.F90 b/hamocc/aufr_bgc.F90 index 7e703bc1..b57b4785 100644 --- a/hamocc/aufr_bgc.F90 +++ b/hamocc/aufr_bgc.F90 @@ -106,7 +106,7 @@ SUBROUTINE AUFR_BGC(kpie,kpje,kpke,ntr,ntrbgc,itrbgc,trc, & use mo_carbch, only: co2star,co3,hi,satoxy use mo_control_bgc, only: io_stdo_bgc,ldtbgc use mo_param1_bgc, only: ialkali,ian2o,iano3,icalc,idet,idicsat,idms,idoc,ifdust,igasnit,iiron,iopal,ioxygen,iphosph,iphy,& - & iprefalk,iprefdic,iprefo2,iprefpo4,isco212,isilica,izoo,nocetra + & iprefalk,iprefdic,iprefo2,iprefpo4,isco212,isilica,izoo,nocetra,iprefsilica use mo_vgrid, only: kbo use mo_sedmnt, only: sedhpl use mo_intfcblom, only: sedlay2,powtra2,burial2,atm2 @@ -157,7 +157,7 @@ SUBROUTINE AUFR_BGC(kpie,kpje,kpke,ntr,ntrbgc,itrbgc,trc, & INTEGER :: restday ! day of restart file INTEGER :: restdtoce ! time step number from bgc ocean file INTEGER :: idate(5),i,j,k - logical :: lread_cfc,lread_nat,lread_iso,lread_atm,lread_bro,lread_extn + logical :: lread_cfc,lread_nat,lread_iso,lread_atm,lread_bro,lread_extn,lread_pref #ifdef cisonew REAL :: rco213,rco214,alpha14,beta13,beta14,d14cat #endif @@ -403,6 +403,24 @@ SUBROUTINE AUFR_BGC(kpie,kpje,kpke,ntr,ntrbgc,itrbgc,trc, & ENDIF #endif + + lread_pref=.true. + IF(IOTYPE==0) THEN + if(mnproc==1) ncstat=nf90_inq_varid(ncid,'prefsilica',ncvarid) + call xcbcst(ncstat) + if(ncstat.ne.nf90_noerr) lread_pref=.false. + ELSE IF(IOTYPE==1) THEN +#ifdef PNETCDF + ncstat=nfmpi_inq_varid(ncid,'prefsilica',ncvarid) + if(ncstat.ne.nf_noerr) lread_pref=.false. +#endif + ENDIF + IF(mnproc==1 .and. .not. lread_pref) THEN + WRITE(io_stdo_bgc,*) ' ' + WRITE(io_stdo_bgc,*) 'AUFR_BGC info: preformed silica not in restart file ' + WRITE(io_stdo_bgc,*) 'Initialising preformed tracer from scratch' + ENDIF + ! ! Read restart data : ocean aquateous tracer ! @@ -428,7 +446,9 @@ SUBROUTINE AUFR_BGC(kpie,kpje,kpke,ntr,ntrbgc,itrbgc,trc, & CALL read_netcdf_var(ncid,'prefalk',locetra(1,1,1,iprefalk),2*kpke,0,iotype) CALL read_netcdf_var(ncid,'prefdic',locetra(1,1,1,iprefdic),2*kpke,0,iotype) CALL read_netcdf_var(ncid,'dicsat',locetra(1,1,1,idicsat),2*kpke,0,iotype) - + IF(lread_pref) THEN + CALL read_netcdf_var(ncid,'prefsilica',locetra(1,1,1,iprefsilica),2*kpke,0,iotype) + ENDIF #ifdef cisonew IF(lread_iso) THEN CALL read_netcdf_var(ncid,'sco213',locetra(1,1,1,isco213),2*kpke,0,iotype) diff --git a/hamocc/aufw_bgc.F90 b/hamocc/aufw_bgc.F90 index d0249966..f606b268 100644 --- a/hamocc/aufw_bgc.F90 +++ b/hamocc/aufw_bgc.F90 @@ -101,7 +101,7 @@ SUBROUTINE AUFW_BGC(kpie,kpje,kpke,ntr,ntrbgc,itrbgc,trc, & use mo_carbch, only: co2star,co3, hi,satoxy use mo_control_bgc, only: io_stdo_bgc,ldtbgc,rmasko use mo_param1_bgc, only: ialkali, ian2o,iano3,icalc,idet,idicsat,idms,idoc,ifdust,igasnit,iiron,iopal,ioxygen,iphosph,iphy, & - & iprefalk,iprefdic,iprefo2,iprefpo4,isco212,isilica,izoo,ks,nocetra + & iprefalk,iprefdic,iprefo2,iprefpo4,isco212,isilica,izoo,ks,nocetra,iprefsilica use mo_sedmnt, only: sedhpl use mo_intfcblom, only: sedlay2,powtra2,burial2,atm2 use mod_xc, only: nbdy,itdm,jtdm,mnproc,iqr,jqr,xchalt @@ -484,6 +484,10 @@ SUBROUTINE AUFW_BGC(kpie,kpje,kpke,ntr,ntrbgc,itrbgc,trc, & CALL NETCDF_DEF_VARDB(ncid,7,'prefpo4',3,ncdimst,ncvarid, & & 6,'mol/kg',19,'Preformed phosphate', & rmissing,28,io_stdo_bgc) + + CALL NETCDF_DEF_VARDB(ncid,10,'prefsilica',3,ncdimst,ncvarid, & + & 6,'mol/kg',16,'Preformed silica', & + rmissing,28,io_stdo_bgc) CALL NETCDF_DEF_VARDB(ncid,7,'prefalk',3,ncdimst,ncvarid, & & 6,'mol/kg',20,'Preformed alkalinity', & @@ -866,6 +870,7 @@ SUBROUTINE AUFW_BGC(kpie,kpje,kpke,ntr,ntrbgc,itrbgc,trc, & CALL write_netcdf_var(ncid,'iron',locetra(1,1,1,iiron),2*kpke,0) CALL write_netcdf_var(ncid,'prefo2',locetra(1,1,1,iprefo2),2*kpke,0) CALL write_netcdf_var(ncid,'prefpo4',locetra(1,1,1,iprefpo4),2*kpke,0) + CALL write_netcdf_var(ncid,'prefsilica',locetra(1,1,1,iprefsilica),2*kpke,0) CALL write_netcdf_var(ncid,'prefalk',locetra(1,1,1,iprefalk),2*kpke,0) CALL write_netcdf_var(ncid,'prefdic',locetra(1,1,1,iprefdic),2*kpke,0) CALL write_netcdf_var(ncid,'dicsat',locetra(1,1,1,idicsat),2*kpke,0) diff --git a/hamocc/beleg_vars.F90 b/hamocc/beleg_vars.F90 index ccff69de..96ca7406 100644 --- a/hamocc/beleg_vars.F90 +++ b/hamocc/beleg_vars.F90 @@ -56,7 +56,7 @@ SUBROUTINE BELEG_VARS(kpaufr,kpie,kpje,kpke,kbnd,pddpo,prho,omask, & use mo_biomod, only: fesoly use mo_control_bgc, only: rmasks use mo_param1_bgc, only: ialkali,ian2o,iano3,icalc,idet,idicsat,idms,idoc,ifdust,igasnit,iiron,iopal,ioxygen,iphosph,iphy, & - & iprefalk,iprefdic,iprefo2,iprefpo4,isco212,isilica,izoo + & iprefalk,iprefdic,iprefo2,iprefpo4,isco212,isilica,izoo,iprefsilica use mo_vgrid, only: kmle,kbo #ifdef AGG @@ -175,6 +175,7 @@ SUBROUTINE BELEG_VARS(kpaufr,kpie,kpje,kpke,kbnd,pddpo,prho,omask, & ocetra(i,j,k,iiron) =fesoly ocetra(i,j,k,iprefo2)=0. ocetra(i,j,k,iprefpo4)=0. + ocetra(i,j,k,iprefsilica)=0. ocetra(i,j,k,iprefalk)=0. ocetra(i,j,k,iprefdic)=0. ocetra(i,j,k,idicsat)=1.e-8 @@ -233,6 +234,7 @@ SUBROUTINE BELEG_VARS(kpaufr,kpie,kpje,kpke,kbnd,pddpo,prho,omask, & IF(omask(i,j) .GT. 0.5) THEN ocetra(i,j,1:kmle(i,j),iprefo2) = ocetra(i,j,1:kmle(i,j),ioxygen) ocetra(i,j,1:kmle(i,j),iprefpo4) = ocetra(i,j,1:kmle(i,j),iphosph) + ocetra(i,j,1:kmle(i,j),iprefsilica)= ocetra(i,j,1:kmle(i,j),isilica) ocetra(i,j,1:kmle(i,j),iprefalk) = ocetra(i,j,1:kmle(i,j),ialkali) ocetra(i,j,1:kmle(i,j),iprefdic) = ocetra(i,j,1:kmle(i,j),isco212) ENDIF diff --git a/hamocc/mo_bgcmean.F90 b/hamocc/mo_bgcmean.F90 index addd4519..4446bc9d 100644 --- a/hamocc/mo_bgcmean.F90 +++ b/hamocc/mo_bgcmean.F90 @@ -121,6 +121,7 @@ MODULE mo_bgcmean & LYR_EPS =0 ,LYR_ASIZE =0 ,LYR_N2O =0 , & & LYR_PREFO2 =0 ,LYR_O2SAT =0 ,LYR_PREFPO4 =0 , & & LYR_PREFALK =0 ,LYR_PREFDIC =0 ,LYR_DICSAT =0 , & + & LYR_PREFSILICA=0 , & & LYR_CFC11 =0 ,LYR_CFC12 =0 ,LYR_SF6 =0 , & & LYR_NATDIC =0 ,LYR_NATALKALI =0 ,LYR_NATCALC =0 , & & LYR_NATPH =0 ,LYR_NATOMEGAA =0 ,LYR_NATOMEGAC =0 , & @@ -153,6 +154,7 @@ MODULE mo_bgcmean & LVL_ASIZE =0 ,LVL_N2O =0 ,LVL_PREFO2 =0 , & & LVL_O2SAT =0 ,LVL_PREFPO4 =0 ,LVL_PREFALK =0 , & & LVL_PREFDIC =0 ,LVL_DICSAT =0 , & + & LVL_PREFSILICA=0 , & & LVL_CFC11 =0 ,LVL_CFC12 =0 ,LVL_SF6 =0 , & & LVL_NATDIC =0 ,LVL_NATALKALI =0 ,LVL_NATCALC =0 , & & LVL_NATPH =0 ,LVL_NATOMEGAA =0 ,LVL_NATOMEGAC =0 , & @@ -237,6 +239,7 @@ MODULE mo_bgcmean & LYR_EPS ,LYR_ASIZE ,LYR_N2O , & & LYR_PREFO2 ,LYR_O2SAT ,LYR_PREFPO4 , & & LYR_PREFALK ,LYR_PREFDIC ,LYR_DICSAT , & + & LYR_PREFSILICA , & & LYR_CFC11 ,LYR_CFC12 ,LYR_SF6 , & & LYR_NATDIC ,LYR_NATALKALI ,LYR_NATCALC , & & LYR_NATPH ,LYR_NATOMEGAA ,LYR_NATOMEGAC , & @@ -266,6 +269,7 @@ MODULE mo_bgcmean & LVL_ASIZE ,LVL_N2O ,LVL_PREFO2 , & & LVL_O2SAT ,LVL_PREFPO4 ,LVL_PREFALK , & & LVL_PREFDIC ,LVL_DICSAT , & + & LVL_PREFSILICA , & & LVL_CFC11 ,LVL_CFC12 ,LVL_SF6 , & & LVL_NATDIC ,LVL_NATALKALI ,LVL_NATCALC , & & LVL_NATPH ,LVL_NATOMEGAA ,LVL_NATOMEGAC , & @@ -471,6 +475,7 @@ MODULE mo_bgcmean & jprefo2 = 0 , & & jo2sat = 0 , & & jprefpo4 = 0 , & + & jprefsilica= 0 , & & jprefalk = 0 , & & jprefdic = 0 , & & jdicsat = 0 , & @@ -499,6 +504,7 @@ MODULE mo_bgcmean & jlvlprefo2 = 0 , & & jlvlo2sat = 0 , & & jlvlprefpo4= 0 , & + & jlvlprefsilica= 0 , & & jlvlprefalk= 0 , & & jlvlprefdic= 0 , & & jlvldicsat = 0 , & @@ -1014,6 +1020,8 @@ SUBROUTINE ALLOC_MEM_BGCMEAN(kpie,kpje,kpke) jo2sat(n)=i_bsc_m3d*min(1,LYR_O2SAT(n)) IF (LYR_PREFPO4(n).GT.0) i_bsc_m3d=i_bsc_m3d+1 jprefpo4(n)=i_bsc_m3d*min(1,LYR_PREFPO4(n)) + IF (LYR_PREFSILICA(n).GT.0) i_bsc_m3d=i_bsc_m3d+1 + jprefsilica(n)=i_bsc_m3d*min(1,LYR_PREFSILICA(n)) IF (LYR_PREFALK(n).GT.0) i_bsc_m3d=i_bsc_m3d+1 jprefalk(n)=i_bsc_m3d*min(1,LYR_PREFALK(n)) IF (LYR_PREFDIC(n).GT.0) i_bsc_m3d=i_bsc_m3d+1 @@ -1191,6 +1199,8 @@ SUBROUTINE ALLOC_MEM_BGCMEAN(kpie,kpje,kpke) jlvlo2sat(n)=ilvl_bsc_m3d*min(1,LVL_O2SAT(n)) IF (LVL_PREFPO4(n).GT.0) ilvl_bsc_m3d=ilvl_bsc_m3d+1 jlvlprefpo4(n)=ilvl_bsc_m3d*min(1,LVL_PREFPO4(n)) + IF (LVL_PREFSILICA(n).GT.0) ilvl_bsc_m3d=ilvl_bsc_m3d+1 + jlvlprefsilica(n)=ilvl_bsc_m3d*min(1,LVL_PREFSILICA(n)) IF (LVL_PREFALK(n).GT.0) ilvl_bsc_m3d=ilvl_bsc_m3d+1 jlvlprefalk(n)=ilvl_bsc_m3d*min(1,LVL_PREFALK(n)) IF (LVL_PREFDIC(n).GT.0) ilvl_bsc_m3d=ilvl_bsc_m3d+1 diff --git a/hamocc/mo_param1_bgc.F90 b/hamocc/mo_param1_bgc.F90 index 3d833e89..1148df54 100644 --- a/hamocc/mo_param1_bgc.F90 +++ b/hamocc/mo_param1_bgc.F90 @@ -45,7 +45,7 @@ MODULE mo_param1_bgc REAL, PARAMETER :: safediv = 1.0e-25 ! added to the denominator of isotopic ratios (avoid div. by zero) ! Tracer indices - INTEGER, PARAMETER :: i_base=22, & + INTEGER, PARAMETER :: i_base=23, & & isco212 =1, & & ialkali =2, & & iphosph =3, & @@ -67,7 +67,8 @@ MODULE mo_param1_bgc & iprefpo4 =19, & & iprefalk =20, & & iprefdic =21, & - & idicsat =22 + & idicsat =22, & + & iprefsilica =23 #ifdef cisonew INTEGER, PARAMETER :: i_iso=12, & & isco213 = i_base+1, & diff --git a/hamocc/ncout_hamocc.F90 b/hamocc/ncout_hamocc.F90 index ecb35f34..acd7dcbb 100644 --- a/hamocc/ncout_hamocc.F90 +++ b/hamocc/ncout_hamocc.F90 @@ -76,12 +76,14 @@ subroutine ncwrt_bgc(iogrp) & jlvlphosy,jlvlphyto,jlvlphyto13,jlvlpoc, & & jlvlpoc13,jlvlprefalk,jlvlprefdic, & & jlvlprefo2,jlvlprefpo4,jlvlsf6,jlvlsilica, & + & jlvlprefsilica, & & jlvlwnos,jlvlwphy,jn2o,jsrfpn2om, & & jn2ofx,jndepnoyfx,jniflux,jnos,joalkfx,jo2sat, & & jomegaa,jomegac,jopal,joxflux,joxygen,jpco2, & & jpco2m,jkwco2khm,jco2kh,jco2khm, & & jph,jphosph,jphosy,jphyto,jpoc,jprefalk, & & jprefdic,jprefo2,jprefpo4,jsilica, & + & jprefsilica, & & jsrfalkali,jsrfano3,jsrfdic,jsrfiron, & & jsrfoxygen,jsrfphosph,jsrfphyto,jsrfsilica,jsrfph, & & jwnos,jwphy, & @@ -91,6 +93,7 @@ subroutine ncwrt_bgc(iogrp) & lyr_opal,lyr_iron,lyr_phosy,lyr_co3,lyr_ph, & & lyr_omegaa,lyr_omegac,lyr_n2o,lyr_prefo2, & & lyr_o2sat,lyr_prefpo4,lyr_prefalk, & + & lyr_prefsilica, & & lyr_prefdic,lyr_dicsat, & & lvl_dic,lvl_alkali, & & lvl_phosph,lvl_oxygen,lvl_ano3,lvl_silica, & @@ -99,6 +102,7 @@ subroutine ncwrt_bgc(iogrp) & lvl_co3,lvl_ph,lvl_omegaa,lvl_omegac, & & lvl_n2o,lvl_prefo2,lvl_o2sat,lvl_prefpo4, & & lvl_prefalk,lvl_prefdic,lvl_dicsat, & + & lvl_prefsilica, & & lvl_o2sat,srf_n2ofx,srf_pn2om,srf_atmco2,srf_kwco2, & & srf_kwco2khm,srf_co2kh,srf_co2khm,srf_pco2m, & & srf_pco2,srf_dmsflux,srf_co2fxd, & @@ -327,6 +331,7 @@ subroutine ncwrt_bgc(iogrp) call finlyr(jprefo2(iogrp),jdp(iogrp)) call finlyr(jo2sat(iogrp),jdp(iogrp)) call finlyr(jprefpo4(iogrp),jdp(iogrp)) + call finlyr(jprefsilica(iogrp),jdp(iogrp)) call finlyr(jprefalk(iogrp),jdp(iogrp)) call finlyr(jprefdic(iogrp),jdp(iogrp)) call finlyr(jdicsat(iogrp),jdp(iogrp)) @@ -439,6 +444,7 @@ subroutine ncwrt_bgc(iogrp) call msklvl(jlvlprefo2(iogrp),depths) call msklvl(jlvlo2sat(iogrp),depths) call msklvl(jlvlprefpo4(iogrp),depths) + call msklvl(jlvlprefsilica(iogrp),depths) call msklvl(jlvlprefalk(iogrp),depths) call msklvl(jlvlprefdic(iogrp),depths) call msklvl(jlvldicsat(iogrp),depths) @@ -660,6 +666,7 @@ subroutine ncwrt_bgc(iogrp) call wrtlyr(jprefo2(iogrp), LYR_PREFO2(iogrp), 1e3, 0.,cmpflg,'p_o2') call wrtlyr(jo2sat(iogrp), LYR_O2SAT(iogrp), 1e3, 0.,cmpflg,'satoxy') call wrtlyr(jprefpo4(iogrp), LYR_PREFPO4(iogrp), 1e3, 0.,cmpflg,'p_po4') + call wrtlyr(jprefsilica(iogrp), LYR_PREFSILICA(iogrp), 1e3, 0.,cmpflg,'p_silica') call wrtlyr(jprefalk(iogrp), LYR_PREFALK(iogrp), 1e3, 0.,cmpflg,'p_talk') call wrtlyr(jprefdic(iogrp), LYR_PREFDIC(iogrp), 1e3, 0.,cmpflg,'p_dic') call wrtlyr(jdicsat(iogrp), LYR_DICSAT(iogrp), 1e3, 0.,cmpflg,'sat_dic') @@ -755,6 +762,7 @@ subroutine ncwrt_bgc(iogrp) call wrtlvl(jlvlprefo2(iogrp), LVL_PREFO2(iogrp), rnacc*1e3, 0.,cmpflg,'p_o2lvl') call wrtlvl(jlvlo2sat(iogrp), LVL_O2SAT(iogrp), rnacc*1e3, 0.,cmpflg,'satoxylvl') call wrtlvl(jlvlprefpo4(iogrp), LVL_PREFPO4(iogrp), rnacc*1e3, 0.,cmpflg,'p_po4lvl') + call wrtlvl(jlvlprefsilica(iogrp),LVL_PREFSILICA(iogrp), rnacc*1e3, 0.,cmpflg,'p_silicalvl') call wrtlvl(jlvlprefalk(iogrp), LVL_PREFALK(iogrp), rnacc*1e3, 0.,cmpflg,'p_talklvl') call wrtlvl(jlvlprefdic(iogrp), LVL_PREFDIC(iogrp), rnacc*1e3, 0.,cmpflg,'p_diclvl') call wrtlvl(jlvldicsat(iogrp), LVL_DICSAT(iogrp), rnacc*1e3, 0.,cmpflg,'sat_diclvl') @@ -1008,6 +1016,7 @@ subroutine ncwrt_bgc(iogrp) call inilyr(jprefo2(iogrp),0.) call inilyr(jo2sat(iogrp),0.) call inilyr(jprefpo4(iogrp),0.) + call inilyr(jprefsilica(iogrp),0.) call inilyr(jprefalk(iogrp),0.) call inilyr(jprefdic(iogrp),0.) call inilyr(jdicsat(iogrp),0.) @@ -1102,6 +1111,7 @@ subroutine ncwrt_bgc(iogrp) call inilvl(jlvlprefo2(iogrp),0.) call inilvl(jlvlo2sat(iogrp),0.) call inilvl(jlvlprefpo4(iogrp),0.) + call inilvl(jlvlprefsilica(iogrp),0.) call inilvl(jlvlprefalk(iogrp),0.) call inilvl(jlvlprefdic(iogrp),0.) call inilvl(jlvldicsat(iogrp),0.) @@ -1238,11 +1248,13 @@ subroutine hamoccvardef(iogrp,timeunits,calendar,cmpflg) & lyr_phyto,lyr_grazer,lyr_poc,lyr_calc,lyr_opal,lyr_iron, & & lyr_phosy,lyr_co3,lyr_ph,lyr_omegaa,lyr_omegac,lyr_n2o, & & lyr_prefo2,lyr_o2sat,lyr_prefpo4,lyr_prefalk,lyr_prefdic, & + & lyr_prefsilica, & & lyr_dicsat,lvl_dic,lvl_alkali,lvl_phosph,lvl_oxygen,lvl_ano3, & & lvl_silica,lvl_doc,lvl_phyto,lvl_grazer,lvl_poc,lvl_calc, & & lvl_opal,lvl_iron,lvl_phosy,lvl_co3,lvl_ph,lvl_omegaa, & & lvl_omegac,lvl_n2o,lvl_prefo2,lvl_o2sat,lvl_prefpo4, & & lvl_prefalk,lvl_prefdic,lvl_dicsat, & + & lvl_prefsilica, & & lyr_agg_ws,lyr_dynvis,lyr_agg_stick, & & lyr_agg_stickf,lyr_agg_dmax,lyr_agg_avdp, & & lyr_agg_avrhop,lyr_agg_avdC,lyr_agg_df, & @@ -1628,6 +1640,8 @@ subroutine hamoccvardef(iogrp,timeunits,calendar,cmpflg) & 'satoxy','Saturated oxygen',' ','mol O2 m-3',1) call ncdefvar3d(LYR_PREFPO4(iogrp),cmpflg,'p', & & 'p_po4','Preformed phosphorus',' ','mol P m-3',1) + call ncdefvar3d(LYR_PREFSILICA(iogrp),cmpflg,'p', & + & 'p_silica','Preformed silica',' ','mol N m-3',1) call ncdefvar3d(LYR_PREFALK(iogrp),cmpflg,'p', & & 'p_talk','Preformed alkalinity',' ','eq m-3',1) call ncdefvar3d(LYR_PREFDIC(iogrp),cmpflg,'p', & @@ -1806,6 +1820,8 @@ subroutine hamoccvardef(iogrp,timeunits,calendar,cmpflg) & 'satoxylvl','Saturated oxygen',' ','mol O2 m-3',2) call ncdefvar3d(LVL_PREFPO4(iogrp),cmpflg,'p', & & 'p_po4lvl','Preformed phosphorus',' ','mol P m-3',2) + call ncdefvar3d(LVL_PREFSILICA(iogrp),cmpflg,'p', & + & 'p_silicalvl','Preformed silica',' ','mol N m-3',2) call ncdefvar3d(LVL_PREFALK(iogrp),cmpflg,'p', & & 'p_talklvl','Preformed alkalinity',' ','eq m-3',2) call ncdefvar3d(LVL_PREFDIC(iogrp),cmpflg,'p', & diff --git a/hamocc/preftrc.F90 b/hamocc/preftrc.F90 index a33280d1..89eab1a0 100644 --- a/hamocc/preftrc.F90 +++ b/hamocc/preftrc.F90 @@ -44,7 +44,7 @@ SUBROUTINE PREFTRC(kpie,kpje,omask) !************************************************************************** use mo_carbch, only: ocetra - use mo_param1_bgc, only: ialkali,ioxygen,iphosph,iprefalk,iprefdic,iprefo2,iprefpo4,isco212 + use mo_param1_bgc, only: ialkali,ioxygen,iphosph,isilica,iprefalk,iprefdic,iprefo2,iprefpo4,isco212,iprefsilica use mo_vgrid, only: kmle implicit none @@ -59,6 +59,7 @@ SUBROUTINE PREFTRC(kpie,kpje,omask) if (omask(i,j) .gt. 0.5 ) then ocetra(i,j,1:kmle(i,j),iprefo2) = ocetra(i,j,1:kmle(i,j),ioxygen) ocetra(i,j,1:kmle(i,j),iprefpo4) = ocetra(i,j,1:kmle(i,j),iphosph) + ocetra(i,j,1:kmle(i,j),iprefsilica)= ocetra(i,j,1:kmle(i,j),isilica) ocetra(i,j,1:kmle(i,j),iprefalk) = ocetra(i,j,1:kmle(i,j),ialkali) ocetra(i,j,1:kmle(i,j),iprefdic) = ocetra(i,j,1:kmle(i,j),isco212) endif From 1fce304bd0602249af8915678ad18aebc1ed298d Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Mon, 23 Oct 2023 18:51:48 +0200 Subject: [PATCH 320/366] Enable or disable writing of M4AGO output via M4AGO switch --- hamocc/accfields.F90 | 58 ++++---- hamocc/ncout_hamocc.F90 | 288 +++++++++++++++++++++------------------- 2 files changed, 180 insertions(+), 166 deletions(-) diff --git a/hamocc/accfields.F90 b/hamocc/accfields.F90 index 578a67e9..01561cde 100644 --- a/hamocc/accfields.F90 +++ b/hamocc/accfields.F90 @@ -78,7 +78,7 @@ SUBROUTINE ACCFIELDS(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask) & jagg_Vrhof,jagg_Vpor,jlvl_agg_ws,jlvl_dynvis,jlvl_agg_stick,jlvl_agg_stickf,jlvl_agg_dmax, & & jlvl_agg_avdp,jlvl_agg_avrhop,jlvl_agg_avdC,jlvl_agg_df,jlvl_agg_b,jlvl_agg_Vrhof,jlvl_agg_Vpor, & & jprefsilica,jlvlprefsilica - use mo_control_bgc, only: io_stdo_bgc + use mo_control_bgc, only: io_stdo_bgc,lm4ago use mo_param1_bgc, only: ialkali,ian2o,iano3,iatmco2,iatmdms,iatmn2,iatmn2o,iatmo2,icalc,idet,idms,idicsat,idoc,iiron,iopal,& & ioxygen,iphosph,iphy,iprefalk,iprefdic,iprefpo4,iprefo2,isco212,isilica,izoo, & & irdin,irdip,irsi,iralk,iriron,irdoc,irdet,issso12,isssc12,issssil,issster,iprefsilica @@ -437,19 +437,21 @@ SUBROUTINE ACCFIELDS(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask) call acclyr(jremin_aerob,remin_aerob,pddpo,1) call acclyr(jremin_sulf,remin_sulf,pddpo,1) #endif - ! M4AGO - call acclyr(jagg_ws,aggregate_diagnostics(1,1,1,kws_agg),pddpo,1) - call acclyr(jdynvis,aggregate_diagnostics(1,1,1,kdynvis),pddpo,1) - call acclyr(jagg_stick,aggregate_diagnostics(1,1,1,kstickiness_agg),pddpo,1) - call acclyr(jagg_stickf,aggregate_diagnostics(1,1,1,kstickiness_frustule),pddpo,1) - call acclyr(jagg_dmax,aggregate_diagnostics(1,1,1,kLmax_agg),pddpo,1) - call acclyr(jagg_avdp,aggregate_diagnostics(1,1,1,kav_dp),pddpo,1) - call acclyr(jagg_avrhop,aggregate_diagnostics(1,1,1,kav_rho_p),pddpo,1) - call acclyr(jagg_avdC,aggregate_diagnostics(1,1,1,kav_d_C),pddpo,1) - call acclyr(jagg_df,aggregate_diagnostics(1,1,1,kdf_agg),pddpo,1) - call acclyr(jagg_b,aggregate_diagnostics(1,1,1,kb_agg),pddpo,1) - call acclyr(jagg_Vrhof,aggregate_diagnostics(1,1,1,kav_rhof_V),pddpo,1) - call acclyr(jagg_Vpor,aggregate_diagnostics(1,1,1,kav_por_V),pddpo,1) + if (lm4ago) then + ! M4AGO + call acclyr(jagg_ws,aggregate_diagnostics(1,1,1,kws_agg),pddpo,1) + call acclyr(jdynvis,aggregate_diagnostics(1,1,1,kdynvis),pddpo,1) + call acclyr(jagg_stick,aggregate_diagnostics(1,1,1,kstickiness_agg),pddpo,1) + call acclyr(jagg_stickf,aggregate_diagnostics(1,1,1,kstickiness_frustule),pddpo,1) + call acclyr(jagg_dmax,aggregate_diagnostics(1,1,1,kLmax_agg),pddpo,1) + call acclyr(jagg_avdp,aggregate_diagnostics(1,1,1,kav_dp),pddpo,1) + call acclyr(jagg_avrhop,aggregate_diagnostics(1,1,1,kav_rho_p),pddpo,1) + call acclyr(jagg_avdC,aggregate_diagnostics(1,1,1,kav_d_C),pddpo,1) + call acclyr(jagg_df,aggregate_diagnostics(1,1,1,kdf_agg),pddpo,1) + call acclyr(jagg_b,aggregate_diagnostics(1,1,1,kb_agg),pddpo,1) + call acclyr(jagg_Vrhof,aggregate_diagnostics(1,1,1,kav_rhof_V),pddpo,1) + call acclyr(jagg_Vpor,aggregate_diagnostics(1,1,1,kav_por_V),pddpo,1) + endif ! Accumulate level diagnostics IF (SUM(jlvlphyto+jlvlgrazer+jlvlphosph+jlvloxygen+jlvliron+ & @@ -554,19 +556,21 @@ SUBROUTINE ACCFIELDS(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask) call acclvl(jlvl_remin_aerob,remin_aerob,k,ind1,ind2,wghts) call acclvl(jlvl_remin_sulf,remin_sulf,k,ind1,ind2,wghts) #endif - !M4AGO - call acclvl(jlvl_agg_ws,aggregate_diagnostics(1,1,1,kws_agg),k,ind1,ind2,wghts) - call acclvl(jlvl_dynvis,aggregate_diagnostics(1,1,1,kdynvis),k,ind1,ind2,wghts) - call acclvl(jlvl_agg_stick,aggregate_diagnostics(1,1,1,kstickiness_agg),k,ind1,ind2,wghts) - call acclvl(jlvl_agg_stickf,aggregate_diagnostics(1,1,1,kstickiness_frustule),k,ind1,ind2,wghts) - call acclvl(jlvl_agg_dmax,aggregate_diagnostics(1,1,1,kLmax_agg),k,ind1,ind2,wghts) - call acclvl(jlvl_agg_avdp,aggregate_diagnostics(1,1,1,kav_dp),k,ind1,ind2,wghts) - call acclvl(jlvl_agg_avrhop,aggregate_diagnostics(1,1,1,kav_rho_p),k,ind1,ind2,wghts) - call acclvl(jlvl_agg_avdC,aggregate_diagnostics(1,1,1,kav_d_C),k,ind1,ind2,wghts) - call acclvl(jlvl_agg_df,aggregate_diagnostics(1,1,1,kdf_agg),k,ind1,ind2,wghts) - call acclvl(jlvl_agg_b,aggregate_diagnostics(1,1,1,kb_agg),k,ind1,ind2,wghts) - call acclvl(jlvl_agg_Vrhof,aggregate_diagnostics(1,1,1,kav_rhof_V),k,ind1,ind2,wghts) - call acclvl(jlvl_agg_Vpor,aggregate_diagnostics(1,1,1,kav_por_V),k,ind1,ind2,wghts) + if (lm4ago) then + !M4AGO + call acclvl(jlvl_agg_ws,aggregate_diagnostics(1,1,1,kws_agg),k,ind1,ind2,wghts) + call acclvl(jlvl_dynvis,aggregate_diagnostics(1,1,1,kdynvis),k,ind1,ind2,wghts) + call acclvl(jlvl_agg_stick,aggregate_diagnostics(1,1,1,kstickiness_agg),k,ind1,ind2,wghts) + call acclvl(jlvl_agg_stickf,aggregate_diagnostics(1,1,1,kstickiness_frustule),k,ind1,ind2,wghts) + call acclvl(jlvl_agg_dmax,aggregate_diagnostics(1,1,1,kLmax_agg),k,ind1,ind2,wghts) + call acclvl(jlvl_agg_avdp,aggregate_diagnostics(1,1,1,kav_dp),k,ind1,ind2,wghts) + call acclvl(jlvl_agg_avrhop,aggregate_diagnostics(1,1,1,kav_rho_p),k,ind1,ind2,wghts) + call acclvl(jlvl_agg_avdC,aggregate_diagnostics(1,1,1,kav_d_C),k,ind1,ind2,wghts) + call acclvl(jlvl_agg_df,aggregate_diagnostics(1,1,1,kdf_agg),k,ind1,ind2,wghts) + call acclvl(jlvl_agg_b,aggregate_diagnostics(1,1,1,kb_agg),k,ind1,ind2,wghts) + call acclvl(jlvl_agg_Vrhof,aggregate_diagnostics(1,1,1,kav_rhof_V),k,ind1,ind2,wghts) + call acclvl(jlvl_agg_Vpor,aggregate_diagnostics(1,1,1,kav_por_V),k,ind1,ind2,wghts) + endif ENDDO ENDIF diff --git a/hamocc/ncout_hamocc.F90 b/hamocc/ncout_hamocc.F90 index acd7dcbb..988d7d1e 100644 --- a/hamocc/ncout_hamocc.F90 +++ b/hamocc/ncout_hamocc.F90 @@ -29,7 +29,7 @@ subroutine ncwrt_bgc(iogrp) use mod_grid, only: depths use mod_dia, only: diafnm,sigmar1,iotype,ddm,depthslev, & & depthslev_bnds - use mo_control_bgc, only: dtbgc + use mo_control_bgc, only: dtbgc,lm4ago use mo_vgrid, only: k0100,k0500,k1000,k2000,k4000 use mo_param1_bgc, only: ks use mod_nctools, only: ncwrt1,ncdims,nctime,ncfcls,ncfopn, & @@ -390,19 +390,21 @@ subroutine ncwrt_bgc(iogrp) call finlyr(jremin_aerob(iogrp),jdp(iogrp)) call finlyr(jremin_sulf(iogrp),jdp(iogrp)) #endif - ! M4AGO - call finlyr(jagg_ws(iogrp),jdp(iogrp)) - call finlyr(jdynvis(iogrp),jdp(iogrp)) - call finlyr(jagg_stick(iogrp),jdp(iogrp)) - call finlyr(jagg_stickf(iogrp),jdp(iogrp)) - call finlyr(jagg_dmax(iogrp),jdp(iogrp)) - call finlyr(jagg_avdp(iogrp),jdp(iogrp)) - call finlyr(jagg_avrhop(iogrp),jdp(iogrp)) - call finlyr(jagg_avdC(iogrp),jdp(iogrp)) - call finlyr(jagg_df(iogrp),jdp(iogrp)) - call finlyr(jagg_b(iogrp),jdp(iogrp)) - call finlyr(jagg_Vrhof(iogrp),jdp(iogrp)) - call finlyr(jagg_Vpor(iogrp),jdp(iogrp)) + if(lm4ago)then + ! M4AGO + call finlyr(jagg_ws(iogrp),jdp(iogrp)) + call finlyr(jdynvis(iogrp),jdp(iogrp)) + call finlyr(jagg_stick(iogrp),jdp(iogrp)) + call finlyr(jagg_stickf(iogrp),jdp(iogrp)) + call finlyr(jagg_dmax(iogrp),jdp(iogrp)) + call finlyr(jagg_avdp(iogrp),jdp(iogrp)) + call finlyr(jagg_avrhop(iogrp),jdp(iogrp)) + call finlyr(jagg_avdC(iogrp),jdp(iogrp)) + call finlyr(jagg_df(iogrp),jdp(iogrp)) + call finlyr(jagg_b(iogrp),jdp(iogrp)) + call finlyr(jagg_Vrhof(iogrp),jdp(iogrp)) + call finlyr(jagg_Vpor(iogrp),jdp(iogrp)) + endif ! --- Mask sea floor in mass fluxes call msksrf(jcarflx0100(iogrp),k0100) @@ -503,19 +505,21 @@ subroutine ncwrt_bgc(iogrp) call msklvl(jlvl_remin_aerob(iogrp),depths) call msklvl(jlvl_remin_sulf(iogrp),depths) #endif - ! M4AGO - call msklvl(jlvl_agg_ws(iogrp),depths) - call msklvl(jlvl_dynvis(iogrp),depths) - call msklvl(jlvl_agg_stick(iogrp),depths) - call msklvl(jlvl_agg_stickf(iogrp),depths) - call msklvl(jlvl_agg_dmax(iogrp),depths) - call msklvl(jlvl_agg_avdp(iogrp),depths) - call msklvl(jlvl_agg_avrhop(iogrp),depths) - call msklvl(jlvl_agg_avdC(iogrp),depths) - call msklvl(jlvl_agg_df(iogrp),depths) - call msklvl(jlvl_agg_b(iogrp),depths) - call msklvl(jlvl_agg_Vrhof(iogrp),depths) - call msklvl(jlvl_agg_Vpor(iogrp),depths) + if(lm4ago)then + ! M4AGO + call msklvl(jlvl_agg_ws(iogrp),depths) + call msklvl(jlvl_dynvis(iogrp),depths) + call msklvl(jlvl_agg_stick(iogrp),depths) + call msklvl(jlvl_agg_stickf(iogrp),depths) + call msklvl(jlvl_agg_dmax(iogrp),depths) + call msklvl(jlvl_agg_avdp(iogrp),depths) + call msklvl(jlvl_agg_avrhop(iogrp),depths) + call msklvl(jlvl_agg_avdC(iogrp),depths) + call msklvl(jlvl_agg_df(iogrp),depths) + call msklvl(jlvl_agg_b(iogrp),depths) + call msklvl(jlvl_agg_Vrhof(iogrp),depths) + call msklvl(jlvl_agg_Vpor(iogrp),depths) + endif ! --- Compute log10 of pH if (SRF_PH(iogrp).ne.0) call logsrf(jsrfph(iogrp),rnacc,0.) @@ -725,20 +729,21 @@ subroutine ncwrt_bgc(iogrp) call wrtlyr(jremin_aerob(iogrp), LYR_remin_aerob(iogrp),1e3/dtbgc, 0.,cmpflg,'remina') call wrtlyr(jremin_sulf(iogrp), LYR_remin_sulf(iogrp),1e3/dtbgc, 0.,cmpflg,'remins') #endif -! M4AGO - call wrtlyr(jagg_ws(iogrp), LYR_agg_ws(iogrp), 1., 0.,cmpflg,'agg_ws') - call wrtlyr(jdynvis(iogrp), LYR_dynvis(iogrp), 1., 0.,cmpflg,'dynvis') - call wrtlyr(jagg_stick(iogrp), LYR_agg_stick(iogrp),1., 0.,cmpflg,'agg_stick') - call wrtlyr(jagg_stickf(iogrp), LYR_agg_stickf(iogrp),1., 0.,cmpflg,'agg_stickf') - call wrtlyr(jagg_dmax(iogrp), LYR_agg_dmax(iogrp), 1., 0.,cmpflg,'agg_dmax') - call wrtlyr(jagg_avdp(iogrp), LYR_agg_avdp(iogrp), 1., 0.,cmpflg,'agg_avdp') - call wrtlyr(jagg_avrhop(iogrp), LYR_agg_avrhop(iogrp),1., 0.,cmpflg,'agg_avrhop') - call wrtlyr(jagg_avdC(iogrp), LYR_agg_avdC(iogrp), 1., 0.,cmpflg,'agg_avdC') - call wrtlyr(jagg_df(iogrp), LYR_agg_df(iogrp), 1., 0.,cmpflg,'agg_df') - call wrtlyr(jagg_b(iogrp), LYR_agg_b(iogrp), 1., 0.,cmpflg,'agg_b') - call wrtlyr(jagg_Vrhof(iogrp), LYR_agg_Vrhof(iogrp),1., 0.,cmpflg,'agg_Vrhof') - call wrtlyr(jagg_Vpor(iogrp), LYR_agg_Vpor(iogrp), 1., 0.,cmpflg,'agg_Vpor') - + if(lm4ago)then + ! M4AGO + call wrtlyr(jagg_ws(iogrp), LYR_agg_ws(iogrp), 1., 0.,cmpflg,'agg_ws') + call wrtlyr(jdynvis(iogrp), LYR_dynvis(iogrp), 1., 0.,cmpflg,'dynvis') + call wrtlyr(jagg_stick(iogrp), LYR_agg_stick(iogrp),1., 0.,cmpflg,'agg_stick') + call wrtlyr(jagg_stickf(iogrp), LYR_agg_stickf(iogrp),1., 0.,cmpflg,'agg_stickf') + call wrtlyr(jagg_dmax(iogrp), LYR_agg_dmax(iogrp), 1., 0.,cmpflg,'agg_dmax') + call wrtlyr(jagg_avdp(iogrp), LYR_agg_avdp(iogrp), 1., 0.,cmpflg,'agg_avdp') + call wrtlyr(jagg_avrhop(iogrp), LYR_agg_avrhop(iogrp),1., 0.,cmpflg,'agg_avrhop') + call wrtlyr(jagg_avdC(iogrp), LYR_agg_avdC(iogrp), 1., 0.,cmpflg,'agg_avdC') + call wrtlyr(jagg_df(iogrp), LYR_agg_df(iogrp), 1., 0.,cmpflg,'agg_df') + call wrtlyr(jagg_b(iogrp), LYR_agg_b(iogrp), 1., 0.,cmpflg,'agg_b') + call wrtlyr(jagg_Vrhof(iogrp), LYR_agg_Vrhof(iogrp),1., 0.,cmpflg,'agg_Vrhof') + call wrtlyr(jagg_Vpor(iogrp), LYR_agg_Vpor(iogrp), 1., 0.,cmpflg,'agg_Vpor') + endif ! --- Store 3d level fields call wrtlvl(jlvldic(iogrp), LVL_DIC(iogrp), rnacc*1e3, 0.,cmpflg,'dissiclvl') call wrtlvl(jlvlalkali(iogrp), LVL_ALKALI(iogrp), rnacc*1e3, 0.,cmpflg,'talklvl') @@ -821,20 +826,21 @@ subroutine ncwrt_bgc(iogrp) call wrtlvl(jlvl_remin_aerob(iogrp), LVL_remin_aerob(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'reminalvl') call wrtlvl(jlvl_remin_sulf(iogrp), LVL_remin_sulf(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'reminslvl') #endif -! M4AGO - call wrtlvl(jlvl_agg_ws(iogrp), LVL_agg_ws(iogrp), rnacc, 0.,cmpflg,'agg_wslvl') - call wrtlvl(jlvl_dynvis(iogrp), LVL_dynvis(iogrp), rnacc, 0.,cmpflg,'dynvislvl') - call wrtlvl(jlvl_agg_stick(iogrp), LVL_agg_stick(iogrp), rnacc, 0.,cmpflg,'agg_sticklvl') - call wrtlvl(jlvl_agg_stickf(iogrp), LVL_agg_stickf(iogrp), rnacc, 0.,cmpflg,'agg_stickflvl') - call wrtlvl(jlvl_agg_dmax(iogrp), LVL_agg_dmax(iogrp), rnacc, 0.,cmpflg,'agg_dmaxlvl') - call wrtlvl(jlvl_agg_avdp(iogrp), LVL_agg_avdp(iogrp), rnacc, 0.,cmpflg,'agg_avdplvl') - call wrtlvl(jlvl_agg_avrhop(iogrp), LVL_agg_avrhop(iogrp), rnacc, 0.,cmpflg,'agg_avrhoplvl') - call wrtlvl(jlvl_agg_avdC(iogrp), LVL_agg_avdC(iogrp), rnacc, 0.,cmpflg,'agg_avdClvl') - call wrtlvl(jlvl_agg_df(iogrp), LVL_agg_df(iogrp), rnacc, 0.,cmpflg,'agg_dflvl') - call wrtlvl(jlvl_agg_b(iogrp), LVL_agg_b(iogrp), rnacc, 0.,cmpflg,'agg_blvl') - call wrtlvl(jlvl_agg_Vrhof(iogrp), LVL_agg_Vrhof(iogrp), rnacc, 0.,cmpflg,'agg_Vrhoflvl') - call wrtlvl(jlvl_agg_Vpor(iogrp), LVL_agg_Vpor(iogrp), rnacc, 0.,cmpflg,'agg_Vporlvl') - + if(lm4ago)then + ! M4AGO + call wrtlvl(jlvl_agg_ws(iogrp), LVL_agg_ws(iogrp), rnacc, 0.,cmpflg,'agg_wslvl') + call wrtlvl(jlvl_dynvis(iogrp), LVL_dynvis(iogrp), rnacc, 0.,cmpflg,'dynvislvl') + call wrtlvl(jlvl_agg_stick(iogrp), LVL_agg_stick(iogrp), rnacc, 0.,cmpflg,'agg_sticklvl') + call wrtlvl(jlvl_agg_stickf(iogrp), LVL_agg_stickf(iogrp), rnacc, 0.,cmpflg,'agg_stickflvl') + call wrtlvl(jlvl_agg_dmax(iogrp), LVL_agg_dmax(iogrp), rnacc, 0.,cmpflg,'agg_dmaxlvl') + call wrtlvl(jlvl_agg_avdp(iogrp), LVL_agg_avdp(iogrp), rnacc, 0.,cmpflg,'agg_avdplvl') + call wrtlvl(jlvl_agg_avrhop(iogrp), LVL_agg_avrhop(iogrp), rnacc, 0.,cmpflg,'agg_avrhoplvl') + call wrtlvl(jlvl_agg_avdC(iogrp), LVL_agg_avdC(iogrp), rnacc, 0.,cmpflg,'agg_avdClvl') + call wrtlvl(jlvl_agg_df(iogrp), LVL_agg_df(iogrp), rnacc, 0.,cmpflg,'agg_dflvl') + call wrtlvl(jlvl_agg_b(iogrp), LVL_agg_b(iogrp), rnacc, 0.,cmpflg,'agg_blvl') + call wrtlvl(jlvl_agg_Vrhof(iogrp), LVL_agg_Vrhof(iogrp), rnacc, 0.,cmpflg,'agg_Vrhoflvl') + call wrtlvl(jlvl_agg_Vpor(iogrp), LVL_agg_Vpor(iogrp), rnacc, 0.,cmpflg,'agg_Vporlvl') + endif ! --- Store sediment fields #ifndef sedbypass call wrtsdm(jpowaic(iogrp), SDM_POWAIC(iogrp), rnacc*1e3, 0.,cmpflg,'powdic') @@ -1075,20 +1081,21 @@ subroutine ncwrt_bgc(iogrp) call inilyr(jremin_aerob(iogrp),0.) call inilyr(jremin_sulf(iogrp),0.) #endif - ! M4AGO - call inilyr(jagg_ws(iogrp),0.) - call inilyr(jdynvis(iogrp),0.) - call inilyr(jagg_stick(iogrp),0.) - call inilyr(jagg_stickf(iogrp),0.) - call inilyr(jagg_dmax(iogrp),0.) - call inilyr(jagg_avdp(iogrp),0.) - call inilyr(jagg_avrhop(iogrp),0.) - call inilyr(jagg_avdC(iogrp),0.) - call inilyr(jagg_df(iogrp),0.) - call inilyr(jagg_b(iogrp),0.) - call inilyr(jagg_Vrhof(iogrp),0.) - call inilyr(jagg_Vpor(iogrp),0.) - + if(lm4ago)then + ! M4AGO + call inilyr(jagg_ws(iogrp),0.) + call inilyr(jdynvis(iogrp),0.) + call inilyr(jagg_stick(iogrp),0.) + call inilyr(jagg_stickf(iogrp),0.) + call inilyr(jagg_dmax(iogrp),0.) + call inilyr(jagg_avdp(iogrp),0.) + call inilyr(jagg_avrhop(iogrp),0.) + call inilyr(jagg_avdC(iogrp),0.) + call inilyr(jagg_df(iogrp),0.) + call inilyr(jagg_b(iogrp),0.) + call inilyr(jagg_Vrhof(iogrp),0.) + call inilyr(jagg_Vpor(iogrp),0.) + endif call inilvl(jlvldic(iogrp),0.) call inilvl(jlvlalkali(iogrp),0.) call inilvl(jlvlphosy(iogrp),0.) @@ -1170,20 +1177,21 @@ subroutine ncwrt_bgc(iogrp) call inilvl(jlvl_remin_aerob(iogrp),0.) call inilvl(jlvl_remin_sulf(iogrp),0.) #endif - ! M4AGO - call inilvl(jlvl_agg_ws(iogrp),0.) - call inilvl(jlvl_dynvis(iogrp),0.) - call inilvl(jlvl_agg_stick(iogrp),0.) - call inilvl(jlvl_agg_stickf(iogrp),0.) - call inilvl(jlvl_agg_dmax(iogrp),0.) - call inilvl(jlvl_agg_avdp(iogrp),0.) - call inilvl(jlvl_agg_avrhop(iogrp),0.) - call inilvl(jlvl_agg_avdC(iogrp),0.) - call inilvl(jlvl_agg_df(iogrp),0.) - call inilvl(jlvl_agg_b(iogrp),0.) - call inilvl(jlvl_agg_Vrhof(iogrp),0.) - call inilvl(jlvl_agg_Vpor(iogrp),0.) - + if(lm4ago)then + ! M4AGO + call inilvl(jlvl_agg_ws(iogrp),0.) + call inilvl(jlvl_dynvis(iogrp),0.) + call inilvl(jlvl_agg_stick(iogrp),0.) + call inilvl(jlvl_agg_stickf(iogrp),0.) + call inilvl(jlvl_agg_dmax(iogrp),0.) + call inilvl(jlvl_agg_avdp(iogrp),0.) + call inilvl(jlvl_agg_avrhop(iogrp),0.) + call inilvl(jlvl_agg_avdC(iogrp),0.) + call inilvl(jlvl_agg_df(iogrp),0.) + call inilvl(jlvl_agg_b(iogrp),0.) + call inilvl(jlvl_agg_Vrhof(iogrp),0.) + call inilvl(jlvl_agg_Vpor(iogrp),0.) + endif #ifndef sedbypass call inisdm(jpowaic(iogrp),0.) call inisdm(jpowaal(iogrp),0.) @@ -1229,7 +1237,7 @@ end subroutine ncwrt_bgc subroutine hamoccvardef(iogrp,timeunits,calendar,cmpflg) use mod_nctools, only:ncdefvar,ncattr,ncfopn,ncdimc,ncdims, & & nctime,ncfcls,ncedef,ncdefvar3d,ndouble - + use mo_control_bgc,only:lm4ago use mo_bgcmean, only: srf_kwco2,srf_pco2,srf_dmsflux,srf_co2fxd, & & srf_kwco2khm,srf_co2kh,srf_co2khm,srf_pco2m, & & srf_co2fxu,srf_oxflux,srf_niflux,srf_pn2om,srf_dms,srf_dmsprod, & @@ -1749,32 +1757,33 @@ subroutine hamoccvardef(iogrp,timeunits,calendar,cmpflg) call ncdefvar3d(LYR_remin_sulf(iogrp),cmpflg,'p', & & 'remins','Sulfate remineralization rate',' ','mol P m-3 s-1',1) #endif - ! M4AGO - call ncdefvar3d(LYR_agg_ws(iogrp),cmpflg,'p', & - & 'agg_ws','aggregate mean settling velocity',' ','m d-1',1) - call ncdefvar3d(LYR_dynvis(iogrp),cmpflg,'p', & - & 'dynvis','dynamic viscosity of sea water',' ','kg m-1 s-1',1) - call ncdefvar3d(LYR_agg_stick(iogrp),cmpflg,'p', & - & 'agg_stick','aggregate mean stickiness',' ','-',1) - call ncdefvar3d(LYR_agg_stickf(iogrp),cmpflg,'p', & - & 'agg_stickf','opal frustule stickiness',' ','-',1) - call ncdefvar3d(LYR_agg_dmax(iogrp),cmpflg,'p', & - & 'agg_dmax','aggregate maximum diameter',' ','m',1) - call ncdefvar3d(LYR_agg_avdp(iogrp),cmpflg,'p', & - & 'agg_avdp','mean primary particle diameter',' ','m',1) - call ncdefvar3d(LYR_agg_avrhop(iogrp),cmpflg,'p', & - & 'agg_avrhop','mean primary particle density',' ','kg m-3',1) - call ncdefvar3d(LYR_agg_avdC(iogrp),cmpflg,'p', & - & 'agg_avdC','Conc.-weighted mean aggregate diameter',' ','m',1) - call ncdefvar3d(LYR_agg_df(iogrp),cmpflg,'p', & - & 'agg_df','aggregate fractal dimension',' ','-',1) - call ncdefvar3d(LYR_agg_b(iogrp),cmpflg,'p', & - & 'agg_b','aggregate number distribution slope',' ','-',1) - call ncdefvar3d(LYR_agg_Vrhof(iogrp),cmpflg,'p', & - & 'agg_Vrhof','V-weighted aggregate mean density',' ','kg m-3',1) - call ncdefvar3d(LYR_agg_Vpor(iogrp),cmpflg,'p', & - & 'agg_Vpor','V-weighted aggregate mean porosity',' ','-',1) - + if(lm4ago)then + ! M4AGO + call ncdefvar3d(LYR_agg_ws(iogrp),cmpflg,'p', & + & 'agg_ws','aggregate mean settling velocity',' ','m d-1',1) + call ncdefvar3d(LYR_dynvis(iogrp),cmpflg,'p', & + & 'dynvis','dynamic viscosity of sea water',' ','kg m-1 s-1',1) + call ncdefvar3d(LYR_agg_stick(iogrp),cmpflg,'p', & + & 'agg_stick','aggregate mean stickiness',' ','-',1) + call ncdefvar3d(LYR_agg_stickf(iogrp),cmpflg,'p', & + & 'agg_stickf','opal frustule stickiness',' ','-',1) + call ncdefvar3d(LYR_agg_dmax(iogrp),cmpflg,'p', & + & 'agg_dmax','aggregate maximum diameter',' ','m',1) + call ncdefvar3d(LYR_agg_avdp(iogrp),cmpflg,'p', & + & 'agg_avdp','mean primary particle diameter',' ','m',1) + call ncdefvar3d(LYR_agg_avrhop(iogrp),cmpflg,'p', & + & 'agg_avrhop','mean primary particle density',' ','kg m-3',1) + call ncdefvar3d(LYR_agg_avdC(iogrp),cmpflg,'p', & + & 'agg_avdC','Conc.-weighted mean aggregate diameter',' ','m',1) + call ncdefvar3d(LYR_agg_df(iogrp),cmpflg,'p', & + & 'agg_df','aggregate fractal dimension',' ','-',1) + call ncdefvar3d(LYR_agg_b(iogrp),cmpflg,'p', & + & 'agg_b','aggregate number distribution slope',' ','-',1) + call ncdefvar3d(LYR_agg_Vrhof(iogrp),cmpflg,'p', & + & 'agg_Vrhof','V-weighted aggregate mean density',' ','kg m-3',1) + call ncdefvar3d(LYR_agg_Vpor(iogrp),cmpflg,'p', & + & 'agg_Vpor','V-weighted aggregate mean porosity',' ','-',1) + endif ! --- define 3d level fields call ncdefvar3d(LVL_DIC(iogrp),cmpflg,'p', & & 'dissiclvl','Dissolved inorganic carbon',' ','mol C m-3',2) @@ -1935,35 +1944,36 @@ subroutine hamoccvardef(iogrp,timeunits,calendar,cmpflg) & 'reminslvl','Sulfate remineralization rate',' ', & & 'mol P m-3 s-1',2) #endif - ! M4AGO - call ncdefvar3d(LVL_agg_ws(iogrp),cmpflg,'p', & - & 'agg_wslvl','aggregate mean settling velocity',' ','m d-1',2) - call ncdefvar3d(LVL_dynvis(iogrp),cmpflg,'p', & - & 'dynvislvl','dynamic viscosity of sea water',' ','kg m-1 s-1', & - & 2) - call ncdefvar3d(LVL_agg_stick(iogrp),cmpflg,'p', & - & 'agg_sticklvl','aggregate mean stickiness',' ','-',2) - call ncdefvar3d(LVL_agg_stickf(iogrp),cmpflg,'p', & - & 'agg_stickflvl','opal frustule stickiness',' ','-',2) - call ncdefvar3d(LVL_agg_dmax(iogrp),cmpflg,'p', & - & 'agg_dmaxlvl','aggregate maximum diameter',' ','m',2) - call ncdefvar3d(LVL_agg_avdp(iogrp),cmpflg,'p', & - & 'agg_avdplvl','mean primary particle diameter',' ','m',2) - call ncdefvar3d(LVL_agg_avrhop(iogrp),cmpflg,'p', & - & 'agg_avrhoplvl','mean primary particle density',' ','kg m-3',2) - call ncdefvar3d(LVL_agg_avdC(iogrp),cmpflg,'p', & - & 'agg_avdClvl','Conc.-weighted mean aggregate diameter',' ', & - & 'm',2) - call ncdefvar3d(LVL_agg_df(iogrp),cmpflg,'p', & - & 'agg_dflvl','aggregate fractal dimension',' ','-',2) - call ncdefvar3d(LVL_agg_b(iogrp),cmpflg,'p', & - & 'agg_blvl','aggregate number distribution slope',' ','-',2) - call ncdefvar3d(LVL_agg_Vrhof(iogrp),cmpflg,'p', & - & 'agg_Vrhoflvl','V-weighted aggregate mean density',' ', & - & 'kg m-3',2) - call ncdefvar3d(LVL_agg_Vpor(iogrp),cmpflg,'p', & - & 'agg_Vporlvl','V-weighted aggregate mean porosity',' ','-',2) - + if(lm4ago)then + ! M4AGO + call ncdefvar3d(LVL_agg_ws(iogrp),cmpflg,'p', & + & 'agg_wslvl','aggregate mean settling velocity',' ','m d-1',2) + call ncdefvar3d(LVL_dynvis(iogrp),cmpflg,'p', & + & 'dynvislvl','dynamic viscosity of sea water',' ','kg m-1 s-1', & + & 2) + call ncdefvar3d(LVL_agg_stick(iogrp),cmpflg,'p', & + & 'agg_sticklvl','aggregate mean stickiness',' ','-',2) + call ncdefvar3d(LVL_agg_stickf(iogrp),cmpflg,'p', & + & 'agg_stickflvl','opal frustule stickiness',' ','-',2) + call ncdefvar3d(LVL_agg_dmax(iogrp),cmpflg,'p', & + & 'agg_dmaxlvl','aggregate maximum diameter',' ','m',2) + call ncdefvar3d(LVL_agg_avdp(iogrp),cmpflg,'p', & + & 'agg_avdplvl','mean primary particle diameter',' ','m',2) + call ncdefvar3d(LVL_agg_avrhop(iogrp),cmpflg,'p', & + & 'agg_avrhoplvl','mean primary particle density',' ','kg m-3',2) + call ncdefvar3d(LVL_agg_avdC(iogrp),cmpflg,'p', & + & 'agg_avdClvl','Conc.-weighted mean aggregate diameter',' ', & + & 'm',2) + call ncdefvar3d(LVL_agg_df(iogrp),cmpflg,'p', & + & 'agg_dflvl','aggregate fractal dimension',' ','-',2) + call ncdefvar3d(LVL_agg_b(iogrp),cmpflg,'p', & + & 'agg_blvl','aggregate number distribution slope',' ','-',2) + call ncdefvar3d(LVL_agg_Vrhof(iogrp),cmpflg,'p', & + & 'agg_Vrhoflvl','V-weighted aggregate mean density',' ', & + & 'kg m-3',2) + call ncdefvar3d(LVL_agg_Vpor(iogrp),cmpflg,'p', & + & 'agg_Vporlvl','V-weighted aggregate mean porosity',' ','-',2) + endif ! --- define sediment fields #ifndef sedbypass call ncdefvar3d(SDM_POWAIC(iogrp),cmpflg,'p', & From fa96bf54fc9ea9877b7b2847de1d7e7f2022c885 Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Fri, 19 Jan 2024 14:16:44 +0100 Subject: [PATCH 321/366] making things compilable again - M4AGO and N-cycle not yet running again --- hamocc/mo_accfields.F90 | 189 +++++++++- hamocc/mo_aufr_bgc.F90 | 64 +++- hamocc/mo_aufw_bgc.F90 | 37 +- hamocc/mo_bgcmean.F90 | 4 +- hamocc/mo_carbch.F90 | 2 +- hamocc/mo_carchm.F90 | 112 +++++- hamocc/mo_control_bgc.F90 | 3 +- hamocc/mo_cyano.F90 | 81 +++-- hamocc/mo_extNsediment.F90 | 4 +- hamocc/mo_extNwatercol.F90 | 3 +- hamocc/mo_hamocc4bcm.F90 | 84 ++++- hamocc/mo_hamocc_init.F90 | 14 +- hamocc/mo_hamocc_step.F90 | 13 +- hamocc/mo_ini_fields.F90 | 21 +- hamocc/mo_inventory_bgc.F90 | 104 +++++- hamocc/mo_m4ago.F90 | 3 +- hamocc/mo_ncout_hamocc.F90 | 676 ++++++++++++++++++++++++++++++++++-- hamocc/mo_ocprod.F90 | 214 ++++++++++-- hamocc/mo_param1_bgc.F90 | 12 +- hamocc/mo_param_bgc.F90 | 40 +-- hamocc/mo_powach.F90 | 105 +++++- hamocc/mo_preftrc.F90 | 3 +- hamocc/mo_sedshi.F90 | 13 +- 23 files changed, 1604 insertions(+), 197 deletions(-) diff --git a/hamocc/mo_accfields.F90 b/hamocc/mo_accfields.F90 index 4fba06d9..2a3ad430 100644 --- a/hamocc/mo_accfields.F90 +++ b/hamocc/mo_accfields.F90 @@ -35,15 +35,15 @@ subroutine accfields(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask) ! ! Purpose ! ------- - ! Accumulate fields for time-avaraged output and write output + ! Accumulate fields for time-averaged output and write output ! !*********************************************************************************************** use mod_xc, only: mnproc use mod_dia, only: ddm use mo_carbch, only: atm,atmflx,co2fxd,co2fxu,co3,hi,kwco2sol, & - ndepflx,rivinflx,oalkflx,ocetra,omegaa,omegac,pco2d, & - satoxy,sedfluxo,pco2m,kwco2d,co2sold,co2solm, & + ndepnoyflx,rivinflx,oalkflx,ocetra,omegaa,omegac,pco2d, & + satoxy,sedfluxo,sedfluxb,pco2m,kwco2d,co2sold,co2solm,pn2om, & co213fxd,co213fxu,co214fxd,co214fxu, & natco3,nathi,natomegaa,natomegac,natpco2d use mo_biomod, only: bsiflx_bot,bsiflx0100,bsiflx0500,bsiflx1000, & @@ -61,6 +61,7 @@ subroutine accfields(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask) jcalflx_bot,jcarflx0100,jcarflx0500, & jcarflx1000,jcarflx2000,jcarflx4000,jcarflx_bot, & jsediffic,jsediffal,jsediffph,jsediffox, & + jburflxsso12,jburflxsssc12,jburflxssssil,jburflxssster, & jsediffn2,jsediffno3,jsediffsi,jco2flux, & jco2fxd,jco2fxu,jco3,jdic,jdicsat, & jdms,jdms_bac,jdms_uv,jdmsflux, & @@ -80,13 +81,13 @@ subroutine accfields(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask) jlvlprefo2,jlvlprefpo4,jlvlsf6,jlvlsilica, & jlvlwnos,jlvlwphy,jn2flux,jn2o,jn2oflux,jn2ofx, & jprorca,jprcaca,jsilpro,jpodiic,jpodial,jpodiph, & - jpodiox,jpodin2,jpodino3,jpodisi,jndep,joalk, & + jpodiox,jpodin2,jpodino3,jpodisi,jndepnoy,jndepnhx,joalk, & jniflux,jnos,jo2flux,jo2sat,jomegaa,jomegac,jopal, & joxflux,joxygen,jpco2,jpco2m,jkwco2khm,jco2khm, & jco2kh,jph,jphosph,jphosy,jphyto,jpoc,jprefalk, & jprefdic,jprefo2,jprefpo4,jsilica,jsrfalkali, & jsrfano3,jsrfdic,jsrfiron,jsrfoxygen,jsrfphosph, & - jsrfphyto,jsrfsilica,jsrfph,jwnos,jwphy,jndepfx, & + jsrfphyto,jsrfsilica,jsrfph,jwnos,jwphy,jndepnoyfx, & joalkfx,nbgc,nacc_bgc,bgcwrt,glb_inventory, & bgct2d,acclvl,acclyr,accsrf,bgczlv, & jatmbromo,jbromo,jbromo_prod,jbromo_uv,jbromofx,jsrfbromo, & @@ -100,9 +101,21 @@ subroutine accfields(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask) jbursssc12,jburssso12,jburssssil,jburssster, & jpowaal,jpowaic,jpowaox,jpowaph,jpowaph,jpowasi,jpown2, & jpowno3,jsssc12,jssso12,jssssil,jssster,accbur,accsdm, & - jatmco2,jatmn2,jatmo2 + jatmco2,jatmn2,jatmo2, & + jlvlanh4,jlvlano2, & + jlvl_nitr_NH4, jsrfpn2om, & + jlvl_nitr_NO2,jlvl_nitr_N2O_prod,jlvl_nitr_NH4_OM,jlvl_nitr_NO2_OM,& + jlvl_denit_NO3,jlvl_denit_NO2,jlvl_denit_N2O,jlvl_DNRA_NO2, & + jlvl_anmx_N2_prod,jlvl_anmx_OM_prod,jlvl_phosy_NH4,jlvl_phosy_NO3, & + jlvl_remin_aerob,jlvl_remin_sulf, & + jagg_ws,jdynvis,jagg_stick,jagg_stickf,jagg_dmax,jagg_avdp, & + jagg_avrhop,jagg_avdC,jagg_df,jagg_b,jagg_Vrhof,jagg_Vpor, & + jlvl_agg_ws,jlvl_dynvis,jlvl_agg_stick,jlvl_agg_stickf, & + jlvl_agg_dmax,jlvl_agg_avdp,jlvl_agg_avrhop,jlvl_agg_avdC, & + jlvl_agg_df,jlvl_agg_b,jlvl_agg_Vrhof,jlvl_agg_Vpor, & + jprefsilica,jlvlprefsilica use mo_control_bgc, only: io_stdo_bgc,dtb,use_BROMO,use_AGG,use_WLIN,use_natDIC, & - use_CFC,use_sedbypass,use_cisonew,use_BOXATM + use_CFC,use_sedbypass,use_cisonew,use_BOXATM,lm4ago,use_extNcycle use mo_param1_bgc, only: ialkali,ian2o,iano3,iatmco2,iatmdms,iatmn2,iatmn2o,iatmo2, & icalc,idet,idms,idicsat,idoc,iiron,iopal, & ioxygen,iphosph,iphy,iprefalk,iprefdic, & @@ -113,11 +126,31 @@ subroutine accfields(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask) izoo13,safediv, & iatmnco2,inatalkali,inatcalc,inatsco212, & ipowaal,ipowaic,ipowaox,ipowaph,ipowasi, & - ipown2,ipowno3,isssc12,issso12,issssil,issster + ipown2,ipowno3,isssc12,issso12,issssil,issster, & + issso12,isssc12,issssil,issster,iprefsilica use mo_sedmnt, only: powtra,sedlay,burial use mo_vgrid, only: dp_min use mo_inventory_bgc, only: inventory_bgc use mo_ncwrt_bgc , only: ncwrt_bgc + use mo_m4ago, only: aggregate_diagnostics,kav_dp,kav_rho_p,kav_d_C,kws_agg,kdf_agg, & + kstickiness_agg,kb_agg,kstickiness_frustule,kLmax_agg,kdynvis, & + kav_rhof_V,kav_por_V +#ifdef extNcycle + use mo_carbch, only: pnh3,ndepnhxflx + use mo_param1_bgc, only: iatmnh3,ianh4,iano2,ipownh4,ipown2o,ipowno2 + use mo_bgcmean, only: jnh3flux,janh3fx,janh4,jano2,jsrfanh4,jsrfano2,jsrfpnh3, & + & jnitr_NH4,jnitr_NO2,jnitr_N2O_prod,jnitr_NH4_OM,jnitr_NO2_OM,jdenit_NO3,jdenit_NO2,jdenit_N2O, & + & jDNRA_NO2,janmx_N2_prod,janmx_OM_prod,jphosy_NH4,jphosy_NO3,jremin_aerob,jremin_sulf, & + & jpownh4,jpown2o,jpowno2,jsdm_nitr_NH4,jsdm_nitr_NO2,jsdm_nitr_N2O_prod,jsdm_nitr_NH4_OM, & + & jsdm_nitr_NO2_OM,jsdm_denit_NO3,jsdm_denit_NO2,jsdm_denit_N2O,jsdm_DNRA_NO2,jsdm_anmx_N2_prod, & + & jsdm_anmx_OM_prod,jsdm_remin_aerob,jsdm_remin_sulf,jsediffnh4,jsediffn2o,jsediffno2,jatmn2o,jatmnh3,& + & jndepnhxfx + use mo_biomod, only: nitr_NH4,nitr_NO2,nitr_N2O_prod,nitr_NH4_OM,nitr_NO2_OM,denit_NO3,denit_NO2,denit_N2O,DNRA_NO2, & + & anmx_N2_prod,anmx_OM_prod,phosy_NH4,phosy_NO3,remin_aerob,remin_sulf + use mo_extNsediment,only: extNsed_diagnostics,ised_nitr_NH4,ised_nitr_NO2,ised_nitr_N2O_prod,ised_nitr_NH4_OM, & + & ised_nitr_NO2_OM,ised_denit_NO3,ised_denit_NO2,ised_denit_N2O,ised_DNRA_NO2,ised_anmx_N2_prod, & + & ised_anmx_OM_prod,ised_remin_aerob,ised_remin_sulf +#endif ! Arguments integer , intent(in) :: kpie ! 1st dimension of model grid. @@ -171,6 +204,10 @@ subroutine accfields(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask) bgct2d(i,j,jo2flux) = bgct2d(i,j,jo2flux) + atmflx(i,j,iatmo2)/2.0 bgct2d(i,j,jn2flux) = bgct2d(i,j,jn2flux) + atmflx(i,j,iatmn2)/2.0 bgct2d(i,j,jn2oflux) = bgct2d(i,j,jn2oflux) + atmflx(i,j,iatmn2o)/2.0 +#ifdef extNcycle + bgct2d(i,j,jnh3flux) = bgct2d(i,j,jnh3flux) + atmflx(i,j,iatmnh3)/2.0 + bgct2d(i,j,jndepnhx) = bgct2d(i,j,jndepnhx) + ndepnhxflx(i,j)/2.0 +#endif ! Particle fluxes between water-column and sediment bgct2d(i,j,jprorca) = bgct2d(i,j,jprorca) + carflx_bot(i,j)/2.0 bgct2d(i,j,jprcaca) = bgct2d(i,j,jprcaca) + calflx_bot(i,j)/2.0 @@ -186,7 +223,7 @@ subroutine accfields(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask) bgct2d(i,j,jpodisi) = bgct2d(i,j,jpodisi) + sedfluxo(i,j,ipowasi)/2.0 endif ! N-deposition, ocean alkalinization, and riverine input fluxes - bgct2d(i,j,jndep) = bgct2d(i,j,jndep) + ndepflx(i,j)/2.0 + bgct2d(i,j,jndepnoy) = bgct2d(i,j,jndepnoy) + ndepnoyflx(i,j)/2.0 bgct2d(i,j,joalk) = bgct2d(i,j,joalk) + oalkflx(i,j)/2.0 bgct2d(i,j,jirdin) = bgct2d(i,j,jirdin) + rivinflx(i,j,irdin)/2.0 bgct2d(i,j,jirdip) = bgct2d(i,j,jirdip) + rivinflx(i,j,irdip)/2.0 @@ -226,7 +263,11 @@ subroutine accfields(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask) call accsrf(jatmc13,atm(1,1,iatmc13),omask,0) call accsrf(jatmc14,atm(1,1,iatmc14),omask,0) endif - +#ifdef extNcycle + call accsrf(janh3fx,atmflx(1,1,iatmnh3),omask,0) + call accsrf(jatmnh3,atm(1,1,iatmnh3),omask,0) + call accsrf(jatmn2o,atm(1,1,iatmn2o),omask,0) +#endif ! Save up and downward fluxes for CO2 seperately call accsrf(jco2fxd,co2fxd,omask,0) call accsrf(jco2fxu,co2fxu,omask,0) @@ -254,6 +295,7 @@ subroutine accfields(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask) call accsrf(jsrfphyto,ocetra(1,1,1,iphy),omask,0) call accsrf(jsrfph,hi(1,1,1),omask,0) call accsrf(jdms,ocetra(1,1,1,idms),omask,0) + call accsrf(jsrfpn2om,pn2om,omask,0) call accsrf(jexport,expoor,omask,0) call accsrf(jexpoca,expoca,omask,0) call accsrf(jexposi,exposi,omask,0) @@ -276,9 +318,16 @@ subroutine accfields(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask) endif ! Accumulate fluxes due to N-deposition, ocean alkalinization - call accsrf(jndepfx,ndepflx,omask,0) + call accsrf(jndepnoyfx,ndepnoyflx,omask,0) call accsrf(joalkfx,oalkflx,omask,0) +#ifdef extNcycle + call accsrf(jsrfanh4,ocetra(1,1,1,ianh4),omask,0) + call accsrf(jsrfpnh3,pnh3,omask,0) + call accsrf(jsrfano2,ocetra(1,1,1,iano2),omask,0) + call accsrf(jndepnhxfx,ndepnhxflx,omask,0) +#endif + ! Accumulate the diagnostic mass sinking field if( domassfluxes ) then call accsrf(jcarflx0100,carflx0100,omask,0) @@ -310,8 +359,16 @@ subroutine accfields(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask) call accsrf(jsediffn2,sedfluxo(1,1,ipown2),omask,0) call accsrf(jsediffno3,sedfluxo(1,1,ipowno3),omask,0) call accsrf(jsediffsi,sedfluxo(1,1,ipowasi),omask,0) + call accsrf(jburflxsso12,sedfluxb(1,1,issso12),omask,0) + call accsrf(jburflxsssc12,sedfluxb(1,1,isssc12),omask,0) + call accsrf(jburflxssssil,sedfluxb(1,1,issssil),omask,0) + call accsrf(jburflxssster,sedfluxb(1,1,issster),omask,0) endif - +#if defined(extNcycle) && ! defined(sedbypass) + call accsrf(jsediffnh4,sedfluxo(1,1,ipownh4),omask,0) + call accsrf(jsediffn2o,sedfluxo(1,1,ipown2o),omask,0) + call accsrf(jsediffno2,sedfluxo(1,1,ipowno2),omask,0) +#endif ! Accumulate layer diagnostics call acclyr(jdp,pddpo,pddpo,0) call acclyr(jphyto,ocetra(1,1,1,iphy),pddpo,1) @@ -336,6 +393,7 @@ subroutine accfields(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask) call acclyr(jo2sat,satoxy,pddpo,1) call acclyr(jprefo2,ocetra(1,1,1,iprefo2),pddpo,1) call acclyr(jprefpo4,ocetra(1,1,1,iprefpo4),pddpo,1) + call acclyr(jprefsilica,ocetra(1,1,1,iprefsilica),pddpo,1) call acclyr(jprefalk,ocetra(1,1,1,iprefalk),pddpo,1) call acclyr(jprefdic,ocetra(1,1,1,iprefdic),pddpo,1) call acclyr(jdicsat,ocetra(1,1,1,idicsat),pddpo,1) @@ -375,17 +433,59 @@ subroutine accfields(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask) if (use_BROMO) then call acclyr(jbromo,ocetra(1,1,1,ibromo),pddpo,1) endif - +#ifdef extNcycle + call acclyr(janh4,ocetra(1,1,1,ianh4),pddpo,1) + call acclyr(jano2,ocetra(1,1,1,iano2),pddpo,1) + call acclyr(jnitr_NH4,nitr_NH4,pddpo,1) + call acclyr(jnitr_NO2,nitr_NO2,pddpo,1) + call acclyr(jnitr_N2O_prod,nitr_N2O_prod,pddpo,1) + call acclyr(jnitr_NH4_OM,nitr_NH4_OM,pddpo,1) + call acclyr(jnitr_NO2_OM,nitr_NO2_OM,pddpo,1) + call acclyr(jdenit_NO3,denit_NO3,pddpo,1) + call acclyr(jdenit_NO2,denit_NO2,pddpo,1) + call acclyr(jdenit_N2O,denit_N2O,pddpo,1) + call acclyr(jDNRA_NO2,DNRA_NO2,pddpo,1) + call acclyr(janmx_N2_prod,anmx_N2_prod,pddpo,1) + call acclyr(janmx_OM_prod,anmx_OM_prod,pddpo,1) + call acclyr(jphosy_NH4,phosy_NH4,pddpo,1) + call acclyr(jphosy_NO3,phosy_NO3,pddpo,1) + call acclyr(jremin_aerob,remin_aerob,pddpo,1) + call acclyr(jremin_sulf,remin_sulf,pddpo,1) +#endif + if (lm4ago) then + ! M4AGO + call acclyr(jagg_ws,aggregate_diagnostics(1,1,1,kws_agg),pddpo,1) + call acclyr(jdynvis,aggregate_diagnostics(1,1,1,kdynvis),pddpo,1) + call acclyr(jagg_stick,aggregate_diagnostics(1,1,1,kstickiness_agg),pddpo,1) + call acclyr(jagg_stickf,aggregate_diagnostics(1,1,1,kstickiness_frustule),pddpo,1) + call acclyr(jagg_dmax,aggregate_diagnostics(1,1,1,kLmax_agg),pddpo,1) + call acclyr(jagg_avdp,aggregate_diagnostics(1,1,1,kav_dp),pddpo,1) + call acclyr(jagg_avrhop,aggregate_diagnostics(1,1,1,kav_rho_p),pddpo,1) + call acclyr(jagg_avdC,aggregate_diagnostics(1,1,1,kav_d_C),pddpo,1) + call acclyr(jagg_df,aggregate_diagnostics(1,1,1,kdf_agg),pddpo,1) + call acclyr(jagg_b,aggregate_diagnostics(1,1,1,kb_agg),pddpo,1) + call acclyr(jagg_Vrhof,aggregate_diagnostics(1,1,1,kav_rhof_V),pddpo,1) + call acclyr(jagg_Vpor,aggregate_diagnostics(1,1,1,kav_por_V),pddpo,1) + endif ! Accumulate level diagnostics if (SUM(jlvlphyto+jlvlgrazer+jlvlphosph+jlvloxygen+jlvliron+ & & jlvlano3+jlvlalkali+jlvlsilica+jlvldic+jlvldoc+jlvlpoc+jlvlcalc+ & & jlvlopal+jlvln2o+jlvlco3+jlvlph+jlvlomegaa+jlvlomegac+jlvlphosy+ & & jlvlo2sat+jlvlprefo2+jlvlprefpo4+jlvlprefalk+jlvlprefdic+ & + & jlvlprefsilica+ & & jlvldicsat+jlvlnatdic+jlvlnatalkali+jlvlnatcalc+jlvlnatco3+ & & jlvlnatomegaa+jlvlnatomegac+jlvldic13+jlvldic14+jlvld13c+ & & jlvld14c+jlvlbigd14c+jlvlpoc13+jlvldoc13+jlvlcalc13+jlvlphyto13+ & & jlvlgrazer13+jlvlnos+jlvlwphy+jlvlwnos+jlvleps+jlvlasize+ & - & jlvlcfc11+jlvlcfc12+jlvlsf6+jlvlbromo) /= 0) then + & jlvlcfc11+jlvlcfc12+jlvlsf6+jlvlbromo+jlvlanh4+jlvlano2+ & + & jlvl_nitr_NH4+jlvl_nitr_NO2+jlvl_nitr_N2O_prod+jlvl_nitr_NH4_OM+& + & jlvl_nitr_NO2_OM+jlvl_denit_NO3+jlvl_denit_NO2+jlvl_denit_N2O+ & + & jlvl_DNRA_NO2+jlvl_anmx_N2_prod+jlvl_anmx_OM_prod+ & + & jlvl_phosy_NH4+jlvl_phosy_NO3+jlvl_remin_aerob+jlvl_remin_sulf+ & + & jlvl_agg_ws+jlvl_dynvis+jlvl_agg_stick+jlvl_agg_stickf+ & + & jlvl_agg_dmax+jlvl_agg_avdp+jlvl_agg_avrhop+jlvl_agg_avdC+ & + & jlvl_agg_df+jlvl_agg_b+jlvl_agg_Vrhof+jlvl_agg_Vpor & + & ) /= 0) then do k=1,kpke call bgczlv(pddpo,k,ind1,ind2,wghts) call acclvl(jlvlphyto,ocetra(1,1,1,iphy),k,ind1,ind2,wghts) @@ -410,6 +510,7 @@ subroutine accfields(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask) call acclvl(jlvlo2sat,satoxy,k,ind1,ind2,wghts) call acclvl(jlvlprefo2,ocetra(1,1,1,iprefo2),k,ind1,ind2,wghts) call acclvl(jlvlprefpo4,ocetra(1,1,1,iprefpo4),k,ind1,ind2,wghts) + call acclvl(jlvlprefsilica,ocetra(1,1,1,iprefsilica),k,ind1,ind2,wghts) call acclvl(jlvlprefalk,ocetra(1,1,1,iprefalk),k,ind1,ind2,wghts) call acclvl(jlvlprefdic,ocetra(1,1,1,iprefdic),k,ind1,ind2,wghts) call acclvl(jlvldicsat,ocetra(1,1,1,idicsat),k,ind1,ind2,wghts) @@ -449,6 +550,41 @@ subroutine accfields(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask) if (use_BROMO) then call acclvl(jlvlbromo,ocetra(1,1,1,ibromo),k,ind1,ind2,wghts) endif +#ifdef extNcycle + call acclvl(jlvlanh4,ocetra(1,1,1,ianh4),k,ind1,ind2,wghts) + call acclvl(jlvlano2,ocetra(1,1,1,iano2),k,ind1,ind2,wghts) + + call acclvl(jlvl_nitr_NH4,nitr_NH4,k,ind1,ind2,wghts) + call acclvl(jlvl_nitr_NO2,nitr_NO2,k,ind1,ind2,wghts) + call acclvl(jlvl_nitr_N2O_prod,nitr_N2O_prod,k,ind1,ind2,wghts) + call acclvl(jlvl_nitr_NH4_OM,nitr_NH4_OM,k,ind1,ind2,wghts) + call acclvl(jlvl_nitr_NO2_OM,nitr_NO2_OM,k,ind1,ind2,wghts) + call acclvl(jlvl_denit_NO3,denit_NO3,k,ind1,ind2,wghts) + call acclvl(jlvl_denit_NO2,denit_NO2,k,ind1,ind2,wghts) + call acclvl(jlvl_denit_N2O,denit_N2O,k,ind1,ind2,wghts) + call acclvl(jlvl_DNRA_NO2,DNRA_NO2,k,ind1,ind2,wghts) + call acclvl(jlvl_anmx_N2_prod,anmx_N2_prod,k,ind1,ind2,wghts) + call acclvl(jlvl_anmx_OM_prod,anmx_OM_prod,k,ind1,ind2,wghts) + call acclvl(jlvl_phosy_NH4,phosy_NH4,k,ind1,ind2,wghts) + call acclvl(jlvl_phosy_NO3,phosy_NO3,k,ind1,ind2,wghts) + call acclvl(jlvl_remin_aerob,remin_aerob,k,ind1,ind2,wghts) + call acclvl(jlvl_remin_sulf,remin_sulf,k,ind1,ind2,wghts) +#endif + if (lm4ago) then + !M4AGO + call acclvl(jlvl_agg_ws,aggregate_diagnostics(1,1,1,kws_agg),k,ind1,ind2,wghts) + call acclvl(jlvl_dynvis,aggregate_diagnostics(1,1,1,kdynvis),k,ind1,ind2,wghts) + call acclvl(jlvl_agg_stick,aggregate_diagnostics(1,1,1,kstickiness_agg),k,ind1,ind2,wghts) + call acclvl(jlvl_agg_stickf,aggregate_diagnostics(1,1,1,kstickiness_frustule),k,ind1,ind2,wghts) + call acclvl(jlvl_agg_dmax,aggregate_diagnostics(1,1,1,kLmax_agg),k,ind1,ind2,wghts) + call acclvl(jlvl_agg_avdp,aggregate_diagnostics(1,1,1,kav_dp),k,ind1,ind2,wghts) + call acclvl(jlvl_agg_avrhop,aggregate_diagnostics(1,1,1,kav_rho_p),k,ind1,ind2,wghts) + call acclvl(jlvl_agg_avdC,aggregate_diagnostics(1,1,1,kav_d_C),k,ind1,ind2,wghts) + call acclvl(jlvl_agg_df,aggregate_diagnostics(1,1,1,kdf_agg),k,ind1,ind2,wghts) + call acclvl(jlvl_agg_b,aggregate_diagnostics(1,1,1,kb_agg),k,ind1,ind2,wghts) + call acclvl(jlvl_agg_Vrhof,aggregate_diagnostics(1,1,1,kav_rhof_V),k,ind1,ind2,wghts) + call acclvl(jlvl_agg_Vpor,aggregate_diagnostics(1,1,1,kav_por_V),k,ind1,ind2,wghts) + endif enddo endif @@ -473,6 +609,26 @@ subroutine accfields(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask) call accbur(jbursssc12,burial(1,1,isssc12)) call accbur(jburssster,burial(1,1,issster)) endif +#if defined(extNcycle) && ! defined(sedbypass) + call accsdm(jpownh4,powtra(1,1,1,ipownh4)) + call accsdm(jpown2o,powtra(1,1,1,ipown2o)) + call accsdm(jpowno2,powtra(1,1,1,ipowno2)) + + call accsdm(jsdm_nitr_NH4 ,extNsed_diagnostics(1,1,1,ised_nitr_NH4)) + call accsdm(jsdm_nitr_NO2 ,extNsed_diagnostics(1,1,1,ised_nitr_NO2)) + call accsdm(jsdm_nitr_N2O_prod ,extNsed_diagnostics(1,1,1,ised_nitr_N2O_prod)) + call accsdm(jsdm_nitr_NH4_OM ,extNsed_diagnostics(1,1,1,ised_nitr_NH4_OM)) + call accsdm(jsdm_nitr_NO2_OM ,extNsed_diagnostics(1,1,1,ised_nitr_NO2_OM)) + call accsdm(jsdm_denit_NO3 ,extNsed_diagnostics(1,1,1,ised_denit_NO3)) + call accsdm(jsdm_denit_NO2 ,extNsed_diagnostics(1,1,1,ised_denit_NO2)) + call accsdm(jsdm_denit_N2O ,extNsed_diagnostics(1,1,1,ised_denit_N2O)) + call accsdm(jsdm_DNRA_NO2 ,extNsed_diagnostics(1,1,1,ised_DNRA_NO2)) + call accsdm(jsdm_anmx_N2_prod ,extNsed_diagnostics(1,1,1,ised_anmx_N2_prod)) + call accsdm(jsdm_anmx_OM_prod ,extNsed_diagnostics(1,1,1,ised_anmx_OM_prod)) + call accsdm(jsdm_remin_aerob ,extNsed_diagnostics(1,1,1,ised_remin_aerob)) + call accsdm(jsdm_remin_sulf ,extNsed_diagnostics(1,1,1,ised_remin_sulf)) + +#endif ! Write output if requested do l=1,nbgc @@ -487,9 +643,12 @@ subroutine accfields(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask) enddo atmflx=0. ! nullifying atm flux here to have zero fluxes for stepwise inventory fluxes - ndepflx=0. + ndepnoyflx=0. oalkflx=0. rivinflx=0. +#ifdef extNcycle + ndepnhxflx=0. +#endif end subroutine accfields diff --git a/hamocc/mo_aufr_bgc.F90 b/hamocc/mo_aufr_bgc.F90 index 8707ea62..c981be8d 100644 --- a/hamocc/mo_aufr_bgc.F90 +++ b/hamocc/mo_aufr_bgc.F90 @@ -84,7 +84,8 @@ subroutine aufr_bgc(kpie,kpje,kpke,ntr,ntrbgc,itrbgc,trc,kplyear,kplmon,kplday,o use_BOXATM,use_BROMO,use_CFC,use_natDIC,use_sedbypass use mo_param1_bgc, only: ialkali,ian2o,iano3,icalc,idet,idicsat, & idms,idoc,ifdust,igasnit,iiron,iopal,ioxygen,iphosph,iphy, & - iprefalk,iprefdic,iprefo2,iprefpo4,isco212,isilica,izoo,nocetra, & + iprefalk,iprefdic,iprefo2,iprefpo4,iprefsilica, & + isco212,isilica,izoo,nocetra, & iadust,inos,iatmco2,iatmn2,iatmo2,ibromo,icfc11,icfc12,isf6, & icalc13,icalc14,idet13,idet14,idoc13,idoc14,iphy13,iphy14, & isco213,isco214,izoo13,izoo14,safediv, & @@ -97,7 +98,9 @@ subroutine aufr_bgc(kpie,kpje,kpke,ntr,ntrbgc,itrbgc,trc,kplyear,kplmon,kplday,o use mo_intfcblom, only: sedlay2,powtra2,burial2,atm2 use mo_param_bgc, only: bifr13_ini,bifr14_ini,c14fac,re1312,re14to,prei13,prei14 use mo_netcdf_bgcrw, only: read_netcdf_var - +#ifdef extNcycle + use mo_param1_bgc, only: ianh4,iano2,ipownh4,ipown2o,ipowno2 +#endif ! Arguments integer, intent(in) :: kpie ! 1st dimension of model grid. integer, intent(in) :: kpje ! 2nd dimension of model grid. @@ -120,7 +123,7 @@ subroutine aufr_bgc(kpie,kpje,kpke,ntr,ntrbgc,itrbgc,trc,kplyear,kplmon,kplday,o integer :: restday ! day of restart file integer :: restdtoce ! time step number from bgc ocean file integer :: idate(5),i,j,k - logical :: lread_cfc,lread_nat,lread_iso,lread_atm,lread_bro + logical :: lread_cfc,lread_nat,lread_iso,lread_atm,lread_bro,lread_extn,lread_pref real :: rco213,rco214,alpha14,beta13,beta14,d13C_atm,d14cat integer :: ncid,ncstat,ncvarid @@ -320,6 +323,26 @@ subroutine aufr_bgc(kpie,kpje,kpke,ntr,ntrbgc,itrbgc,trc,kplyear,kplmon,kplday,o endif endif +! Find out whether to restart extended nitrogen cycle +#ifdef extNcycle + lread_extn=.true. + if(IOTYPE==0) then + if(mnproc==1) ncstat=nf90_inq_varid(ncid,'anh4',ncvarid) + call xcbcst(ncstat) + if(ncstat.ne.nf90_noerr) lread_extn=.false. + else if(IOTYPE==1) then +#ifdef PNETCDF + ncstat=nfmpi_inq_varid(ncid,'anh4',ncvarid) + if(ncstat.ne.nf_noerr) lread_extn=.false. +#endif + endif + if(mnproc==1 .and. .not. lread_extn) then + write(io_stdo_bgc,*) ' ' + write(io_stdo_bgc,*) 'AUFR_BGC info: extended nitrogen cycle tracer not in restart file ' + write(io_stdo_bgc,*) 'Initialising extended nitrogen cycle from scratch' + endif +#endif + ! Find out whether to restart atmosphere if (use_BOXATM) then lread_atm=.true. @@ -339,6 +362,24 @@ subroutine aufr_bgc(kpie,kpje,kpke,ntr,ntrbgc,itrbgc,trc,kplyear,kplmon,kplday,o write(io_stdo_bgc,*) ' Initialising atmosphere from scratch ' endif endif + + lread_pref=.true. + if(IOTYPE==0) then + if(mnproc==1) ncstat=nf90_inq_varid(ncid,'prefsilica',ncvarid) + call xcbcst(ncstat) + if(ncstat.ne.nf90_noerr) lread_pref=.false. + else if(IOTYPE==1) then +#ifdef PNETCDF + ncstat=nfmpi_inq_varid(ncid,'prefsilica',ncvarid) + if(ncstat.ne.nf_noerr) lread_pref=.false. +#endif + endif + if(mnproc==1 .and. .not. lread_pref) then + write(io_stdo_bgc,*) ' ' + write(io_stdo_bgc,*) 'AUFR_BGC info: preformed silica not in restart file ' + write(io_stdo_bgc,*) 'Initialising preformed tracer from scratch' + endif + ! ! Read restart data : ocean aquateous tracer ! @@ -364,6 +405,9 @@ subroutine aufr_bgc(kpie,kpje,kpke,ntr,ntrbgc,itrbgc,trc,kplyear,kplmon,kplday,o call read_netcdf_var(ncid,'prefalk',locetra(1,1,1,iprefalk),2*kpke,0,iotype) call read_netcdf_var(ncid,'prefdic',locetra(1,1,1,iprefdic),2*kpke,0,iotype) call read_netcdf_var(ncid,'dicsat',locetra(1,1,1,idicsat),2*kpke,0,iotype) + if(lread_pref) then + call read_netcdf_var(ncid,'prefsilica',locetra(1,1,1,iprefsilica),2*kpke,0,iotype) + endif if (use_cisonew .and. lread_iso) then call read_netcdf_var(ncid,'sco213',locetra(1,1,1,isco213),2*kpke,0,iotype) @@ -404,6 +448,13 @@ subroutine aufr_bgc(kpie,kpje,kpke,ntr,ntrbgc,itrbgc,trc,kplyear,kplmon,kplday,o if (use_BROMO .and. lread_bro) then call read_netcdf_var(ncid,'bromo',locetra(1,1,1,ibromo),2*kpke,0,iotype) endif +#ifdef extNcycle + if(lread_extn) then + call read_netcdf_var(ncid,'anh4',locetra(1,1,1,ianh4),2*kpke,0,iotype) + call read_netcdf_var(ncid,'ano2',locetra(1,1,1,iano2),2*kpke,0,iotype) + endif +#endif + ! ! Read restart data : diagnostic ocean fields (needed for bit to bit reproducability) ! @@ -443,6 +494,13 @@ subroutine aufr_bgc(kpie,kpje,kpke,ntr,ntrbgc,itrbgc,trc,kplyear,kplmon,kplday,o call read_netcdf_var(ncid,'powc13',powtra2(1,1,1,ipowc13),2*ks,0,iotype) call read_netcdf_var(ncid,'powc14',powtra2(1,1,1,ipowc14),2*ks,0,iotype) endif +#ifdef extNcycle + IF(lread_extn) THEN + CALL read_netcdf_var(ncid,'pownh4',powtra2(1,1,1,ipownh4),2*ks,0,iotype) + CALL read_netcdf_var(ncid,'pown2o',powtra2(1,1,1,ipown2o),2*ks,0,iotype) + CALL read_netcdf_var(ncid,'powno2',powtra2(1,1,1,ipowno2),2*ks,0,iotype) + ENDIF +#endif endif ! ! Read restart data: atmosphere diff --git a/hamocc/mo_aufw_bgc.F90 b/hamocc/mo_aufw_bgc.F90 index ab9b13c6..20fec7cf 100644 --- a/hamocc/mo_aufw_bgc.F90 +++ b/hamocc/mo_aufw_bgc.F90 @@ -85,8 +85,11 @@ subroutine aufw_bgc(kpie,kpje,kpke,ntr,ntrbgc,itrbgc,trc, idoc14,iphy13,iphy14,isco213,isco214,izoo13,izoo14,issso13,issso14, & isssc13,isssc14,ipowc13,ipowc14,iatmnco2,iatmc13,iatmc14,inatalkali, & inatcalc,inatsco212,ipowaal,ipowaic,ipowaox,ipowaph,ipowasi,ipown2, & - ipowno3,isssc12,issso12,issssil,issster + ipowno3,isssc12,issso12,issssil,issster,iprefsilica use mo_netcdf_bgcrw,only: write_netcdf_var,netcdf_def_vardb +#ifdef extNcycle + use mo_param1_bgc, only: ianh4,iano2,ipownh4,ipown2o,ipowno2 +#endif ! Arguments integer, intent(in) :: kpie ! 1st dimension of model grid. @@ -436,6 +439,9 @@ subroutine aufw_bgc(kpie,kpje,kpke,ntr,ntrbgc,itrbgc,trc, call NETCDF_DEF_VARDB(ncid,7,'prefpo4',3,ncdimst,ncvarid, & & 6,'mol/kg',19,'Preformed phosphate',rmissing,28,io_stdo_bgc) + call NETCDF_DEF_VARDB(ncid,10,'prefsilica',3,ncdimst,ncvarid, & + & 6,'mol/kg',16,'Preformed silica',rmissing,28,io_stdo_bgc) + call NETCDF_DEF_VARDB(ncid,7,'prefalk',3,ncdimst,ncvarid, & & 6,'mol/kg',20,'Preformed alkalinity',rmissing,29,io_stdo_bgc) @@ -513,6 +519,13 @@ subroutine aufw_bgc(kpie,kpje,kpke,ntr,ntrbgc,itrbgc,trc, call NETCDF_DEF_VARDB(ncid,5,'bromo',3,ncdimst,ncvarid, & & 6,'mol/kg',9,'Bromoform',rmissing,47,io_stdo_bgc) endif +#ifdef extNcycle + call NETCDF_DEF_VARDB(ncid,4,'anh4',3,ncdimst,ncvarid, & + & 6,'mol/kg',18,'Dissolved ammonium',rmissing,54,io_stdo_bgc) + + call NETCDF_DEF_VARDB(ncid,4,'ano2',3,ncdimst,ncvarid, & + & 6,'mol/kg',17,'Dissolved nitrite',rmissing,55,io_stdo_bgc) +#endif ! ! Define variables : diagnostic ocean fields @@ -608,9 +621,19 @@ subroutine aufw_bgc(kpie,kpje,kpke,ntr,ntrbgc,itrbgc,trc, call NETCDF_DEF_VARDB(ncid,6,'powc14',3,ncdimst,ncvarid, & & 9,'kmol/m**3',25,'Sediment pore water DIC14',rmissing,86,io_stdo_bgc) - endif +#ifdef extNcycle + call NETCDF_DEF_VARDB(ncid,6,'pownh4',3,ncdimst,ncvarid, & + & 9,'kmol/m**3',34,'Sediment pore water ammonium (NH4)',rmissing,79,io_stdo_bgc) + + call NETCDF_DEF_VARDB(ncid,6,'pown2o',3,ncdimst,ncvarid, & + & 9,'kmol/m**3',39,'Sediment pore water nitrous oxide (N2O)',rmissing,79,io_stdo_bgc) + + call NETCDF_DEF_VARDB(ncid,6,'powno2',3,ncdimst,ncvarid, & + & 9,'kmol/m**3',33,'Sediment pore water nitrite (NO2)',rmissing,79,io_stdo_bgc) +#endif + if((mnproc==1 .and. IOTYPE==0) .OR. IOTYPE==1) then ncdimst(1) = nclonid ncdimst(2) = nclatid @@ -743,6 +766,7 @@ subroutine aufw_bgc(kpie,kpje,kpke,ntr,ntrbgc,itrbgc,trc, call write_netcdf_var(ncid,'iron',locetra(1,1,1,iiron),2*kpke,0) call write_netcdf_var(ncid,'prefo2',locetra(1,1,1,iprefo2),2*kpke,0) call write_netcdf_var(ncid,'prefpo4',locetra(1,1,1,iprefpo4),2*kpke,0) + call write_netcdf_var(ncid,'prefsilica',locetra(1,1,1,iprefsilica),2*kpke,0) call write_netcdf_var(ncid,'prefalk',locetra(1,1,1,iprefalk),2*kpke,0) call write_netcdf_var(ncid,'prefdic',locetra(1,1,1,iprefdic),2*kpke,0) call write_netcdf_var(ncid,'dicsat',locetra(1,1,1,idicsat),2*kpke,0) @@ -777,6 +801,10 @@ subroutine aufw_bgc(kpie,kpje,kpke,ntr,ntrbgc,itrbgc,trc, if (use_BROMO) then call write_netcdf_var(ncid,'bromo',locetra(1,1,1,ibromo),2*kpke,0) endif +#ifdef extNcycle + call write_netcdf_var(ncid,'anh4',locetra(1,1,1,ianh4),2*kpke,0) + call write_netcdf_var(ncid,'ano2',locetra(1,1,1,iano2),2*kpke,0) +#endif ! ! Write restart data : diagtnostic ocean fields @@ -820,6 +848,11 @@ subroutine aufw_bgc(kpie,kpje,kpke,ntr,ntrbgc,itrbgc,trc, call write_netcdf_var(ncid,'powc13',powtra2(1,1,1,ipowc13),2*ks,0) call write_netcdf_var(ncid,'powc14',powtra2(1,1,1,ipowc14),2*ks,0) endif +#ifdef extNcycle + call write_netcdf_var(ncid,'pownh4',powtra2(1,1,1,ipownh4),2*ks,0) + call write_netcdf_var(ncid,'pown2o',powtra2(1,1,1,ipown2o),2*ks,0) + call write_netcdf_var(ncid,'powno2',powtra2(1,1,1,ipowno2),2*ks,0) +#endif endif ! ! Write restart data: atmosphere. diff --git a/hamocc/mo_bgcmean.F90 b/hamocc/mo_bgcmean.F90 index 5d66985d..e2969f06 100644 --- a/hamocc/mo_bgcmean.F90 +++ b/hamocc/mo_bgcmean.F90 @@ -113,7 +113,7 @@ module mo_bgcmean & SRF_ATMBROMO =0 ,SRF_BROMO =0 ,SRF_BROMOFX =0 , & & SRF_ANH4 =0 ,SRF_ANO2 =0 ,SRF_ANH3FX =0 , & & SRF_PN2OM =0 ,SRF_PNH3 =0 ,SRF_ATMNH3 =0 , & - & SRF_ATMN2O =0 , + & SRF_ATMN2O =0 , & & INT_BROMOPRO =0 ,INT_BROMOUV =0 , & & INT_PHOSY =0 ,INT_NFIX =0 ,INT_DNIT =0 , & & FLX_NDEPNOY =0 ,FLX_NDEPNHX =0 ,FLX_OALK =0 , & @@ -1433,7 +1433,7 @@ subroutine alloc_mem_bgcmean(kpie,kpje,kpke) if (SDM_remin_sulf(n) > 0) i_bsc_sed=i_bsc_sed+1 jsdm_remin_sulf(n)=i_bsc_sed*min(1,SDM_remin_sulf(n)) enddo - +#endif nbgcm2d = i_bsc_m2d+i_atm_m2d nbgcm3d = i_bsc_m3d nbgcm3dlvl = ilvl_bsc_m3d diff --git a/hamocc/mo_carbch.F90 b/hamocc/mo_carbch.F90 index 8188610f..63b5ba71 100644 --- a/hamocc/mo_carbch.F90 +++ b/hamocc/mo_carbch.F90 @@ -249,7 +249,7 @@ subroutine alloc_mem_carbch(kpie,kpje,kpke) write(io_stdo_bgc,*)'First dimension : ',kpie write(io_stdo_bgc,*)'Second dimension : ',kpje endif - allocat (pn2om(kpie,kpje),stat=errstat) + allocate (pn2om(kpie,kpje),stat=errstat) if(errstat.ne.0) stop 'not enough memory pn2om' pn2om(:,:) = 0.0 diff --git a/hamocc/mo_carchm.F90 b/hamocc/mo_carchm.F90 index c7fdb6f7..72da6871 100644 --- a/hamocc/mo_carchm.F90 +++ b/hamocc/mo_carchm.F90 @@ -68,8 +68,8 @@ subroutine carchm(kpie,kpje,kpke,kbnd,pdlxp,pdlyp,pddpo,prho,pglat,omask,psicomo use mo_carbch, only: atm,atmflx,co2fxd,co2fxu,co2star,co3,hi,keqb,kwco2sol, & ocetra,omegaa,omegac,pco2d,satn2o,satoxy, & - pco2m,kwco2d,co2sold,co2solm - use mo_chemcon, only: al1,al2,al3,al4,an0,an1,an2,an3,an4,an5,an6,atn2o, & + pco2m,kwco2d,co2sold,co2solm,pn2om + use mo_chemcon, only: al1,al2,al3,al4,an0,an1,an2,an3,an4,an5,an6, & bl1,bl2,bl3,calcon,ox0,ox1,ox2,ox3,ox4,ox5,ox6, & oxyco,tzero use mo_control_bgc, only: dtbgc,use_cisonew,use_natDIC,use_CFC,use_BROMO, & @@ -83,13 +83,18 @@ subroutine carchm(kpie,kpje,kpke,kbnd,pdlxp,pdlyp,pddpo,prho,pglat,omask,psicomo iatmnco2,inatalkali,inatcalc,inatsco212, & ks,issso14,isssc14,ipowc14, & iatmbromo,ibromo - use mo_param_bgc, only: c14dec,atm_co2_nat + use mo_param_bgc, only: c14dec,atm_co2_nat,atm_n2o use mo_vgrid, only: dp_min,kmle,kbo,ptiestu use mo_carbch, only: atm_cfc11_nh,atm_cfc11_sh,atm_cfc12_nh,atm_cfc12_sh, & atm_sf6_nh,atm_sf6_sh, & co213fxd,co213fxu,co214fxd,co214fxu, & nathi,natco3,natpco2d,natomegaa,natomegac use mo_sedmnt, only: sedlay,powtra,burial +#ifdef extNcycle + use mo_carbch, only: pnh3 + use mo_param1_bgc, only: iatmnh3,ianh4 + use mo_chemcon, only: SV0_air,SV1_air,SV2_air,SV3_air,SV4_air,SD0_air,SD1_air,SD2_air,SD3_air,Vb_nh3,M_nh3,kappa +#endif ! Arguments integer, intent(in) :: kpie ! 1st dimension of model grid. @@ -117,7 +122,7 @@ subroutine carchm(kpie,kpje,kpke,kbnd,pdlxp,pdlyp,pddpo,prho,pglat,omask,psicomo real :: scco2,sco2,scn2,scdms,scn2o real :: xconvxa real :: oxflux,niflux,dmsflux,n2oflux - real :: ato2,atn2,atco2,pco2 + real :: ato2,atn2,atco2,pco2,atn2ov real :: oxy,ani,anisa real :: rrho,t,t2,t3,t4,tk,tk100,prb,s,rs real :: Kh,Khd,K1,K2,Kb,K1p,K2p,K3p,Ksi,Kw,Ks1,Kf,Kspc,Kspa @@ -135,6 +140,11 @@ subroutine carchm(kpie,kpje,kpke,kbnd,pdlxp,pdlyp,pddpo,prho,pglat,omask,psicomo real :: atco213,atco214,pco213,pco214 ! cisonew real :: frac_k,frac_aqg,frac_dicg ! cisonew real :: flx_bromo,sch_bromo,kw_bromo,a_bromo,atbrf,Kb1,lsub ! BROMO +#ifdef extNcycle + real :: flx_nh3,sch_nh3_a,sch_nh3_w,kw_nh3,ka_nh3,atnh3,diff_nh3_a,diff_nh3_w,mu_air,mu_w,p_dbar,rho_air + real :: h_nh3,hstar_nh3,pKa_nh3,eps_safe,Kh_nh3,cD_wind,u_star + eps_safe = EPSILON(1.) +#endif ! set variables for diagnostic output to zero atmflx (:,:,:)=0. @@ -151,6 +161,7 @@ subroutine carchm(kpie,kpje,kpke,kbnd,pdlxp,pdlyp,pddpo,prho,pglat,omask,psicomo satoxy (:,:,:)=0. omegaA (:,:,:)=0. omegaC (:,:,:)=0. + pn2om (:,:)=0. if (use_cisonew) then co213fxd (:,:)=0. co213fxu (:,:)=0. @@ -163,12 +174,15 @@ subroutine carchm(kpie,kpje,kpke,kbnd,pdlxp,pdlyp,pddpo,prho,pglat,omask,psicomo natomegaA(:,:,:)=0. natomegaC(:,:,:)=0. endif +#ifdef extNcycle + pnh3 (:,:)=0. +#endif !$OMP PARALLEL DO PRIVATE(t,t2,t3,t4,tk,tk100,s,rs,prb,Kh,Khd,K1,K2 & !$OMP ,Kb,K1p,K2p,K3p,Ksi,Kw,Ks1,Kf,Kspc,Kspa,tc,ta,sit,pt,ah1,ac & !$OMP ,cu,cb,cc,pco2,rpp0,scco2,scdms,sco2,oxy,ani,anisa,Xconvxa & - !$OMP ,kwco2,kwdms,kwo2,atco2,ato2,atn2,fluxd,fluxu,oxflux,tc_sat & - !$OMP ,niflux,n2oflux,dmsflux,omega,supsat,undsa,dissol & + !$OMP ,kwco2,kwdms,kwo2,atco2,ato2,atn2,atn2ov,fluxd,fluxu,oxflux & + !$OMP ,tc_sat,niflux,n2oflux,dmsflux,omega,supsat,undsa,dissol & !$OMP ,sch_11,sch_12,sch_sf,kw_11,kw_12,kw_sf,a_11,a_12,a_sf,flx11 & !$OMP ,flx12,flxsf,atm_cfc11,atm_cfc12,atm_sf6,fact & !$OMP ,natcu,natcb,natcc,natpco2,natfluxd,natfluxu,natomega & @@ -176,6 +190,11 @@ subroutine carchm(kpie,kpje,kpke,kbnd,pdlxp,pdlyp,pddpo,prho,pglat,omask,psicomo !$OMP ,atco213,atco214,rco213,rco214,pco213,pco214,frac_aqg & !$OMP ,frac_dicg,flux13d,flux13u,flux14d,flux14u,dissol13,dissol14 & !$OMP ,flx_bromo,sch_bromo,kw_bromo,a_bromo,atbrf,Kb1,lsub & +#ifdef extNcycle +!$OMP ,flx_nh3,sch_nh3_a,sch_nh3_w,kw_nh3,ka_nh3,atnh3 & +!$OMP ,diff_nh3_a,diff_nh3_w,mu_air,mu_w,p_dbar,rho_air,h_nh3 & +!$OMP ,hstar_nh3,pKa_nh3,eps_safe,Kh_nh3,cD_wind,u_star & +#endif !$OMP ,k,j,i,rrho,scn2,scn2o,kwn2,kwn2o) do k=1,kpke do j=1,kpje @@ -266,7 +285,37 @@ subroutine carchm(kpie,kpje,kpke,kbnd,pdlxp,pdlyp,pddpo,prho,pglat,omask,psicomo ! (2003; GBC) sch_bromo = 4662.8 - 319.45*t + 9.9012*t2 - 0.1159*t3 endif - +#ifdef extNcycle + ! Tsilingiris 2008 Eq.(45) for moist air (kg/m s) + mu_air = SV0_air + SV1_air*t + SV2_air*t2 + SV3_air*t3 + SV4_air*t4 + + ! Tsinlingiris(44) moist air density (kg/m3) + rho_air = SD0_air + SD1_air*t + SD2_air*t2 + SD3_air*t3 + + ! molecular viscosity of sea water + ! (Matthaeus 1972, Richards 1998,assuming salinity s in per mille = ~PSU) + p_dbar = ppao(i,j)*1e-4 ! sea level pressure (Pa *1e-5 -> bar *10-> dbar + mu_w = 1.79e-2 - 6.1299e-4 * t + 1.4467e-5 * t2 - 1.6826e-7 * t3 & + & - 1.8266e-7 * p_dbar + 9.8972e-12 * p_dbar*p_dbar + 2.4727e-5 * s & + & + s * (4.8429e-7 * t - 4.7172e-8 * t2 + 7.5986e-10 * t3) & + & + s * (1.3817e-8 * t - 2.6363e-10 * t2) & + & - p_dbar*p_dbar * (6.3255e-13 * t - 1.2116e-14 * t2) + mu_w = mu_w * 0.1 ! conversion from g/(cm s) to kg/(m s) + + ! diffusion coeff in air (m2/s) Fuller 1966 / Johnson 2010 + ! division by pressure: ppao [Pa]; in Fuller, p is a factor for denominator [atm] + diff_nh3_a = 1e-7 * (t+273.15)**1.75 * M_nh3 / (ppao(i,j)/101325.0) + + ! Johnson 2010 - (34) cm2/s -> m2/s (1e-8*1e-4=1e-12) + ! closer to fit for Li & Gregory of: 9.874e-6*exp(2.644e-2*t) + ! mu_w*1000: kg/(m s) -> cPoise as in Eq.(34) of Johnson 2010 + diff_nh3_w = 1.25e-12*(t+273.15)**1.52 *(mu_w*1000.)**(9.58/Vb_nh3 -1.12)*(Vb_nh3**(-0.19) - 0.292) + + ! Schmidt number air phase + sch_nh3_a = mu_air /(diff_nh3_a * rho_air) + ! Schmidt number water phase + sch_nh3_w = mu_w /(diff_nh3_w * rrho * 1000.) +#endif ! solubility of N2 (Weiss, R.F. 1970, Deep-Sea Res., 17, 721-735) for moist air ! at 1 atm; multiplication with oxyco converts to kmol/m^3/atm ani=an0+an1/tk100+an2*alog(tk100)+an3*tk100+s*(an4+an5*tk100+an6*tk100**2) @@ -298,7 +347,14 @@ subroutine carchm(kpie,kpje,kpke,kbnd,pdlxp,pdlyp,pddpo,prho,pglat,omask,psicomo !Henry's law constant [dimensionless] for Bromoform from Quack and Wallace (2003; GBC) a_bromo = exp(13.16 - 4973*(1/tk)) endif - +#ifdef extNcycle + !Henry number for NH3 (Paulot et al. 2015, ) + h_nh3 = (17.93*(t+273.15)/273.15 * exp(4092./(t+273.15) - 9.7))**(-1) + ! Dissociation constant (Paulot et al. 2015, Bell 2007/2008) + pKa_nh3 = 10.0423 - 3.15536e-2*t + 3.071e-3*s + ! effective gas-over-liquid Henry constant (Paulot et al. 2015) + hstar_nh3 = h_nh3/(1. + 10.**(log10(hi(i,j,k))+pKa_nh3)) +#endif ! Transfer (piston) velocity kw according to Wanninkhof (2014), in units of ms-1 Xconvxa = 6.97e-07 ! Wanninkhof's a=0.251 converted from [cm hr-1]/[m s-1]^2 to [ms-1]/[m s-1]^2 kwco2 = (1.-psicomo(i,j)) * Xconvxa * pfu10(i,j)**2*(660./scco2)**0.5 @@ -317,6 +373,22 @@ subroutine carchm(kpie,kpje,kpke,kbnd,pdlxp,pdlyp,pddpo,prho,pglat,omask,psicomo kw_bromo=(1.-psicomo(i,j)) * 1.e-2/3600. * & & (0.222*pfu10(i,j)**2+0.33*pfu10(i,j))*(660./sch_bromo)**0.5 endif +#ifdef extNcycle + ! Paulot et al. 2015 / Johnson 2010 + ! friction velocity of wind (m/s) + u_star = pfu10(i,j)*sqrt(6.1e-4 + 6.3e-5*pfu10(i,j)) + ! wind drag coeff (-) + cD_wind = (u_star / (pfu10(i,j) + eps_safe))**2. + ! gas transfer velocity on gas phase side (m/s) + ka_nh3 = 1e-3 + u_star/ (13.3*sch_nh3_a + (eps_safe + cD_wind)**(-0.5) - 5. + log(sch_nh3_a)/(2.*kappa)) + ! gas transfer velocity on liquid phase side (m/s) Nightingale 2000b - 3600*100: cm/h -> m/s + kw_nh3 = (0.24*pfu10(i,j)**2 + 0.061*pfu10(i,j))*sqrt(600./sch_nh3_w)/360000. + + ! total effective gas transfer velocity (m/s) + Kh_nh3 = (1./(ka_nh3 + eps_safe) + hstar_nh3/(kw_nh3 + eps_safe))**(-1.) + ! account for ice + Kh_nh3 = (1.-psicomo(i,j)) * Kh_nh3 +#endif atco2 = atm(i,j,iatmco2) ato2 = atm(i,j,iatmo2) @@ -328,6 +400,12 @@ subroutine carchm(kpie,kpje,kpke,kbnd,pdlxp,pdlyp,pddpo,prho,pglat,omask,psicomo if (use_BROMO) then atbrf = atm(i,j,iatmbromo) endif +#ifdef extNcycle + atnh3 = atm(i,j,iatmnh3) + atn2ov = atm(i,j,iatmn2o) +#else + atn2ov = atm_n2o +#endif ! Ratio P/P_0, where P is the local SLP and P_0 is standard pressure (1 atm). This is ! used in all surface flux calculations where atmospheric concentration is given as a @@ -385,7 +463,9 @@ subroutine carchm(kpie,kpje,kpke,kbnd,pdlxp,pdlyp,pddpo,prho,pglat,omask,psicomo niflux=kwn2*dtbgc*(ocetra(i,j,1,igasnit)-anisa*(atn2/802000)*rpp0) ocetra(i,j,1,igasnit)=ocetra(i,j,1,igasnit)-niflux/pddpo(i,j,1) ! Surface flux of laughing gas (same piston velocity as for O2 and N2) - n2oflux=kwn2o*dtbgc*(ocetra(i,j,1,ian2o)-satn2o(i,j)*atn2o*rpp0) + n2oflux=kwn2o*dtbgc*(ocetra(i,j,1,ian2o)-satn2o(i,j)*atn2ov*1e-12*rpp0) + ! pN2O under moist air assumption at normal pressure + pn2om(i,j) = 1e9 * ocetra(i,j,1,ian2o)/satn2o(i,j) ocetra(i,j,1,ian2o)=ocetra(i,j,1,ian2o)-n2oflux/pddpo(i,j,1) if (use_CFC) then ! Surface fluxes for CFC: eqn. (1a) in ocmip2 howto doc(hyc) @@ -441,12 +521,20 @@ subroutine carchm(kpie,kpje,kpke,kbnd,pdlxp,pdlyp,pddpo,prho,pglat,omask,psicomo ocetra(i,j,1,ibromo) = ocetra(i,j,1,ibromo) + flx_bromo/pddpo(i,j,1) atmflx(i,j,iatmbromo) = -flx_bromo endif +#ifdef extNcycle + ! surface flux NH3: STILL REQUIRES TO CHECK CONVERSION FACTOR FOR atNH3 (currently assumed atNH3 in pptv) + flx_nh3 = Kh_nh3*dtbgc*(atnh3*1e-12*ppao(i,j)*1e-5/(tk*0.08314510) - hstar_nh3*ocetra(i,j,1,ianh4)) + ocetra(i,j,1,ianh4) = ocetra(i,j,1,ianh4) + flx_nh3/pddpo(i,j,1) + + ! pNH3 in natm + pnh3(i,j) = hstar_nh3*ocetra(i,j,1,ianh4) * 8.20573660809596e-5 * (t+273.15) * 1e12 +#endif ! Save surface fluxes atmflx(i,j,iatmco2)=fluxu-fluxd atmflx(i,j,iatmo2)=oxflux atmflx(i,j,iatmn2)=niflux - atmflx(i,j,iatmn2o)=n2oflux + atmflx(i,j,iatmn2o)=n2oflux ! positive to atmosphere [kmol N2O m-2 timestep-1] if (use_cisonew) then atmflx(i,j,iatmc13)=flux13u-flux13d atmflx(i,j,iatmc14)=flux14u-flux14d @@ -459,7 +547,9 @@ subroutine carchm(kpie,kpje,kpke,kbnd,pdlxp,pdlyp,pddpo,prho,pglat,omask,psicomo if (use_natDIC) then atmflx(i,j,iatmnco2)=natfluxu-natfluxd endif - +#ifdef extNcycle + atmflx(i,j,iatmnh3)=-flx_nh3 ! positive to atmosphere [kmol NH3 m-2 timestep-1] +#endif ! Save up- and downward components of carbon fluxes for output co2fxd(i,j) = fluxd co2fxu(i,j) = fluxu diff --git a/hamocc/mo_control_bgc.F90 b/hamocc/mo_control_bgc.F90 index a1f9b4a8..9ea44479 100644 --- a/hamocc/mo_control_bgc.F90 +++ b/hamocc/mo_control_bgc.F90 @@ -66,7 +66,7 @@ module mo_control_bgc integer :: sedspin_yr_e = -1 ! end year for sediment spin-up integer :: sedspin_ncyc = -1 ! sediment spin-up sub-cycles character(len=64) :: ocn_co2_type ! indicates co2 coupling to an active atm - ! model if set to 'diagnostic' + ! model if set to 'diagnostic' ! or 'prognostic' ! Logical switches set via namelist config_bgc @@ -81,6 +81,7 @@ module mo_control_bgc logical :: use_FB_BGC_OCE = .false. logical :: use_BOXATM = .false. logical :: use_sedbypass = .false. + logical :: use_extNcycle = .false. contains diff --git a/hamocc/mo_cyano.F90 b/hamocc/mo_cyano.F90 index 868ea204..705abfc4 100644 --- a/hamocc/mo_cyano.F90 +++ b/hamocc/mo_cyano.F90 @@ -44,12 +44,15 @@ subroutine cyano(kpie,kpje,kpke,kbnd,pddpo,omask,ptho) ! - added reduction of alkalinity through N-fixation !*********************************************************************************************** - use mo_vgrid, only: kmle + use mo_vgrid, only: kmle,kwrbioz use mo_carbch, only: ocetra use mo_param_bgc, only: bluefix,rnit,tf0,tf1,tf2,tff use mo_param1_bgc, only: ialkali,iano3,igasnit,iphosph,ioxygen,inatalkali use mo_biomod, only: intnfix - use mo_control_bgc, only: use_natDIC + use mo_control_bgc, only: use_natDIC,leuphotic_cya +#ifdef extNcycle + use mo_param1_bgc, only: ianh4 +#endif ! Arguments integer, intent(in) :: kpie ! 1st dimension of model grid. @@ -62,46 +65,64 @@ subroutine cyano(kpie,kpje,kpke,kbnd,pddpo,omask,ptho) ! Local variables integer :: i,j,k - real :: oldocetra,dano3 + real :: oldocetra,anavail,dansp,dox,dalk real :: ttemp,nfixtfac intnfix(:,:)=0.0 + ! ! N-fixation by cyano bacteria (followed by remineralisation and nitrification), + ! or, for the extended nitrogen cycle only by remin to NH4), ! it is assumed here that this process is limited to the mixed layer ! do j=1,kpje do i=1,kpie if (omask(i,j).gt.0.5) then - do k=1,kmle(i,j) + do k=1,merge(kwrbioz(i,j),kmle(i,j),leuphotic_cya) ! if leuphotic_cya=.true., do bluefix only in euphotic zone if (ocetra(i,j,k,iano3) < (rnit*ocetra(i,j,k,iphosph))) then - - oldocetra = ocetra(i,j,k,iano3) - ttemp = min(40.,max(-3.,ptho(i,j,k))) - - ! Temperature dependence of nitrogen fixation, Kriest and Oschlies 2015. - nfixtfac = max(0.0,tf2*ttemp*ttemp + tf1*ttemp + tf0)/tff - - ocetra(i,j,k,iano3)=ocetra(i,j,k,iano3)*(1-bluefix*nfixtfac) & - & + bluefix*nfixtfac*rnit*ocetra(i,j,k,iphosph) - - dano3=ocetra(i,j,k,iano3)-oldocetra - - ocetra(i,j,k,igasnit)=ocetra(i,j,k,igasnit)-dano3*(1./2.) - - ! Note: to fix one mole N2 requires: N2+H2O+y*O2 = 2* HNO3 <-> y=2.5 mole O2. - ! I.e., to release one mole HNO3 = H+ + NO3- requires 1.25 mole O2 - ocetra(i,j,k,ioxygen)=ocetra(i,j,k,ioxygen)-dano3*1.25 - - ! Nitrogen fixation followed by remineralisation and nitrification decreases - ! alkalinity by 1 mole per mole nitrogen fixed (Wolf-Gladrow et al. 2007) - ocetra(i,j,k,ialkali)=ocetra(i,j,k,ialkali)-dano3 - if (use_natDIC) then - ocetra(i,j,k,inatalkali)=ocetra(i,j,k,inatalkali)-dano3 +#ifdef extNcycle + ! assuming nitrate and ammonium required for cyanobacteria growth (as bulk PP) + anavail = ocetra(i,j,k,iano3)+ocetra(i,j,k,ianh4) +#else + anavail = ocetra(i,j,k,iano3) +#endif + if(anavail < (rnit*ocetra(i,j,k,iphosph))) then + + ttemp = min(40.,max(-3.,ptho(i,j,k))) + + ! Temperature dependence of nitrogen fixation, Kriest and Oschlies 2015. + nfixtfac = MAX(0.0,tf2*ttemp*ttemp + tf1*ttemp + tf0)/tff + +#ifndef extNcycle + oldocetra = ocetra(i,j,k,iano3) + ocetra(i,j,k,iano3)=ocetra(i,j,k,iano3)*(1.-bluefix*nfixtfac) & + & +bluefix*nfixtfac*rnit*ocetra(i,j,k,iphosph) + dansp=ocetra(i,j,k,iano3)-oldocetra + ! Note: to fix one mole N2 requires: N2+H2O+y*O2 = 2* HNO3 <-> y=2.5 mole O2. + ! I.e., to release one mole HNO3 = H+ + NO3- requires 1.25 mole O2 + dox = -dansp*1.25 + ! Nitrogen fixation followed by remineralisation and nitrification decreases + ! alkalinity by 1 mole per mole nitrogen fixed (Wolf-Gladrow et al. 2007) + dalk = -dansp +#else + oldocetra = ocetra(i,j,k,ianh4) + ocetra(i,j,k,ianh4)=ocetra(i,j,k,ianh4)*(1.-bluefix*nfixtfac) & + & +bluefix*nfixtfac*rnit*ocetra(i,j,k,iphosph) + dansp=ocetra(i,j,k,ianh4)-oldocetra + dox = dansp*0.75 + dalk = dansp +#endif + ocetra(i,j,k,igasnit)=ocetra(i,j,k,igasnit)-dansp*(1./2.) + + ocetra(i,j,k,ioxygen)=ocetra(i,j,k,ioxygen)+dox + + ocetra(i,j,k,ialkali)=ocetra(i,j,k,ialkali)+dalk +#ifdef natDIC + ocetra(i,j,k,inatalkali)=ocetra(i,j,k,inatalkali)+dalk +#endif + + intnfix(i,j) = intnfix(i,j) + dansp*pddpo(i,j,k) endif - - intnfix(i,j) = intnfix(i,j) + (ocetra(i,j,k,iano3)-oldocetra)*pddpo(i,j,k) - endif enddo endif diff --git a/hamocc/mo_extNsediment.F90 b/hamocc/mo_extNsediment.F90 index 66274894..e4a8b282 100644 --- a/hamocc/mo_extNsediment.F90 +++ b/hamocc/mo_extNsediment.F90 @@ -44,7 +44,7 @@ MODULE mo_extNsediment !********************************************************************** use mo_param1_bgc, only: issso12,ipowaic,ipowaal,ipowaph,ipowaox,ipown2,ipowno3,ipownh4,ipown2o,ipowno2,ks use mo_vgrid, only: kbo - use mo_biomod, only: rnit,rcar,rnoi + use mo_param_bgc, only: rnit,rcar,rnoi use mo_control_bgc, only: io_stdo_bgc,dtb use mo_sedmnt, only: powtra,sedlay,porsol,porwat use mo_extNwatercol,only: rc2n,ro2utammo,ro2nnit,rnoxp,rnoxpi,rno2anmx,rno2anmxi,rnh4anmx, & @@ -132,7 +132,7 @@ subroutine extNsediment_param_init() & q10anh4nitr,Trefanh4nitr,bkoxamox,bkanh4nitr,bkamoxn2o,bkyamox,n2omaxy,n2oybeta, & & q10ano2nitr,Trefano2nitr,bkoxnitr,bkano2nitr,NOB2AOAy,rno2anmx,rnh4anmx use mo_m4ago, only: POM_remin_q10,POM_remin_Tref - use mo_biomod, only: bkox_drempoc + use mo_param_bgc, only: bkox_drempoc implicit none diff --git a/hamocc/mo_extNwatercol.F90 b/hamocc/mo_extNwatercol.F90 index ce618b3e..ed55341c 100644 --- a/hamocc/mo_extNwatercol.F90 +++ b/hamocc/mo_extNwatercol.F90 @@ -54,7 +54,8 @@ MODULE mo_extNwatercol use mo_control_bgc, only: io_stdo_bgc,dtb use mo_param1_bgc, only: ialkali,ianh4,iano2,ian2o,iano3,idet,igasnit,iiron,ioxygen,iphosph,isco212 use mo_carbch, only: ocetra - use mo_biomod, only: riron,rnit,rcar,rnoi, nitr_NH4,nitr_NO2,nitr_N2O_prod,nitr_NH4_OM,nitr_NO2_OM,denit_NO3,denit_NO2, & + use mo_param_bgc, only: riron,rnit,rcar,rnoi + use mo_biomod, only: nitr_NH4,nitr_NO2,nitr_N2O_prod,nitr_NH4_OM,nitr_NO2_OM,denit_NO3,denit_NO2, & & denit_N2O,DNRA_NO2,anmx_N2_prod,anmx_OM_prod implicit none diff --git a/hamocc/mo_hamocc4bcm.F90 b/hamocc/mo_hamocc4bcm.F90 index b6ef50a1..2e3cbe7b 100644 --- a/hamocc/mo_hamocc4bcm.F90 +++ b/hamocc/mo_hamocc4bcm.F90 @@ -27,7 +27,8 @@ module mo_hamocc4bcm subroutine hamocc4bcm(kpie,kpje,kpke,kbnd,kplyear,kplmon,kplday,kldtday,pdlxp,pdlyp,pddpo,prho, & pglat,omask, dust,rivin,ndep,oafx,pi_ph,pfswr,psicomo,ppao,pfu10,ptho,psao,& - patmco2,pflxco2,pflxdms,patmbromo,pflxbromo) + patmco2,pflxco2,pflxdms,patmbromo,pflxbromo, & + patmn2o,pflxn2o,patmnh3,pflxnh3,patmnhxdep,patmnoydep) !*********************************************************************************************** ! Main routine of iHAMOCC. @@ -53,8 +54,9 @@ subroutine hamocc4bcm(kpie,kpje,kpke,kbnd,kplyear,kplmon,kplday,kldtday,pdlxp,pd use mo_control_bgc, only: ldtrunbgc,dtbgc,ldtbgc,io_stdo_bgc,dtbgc,ndtdaybgc, & do_sedspinup,sedspin_yr_s,sedspin_yr_e,sedspin_ncyc, & use_BROMO, use_CFC, use_PBGC_CK_TIMESTEP, & - use_BOXATM, use_sedbypass,ocn_co2_type - use mo_param1_bgc, only: iatmco2,iatmdms,nocetra,nriv,iatmbromo + use_BOXATM, use_sedbypass,ocn_co2_type, & + do_ndep_coupled,do_n2onh3_coupled + use mo_param1_bgc, only: iatmco2,iatmdms,nocetra,nriv,iatmbromo,nndep,idepnoy use mo_vgrid, only: set_vgrid use mo_apply_fedep, only: apply_fedep use mo_apply_rivin, only: apply_rivin @@ -69,6 +71,10 @@ subroutine hamocc4bcm(kpie,kpje,kpke,kbnd,kplyear,kplmon,kplday,kldtday,pdlxp,pd use mo_cyano, only: cyano use mo_ocprod, only: ocprod use mo_carchm, only: carchm +#ifdef extNcycle + use mo_param1_bgc, only: iatmn2o,iatmnh3,idepnhx + use mo_chemcon, only: mw_nitrogen,mw_nh3,mw_n2o +#endif ! Arguments integer, intent(in) :: kpie ! 1st dimension of model grid. @@ -87,7 +93,7 @@ subroutine hamocc4bcm(kpie,kpje,kpke,kbnd,kplyear,kplmon,kplday,kldtday,pdlxp,pd real, intent(in) :: omask (kpie,kpje) ! land/ocean mask. real, intent(in) :: dust (kpie,kpje) ! dust deposition flux [kg/m2/month]. real, intent(in) :: rivin (kpie,kpje,nriv) ! riverine input [kmol m-2 yr-1]. - real, intent(in) :: ndep (kpie,kpje) ! nitrogen deposition [kmol m-2 yr-1]. + real, intent(inout):: ndep (kpie,kpje,nndep) ! nitrogen deposition [kmol m-2 yr-1]. real, intent(in) :: oafx (kpie,kpje) ! alkalinity flux from alkalinization [kmol m-2 yr-1] real, intent(in) :: pi_ph (kpie,kpje) ! pre-ind. pH climatology used for pH-dependent DMS fluxes [log10([H+])] real, intent(in) :: pfswr (1-kbnd:kpie+kbnd,1-kbnd:kpje+kbnd) ! solar radiation [W/m**2]. @@ -101,11 +107,18 @@ subroutine hamocc4bcm(kpie,kpje,kpke,kbnd,kplyear,kplmon,kplday,kldtday,pdlxp,pd real, intent(out) :: pflxdms(1-kbnd:kpie+kbnd,1-kbnd:kpje+kbnd) ! DMS flux [kg/m^2/s]. real, intent(in) :: patmbromo(1-kbnd:kpie+kbnd,1-kbnd:kpje+kbnd) ! atmospheric bromoform concentration [ppt] used in fully coupled mode. real, intent(out) :: pflxbromo(1-kbnd:kpie+kbnd,1-kbnd:kpje+kbnd) ! Bromoform flux [kg/m^2/s]. + real, intent(in) :: patmn2o(1-kbnd:kpie+kbnd,1-kbnd:kpje+kbnd) ! atmospheric nitrous oxide concentration [ppt] used in fully coupled mode. + real, intent(out) :: pflxn2o(1-kbnd:kpie+kbnd,1-kbnd:kpje+kbnd) ! Nitrous oxide flux [kg N2O m-2 s-1]. + real, intent(in) :: patmnh3(1-kbnd:kpie+kbnd,1-kbnd:kpje+kbnd) ! atmospheric ammonia concentration [ppt] used in fully coupled mode + real, intent(out) :: pflxnh3(1-kbnd:kpie+kbnd,1-kbnd:kpje+kbnd) ! Ammonia flux [kg NH3 m-2 s-1]. + real, intent(in) :: patmnhxdep(1-kbnd:kpie+kbnd,1-kbnd:kpje+kbnd) ! Atmospheric NHx deposition [kgN m-2 s-1] + real, intent(in) :: patmnoydep(1-kbnd:kpie+kbnd,1-kbnd:kpje+kbnd) ! Atmospheric NOy deposition [kgN m-2 s-1] ! Local variables integer :: i,j,k,l integer :: nspin,it logical :: lspin + real :: fatmndep if (mnproc.eq.1) then write(io_stdo_bgc,*) 'iHAMOCC',KLDTDAY,LDTRUNBGC,NDTDAYBGC @@ -164,6 +177,43 @@ subroutine hamocc4bcm(kpie,kpje,kpke,kbnd,kplyear,kplmon,kplday,kldtday,pdlxp,pd if (mnproc.eq.1) write (io_stdo_bgc,*) 'iHAMOCC: getting bromoform from atm' endif +#ifdef extNcycle +!$OMP PARALLEL DO PRIVATE(i) + if(do_n2onh3_coupled) then + do j=1,kpje + do i=1,kpie + if (patmn2o(i,j) > 0.) then + atm(i,j,iatmn2o)=patmn2o(i,j) + endif + if (patmnh3(i,j) > 0.) then + atm(i,j,iatmnh3)=patmnh3(i,j) + endif + enddo + enddo +!$OMP END PARALLEL DO + if (mnproc.eq.1) write (io_stdo_bgc,*) 'iHAMOCC: getting N2O and NH3 conc. from atm' + ENDIF + + if(do_ndep_coupled) then + fatmndep = 365.*86400./mw_nitrogen + ndep(:,:,:) = 0. +!$OMP PARALLEL DO PRIVATE(i) + do j=1,kpje + do i=1,kpie + ! convert from kgN/m2/s to climatological input file units: kmolN/m2/yr + if (patmnoydep(i,j).gt.0.) then + ndep(i,j,idepnoy) = patmnoydep(i,j)*fatmndep + endif + if (patmnhxdep(i,j).gt.0.) then + ndep(i,j,idepnhx) = patmnhxdep(i,j)*fatmndep + endif + enddo + enddo +!$OMP END PARALLEL DO + if (mnproc.eq.1) write (io_stdo_bgc,*) 'iHAMOCC: getting NOy and NHx deposition from atm' + endif +#endif + !-------------------------------------------------------------------- ! Read atmospheric cfc concentrations ! @@ -190,7 +240,7 @@ subroutine hamocc4bcm(kpie,kpje,kpke,kbnd,kplyear,kplmon,kplday,kldtday,pdlxp,pd ! the model call apply_fedep(kpie,kpje,kpke,pddpo,omask,dust) - call ocprod(kpie,kpje,kpke,kbnd,pdlxp,pdlyp,pddpo,omask,ptho,pi_ph) + call ocprod(kpie,kpje,kpke,kbnd,pdlxp,pdlyp,pddpo,omask,ptho,pi_ph,psao,ppao,prho) if (use_PBGC_CK_TIMESTEP ) then if (mnproc.eq.1) then @@ -317,7 +367,7 @@ subroutine hamocc4bcm(kpie,kpje,kpke,kbnd,kplyear,kplmon,kplday,kldtday,pdlxp,pd lspin=.false. endif - call powach(kpie,kpje,kpke,kbnd,prho,omask,psao,lspin) + call powach(kpie,kpje,kpke,kbnd,prho,omask,psao,ptho,lspin) enddo @@ -386,7 +436,27 @@ subroutine hamocc4bcm(kpie,kpje,kpke,kbnd,kplyear,kplmon,kplday,kldtday,pdlxp,pd enddo !$OMP END PARALLEL DO !-------------------------------------------------------------------- - + ! Pass nitrous oxide and ammonia fluxes. Convert unit from kmol N2O (NH3)/m2/Delta t to kg/m2/s + ! negative values to the atmosphere + !$OMP PARALLEL DO PRIVATE(i) + do j=1,kpje + do i=1,kpie +#ifdef extNcycle + if (do_n2onh3_coupled) then + if(omask(i,j) > 0.5) pflxn2o(i,j)=-mw_n2o*atmflx(i,j,iatmn2o)/dtbgc ! conversion factor checked against CAM + if(omask(i,j) > 0.5) pflxnh3(i,j)=-mw_nh3*atmflx(i,j,iatmnh3)/dtbgc ! conversion factor checked against CAM + else + if(omask(i,j) > 0.5) pflxn2o(i,j)=0.0 + if(omask(i,j) > 0.5) pflxnh3(i,j)=0.0 + endif +#else + if(omask(i,j) > 0.5) pflxn2o(i,j)=0.0 + if(omask(i,j) > 0.5) pflxnh3(i,j)=0.0 +#endif + enddo + enddo + !$OMP END PARALLEL DO + !-------------------------------------------------------------------- end subroutine hamocc4bcm end module mo_hamocc4bcm diff --git a/hamocc/mo_hamocc_init.F90 b/hamocc/mo_hamocc_init.F90 index dbfbab4a..19faf4c5 100644 --- a/hamocc/mo_hamocc_init.F90 +++ b/hamocc/mo_hamocc_init.F90 @@ -42,7 +42,8 @@ subroutine hamocc_init(read_rest,rstfnm_hamocc) use mo_control_bgc, only: bgc_namelist,get_bgc_namelist,do_ndep,do_rivinpt,do_oalk, & do_sedspinup,sedspin_yr_s,sedspin_yr_e,sedspin_ncyc, & dtb,dtbgc,io_stdo_bgc,ldtbgc, & - ldtrunbgc,ndtdaybgc,with_dmsph,l_3Dvarsedpor, & + ldtrunbgc,ndtdaybgc,with_dmsph,l_3Dvarsedpor,lm4ago, & + do_ndep_coupled,leuphotic_cya,do_n2onh3_coupled, & ocn_co2_type, use_sedbypass, use_BOXATM, use_BROMO use mo_param1_bgc, only: ks,init_por2octra_mapping use mo_param_bgc, only: ini_parambgc @@ -63,6 +64,10 @@ subroutine hamocc_init(read_rest,rstfnm_hamocc) sedlay2,powtra2,burial2,blom2hamocc,atm2 use mo_ini_fields, only: ini_fields_ocean,ini_fields_atm use mo_aufr_bgc, only: aufr_bgc + use mo_m4ago, only: alloc_mem_m4ago +#ifdef extNcycle + use mo_extNsediment,only: alloc_mem_extNsediment_diag +#endif ! Arguments integer, intent(in) :: read_rest ! flag indicating whether to read restart files. @@ -76,7 +81,8 @@ subroutine hamocc_init(read_rest,rstfnm_hamocc) namelist /bgcnml/ atm_co2,fedepfile,do_rivinpt,rivinfile,do_ndep,ndepfile,do_oalk, & & do_sedspinup,sedspin_yr_s,sedspin_yr_e,sedspin_ncyc, & & inidic,inialk,inipo4,inioxy,inino3,inisil,inid13c,inid14c,swaclimfile, & - & with_dmsph,pi_ph_file,l_3Dvarsedpor,sedporfile,ocn_co2_type + & with_dmsph,pi_ph_file,l_3Dvarsedpor,sedporfile,ocn_co2_type,lm4ago,leuphotic_cya, & + & do_ndep_coupled,do_n2onh3_coupled ! ! --- Set io units and some control parameters ! @@ -134,6 +140,10 @@ subroutine hamocc_init(read_rest,rstfnm_hamocc) call alloc_mem_biomod(idm,jdm,kdm) call alloc_mem_sedmnt(idm,jdm) call alloc_mem_carbch(idm,jdm,kdm) + call alloc_mem_M4AGO(idm,jdm,kdm) +#if defined(extNcycle) && ! defined(sedbypass) + call alloc_mem_extNsediment_diag(idm,jdm,ks) +#endif ! ! --- initialise trc array (two time levels) ! diff --git a/hamocc/mo_hamocc_step.F90 b/hamocc/mo_hamocc_step.F90 index 3b9d486f..67c8fe8c 100644 --- a/hamocc/mo_hamocc_step.F90 +++ b/hamocc/mo_hamocc_step.F90 @@ -33,7 +33,8 @@ subroutine hamocc_step(m,n,mm,nn,k1m,k1n) use mod_time, only: date,nday_of_year,nstep,nstep_in_day use mod_grid, only: plat use mod_state, only: temp,saln - use mod_forcing, only: swa,slp,abswnd,atmco2,flxco2,flxdms,atmbrf,flxbrf + use mod_forcing, only: swa,slp,abswnd,atmco2,flxco2,flxdms,atmbrf,flxbrf, & + atmn2o,flxn2o,atmnh3,flxnh3,atmnhxdep,atmnoydep use mod_seaice, only: ficem use mo_bgcmean, only: nbgc,bgcwrt, diagfq_bgc,diagmon_bgc,diagann_bgc use mo_intfcblom, only: bgc_dx,bgc_dy,bgc_dp,bgc_rho,omask,blom2hamocc,hamocc2blom @@ -42,17 +43,18 @@ subroutine hamocc_step(m,n,mm,nn,k1m,k1n) use mo_read_ndep, only: get_ndep use mo_read_oafx, only: get_oafx use mo_read_pi_ph, only: get_pi_ph,pi_ph - use mo_control_bgc, only: with_dmsph + use mo_control_bgc, only: with_dmsph,do_ndep_coupled use mo_accfields, only: accfields use mo_hamocc4bcm, only: hamocc4bcm use mo_trc_limitc, only: trc_limitc + use mo_param1_bgc, only: nndep ! Arguments integer, intent(in) :: m,n,mm,nn,k1m,k1n ! Local variables integer :: l,ldtday - real :: ndep(idm,jdm) + real :: ndep(idm,jdm,nndep) real :: dust(idm,jdm) real :: oafx(idm,jdm) @@ -73,14 +75,15 @@ subroutine hamocc_step(m,n,mm,nn,k1m,k1n) enddo call get_fedep(idm,jdm,date%month,dust) - call get_ndep(idm,jdm,date%year,date%month,omask,ndep) + if (.not. do_ndep_coupled) call get_ndep(idm,jdm,date%year,date%month,omask,ndep) call get_oafx(idm,jdm,date%year,date%month,omask,oafx) if(with_dmsph) call get_pi_ph(idm,jdm,date%month) call hamocc4bcm(idm,jdm,kdm,nbdy,date%year,date%month,date%day,ldtday,bgc_dx,bgc_dy,bgc_dp, & & bgc_rho,plat,omask,dust,rivflx,ndep,oafx,pi_ph,swa,ficem,slp,abswnd, & & temp(1-nbdy,1-nbdy,1+nn),saln(1-nbdy,1-nbdy,1+nn), & - & atmco2,flxco2,flxdms,atmbrf,flxbrf) + & atmco2,flxco2,flxdms,atmbrf,flxbrf, & + & atmn2o,flxn2o,atmnh3,flxnh3,atmnhxdep,atmnoydep) ! ! --- accumulate fields and write output diff --git a/hamocc/mo_ini_fields.F90 b/hamocc/mo_ini_fields.F90 index 5b7e48ce..823c7c6f 100644 --- a/hamocc/mo_ini_fields.F90 +++ b/hamocc/mo_ini_fields.F90 @@ -38,9 +38,9 @@ subroutine ini_fields_atm(kpie,kpje) ! -split the original BELEG_BGC in two parts, BELEG_PARM (NOW MO_PARAM_BGC) and BELEG_VARS !*********************************************************************************************** - use mo_control_bgc, only: use_natDIC,use_cisonew,use_BROMO + use mo_control_bgc, only: use_natDIC,use_cisonew,use_BROMO,use_extNcycle use mo_param1_bgc, only: iatmco2,iatmo2,iatmn2,iatmnco2,iatmc13,iatmc14,iatmbromo - use mo_param_bgc, only: atm_o2,atm_n2,atm_co2_nat,atm_c13,atm_c14,c14fac,atm_bromo + use mo_param_bgc, only: atm_o2,atm_n2,atm_co2_nat,atm_c13,atm_c14,c14fac,atm_bromo,atm_n2o,atm_nh3 use mo_carbch, only: atm,atm_co2 ! Initialise atmosphere fields. We use a 2D representation of atmospheric @@ -69,6 +69,10 @@ subroutine ini_fields_atm(kpie,kpje) if (use_BROMO) then atm(i,j,iatmbromo)= atm_bromo endif +#ifdef extNcycle + atm(i,j,iatmnh3) = atm_nh3 + atm(i,j,iatmn2o) = atm_n2o +#endif enddo enddo end subroutine ini_fields_atm @@ -98,12 +102,14 @@ subroutine ini_fields_ocean(kpaufr,kpie,kpje,kpke,kbnd,pddpo,prho,omask,pglon,pg isco213,isco214,izoo13,izoo14,safediv,inatcalc, & ipowaal,ipowaic,ipowaox,ipowaph,ipowasi,ipown2,ipowno3,isssc12, & issso12,issssil,issster,ks,nsedtra,ipowc13,ipowc13,issso13,issso13, & - isssc13,ipowc14,isssc14,issso14 + isssc13,ipowc14,isssc14,issso14,iprefsilica use mo_vgrid, only: kmle,kbo use mo_carbch, only: nathi,natco3 use mo_sedmnt, only: sedhpl,burial,powtra,sedlay use mo_profile_gd, only: profile_gd - +#ifdef extNcycle + use mo_param1_bgc, only: iano2,ianh4 +#endif ! Arguments integer, intent(in) :: kpaufr ! 1/0 flag, 1 indicating a restart run integer, intent(in) :: kpie ! 1st dimension of model grid. @@ -188,6 +194,7 @@ subroutine ini_fields_ocean(kpaufr,kpie,kpje,kpke,kbnd,pddpo,prho,omask,pglon,pg ocetra(i,j,k,iiron) =fesoly ocetra(i,j,k,iprefo2)=0. ocetra(i,j,k,iprefpo4)=0. + ocetra(i,j,k,iprefsilica)=0. ocetra(i,j,k,iprefalk)=0. ocetra(i,j,k,iprefdic)=0. ocetra(i,j,k,idicsat)=1.e-8 @@ -228,6 +235,11 @@ subroutine ini_fields_ocean(kpaufr,kpie,kpje,kpke,kbnd,pddpo,prho,omask,pglon,pg ! Initialise to 0,01 pmol L-1 (Stemmler et al., 2015) => mol/kg ocetra(i,j,k,ibromo)= 1.e-14/prho(i,j,k) endif +#ifdef extNcycle + ocetra(i,j,k,iano2) =1.e-9 ! expecting fast cycling + ocetra(i,j,k,ianh4) =0.5e-9 ! expecting fast cycling + ocetra(i,j,k,ian2o) =6.e-9 ! 6 to 8 nmol/kg = ca. value in near surface regions Toyoda et al. 2019, prevent from too long outgassing +#endif endif ! omask > 0.5 enddo enddo @@ -240,6 +252,7 @@ subroutine ini_fields_ocean(kpaufr,kpie,kpje,kpke,kbnd,pddpo,prho,omask,pglon,pg if (omask(i,j) > 0.5) then ocetra(i,j,1:kmle(i,j),iprefo2) = ocetra(i,j,1:kmle(i,j),ioxygen) ocetra(i,j,1:kmle(i,j),iprefpo4) = ocetra(i,j,1:kmle(i,j),iphosph) + ocetra(i,j,1:kmle(i,j),iprefsilica)= ocetra(i,j,1:kmle(i,j),isilica) ocetra(i,j,1:kmle(i,j),iprefalk) = ocetra(i,j,1:kmle(i,j),ialkali) ocetra(i,j,1:kmle(i,j),iprefdic) = ocetra(i,j,1:kmle(i,j),isco212) endif diff --git a/hamocc/mo_inventory_bgc.F90 b/hamocc/mo_inventory_bgc.F90 index 1f4d1895..baefe44b 100644 --- a/hamocc/mo_inventory_bgc.F90 +++ b/hamocc/mo_inventory_bgc.F90 @@ -38,12 +38,13 @@ subroutine inventory_bgc(kpie,kpje,kpke,dlxp,dlyp,ddpo,omask,iogrp) !*********************************************************************************************** use mod_xc, only: mnproc,ips,nbdy,xcsum - use mo_carbch, only: atm,atmflx,co3,hi,ndepflx,rivinflx,ocetra,sedfluxo + use mo_carbch, only: atm,atmflx,co3,hi,ndepnoyflx,rivinflx,ocetra,sedfluxo use mo_sedmnt, only: prcaca,prorca,silpro use mo_biomod, only: expoor,expoca,exposi use mo_param_bgc, only: rcar,rnit use mo_control_bgc, only: do_ndep,do_rivinpt,io_stdo_bgc - use mo_bgcmean, only: bgct2d,jco2flux,jirdin,jn2flux,jn2oflux,jndep,jo2flux,jprcaca, & + use mo_bgcmean, only: bgct2d,jco2flux,jirdin,jn2flux,jn2oflux,jndepnoy,jndepnhx, & + jo2flux,jprcaca, & jprorca,jsilpro,nbgcmax,glb_inventory use mo_param1_bgc, only: ialkali,ian2o,iano3,iatmco2,iatmn2,iatmn2o,iatmo2,icalc,idet,idoc, & igasnit,iopal,ioxygen,iphosph,iphy,ipowaic,ipowaox,ipowaph,ipowasi, & @@ -56,6 +57,11 @@ subroutine inventory_bgc(kpie,kpje,kpke,dlxp,dlyp,ddpo,omask,iogrp) use mo_sedmnt, only: porwat,seddw,sedlay,burial,sedhpl,powtra,porsol use mo_control_bgc, only: use_PBGC_CK_TIMESTEP,use_BOXATM,use_sedbypass,use_cisonew,use_AGG, & use_CFC,use_natDIC,use_BROMO +#ifdef extNcycle + use mo_carbch, only: ndepnhxflx + use mo_param1_bgc, only: ianh4,iano2,iatmnh3,ipownh4,ipown2o,ipowno2 + use mo_bgcmean, only: jnh3flux +#endif ! Arguments integer, intent(in) :: kpie,kpje,kpke @@ -96,9 +102,10 @@ subroutine inventory_bgc(kpie,kpje,kpke,dlxp,dlyp,ddpo,omask,iogrp) !--- river fluxes real :: srivflux(nriv) ! sum of riverfluxes !--- atmosphere flux and atmospheric CO2 - real :: sndepflux ! sum of N dep fluxes + real :: sndepnoyflux ! sum of N dep fluxes + real :: sndepnhxflux ! sum of N dep fluxes real :: zatmco2,zatmo2,zatmn2 - real :: co2flux,so2flux,sn2flux,sn2oflux + real :: co2flux,so2flux,sn2flux,sn2oflux,snh3flux real :: zprorca,zprcaca,zsilpro !--- total tracer budgets real :: totalcarbon,totalphos,totalsil,totalnitr,totaloxy @@ -271,7 +278,9 @@ subroutine inventory_bgc(kpie,kpje,kpke,dlxp,dlyp,ddpo,omask,iogrp) so2flux =0. sn2flux =0. sn2oflux =0. - sndepflux=0. + snh3flux =0. + sndepnoyflux=0. + sndepnhxflux=0. srivflux =0. zatmco2 =0. zatmo2 =0. @@ -291,10 +300,16 @@ subroutine inventory_bgc(kpie,kpje,kpke,dlxp,dlyp,ddpo,omask,iogrp) so2flux = sum2d(atmflx(:,:,iatmo2)) sn2flux = sum2d(atmflx(:,:,iatmn2)) sn2oflux = sum2d(atmflx(:,:,iatmn2o)) +#ifdef extNcycle + snh3flux = sum2d(atmflx(:,:,iatmnh3)) +#endif ! nitrogen deposition if(do_ndep) then - sndepflux = sum2d(ndepflx) + sndepnoyflux = sum2d(ndepnoyflx) +#ifdef extNcycle + sndepnhxflux = sum2d(ndepnhxflx) +#endif endif ! river fluxes @@ -307,10 +322,16 @@ subroutine inventory_bgc(kpie,kpje,kpke,dlxp,dlyp,ddpo,omask,iogrp) so2flux = sum2d(bgct2d(:,:,jo2flux)) sn2flux = sum2d(bgct2d(:,:,jn2flux)) sn2oflux = sum2d(bgct2d(:,:,jn2oflux)) +#ifdef extNcycle + snh3flux = sum2d(bgct2d(:,:,jnh3flux)) +#endif ! nitrogen deposition fluxes if(do_ndep) then - sndepflux = sum2d(bgct2d(:,:,jndep)) + sndepnoyflux = sum2d(bgct2d(:,:,jndepnoy)) +#ifdef extNcycle + sndepnhxflux = sum2d(bgct2d(:,:,jndepnhx)) +#endif endif ! River fluxes @@ -358,7 +379,7 @@ subroutine inventory_bgc(kpie,kpje,kpke,dlxp,dlyp,ddpo,omask,iogrp) + zpowtratot(ipowno3)+zpowtratot(ipown2)*2 & + zsedlayto(issso12)*rnit+zburial(issso12)*rnit & + zocetratot(ian2o)*2 & - - sndepflux & + - sndepnoyflux & + zprorca*rnit if (use_BOXATM) then @@ -366,6 +387,11 @@ subroutine inventory_bgc(kpie,kpje,kpke,dlxp,dlyp,ddpo,omask,iogrp) else totalnitr = totalnitr + sn2flux*2+sn2oflux*2 endif +#ifdef extNcycle + totalnitr = totalnitr + zocetratot(ianh4)+zocetratot(iano2)+snh3flux& + & - sndepnhxflux & + & +zpowtratot(ipownh4)+zpowtratot(ipown2o)*2+zpowtratot(ipowno2) +#endif totalphos= & zocetratot(idet)+zocetratot(idoc)+zocetratot(iphy) & @@ -388,7 +414,7 @@ subroutine inventory_bgc(kpie,kpje,kpke,dlxp,dlyp,ddpo,omask,iogrp) !+ zburial(issso12)*(-24.) + zburial(isssc12) & + zpowtratot(ipowno3)*1.5+zpowtratot(ipowaic) & + zpowtratot(ipowaox)+zpowtratot(ipowaph)*2 & - - sndepflux*1.5 & + - sndepnoyflux*1.5 & + zprorca*(-24.)+zprcaca if (use_BOXATM) then @@ -396,6 +422,9 @@ subroutine inventory_bgc(kpie,kpje,kpke,dlxp,dlyp,ddpo,omask,iogrp) else totaloxy = totaloxy + so2flux+sn2oflux*0.5+co2flux endif +#ifdef extNcycle + totaloxy = totaloxy + zocetratot(iano2)+zpowtratot(ipown2o)*0.5+zpowtratot(ipowno2) +#endif if (do_rivinpt) then totalcarbon = totalcarbon- (srivflux(irdoc)+srivflux(irdet))*rcar & @@ -568,6 +597,9 @@ subroutine write_stdout ! write(io_stdo_bgc,*) 'O2 Flux :',so2flux ! write(io_stdo_bgc,*) 'N2 Flux :',sn2flux ! write(io_stdo_bgc,*) 'N2O Flux :',sn2oflux +#ifdef extNcycle + ! write(io_stdo_bgc,*) 'NH3 Flux :',snh3flux +#endif ! write(io_stdo_bgc,*) ' ' if (use_BOXATM) then ! write(io_stdo_bgc,*) 'global atm. CO2[ppm] / kmol: ', & @@ -583,7 +615,12 @@ subroutine write_stdout ! & zprorca, zprcaca, zsilpro ! write(io_stdo_bgc,*) ' ' - if (do_ndep) write(io_stdo_bgc,*) 'NdepFlux :',sndepflux + if(do_ndep) then + write(io_stdo_bgc,*) 'NdepNOyFlux :',sndepnoyflux +#ifdef extNcycle + write(io_stdo_bgc,*) 'NdepNHxFlux :',sndepnhxflux +#endif + endif ! riverine fluxes !------------------------------------------------------------------ @@ -650,6 +687,7 @@ subroutine write_netcdf(iogrp) inatalkali,inatcalc,inatsco212 use mo_control_bgc,only: use_PBGC_CK_TIMESTEP,use_BOXATM,use_sedbypass,use_cisonew,use_AGG, & use_CFC,use_natDIC,use_BROMO + use mo_param1_bgc, only: ianh4,iano2 implicit none @@ -750,6 +788,10 @@ subroutine write_netcdf(iogrp) ! BROMO integer :: zt_bromo_varid, zc_bromo_varid ! Bromoform + + ! extNcycle + integer :: zt_nh4_varid, zc_nh4_varid ! Ammonium (NH4+) + integer :: zt_ano2_varid, zc_ano2_varid ! Nitrite (NO2-) !--- sum of inventory integer :: totcarb_varid, totphos_varid, totsili_varid, totnitr_varid @@ -1386,7 +1428,31 @@ subroutine write_netcdf(iogrp) & 'Mean bromoform concentration') ) call nccheck( NF90_PUT_ATT(ncid, zc_bromo_varid, 'units', 'kmol/m^3') ) endif - +#ifdef extNcycle + call nccheck( NF90_DEF_VAR(ncid, 'zt_nh4', NF90_DOUBLE, & + & time_dimid, zt_nh4_varid) ) + call nccheck( NF90_PUT_ATT(ncid, zt_nh4_varid, 'long_name', & + & 'Total ammonium tracer') ) + call nccheck( NF90_PUT_ATT(ncid, zt_nh4_varid, 'units', 'kmol') ) + + call nccheck( NF90_DEF_VAR(ncid, 'zc_nh4', NF90_DOUBLE, & + & time_dimid, zc_nh4_varid) ) + call nccheck( NF90_PUT_ATT(ncid, zc_nh4_varid, 'long_name', & + & 'Mean ammonium concentration') ) + call nccheck( NF90_PUT_ATT(ncid, zc_nh4_varid, 'units', 'kmol/m^3') ) + + call nccheck( NF90_DEF_VAR(ncid, 'zt_ano2', NF90_DOUBLE, & + & time_dimid, zt_ano2_varid) ) + call nccheck( NF90_PUT_ATT(ncid, zt_ano2_varid, 'long_name', & + & 'Total nitrite tracer') ) + call nccheck( NF90_PUT_ATT(ncid, zt_ano2_varid, 'units', 'kmol') ) + + call nccheck( NF90_DEF_VAR(ncid, 'zc_ano2', NF90_DOUBLE, & + & time_dimid, zc_ano2_varid) ) + call nccheck( NF90_PUT_ATT(ncid, zc_ano2_varid, 'long_name', & + & 'Mean nitrite concentration') ) + call nccheck( NF90_PUT_ATT(ncid, zc_ano2_varid, 'units', 'kmol/m^3') ) +#endif !--- Define variables : sum of inventory call nccheck( NF90_DEF_VAR(ncid, 'totcarb', NF90_DOUBLE, time_dimid, & & totcarb_varid) ) @@ -1581,6 +1647,12 @@ subroutine write_netcdf(iogrp) call nccheck( NF90_INQ_VARID(ncid, "zt_bromo", zt_bromo_varid) ) call nccheck( NF90_INQ_VARID(ncid, "zc_bromo", zc_bromo_varid) ) endif +#ifdef extNcycle + call nccheck( NF90_INQ_VARID(ncid, "zt_nh4", zt_nh4_varid) ) + call nccheck( NF90_INQ_VARID(ncid, "zc_nh4", zc_nh4_varid) ) + call nccheck( NF90_INQ_VARID(ncid, "zt_ano2", zt_ano2_varid) ) + call nccheck( NF90_INQ_VARID(ncid, "zc_ano2", zc_ano2_varid) ) +#endif !--- Inquire varid : sum of inventory call nccheck( NF90_INQ_VARID(ncid, "totcarb", totcarb_varid) ) call nccheck( NF90_INQ_VARID(ncid, "totphos", totphos_varid) ) @@ -1810,6 +1882,16 @@ subroutine write_netcdf(iogrp) call nccheck( NF90_PUT_VAR(ncid, zc_bromo_varid, & & zocetratoc(ibromo), start = wrstart) ) endif +#ifdef extNcycle + call nccheck( NF90_PUT_VAR(ncid, zt_nh4_varid, & + & zocetratot(ianh4), start = wrstart) ) + call nccheck( NF90_PUT_VAR(ncid, zc_nh4_varid, & + & zocetratoc(ianh4), start = wrstart) ) + call nccheck( NF90_PUT_VAR(ncid, zt_ano2_varid, & + & zocetratot(iano2), start = wrstart) ) + call nccheck( NF90_PUT_VAR(ncid, zc_ano2_varid, & + & zocetratoc(iano2), start = wrstart) ) +#endif !--- Write data : sum of inventory call nccheck( NF90_PUT_VAR(ncid, totcarb_varid, totalcarbon, & & start = wrstart) ) diff --git a/hamocc/mo_m4ago.F90 b/hamocc/mo_m4ago.F90 index 19a89628..da8b9513 100644 --- a/hamocc/mo_m4ago.F90 +++ b/hamocc/mo_m4ago.F90 @@ -71,10 +71,9 @@ MODULE mo_m4ago USE mo_vgrid, ONLY: dp_min USE mo_control_bgc, ONLY: dtb, dtbgc,io_stdo_bgc - USE mo_sedmnt, ONLY: calcdens, claydens, opaldens, calcwei, opalwei + USE mo_param_bgc, ONLY: calcdens, claydens, opaldens, calcwei, opalwei, ropal USE mo_carbch, ONLY: ocetra USE mo_param1_bgc, ONLY: iopal, ifdust, icalc, idet - USE mo_biomod, ONLY: ropal IMPLICIT NONE diff --git a/hamocc/mo_ncout_hamocc.F90 b/hamocc/mo_ncout_hamocc.F90 index ca43e61b..fdfe104a 100644 --- a/hamocc/mo_ncout_hamocc.F90 +++ b/hamocc/mo_ncout_hamocc.F90 @@ -35,11 +35,11 @@ subroutine ncwrt_bgc(iogrp) use mod_grid, only: depths use mod_dia, only: diafnm,sigmar1,iotype,ddm,depthslev,depthslev_bnds use mo_control_bgc, only: dtbgc,use_cisonew,use_AGG,use_CFC,use_natDIC,use_BROMO, & - use_sedbypass,use_BOXATM + use_sedbypass,use_BOXATM,lm4ago use mo_vgrid, only: k0100,k0500,k1000,k2000,k4000 use mo_param1_bgc, only: ks use mod_nctools, only: ncwrt1,ncdims,nctime,ncfcls,ncfopn,ncdimc - use mo_bgcmean, only: domassfluxes,flx_ndep,flx_oalk, & + use mo_bgcmean, only: domassfluxes,flx_ndepnoy,flx_oalk, & flx_cal0100,flx_cal0500,flx_cal1000, & flx_cal2000,flx_cal4000,flx_cal_bot, & flx_car0100,flx_car0500,flx_car1000, & @@ -48,8 +48,12 @@ subroutine ncwrt_bgc(iogrp) flx_bsi2000,flx_bsi4000,flx_bsi_bot, & flx_sediffic,flx_sediffal,flx_sediffph, & flx_sediffox,flx_sediffn2,flx_sediffno3,flx_sediffsi, & + flx_bursso12,flx_bursssc12,flx_burssssil, & + flx_burssster, & jsediffic,jsediffal,jsediffph,jsediffox, & jsediffn2,jsediffno3,jsediffsi, & + jburflxsso12,jburflxsssc12,jburflxssssil, & + jburflxssster, & jalkali,jano3,jasize,jatmco2, & jbsiflx0100,jbsiflx0500,jbsiflx1000, & jbsiflx2000,jbsiflx4000,jbsiflx_bot, & @@ -74,12 +78,12 @@ subroutine ncwrt_bgc(iogrp) jlvlphosy,jlvlphyto,jlvlphyto13,jlvlpoc, & jlvlpoc13,jlvlprefalk,jlvlprefdic, & jlvlprefo2,jlvlprefpo4,jlvlsf6,jlvlsilica, & - jlvlwnos,jlvlwphy,jn2o, & - jn2ofx,jndepfx,jniflux,jnos,joalkfx, & + jlvlwnos,jlvlwphy,jn2o,jsrfpn2om, & + jn2ofx,jndepnoyfx,jniflux,jnos,joalkfx, & jo2sat,jomegaa,jomegac,jopal,joxflux,joxygen,jpco2, & jpco2m,jkwco2khm,jco2kh,jco2khm, & jph,jphosph,jphosy,jphyto,jpoc,jprefalk, & - jprefdic,jprefo2,jprefpo4,jsilica, & + jprefdic,jprefo2,jprefpo4,jsilica,jprefsilica, & jsrfalkali,jsrfano3,jsrfdic,jsrfiron, & jsrfoxygen,jsrfphosph,jsrfphyto,jsrfsilica,jsrfph, & jwnos,jwphy, & @@ -88,16 +92,16 @@ subroutine ncwrt_bgc(iogrp) lyr_phyto,lyr_grazer,lyr_poc,lyr_calc, & lyr_opal,lyr_iron,lyr_phosy,lyr_co3,lyr_ph, & lyr_omegaa,lyr_omegac,lyr_n2o,lyr_prefo2, & - lyr_o2sat,lyr_prefpo4,lyr_prefalk, & + lyr_o2sat,lyr_prefpo4,lyr_prefalk,lyr_prefsilica, & lyr_prefdic,lyr_dicsat, & lvl_dic,lvl_alkali, & lvl_phosph,lvl_oxygen,lvl_ano3,lvl_silica, & lvl_doc,lvl_phyto,lvl_grazer,lvl_poc, & lvl_calc,lvl_opal,lvl_iron,lvl_phosy, & lvl_co3,lvl_ph,lvl_omegaa,lvl_omegac, & - lvl_n2o,lvl_prefo2,lvl_o2sat,lvl_prefpo4, & + lvl_n2o,lvl_prefo2,lvl_o2sat,lvl_prefpo4,lvl_prefsilica, & lvl_prefalk,lvl_prefdic,lvl_dicsat, & - lvl_o2sat,srf_n2ofx,srf_atmco2,srf_kwco2, & + lvl_o2sat,srf_n2ofx,srf_pn2om,srf_atmco2,srf_kwco2, & srf_kwco2khm,srf_co2kh,srf_co2khm,srf_pco2m, & srf_pco2,srf_dmsflux,srf_co2fxd, & srf_co2fxu,srf_oxflux,srf_niflux,srf_dms, & @@ -133,7 +137,7 @@ subroutine ncwrt_bgc(iogrp) lvl_d14c,lvl_bigd14c,lvl_poc13,lvl_doc13, & lvl_calc13,lvl_phyto13,lvl_grazer13, & jnatalkali,jnatdic,jnatcalc,jnatco3,jnatph, & - jnatomegaa,jnatomegac,jlvlnatph, & + jnatomegaa,jnatomegac,jlvlnatph,jlvlprefsilica, & jsrfnatdic,jsrfnatalk,jsrfnatph, & jnatpco2,jnatco2fx,lyr_natco3, & lyr_natalkali,lyr_natdic,lyr_natph,lyr_natcalc, & @@ -149,7 +153,67 @@ subroutine ncwrt_bgc(iogrp) sdm_ssssil,sdm_sssc12,sdm_ssster,jburssso12, & bur_sssc12,bur_ssssil,bur_ssster,bur_ssso12, & inisdm,inibur,wrtsdm,accbur,accsdm,wrtbur, & - jatmco2,jatmn2,jatmo2,srf_atmo2,srf_atmn2 + jatmco2,jatmn2,jatmo2,srf_atmo2,srf_atmn2, & + lyr_agg_ws,lyr_dynvis,lyr_agg_stick, & + lyr_agg_stickf,lyr_agg_dmax,lyr_agg_avdp, & + lyr_agg_avrhop,lyr_agg_avdC,lyr_agg_df, & + lyr_agg_b,lyr_agg_Vrhof,lyr_agg_Vpor, & + lvl_agg_ws,lvl_dynvis,lvl_agg_stick, & + lvl_agg_stickf,lvl_agg_dmax,lvl_agg_avdp, & + lvl_agg_avrhop,lvl_agg_avdC,lvl_agg_df, & + lvl_agg_b,lvl_agg_Vrhof,lvl_agg_Vpor, & + jagg_ws,jdynvis,jagg_stick, & + jagg_stickf,jagg_dmax,jagg_avdp, & + jagg_avrhop,jagg_avdC,jagg_df, & + jagg_b,jagg_Vrhof,jagg_Vpor, & + jlvl_agg_ws,jlvl_dynvis,jlvl_agg_stick, & + jlvl_agg_stickf,jlvl_agg_dmax,jlvl_agg_avdp, & + jlvl_agg_avrhop,jlvl_agg_avdC,jlvl_agg_df, & + jlvl_agg_b,jlvl_agg_Vrhof,jlvl_agg_Vpor +#ifdef extNcycle + use mo_bgcmean, only: janh4,jano2,jlvlanh4,jlvlano2,jsrfanh4,jsrfpnh3, & + & jsrfano2,janh3fx,srf_pnh3,srf_anh4,srf_ano2, & + & srf_anh3fx,lyr_anh4,lyr_ano2,lvl_anh4, & + & lvl_ano2, & + & LYR_nitr_NH4,LYR_nitr_NO2,LYR_nitr_N2O_prod, & + & LYR_nitr_NH4_OM,LYR_nitr_NO2_OM, & + & LYR_denit_NO3,LYR_denit_NO2,LYR_denit_N2O, & + & LYR_DNRA_NO2,LYR_anmx_N2_prod, & + & LYR_anmx_OM_prod,LYR_phosy_NH4, & + & LYR_phosy_NO3,LYR_remin_aerob,LYR_remin_sulf, & + & LVL_nitr_NH4,LVL_nitr_NO2,LVL_nitr_N2O_prod, & + & LVL_nitr_NH4_OM,LVL_nitr_NO2_OM, & + & LVL_denit_NO3,LVL_denit_NO2,LVL_denit_N2O, & + & LVL_DNRA_NO2,LVL_anmx_N2_prod, & + & LVL_anmx_OM_prod,LVL_phosy_NH4, & + & LVL_phosy_NO3,LVL_remin_aerob,LVL_remin_sulf, & + & jnitr_NH4,jnitr_NO2,jnitr_N2O_prod, & + & jnitr_NH4_OM,jnitr_NO2_OM,jdenit_NO3, & + & jdenit_NO2,jdenit_N2O,jDNRA_NO2, & + & janmx_N2_prod,janmx_OM_prod,jphosy_NH4, & + & jphosy_NO3,jremin_aerob,jremin_sulf, & + & jlvl_nitr_NH4,jlvl_nitr_NO2, & + & jlvl_nitr_N2O_prod,jlvl_nitr_NH4_OM, & + & jlvl_nitr_NO2_OM,jlvl_denit_NO3, & + & jlvl_denit_NO2,jlvl_denit_N2O,jlvl_DNRA_NO2, & + & jlvl_anmx_N2_prod,jlvl_anmx_OM_prod, & + & jlvl_phosy_NH4,jlvl_phosy_NO3, & + & jlvl_remin_aerob,jlvl_remin_sulf,jatmnh3,jatmn2o, & + & srf_atmnh3,srf_atmn2o,flx_ndepnhx,jndepnhxfx +#endif +#if defined(extNcycle) && ! defined(sedbypass) + use mo_bgcmean, only: jpownh4,jpown2o,jpowno2,jsdm_nitr_NH4,jsdm_nitr_NO2, & + & jsdm_nitr_N2O_prod,jsdm_nitr_NH4_OM,jsdm_nitr_NO2_OM, & + & jsdm_denit_NO3,jsdm_denit_NO2,jsdm_denit_N2O, & + & jsdm_DNRA_NO2,jsdm_anmx_N2_prod,jsdm_anmx_OM_prod, & + & jsdm_remin_aerob,jsdm_remin_sulf, SDM_POWNH4,SDM_POWN2O,& + & SDM_POWNO2,SDM_nitr_NH4,SDM_nitr_NO2,SDM_nitr_N2O_prod, & + & SDM_nitr_NH4_OM,SDM_nitr_NO2_OM,SDM_denit_NO3, & + & SDM_denit_NO2,SDM_denit_N2O,SDM_DNRA_NO2, & + & SDM_anmx_N2_prod,SDM_anmx_OM_prod,SDM_remin_aerob, & + & SDM_remin_sulf,jsediffnh4,jsediffn2o,jsediffno2, & + & FLX_SEDIFFNH4,FLX_SEDIFFN2O,FLX_SEDIFFNO2 +#endif use mo_param_bgc, only: c14fac ! Arguments @@ -252,6 +316,7 @@ subroutine ncwrt_bgc(iogrp) call finlyr(jprefo2(iogrp),jdp(iogrp)) call finlyr(jo2sat(iogrp),jdp(iogrp)) call finlyr(jprefpo4(iogrp),jdp(iogrp)) + call finlyr(jprefsilica(iogrp),jdp(iogrp)) call finlyr(jprefalk(iogrp),jdp(iogrp)) call finlyr(jprefdic(iogrp),jdp(iogrp)) call finlyr(jdicsat(iogrp),jdp(iogrp)) @@ -291,6 +356,40 @@ subroutine ncwrt_bgc(iogrp) if (use_BROMO) then call finlyr(jbromo(iogrp),jdp(iogrp)) endif +#ifdef extNcycle + call finlyr(janh4(iogrp),jdp(iogrp)) + call finlyr(jano2(iogrp),jdp(iogrp)) + call finlyr(jnitr_NH4(iogrp),jdp(iogrp)) + call finlyr(jnitr_NO2(iogrp),jdp(iogrp)) + call finlyr(jnitr_N2O_prod(iogrp),jdp(iogrp)) + call finlyr(jnitr_NH4_OM(iogrp),jdp(iogrp)) + call finlyr(jnitr_NO2_OM(iogrp),jdp(iogrp)) + call finlyr(jdenit_NO3(iogrp),jdp(iogrp)) + call finlyr(jdenit_NO2(iogrp),jdp(iogrp)) + call finlyr(jdenit_N2O(iogrp),jdp(iogrp)) + call finlyr(jDNRA_NO2(iogrp),jdp(iogrp)) + call finlyr(janmx_N2_prod(iogrp),jdp(iogrp)) + call finlyr(janmx_OM_prod(iogrp),jdp(iogrp)) + call finlyr(jphosy_NH4(iogrp),jdp(iogrp)) + call finlyr(jphosy_NO3(iogrp),jdp(iogrp)) + call finlyr(jremin_aerob(iogrp),jdp(iogrp)) + call finlyr(jremin_sulf(iogrp),jdp(iogrp)) +#endif + if(lm4ago)then + ! M4AGO + call finlyr(jagg_ws(iogrp),jdp(iogrp)) + call finlyr(jdynvis(iogrp),jdp(iogrp)) + call finlyr(jagg_stick(iogrp),jdp(iogrp)) + call finlyr(jagg_stickf(iogrp),jdp(iogrp)) + call finlyr(jagg_dmax(iogrp),jdp(iogrp)) + call finlyr(jagg_avdp(iogrp),jdp(iogrp)) + call finlyr(jagg_avrhop(iogrp),jdp(iogrp)) + call finlyr(jagg_avdC(iogrp),jdp(iogrp)) + call finlyr(jagg_df(iogrp),jdp(iogrp)) + call finlyr(jagg_b(iogrp),jdp(iogrp)) + call finlyr(jagg_Vrhof(iogrp),jdp(iogrp)) + call finlyr(jagg_Vpor(iogrp),jdp(iogrp)) + endif ! --- Mask sea floor in mass fluxes call msksrf(jcarflx0100(iogrp),k0100) @@ -332,6 +431,7 @@ subroutine ncwrt_bgc(iogrp) call msklvl(jlvlprefo2(iogrp),depths) call msklvl(jlvlo2sat(iogrp),depths) call msklvl(jlvlprefpo4(iogrp),depths) + call msklvl(jlvlprefsilica(iogrp),depths) call msklvl(jlvlprefalk(iogrp),depths) call msklvl(jlvlprefdic(iogrp),depths) call msklvl(jlvldicsat(iogrp),depths) @@ -371,6 +471,40 @@ subroutine ncwrt_bgc(iogrp) if (use_BROMO) then call msklvl(jlvlbromo(iogrp),depths) endif +#ifdef extNcycle + call msklvl(jlvlanh4(iogrp),depths) + call msklvl(jlvlano2(iogrp),depths) + call msklvl(jlvl_nitr_NH4(iogrp),depths) + call msklvl(jlvl_nitr_NO2(iogrp),depths) + call msklvl(jlvl_nitr_N2O_prod(iogrp),depths) + call msklvl(jlvl_nitr_NH4_OM(iogrp),depths) + call msklvl(jlvl_nitr_NO2_OM(iogrp),depths) + call msklvl(jlvl_denit_NO3(iogrp),depths) + call msklvl(jlvl_denit_NO2(iogrp),depths) + call msklvl(jlvl_denit_N2O(iogrp),depths) + call msklvl(jlvl_DNRA_NO2(iogrp),depths) + call msklvl(jlvl_anmx_N2_prod(iogrp),depths) + call msklvl(jlvl_anmx_OM_prod(iogrp),depths) + call msklvl(jlvl_phosy_NH4(iogrp),depths) + call msklvl(jlvl_phosy_NO3(iogrp),depths) + call msklvl(jlvl_remin_aerob(iogrp),depths) + call msklvl(jlvl_remin_sulf(iogrp),depths) +#endif + if(lm4ago)then + ! M4AGO + call msklvl(jlvl_agg_ws(iogrp),depths) + call msklvl(jlvl_dynvis(iogrp),depths) + call msklvl(jlvl_agg_stick(iogrp),depths) + call msklvl(jlvl_agg_stickf(iogrp),depths) + call msklvl(jlvl_agg_dmax(iogrp),depths) + call msklvl(jlvl_agg_avdp(iogrp),depths) + call msklvl(jlvl_agg_avrhop(iogrp),depths) + call msklvl(jlvl_agg_avdC(iogrp),depths) + call msklvl(jlvl_agg_df(iogrp),depths) + call msklvl(jlvl_agg_b(iogrp),depths) + call msklvl(jlvl_agg_Vrhof(iogrp),depths) + call msklvl(jlvl_agg_Vpor(iogrp),depths) + endif ! --- Compute log10 of pH if (SRF_PH(iogrp).ne.0) call logsrf(jsrfph(iogrp),rnacc,0.) @@ -395,6 +529,7 @@ subroutine ncwrt_bgc(iogrp) call wrtsrf(joxflux(iogrp), SRF_OXFLUX(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'fgo2') call wrtsrf(jniflux(iogrp), SRF_NIFLUX(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'fgn2') call wrtsrf(jn2ofx(iogrp), SRF_N2OFX(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'n2oflux') + call wrtsrf(jsrfpn2om(iogrp), SRF_PN2OM(iogrp), rnacc, 0.,cmpflg,'pn2om') call wrtsrf(jdms(iogrp), SRF_DMS(iogrp), rnacc, 0.,cmpflg,'dms') call wrtsrf(jdmsprod(iogrp), SRF_DMSPROD(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'dmsprod') call wrtsrf(jdms_bac(iogrp), SRF_DMS_BAC(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'dms_bac') @@ -414,7 +549,7 @@ subroutine ncwrt_bgc(iogrp) call wrtsrf(jintphosy(iogrp), INT_PHOSY(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'ppint') call wrtsrf(jintnfix(iogrp), INT_NFIX(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'nfixint') call wrtsrf(jintdnit(iogrp), INT_DNIT(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'dnitint') - call wrtsrf(jndepfx(iogrp), FLX_NDEP(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'ndep') + call wrtsrf(jndepnoyfx(iogrp), FLX_NDEPNOY(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'ndepnoy') call wrtsrf(joalkfx(iogrp), FLX_OALK(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'oalkfx') call wrtsrf(jcarflx0100(iogrp), FLX_CAR0100(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'carflx0100') call wrtsrf(jcarflx0500(iogrp), FLX_CAR0500(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'carflx0500') @@ -442,7 +577,16 @@ subroutine ncwrt_bgc(iogrp) call wrtsrf(jsediffn2(iogrp), FLX_SEDIFFN2(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'sedfn2') call wrtsrf(jsediffno3(iogrp), FLX_SEDIFFNO3(iogrp),rnacc*1e3/dtbgc,0.,cmpflg,'sedfno3') call wrtsrf(jsediffsi(iogrp), FLX_SEDIFFSI(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'sedfsi') - endif + call wrtsrf(jburflxsso12(iogrp), FLX_BURSSO12(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'burfsso12') + call wrtsrf(jburflxsssc12(iogrp),FLX_BURSSSC12(iogrp),rnacc*1e3/dtbgc,0.,cmpflg,'burfsssc12') + call wrtsrf(jburflxssssil(iogrp),FLX_BURSSSSIL(iogrp),rnacc*1e3/dtbgc,0.,cmpflg,'burfssssil') + call wrtsrf(jburflxssster(iogrp),FLX_BURSSSTER(iogrp),rnacc*1e3/dtbgc,0.,cmpflg,'burfssster') + endif +#if defined(extNcycle) && ! defined(sedbypass) + call wrtsrf(jsediffnh4(iogrp), FLX_SEDIFFNH4(iogrp),rnacc*1e3/dtbgc,0.,cmpflg,'sedfnh4') + call wrtsrf(jsediffn2o(iogrp), FLX_SEDIFFN2O(iogrp),rnacc*1e3/dtbgc,0.,cmpflg,'sedfn2o') + call wrtsrf(jsediffno2(iogrp), FLX_SEDIFFNO2(iogrp),rnacc*1e3/dtbgc,0.,cmpflg,'sedfno2') +#endif if (use_cisonew) then call wrtsrf(jco213fxd(iogrp), SRF_CO213FXD(iogrp), rnacc*12./dtbgc,0.,cmpflg,'co213fxd') call wrtsrf(jco213fxu(iogrp), SRF_CO213FXU(iogrp), rnacc*12./dtbgc,0.,cmpflg,'co213fxu') @@ -477,7 +621,15 @@ subroutine ncwrt_bgc(iogrp) call wrtsrf(jatmc13(iogrp), SRF_ATMC13(iogrp), rnacc, 0.,cmpflg,'atmc13') call wrtsrf(jatmc14(iogrp), SRF_ATMC14(iogrp), rnacc, 0.,cmpflg,'atmc14') endif - +#ifdef extNcycle + call wrtsrf(jsrfanh4(iogrp), SRF_ANH4(iogrp), rnacc*1e3, 0.,cmpflg,'srfnh4') + call wrtsrf(jsrfpnh3(iogrp), SRF_PNH3(iogrp), rnacc, 0.,cmpflg,'pnh3') + call wrtsrf(jsrfano2(iogrp), SRF_ANO2(iogrp), rnacc*1e3, 0.,cmpflg,'srfno2') + call wrtsrf(janh3fx(iogrp), SRF_ANH3FX(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'nh3flux') + call wrtsrf(jatmnh3(iogrp), SRF_ATMNH3(iogrp), rnacc, 0.,cmpflg,'atmnh3') + call wrtsrf(jatmn2o(iogrp), SRF_ATMN2O(iogrp), rnacc, 0.,cmpflg,'atmn2o') + call wrtsrf(jndepnhxfx(iogrp), FLX_NDEPNHX(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'ndepnhx') +#endif ! --- Store 3d layer fields call wrtlyr(jdp(iogrp), LYR_DP(iogrp), rnacc, 0.,cmpflg,'pddpo') call wrtlyr(jdic(iogrp), LYR_DIC(iogrp), 1e3, 0.,cmpflg,'dissic') @@ -502,6 +654,7 @@ subroutine ncwrt_bgc(iogrp) call wrtlyr(jprefo2(iogrp), LYR_PREFO2(iogrp), 1e3, 0.,cmpflg,'p_o2') call wrtlyr(jo2sat(iogrp), LYR_O2SAT(iogrp), 1e3, 0.,cmpflg,'satoxy') call wrtlyr(jprefpo4(iogrp), LYR_PREFPO4(iogrp), 1e3, 0.,cmpflg,'p_po4') + call wrtlyr(jprefsilica(iogrp), LYR_PREFSILICA(iogrp), 1e3, 0.,cmpflg,'p_silica') call wrtlyr(jprefalk(iogrp), LYR_PREFALK(iogrp), 1e3, 0.,cmpflg,'p_talk') call wrtlyr(jprefdic(iogrp), LYR_PREFDIC(iogrp), 1e3, 0.,cmpflg,'p_dic') call wrtlyr(jdicsat(iogrp), LYR_DICSAT(iogrp), 1e3, 0.,cmpflg,'sat_dic') @@ -541,6 +694,40 @@ subroutine ncwrt_bgc(iogrp) if (use_BROMO) then call wrtlyr(jbromo(iogrp), LYR_BROMO(iogrp), 1e3, 0.,cmpflg,'bromo') endif +#ifdef extNcycle + call wrtlyr(janh4(iogrp), LYR_ANH4(iogrp), 1e3, 0.,cmpflg,'nh4') + call wrtlyr(jano2(iogrp), LYR_ANO2(iogrp), 1e3, 0.,cmpflg,'no2') + call wrtlyr(jnitr_NH4(iogrp), LYR_nitr_NH4(iogrp), 1e3/dtbgc, 0.,cmpflg,'nh4nitr') + call wrtlyr(jnitr_NO2(iogrp), LYR_nitr_NO2(iogrp), 1e3/dtbgc, 0.,cmpflg,'no2nitr') + call wrtlyr(jnitr_N2O_prod(iogrp),LYR_nitr_N2O_prod(iogrp),1e3/dtbgc, 0.,cmpflg,'nitr_n2o') + call wrtlyr(jnitr_NH4_OM(iogrp), LYR_nitr_NH4_OM(iogrp),1e3/dtbgc, 0.,cmpflg,'nh4nitr_om') + call wrtlyr(jnitr_NO2_OM(iogrp), LYR_nitr_NO2_OM(iogrp),1e3/dtbgc, 0.,cmpflg,'no2nitr_om') + call wrtlyr(jdenit_NO3(iogrp), LYR_denit_NO3(iogrp),1e3/dtbgc, 0.,cmpflg,'no3denit') + call wrtlyr(jdenit_NO2(iogrp), LYR_denit_NO2(iogrp),1e3/dtbgc, 0.,cmpflg,'no2denit') + call wrtlyr(jdenit_N2O(iogrp), LYR_denit_N2O(iogrp),1e3/dtbgc, 0.,cmpflg,'n2odenit') + call wrtlyr(jDNRA_NO2(iogrp), LYR_DNRA_NO2(iogrp), 1e3/dtbgc, 0.,cmpflg,'no2dnra') + call wrtlyr(janmx_N2_prod(iogrp),LYR_anmx_N2_prod(iogrp),1e3/dtbgc, 0.,cmpflg,'anmx_n2') + call wrtlyr(janmx_OM_prod(iogrp),LYR_anmx_OM_prod(iogrp),1e3/dtbgc, 0.,cmpflg,'anmx_om') + call wrtlyr(jphosy_NH4(iogrp), LYR_phosy_NH4(iogrp),1e3/dtbgc, 0.,cmpflg,'phosy_nh4') + call wrtlyr(jphosy_NO3(iogrp), LYR_phosy_NO3(iogrp),1e3/dtbgc, 0.,cmpflg,'phosy_no3') + call wrtlyr(jremin_aerob(iogrp), LYR_remin_aerob(iogrp),1e3/dtbgc, 0.,cmpflg,'remina') + call wrtlyr(jremin_sulf(iogrp), LYR_remin_sulf(iogrp),1e3/dtbgc, 0.,cmpflg,'remins') +#endif + if(lm4ago)then + ! M4AGO + call wrtlyr(jagg_ws(iogrp), LYR_agg_ws(iogrp), 1., 0.,cmpflg,'agg_ws') + call wrtlyr(jdynvis(iogrp), LYR_dynvis(iogrp), 1., 0.,cmpflg,'dynvis') + call wrtlyr(jagg_stick(iogrp), LYR_agg_stick(iogrp),1., 0.,cmpflg,'agg_stick') + call wrtlyr(jagg_stickf(iogrp), LYR_agg_stickf(iogrp),1., 0.,cmpflg,'agg_stickf') + call wrtlyr(jagg_dmax(iogrp), LYR_agg_dmax(iogrp), 1., 0.,cmpflg,'agg_dmax') + call wrtlyr(jagg_avdp(iogrp), LYR_agg_avdp(iogrp), 1., 0.,cmpflg,'agg_avdp') + call wrtlyr(jagg_avrhop(iogrp), LYR_agg_avrhop(iogrp),1., 0.,cmpflg,'agg_avrhop') + call wrtlyr(jagg_avdC(iogrp), LYR_agg_avdC(iogrp), 1., 0.,cmpflg,'agg_avdC') + call wrtlyr(jagg_df(iogrp), LYR_agg_df(iogrp), 1., 0.,cmpflg,'agg_df') + call wrtlyr(jagg_b(iogrp), LYR_agg_b(iogrp), 1., 0.,cmpflg,'agg_b') + call wrtlyr(jagg_Vrhof(iogrp), LYR_agg_Vrhof(iogrp),1., 0.,cmpflg,'agg_Vrhof') + call wrtlyr(jagg_Vpor(iogrp), LYR_agg_Vpor(iogrp), 1., 0.,cmpflg,'agg_Vpor') + endif ! --- Store 3d level fields call wrtlvl(jlvldic(iogrp), LVL_DIC(iogrp), rnacc*1e3, 0.,cmpflg,'dissiclvl') @@ -565,6 +752,7 @@ subroutine ncwrt_bgc(iogrp) call wrtlvl(jlvlprefo2(iogrp), LVL_PREFO2(iogrp), rnacc*1e3, 0.,cmpflg,'p_o2lvl') call wrtlvl(jlvlo2sat(iogrp), LVL_O2SAT(iogrp), rnacc*1e3, 0.,cmpflg,'satoxylvl') call wrtlvl(jlvlprefpo4(iogrp), LVL_PREFPO4(iogrp), rnacc*1e3, 0.,cmpflg,'p_po4lvl') + call wrtlvl(jlvlprefsilica(iogrp),LVL_PREFSILICA(iogrp), rnacc*1e3, 0.,cmpflg,'p_silicalvl') call wrtlvl(jlvlprefalk(iogrp), LVL_PREFALK(iogrp), rnacc*1e3, 0.,cmpflg,'p_talklvl') call wrtlvl(jlvlprefdic(iogrp), LVL_PREFDIC(iogrp), rnacc*1e3, 0.,cmpflg,'p_diclvl') call wrtlvl(jlvldicsat(iogrp), LVL_DICSAT(iogrp), rnacc*1e3, 0.,cmpflg,'sat_diclvl') @@ -604,6 +792,40 @@ subroutine ncwrt_bgc(iogrp) if (use_BROMO) then call wrtlvl(jlvlbromo(iogrp), LVL_BROMO(iogrp), rnacc*1e3, 0.,cmpflg,'bromolvl') endif +#ifdef extNcycle + call wrtlvl(jlvlanh4(iogrp), LVL_ANH4(iogrp), rnacc*1e3, 0.,cmpflg,'nh4lvl') + call wrtlvl(jlvlano2(iogrp), LVL_ANO2(iogrp), rnacc*1e3, 0.,cmpflg,'no2lvl') + call wrtlvl(jlvl_nitr_NH4(iogrp), LVL_nitr_NH4(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'nh4nitrlvl') + call wrtlvl(jlvl_nitr_NO2(iogrp), LVL_nitr_NO2(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'no2nitrlvl') + call wrtlvl(jlvl_nitr_N2O_prod(iogrp),LVL_nitr_N2O_prod(iogrp),rnacc*1e3/dtbgc,0.,cmpflg,'nitr_n2olvl') + call wrtlvl(jlvl_nitr_NH4_OM(iogrp), LVL_nitr_NH4_OM(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'nh4nitr_omlvl') + call wrtlvl(jlvl_nitr_NO2_OM(iogrp), LVL_nitr_NO2_OM(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'no2nitr_omlvl') + call wrtlvl(jlvl_denit_NO3(iogrp), LVL_denit_NO3(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'no3denitlvl') + call wrtlvl(jlvl_denit_NO2(iogrp), LVL_denit_NO2(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'no2denitlvl') + call wrtlvl(jlvl_denit_N2O(iogrp), LVL_denit_N2O(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'n2odenitlvl') + call wrtlvl(jlvl_DNRA_NO2(iogrp), LVL_DNRA_NO2(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'no2dnralvl') + call wrtlvl(jlvl_anmx_N2_prod(iogrp), LVL_anmx_N2_prod(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'anmx_n2lvl') + call wrtlvl(jlvl_anmx_OM_prod(iogrp), LVL_anmx_OM_prod(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'anmx_omlvl') + call wrtlvl(jlvl_phosy_NH4(iogrp), LVL_phosy_NH4(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'phosy_nh4lvl') + call wrtlvl(jlvl_phosy_NO3(iogrp), LVL_phosy_NO3(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'phosy_no3lvl') + call wrtlvl(jlvl_remin_aerob(iogrp), LVL_remin_aerob(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'reminalvl') + call wrtlvl(jlvl_remin_sulf(iogrp), LVL_remin_sulf(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'reminslvl') +#endif + if(lm4ago)then + ! M4AGO + call wrtlvl(jlvl_agg_ws(iogrp), LVL_agg_ws(iogrp), rnacc, 0.,cmpflg,'agg_wslvl') + call wrtlvl(jlvl_dynvis(iogrp), LVL_dynvis(iogrp), rnacc, 0.,cmpflg,'dynvislvl') + call wrtlvl(jlvl_agg_stick(iogrp), LVL_agg_stick(iogrp), rnacc, 0.,cmpflg,'agg_sticklvl') + call wrtlvl(jlvl_agg_stickf(iogrp), LVL_agg_stickf(iogrp), rnacc, 0.,cmpflg,'agg_stickflvl') + call wrtlvl(jlvl_agg_dmax(iogrp), LVL_agg_dmax(iogrp), rnacc, 0.,cmpflg,'agg_dmaxlvl') + call wrtlvl(jlvl_agg_avdp(iogrp), LVL_agg_avdp(iogrp), rnacc, 0.,cmpflg,'agg_avdplvl') + call wrtlvl(jlvl_agg_avrhop(iogrp), LVL_agg_avrhop(iogrp), rnacc, 0.,cmpflg,'agg_avrhoplvl') + call wrtlvl(jlvl_agg_avdC(iogrp), LVL_agg_avdC(iogrp), rnacc, 0.,cmpflg,'agg_avdClvl') + call wrtlvl(jlvl_agg_df(iogrp), LVL_agg_df(iogrp), rnacc, 0.,cmpflg,'agg_dflvl') + call wrtlvl(jlvl_agg_b(iogrp), LVL_agg_b(iogrp), rnacc, 0.,cmpflg,'agg_blvl') + call wrtlvl(jlvl_agg_Vrhof(iogrp), LVL_agg_Vrhof(iogrp), rnacc, 0.,cmpflg,'agg_Vrhoflvl') + call wrtlvl(jlvl_agg_Vpor(iogrp), LVL_agg_Vpor(iogrp), rnacc, 0.,cmpflg,'agg_Vporlvl') + endif ! --- Store sediment fields if (.not. use_sedbypass) then @@ -625,6 +847,24 @@ subroutine ncwrt_bgc(iogrp) call wrtbur(jburssssil(iogrp), BUR_SSSSIL(iogrp), rnacc*1e3, 0.,cmpflg,'bursil') call wrtbur(jburssster(iogrp), BUR_SSSTER(iogrp), rnacc, 0.,cmpflg,'burter') endif +#if defined(extNcycle) && ! defined(sedbypass) + call wrtsdm(jpownh4(iogrp), SDM_POWNH4(iogrp), rnacc*1e3, 0.,cmpflg,'pownh4') + call wrtsdm(jpown2o(iogrp), SDM_POWN2O(iogrp), rnacc*1e3, 0.,cmpflg,'pown2o') + call wrtsdm(jpowno2(iogrp), SDM_POWNO2(iogrp), rnacc*1e3, 0.,cmpflg,'powno2') + call wrtsdm(jsdm_nitr_NH4(iogrp), sdm_nitr_NH4(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'nh4nitrsdm') + call wrtsdm(jsdm_nitr_NO2(iogrp), sdm_nitr_NO2(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'no2nitrsdm') + call wrtsdm(jsdm_nitr_N2O_prod(iogrp),sdm_nitr_N2O_prod(iogrp),rnacc*1e3/dtbgc,0.,cmpflg,'nitr_n2osdm') + call wrtsdm(jsdm_nitr_NH4_OM(iogrp), sdm_nitr_NH4_OM(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'nh4nitr_omsdm') + call wrtsdm(jsdm_nitr_NO2_OM(iogrp), sdm_nitr_NO2_OM(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'no2nitr_omsdm') + call wrtsdm(jsdm_denit_NO3(iogrp), sdm_denit_NO3(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'no3denitsdm') + call wrtsdm(jsdm_denit_NO2(iogrp), sdm_denit_NO2(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'no2denitsdm') + call wrtsdm(jsdm_denit_N2O(iogrp), sdm_denit_N2O(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'n2odenitsdm') + call wrtsdm(jsdm_DNRA_NO2(iogrp), sdm_DNRA_NO2(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'no2dnrasdm') + call wrtsdm(jsdm_anmx_N2_prod(iogrp), sdm_anmx_N2_prod(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'anmx_n2sdm') + call wrtsdm(jsdm_anmx_OM_prod(iogrp), sdm_anmx_OM_prod(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'anmx_omsdm') + call wrtsdm(jsdm_remin_aerob(iogrp), sdm_remin_aerob(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'reminasdm') + call wrtsdm(jsdm_remin_sulf(iogrp), sdm_remin_sulf(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'reminssdm') +#endif ! --- close netcdf file call ncfcls @@ -642,6 +882,7 @@ subroutine ncwrt_bgc(iogrp) call inisrf(joxflux(iogrp),0.) call inisrf(jniflux(iogrp),0.) call inisrf(jn2ofx(iogrp),0.) + call inisrf(jsrfpn2om(iogrp),0.) call inisrf(jdms(iogrp),0.) call inisrf(jdmsprod(iogrp),0.) call inisrf(jdms_bac(iogrp),0.) @@ -661,7 +902,7 @@ subroutine ncwrt_bgc(iogrp) call inisrf(jintphosy(iogrp),0.) call inisrf(jintnfix(iogrp),0.) call inisrf(jintdnit(iogrp),0.) - call inisrf(jndepfx(iogrp),0.) + call inisrf(jndepnoyfx(iogrp),0.) call inisrf(joalkfx(iogrp),0.) call inisrf(jcarflx0100(iogrp),0.) call inisrf(jcarflx0500(iogrp),0.) @@ -689,6 +930,10 @@ subroutine ncwrt_bgc(iogrp) call inisrf(jsediffn2(iogrp),0.) call inisrf(jsediffno3(iogrp),0.) call inisrf(jsediffsi(iogrp),0.) + call inisrf(jburflxsso12(iogrp),0.) + call inisrf(jburflxsssc12(iogrp),0.) + call inisrf(jburflxssssil(iogrp),0.) + call inisrf(jburflxssster(iogrp),0.) endif if (use_cisonew) then call inisrf(jco213fxd(iogrp),0.) @@ -726,7 +971,20 @@ subroutine ncwrt_bgc(iogrp) call inisrf(jatmc13(iogrp),0.) call inisrf(jatmc14(iogrp),0.) endif - +#ifdef extNcycle + call inisrf(jsrfanh4(iogrp),0.) + call inisrf(jsrfpnh3(iogrp),0.) + call inisrf(jsrfano2(iogrp),0.) + call inisrf(janh3fx(iogrp),0.) + call inisrf(jatmnh3(iogrp),0.) + call inisrf(jatmn2o(iogrp),0.) + call inisrf(jndepnhxfx(iogrp),0.) +#endif +#if defined(extNcycle) && ! defined(sedbypass) + call inisrf(jsediffnh4(iogrp),0.) + call inisrf(jsediffn2o(iogrp),0.) + call inisrf(jsediffno2(iogrp),0.) +#endif call inilyr(jdp(iogrp),0.) call inilyr(jdic(iogrp),0.) call inilyr(jalkali(iogrp),0.) @@ -750,6 +1008,7 @@ subroutine ncwrt_bgc(iogrp) call inilyr(jprefo2(iogrp),0.) call inilyr(jo2sat(iogrp),0.) call inilyr(jprefpo4(iogrp),0.) + call inilyr(jprefsilica(iogrp),0.) call inilyr(jprefalk(iogrp),0.) call inilyr(jprefdic(iogrp),0.) call inilyr(jdicsat(iogrp),0.) @@ -789,7 +1048,40 @@ subroutine ncwrt_bgc(iogrp) if (use_BROMO) then call inilyr(jbromo(iogrp),0.) endif - +#ifdef extNcycle + call inilyr(janh4(iogrp),0.) + call inilyr(jano2(iogrp),0.) + call inilyr(jnitr_NH4(iogrp),0.) + call inilyr(jnitr_NO2(iogrp),0.) + call inilyr(jnitr_N2O_prod(iogrp),0.) + call inilyr(jnitr_NH4_OM(iogrp),0.) + call inilyr(jnitr_NO2_OM(iogrp),0.) + call inilyr(jdenit_NO3(iogrp),0.) + call inilyr(jdenit_NO2(iogrp),0.) + call inilyr(jdenit_N2O(iogrp),0.) + call inilyr(jDNRA_NO2(iogrp),0.) + call inilyr(janmx_N2_prod(iogrp),0.) + call inilyr(janmx_OM_prod(iogrp),0.) + call inilyr(jphosy_NH4(iogrp),0.) + call inilyr(jphosy_NO3(iogrp),0.) + call inilyr(jremin_aerob(iogrp),0.) + call inilyr(jremin_sulf(iogrp),0.) +#endif + if(lm4ago)then + ! M4AGO + call inilyr(jagg_ws(iogrp),0.) + call inilyr(jdynvis(iogrp),0.) + call inilyr(jagg_stick(iogrp),0.) + call inilyr(jagg_stickf(iogrp),0.) + call inilyr(jagg_dmax(iogrp),0.) + call inilyr(jagg_avdp(iogrp),0.) + call inilyr(jagg_avrhop(iogrp),0.) + call inilyr(jagg_avdC(iogrp),0.) + call inilyr(jagg_df(iogrp),0.) + call inilyr(jagg_b(iogrp),0.) + call inilyr(jagg_Vrhof(iogrp),0.) + call inilyr(jagg_Vpor(iogrp),0.) + endif call inilvl(jlvldic(iogrp),0.) call inilvl(jlvlalkali(iogrp),0.) call inilvl(jlvlphosy(iogrp),0.) @@ -812,6 +1104,7 @@ subroutine ncwrt_bgc(iogrp) call inilvl(jlvlprefo2(iogrp),0.) call inilvl(jlvlo2sat(iogrp),0.) call inilvl(jlvlprefpo4(iogrp),0.) + call inilvl(jlvlprefsilica(iogrp),0.) call inilvl(jlvlprefalk(iogrp),0.) call inilvl(jlvlprefdic(iogrp),0.) call inilvl(jlvldicsat(iogrp),0.) @@ -851,6 +1144,40 @@ subroutine ncwrt_bgc(iogrp) if (use_BROMO) then call inilvl(jlvlbromo(iogrp),0.) endif +#ifdef extNcycle + call inilvl(jlvlanh4(iogrp),0.) + call inilvl(jlvlano2(iogrp),0.) + call inilvl(jlvl_nitr_NH4(iogrp),0.) + call inilvl(jlvl_nitr_NO2(iogrp),0.) + call inilvl(jlvl_nitr_N2O_prod(iogrp),0.) + call inilvl(jlvl_nitr_NH4_OM(iogrp),0.) + call inilvl(jlvl_nitr_NO2_OM(iogrp),0.) + call inilvl(jlvl_denit_NO3(iogrp),0.) + call inilvl(jlvl_denit_NO2(iogrp),0.) + call inilvl(jlvl_denit_N2O(iogrp),0.) + call inilvl(jlvl_DNRA_NO2(iogrp),0.) + call inilvl(jlvl_anmx_N2_prod(iogrp),0.) + call inilvl(jlvl_anmx_OM_prod(iogrp),0.) + call inilvl(jlvl_phosy_NH4(iogrp),0.) + call inilvl(jlvl_phosy_NO3(iogrp),0.) + call inilvl(jlvl_remin_aerob(iogrp),0.) + call inilvl(jlvl_remin_sulf(iogrp),0.) +#endif + if(lm4ago)then + ! M4AGO + call inilvl(jlvl_agg_ws(iogrp),0.) + call inilvl(jlvl_dynvis(iogrp),0.) + call inilvl(jlvl_agg_stick(iogrp),0.) + call inilvl(jlvl_agg_stickf(iogrp),0.) + call inilvl(jlvl_agg_dmax(iogrp),0.) + call inilvl(jlvl_agg_avdp(iogrp),0.) + call inilvl(jlvl_agg_avrhop(iogrp),0.) + call inilvl(jlvl_agg_avdC(iogrp),0.) + call inilvl(jlvl_agg_df(iogrp),0.) + call inilvl(jlvl_agg_b(iogrp),0.) + call inilvl(jlvl_agg_Vrhof(iogrp),0.) + call inilvl(jlvl_agg_Vpor(iogrp),0.) + endif if (.not. use_sedbypass) then call inisdm(jpowaic(iogrp),0.) @@ -870,7 +1197,24 @@ subroutine ncwrt_bgc(iogrp) call inibur(jburssssil(iogrp),0.) call inibur(jburssster(iogrp),0.) endif - +#if defined(extNcycle) && ! defined(sedbypass) + call inisdm(jpownh4(iogrp),0.) + call inisdm(jpown2o(iogrp),0.) + call inisdm(jpowno2(iogrp),0.) + call inisdm(jsdm_nitr_NH4(iogrp),0.) + call inisdm(jsdm_nitr_NO2(iogrp),0.) + call inisdm(jsdm_nitr_N2O_prod(iogrp),0.) + call inisdm(jsdm_nitr_NH4_OM(iogrp),0.) + call inisdm(jsdm_nitr_NO2_OM(iogrp),0.) + call inisdm(jsdm_denit_NO3(iogrp),0.) + call inisdm(jsdm_denit_NO2(iogrp),0.) + call inisdm(jsdm_denit_N2O(iogrp),0.) + call inisdm(jsdm_DNRA_NO2(iogrp),0.) + call inisdm(jsdm_anmx_N2_prod(iogrp),0.) + call inisdm(jsdm_anmx_OM_prod(iogrp),0.) + call inisdm(jsdm_remin_aerob(iogrp),0.) + call inisdm(jsdm_remin_sulf(iogrp),0.) +#endif nacc_bgc(iogrp)=0 end subroutine ncwrt_bgc @@ -883,23 +1227,26 @@ subroutine hamoccvardef(iogrp,timeunits,calendar,cmpflg) use mod_nctools, only: ncdefvar,ncattr,ncfopn,ncdimc,ncdims, & nctime,ncfcls,ncedef,ncdefvar3d,ndouble + use mo_control_bgc,only:lm4ago use mo_bgcmean, only: srf_kwco2,srf_pco2,srf_dmsflux,srf_co2fxd, & srf_kwco2khm,srf_co2kh,srf_co2khm,srf_pco2m, & - srf_co2fxu,srf_oxflux,srf_niflux,srf_dms,srf_dmsprod, & + srf_co2fxu,srf_oxflux,srf_niflux,srf_pn2om,srf_dms,srf_dmsprod, & srf_dms_bac,srf_dms_uv,srf_export,srf_exposi,srf_expoca, & srf_dic,srf_alkali,srf_phosph,srf_oxygen,srf_ano3,srf_silica, & srf_iron,srf_phyto,srf_ph,int_phosy,int_nfix,int_dnit, & - flx_ndep,flx_oalk,flx_car0100,flx_car0500, & + flx_ndepnoy,flx_oalk,flx_car0100,flx_car0500, & flx_car1000,flx_car2000,flx_car4000,flx_car_bot, & flx_bsi0100,flx_bsi0500,flx_bsi1000,flx_bsi2000,flx_bsi4000, & flx_bsi_bot,flx_cal0100,flx_cal0500,flx_cal1000,flx_cal2000, & flx_cal4000,flx_cal_bot,flx_sediffic,flx_sediffal, & flx_sediffph,flx_sediffox,flx_sediffn2,flx_sediffno3, & - flx_sediffsi,srf_n2ofx,srf_atmco2,lyr_dp,lyr_dic, & + flx_sediffsi,flx_bursso12,flx_bursssc12,flx_burssssil,flx_burssster, & + srf_n2ofx,srf_atmco2,lyr_dp,lyr_dic, & lyr_alkali,lyr_phosph,lyr_oxygen,lyr_ano3,lyr_silica,lyr_doc, & lyr_phyto,lyr_grazer,lyr_poc,lyr_calc,lyr_opal,lyr_iron, & lyr_phosy,lyr_co3,lyr_ph,lyr_omegaa,lyr_omegac,lyr_n2o, & lyr_prefo2,lyr_o2sat,lyr_prefpo4,lyr_prefalk,lyr_prefdic, & + lyr_prefsilica, & lyr_dicsat,lvl_dic,lvl_alkali,lvl_phosph,lvl_oxygen,lvl_ano3, & lvl_silica,lvl_doc,lvl_phyto,lvl_grazer,lvl_poc,lvl_calc, & lvl_opal,lvl_iron,lvl_phosy,lvl_co3,lvl_ph,lvl_omegaa, & @@ -924,7 +1271,60 @@ subroutine hamoccvardef(iogrp,timeunits,calendar,cmpflg) lvl_natomegaa,lvl_natomegac,lvl_natco3, & sdm_powaic,sdm_powaal,sdm_powaph,sdm_powaox, & sdm_pown2,sdm_powno3,sdm_powasi,sdm_ssso12,sdm_ssssil, & - sdm_sssc12,sdm_ssster,bur_ssso12,bur_sssc12,bur_ssssil,bur_ssster + sdm_sssc12,sdm_ssster,bur_ssso12,bur_sssc12,bur_ssssil,bur_ssster, & + lvl_prefsilica, & + lyr_agg_ws,lyr_dynvis,lyr_agg_stick, & + lyr_agg_stickf,lyr_agg_dmax,lyr_agg_avdp, & + lyr_agg_avrhop,lyr_agg_avdC,lyr_agg_df, & + lyr_agg_b,lyr_agg_Vrhof,lyr_agg_Vpor, & + lvl_agg_ws,lvl_dynvis,lvl_agg_stick, & + lvl_agg_stickf,lvl_agg_dmax,lvl_agg_avdp, & + lvl_agg_avrhop,lvl_agg_avdC,lvl_agg_df, & + lvl_agg_b,lvl_agg_Vrhof,lvl_agg_Vpor +#ifdef extNcycle + use mo_bgcmean, only: janh4,jano2,jlvlanh4,jlvlano2,jsrfanh4, & + & jsrfano2,janh3fx,srf_pnh3,srf_anh4,srf_ano2, & + & srf_anh3fx,lyr_anh4,lyr_ano2,lvl_anh4, & + & lvl_ano2, & + & LYR_nitr_NH4,LYR_nitr_NO2,LYR_nitr_N2O_prod, & + & LYR_nitr_NH4_OM,LYR_nitr_NO2_OM, & + & LYR_denit_NO3,LYR_denit_NO2,LYR_denit_N2O, & + & LYR_DNRA_NO2,LYR_anmx_N2_prod, & + & LYR_anmx_OM_prod,LYR_phosy_NH4, & + & LYR_phosy_NO3,LYR_remin_aerob,LYR_remin_sulf, & + & LVL_nitr_NH4,LVL_nitr_NO2,LVL_nitr_N2O_prod, & + & LVL_nitr_NH4_OM,LVL_nitr_NO2_OM, & + & LVL_denit_NO3,LVL_denit_NO2,LVL_denit_N2O, & + & LVL_DNRA_NO2,LVL_anmx_N2_prod, & + & LVL_anmx_OM_prod,LVL_phosy_NH4, & + & LVL_phosy_NO3,LVL_remin_aerob,LVL_remin_sulf, & + & jnitr_NH4,jnitr_NO2,jnitr_N2O_prod, & + & jnitr_NH4_OM,jnitr_NO2_OM,jdenit_NO3, & + & jdenit_NO2,jdenit_N2O,jDNRA_NO2, & + & janmx_N2_prod,janmx_OM_prod,jphosy_NH4, & + & jphosy_NO3,jremin_aerob,jremin_sulf, & + & jlvl_nitr_NH4,jlvl_nitr_NO2, & + & jlvl_nitr_N2O_prod,jlvl_nitr_NH4_OM, & + & jlvl_nitr_NO2_OM,jlvl_denit_NO3, & + & jlvl_denit_NO2,jlvl_denit_N2O,jlvl_DNRA_NO2, & + & jlvl_anmx_N2_prod,jlvl_anmx_OM_prod, & + & jlvl_phosy_NH4,jlvl_phosy_NO3, & + & jlvl_remin_aerob,jlvl_remin_sulf,srf_atmnh3, & + & srf_atmn2o,flx_ndepnhx +#endif +#if defined(extNcycle) && ! defined(sedbypass) + use mo_bgcmean, only: jpownh4,jpown2o,jpowno2,jsdm_nitr_NH4,jsdm_nitr_NO2, & + & jsdm_nitr_N2O_prod,jsdm_nitr_NH4_OM,jsdm_nitr_NO2_OM, & + & jsdm_denit_NO3,jsdm_denit_NO2,jsdm_denit_N2O, & + & jsdm_DNRA_NO2,jsdm_anmx_N2_prod,jsdm_anmx_OM_prod, & + & jsdm_remin_aerob,jsdm_remin_sulf, SDM_POWNH4,SDM_POWN2O,& + & SDM_POWNO2,SDM_nitr_NH4,SDM_nitr_NO2,SDM_nitr_N2O_prod, & + & SDM_nitr_NH4_OM,SDM_nitr_NO2_OM,SDM_denit_NO3, & + & SDM_denit_NO2,SDM_denit_N2O,SDM_DNRA_NO2, & + & SDM_anmx_N2_prod,SDM_anmx_OM_prod,SDM_remin_aerob, & + & SDM_remin_sulf,jsediffnh4,jsediffn2o,jsediffno2, & + & FLX_SEDIFFNH4,FLX_SEDIFFN2O,FLX_SEDIFFNO2 +#endif use mo_control_bgc, only: use_cisonew,use_AGG,use_CFC,use_natDIC,use_BROMO, & use_sedbypass,use_BOXATM @@ -968,6 +1368,8 @@ subroutine hamoccvardef(iogrp,timeunits,calendar,cmpflg) & cmpflg,'p','co2fxu','Upward CO2 flux',' ','kg C m-2 s-1',0) call ncdefvar3d(SRF_OXFLUX(iogrp), & & cmpflg,'p','fgo2','Oxygen flux',' ','mol O2 m-2 s-1',0) + call ncdefvar3d(SRF_PN2OM(iogrp),cmpflg,'p', & + & 'pn2om','Surface pN2O moist air',' ','natm',0) call ncdefvar3d(SRF_NIFLUX(iogrp), & & cmpflg,'p','fgn2','Nitrogen flux',' ','mol N2 m-2 s-1',0) call ncdefvar3d(SRF_DMS(iogrp),cmpflg,'p', & @@ -1009,8 +1411,8 @@ subroutine hamoccvardef(iogrp,timeunits,calendar,cmpflg) & 'Integrated nitrogen fixation',' ','mol N m-2 s-1',0) call ncdefvar3d(INT_DNIT(iogrp),cmpflg,'p','dnitint', & & 'Integrated denitrification',' ','mol N m-2 s-1',0) - call ncdefvar3d(FLX_NDEP(iogrp),cmpflg,'p','ndep', & - & 'Nitrogen deposition flux',' ','mol N m-2 s-1',0) + call ncdefvar3d(FLX_NDEPNOY(iogrp),cmpflg,'p','ndepnoy', & + & 'Nitrogen NOy deposition flux',' ','mol N m-2 s-1',0) call ncdefvar3d(FLX_OALK(iogrp),cmpflg,'p','oalkfx', & & 'Alkalinity flux due to OA',' ','mol TA m-2 s-1',0) call ncdefvar3d(FLX_CAR0100(iogrp),cmpflg,'p','carflx0100', & @@ -1073,7 +1475,30 @@ subroutine hamoccvardef(iogrp,timeunits,calendar,cmpflg) call ncdefvar3d(FLX_SEDIFFSI(iogrp),cmpflg,'p','sedfsi', & & 'diffusive silica flux to sediment (positive downwards)', & & ' ','mol Si m-2 s-1',0) - endif + call ncdefvar3d(FLX_BURSSO12(iogrp),cmpflg,'p','burfsso12', & + & 'Organic matter burial flux to burial layer (positive downwards)',& + & ' ','mol P m-2 s-1',0) + call ncdefvar3d(FLX_BURSSSC12(iogrp),cmpflg,'p','burfsssc12', & + & 'CaCO3 burial flux to burial layer (positive downwards)', & + & ' ','mol Ca m-2 s-1',0) + call ncdefvar3d(FLX_BURSSSSIL(iogrp),cmpflg,'p','burfssssil', & + & 'Opal burial flux to burial layer (positive downwards)', & + & ' ','mol Si m-2 s-1',0) + call ncdefvar3d(FLX_BURSSSTER(iogrp),cmpflg,'p','burfssster', & + & 'Clay burial flux to burial layer (positive downwards)', & + & ' ','g m-2 s-1',0) + endif +#if defined(extNcycle) && ! defined(sedbypass) + call ncdefvar3d(FLX_SEDIFFNH4(iogrp),cmpflg,'p','sedfnh4', & + & 'diffusive ammonium flux to sediment (positive downwards)', & + & ' ','mol NH4 m-2 s-1',0) + call ncdefvar3d(FLX_SEDIFFN2O(iogrp),cmpflg,'p','sedfn2o', & + & 'diffusive nitrous oxide flux to sediment (positive downwards)', & + & ' ','mol N2O m-2 s-1',0) + call ncdefvar3d(FLX_SEDIFFNO2(iogrp),cmpflg,'p','sedfno2', & + & 'diffusive nitrite flux to sediment (positive downwards)', & + & ' ','mol NO2 m-2 s-1',0) +#endif if (use_cisonew) then call ncdefvar3d(SRF_CO213FXD(iogrp),cmpflg,'p','co213fxd', & & 'Downward 13CO2 flux',' ','kg C m-2 s-1',0) @@ -1132,6 +1557,22 @@ subroutine hamoccvardef(iogrp,timeunits,calendar,cmpflg) call ncdefvar3d(SRF_ATMC14(iogrp),cmpflg,'p', & & 'atmc14','Atmospheric 14CO2',' ','ppm',0) endif +#ifdef extNcycle + call ncdefvar3d(SRF_PNH3(iogrp),cmpflg,'p', & + & 'pnh3','Surface pNH3',' ','natm',0) + call ncdefvar3d(SRF_ANH4(iogrp),cmpflg,'p','srfnh4', & + & 'Surface ammonium',' ','mol N m-3',0) + call ncdefvar3d(SRF_ANO2(iogrp),cmpflg,'p','srfno2', & + & 'Surface nitrite',' ','mol N m-3',0) + call ncdefvar3d(SRF_ANH3FX(iogrp),cmpflg,'p','nh3flux', & + & 'NH3 flux',' ','mol NH3 m-2 s-1',0) + call ncdefvar3d(SRF_ATMNH3(iogrp),cmpflg,'p', & + & 'atmnh3','Atmospheric ammonia',' ','ppt',0) + call ncdefvar3d(SRF_ATMN2O(iogrp),cmpflg,'p', & + & 'atmn2o','Atmospheric nitrous oxide',' ','ppt',0) + call ncdefvar3d(FLX_NDEPNHX(iogrp),cmpflg,'p','ndepnhx', & + & 'Nitrogen NHx deposition flux',' ','mol N m-2 s-1',0) +#endif ! --- define 3d layer fields call ncdefvar3d(LYR_DP(iogrp),cmpflg,'p', & @@ -1180,6 +1621,8 @@ subroutine hamoccvardef(iogrp,timeunits,calendar,cmpflg) & 'satoxy','Saturated oxygen',' ','mol O2 m-3',1) call ncdefvar3d(LYR_PREFPO4(iogrp),cmpflg,'p', & & 'p_po4','Preformed phosphorus',' ','mol P m-3',1) + call ncdefvar3d(LYR_PREFSILICA(iogrp),cmpflg,'p', & + & 'p_silica','Preformed silica',' ','mol N m-3',1) call ncdefvar3d(LYR_PREFALK(iogrp),cmpflg,'p', & & 'p_talk','Preformed alkalinity',' ','eq m-3',1) call ncdefvar3d(LYR_PREFDIC(iogrp),cmpflg,'p', & @@ -1248,7 +1691,72 @@ subroutine hamoccvardef(iogrp,timeunits,calendar,cmpflg) call ncdefvar3d(LYR_BROMO(iogrp),cmpflg,'p', & & 'bromo','Bromoform',' ','mol CHBr3 m-3',1) endif - +#ifdef extNcycle + call ncdefvar3d(LYR_ANH4(iogrp),cmpflg,'p', & + & 'nh4','Ammonium',' ','mol N m-3',1) + call ncdefvar3d(LYR_ANO2(iogrp),cmpflg,'p', & + & 'no2','Nitrite',' ','mol N m-3',1) + call ncdefvar3d(LYR_nitr_NH4(iogrp),cmpflg,'p', & + & 'nh4nitr','NH4 nitrification rate',' ','mol N m-3 s-1',1) + call ncdefvar3d(LYR_nitr_NO2(iogrp),cmpflg,'p', & + & 'no2nitr','NO2 nitrification rate',' ','mol N m-3 s-1',1) + call ncdefvar3d(LYR_nitr_N2O_prod(iogrp),cmpflg,'p', & + & 'nitr_n2o','N2O prod during NH4 nitrification',' ', & + & 'mol N2O m-3 s-1',1) + call ncdefvar3d(LYR_nitr_NH4_OM(iogrp),cmpflg,'p', & + & 'nh4nitr_om','OM production during NH4 nitrification',' ', & + & 'mol P m-3 s-1',1) + call ncdefvar3d(LYR_nitr_NO2_OM(iogrp),cmpflg,'p', & + & 'no2nitr_om','OM production during NO2 nitrification',' ', & + & 'mol P m-3 s-1',1) + call ncdefvar3d(LYR_denit_NO3(iogrp),cmpflg,'p', & + & 'no3denit','NO3 denitrification rate',' ','mol N m-3 s-1',1) + call ncdefvar3d(LYR_denit_NO2(iogrp),cmpflg,'p', & + & 'no2denit','NO2 denitrification rate',' ','mol N m-3 s-1',1) + call ncdefvar3d(LYR_denit_N2O(iogrp),cmpflg,'p', & + & 'n2odenit','N2O denitrification rate',' ','mol N2O m-3 s-1',1) + call ncdefvar3d(LYR_DNRA_NO2(iogrp),cmpflg,'p', & + & 'no2dnra','NO2 DNRA rate',' ','mol N m-3 s-1',1) + call ncdefvar3d(LYR_anmx_N2_prod(iogrp),cmpflg,'p', & + & 'anmx_n2','Anammox N2 production rate',' ','mol N2 m-3 s-1',1) + call ncdefvar3d(LYR_anmx_OM_prod(iogrp),cmpflg,'p', & + & 'anmx_om','Anammox OM production rate',' ','mol P m-3 s-1',1) + call ncdefvar3d(LYR_phosy_NH4(iogrp),cmpflg,'p', & + & 'phosy_nh4','PP consumption rate of NH4',' ','mol N m-3 s-1',1) + call ncdefvar3d(LYR_phosy_NO3(iogrp),cmpflg,'p', & + & 'phosy_no3','PP consumption rate of NO3',' ','mol N m-3 s-1',1) + call ncdefvar3d(LYR_remin_aerob(iogrp),cmpflg,'p', & + & 'remina','Aerob remineralization rate',' ','mol N m-3 s-1',1) + call ncdefvar3d(LYR_remin_sulf(iogrp),cmpflg,'p', & + & 'remins','Sulfate remineralization rate',' ','mol P m-3 s-1',1) +#endif + if(lm4ago)then + ! M4AGO + call ncdefvar3d(LYR_agg_ws(iogrp),cmpflg,'p', & + & 'agg_ws','aggregate mean settling velocity',' ','m d-1',1) + call ncdefvar3d(LYR_dynvis(iogrp),cmpflg,'p', & + & 'dynvis','dynamic viscosity of sea water',' ','kg m-1 s-1',1) + call ncdefvar3d(LYR_agg_stick(iogrp),cmpflg,'p', & + & 'agg_stick','aggregate mean stickiness',' ','-',1) + call ncdefvar3d(LYR_agg_stickf(iogrp),cmpflg,'p', & + & 'agg_stickf','opal frustule stickiness',' ','-',1) + call ncdefvar3d(LYR_agg_dmax(iogrp),cmpflg,'p', & + & 'agg_dmax','aggregate maximum diameter',' ','m',1) + call ncdefvar3d(LYR_agg_avdp(iogrp),cmpflg,'p', & + & 'agg_avdp','mean primary particle diameter',' ','m',1) + call ncdefvar3d(LYR_agg_avrhop(iogrp),cmpflg,'p', & + & 'agg_avrhop','mean primary particle density',' ','kg m-3',1) + call ncdefvar3d(LYR_agg_avdC(iogrp),cmpflg,'p', & + & 'agg_avdC','Conc.-weighted mean aggregate diameter',' ','m',1) + call ncdefvar3d(LYR_agg_df(iogrp),cmpflg,'p', & + & 'agg_df','aggregate fractal dimension',' ','-',1) + call ncdefvar3d(LYR_agg_b(iogrp),cmpflg,'p', & + & 'agg_b','aggregate number distribution slope',' ','-',1) + call ncdefvar3d(LYR_agg_Vrhof(iogrp),cmpflg,'p', & + & 'agg_Vrhof','V-weighted aggregate mean density',' ','kg m-3',1) + call ncdefvar3d(LYR_agg_Vpor(iogrp),cmpflg,'p', & + & 'agg_Vpor','V-weighted aggregate mean porosity',' ','-',1) + endif ! --- define 3d level fields call ncdefvar3d(LVL_DIC(iogrp),cmpflg,'p', & & 'dissiclvl','Dissolved inorganic carbon',' ','mol C m-3',2) @@ -1294,6 +1802,8 @@ subroutine hamoccvardef(iogrp,timeunits,calendar,cmpflg) & 'satoxylvl','Saturated oxygen',' ','mol O2 m-3',2) call ncdefvar3d(LVL_PREFPO4(iogrp),cmpflg,'p', & & 'p_po4lvl','Preformed phosphorus',' ','mol P m-3',2) + call ncdefvar3d(LVL_PREFSILICA(iogrp),cmpflg,'p', & + & 'p_silicalvl','Preformed silica',' ','mol N m-3',2) call ncdefvar3d(LVL_PREFALK(iogrp),cmpflg,'p', & & 'p_talklvl','Preformed alkalinity',' ','eq m-3',2) call ncdefvar3d(LVL_PREFDIC(iogrp),cmpflg,'p', & @@ -1362,7 +1872,78 @@ subroutine hamoccvardef(iogrp,timeunits,calendar,cmpflg) call ncdefvar3d(LVL_BROMO(iogrp),cmpflg,'p', & & 'bromolvl','Bromoform',' ','mol CHBr3 m-3',2) endif - +#ifdef extNcycle + call ncdefvar3d(LVL_ANH4(iogrp),cmpflg,'p', & + & 'nh4lvl','Ammonium',' ','mol N m-3',2) + call ncdefvar3d(LVL_ANO2(iogrp),cmpflg,'p', & + & 'no2lvl','Nitrite',' ','mol N m-3',2) + call ncdefvar3d(LVL_nitr_NH4(iogrp),cmpflg,'p', & + & 'nh4nitrlvl','NH4 nitrification rate',' ','mol N m-3 s-1',2) + call ncdefvar3d(LVL_nitr_NO2(iogrp),cmpflg,'p', & + & 'no2nitrlvl','NO2 nitrification rate',' ','mol N m-3 s-1',2) + call ncdefvar3d(LVL_nitr_N2O_prod(iogrp),cmpflg,'p', & + & 'nitr_n2olvl','N2O prod during NH4 nitrification',' ', & + & 'mol N2O m-3 s-1',2) + call ncdefvar3d(LVL_nitr_NH4_OM(iogrp),cmpflg,'p', & + & 'nh4nitr_omlvl','OM production during NH4 nitrification',' ', & + & 'mol P m-3 s-1',2) + call ncdefvar3d(LVL_nitr_NO2_OM(iogrp),cmpflg,'p', & + & 'no2nitr_omlvl','OM production during NO2 nitrification',' ', & + & 'mol P m-3 s-1',2) + call ncdefvar3d(LVL_denit_NO3(iogrp),cmpflg,'p', & + & 'no3denitlvl','NO3 denitrification rate',' ','mol N m-3 s-1',2) + call ncdefvar3d(LVL_denit_NO2(iogrp),cmpflg,'p', & + & 'no2denitlvl','NO2 denitrification rate',' ','mol N m-3 s-1',2) + call ncdefvar3d(LVL_denit_N2O(iogrp),cmpflg,'p', & + & 'n2odenitlvl','N2O denitrification rate',' ', & + & 'mol N2O m-3 s-1',2) + call ncdefvar3d(LVL_DNRA_NO2(iogrp),cmpflg,'p', & + & 'no2dnralvl','NO2 DNRA rate',' ','mol N m-3 s-1',2) + call ncdefvar3d(LVL_anmx_N2_prod(iogrp),cmpflg,'p', & + & 'anmx_n2lvl','Anammox N2 production rate',' ', & + & 'mol N2 m-3 s-1',2) + call ncdefvar3d(LVL_anmx_OM_prod(iogrp),cmpflg,'p', & + & 'anmx_omlvl','Anammox OM production rate',' ','mol P m-3 s-1',2) + call ncdefvar3d(LVL_phosy_NH4(iogrp),cmpflg,'p', & + & 'phosy_nh4lvl','PP consumption rate of NH4',' ', & + & 'mol N m-3 s-1',2) + call ncdefvar3d(LVL_phosy_NO3(iogrp),cmpflg,'p', & + & 'phosy_no3lvl','PP consumption rate of NO3',' ', & + & 'mol N m-3 s-1',2) + call ncdefvar3d(LVL_remin_aerob(iogrp),cmpflg,'p', & + & 'reminalvl','Aerob remineralization rate',' ', & + & 'mol N m-3 s-1',2) + call ncdefvar3d(LVL_remin_sulf(iogrp),cmpflg,'p', & + & 'reminslvl','Sulfate remineralization rate',' ', & + & 'mol P m-3 s-1',2) +#endif + if(lm4ago)then + ! M4AGO + call ncdefvar3d(LVL_agg_ws(iogrp),cmpflg,'p', & + & 'agg_wslvl','aggregate mean settling velocity',' ','m d-1',2) + call ncdefvar3d(LVL_dynvis(iogrp),cmpflg,'p', & + & 'dynvislvl','dynamic viscosity of sea water',' ','kg m-1 s-1',2) + call ncdefvar3d(LVL_agg_stick(iogrp),cmpflg,'p', & + & 'agg_sticklvl','aggregate mean stickiness',' ','-',2) + call ncdefvar3d(LVL_agg_stickf(iogrp),cmpflg,'p', & + & 'agg_stickflvl','opal frustule stickiness',' ','-',2) + call ncdefvar3d(LVL_agg_dmax(iogrp),cmpflg,'p', & + & 'agg_dmaxlvl','aggregate maximum diameter',' ','m',2) + call ncdefvar3d(LVL_agg_avdp(iogrp),cmpflg,'p', & + & 'agg_avdplvl','mean primary particle diameter',' ','m',2) + call ncdefvar3d(LVL_agg_avrhop(iogrp),cmpflg,'p', & + & 'agg_avrhoplvl','mean primary particle density',' ','kg m-3',2) + call ncdefvar3d(LVL_agg_avdC(iogrp),cmpflg,'p', & + & 'agg_avdClvl','Conc.-weighted mean aggregate diameter',' ','m',2) + call ncdefvar3d(LVL_agg_df(iogrp),cmpflg,'p', & + & 'agg_dflvl','aggregate fractal dimension',' ','-',2) + call ncdefvar3d(LVL_agg_b(iogrp),cmpflg,'p', & + & 'agg_blvl','aggregate number distribution slope',' ','-',2) + call ncdefvar3d(LVL_agg_Vrhof(iogrp),cmpflg,'p', & + & 'agg_Vrhoflvl','V-weighted aggregate mean density',' ','kg m-3',2) + call ncdefvar3d(LVL_agg_Vpor(iogrp),cmpflg,'p', & + & 'agg_Vporlvl','V-weighted aggregate mean porosity',' ','-',2) + endif ! --- define sediment fields if (.not. use_sedbypass) then call ncdefvar3d(SDM_POWAIC(iogrp),cmpflg,'p', & @@ -1398,7 +1979,48 @@ subroutine hamoccvardef(iogrp,timeunits,calendar,cmpflg) call ncdefvar3d(BUR_SSSTER(iogrp), & & cmpflg,'p','burter','Burial clay',' ','kg m-2',4) endif - +#if defined(extNcycle) && ! defined(sedbypass) + call ncdefvar3d(SDM_POWNH4(iogrp),cmpflg,'p', & + & 'pownh4','PoWa ammonium',' ','mol N m-3',3) + call ncdefvar3d(SDM_POWN2O(iogrp),cmpflg,'p', & + & 'pown2o','PoWa nitrous oxide',' ','mol N m-3',3) + call ncdefvar3d(SDM_POWNO2(iogrp),cmpflg,'p', & + & 'powno2','PoWa nitrite',' ','mol N m-3',3) + call ncdefvar3d(sdm_nitr_NH4(iogrp),cmpflg,'p', & + & 'nh4nitrsdm','NH4 nitrification rate sediment',' ','mol N m-3 s-1',3) + call ncdefvar3d(sdm_nitr_NO2(iogrp),cmpflg,'p', & + & 'no2nitrsdm','NO2 nitrification rate sediment',' ','mol N m-3 s-1',3) + call ncdefvar3d(sdm_nitr_N2O_prod(iogrp),cmpflg,'p', & + & 'nitr_n2osdm','N2O prod during NH4 nitrification sediment',' ', & + & 'mol N2O m-3 s-1',3) + call ncdefvar3d(sdm_nitr_NH4_OM(iogrp),cmpflg,'p', & + & 'nh4nitr_omsdm','OM production during NH4 nitrification sediment',' ', & + & 'mol P m-3 s-1',3) + call ncdefvar3d(sdm_nitr_NO2_OM(iogrp),cmpflg,'p', & + & 'no2nitr_omsdm','OM production during NO2 nitrification sediment',' ', & + & 'mol P m-3 s-1',3) + call ncdefvar3d(sdm_denit_NO3(iogrp),cmpflg,'p', & + & 'no3denitsdm','NO3 denitrification rate sediment',' ','mol N m-3 s-1',3) + call ncdefvar3d(sdm_denit_NO2(iogrp),cmpflg,'p', & + & 'no2denitsdm','NO2 denitrification rate sediment',' ','mol N m-3 s-1',3) + call ncdefvar3d(sdm_denit_N2O(iogrp),cmpflg,'p', & + & 'n2odenitsdm','N2O denitrification rate sediment',' ', & + & 'mol N2O m-3 s-1',3) + call ncdefvar3d(sdm_DNRA_NO2(iogrp),cmpflg,'p', & + & 'no2dnrasdm','NO2 DNRA rate sediment',' ','mol N m-3 s-1',3) + call ncdefvar3d(sdm_anmx_N2_prod(iogrp),cmpflg,'p', & + & 'anmx_n2sdm','Anammox N2 production rate sediment',' ', & + & 'mol N2 m-3 s-1',3) + call ncdefvar3d(sdm_anmx_OM_prod(iogrp),cmpflg,'p', & + & 'anmx_omsdm','Anammox OM production rate sediment',' ', & + & 'mol P m-3 s-1',3) + call ncdefvar3d(sdm_remin_aerob(iogrp),cmpflg,'p', & + & 'reminasdm','Aerob remineralization rate sediment',' ', & + & 'mol N m-3 s-1',3) + call ncdefvar3d(sdm_remin_sulf(iogrp),cmpflg,'p', & + & 'reminssdm','Sulfate remineralization rate sediment',' ', & + & 'mol P m-3 s-1',3) +#endif ! --- enddef netcdf file call ncedef diff --git a/hamocc/mo_ocprod.F90 b/hamocc/mo_ocprod.F90 index c3fcd2aa..c9a7705d 100644 --- a/hamocc/mo_ocprod.F90 +++ b/hamocc/mo_ocprod.F90 @@ -26,7 +26,7 @@ module mo_ocprod contains - subroutine ocprod(kpie,kpje,kpke,kbnd,pdlxp,pdlyp,pddpo,omask,ptho,pi_ph) + subroutine ocprod(kpie,kpje,kpke,kbnd,pdlxp,pdlyp,pddpo,omask,ptho,pi_ph,psao,ppao,prho) !*********************************************************************************************** ! Biological production, remineralization and particle sinking. @@ -63,7 +63,8 @@ subroutine ocprod(kpie,kpje,kpke,kbnd,pdlxp,pdlyp,pddpo,omask,ptho,pi_ph) use mod_xc, only: mnproc use mo_carbch, only: ocetra,satoxy,hi,co2star use mo_sedmnt, only: prcaca,produs,prorca,silpro,pror13,pror14,prca13,prca14 - use mo_param_bgc, only: drempoc,dremn2o,dremopal,dremsul,dyphy,ecan,epsher,fesoly, & + use mo_param_bgc, only: drempoc,drempoc_anaerob,bkox_drempoc,dremn2o,dremopal,dremsul, & + dyphy,ecan,epsher,fesoly, & gammap,gammaz,grami,grazra,pi_alpha,phytomi, & rcalc,rcar,rdn2o1,rdn2o2,rdnit0,rdnit1,rdnit2, & relaxfe,remido,riron,rnit,rnoi,ro2ut,ropal, & @@ -89,11 +90,19 @@ subroutine ocprod(kpie,kpje,kpke,kbnd,pdlxp,pdlyp,pddpo,omask,ptho,pi_ph) inatalkali,inatcalc,inatsco212 use mo_control_bgc, only: dtb,io_stdo_bgc,with_dmsph, & use_BROMO,use_AGG,use_PBGC_OCNP_TIMESTEP,use_FB_BGC_OCE, & - use_AGG,use_cisonew,use_natDIC, use_WLIN,use_sedbypass + use_AGG,use_cisonew,use_natDIC, use_WLIN,use_sedbypass,lm4ago use mo_vgrid, only: dp_min,dp_min_sink,k0100,k0500,k1000,k2000,k4000,kwrbioz,ptiestu use mo_vgrid, only: kmle use mo_clim_swa, only: swa_clim use mo_inventory_bgc, only: inventory_bgc + use mo_m4ago, only: mean_aggregate_sinking_speed,ws_agg,POM_remin_q10,POM_remin_Tref, & + opal_remin_q10,opal_remin_Tref +#ifdef extNcycle + use mo_extNwatercol,only: nitrification,denit_NO3_to_NO2,anammox,denit_dnra,extN_inv_check + use mo_extNwatercol,only: bkphyanh4,bkphyano3,bkphosph,bkiron,ro2utammo + use mo_param1_bgc, only: ianh4 + use mo_biomod, only: phosy_NH4, phosy_NO3, remin_aerob,remin_sulf +#endif ! Arguments integer, intent(in) :: kpie ! 1st dimension of model grid. @@ -106,6 +115,9 @@ subroutine ocprod(kpie,kpje,kpke,kbnd,pdlxp,pdlyp,pddpo,omask,ptho,pi_ph) real, intent(in) :: omask(kpie,kpje) ! land/ocean mask (1=ocean) real, intent(in) :: ptho(1-kbnd:kpie+kbnd,1-kbnd:kpje+kbnd,kpke) ! potential temperature [deg C]. real, intent(in) :: pi_ph(kpie,kpje) + real, intent(in) :: psao(1-kbnd:kpie+kbnd,1-kbnd:kpje+kbnd,kpke) ! salinity [psu]. + real, intent(in) :: ppao(1-kbnd:kpie+kbnd,1-kbnd:kpje+kbnd) ! sea level pressure [Pascal]. + real, intent(in) :: prho(kpie,kpje,kpke) ! density [kg/m^3]. ! Local variables integer, parameter :: nsinkmax = 12 @@ -125,6 +137,7 @@ subroutine ocprod(kpie,kpje,kpke,kbnd,pdlxp,pdlyp,pddpo,omask,ptho,pi_ph) real :: dtr,dz real :: wpocd,wcald,wopald,wdustd,dagg real :: wcal,wdust,wopal,wpoc + real :: o2lim ! O2 limitation of ammonification (POC remin) ! sedbypass real :: florca,flcaca,flsil ! cisonew @@ -165,6 +178,10 @@ subroutine ocprod(kpie,kpje,kpke,kbnd,pdlxp,pdlyp,pddpo,omask,ptho,pi_ph) ! BROMO real :: bro_beta,bro_uv real :: abs_uv(kpie,kpje,kpke) +#ifdef extNcycle + character(len=:), allocatable :: inv_message + real :: ano3up_inh,nutlim,anh4lim,nlim,grlim,nh4uptfrac +#endif ! set variables for diagnostic output to zero expoor (:,:) = 0. @@ -200,7 +217,12 @@ subroutine ocprod(kpie,kpje,kpke,kbnd,pdlxp,pdlyp,pddpo,omask,ptho,pi_ph) eps3d(:,:,:) = 0. asize3d(:,:,:) = 0. endif - +#ifdef extNcycle + phosy_NH4(:,:,:) = 0. + phosy_NO3(:,:,:) = 0. + remin_aerob(:,:,:) = 0. + remin_sulf(:,:,:) = 0. +#endif if (use_PBGC_OCNP_TIMESTEP) then if (mnproc == 1) then @@ -262,11 +284,16 @@ subroutine ocprod(kpie,kpje,kpke,kbnd,pdlxp,pdlyp,pddpo,omask,ptho,pi_ph) enddo !$OMP END PARALLEL DO + if (lm4ago) then + ! even though we loose detritus, etc. we call the calculation for settling velocity by M4AGO here + ! to enable further future development... - assuming that the operator splitting decently functions + call mean_aggregate_sinking_speed(kpie, kpje, kpke, kbnd, pddpo, omask, ptho, psao, ppao, prho) + endif !$OMP PARALLEL DO PRIVATE(avphy,avgra,avsil,avanut,avanfe,pho,xa,xn & !$OMP ,phosy,ya,yn,grazing,graton,gratpoc,grawa,bacfra,phymor & !$OMP ,zoomor,excdoc,exud,export,delsil,delcar,dmsprod & - !$OMP ,dms_bac,dms_uv,dtr,phofa,temfa,zoothresh,dms_ph,dz & + !$OMP ,dms_bac,dms_uv,dtr,phofa,temfa,zoothresh,dms_ph,dz,opalrem & !$OMP ,avmass,avnos,zmornos & !$OMP ,rco213,rco214,rphy13,rphy14,rzoo13,rzoo14,grazing13,grazing14 & !$OMP ,graton13,graton14,gratpoc13,gratpoc14,grawa13,grawa14 & @@ -275,6 +302,9 @@ subroutine ocprod(kpie,kpje,kpke,kbnd,pdlxp,pdlyp,pddpo,omask,ptho,pi_ph) !$OMP ,delcar13,delcar14,dtr13,dtr14,bifr13,bifr14,bifr13_perm & !$OMP ,growth_co2,phygrowth & !$OMP ,bro_beta,bro_uv & +#ifdef extNcycle + !$OMP , ano3up_inh,nutlim,anh4lim,nlim,grlim,nh4uptfrac & +#endif !$OMP ,i,k) loop1: do j = 1,kpje @@ -299,11 +329,28 @@ subroutine ocprod(kpie,kpje,kpke,kbnd,pdlxp,pdlyp,pddpo,omask,ptho,pi_ph) avgra = max(grami,ocetra(i,j,k,izoo)) ! 'available' zooplankton avsil = max(0.,ocetra(i,j,k,isilica)) avdic = max(0.,ocetra(i,j,k,isco212)) +#ifdef extNcycle + ano3up_inh = bkphyanh4/(bkphyanh4 + ocetra(i,j,k,ianh4)) ! inhibition of NO3 uptake + nutlim = min(ocetra(i,j,k,iphosph)/(ocetra(i,j,k,iphosph)+bkphosph),ocetra(i,j,k,iiron)/(ocetra(i,j,k,iiron)+bkiron)) + anh4lim = ocetra(i,j,k,ianh4)/(ocetra(i,j,k,ianh4) + bkphyanh4) + nlim = ano3up_inh*ocetra(i,j,k,iano3)/(ocetra(i,j,k,iano3) + bkphyano3) + anh4lim + grlim = min(nutlim,nlim) ! growth limitation + + nh4uptfrac = 1. + if(nlim .gt. 1.e-18) nh4uptfrac = anh4lim/nlim + ! re-check avnut - can sum N avail exceed indiv. contrib? + avanut = max(0.,min(ocetra(i,j,k,iphosph), ocetra(i,j,k,iiron)/riron, & + & rnoi*((1.-nh4uptfrac)*ocetra(i,j,k,iano3) + nh4uptfrac*ocetra(i,j,k,ianh4)))) + + xn = avphy/(1. - pho*grlim) ! phytoplankton growth + phosy = max(0.,min(xn-avphy,avanut)) ! limit PP growth to available nutr. +#else avanut = max(0.,min(ocetra(i,j,k,iphosph),rnoi*ocetra(i,j,k,iano3))) avanfe = max(0.,min(avanut,ocetra(i,j,k,iiron)/riron)) xa = avanfe xn = xa/(1.+pho*avphy/(xa+bkphy)) phosy = max(0.,xa-xn) +#endif phosy = MERGE(avdic/rcar, phosy, avdic <= rcar*phosy) ! limit phosy by available DIC ya = avphy+phosy yn = (ya+grazra*avgra*phytomi/(avphy+bkzoo))/(1.+grazra*avgra/(avphy+bkzoo)) @@ -403,12 +450,27 @@ subroutine ocprod(kpie,kpje,kpke,kbnd,pdlxp,pdlyp,pddpo,omask,ptho,pi_ph) dtr = bacfra-phosy+graton+ecan*zoomor ocetra(i,j,k,iphosph) = ocetra(i,j,k,iphosph)+dtr - ocetra(i,j,k,iano3) = ocetra(i,j,k,iano3)+dtr*rnit +#ifndef extNcycle + ocetra(i,j,k,iano3) = ocetra(i,j,k,iano3)+dtr*rnit + ocetra(i,j,k,ialkali) = ocetra(i,j,k,ialkali)-2.*delcar-(rnit+1)*dtr + ocetra(i,j,k,ioxygen) = ocetra(i,j,k,ioxygen)-dtr*ro2ut +#else + ocetra(i,j,k,iano3) = ocetra(i,j,k,iano3) - (1.-nh4uptfrac)*phosy*rnit + ocetra(i,j,k,ianh4) = ocetra(i,j,k,ianh4) - nh4uptfrac*phosy*rnit + (dtr+phosy)*rnit + ocetra(i,j,k,ialkali) = ocetra(i,j,k,ialkali) - nh4uptfrac*phosy*(rnit-1.) & ! NH4 + PO4 Uptake + & + (1.-nh4uptfrac)*phosy*(rnit+1.) & ! NO3 + PO4 Uptake + & + (dtr+phosy)*(rnit-1.) - 2.*delcar ! Remin to (NH4 + PO4) and CaCO3 formation + ocetra(i,j,k,ioxygen) = ocetra(i,j,k,ioxygen) + nh4uptfrac*phosy*ro2utammo & ! NH4 uptake + & + (1.-nh4uptfrac)*phosy*ro2ut & ! NO3 uptake + & - (dtr+phosy)*ro2utammo ! Remin to NH4 + ! Output + phosy_NH4(i,j,k) = nh4uptfrac*phosy*rnit ! kmol N/m3/dtb - NH4 uptake during PP growth + phosy_NO3(i,j,k) = (1.-nh4uptfrac)*phosy*rnit ! kmol N/m3/dtb - NO3 uptake during PP growth + remin_aerob(i,j,k) = (dtr+phosy)*rnit ! kmol N/m3/dtb - Aerob remin to ammonium (var. sources) +#endif ocetra(i,j,k,idet) = ocetra(i,j,k,idet)+export ocetra(i,j,k,idms) = ocetra(i,j,k,idms)+dmsprod-dms_bac-dms_uv ocetra(i,j,k,isco212) = ocetra(i,j,k,isco212)-delcar+rcar*dtr - ocetra(i,j,k,ialkali) = ocetra(i,j,k,ialkali)-2.*delcar-(rnit+1)*dtr - ocetra(i,j,k,ioxygen) = ocetra(i,j,k,ioxygen)-dtr*ro2ut ocetra(i,j,k,iphy) = ocetra(i,j,k,iphy)+phosy-grazing-phymor-exud ocetra(i,j,k,izoo) = ocetra(i,j,k,izoo)+grawa-excdoc-zoomor ocetra(i,j,k,idoc) = ocetra(i,j,k,idoc)-bacfra+excdoc+exud @@ -435,8 +497,13 @@ subroutine ocprod(kpie,kpje,kpke,kbnd,pdlxp,pdlyp,pddpo,omask,ptho,pi_ph) ocetra(i,j,k,inatalkali) = ocetra(i,j,k,inatalkali)-2.*delcar-(rnit+1)*dtr ocetra(i,j,k,inatcalc) = ocetra(i,j,k,inatcalc)+delcar endif - ocetra(i,j,k,isilica) = ocetra(i,j,k,isilica)-delsil+dremopal*ocetra(i,j,k,iopal) - ocetra(i,j,k,iopal) = ocetra(i,j,k,iopal)+delsil-dremopal*ocetra(i,j,k,iopal) + if(lm4ago)then + opalrem = dremopal*opal_remin_q10**((ptho(i,j,k)-opal_remin_Tref)/10.)*ocetra(i,j,k,iopal) + else + opalrem = dremopal*ocetra(i,j,k,iopal) + endif + ocetra(i,j,k,isilica) = ocetra(i,j,k,isilica)-delsil+opalrem + ocetra(i,j,k,iopal) = ocetra(i,j,k,iopal)+delsil-opalrem ocetra(i,j,k,iiron) = ocetra(i,j,k,iiron)+dtr*riron & & - relaxfe*max(ocetra(i,j,k,iiron)-fesoly,0.) @@ -522,7 +589,7 @@ subroutine ocprod(kpie,kpje,kpke,kbnd,pdlxp,pdlyp,pddpo,omask,ptho,pi_ph) endif !$OMP PARALLEL DO PRIVATE(phythresh,zoothresh,sterph,sterzo,remin & - !$OMP ,opalrem,aou,refra,dms_bac,pocrem,docrem,phyrem,dz & + !$OMP ,opalrem,aou,refra,dms_bac,pocrem,docrem,phyrem,dz,o2lim & !$OMP ,avmass,avnos,zmornos & !$OMP ,rphy13,rphy14,rzoo13,rzoo14,rdet13,rdet14,rdoc13,rdoc14 & !$OMP ,sterph13,sterph14,sterzo13,sterzo14,pocrem13,pocrem14 & @@ -567,9 +634,29 @@ subroutine ocprod(kpie,kpje,kpke,kbnd,pdlxp,pdlyp,pddpo,omask,ptho,pi_ph) endif if(ocetra(i,j,k,ioxygen) > 5.e-8) then - pocrem = min(drempoc*ocetra(i,j,k,idet),0.33*ocetra(i,j,k,ioxygen)/ro2ut) - docrem = min( remido*ocetra(i,j,k,idoc),0.33*ocetra(i,j,k,ioxygen)/ro2ut) - phyrem = min(0.5*dyphy*phythresh, 0.33*ocetra(i,j,k,ioxygen)/ro2ut) + if(lm4ago) then +#ifndef extNcycle + ! M4AGO comes with O2-lim + o2lim = ocetra(i,j,k,ioxygen)/(ocetra(i,j,k,ioxygen) + bkox_drempoc) + pocrem = o2lim*drempoc*POM_remin_q10**((ptho(i,j,k)-POM_remin_Tref)/10.)*ocetra(i,j,k,idet) +#else + ! nitrogen always accounts for O2-lim - see below + pocrem = drempoc*POM_remin_q10**((ptho(i,j,k)-POM_remin_Tref)/10.)*ocetra(i,j,k,idet) +#endif + else + pocrem = drempoc*ocetra(i,j,k,idet) + endif +#ifndef extNcycle + pocrem = MIN(pocrem,0.33*ocetra(i,j,k,ioxygen)/ro2ut) + docrem = MIN( remido*ocetra(i,j,k,idoc),0.33*ocetra(i,j,k,ioxygen)/ro2ut) + phyrem = MIN(0.5*dyphy*phythresh, 0.33*ocetra(i,j,k,ioxygen)/ro2ut) +#else + o2lim = ocetra(i,j,k,ioxygen)/(ocetra(i,j,k,ioxygen) + bkox_drempoc) + pocrem = MIN(o2lim*pocrem,0.33*ocetra(i,j,k,ioxygen)/ro2utammo) + docrem = MIN(remido*ocetra(i,j,k,idoc),0.33*ocetra(i,j,k,ioxygen)/ro2utammo) + phyrem = MIN(0.5*dyphy*phythresh, 0.33*ocetra(i,j,k,ioxygen)/ro2utammo) +#endif + if (use_cisonew) then pocrem13 = pocrem*rdet13 pocrem14 = pocrem*rdet14 @@ -599,10 +686,17 @@ subroutine ocprod(kpie,kpje,kpke,kbnd,pdlxp,pdlyp,pddpo,omask,ptho,pi_ph) remin = pocrem + docrem + phyrem ocetra(i,j,k,iphosph) = ocetra(i,j,k,iphosph)+remin - ocetra(i,j,k,iano3) = ocetra(i,j,k,iano3)+remin*rnit - ocetra(i,j,k,isco212) = ocetra(i,j,k,isco212)+rcar*remin - ocetra(i,j,k,ialkali) = ocetra(i,j,k,ialkali)-(rnit+1)*remin - ocetra(i,j,k,ioxygen) = ocetra(i,j,k,ioxygen)-ro2ut*remin +#ifndef extNcycle + ocetra(i,j,k,iano3) = ocetra(i,j,k,iano3)+remin*rnit + ocetra(i,j,k,ialkali) = ocetra(i,j,k,ialkali)-(rnit+1)*remin + ocetra(i,j,k,ioxygen) = ocetra(i,j,k,ioxygen)-ro2ut*remin +#else + ocetra(i,j,k,ianh4) = ocetra(i,j,k,ianh4) + remin*rnit + ocetra(i,j,k,ialkali) = ocetra(i,j,k,ialkali) + (rnit-1.)*remin + ocetra(i,j,k,ioxygen) = ocetra(i,j,k,ioxygen) - ro2utammo*remin + remin_aerob(i,j,k) = remin*rnit ! kmol/NH4/dtb - remin to NH4 from various sources +#endif + ocetra(i,j,k,isco212) = ocetra(i,j,k,isco212)+rcar*remin ocetra(i,j,k,iiron) = ocetra(i,j,k,iiron)+remin*riron & & -relaxfe*max(ocetra(i,j,k,iiron)-fesoly,0.) if (use_natDIC) then @@ -626,21 +720,28 @@ subroutine ocprod(kpie,kpje,kpke,kbnd,pdlxp,pdlyp,pddpo,omask,ptho,pi_ph) ! so the expression dremopal*(Si(OH)4sat-Si(OH)4) would change the ! rate only from 0 to 100% !*********************************************************************** - opalrem = dremopal*0.1*(temp+3.)*ocetra(i,j,k,iopal) + if(lm4ago)then + opalrem = dremopal*opal_remin_q10**((ptho(i,j,k)-opal_remin_Tref)/10.)*ocetra(i,j,k,iopal) + else + opalrem = dremopal*0.1*(temp+3.)*ocetra(i,j,k,iopal) + endif ocetra(i,j,k,iopal) = ocetra(i,j,k,iopal)-opalrem ocetra(i,j,k,isilica) = ocetra(i,j,k,isilica)+opalrem +#ifndef extNcycle !*********************************************************************** ! There is about 1.e4 O2 on 1 N2O molecule (Broeker&Peng) ! refra : Tim Rixton, private communication !*********************************************************************** aou = satoxy(i,j,k)-ocetra(i,j,k,ioxygen) refra = 1.+3.*(0.5+sign(0.5,aou-1.97e-4)) - dms_bac = dmsp3 * abs(temp+3.) * ocetra(i,j,k,idms) & - & * (ocetra(i,j,k,idms) / (dmsp6+ocetra(i,j,k,idms))) ocetra(i,j,k,ian2o) = ocetra(i,j,k,ian2o)+remin*1.e-4*ro2ut*refra ocetra(i,j,k,igasnit) = ocetra(i,j,k,igasnit)-remin*1.e-4*ro2ut*refra ocetra(i,j,k,ioxygen) = ocetra(i,j,k,ioxygen)-remin*1.e-4*ro2ut*refra*0.5 +#endif + + dms_bac = dmsp3 * dtb * abs(temp+3.) * ocetra(i,j,k,idms) & + & * (ocetra(i,j,k,idms) / (dmsp6+ocetra(i,j,k,idms))) ocetra(i,j,k,idms) = ocetra(i,j,k,idms)-dms_bac dz = pddpo(i,j,k) @@ -679,6 +780,8 @@ subroutine ocprod(kpie,kpje,kpke,kbnd,pdlxp,pdlyp,pddpo,omask,ptho,pi_ph) call inventory_bgc(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask,0) endif +#ifndef extNcycle +! =====>>>> Regular CMIP6 iHAMOCC version for denitrification wo extended nitrogen cycle =====>>>> !$OMP PARALLEL DO PRIVATE(remin,remin2o,dz,avmass,avnos,rem13,rem14,i,k) loop3: do j = 1,kpje do i = 1,kpie @@ -689,7 +792,7 @@ subroutine ocprod(kpie,kpje,kpke,kbnd,pdlxp,pdlyp,pddpo,omask,ptho,pi_ph) avmass = ocetra(i,j,k,iphy) + ocetra(i,j,k,idet) endif - remin = 0.05*drempoc*min(ocetra(i,j,k,idet),0.5 *ocetra(i,j,k,iano3)/rdnit1) + remin = drempoc_anaerob*min(ocetra(i,j,k,idet),0.5 *ocetra(i,j,k,iano3)/rdnit1) remin2o = dremn2o*min(ocetra(i,j,k,idet),0.003 *ocetra(i,j,k,ian2o)/rdn2o1) if (use_cisonew) then @@ -745,7 +848,25 @@ subroutine ocprod(kpie,kpje,kpke,kbnd,pdlxp,pdlyp,pddpo,omask,ptho,pi_ph) endif call inventory_bgc(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask,0) endif - +! <<<<===== end of CMIP6 version denitrification processes without extended nitrogen cycle <<<<===== +#else + !======>>>> extended nitrogen cycle processes (aerobic and anaerobic) that follow ammonification + inv_message = 'in OCPROD after extNcycle nitrification' + CALL nitrification(kpie,kpje,kpke,kbnd,pddpo,omask,ptho) + CALL extN_inv_check(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask,inv_message) + + inv_message = 'in OCPROD after extNcycle denitrification NO3 -> NO2' + CALL denit_NO3_to_NO2(kpie,kpje,kpke,kbnd,pddpo,omask,ptho) + CALL extN_inv_check(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask,inv_message) + + inv_message = 'in OCPROD after extNcycle anammox' + CALL anammox(kpie,kpje,kpke,kbnd,pddpo,omask,ptho) + CALL extN_inv_check(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask,inv_message) + + inv_message = 'in OCPROD after extNcycle denitrification / DNRA' + CALL denit_dnra(kpie,kpje,kpke,kbnd,pddpo,omask,ptho) + CALL extN_inv_check(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask,inv_message) +#endif !sulphate reduction ! introduced 11.5.2007 to improve poc-remineralisation in the ! oxygen minimum zone in the subsurface equatorial Pacific @@ -786,7 +907,10 @@ subroutine ocprod(kpie,kpje,kpke,kbnd,pdlxp,pdlyp,pddpo,omask,ptho,pi_ph) ocetra(i,j,k,isco213) = ocetra(i,j,k,isco213)+rcar*rem13 ocetra(i,j,k,isco214) = ocetra(i,j,k,isco214)+rcar*rem14 endif - +#ifdef extNcycle + ! Output + remin_sulf(i,j,k) = remin ! kmol P/m3/dtb +#endif if (use_AGG) then !*********************************************************************** ! loss of snow numbers due to remineralization of poc @@ -1050,6 +1174,17 @@ subroutine ocprod(kpie,kpje,kpke,kbnd,pdlxp,pdlyp,pddpo,omask,ptho,pi_ph) wdustd = wdust_const dagg = 0.0 endif + if(lm4ago)then ! superseding every other method + wpoc = ws_agg(i,j,k) + wpocd = ws_agg(i,j,kdonor) + wcal = ws_agg(i,j,k) + wcald = ws_agg(i,j,kdonor) + wopal = ws_agg(i,j,k) + wopald = ws_agg(i,j,kdonor) + wdust = ws_agg(i,j,k) + wdustd = ws_agg(i,j,kdonor) + dagg = 0.0 + endif if( k == 1 ) then wpocd = 0.0 @@ -1059,7 +1194,11 @@ subroutine ocprod(kpie,kpje,kpke,kbnd,pdlxp,pdlyp,pddpo,omask,ptho,pi_ph) if (use_AGG) then wnosd = 0.0 else if (use_WLIN) then - wpoc = wmin + if (lm4ago)then + wpoc = ws_agg(i,j,k) + else + wpoc = wmin + endif endif endif @@ -1249,6 +1388,11 @@ subroutine ocprod(kpie,kpje,kpke,kbnd,pdlxp,pdlyp,pddpo,omask,ptho,pi_ph) else if (use_WLIN) then wpoc = min(wmin+wlin*ptiestu(i,j,k), wmax) endif + if(lm4ago)then + wpoc = ws_agg(i,j,k) + wcal = ws_agg(i,j,k) + wopal = ws_agg(i,j,k) + endif if (use_AGG) then carflx0100(i,j) = (ocetra(i,j,k,idet)+ocetra(i,j,k,iphy))*rcar*wpoc @@ -1269,6 +1413,11 @@ subroutine ocprod(kpie,kpje,kpke,kbnd,pdlxp,pdlyp,pddpo,omask,ptho,pi_ph) else if (use_WLIN) then wpoc = min(wmin+wlin*ptiestu(i,j,k), wmax) endif + if(lm4ago)then + wpoc = ws_agg(i,j,k) + wcal = ws_agg(i,j,k) + wopal = ws_agg(i,j,k) + endif if (use_AGG) then carflx0500(i,j) = (ocetra(i,j,k,idet)+ocetra(i,j,k,iphy))*rcar*wpoc @@ -1289,6 +1438,11 @@ subroutine ocprod(kpie,kpje,kpke,kbnd,pdlxp,pdlyp,pddpo,omask,ptho,pi_ph) else if (use_WLIN) then wpoc = min(wmin+wlin*ptiestu(i,j,k), wmax) endif + if(lm4ago)then + wpoc = ws_agg(i,j,k) + wcal = ws_agg(i,j,k) + wopal = ws_agg(i,j,k) + endif if (use_AGG) then carflx1000(i,j) = (ocetra(i,j,k,idet)+ocetra(i,j,k,iphy))*rcar*wpoc @@ -1309,6 +1463,11 @@ subroutine ocprod(kpie,kpje,kpke,kbnd,pdlxp,pdlyp,pddpo,omask,ptho,pi_ph) else if (use_WLIN) then wpoc = min(wmin+wlin*ptiestu(i,j,k), wmax) endif + if(lm4ago)then + wpoc = ws_agg(i,j,k) + wcal = ws_agg(i,j,k) + wopal = ws_agg(i,j,k) + endif if (use_AGG) then carflx2000(i,j) = (ocetra(i,j,k,idet)+ocetra(i,j,k,iphy))*rcar*wpoc @@ -1329,6 +1488,11 @@ subroutine ocprod(kpie,kpje,kpke,kbnd,pdlxp,pdlyp,pddpo,omask,ptho,pi_ph) else if (use_WLIN) then wpoc = min(wmin+wlin*ptiestu(i,j,k), wmax) endif + if(lm4ago)then + wpoc = ws_agg(i,j,k) + wcal = ws_agg(i,j,k) + wopal = ws_agg(i,j,k) + endif if (use_AGG) then carflx4000(i,j) = (ocetra(i,j,k,idet)+ocetra(i,j,k,iphy))*rcar*wpoc diff --git a/hamocc/mo_param1_bgc.F90 b/hamocc/mo_param1_bgc.F90 index b2244459..7fec00db 100644 --- a/hamocc/mo_param1_bgc.F90 +++ b/hamocc/mo_param1_bgc.F90 @@ -29,7 +29,7 @@ module mo_param1_bgc use mo_control_bgc, only: use_BROMO, use_AGG, use_WLIN, use_natDIC, use_CFC, & use_cisonew, use_PBGC_OCNP_TIMESTEP, use_PBGC_CK_TIMESTEP, & - use_FB_BGC_OCE, use_BOXATM, use_sedbypass + use_FB_BGC_OCE, use_BOXATM, use_sedbypass, use_extNcycle implicit none public @@ -199,7 +199,7 @@ module mo_param1_bgc integer, protected :: ipowc14 integer, protected :: npowtra ! computed in init_indices - ! Indices for extended nitrogen cycle + ! Indices for extended nitrogen cycle integer, protected :: i_pow_extNcycle integer, protected :: ipownh4 integer, protected :: ipown2o @@ -228,7 +228,7 @@ subroutine init_por2octra_mapping() map_por2octra(ipownh4) = ianh4 map_por2octra(ipown2o) = ian2o map_por2octra(ipowno2) = iano2 - end + endif end subroutine init_por2octra_mapping ! =========================================================================== @@ -410,7 +410,7 @@ subroutine init_indices() else i_nh3_atm = 0 iatmnh3 = -1 - end + endif ! total number of atmosphere tracers natm=i_base_atm+i_iso_atm+i_cfc_atm+i_ndic_atm+i_bromo_atm+i_nh3_atm @@ -424,7 +424,7 @@ subroutine init_indices() nndep = 1 idepnoy = 1 idepnhx = -1 - end + endif ! rivers nriv =7 @@ -486,7 +486,7 @@ subroutine init_indices() ipownh4 = -1 ipown2o = -1 ipowno2 = -1 - end + endif npowtra = i_pow_base + i_pow_cisonew+i_pow_extNcycle diff --git a/hamocc/mo_param_bgc.F90 b/hamocc/mo_param_bgc.F90 index 414b436e..abb4cb14 100644 --- a/hamocc/mo_param_bgc.F90 +++ b/hamocc/mo_param_bgc.F90 @@ -37,17 +37,15 @@ module mo_param_bgc do_ndep,do_oalk,do_rivinpt,do_sedspinup,l_3Dvarsedpor, & use_BOXATM,use_CFC,use_PBGC_CK_TIMESTEP, & use_sedbypass,with_dmsph,use_PBGC_OCNP_TIMESTEP,ocn_co2_type,lm4ago, & - leuphotic_cya + leuphotic_cya,do_ndep_coupled,do_n2onh3_coupled,use_extNcycle + use mod_xc, only: mnproc - use mo_m4ago, only: init_m4ago_nml_params, init_m4ago_params -#ifdef extNcycle - use mo_control_bgc, only: do_ndep_coupled,do_n2onh3_coupled - use mo_param1_bgc, only: iatmnh3,iatmn2o - use mo_extNwatercol,only: extNwatercol_param_init,extNwatercol_param_update,extNwatercol_param_write, & - rano3denit,rano2anmx,rano2denit,ran2odenit,rdnra,ranh4nitr,rano2nitr - use mo_extNsediment,only: extNsediment_param_init,extNsediment_param_update,extNsediment_param_write, & - rano3denit_sed,rano2anmx_sed,rano2denit_sed,ran2odenit_sed,rdnra_sed,ranh4nitr_sed,rano2nitr_sed -#endif +! use mo_m4ago, only: init_m4ago_nml_params, init_m4ago_params + use mo_param1_bgc, only: iatmnh3,iatmn2o +! use mo_extNwatercol,only: extNwatercol_param_init,extNwatercol_param_update,extNwatercol_param_write, & +! rano3denit,rano2anmx,rano2denit,ran2odenit,rdnra,ranh4nitr,rano2nitr +! use mo_extNsediment,only: extNsediment_param_init,extNsediment_param_update,extNsediment_param_write, & +! rano3denit_sed,rano2anmx_sed,rano2denit_sed,ran2odenit_sed,rdnra_sed,ranh4nitr_sed,rano2nitr_sed implicit none private @@ -72,7 +70,7 @@ module mo_param_bgc ! Other module variables public :: ro2ut,rcar,rnit,rnoi,riron,rdnit0,rdnit1,rdnit2,rdn2o1,rdn2o2 - public :: atm_n2,atm_o2,atm_co2_nat,atm_bromo,re1312 + public :: atm_n2,atm_o2,atm_co2_nat,atm_bromo,re1312,atm_n2o,atm_nh3 public :: re14to,prei13,prei14,ctochl public :: atten_w,atten_c,atten_uv,atten_f public :: perc_diron,fesoly,phytomi,pi_alpha @@ -123,7 +121,7 @@ module mo_param_bgc real, protected :: atm_n2 = 802000. ! atmosphere dinitrogen concentration real, protected :: atm_n2o = 300e3 ! atmosphere laughing gas mixing ratio around 1980: 300 ppb,provided in ppt,300ppb = 300e3ppt = 3e-7 mol/mol - real, proteced :: atm_nh3 = 0. ! Six & Mikolajewicz 2022: less than 1nmol m-3 + real, protected :: atm_nh3 = 0. ! Six & Mikolajewicz 2022: less than 1nmol m-3 real, protected :: atm_o2 = 196800. ! atmosphere oxygen concentration real, protected :: atm_co2_nat = 284.32 ! atmosphere CO2 concentration CMIP6 pre-industrial reference real, protected :: atm_bromo = 3.4 ! atmosphere bromophorme concentration @@ -227,7 +225,7 @@ module mo_param_bgc real, protected :: remido = 0.004 ! 1/d - remineralization rate (of DOM) ! deep sea remineralisation constants real, protected :: drempoc = 0.025 ! 1/d Aerob remineralization rate detritus - real, protected :: drempoc_anaerob = 0.05*drempoc ! remin in sub-/anoxic environm. - not be overwritten by lm4ago + real, protected :: drempoc_anaerob = 1.25e-3 ! =0.05*drempoc - remin in sub-/anoxic environm. - not be overwritten by lm4ago real, protected :: bkox_drempoc = 1e-7 ! half-saturation constant for oxygen for ammonification (aerobic remin via drempoc) real, protected :: dremopal = 0.003 ! 1/d Dissolution rate for opal real, protected :: dremn2o = 0.01 ! 1/d Remineralization rate of detritus on N2O @@ -337,7 +335,7 @@ subroutine ini_parambgc(kpie,kpje) call calc_param_atm() ! calculate atmospheric parameters after updating parameters via nml call calc_param_biol() ! potentially readjust namlist parameter-dependent parameters call rates_2_timestep() ! Converting rates from /d... to /dtb - call init_m4ago_params() ! Initialize M4AGO parameters relying on nml parameters +! call init_m4ago_params() ! Initialize M4AGO parameters relying on nml parameters call write_parambgc() ! write out used parameters and calculate back rates from /dtb to /d.. end subroutine ini_parambgc @@ -445,13 +443,13 @@ subroutine calc_param_biol() dremopal = 0.023 endif ! M4AGO parameters - call init_m4ago_nml_params() +! call init_m4ago_nml_params() #ifdef extNcycle ! initialize the extended nitrogen cycle parameters - first water column, then sediment, ! since sediment relies on water column parameters for the extended nitrogen cycle ! Sediment also relies on M4AGO being initialized (POM_remin_q10 and POM_remin_Tref) - call extNwatercol_param_init() - call extNsediment_param_init() +! call extNwatercol_param_init() +! call extNsediment_param_init() #endif end subroutine calc_param_biol @@ -533,8 +531,8 @@ subroutine rates_2_timestep() disso_caco3 = disso_caco3 * dtbgc ! 1/(kmol CO3--/m3 time step) Dissolution rate constant of CaCO3 sed_denit = sed_denit * dtbgc ! 1/time step Denitrification rate constant of POP #ifdef extNcycle - call extNwatercol_param_update() - call extNsediment_param_update() +! call extNwatercol_param_update() +! call extNsediment_param_update() #endif end subroutine rates_2_timestep @@ -773,8 +771,8 @@ subroutine write_parambgc() write(io_stdo_bgc,*) '* claydens = ',claydens endif #ifdef extNcycle - call extNwatercol_param_write() - call extNsediment_param_write() +! call extNwatercol_param_write() +! call extNsediment_param_write() #endif end subroutine write_parambgc diff --git a/hamocc/mo_powach.F90 b/hamocc/mo_powach.F90 index f77be13a..5b7825fc 100644 --- a/hamocc/mo_powach.F90 +++ b/hamocc/mo_powach.F90 @@ -25,7 +25,7 @@ module mo_powach contains - subroutine powach(kpie,kpje,kpke,kbnd,prho,omask,psao,lspin) + subroutine powach(kpie,kpje,kpke,kbnd,prho,omask,psao,ptho,lspin) !*********************************************************************************************** ! Ernst Maier-Reimer, *MPI-Met, HH* 10.04.01 @@ -46,6 +46,13 @@ subroutine powach(kpie,kpje,kpke,kbnd,prho,omask,psao,lspin) use mo_powadi, only: powadi use mo_carchm, only: carchm_solve use mo_dipowa, only: dipowa +#ifdef extNcycle + use mo_param1_bgc, only: ipownh4 + use mo_extNwatercol, only: ro2utammo + use mo_extNsediment, only: extNsediment_param_init,sed_nitrification,sed_denit_NO3_to_NO2,sed_anammox,sed_denit_DNRA, & + & extNsed_diagnostics,ised_remin_aerob,ised_remin_sulf,POM_remin_q10_sed,POM_remin_Tref_sed, & + & bkox_drempoc_sed +#endif ! Arguments integer, intent(in) :: kpie ! 1st dimension of model grid. @@ -55,6 +62,7 @@ subroutine powach(kpie,kpje,kpke,kbnd,prho,omask,psao,lspin) real, intent(in) :: prho(kpie,kpje,kpke) ! seawater density [g/cm^3]. real, intent(in) :: omask(kpie,kpje) ! land/ocean mask. real, intent(in) :: psao(1-kbnd:kpie+kbnd,1-kbnd:kpje+kbnd,kpke) ! salinity [psu]. + real, intent(in) :: ptho(1-kbnd:kpie+kbnd,1-kbnd:kpje+kbnd,kpke) ! Pot. temperature [deg C]. logical, intent(in) :: lspin ! Local variables @@ -62,6 +70,8 @@ subroutine powach(kpie,kpje,kpke,kbnd,prho,omask,psao,lspin) real :: sedb1(kpie,0:ks),sediso(kpie,0:ks) real :: solrat(kpie,ks),powcar(kpie,ks) real :: aerob(kpie,ks),anaerob(kpie,ks),sulf(kpie,ks) + real :: ex_ddic(kpie,ks),ex_dalk(kpie,ks) !sum of DIC and alk changes related to extended nitrogen cycle + real :: ex_disso_poc real :: aerob13(kpie,ks),anaerob13(kpie,ks),sulf13(kpie,ks) ! cisonew real :: aerob14(kpie,ks),anaerob14(kpie,ks),sulf14(kpie,ks) ! cisonew real :: dissot, undsa, posol @@ -82,6 +92,7 @@ subroutine powach(kpie,kpje,kpke,kbnd,prho,omask,psao,lspin) !$OMP PARALLEL DO & !$OMP&PRIVATE(sedb1,sediso,solrat,powcar,aerob,anaerob, & + !$OMP& ex_dalk,ex_ddic,ex_disso_poc, & !$OMP& dissot,undsa,posol, & !$OMP& umfa,denit,saln,rrho,alk,c,sit,pt, & !$OMP& K1,K2,Kb,Kw,Ks1,Kf,Ksi,K1p,K2p,K3p, & @@ -95,7 +106,12 @@ subroutine powach(kpie,kpje,kpke,kbnd,prho,omask,psao,lspin) do i = 1, kpie solrat(i,k) = 0. powcar(i,k) = 0. +#ifndef extNcycle anaerob(i,k)= 0. +#else + ex_ddic(i,k)=0. + ex_dalk(i,k)=0. +#endif aerob(i,k) = 0. sulf(i,k) = 0. if (use_cisonew) then @@ -205,10 +221,21 @@ subroutine powach(kpie,kpje,kpke,kbnd,prho,omask,psao,lspin) if(omask(i,j) > 0.5) then undsa = powtra(i,j,1,ipowaox) sedb1(i,0) = bolay(i,j) * ocetra(i,j,kbo(i,j),ioxygen) - solrat(i,1) = ( sedlay(i,j,1,issso12) + prorca(i,j) & - & / (porsol(i,j,1) * seddw(1)) ) & - & * ro2ut * dissot / (1. + dissot * undsa) & - & * porsol(i,j,1) / porwat(i,j,1) +#ifndef extNcyce + solrat(i,1) = ( sedlay(i,j,1,issso12) + prorca(i,j) & + & / (porsol(i,j,1) * seddw(1)) ) & + & * ro2ut * dissot / (1. + dissot * undsa) & + & * porsol(i,j,1) / porwat(i,j,1) +#else + ! extended nitrogen cycle - 140mol O2/mol POP O2-consumption + ! O2 and T-dep + ex_disso_poc = dissot * powtra(i,j,k,ipowaox)/(powtra(i,j,k,ipowaox) + bkox_drempoc_sed) & ! oxygen limitation + & * POM_remin_q10_sed**((ptho(i,j,kbo(i,j))-POM_remin_Tref_sed)/10.) ! T-dep + solrat(i,1) = ( sedlay(i,j,1,issso12) + prorca(i,j) & + & / (porsol(i,j,1) * seddw(1)) ) & + & * ro2utammo * ex_disso_poc / (1. + ex_disso_poc * undsa) & + & * porsol(i,j,1) / porwat(i,j,1) +#endif endif enddo @@ -221,8 +248,16 @@ subroutine powach(kpie,kpje,kpke,kbnd,prho,omask,psao,lspin) if(omask(i,j) > 0.5) then undsa = powtra(i,j,k,ipowaox) sedb1(i,k) = seddw(k) * porwat(i,j,k) * powtra(i,j,k,ipowaox) - if (k > 1) solrat(i,k) = sedlay(i,j,k,issso12) * ro2ut * dissot & - & / (1. + dissot*undsa) * porsol(i,j,k) / porwat(i,j,k) +#ifndef extNcycle + if (k > 1) solrat(i,k) = sedlay(i,j,k,issso12) * ro2ut * dissot & + & / (1. + dissot*undsa) * porsol(i,j,k) / porwat(i,j,k) +#else + ! extended nitrogen cycle - 140mol O2/mol POP O2-consumption + ex_disso_poc = dissot * powtra(i,j,k,ipowaox)/(powtra(i,j,k,ipowaox) + bkox_drempoc_sed) & ! oxygen limitation + & * POM_remin_q10_sed**((ptho(i,j,kbo(i,j))-POM_remin_Tref_sed)/10.) ! T-dep + if (k > 1) solrat(i,k) = sedlay(i,j,k,issso12) * ro2utammo * ex_disso_poc & + & / (1. + ex_disso_poc*undsa) * porsol(i,j,k) / porwat(i,j,k) +#endif endif enddo enddo @@ -258,9 +293,14 @@ subroutine powach(kpie,kpje,kpke,kbnd,prho,omask,psao,lspin) do i = 1, kpie if(omask(i,j) > 0.5) then umfa = porsol(i,j,k) / porwat(i,j,k) +#ifndef extNcycle solrat(i,k) = sedlay(i,j,k,issso12) * dissot/(1. + dissot*sediso(i,k)) +#else + ex_disso_poc = dissot * powtra(i,j,k,ipowaox)/(powtra(i,j,k,ipowaox) + bkox_drempoc_sed) & ! oxygen limitation + & * POM_remin_q10_sed**((ptho(i,j,kbo(i,j))-POM_remin_Tref_sed)/10.) ! T-dep + solrat(i,k) = sedlay(i,j,k,issso12) * ex_disso_poc/(1. + ex_disso_poc*sediso(i,k)) +#endif posol = sediso(i,k)*solrat(i,k) - aerob(i,k) = posol*umfa !this has P units: kmol P/m3 of pore water if (use_cisonew) then rato13 = sedlay(i,j,k,issso13) / (sedlay(i,j,k,issso12) + safediv) rato14 = sedlay(i,j,k,issso14) / (sedlay(i,j,k,issso12) + safediv) @@ -271,7 +311,15 @@ subroutine powach(kpie,kpje,kpke,kbnd,prho,omask,psao,lspin) endif sedlay(i,j,k,issso12) = sedlay(i,j,k,issso12) - posol powtra(i,j,k,ipowaph) = powtra(i,j,k,ipowaph) + posol*umfa - powtra(i,j,k,ipowno3) = powtra(i,j,k,ipowno3) + posol*rnit*umfa +#ifndef extNcycle + powtra(i,j,k,ipowno3) = powtra(i,j,k,ipowno3) + posol*rnit*umfa + aerob(i,k) = posol*umfa !this has P units: kmol P/m3 of pore water +#else + powtra(i,j,k,ipownh4) = powtra(i,j,k,ipownh4) + posol*rnit*umfa + ex_ddic(i,k) = rcar*posol*umfa ! C-units kmol C/m3 of pore water + ex_dalk(i,k) = (rnit-1.)*posol*umfa ! alkalinity units + extNsed_diagnostics(i,j,k,ised_remin_aerob) = posol*rnit*umfa ! Output +#endif powtra(i,j,k,ipowaox) = sediso(i,k) if (use_cisonew) then sedlay(i,j,k,issso13) = sedlay(i,j,k,issso13) - poso13 @@ -283,9 +331,11 @@ subroutine powach(kpie,kpje,kpke,kbnd,prho,omask,psao,lspin) ! Calculate nitrate reduction under anaerobic conditions explicitely !******************************************************************* - +#ifndef extNcycle ! Denitrification rate constant of POP (disso) [1/sec]*dtbgc denit = sed_denit + + ! Store flux in array anaerob, for later computation of DIC and alkalinity. do k = 1, ks do i = 1, kpie if(omask(i,j) > 0.5) then @@ -313,6 +363,14 @@ subroutine powach(kpie,kpje,kpke,kbnd,prho,omask,psao,lspin) endif enddo enddo +#else + !======>>>> extended nitrogen cycle processes (aerobic and anaerobic) that follow ammonification + call sed_nitrification(j,kpie,kpje,kpke,kbnd,ptho,omask,ex_ddic,ex_dalk) + call sed_denit_NO3_to_NO2(j,kpie,kpje,kpke,kbnd,ptho,omask,ex_ddic,ex_dalk) + call sed_anammox(j,kpie,kpje,kpke,kbnd,ptho,omask,ex_ddic,ex_dalk) + call sed_denit_dnra(j,kpie,kpje,kpke,kbnd,ptho,omask,ex_ddic,ex_dalk) +#endif + ! sulphate reduction in sediments do k = 1, ks @@ -337,6 +395,9 @@ subroutine powach(kpie,kpje,kpke,kbnd,prho,omask,psao,lspin) sedlay(i,j,k,issso13) = sedlay(i,j,k,issso13) - poso13 sedlay(i,j,k,issso14) = sedlay(i,j,k,issso14) - poso14 endif +#ifdef extNcycle + extNsed_diagnostics(i,j,k,ised_remin_sulf) = posol*umfa ! Output +#endif endif endif enddo @@ -355,8 +416,13 @@ subroutine powach(kpie,kpje,kpke,kbnd,prho,omask,psao,lspin) if(omask(i,j) > 0.5) then saln= min( 40., max( 0., psao(i,j,kbo(i,j)))) rrho= prho(i,j,kbo(i,j)) - alk = (powtra(i,j,k,ipowaal) - (sulf(i,k)+aerob(i,k))*(rnit+1.) + anaerob(i,k)*(rdnit1-1.)) / rrho - c = (powtra(i,j,k,ipowaic) + (anaerob(i,k)+aerob(i,k)+sulf(i,k))*rcar) / rrho +#ifdef extNcycle + alk = (powtra(i,j,k,ipowaal) - (sulf(i,k)+aerob(i,k))*(rnit+1.) + ex_dalk(i,k)) / rrho + c = (powtra(i,j,k,ipowaic) + (aerob(i,k)+sulf(i,k))*rcar + ex_ddic(i,k)) / rrho +#else + alk = (powtra(i,j,k,ipowaal) - (sulf(i,k)+aerob(i,k))*(rnit+1.) + anaerob(i,k)*(rdnit1-1.)) / rrho + c = (powtra(i,j,k,ipowaic) + (anaerob(i,k)+aerob(i,k)+sulf(i,k))*rcar) / rrho +#endif sit = powtra(i,j,k,ipowasi) / rrho pt = powtra(i,j,k,ipowaph) / rrho ah1 = sedhpl(i,j,k) @@ -461,10 +527,17 @@ subroutine powach(kpie,kpje,kpke,kbnd,prho,omask,psao,lspin) poso14 = posol * ratc14 endif sedlay(i,j,k,isssc12) = sedlay(i,j,k,isssc12) - posol - powtra(i,j,k,ipowaic) = powtra(i,j,k,ipowaic) & - & + posol * umfa + (aerob(i,k) + anaerob(i,k) + sulf(i,k)) * rcar - powtra(i,j,k,ipowaal) = powtra(i,j,k,ipowaal) & - & + 2. * posol * umfa - (rnit+1.)*(aerob(i,k) + sulf(i,k)) + (rdnit1-1.)*anaerob(i,k) +#ifdef extNcycle + powtra(i,j,k,ipowaic) = powtra(i,j,k,ipowaic) & + & + posol * umfa + (aerob(i,k) + sulf(i,k)) * rcar + ex_ddic(i,k) + powtra(i,j,k,ipowaal) = powtra(i,j,k,ipowaal) & + & + 2. * posol * umfa - (rnit+1.)*(aerob(i,k) + sulf(i,k)) + ex_dalk(i,k) +#else + powtra(i,j,k,ipowaic) = powtra(i,j,k,ipowaic) & + & + posol * umfa + (aerob(i,k) + anaerob(i,k) + sulf(i,k)) * rcar + powtra(i,j,k,ipowaal) = powtra(i,j,k,ipowaal) & + & + 2. * posol * umfa - (rnit+1.)*(aerob(i,k) + sulf(i,k)) + (rdnit1-1.)*anaerob(i,k) +#endif if (use_cisonew) then sedlay(i,j,k,isssc13) = sedlay(i,j,k,isssc13) - poso13 sedlay(i,j,k,isssc14) = sedlay(i,j,k,isssc14) - poso14 diff --git a/hamocc/mo_preftrc.F90 b/hamocc/mo_preftrc.F90 index 007c4ee5..9a80be36 100644 --- a/hamocc/mo_preftrc.F90 +++ b/hamocc/mo_preftrc.F90 @@ -39,7 +39,7 @@ subroutine preftrc(kpie,kpje,omask) !*********************************************************************************************** use mo_carbch, only: ocetra - use mo_param1_bgc, only: ialkali,ioxygen,iphosph,iprefalk,iprefdic,iprefo2,iprefpo4,isco212 + use mo_param1_bgc, only: ialkali,ioxygen,iphosph,isilica,iprefalk,iprefdic,iprefo2,iprefpo4,isco212,iprefsilica use mo_vgrid, only: kmle ! Arguments @@ -55,6 +55,7 @@ subroutine preftrc(kpie,kpje,omask) if (omask(i,j) .gt. 0.5 ) then ocetra(i,j,1:kmle(i,j),iprefo2) = ocetra(i,j,1:kmle(i,j),ioxygen) ocetra(i,j,1:kmle(i,j),iprefpo4) = ocetra(i,j,1:kmle(i,j),iphosph) + ocetra(i,j,1:kmle(i,j),iprefsilica)= ocetra(i,j,1:kmle(i,j),isilica) ocetra(i,j,1:kmle(i,j),iprefalk) = ocetra(i,j,1:kmle(i,j),ialkali) ocetra(i,j,1:kmle(i,j),iprefdic) = ocetra(i,j,1:kmle(i,j),isco212) endif diff --git a/hamocc/mo_sedshi.F90 b/hamocc/mo_sedshi.F90 index 9015fe0f..102e10c5 100644 --- a/hamocc/mo_sedshi.F90 +++ b/hamocc/mo_sedshi.F90 @@ -44,6 +44,7 @@ subroutine sedshi(kpie,kpje,omask) use mo_param_bgc, only: rcar use mo_param1_bgc, only: isssc12,issssil,issso12,issster,ks,nsedtra,isssc13,isssc14, & issso13,issso14 + use mo_carbch, only: sedfluxb use mo_control_bgc, only: use_cisonew ! Arguments @@ -58,6 +59,7 @@ subroutine sedshi(kpie,kpje,omask) real :: sedlo,uebers,seddef,spresent,buried real :: refill,frac + sedfluxb(:,:,:) = 0. ! DOWNWARD SHIFTING ! shift solid sediment sediment downwards, if layer is full, i.e., if ! the volume filled by the four constituents poc, opal, caco3, clay @@ -130,9 +132,10 @@ subroutine sedshi(kpie,kpje,omask) do i=1,kpie if(omask(i,j).gt.0.5) then !ka if(bolay(i,j).gt.0.) then - uebers=wsed(i,j)*sedlay(i,j,k,iv) + uebers=wsed(i,j)*sedlay(i,j,ks,iv) sedlay(i,j,ks ,iv)=sedlay(i,j,ks ,iv)-uebers - burial(i,j,iv)=burial(i,j,iv)+uebers*seddw(k)*porsol(i,j,k) + burial(i,j,iv)=burial(i,j,iv)+uebers*seddw(ks)*porsol(i,j,ks) + sedfluxb(i,j,iv) = uebers*seddw(ks)*porsol(i,j,ks) endif enddo !end i-loop enddo !end j-loop @@ -236,6 +239,12 @@ subroutine sedshi(kpie,kpje,omask) burial(i,j,issso14) = burial(i,j,issso14)-refill*burial(i,j,issso14) burial(i,j,isssc14) = burial(i,j,isssc14)-refill*burial(i,j,isssc14) endif + ! account for refluxes to get net-burial fluxes: + ! note that this (and before) assumes no reflux of isotopes! - up to change? + sedfluxb(i,j,issso12) = sedfluxb(i,j,issso12) - refill*burial(i,j,issso12) + sedfluxb(i,j,isssc12) = sedfluxb(i,j,isssc12) - refill*burial(i,j,isssc12) + sedfluxb(i,j,issssil) = sedfluxb(i,j,issssil) - refill*burial(i,j,issssil) + sedfluxb(i,j,issster) = sedfluxb(i,j,issster) - refill*burial(i,j,issster) endif enddo !end i-loop enddo !end j-loop From a1ef6a7f2f81ece3c52584d48c2aa48916462217 Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Fri, 19 Jan 2024 18:16:22 +0100 Subject: [PATCH 322/366] replace extNcycle preprocessor flags - still fixes to be done M4AGO- and extNcycle-routines currently not ready due to cyclic dependencies, introduced by the new proteced statements in mo_param_bgc via the merge - requires modifications --- hamocc/mo_accfields.F90 | 190 ++++++++------- hamocc/mo_apply_ndep.F90 | 34 ++- hamocc/mo_aufr_bgc.F90 | 32 +-- hamocc/mo_aufw_bgc.F90 | 38 ++- hamocc/mo_bgcmean.F90 | 130 +++++----- hamocc/mo_biomod.F90 | 50 ++-- hamocc/mo_carbch.F90 | 8 +- hamocc/mo_carchm.F90 | 82 +++---- hamocc/mo_chemcon.F90 | 55 ++--- hamocc/mo_cyano.F90 | 33 ++- hamocc/mo_hamocc4bcm.F90 | 36 ++- hamocc/mo_hamocc_init.F90 | 15 +- hamocc/mo_ini_fields.F90 | 24 +- hamocc/mo_inventory_bgc.F90 | 72 +++--- hamocc/mo_ncout_hamocc.F90 | 465 ++++++++++++++++++------------------ hamocc/mo_ocprod.F90 | 292 +++++++++++----------- hamocc/mo_param_bgc.F90 | 13 +- hamocc/mo_powach.F90 | 166 +++++++------ hamocc/mo_read_ndep.F90 | 104 ++++---- 19 files changed, 898 insertions(+), 941 deletions(-) diff --git a/hamocc/mo_accfields.F90 b/hamocc/mo_accfields.F90 index 2a3ad430..5469193d 100644 --- a/hamocc/mo_accfields.F90 +++ b/hamocc/mo_accfields.F90 @@ -45,14 +45,17 @@ subroutine accfields(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask) ndepnoyflx,rivinflx,oalkflx,ocetra,omegaa,omegac,pco2d, & satoxy,sedfluxo,sedfluxb,pco2m,kwco2d,co2sold,co2solm,pn2om, & co213fxd,co213fxu,co214fxd,co214fxu, & - natco3,nathi,natomegaa,natomegac,natpco2d + natco3,nathi,natomegaa,natomegac,natpco2d,pnh3,ndepnhxflx use mo_biomod, only: bsiflx_bot,bsiflx0100,bsiflx0500,bsiflx1000, & bsiflx2000,bsiflx4000,calflx_bot,calflx0100,calflx0500, & calflx1000,calflx2000,calflx4000,carflx_bot,carflx0100, & carflx0500,carflx1000,carflx2000,carflx4000, & expoca,expoor,exposi,intdms_bac,intdms_uv,intdmsprod, & intdnit,intnfix,intphosy,phosy3d, & - int_chbr3_prod,int_chbr3_uv,asize3d,eps3d,wnumb,wmass + int_chbr3_prod,int_chbr3_uv,asize3d,eps3d,wnumb,wmass, & + nitr_NH4,nitr_NO2,nitr_N2O_prod,nitr_NH4_OM,nitr_NO2_OM,denit_NO3, & + denit_NO2,denit_N2O,DNRA_NO2,anmx_N2_prod,anmx_OM_prod,phosy_NH4, & + phosy_NO3,remin_aerob,remin_sulf use mo_param_bgc, only: c14fac,re1312,re14to use mo_bgcmean, only: domassfluxes,jalkali,jano3,jasize,jatmco2, & jbsiflx0100,jbsiflx0500,jbsiflx1000,jbsiflx2000, & @@ -113,7 +116,17 @@ subroutine accfields(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask) jlvl_agg_ws,jlvl_dynvis,jlvl_agg_stick,jlvl_agg_stickf, & jlvl_agg_dmax,jlvl_agg_avdp,jlvl_agg_avrhop,jlvl_agg_avdC, & jlvl_agg_df,jlvl_agg_b,jlvl_agg_Vrhof,jlvl_agg_Vpor, & - jprefsilica,jlvlprefsilica + jprefsilica,jlvlprefsilica, & + jnh3flux,janh3fx,janh4,jano2,jsrfanh4,jsrfano2,jsrfpnh3, & + jnitr_NH4,jnitr_NO2,jnitr_N2O_prod,jnitr_NH4_OM,jnitr_NO2_OM, & + jdenit_NO3,jdenit_NO2,jdenit_N2O,jDNRA_NO2,janmx_N2_prod, & + janmx_OM_prod,jphosy_NH4,jphosy_NO3,jremin_aerob,jremin_sulf, & + jpownh4,jpown2o,jpowno2,jsdm_nitr_NH4,jsdm_nitr_NO2, & + jsdm_nitr_N2O_prod,jsdm_nitr_NH4_OM,jsdm_nitr_NO2_OM, & + jsdm_denit_NO3,jsdm_denit_NO2,jsdm_denit_N2O,jsdm_DNRA_NO2, & + jsdm_anmx_N2_prod,jsdm_anmx_OM_prod,jsdm_remin_aerob, & + jsdm_remin_sulf,jsediffnh4,jsediffn2o,jsediffno2,jatmn2o,jatmnh3, & + jndepnhxfx use mo_control_bgc, only: io_stdo_bgc,dtb,use_BROMO,use_AGG,use_WLIN,use_natDIC, & use_CFC,use_sedbypass,use_cisonew,use_BOXATM,lm4ago,use_extNcycle use mo_param1_bgc, only: ialkali,ian2o,iano3,iatmco2,iatmdms,iatmn2,iatmn2o,iatmo2, & @@ -127,7 +140,8 @@ subroutine accfields(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask) iatmnco2,inatalkali,inatcalc,inatsco212, & ipowaal,ipowaic,ipowaox,ipowaph,ipowasi, & ipown2,ipowno3,isssc12,issso12,issssil,issster, & - issso12,isssc12,issssil,issster,iprefsilica + issso12,isssc12,issssil,issster,iprefsilica,iatmnh3,ianh4,iano2, & + ipownh4,ipown2o,ipowno2 use mo_sedmnt, only: powtra,sedlay,burial use mo_vgrid, only: dp_min use mo_inventory_bgc, only: inventory_bgc @@ -135,22 +149,10 @@ subroutine accfields(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask) use mo_m4ago, only: aggregate_diagnostics,kav_dp,kav_rho_p,kav_d_C,kws_agg,kdf_agg, & kstickiness_agg,kb_agg,kstickiness_frustule,kLmax_agg,kdynvis, & kav_rhof_V,kav_por_V -#ifdef extNcycle - use mo_carbch, only: pnh3,ndepnhxflx - use mo_param1_bgc, only: iatmnh3,ianh4,iano2,ipownh4,ipown2o,ipowno2 - use mo_bgcmean, only: jnh3flux,janh3fx,janh4,jano2,jsrfanh4,jsrfano2,jsrfpnh3, & - & jnitr_NH4,jnitr_NO2,jnitr_N2O_prod,jnitr_NH4_OM,jnitr_NO2_OM,jdenit_NO3,jdenit_NO2,jdenit_N2O, & - & jDNRA_NO2,janmx_N2_prod,janmx_OM_prod,jphosy_NH4,jphosy_NO3,jremin_aerob,jremin_sulf, & - & jpownh4,jpown2o,jpowno2,jsdm_nitr_NH4,jsdm_nitr_NO2,jsdm_nitr_N2O_prod,jsdm_nitr_NH4_OM, & - & jsdm_nitr_NO2_OM,jsdm_denit_NO3,jsdm_denit_NO2,jsdm_denit_N2O,jsdm_DNRA_NO2,jsdm_anmx_N2_prod, & - & jsdm_anmx_OM_prod,jsdm_remin_aerob,jsdm_remin_sulf,jsediffnh4,jsediffn2o,jsediffno2,jatmn2o,jatmnh3,& - & jndepnhxfx - use mo_biomod, only: nitr_NH4,nitr_NO2,nitr_N2O_prod,nitr_NH4_OM,nitr_NO2_OM,denit_NO3,denit_NO2,denit_N2O,DNRA_NO2, & - & anmx_N2_prod,anmx_OM_prod,phosy_NH4,phosy_NO3,remin_aerob,remin_sulf - use mo_extNsediment,only: extNsed_diagnostics,ised_nitr_NH4,ised_nitr_NO2,ised_nitr_N2O_prod,ised_nitr_NH4_OM, & - & ised_nitr_NO2_OM,ised_denit_NO3,ised_denit_NO2,ised_denit_N2O,ised_DNRA_NO2,ised_anmx_N2_prod, & - & ised_anmx_OM_prod,ised_remin_aerob,ised_remin_sulf -#endif + use mo_extNsediment, only: extNsed_diagnostics,ised_nitr_NH4,ised_nitr_NO2,ised_nitr_N2O_prod,& + ised_nitr_NH4_OM,ised_nitr_NO2_OM,ised_denit_NO3,ised_denit_NO2, & + ised_denit_N2O,ised_DNRA_NO2,ised_anmx_N2_prod,ised_anmx_OM_prod, & + ised_remin_aerob,ised_remin_sulf ! Arguments integer , intent(in) :: kpie ! 1st dimension of model grid. @@ -204,10 +206,10 @@ subroutine accfields(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask) bgct2d(i,j,jo2flux) = bgct2d(i,j,jo2flux) + atmflx(i,j,iatmo2)/2.0 bgct2d(i,j,jn2flux) = bgct2d(i,j,jn2flux) + atmflx(i,j,iatmn2)/2.0 bgct2d(i,j,jn2oflux) = bgct2d(i,j,jn2oflux) + atmflx(i,j,iatmn2o)/2.0 -#ifdef extNcycle - bgct2d(i,j,jnh3flux) = bgct2d(i,j,jnh3flux) + atmflx(i,j,iatmnh3)/2.0 - bgct2d(i,j,jndepnhx) = bgct2d(i,j,jndepnhx) + ndepnhxflx(i,j)/2.0 -#endif + if (use_extNcycle) then + bgct2d(i,j,jnh3flux) = bgct2d(i,j,jnh3flux) + atmflx(i,j,iatmnh3)/2.0 + bgct2d(i,j,jndepnhx) = bgct2d(i,j,jndepnhx) + ndepnhxflx(i,j)/2.0 + endif ! Particle fluxes between water-column and sediment bgct2d(i,j,jprorca) = bgct2d(i,j,jprorca) + carflx_bot(i,j)/2.0 bgct2d(i,j,jprcaca) = bgct2d(i,j,jprcaca) + calflx_bot(i,j)/2.0 @@ -263,11 +265,11 @@ subroutine accfields(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask) call accsrf(jatmc13,atm(1,1,iatmc13),omask,0) call accsrf(jatmc14,atm(1,1,iatmc14),omask,0) endif -#ifdef extNcycle + if (use_extNcycle) then call accsrf(janh3fx,atmflx(1,1,iatmnh3),omask,0) call accsrf(jatmnh3,atm(1,1,iatmnh3),omask,0) call accsrf(jatmn2o,atm(1,1,iatmn2o),omask,0) -#endif + endif ! Save up and downward fluxes for CO2 seperately call accsrf(jco2fxd,co2fxd,omask,0) call accsrf(jco2fxu,co2fxu,omask,0) @@ -321,12 +323,12 @@ subroutine accfields(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask) call accsrf(jndepnoyfx,ndepnoyflx,omask,0) call accsrf(joalkfx,oalkflx,omask,0) -#ifdef extNcycle + if (use_extNcycle) then call accsrf(jsrfanh4,ocetra(1,1,1,ianh4),omask,0) call accsrf(jsrfpnh3,pnh3,omask,0) call accsrf(jsrfano2,ocetra(1,1,1,iano2),omask,0) - call accsrf(jndepnhxfx,ndepnhxflx,omask,0) -#endif + call accsrf(jndepnhxfx,ndepnhxflx,omask,0) + endif ! Accumulate the diagnostic mass sinking field if( domassfluxes ) then @@ -359,16 +361,16 @@ subroutine accfields(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask) call accsrf(jsediffn2,sedfluxo(1,1,ipown2),omask,0) call accsrf(jsediffno3,sedfluxo(1,1,ipowno3),omask,0) call accsrf(jsediffsi,sedfluxo(1,1,ipowasi),omask,0) - call accsrf(jburflxsso12,sedfluxb(1,1,issso12),omask,0) - call accsrf(jburflxsssc12,sedfluxb(1,1,isssc12),omask,0) - call accsrf(jburflxssssil,sedfluxb(1,1,issssil),omask,0) + call accsrf(jburflxsso12,sedfluxb(1,1,issso12),omask,0) + call accsrf(jburflxsssc12,sedfluxb(1,1,isssc12),omask,0) + call accsrf(jburflxssssil,sedfluxb(1,1,issssil),omask,0) call accsrf(jburflxssster,sedfluxb(1,1,issster),omask,0) + if (use_extNcycle) then + call accsrf(jsediffnh4,sedfluxo(1,1,ipownh4),omask,0) + call accsrf(jsediffn2o,sedfluxo(1,1,ipown2o),omask,0) + call accsrf(jsediffno2,sedfluxo(1,1,ipowno2),omask,0) + endif endif -#if defined(extNcycle) && ! defined(sedbypass) - call accsrf(jsediffnh4,sedfluxo(1,1,ipownh4),omask,0) - call accsrf(jsediffn2o,sedfluxo(1,1,ipown2o),omask,0) - call accsrf(jsediffno2,sedfluxo(1,1,ipowno2),omask,0) -#endif ! Accumulate layer diagnostics call acclyr(jdp,pddpo,pddpo,0) call acclyr(jphyto,ocetra(1,1,1,iphy),pddpo,1) @@ -433,8 +435,8 @@ subroutine accfields(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask) if (use_BROMO) then call acclyr(jbromo,ocetra(1,1,1,ibromo),pddpo,1) endif -#ifdef extNcycle - call acclyr(janh4,ocetra(1,1,1,ianh4),pddpo,1) + if (use_extNcycle) then + call acclyr(janh4,ocetra(1,1,1,ianh4),pddpo,1) call acclyr(jano2,ocetra(1,1,1,iano2),pddpo,1) call acclyr(jnitr_NH4,nitr_NH4,pddpo,1) call acclyr(jnitr_NO2,nitr_NO2,pddpo,1) @@ -451,22 +453,22 @@ subroutine accfields(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask) call acclyr(jphosy_NO3,phosy_NO3,pddpo,1) call acclyr(jremin_aerob,remin_aerob,pddpo,1) call acclyr(jremin_sulf,remin_sulf,pddpo,1) -#endif - if (lm4ago) then - ! M4AGO - call acclyr(jagg_ws,aggregate_diagnostics(1,1,1,kws_agg),pddpo,1) - call acclyr(jdynvis,aggregate_diagnostics(1,1,1,kdynvis),pddpo,1) - call acclyr(jagg_stick,aggregate_diagnostics(1,1,1,kstickiness_agg),pddpo,1) - call acclyr(jagg_stickf,aggregate_diagnostics(1,1,1,kstickiness_frustule),pddpo,1) - call acclyr(jagg_dmax,aggregate_diagnostics(1,1,1,kLmax_agg),pddpo,1) - call acclyr(jagg_avdp,aggregate_diagnostics(1,1,1,kav_dp),pddpo,1) - call acclyr(jagg_avrhop,aggregate_diagnostics(1,1,1,kav_rho_p),pddpo,1) - call acclyr(jagg_avdC,aggregate_diagnostics(1,1,1,kav_d_C),pddpo,1) - call acclyr(jagg_df,aggregate_diagnostics(1,1,1,kdf_agg),pddpo,1) - call acclyr(jagg_b,aggregate_diagnostics(1,1,1,kb_agg),pddpo,1) - call acclyr(jagg_Vrhof,aggregate_diagnostics(1,1,1,kav_rhof_V),pddpo,1) - call acclyr(jagg_Vpor,aggregate_diagnostics(1,1,1,kav_por_V),pddpo,1) - endif + endif + if (lm4ago) then + ! M4AGO + call acclyr(jagg_ws,aggregate_diagnostics(1,1,1,kws_agg),pddpo,1) + call acclyr(jdynvis,aggregate_diagnostics(1,1,1,kdynvis),pddpo,1) + call acclyr(jagg_stick,aggregate_diagnostics(1,1,1,kstickiness_agg),pddpo,1) + call acclyr(jagg_stickf,aggregate_diagnostics(1,1,1,kstickiness_frustule),pddpo,1) + call acclyr(jagg_dmax,aggregate_diagnostics(1,1,1,kLmax_agg),pddpo,1) + call acclyr(jagg_avdp,aggregate_diagnostics(1,1,1,kav_dp),pddpo,1) + call acclyr(jagg_avrhop,aggregate_diagnostics(1,1,1,kav_rho_p),pddpo,1) + call acclyr(jagg_avdC,aggregate_diagnostics(1,1,1,kav_d_C),pddpo,1) + call acclyr(jagg_df,aggregate_diagnostics(1,1,1,kdf_agg),pddpo,1) + call acclyr(jagg_b,aggregate_diagnostics(1,1,1,kb_agg),pddpo,1) + call acclyr(jagg_Vrhof,aggregate_diagnostics(1,1,1,kav_rhof_V),pddpo,1) + call acclyr(jagg_Vpor,aggregate_diagnostics(1,1,1,kav_por_V),pddpo,1) + endif ! Accumulate level diagnostics if (SUM(jlvlphyto+jlvlgrazer+jlvlphosph+jlvloxygen+jlvliron+ & & jlvlano3+jlvlalkali+jlvlsilica+jlvldic+jlvldoc+jlvlpoc+jlvlcalc+ & @@ -550,10 +552,9 @@ subroutine accfields(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask) if (use_BROMO) then call acclvl(jlvlbromo,ocetra(1,1,1,ibromo),k,ind1,ind2,wghts) endif -#ifdef extNcycle + if (use_extNcycle) then call acclvl(jlvlanh4,ocetra(1,1,1,ianh4),k,ind1,ind2,wghts) call acclvl(jlvlano2,ocetra(1,1,1,iano2),k,ind1,ind2,wghts) - call acclvl(jlvl_nitr_NH4,nitr_NH4,k,ind1,ind2,wghts) call acclvl(jlvl_nitr_NO2,nitr_NO2,k,ind1,ind2,wghts) call acclvl(jlvl_nitr_N2O_prod,nitr_N2O_prod,k,ind1,ind2,wghts) @@ -569,26 +570,25 @@ subroutine accfields(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask) call acclvl(jlvl_phosy_NO3,phosy_NO3,k,ind1,ind2,wghts) call acclvl(jlvl_remin_aerob,remin_aerob,k,ind1,ind2,wghts) call acclvl(jlvl_remin_sulf,remin_sulf,k,ind1,ind2,wghts) -#endif - if (lm4ago) then - !M4AGO - call acclvl(jlvl_agg_ws,aggregate_diagnostics(1,1,1,kws_agg),k,ind1,ind2,wghts) - call acclvl(jlvl_dynvis,aggregate_diagnostics(1,1,1,kdynvis),k,ind1,ind2,wghts) - call acclvl(jlvl_agg_stick,aggregate_diagnostics(1,1,1,kstickiness_agg),k,ind1,ind2,wghts) - call acclvl(jlvl_agg_stickf,aggregate_diagnostics(1,1,1,kstickiness_frustule),k,ind1,ind2,wghts) - call acclvl(jlvl_agg_dmax,aggregate_diagnostics(1,1,1,kLmax_agg),k,ind1,ind2,wghts) - call acclvl(jlvl_agg_avdp,aggregate_diagnostics(1,1,1,kav_dp),k,ind1,ind2,wghts) - call acclvl(jlvl_agg_avrhop,aggregate_diagnostics(1,1,1,kav_rho_p),k,ind1,ind2,wghts) - call acclvl(jlvl_agg_avdC,aggregate_diagnostics(1,1,1,kav_d_C),k,ind1,ind2,wghts) - call acclvl(jlvl_agg_df,aggregate_diagnostics(1,1,1,kdf_agg),k,ind1,ind2,wghts) - call acclvl(jlvl_agg_b,aggregate_diagnostics(1,1,1,kb_agg),k,ind1,ind2,wghts) - call acclvl(jlvl_agg_Vrhof,aggregate_diagnostics(1,1,1,kav_rhof_V),k,ind1,ind2,wghts) - call acclvl(jlvl_agg_Vpor,aggregate_diagnostics(1,1,1,kav_por_V),k,ind1,ind2,wghts) - endif + endif + if (lm4ago) then + !M4AGO + call acclvl(jlvl_agg_ws,aggregate_diagnostics(1,1,1,kws_agg),k,ind1,ind2,wghts) + call acclvl(jlvl_dynvis,aggregate_diagnostics(1,1,1,kdynvis),k,ind1,ind2,wghts) + call acclvl(jlvl_agg_stick,aggregate_diagnostics(1,1,1,kstickiness_agg),k,ind1,ind2,wghts) + call acclvl(jlvl_agg_stickf,aggregate_diagnostics(1,1,1,kstickiness_frustule),k,ind1,ind2,wghts) + call acclvl(jlvl_agg_dmax,aggregate_diagnostics(1,1,1,kLmax_agg),k,ind1,ind2,wghts) + call acclvl(jlvl_agg_avdp,aggregate_diagnostics(1,1,1,kav_dp),k,ind1,ind2,wghts) + call acclvl(jlvl_agg_avrhop,aggregate_diagnostics(1,1,1,kav_rho_p),k,ind1,ind2,wghts) + call acclvl(jlvl_agg_avdC,aggregate_diagnostics(1,1,1,kav_d_C),k,ind1,ind2,wghts) + call acclvl(jlvl_agg_df,aggregate_diagnostics(1,1,1,kdf_agg),k,ind1,ind2,wghts) + call acclvl(jlvl_agg_b,aggregate_diagnostics(1,1,1,kb_agg),k,ind1,ind2,wghts) + call acclvl(jlvl_agg_Vrhof,aggregate_diagnostics(1,1,1,kav_rhof_V),k,ind1,ind2,wghts) + call acclvl(jlvl_agg_Vpor,aggregate_diagnostics(1,1,1,kav_por_V),k,ind1,ind2,wghts) + endif enddo endif - if (.not. use_sedbypass) then ! Accumulate sediments call accsdm(jpowaic,powtra(1,1,1,ipowaic)) @@ -608,27 +608,25 @@ subroutine accfields(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask) call accbur(jburssssil,burial(1,1,issssil)) call accbur(jbursssc12,burial(1,1,isssc12)) call accbur(jburssster,burial(1,1,issster)) + if (use_extNcycle) then + call accsdm(jpownh4,powtra(1,1,1,ipownh4)) + call accsdm(jpown2o,powtra(1,1,1,ipown2o)) + call accsdm(jpowno2,powtra(1,1,1,ipowno2)) + call accsdm(jsdm_nitr_NH4 ,extNsed_diagnostics(1,1,1,ised_nitr_NH4)) + call accsdm(jsdm_nitr_NO2 ,extNsed_diagnostics(1,1,1,ised_nitr_NO2)) + call accsdm(jsdm_nitr_N2O_prod ,extNsed_diagnostics(1,1,1,ised_nitr_N2O_prod)) + call accsdm(jsdm_nitr_NH4_OM ,extNsed_diagnostics(1,1,1,ised_nitr_NH4_OM)) + call accsdm(jsdm_nitr_NO2_OM ,extNsed_diagnostics(1,1,1,ised_nitr_NO2_OM)) + call accsdm(jsdm_denit_NO3 ,extNsed_diagnostics(1,1,1,ised_denit_NO3)) + call accsdm(jsdm_denit_NO2 ,extNsed_diagnostics(1,1,1,ised_denit_NO2)) + call accsdm(jsdm_denit_N2O ,extNsed_diagnostics(1,1,1,ised_denit_N2O)) + call accsdm(jsdm_DNRA_NO2 ,extNsed_diagnostics(1,1,1,ised_DNRA_NO2)) + call accsdm(jsdm_anmx_N2_prod ,extNsed_diagnostics(1,1,1,ised_anmx_N2_prod)) + call accsdm(jsdm_anmx_OM_prod ,extNsed_diagnostics(1,1,1,ised_anmx_OM_prod)) + call accsdm(jsdm_remin_aerob ,extNsed_diagnostics(1,1,1,ised_remin_aerob)) + call accsdm(jsdm_remin_sulf ,extNsed_diagnostics(1,1,1,ised_remin_sulf)) + endif endif -#if defined(extNcycle) && ! defined(sedbypass) - call accsdm(jpownh4,powtra(1,1,1,ipownh4)) - call accsdm(jpown2o,powtra(1,1,1,ipown2o)) - call accsdm(jpowno2,powtra(1,1,1,ipowno2)) - - call accsdm(jsdm_nitr_NH4 ,extNsed_diagnostics(1,1,1,ised_nitr_NH4)) - call accsdm(jsdm_nitr_NO2 ,extNsed_diagnostics(1,1,1,ised_nitr_NO2)) - call accsdm(jsdm_nitr_N2O_prod ,extNsed_diagnostics(1,1,1,ised_nitr_N2O_prod)) - call accsdm(jsdm_nitr_NH4_OM ,extNsed_diagnostics(1,1,1,ised_nitr_NH4_OM)) - call accsdm(jsdm_nitr_NO2_OM ,extNsed_diagnostics(1,1,1,ised_nitr_NO2_OM)) - call accsdm(jsdm_denit_NO3 ,extNsed_diagnostics(1,1,1,ised_denit_NO3)) - call accsdm(jsdm_denit_NO2 ,extNsed_diagnostics(1,1,1,ised_denit_NO2)) - call accsdm(jsdm_denit_N2O ,extNsed_diagnostics(1,1,1,ised_denit_N2O)) - call accsdm(jsdm_DNRA_NO2 ,extNsed_diagnostics(1,1,1,ised_DNRA_NO2)) - call accsdm(jsdm_anmx_N2_prod ,extNsed_diagnostics(1,1,1,ised_anmx_N2_prod)) - call accsdm(jsdm_anmx_OM_prod ,extNsed_diagnostics(1,1,1,ised_anmx_OM_prod)) - call accsdm(jsdm_remin_aerob ,extNsed_diagnostics(1,1,1,ised_remin_aerob)) - call accsdm(jsdm_remin_sulf ,extNsed_diagnostics(1,1,1,ised_remin_sulf)) - -#endif ! Write output if requested do l=1,nbgc @@ -646,9 +644,9 @@ subroutine accfields(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask) ndepnoyflx=0. oalkflx=0. rivinflx=0. -#ifdef extNcycle + if (use_extNcycle) then ndepnhxflx=0. -#endif + endif end subroutine accfields diff --git a/hamocc/mo_apply_ndep.F90 b/hamocc/mo_apply_ndep.F90 index 49a18b18..655e4a1f 100644 --- a/hamocc/mo_apply_ndep.F90 +++ b/hamocc/mo_apply_ndep.F90 @@ -19,11 +19,11 @@ module mo_apply_ndep !************************************************************************************************* - ! Routine for applying the nitrogen deposition flux. + ! Routine for applying the nitrogen deposition flux. ! - ! N-deposition is activated through a logical switch 'do_ndep' read from HAMOCC's bgcnml - ! namelist. When coupled to NorESM, this is achieved by setting BLOM_N_DEPOSITION to - ! TRUE in env_run.xml. + ! N-deposition is activated through a logical switch 'do_ndep' read from HAMOCC's bgcnml + ! namelist. When coupled to NorESM, this is achieved by setting BLOM_N_DEPOSITION to + ! TRUE in env_run.xml. ! ! The routine n_deposition applies the nitrogen deposition flux to the top-most model layer. ! @@ -54,14 +54,10 @@ subroutine apply_ndep(kpie,kpje,kpke,pddpo,omask,ndep) ! Tjiputra (18.09.2017): add 1 mol [H+], per mol [NO3] deposition, to alkalinity (minus 1 mol) !*********************************************************************************************** - use mo_control_bgc, only: dtb,do_ndep - use mo_carbch, only: ocetra,ndepnoyflx - use mo_param1_bgc, only: iano3,ialkali,inatalkali,nndep,idepnoy + use mo_control_bgc, only: dtb,do_ndep,use_extNcycle + use mo_carbch, only: ocetra,ndepnoyflx,ndepnhxflx + use mo_param1_bgc, only: iano3,ialkali,inatalkali,nndep,idepnoy,ianh4,idepnhx use mo_control_bgc, only: use_natDIC -#ifdef extNcycle - use mo_carbch, only: ndepnhxflx - use mo_param1_bgc, only: ianh4,idepnhx -#endif ! Arguments integer, intent(in) :: kpie ! 1st dimension of model grid. @@ -76,9 +72,9 @@ subroutine apply_ndep(kpie,kpje,kpke,pddpo,omask,ndep) ! ndepflx stores the applied n-deposition flux for inventory calculations and output ndepnoyflx(:,:)=0.0 -#ifdef extNcycle - ndepnhxflx(:,:)=0.0 -#endif + if (use_extNcycle) then + ndepnhxflx(:,:)=0.0 + endif if (.not. do_ndep) return ! deposite N in topmost layer @@ -91,11 +87,11 @@ subroutine apply_ndep(kpie,kpje,kpke,pddpo,omask,ndep) if (use_natDIC) then ocetra(i,j,1,inatalkali)=ocetra(i,j,1,inatalkali)-ndepnoyflx(i,j)/pddpo(i,j,1) endif -#ifdef extNcycle - ndepnhxflx(i,j) = ndep(i,j,idepnhx)*dtb/365. - ocetra(i,j,1,ianh4) = ocetra(i,j,1,ianh4) + ndepnhxflx(i,j)/pddpo(i,j,1) - ocetra(i,j,1,ialkali) = ocetra(i,j,1,ialkali) + ndepnhxflx(i,j)/pddpo(i,j,1) -#endif + if (use_extNcycle) then + ndepnhxflx(i,j) = ndep(i,j,idepnhx)*dtb/365. + ocetra(i,j,1,ianh4) = ocetra(i,j,1,ianh4) + ndepnhxflx(i,j)/pddpo(i,j,1) + ocetra(i,j,1,ialkali) = ocetra(i,j,1,ialkali) + ndepnhxflx(i,j)/pddpo(i,j,1) + endif endif enddo enddo diff --git a/hamocc/mo_aufr_bgc.F90 b/hamocc/mo_aufr_bgc.F90 index c981be8d..a7d11884 100644 --- a/hamocc/mo_aufr_bgc.F90 +++ b/hamocc/mo_aufr_bgc.F90 @@ -81,7 +81,8 @@ subroutine aufr_bgc(kpie,kpje,kpke,ntr,ntrbgc,itrbgc,trc,kplyear,kplmon,kplday,o use mod_dia, only: iotype use mo_carbch, only: co2star,co3,hi,satoxy,ocetra,atm,nathi use mo_control_bgc, only: io_stdo_bgc,ldtbgc,use_cisonew,use_AGG, & - use_BOXATM,use_BROMO,use_CFC,use_natDIC,use_sedbypass + use_BOXATM,use_BROMO,use_CFC,use_natDIC,use_sedbypass, & + use_extNcycle use mo_param1_bgc, only: ialkali,ian2o,iano3,icalc,idet,idicsat, & idms,idoc,ifdust,igasnit,iiron,iopal,ioxygen,iphosph,iphy, & iprefalk,iprefdic,iprefo2,iprefpo4,iprefsilica, & @@ -92,15 +93,14 @@ subroutine aufr_bgc(kpie,kpje,kpke,ntr,ntrbgc,itrbgc,trc,kplyear,kplmon,kplday,o issso13,issso14,isssc13,isssc14,ipowc13,ipowc14, & iatmc13,iatmc14,iatmnco2,inatalkali,inatcalc,inatsco212, & ipowaal,ipowaic,ipowaox,ipowaph,ipowasi,ipown2,ipowno3, & - isssc12,issso12,issssil,issster,ks + isssc12,issso12,issssil,issster,ks,ianh4,iano2,ipownh4,ipown2o, & + ipowno2 use mo_vgrid, only: kbo use mo_sedmnt, only: sedhpl use mo_intfcblom, only: sedlay2,powtra2,burial2,atm2 use mo_param_bgc, only: bifr13_ini,bifr14_ini,c14fac,re1312,re14to,prei13,prei14 use mo_netcdf_bgcrw, only: read_netcdf_var -#ifdef extNcycle - use mo_param1_bgc, only: ianh4,iano2,ipownh4,ipown2o,ipowno2 -#endif + ! Arguments integer, intent(in) :: kpie ! 1st dimension of model grid. integer, intent(in) :: kpje ! 2nd dimension of model grid. @@ -324,7 +324,7 @@ subroutine aufr_bgc(kpie,kpje,kpke,ntr,ntrbgc,itrbgc,trc,kplyear,kplmon,kplday,o endif ! Find out whether to restart extended nitrogen cycle -#ifdef extNcycle + if (use_extNcycle) then lread_extn=.true. if(IOTYPE==0) then if(mnproc==1) ncstat=nf90_inq_varid(ncid,'anh4',ncvarid) @@ -341,7 +341,7 @@ subroutine aufr_bgc(kpie,kpje,kpke,ntr,ntrbgc,itrbgc,trc,kplyear,kplmon,kplday,o write(io_stdo_bgc,*) 'AUFR_BGC info: extended nitrogen cycle tracer not in restart file ' write(io_stdo_bgc,*) 'Initialising extended nitrogen cycle from scratch' endif -#endif + endif ! Find out whether to restart atmosphere if (use_BOXATM) then @@ -448,12 +448,12 @@ subroutine aufr_bgc(kpie,kpje,kpke,ntr,ntrbgc,itrbgc,trc,kplyear,kplmon,kplday,o if (use_BROMO .and. lread_bro) then call read_netcdf_var(ncid,'bromo',locetra(1,1,1,ibromo),2*kpke,0,iotype) endif -#ifdef extNcycle + if (use_extNcycle) then if(lread_extn) then call read_netcdf_var(ncid,'anh4',locetra(1,1,1,ianh4),2*kpke,0,iotype) call read_netcdf_var(ncid,'ano2',locetra(1,1,1,iano2),2*kpke,0,iotype) endif -#endif + endif ! ! Read restart data : diagnostic ocean fields (needed for bit to bit reproducability) @@ -494,13 +494,13 @@ subroutine aufr_bgc(kpie,kpje,kpke,ntr,ntrbgc,itrbgc,trc,kplyear,kplmon,kplday,o call read_netcdf_var(ncid,'powc13',powtra2(1,1,1,ipowc13),2*ks,0,iotype) call read_netcdf_var(ncid,'powc14',powtra2(1,1,1,ipowc14),2*ks,0,iotype) endif -#ifdef extNcycle - IF(lread_extn) THEN - CALL read_netcdf_var(ncid,'pownh4',powtra2(1,1,1,ipownh4),2*ks,0,iotype) - CALL read_netcdf_var(ncid,'pown2o',powtra2(1,1,1,ipown2o),2*ks,0,iotype) - CALL read_netcdf_var(ncid,'powno2',powtra2(1,1,1,ipowno2),2*ks,0,iotype) - ENDIF -#endif + if (use_extNcycle) then + if(lread_extn) then + call read_netcdf_var(ncid,'pownh4',powtra2(1,1,1,ipownh4),2*ks,0,iotype) + call read_netcdf_var(ncid,'pown2o',powtra2(1,1,1,ipown2o),2*ks,0,iotype) + call read_netcdf_var(ncid,'powno2',powtra2(1,1,1,ipowno2),2*ks,0,iotype) + endif + endif endif ! ! Read restart data: atmosphere diff --git a/hamocc/mo_aufw_bgc.F90 b/hamocc/mo_aufw_bgc.F90 index 20fec7cf..14bf0974 100644 --- a/hamocc/mo_aufw_bgc.F90 +++ b/hamocc/mo_aufw_bgc.F90 @@ -75,7 +75,7 @@ subroutine aufw_bgc(kpie,kpje,kpke,ntr,ntrbgc,itrbgc,trc, use mod_dia, only: iotype use mo_carbch, only: co2star,co3,hi,satoxy,nathi use mo_control_bgc, only: io_stdo_bgc,ldtbgc,rmasks,rmasko,use_cisonew,use_AGG,use_BOXATM, & - use_BROMO,use_CFC,use_natDIC,use_sedbypass + use_BROMO,use_CFC,use_natDIC,use_sedbypass,use_extNcycle use mo_sedmnt, only: sedhpl use mo_intfcblom, only: sedlay2,powtra2,burial2,atm2 use mo_param1_bgc, only: ialkali, ian2o,iano3,icalc,idet,idicsat,idms,idoc,ifdust,igasnit, & @@ -85,11 +85,9 @@ subroutine aufw_bgc(kpie,kpje,kpke,ntr,ntrbgc,itrbgc,trc, idoc14,iphy13,iphy14,isco213,isco214,izoo13,izoo14,issso13,issso14, & isssc13,isssc14,ipowc13,ipowc14,iatmnco2,iatmc13,iatmc14,inatalkali, & inatcalc,inatsco212,ipowaal,ipowaic,ipowaox,ipowaph,ipowasi,ipown2, & - ipowno3,isssc12,issso12,issssil,issster,iprefsilica + ipowno3,isssc12,issso12,issssil,issster,iprefsilica,ianh4,iano2, & + ipownh4,ipown2o,ipowno2 use mo_netcdf_bgcrw,only: write_netcdf_var,netcdf_def_vardb -#ifdef extNcycle - use mo_param1_bgc, only: ianh4,iano2,ipownh4,ipown2o,ipowno2 -#endif ! Arguments integer, intent(in) :: kpie ! 1st dimension of model grid. @@ -519,13 +517,13 @@ subroutine aufw_bgc(kpie,kpje,kpke,ntr,ntrbgc,itrbgc,trc, call NETCDF_DEF_VARDB(ncid,5,'bromo',3,ncdimst,ncvarid, & & 6,'mol/kg',9,'Bromoform',rmissing,47,io_stdo_bgc) endif -#ifdef extNcycle - call NETCDF_DEF_VARDB(ncid,4,'anh4',3,ncdimst,ncvarid, & - & 6,'mol/kg',18,'Dissolved ammonium',rmissing,54,io_stdo_bgc) + if (use_extNcycle) then + call NETCDF_DEF_VARDB(ncid,4,'anh4',3,ncdimst,ncvarid, & + & 6,'mol/kg',18,'Dissolved ammonium',rmissing,54,io_stdo_bgc) - call NETCDF_DEF_VARDB(ncid,4,'ano2',3,ncdimst,ncvarid, & - & 6,'mol/kg',17,'Dissolved nitrite',rmissing,55,io_stdo_bgc) -#endif + call NETCDF_DEF_VARDB(ncid,4,'ano2',3,ncdimst,ncvarid, & + & 6,'mol/kg',17,'Dissolved nitrite',rmissing,55,io_stdo_bgc) + endif ! ! Define variables : diagnostic ocean fields @@ -623,7 +621,7 @@ subroutine aufw_bgc(kpie,kpje,kpke,ntr,ntrbgc,itrbgc,trc, & 9,'kmol/m**3',25,'Sediment pore water DIC14',rmissing,86,io_stdo_bgc) endif -#ifdef extNcycle + if (use_extNcycle) then call NETCDF_DEF_VARDB(ncid,6,'pownh4',3,ncdimst,ncvarid, & & 9,'kmol/m**3',34,'Sediment pore water ammonium (NH4)',rmissing,79,io_stdo_bgc) @@ -632,7 +630,7 @@ subroutine aufw_bgc(kpie,kpje,kpke,ntr,ntrbgc,itrbgc,trc, call NETCDF_DEF_VARDB(ncid,6,'powno2',3,ncdimst,ncvarid, & & 9,'kmol/m**3',33,'Sediment pore water nitrite (NO2)',rmissing,79,io_stdo_bgc) -#endif + endif if((mnproc==1 .and. IOTYPE==0) .OR. IOTYPE==1) then ncdimst(1) = nclonid @@ -801,10 +799,10 @@ subroutine aufw_bgc(kpie,kpje,kpke,ntr,ntrbgc,itrbgc,trc, if (use_BROMO) then call write_netcdf_var(ncid,'bromo',locetra(1,1,1,ibromo),2*kpke,0) endif -#ifdef extNcycle + if (use_extNcycle) then call write_netcdf_var(ncid,'anh4',locetra(1,1,1,ianh4),2*kpke,0) call write_netcdf_var(ncid,'ano2',locetra(1,1,1,iano2),2*kpke,0) -#endif + endif ! ! Write restart data : diagtnostic ocean fields @@ -848,11 +846,11 @@ subroutine aufw_bgc(kpie,kpje,kpke,ntr,ntrbgc,itrbgc,trc, call write_netcdf_var(ncid,'powc13',powtra2(1,1,1,ipowc13),2*ks,0) call write_netcdf_var(ncid,'powc14',powtra2(1,1,1,ipowc14),2*ks,0) endif -#ifdef extNcycle - call write_netcdf_var(ncid,'pownh4',powtra2(1,1,1,ipownh4),2*ks,0) - call write_netcdf_var(ncid,'pown2o',powtra2(1,1,1,ipown2o),2*ks,0) - call write_netcdf_var(ncid,'powno2',powtra2(1,1,1,ipowno2),2*ks,0) -#endif + if (use_extNcycle) then + call write_netcdf_var(ncid,'pownh4',powtra2(1,1,1,ipownh4),2*ks,0) + call write_netcdf_var(ncid,'pown2o',powtra2(1,1,1,ipown2o),2*ks,0) + call write_netcdf_var(ncid,'powno2',powtra2(1,1,1,ipowno2),2*ks,0) + endif endif ! ! Write restart data: atmosphere. diff --git a/hamocc/mo_bgcmean.F90 b/hamocc/mo_bgcmean.F90 index e2969f06..8d41fea1 100644 --- a/hamocc/mo_bgcmean.F90 +++ b/hamocc/mo_bgcmean.F90 @@ -49,7 +49,7 @@ module mo_bgcmean use netcdf, only: nf90_fill_double use mo_param1_bgc, only: ks use mo_control_bgc, only: use_sedbypass,use_cisonew,use_CFC,use_natDIC,use_BROMO,use_BOXATM, & - use_AGG + use_AGG,lm4ago,use_extNcycle implicit none @@ -160,8 +160,8 @@ module mo_bgcmean & LYR_agg_ws =0 ,LYR_dynvis =0 ,LYR_agg_stick =0 , & & LYR_agg_stickf=0 ,LYR_agg_dmax =0 ,LYR_agg_avdp =0 , & & LYR_agg_avrhop=0 ,LYR_agg_avdC =0 ,LYR_agg_df =0 , & - & LYR_agg_b =0 ,LYR_agg_Vrhof =0 ,LYR_agg_Vpor =0 , & - !========== LVLs + & LYR_agg_b =0 ,LYR_agg_Vrhof =0 ,LYR_agg_Vpor =0 , & + !========== LVLs & LVL_PHYTO =0 ,LVL_GRAZER =0 ,LVL_DOC =0 , & & LVL_PHOSY =0 ,LVL_PHOSPH =0 ,LVL_OXYGEN =0 , & & LVL_IRON =0 ,LVL_ANO3 =0 ,LVL_ALKALI =0 , & @@ -880,23 +880,23 @@ subroutine alloc_mem_bgcmean(kpie,kpje,kpke) jsediffno3(n)=i_bsc_m2d*min(1,FLX_SEDIFFNO3(n)) if (FLX_SEDIFFSI(n) > 0) i_bsc_m2d=i_bsc_m2d+1 jsediffsi(n)=i_bsc_m2d*min(1,FLX_SEDIFFSI(n)) - if (FLX_BURSSO12(n) > 0) i_bsc_m2d=i_bsc_m2d+1 + if (FLX_BURSSO12(n) > 0) i_bsc_m2d=i_bsc_m2d+1 jburflxsso12(n)=i_bsc_m2d*min(1,FLX_BURSSO12(n)) - if (FLX_BURSSSC12(n) > 0) i_bsc_m2d=i_bsc_m2d+1 + if (FLX_BURSSSC12(n) > 0) i_bsc_m2d=i_bsc_m2d+1 jburflxsssc12(n)=i_bsc_m2d*min(1,FLX_BURSSSC12(n)) - if (FLX_BURSSSSIL(n) > 0) i_bsc_m2d=i_bsc_m2d+1 + if (FLX_BURSSSSIL(n) > 0) i_bsc_m2d=i_bsc_m2d+1 jburflxssssil(n)=i_bsc_m2d*min(1,FLX_BURSSSSIL(n)) - if (FLX_BURSSSTER(n) > 0) i_bsc_m2d=i_bsc_m2d+1 + if (FLX_BURSSSTER(n) > 0) i_bsc_m2d=i_bsc_m2d+1 jburflxssster(n)=i_bsc_m2d*min(1,FLX_BURSSSTER(n)) + if (use_extNcycle) then + if (FLX_SEDIFFNH4(n) > 0) i_bsc_m2d=i_bsc_m2d+1 + jsediffnh4(n)=i_bsc_m2d*min(1,FLX_SEDIFFNH4(n)) + if (FLX_SEDIFFN2O(n) > 0) i_bsc_m2d=i_bsc_m2d+1 + jsediffn2o(n)=i_bsc_m2d*min(1,FLX_SEDIFFN2O(n)) + if (FLX_SEDIFFNO2(n) > 0) i_bsc_m2d=i_bsc_m2d+1 + jsediffno2(n)=i_bsc_m2d*min(1,FLX_SEDIFFNO2(n)) + endif endif -#if defined (extNcycle) && ! defined(sedbypass) - if (FLX_SEDIFFNH4(n) > 0) i_bsc_m2d=i_bsc_m2d+1 - jsediffnh4(n)=i_bsc_m2d*min(1,FLX_SEDIFFNH4(n)) - if (FLX_SEDIFFN2O(n) > 0) i_bsc_m2d=i_bsc_m2d+1 - jsediffn2o(n)=i_bsc_m2d*min(1,FLX_SEDIFFN2O(n)) - if (FLX_SEDIFFNO2(n) > 0) i_bsc_m2d=i_bsc_m2d+1 - jsediffno2(n)=i_bsc_m2d*min(1,FLX_SEDIFFNO2(n)) -#endif if (use_cisonew) then if (SRF_CO213FXD(n) > 0) i_bsc_m2d=i_bsc_m2d+1 jco213fxd(n)=i_bsc_m2d*min(1,SRF_CO213FXD(n)) @@ -937,18 +937,18 @@ subroutine alloc_mem_bgcmean(kpie,kpje,kpke) if (INT_BROMOUV(n) > 0) i_bsc_m2d=i_bsc_m2d+1 jbromo_uv(n)=i_bsc_m2d*min(1,INT_BROMOUV(n)) endif -#ifdef extNcycle - if (SRF_ANH3FX(n) > 0) i_bsc_m2d=i_bsc_m2d+1 + if (use_extNcycle) then + if (SRF_ANH3FX(n) > 0) i_bsc_m2d=i_bsc_m2d+1 janh3fx(n)=i_bsc_m2d*min(1,SRF_ANH3FX(n)) - if (SRF_PNH3(n) > 0) i_bsc_m2d=i_bsc_m2d+1 + if (SRF_PNH3(n) > 0) i_bsc_m2d=i_bsc_m2d+1 jsrfpnh3(n)=i_bsc_m2d*min(1,SRF_PNH3(n)) if (SRF_ANH4(n) > 0) i_bsc_m2d=i_bsc_m2d+1 jsrfanh4(n)=i_bsc_m2d*min(1,SRF_ANH4(n)) if (SRF_ANO2(n) > 0) i_bsc_m2d=i_bsc_m2d+1 jsrfano2(n)=i_bsc_m2d*min(1,SRF_ANO2(n)) - if (FLX_NDEPNHX(n) > 0) i_bsc_m2d=i_bsc_m2d+1 + if (FLX_NDEPNHX(n) > 0) i_bsc_m2d=i_bsc_m2d+1 jndepnhxfx(n)=i_bsc_m2d*min(1,FLX_NDEPNHX(n)) -#endif + endif enddo domassfluxes = any( & @@ -979,12 +979,12 @@ subroutine alloc_mem_bgcmean(kpie,kpje,kpke) if (SRF_ATMBROMO(n) > 0) i_atm_m2d=i_atm_m2d+1 jatmbromo(n)=i_atm_m2d*min(1,SRF_ATMBROMO(n)) endif -#ifdef extNcycle + if (use_extNcycle) then if (SRF_ATMNH3(n) > 0) i_atm_m2d=i_atm_m2d+1 jatmnh3(n)=i_atm_m2d*min(1,SRF_ATMNH3(n)) if (SRF_ATMN2O(n) > 0) i_atm_m2d=i_atm_m2d+1 jatmn2o(n)=i_atm_m2d*min(1,SRF_ATMN2O(n)) -#endif + endif enddo i_atm_m2d=i_atm_m2d-i_bsc_m2d @@ -1109,7 +1109,7 @@ subroutine alloc_mem_bgcmean(kpie,kpje,kpke) if (LYR_BROMO(n) > 0) i_bsc_m3d=i_bsc_m3d+1 jbromo(n)=i_bsc_m3d*min(1,LYR_BROMO(n)) endif -#ifdef extNcycle + if (use_extNcycle) then if (LYR_ANH4(n) > 0) i_bsc_m3d=i_bsc_m3d+1 janh4(n)=i_bsc_m3d*min(1,LYR_ANH4(n)) if (LYR_ANO2(n) > 0) i_bsc_m3d=i_bsc_m3d+1 @@ -1144,7 +1144,8 @@ subroutine alloc_mem_bgcmean(kpie,kpje,kpke) jremin_aerob(n)=i_bsc_m3d*min(1,LYR_remin_aerob(n)) if (LYR_remin_sulf(n) > 0) i_bsc_m3d=i_bsc_m3d+1 jremin_sulf(n)=i_bsc_m3d*min(1,LYR_remin_sulf(n)) -#endif + endif + if (lm4ago) then ! M4AGO if (LYR_agg_ws(n) > 0) i_bsc_m3d=i_bsc_m3d+1 jagg_ws(n)=i_bsc_m3d*min(1,LYR_agg_ws(n)) @@ -1170,7 +1171,7 @@ subroutine alloc_mem_bgcmean(kpie,kpje,kpke) jagg_Vrhof(n)=i_bsc_m3d*min(1,LYR_agg_Vrhof(n)) if (LYR_agg_Vpor(n) > 0) i_bsc_m3d=i_bsc_m3d+1 jagg_Vpor(n)=i_bsc_m3d*min(1,LYR_agg_Vpor(n)) - + endif if (LVL_PHYTO(n) > 0) ilvl_bsc_m3d=ilvl_bsc_m3d+1 jlvlphyto(n)=ilvl_bsc_m3d*min(1,LVL_PHYTO(n)) if (LVL_GRAZER(n) > 0) ilvl_bsc_m3d=ilvl_bsc_m3d+1 @@ -1285,7 +1286,7 @@ subroutine alloc_mem_bgcmean(kpie,kpje,kpke) if (LVL_BROMO(n) > 0) ilvl_bsc_m3d=ilvl_bsc_m3d+1 jlvlbromo(n)=ilvl_bsc_m3d*min(1,LVL_BROMO(n)) endif -#ifdef extNcycle + if (use_extNcycle) then if (LVL_ANH4(n) > 0) ilvl_bsc_m3d=ilvl_bsc_m3d+1 jlvlanh4(n)=ilvl_bsc_m3d*min(1,LVL_ANH4(n)) if (LVL_ANO2(n) > 0) ilvl_bsc_m3d=ilvl_bsc_m3d+1 @@ -1320,7 +1321,8 @@ subroutine alloc_mem_bgcmean(kpie,kpje,kpke) jlvl_remin_aerob(n)=ilvl_bsc_m3d*min(1,LVL_remin_aerob(n)) if (LVL_remin_sulf(n) > 0) ilvl_bsc_m3d=ilvl_bsc_m3d+1 jlvl_remin_sulf(n)=ilvl_bsc_m3d*min(1,LVL_remin_sulf(n)) -#endif + endif + if (lm4ago) then ! M4AGO if (LVL_agg_ws(n) > 0) ilvl_bsc_m3d=ilvl_bsc_m3d+1 jlvl_agg_ws(n)=ilvl_bsc_m3d*min(1,LVL_agg_ws(n)) @@ -1346,7 +1348,7 @@ subroutine alloc_mem_bgcmean(kpie,kpje,kpke) jlvl_agg_Vrhof(n)=ilvl_bsc_m3d*min(1,LVL_agg_Vrhof(n)) if (LVL_agg_Vpor(n) > 0) ilvl_bsc_m3d=ilvl_bsc_m3d+1 jlvl_agg_Vpor(n)=ilvl_bsc_m3d*min(1,LVL_agg_Vpor(n)) - + endif if (i_bsc_m3d /= 0) checkdp(n)=1 enddo @@ -1397,43 +1399,43 @@ subroutine alloc_mem_bgcmean(kpie,kpje,kpke) if (BUR_SSSTER(n) > 0) i_bsc_bur=i_bsc_bur+1 jburssster(n)=i_bsc_bur*min(1,BUR_SSSTER(n)) enddo + if (use_extNcycle) then + do n=1,nbgc + if (SDM_POWNH4(n) > 0) i_bsc_sed=i_bsc_sed+1 + jpownh4(n)=i_bsc_sed*min(1,SDM_POWNH4(n)) + if (SDM_POWN2O(n) > 0) i_bsc_sed=i_bsc_sed+1 + jpown2o(n)=i_bsc_sed*min(1,SDM_POWN2O(n)) + if (SDM_POWNO2(n) > 0) i_bsc_sed=i_bsc_sed+1 + jpowno2(n)=i_bsc_sed*min(1,SDM_POWNO2(n)) + if (SDM_nitr_NH4(n) > 0) i_bsc_sed=i_bsc_sed+1 + jsdm_nitr_NH4(n)=i_bsc_sed*min(1,SDM_nitr_NH4(n)) + if (SDM_nitr_NO2(n) > 0) i_bsc_sed=i_bsc_sed+1 + jsdm_nitr_NO2(n)=i_bsc_sed*min(1,SDM_nitr_NO2(n)) + if (SDM_nitr_N2O_prod(n) > 0) i_bsc_sed=i_bsc_sed+1 + jsdm_nitr_N2O_prod(n)=i_bsc_sed*min(1,SDM_nitr_N2O_prod(n)) + if (SDM_nitr_NH4_OM(n) > 0) i_bsc_sed=i_bsc_sed+1 + jsdm_nitr_NH4_OM(n)=i_bsc_sed*min(1,SDM_nitr_NH4_OM(n)) + if (SDM_nitr_NO2_OM(n) > 0) i_bsc_sed=i_bsc_sed+1 + jsdm_nitr_NO2_OM(n)=i_bsc_sed*min(1,SDM_nitr_NO2_OM(n)) + if (SDM_denit_NO3(n) > 0) i_bsc_sed=i_bsc_sed+1 + jsdm_denit_NO3(n)=i_bsc_sed*min(1,SDM_denit_NO3(n)) + if (SDM_denit_NO2(n) > 0) i_bsc_sed=i_bsc_sed+1 + jsdm_denit_NO2(n)=i_bsc_sed*min(1,SDM_denit_NO2(n)) + if (SDM_denit_N2O(n) > 0) i_bsc_sed=i_bsc_sed+1 + jsdm_denit_N2O(n)=i_bsc_sed*min(1,SDM_denit_N2O(n)) + if (SDM_DNRA_NO2(n) > 0) i_bsc_sed=i_bsc_sed+1 + jsdm_DNRA_NO2(n)=i_bsc_sed*min(1,SDM_DNRA_NO2(n)) + if (SDM_anmx_N2_prod(n) > 0) i_bsc_sed=i_bsc_sed+1 + jsdm_anmx_N2_prod(n)=i_bsc_sed*min(1,SDM_anmx_N2_prod(n)) + if (SDM_anmx_OM_prod(n) > 0) i_bsc_sed=i_bsc_sed+1 + jsdm_anmx_OM_prod(n)=i_bsc_sed*min(1,SDM_anmx_OM_prod(n)) + if (SDM_remin_aerob(n) > 0) i_bsc_sed=i_bsc_sed+1 + jsdm_remin_aerob(n)=i_bsc_sed*min(1,SDM_remin_aerob(n)) + if (SDM_remin_sulf(n) > 0) i_bsc_sed=i_bsc_sed+1 + jsdm_remin_sulf(n)=i_bsc_sed*min(1,SDM_remin_sulf(n)) + enddo + endif endif -#if defined(extNcycle) && ! defined(sedbypass) - do n=1,nbgc - if (SDM_POWNH4(n) > 0) i_bsc_sed=i_bsc_sed+1 - jpownh4(n)=i_bsc_sed*min(1,SDM_POWNH4(n)) - if (SDM_POWN2O(n) > 0) i_bsc_sed=i_bsc_sed+1 - jpown2o(n)=i_bsc_sed*min(1,SDM_POWN2O(n)) - if (SDM_POWNO2(n) > 0) i_bsc_sed=i_bsc_sed+1 - jpowno2(n)=i_bsc_sed*min(1,SDM_POWNO2(n)) - if (SDM_nitr_NH4(n) > 0) i_bsc_sed=i_bsc_sed+1 - jsdm_nitr_NH4(n)=i_bsc_sed*min(1,SDM_nitr_NH4(n)) - if (SDM_nitr_NO2(n) > 0) i_bsc_sed=i_bsc_sed+1 - jsdm_nitr_NO2(n)=i_bsc_sed*min(1,SDM_nitr_NO2(n)) - if (SDM_nitr_N2O_prod(n) > 0) i_bsc_sed=i_bsc_sed+1 - jsdm_nitr_N2O_prod(n)=i_bsc_sed*min(1,SDM_nitr_N2O_prod(n)) - if (SDM_nitr_NH4_OM(n) > 0) i_bsc_sed=i_bsc_sed+1 - jsdm_nitr_NH4_OM(n)=i_bsc_sed*min(1,SDM_nitr_NH4_OM(n)) - if (SDM_nitr_NO2_OM(n) > 0) i_bsc_sed=i_bsc_sed+1 - jsdm_nitr_NO2_OM(n)=i_bsc_sed*min(1,SDM_nitr_NO2_OM(n)) - if (SDM_denit_NO3(n) > 0) i_bsc_sed=i_bsc_sed+1 - jsdm_denit_NO3(n)=i_bsc_sed*min(1,SDM_denit_NO3(n)) - if (SDM_denit_NO2(n) > 0) i_bsc_sed=i_bsc_sed+1 - jsdm_denit_NO2(n)=i_bsc_sed*min(1,SDM_denit_NO2(n)) - if (SDM_denit_N2O(n) > 0) i_bsc_sed=i_bsc_sed+1 - jsdm_denit_N2O(n)=i_bsc_sed*min(1,SDM_denit_N2O(n)) - if (SDM_DNRA_NO2(n) > 0) i_bsc_sed=i_bsc_sed+1 - jsdm_DNRA_NO2(n)=i_bsc_sed*min(1,SDM_DNRA_NO2(n)) - if (SDM_anmx_N2_prod(n) > 0) i_bsc_sed=i_bsc_sed+1 - jsdm_anmx_N2_prod(n)=i_bsc_sed*min(1,SDM_anmx_N2_prod(n)) - if (SDM_anmx_OM_prod(n) > 0) i_bsc_sed=i_bsc_sed+1 - jsdm_anmx_OM_prod(n)=i_bsc_sed*min(1,SDM_anmx_OM_prod(n)) - if (SDM_remin_aerob(n) > 0) i_bsc_sed=i_bsc_sed+1 - jsdm_remin_aerob(n)=i_bsc_sed*min(1,SDM_remin_aerob(n)) - if (SDM_remin_sulf(n) > 0) i_bsc_sed=i_bsc_sed+1 - jsdm_remin_sulf(n)=i_bsc_sed*min(1,SDM_remin_sulf(n)) - enddo -#endif nbgcm2d = i_bsc_m2d+i_atm_m2d nbgcm3d = i_bsc_m3d nbgcm3dlvl = ilvl_bsc_m3d diff --git a/hamocc/mo_biomod.F90 b/hamocc/mo_biomod.F90 index bf377b22..56bea1c0 100644 --- a/hamocc/mo_biomod.F90 +++ b/hamocc/mo_biomod.F90 @@ -108,7 +108,7 @@ subroutine alloc_mem_biomod(kpie,kpje,kpke) !****************************************************************************** use mod_xc, only: mnproc use mo_control_bgc, only: io_stdo_bgc - use mo_control_bgc, only: use_FB_BGC_OCE,use_AGG,use_BROMO + use mo_control_bgc, only: use_FB_BGC_OCE,use_AGG,use_BROMO,use_extNcycle ! Arguments integer, intent(in) :: kpie @@ -356,29 +356,29 @@ subroutine alloc_mem_biomod(kpie,kpje,kpke) int_chbr3_uv(:,:) = 0.0 endif -#ifdef extNcycle - IF (mnproc.eq.1) THEN - WRITE(io_stdo_bgc,*)'Memory allocation for variable of the extended nitrogen cycle ...' - WRITE(io_stdo_bgc,*)'First dimension : ',kpie - WRITE(io_stdo_bgc,*)'Second dimension : ',kpje - WRITE(io_stdo_bgc,*)'Third dimension : ',kpke - ENDIF - - ALLOCATE (nitr_NH4(kpie,kpje,kpke),stat=errstat) - ALLOCATE (nitr_NO2(kpie,kpje,kpke),stat=errstat) - ALLOCATE (nitr_N2O_prod(kpie,kpje,kpke),stat=errstat) - ALLOCATE (nitr_NH4_OM(kpie,kpje,kpke),stat=errstat) - ALLOCATE (nitr_NO2_OM(kpie,kpje,kpke),stat=errstat) - ALLOCATE (denit_NO3(kpie,kpje,kpke),stat=errstat) - ALLOCATE (denit_NO2(kpie,kpje,kpke),stat=errstat) - ALLOCATE (denit_N2O(kpie,kpje,kpke),stat=errstat) - ALLOCATE (DNRA_NO2(kpie,kpje,kpke),stat=errstat) - ALLOCATE (anmx_N2_prod(kpie,kpje,kpke),stat=errstat) - ALLOCATE (anmx_OM_prod(kpie,kpje,kpke),stat=errstat) - ALLOCATE (phosy_NH4(kpie,kpje,kpke),stat=errstat) - ALLOCATE (phosy_NO3(kpie,kpje,kpke),stat=errstat) - ALLOCATE (remin_aerob(kpie,kpje,kpke),stat=errstat) - ALLOCATE (remin_sulf(kpie,kpje,kpke),stat=errstat) + if (use_extNcycle) then + if (mnproc.eq.1) then + write(io_stdo_bgc,*)'Memory allocation for variable of the extended nitrogen cycle ...' + write(io_stdo_bgc,*)'First dimension : ',kpie + write(io_stdo_bgc,*)'Second dimension : ',kpje + write(io_stdo_bgc,*)'Third dimension : ',kpke + endif + + allocate (nitr_NH4(kpie,kpje,kpke),stat=errstat) + allocate (nitr_NO2(kpie,kpje,kpke),stat=errstat) + allocate (nitr_N2O_prod(kpie,kpje,kpke),stat=errstat) + allocate (nitr_NH4_OM(kpie,kpje,kpke),stat=errstat) + allocate (nitr_NO2_OM(kpie,kpje,kpke),stat=errstat) + allocate (denit_NO3(kpie,kpje,kpke),stat=errstat) + allocate (denit_NO2(kpie,kpje,kpke),stat=errstat) + allocate (denit_N2O(kpie,kpje,kpke),stat=errstat) + allocate (DNRA_NO2(kpie,kpje,kpke),stat=errstat) + allocate (anmx_N2_prod(kpie,kpje,kpke),stat=errstat) + allocate (anmx_OM_prod(kpie,kpje,kpke),stat=errstat) + allocate (phosy_NH4(kpie,kpje,kpke),stat=errstat) + allocate (phosy_NO3(kpie,kpje,kpke),stat=errstat) + allocate (remin_aerob(kpie,kpje,kpke),stat=errstat) + allocate (remin_sulf(kpie,kpje,kpke),stat=errstat) if(errstat.ne.0) stop 'not enough memory extended nitrogen cycle' nitr_NH4 = 0. @@ -396,7 +396,7 @@ subroutine alloc_mem_biomod(kpie,kpje,kpke) phosy_NO3 = 0. remin_aerob = 0. remin_sulf = 0. -#endif + endif end subroutine alloc_mem_biomod diff --git a/hamocc/mo_carbch.F90 b/hamocc/mo_carbch.F90 index 63b5ba71..a6ad8d0f 100644 --- a/hamocc/mo_carbch.F90 +++ b/hamocc/mo_carbch.F90 @@ -103,7 +103,7 @@ subroutine alloc_mem_carbch(kpie,kpje,kpke) use mod_xc, only: mnproc use mo_control_bgc, only: io_stdo_bgc use mo_param1_bgc, only: nocetra,npowtra,nsedtra,natm,nriv - use mo_control_bgc, only: use_natDIC,use_cisonew + use mo_control_bgc, only: use_natDIC,use_cisonew,use_extNcycle integer, intent(in) :: kpie integer, intent(in) :: kpje @@ -409,7 +409,7 @@ subroutine alloc_mem_carbch(kpie,kpje,kpke) co214fxu(:,:) = 0.0 endif -#ifdef extNcycle + if (use_extNcycle) then if (mnproc.eq.1) then write(io_stdo_bgc,*)'Memory allocation for variable pnh3 ...' write(io_stdo_bgc,*)'First dimension : ',kpie @@ -418,7 +418,7 @@ subroutine alloc_mem_carbch(kpie,kpje,kpke) allocate (pnh3(kpie,kpje),stat=errstat) if(errstat.ne.0) stop 'not enough memory pnh3' pnh3(:,:) = 0.0 - + ! Allocate field to hold N-deposition NHx fluxes per timestep for inventory caluclations if (mnproc.eq.1) then write(io_stdo_bgc,*)'Memory allocation for variable ndepnhxflx ...' @@ -428,7 +428,7 @@ subroutine alloc_mem_carbch(kpie,kpje,kpke) allocate (ndepnhxflx(kpie,kpje),stat=errstat) if(errstat.ne.0) stop 'not enough memory ndepnhxflx' ndepnhxflx(:,:) = 0.0 -#endif + endif end subroutine alloc_mem_carbch !************************************************************************************************* diff --git a/hamocc/mo_carchm.F90 b/hamocc/mo_carchm.F90 index 72da6871..5136e623 100644 --- a/hamocc/mo_carchm.F90 +++ b/hamocc/mo_carchm.F90 @@ -71,9 +71,11 @@ subroutine carchm(kpie,kpje,kpke,kbnd,pdlxp,pdlyp,pddpo,prho,pglat,omask,psicomo pco2m,kwco2d,co2sold,co2solm,pn2om use mo_chemcon, only: al1,al2,al3,al4,an0,an1,an2,an3,an4,an5,an6, & bl1,bl2,bl3,calcon,ox0,ox1,ox2,ox3,ox4,ox5,ox6, & - oxyco,tzero + oxyco,tzero, & + SV0_air,SV1_air,SV2_air,SV3_air,SV4_air,SD0_air,SD1_air,SD2_air, & + SD3_air,Vb_nh3,M_nh3,kappa use mo_control_bgc, only: dtbgc,use_cisonew,use_natDIC,use_CFC,use_BROMO, & - use_cisonew,use_sedbypass + use_cisonew,use_sedbypass,use_extNcycle use mo_param1_bgc, only: ialkali,iatmo2,iatmco2,iatmdms,iatmn2,iatmn2o,ian2o,icalc, & idicsat,idms,igasnit,ioxygen,iphosph, & isco212,isilica, & @@ -82,19 +84,14 @@ subroutine carchm(kpie,kpje,kpke,kbnd,pdlxp,pdlyp,pddpo,prho,pglat,omask,psicomo isco213,isco214,izoo14,safediv, & iatmnco2,inatalkali,inatcalc,inatsco212, & ks,issso14,isssc14,ipowc14, & - iatmbromo,ibromo + iatmbromo,ibromo,iatmnh3,ianh4 use mo_param_bgc, only: c14dec,atm_co2_nat,atm_n2o use mo_vgrid, only: dp_min,kmle,kbo,ptiestu use mo_carbch, only: atm_cfc11_nh,atm_cfc11_sh,atm_cfc12_nh,atm_cfc12_sh, & atm_sf6_nh,atm_sf6_sh, & co213fxd,co213fxu,co214fxd,co214fxu, & - nathi,natco3,natpco2d,natomegaa,natomegac + nathi,natco3,natpco2d,natomegaa,natomegac,pnh3 use mo_sedmnt, only: sedlay,powtra,burial -#ifdef extNcycle - use mo_carbch, only: pnh3 - use mo_param1_bgc, only: iatmnh3,ianh4 - use mo_chemcon, only: SV0_air,SV1_air,SV2_air,SV3_air,SV4_air,SD0_air,SD1_air,SD2_air,SD3_air,Vb_nh3,M_nh3,kappa -#endif ! Arguments integer, intent(in) :: kpie ! 1st dimension of model grid. @@ -140,11 +137,10 @@ subroutine carchm(kpie,kpje,kpke,kbnd,pdlxp,pdlyp,pddpo,prho,pglat,omask,psicomo real :: atco213,atco214,pco213,pco214 ! cisonew real :: frac_k,frac_aqg,frac_dicg ! cisonew real :: flx_bromo,sch_bromo,kw_bromo,a_bromo,atbrf,Kb1,lsub ! BROMO -#ifdef extNcycle + ! extNcycle real :: flx_nh3,sch_nh3_a,sch_nh3_w,kw_nh3,ka_nh3,atnh3,diff_nh3_a,diff_nh3_w,mu_air,mu_w,p_dbar,rho_air real :: h_nh3,hstar_nh3,pKa_nh3,eps_safe,Kh_nh3,cD_wind,u_star eps_safe = EPSILON(1.) -#endif ! set variables for diagnostic output to zero atmflx (:,:,:)=0. @@ -174,9 +170,9 @@ subroutine carchm(kpie,kpje,kpke,kbnd,pdlxp,pdlyp,pddpo,prho,pglat,omask,psicomo natomegaA(:,:,:)=0. natomegaC(:,:,:)=0. endif -#ifdef extNcycle + if (use_extNcycle) then pnh3 (:,:)=0. -#endif + endif !$OMP PARALLEL DO PRIVATE(t,t2,t3,t4,tk,tk100,s,rs,prb,Kh,Khd,K1,K2 & !$OMP ,Kb,K1p,K2p,K3p,Ksi,Kw,Ks1,Kf,Kspc,Kspa,tc,ta,sit,pt,ah1,ac & @@ -190,11 +186,9 @@ subroutine carchm(kpie,kpje,kpke,kbnd,pdlxp,pdlyp,pddpo,prho,pglat,omask,psicomo !$OMP ,atco213,atco214,rco213,rco214,pco213,pco214,frac_aqg & !$OMP ,frac_dicg,flux13d,flux13u,flux14d,flux14u,dissol13,dissol14 & !$OMP ,flx_bromo,sch_bromo,kw_bromo,a_bromo,atbrf,Kb1,lsub & -#ifdef extNcycle -!$OMP ,flx_nh3,sch_nh3_a,sch_nh3_w,kw_nh3,ka_nh3,atnh3 & -!$OMP ,diff_nh3_a,diff_nh3_w,mu_air,mu_w,p_dbar,rho_air,h_nh3 & -!$OMP ,hstar_nh3,pKa_nh3,eps_safe,Kh_nh3,cD_wind,u_star & -#endif + !$OMP ,flx_nh3,sch_nh3_a,sch_nh3_w,kw_nh3,ka_nh3,atnh3 & + !$OMP ,diff_nh3_a,diff_nh3_w,mu_air,mu_w,p_dbar,rho_air,h_nh3 & + !$OMP ,hstar_nh3,pKa_nh3,eps_safe,Kh_nh3,cD_wind,u_star & !$OMP ,k,j,i,rrho,scn2,scn2o,kwn2,kwn2o) do k=1,kpke do j=1,kpje @@ -285,25 +279,25 @@ subroutine carchm(kpie,kpje,kpke,kbnd,pdlxp,pdlyp,pddpo,prho,pglat,omask,psicomo ! (2003; GBC) sch_bromo = 4662.8 - 319.45*t + 9.9012*t2 - 0.1159*t3 endif -#ifdef extNcycle - ! Tsilingiris 2008 Eq.(45) for moist air (kg/m s) + if (use_extNcycle) then + ! Tsilingiris 2008 Eq.(45) for moist air (kg/m s) mu_air = SV0_air + SV1_air*t + SV2_air*t2 + SV3_air*t3 + SV4_air*t4 ! Tsinlingiris(44) moist air density (kg/m3) rho_air = SD0_air + SD1_air*t + SD2_air*t2 + SD3_air*t3 - ! molecular viscosity of sea water + ! molecular viscosity of sea water ! (Matthaeus 1972, Richards 1998,assuming salinity s in per mille = ~PSU) p_dbar = ppao(i,j)*1e-4 ! sea level pressure (Pa *1e-5 -> bar *10-> dbar - mu_w = 1.79e-2 - 6.1299e-4 * t + 1.4467e-5 * t2 - 1.6826e-7 * t3 & + mu_w = 1.79e-2 - 6.1299e-4 * t + 1.4467e-5 * t2 - 1.6826e-7 * t3 & & - 1.8266e-7 * p_dbar + 9.8972e-12 * p_dbar*p_dbar + 2.4727e-5 * s & & + s * (4.8429e-7 * t - 4.7172e-8 * t2 + 7.5986e-10 * t3) & & + s * (1.3817e-8 * t - 2.6363e-10 * t2) & & - p_dbar*p_dbar * (6.3255e-13 * t - 1.2116e-14 * t2) - mu_w = mu_w * 0.1 ! conversion from g/(cm s) to kg/(m s) + mu_w = mu_w * 0.1 ! conversion from g/(cm s) to kg/(m s) ! diffusion coeff in air (m2/s) Fuller 1966 / Johnson 2010 - ! division by pressure: ppao [Pa]; in Fuller, p is a factor for denominator [atm] + ! division by pressure: ppao [Pa]; in Fuller, p is a factor for denominator [atm] diff_nh3_a = 1e-7 * (t+273.15)**1.75 * M_nh3 / (ppao(i,j)/101325.0) ! Johnson 2010 - (34) cm2/s -> m2/s (1e-8*1e-4=1e-12) @@ -315,7 +309,7 @@ subroutine carchm(kpie,kpje,kpke,kbnd,pdlxp,pdlyp,pddpo,prho,pglat,omask,psicomo sch_nh3_a = mu_air /(diff_nh3_a * rho_air) ! Schmidt number water phase sch_nh3_w = mu_w /(diff_nh3_w * rrho * 1000.) -#endif + endif ! solubility of N2 (Weiss, R.F. 1970, Deep-Sea Res., 17, 721-735) for moist air ! at 1 atm; multiplication with oxyco converts to kmol/m^3/atm ani=an0+an1/tk100+an2*alog(tk100)+an3*tk100+s*(an4+an5*tk100+an6*tk100**2) @@ -347,14 +341,14 @@ subroutine carchm(kpie,kpje,kpke,kbnd,pdlxp,pdlyp,pddpo,prho,pglat,omask,psicomo !Henry's law constant [dimensionless] for Bromoform from Quack and Wallace (2003; GBC) a_bromo = exp(13.16 - 4973*(1/tk)) endif -#ifdef extNcycle + if (use_extNcycle) then !Henry number for NH3 (Paulot et al. 2015, ) h_nh3 = (17.93*(t+273.15)/273.15 * exp(4092./(t+273.15) - 9.7))**(-1) ! Dissociation constant (Paulot et al. 2015, Bell 2007/2008) pKa_nh3 = 10.0423 - 3.15536e-2*t + 3.071e-3*s ! effective gas-over-liquid Henry constant (Paulot et al. 2015) hstar_nh3 = h_nh3/(1. + 10.**(log10(hi(i,j,k))+pKa_nh3)) -#endif + endif ! Transfer (piston) velocity kw according to Wanninkhof (2014), in units of ms-1 Xconvxa = 6.97e-07 ! Wanninkhof's a=0.251 converted from [cm hr-1]/[m s-1]^2 to [ms-1]/[m s-1]^2 kwco2 = (1.-psicomo(i,j)) * Xconvxa * pfu10(i,j)**2*(660./scco2)**0.5 @@ -373,10 +367,10 @@ subroutine carchm(kpie,kpje,kpke,kbnd,pdlxp,pdlyp,pddpo,prho,pglat,omask,psicomo kw_bromo=(1.-psicomo(i,j)) * 1.e-2/3600. * & & (0.222*pfu10(i,j)**2+0.33*pfu10(i,j))*(660./sch_bromo)**0.5 endif -#ifdef extNcycle + if (use_extNcycle) then ! Paulot et al. 2015 / Johnson 2010 ! friction velocity of wind (m/s) - u_star = pfu10(i,j)*sqrt(6.1e-4 + 6.3e-5*pfu10(i,j)) + u_star = pfu10(i,j)*sqrt(6.1e-4 + 6.3e-5*pfu10(i,j)) ! wind drag coeff (-) cD_wind = (u_star / (pfu10(i,j) + eps_safe))**2. ! gas transfer velocity on gas phase side (m/s) @@ -387,8 +381,8 @@ subroutine carchm(kpie,kpje,kpke,kbnd,pdlxp,pdlyp,pddpo,prho,pglat,omask,psicomo ! total effective gas transfer velocity (m/s) Kh_nh3 = (1./(ka_nh3 + eps_safe) + hstar_nh3/(kw_nh3 + eps_safe))**(-1.) ! account for ice - Kh_nh3 = (1.-psicomo(i,j)) * Kh_nh3 -#endif + Kh_nh3 = (1.-psicomo(i,j)) * Kh_nh3 + endif atco2 = atm(i,j,iatmco2) ato2 = atm(i,j,iatmo2) @@ -400,12 +394,12 @@ subroutine carchm(kpie,kpje,kpke,kbnd,pdlxp,pdlyp,pddpo,prho,pglat,omask,psicomo if (use_BROMO) then atbrf = atm(i,j,iatmbromo) endif -#ifdef extNcycle + if (use_extNcycle) then atnh3 = atm(i,j,iatmnh3) atn2ov = atm(i,j,iatmn2o) -#else + else atn2ov = atm_n2o -#endif + endif ! Ratio P/P_0, where P is the local SLP and P_0 is standard pressure (1 atm). This is ! used in all surface flux calculations where atmospheric concentration is given as a @@ -521,14 +515,14 @@ subroutine carchm(kpie,kpje,kpke,kbnd,pdlxp,pdlyp,pddpo,prho,pglat,omask,psicomo ocetra(i,j,1,ibromo) = ocetra(i,j,1,ibromo) + flx_bromo/pddpo(i,j,1) atmflx(i,j,iatmbromo) = -flx_bromo endif -#ifdef extNcycle - ! surface flux NH3: STILL REQUIRES TO CHECK CONVERSION FACTOR FOR atNH3 (currently assumed atNH3 in pptv) - flx_nh3 = Kh_nh3*dtbgc*(atnh3*1e-12*ppao(i,j)*1e-5/(tk*0.08314510) - hstar_nh3*ocetra(i,j,1,ianh4)) + if (use_extNcycle) then + ! surface flux NH3: STILL REQUIRES TO CHECK CONVERSION FACTOR FOR atNH3 (currently assumed atNH3 in pptv) + flx_nh3 = Kh_nh3*dtbgc*(atnh3*1e-12*ppao(i,j)*1e-5/(tk*0.08314510) - hstar_nh3*ocetra(i,j,1,ianh4)) ocetra(i,j,1,ianh4) = ocetra(i,j,1,ianh4) + flx_nh3/pddpo(i,j,1) - - ! pNH3 in natm - pnh3(i,j) = hstar_nh3*ocetra(i,j,1,ianh4) * 8.20573660809596e-5 * (t+273.15) * 1e12 -#endif + + ! pNH3 in natm + pnh3(i,j) = hstar_nh3*ocetra(i,j,1,ianh4) * 8.20573660809596e-5 * (t+273.15) * 1e12 + endif ! Save surface fluxes atmflx(i,j,iatmco2)=fluxu-fluxd @@ -547,9 +541,9 @@ subroutine carchm(kpie,kpje,kpke,kbnd,pdlxp,pdlyp,pddpo,prho,pglat,omask,psicomo if (use_natDIC) then atmflx(i,j,iatmnco2)=natfluxu-natfluxd endif -#ifdef extNcycle - atmflx(i,j,iatmnh3)=-flx_nh3 ! positive to atmosphere [kmol NH3 m-2 timestep-1] -#endif + if (use_extNcycle) then + atmflx(i,j,iatmnh3)=-flx_nh3 ! positive to atmosphere [kmol NH3 m-2 timestep-1] + endif ! Save up- and downward components of carbon fluxes for output co2fxd(i,j) = fluxd co2fxu(i,j) = fluxu diff --git a/hamocc/mo_chemcon.F90 b/hamocc/mo_chemcon.F90 index afe282fd..1ef3e168 100644 --- a/hamocc/mo_chemcon.F90 +++ b/hamocc/mo_chemcon.F90 @@ -137,33 +137,34 @@ module mo_chemcon real, parameter :: bl2= 0.031619 real, parameter :: bl3= -0.0048472 -#ifdef extNcycle - ! Tsilingiris 2008 - ! moist air dynamic viscosity parameters - real, parameter :: SV0_air = 1.715747771e-5 - real, parameter :: SV1_air = 4.722402075e-8 - real, parameter :: SV2_air = -3.663027156e-10 - real, parameter :: SV3_air = 1.873236686e-12 - real, parameter :: SV4_air = -8.050218737e-14 - - ! moist air density parameters - real, parameter :: SD0_air = 1.293393662 - real, parameter :: SD1_air = -5.538444326e-3 - real, parameter :: SD2_air = 3.860201577e-5 - real, parameter :: SD3_air = -5.2536065e-7 - - ! diffusion of NH3 in water and air - real, parameter :: Va_air = 20.1 ! Johnson 2010 - real, parameter :: Ma_air = 28.97 ! Johnson 2010 - real, parameter :: Mb_nh3 = 17.03 ! Johnson 2010, Tang 2014 - real, parameter :: Vb_nh3 = 20.7 ! Johnson 2010 - real, parameter :: M_nh3 = (1./Ma_air + 1./Mb_nh3)**0.5 / (Va_air**(1./3.)+Vb_nh3**(1./3.))**2. - real, parameter :: kappa = 0.4 ! von Karman constant - - real, parameter :: mw_nitrogen = 14.00674 ! [g/mol N] nitrogen mol-weight as defined by CAM - real, parameter :: mw_nh3 = 17.028940 ! [g/mol NH3] ammonia mol-weight as defined by CAM - real, parameter :: mw_n2o = 44.012880 ! [g/mol N2O] nitrous oxide mol-weight as defined by CAM -#endif + ! ----------------------------------------------------------------- + ! NH3/NH4 + ! Tsilingiris 2008 + ! moist air dynamic viscosity parameters + real, parameter :: SV0_air = 1.715747771e-5 + real, parameter :: SV1_air = 4.722402075e-8 + real, parameter :: SV2_air = -3.663027156e-10 + real, parameter :: SV3_air = 1.873236686e-12 + real, parameter :: SV4_air = -8.050218737e-14 + + ! moist air density parameters + real, parameter :: SD0_air = 1.293393662 + real, parameter :: SD1_air = -5.538444326e-3 + real, parameter :: SD2_air = 3.860201577e-5 + real, parameter :: SD3_air = -5.2536065e-7 + + ! diffusion of NH3 in water and air + real, parameter :: Va_air = 20.1 ! Johnson 2010 + real, parameter :: Ma_air = 28.97 ! Johnson 2010 + real, parameter :: Mb_nh3 = 17.03 ! Johnson 2010, Tang 2014 + real, parameter :: Vb_nh3 = 20.7 ! Johnson 2010 + real, parameter :: M_nh3 = (1./Ma_air + 1./Mb_nh3)**0.5 / (Va_air**(1./3.)+Vb_nh3**(1./3.))**2. + real, parameter :: kappa = 0.4 ! von Karman constant + + real, parameter :: mw_nitrogen = 14.00674 ! [g/mol N] nitrogen mol-weight as defined by CAM + real, parameter :: mw_nh3 = 17.028940 ! [g/mol NH3] ammonia mol-weight as defined by CAM + real, parameter :: mw_n2o = 44.012880 ! [g/mol N2O] nitrous oxide mol-weight as defined by CAM + ! ----------------------------------------------------------------- ! Constants needed for pressure correction of equilibrium constants diff --git a/hamocc/mo_cyano.F90 b/hamocc/mo_cyano.F90 index 705abfc4..4682ed61 100644 --- a/hamocc/mo_cyano.F90 +++ b/hamocc/mo_cyano.F90 @@ -47,12 +47,9 @@ subroutine cyano(kpie,kpje,kpke,kbnd,pddpo,omask,ptho) use mo_vgrid, only: kmle,kwrbioz use mo_carbch, only: ocetra use mo_param_bgc, only: bluefix,rnit,tf0,tf1,tf2,tff - use mo_param1_bgc, only: ialkali,iano3,igasnit,iphosph,ioxygen,inatalkali + use mo_param1_bgc, only: ialkali,iano3,igasnit,iphosph,ioxygen,inatalkali,ianh4 use mo_biomod, only: intnfix - use mo_control_bgc, only: use_natDIC,leuphotic_cya -#ifdef extNcycle - use mo_param1_bgc, only: ianh4 -#endif + use mo_control_bgc, only: use_natDIC,leuphotic_cya,use_extNcycle ! Arguments integer, intent(in) :: kpie ! 1st dimension of model grid. @@ -80,12 +77,12 @@ subroutine cyano(kpie,kpje,kpke,kbnd,pddpo,omask,ptho) if (omask(i,j).gt.0.5) then do k=1,merge(kwrbioz(i,j),kmle(i,j),leuphotic_cya) ! if leuphotic_cya=.true., do bluefix only in euphotic zone if (ocetra(i,j,k,iano3) < (rnit*ocetra(i,j,k,iphosph))) then -#ifdef extNcycle - ! assuming nitrate and ammonium required for cyanobacteria growth (as bulk PP) - anavail = ocetra(i,j,k,iano3)+ocetra(i,j,k,ianh4) -#else - anavail = ocetra(i,j,k,iano3) -#endif + if (use_extNcycle) then + ! assuming nitrate and ammonium required for cyanobacteria growth (as bulk PP) + anavail = ocetra(i,j,k,iano3)+ocetra(i,j,k,ianh4) + else + anavail = ocetra(i,j,k,iano3) + endif if(anavail < (rnit*ocetra(i,j,k,iphosph))) then ttemp = min(40.,max(-3.,ptho(i,j,k))) @@ -93,7 +90,7 @@ subroutine cyano(kpie,kpje,kpke,kbnd,pddpo,omask,ptho) ! Temperature dependence of nitrogen fixation, Kriest and Oschlies 2015. nfixtfac = MAX(0.0,tf2*ttemp*ttemp + tf1*ttemp + tf0)/tff -#ifndef extNcycle + if (.not. use_extNcycle) then oldocetra = ocetra(i,j,k,iano3) ocetra(i,j,k,iano3)=ocetra(i,j,k,iano3)*(1.-bluefix*nfixtfac) & & +bluefix*nfixtfac*rnit*ocetra(i,j,k,iphosph) @@ -103,23 +100,23 @@ subroutine cyano(kpie,kpje,kpke,kbnd,pddpo,omask,ptho) dox = -dansp*1.25 ! Nitrogen fixation followed by remineralisation and nitrification decreases ! alkalinity by 1 mole per mole nitrogen fixed (Wolf-Gladrow et al. 2007) - dalk = -dansp -#else + dalk = -dansp + else oldocetra = ocetra(i,j,k,ianh4) ocetra(i,j,k,ianh4)=ocetra(i,j,k,ianh4)*(1.-bluefix*nfixtfac) & & +bluefix*nfixtfac*rnit*ocetra(i,j,k,iphosph) dansp=ocetra(i,j,k,ianh4)-oldocetra dox = dansp*0.75 - dalk = dansp -#endif + dalk = dansp + endif ocetra(i,j,k,igasnit)=ocetra(i,j,k,igasnit)-dansp*(1./2.) ocetra(i,j,k,ioxygen)=ocetra(i,j,k,ioxygen)+dox ocetra(i,j,k,ialkali)=ocetra(i,j,k,ialkali)+dalk -#ifdef natDIC + if (use_natDIC) then ocetra(i,j,k,inatalkali)=ocetra(i,j,k,inatalkali)+dalk -#endif + endif intnfix(i,j) = intnfix(i,j) + dansp*pddpo(i,j,k) endif diff --git a/hamocc/mo_hamocc4bcm.F90 b/hamocc/mo_hamocc4bcm.F90 index 2e3cbe7b..5e2a720f 100644 --- a/hamocc/mo_hamocc4bcm.F90 +++ b/hamocc/mo_hamocc4bcm.F90 @@ -55,8 +55,9 @@ subroutine hamocc4bcm(kpie,kpje,kpke,kbnd,kplyear,kplmon,kplday,kldtday,pdlxp,pd do_sedspinup,sedspin_yr_s,sedspin_yr_e,sedspin_ncyc, & use_BROMO, use_CFC, use_PBGC_CK_TIMESTEP, & use_BOXATM, use_sedbypass,ocn_co2_type, & - do_ndep_coupled,do_n2onh3_coupled - use mo_param1_bgc, only: iatmco2,iatmdms,nocetra,nriv,iatmbromo,nndep,idepnoy + do_ndep_coupled,do_n2onh3_coupled,use_extNcycle + use mo_param1_bgc, only: iatmco2,iatmdms,nocetra,nriv,iatmbromo,nndep,idepnoy,iatmn2o, & + iatmnh3,idepnhx use mo_vgrid, only: set_vgrid use mo_apply_fedep, only: apply_fedep use mo_apply_rivin, only: apply_rivin @@ -71,10 +72,7 @@ subroutine hamocc4bcm(kpie,kpje,kpke,kbnd,kplyear,kplmon,kplday,kldtday,pdlxp,pd use mo_cyano, only: cyano use mo_ocprod, only: ocprod use mo_carchm, only: carchm -#ifdef extNcycle - use mo_param1_bgc, only: iatmn2o,iatmnh3,idepnhx - use mo_chemcon, only: mw_nitrogen,mw_nh3,mw_n2o -#endif + use mo_chemcon, only: mw_nitrogen,mw_nh3,mw_n2o ! Arguments integer, intent(in) :: kpie ! 1st dimension of model grid. @@ -177,9 +175,9 @@ subroutine hamocc4bcm(kpie,kpje,kpke,kbnd,kplyear,kplmon,kplday,kldtday,pdlxp,pd if (mnproc.eq.1) write (io_stdo_bgc,*) 'iHAMOCC: getting bromoform from atm' endif -#ifdef extNcycle -!$OMP PARALLEL DO PRIVATE(i) - if(do_n2onh3_coupled) then + if (use_extNcycle) then + if (do_n2onh3_coupled) then + !$OMP PARALLEL DO PRIVATE(i) do j=1,kpje do i=1,kpie if (patmn2o(i,j) > 0.) then @@ -190,14 +188,14 @@ subroutine hamocc4bcm(kpie,kpje,kpke,kbnd,kplyear,kplmon,kplday,kldtday,pdlxp,pd endif enddo enddo -!$OMP END PARALLEL DO + !$OMP END PARALLEL DO if (mnproc.eq.1) write (io_stdo_bgc,*) 'iHAMOCC: getting N2O and NH3 conc. from atm' - ENDIF + endif - if(do_ndep_coupled) then + if (do_ndep_coupled) then fatmndep = 365.*86400./mw_nitrogen ndep(:,:,:) = 0. -!$OMP PARALLEL DO PRIVATE(i) + !$OMP PARALLEL DO PRIVATE(i) do j=1,kpje do i=1,kpie ! convert from kgN/m2/s to climatological input file units: kmolN/m2/yr @@ -209,10 +207,10 @@ subroutine hamocc4bcm(kpie,kpje,kpke,kbnd,kplyear,kplmon,kplday,kldtday,pdlxp,pd endif enddo enddo -!$OMP END PARALLEL DO - if (mnproc.eq.1) write (io_stdo_bgc,*) 'iHAMOCC: getting NOy and NHx deposition from atm' + !$OMP END PARALLEL DO + if (mnproc.eq.1) write (io_stdo_bgc,*) 'iHAMOCC: getting NOy and NHx deposition from atm' endif -#endif + endif !-------------------------------------------------------------------- ! Read atmospheric cfc concentrations @@ -441,7 +439,7 @@ subroutine hamocc4bcm(kpie,kpje,kpke,kbnd,kplyear,kplmon,kplday,kldtday,pdlxp,pd !$OMP PARALLEL DO PRIVATE(i) do j=1,kpje do i=1,kpie -#ifdef extNcycle + if (use_extNcycle) then if (do_n2onh3_coupled) then if(omask(i,j) > 0.5) pflxn2o(i,j)=-mw_n2o*atmflx(i,j,iatmn2o)/dtbgc ! conversion factor checked against CAM if(omask(i,j) > 0.5) pflxnh3(i,j)=-mw_nh3*atmflx(i,j,iatmnh3)/dtbgc ! conversion factor checked against CAM @@ -449,10 +447,10 @@ subroutine hamocc4bcm(kpie,kpje,kpke,kbnd,kplyear,kplmon,kplday,kldtday,pdlxp,pd if(omask(i,j) > 0.5) pflxn2o(i,j)=0.0 if(omask(i,j) > 0.5) pflxnh3(i,j)=0.0 endif -#else + else if(omask(i,j) > 0.5) pflxn2o(i,j)=0.0 if(omask(i,j) > 0.5) pflxnh3(i,j)=0.0 -#endif + endif enddo enddo !$OMP END PARALLEL DO diff --git a/hamocc/mo_hamocc_init.F90 b/hamocc/mo_hamocc_init.F90 index 19faf4c5..b23ae8c1 100644 --- a/hamocc/mo_hamocc_init.F90 +++ b/hamocc/mo_hamocc_init.F90 @@ -44,7 +44,7 @@ subroutine hamocc_init(read_rest,rstfnm_hamocc) dtb,dtbgc,io_stdo_bgc,ldtbgc, & ldtrunbgc,ndtdaybgc,with_dmsph,l_3Dvarsedpor,lm4ago, & do_ndep_coupled,leuphotic_cya,do_n2onh3_coupled, & - ocn_co2_type, use_sedbypass, use_BOXATM, use_BROMO + ocn_co2_type, use_sedbypass, use_BOXATM, use_BROMO,use_extNcycle use mo_param1_bgc, only: ks,init_por2octra_mapping use mo_param_bgc, only: ini_parambgc use mo_carbch, only: alloc_mem_carbch,ocetra,atm,atm_co2 @@ -65,9 +65,8 @@ subroutine hamocc_init(read_rest,rstfnm_hamocc) use mo_ini_fields, only: ini_fields_ocean,ini_fields_atm use mo_aufr_bgc, only: aufr_bgc use mo_m4ago, only: alloc_mem_m4ago -#ifdef extNcycle - use mo_extNsediment,only: alloc_mem_extNsediment_diag -#endif + use mo_extNsediment,only: alloc_mem_extNsediment_diag + ! Arguments integer, intent(in) :: read_rest ! flag indicating whether to read restart files. @@ -81,8 +80,8 @@ subroutine hamocc_init(read_rest,rstfnm_hamocc) namelist /bgcnml/ atm_co2,fedepfile,do_rivinpt,rivinfile,do_ndep,ndepfile,do_oalk, & & do_sedspinup,sedspin_yr_s,sedspin_yr_e,sedspin_ncyc, & & inidic,inialk,inipo4,inioxy,inino3,inisil,inid13c,inid14c,swaclimfile, & - & with_dmsph,pi_ph_file,l_3Dvarsedpor,sedporfile,ocn_co2_type,lm4ago,leuphotic_cya, & - & do_ndep_coupled,do_n2onh3_coupled + & with_dmsph,pi_ph_file,l_3Dvarsedpor,sedporfile,ocn_co2_type,lm4ago, & + & leuphotic_cya, do_ndep_coupled,do_n2onh3_coupled ! ! --- Set io units and some control parameters ! @@ -141,9 +140,9 @@ subroutine hamocc_init(read_rest,rstfnm_hamocc) call alloc_mem_sedmnt(idm,jdm) call alloc_mem_carbch(idm,jdm,kdm) call alloc_mem_M4AGO(idm,jdm,kdm) -#if defined(extNcycle) && ! defined(sedbypass) + if (use_extNcycle .and. .not. use_sedbypass) then call alloc_mem_extNsediment_diag(idm,jdm,ks) -#endif + endif ! ! --- initialise trc array (two time levels) ! diff --git a/hamocc/mo_ini_fields.F90 b/hamocc/mo_ini_fields.F90 index 823c7c6f..6c73e808 100644 --- a/hamocc/mo_ini_fields.F90 +++ b/hamocc/mo_ini_fields.F90 @@ -39,7 +39,7 @@ subroutine ini_fields_atm(kpie,kpje) !*********************************************************************************************** use mo_control_bgc, only: use_natDIC,use_cisonew,use_BROMO,use_extNcycle - use mo_param1_bgc, only: iatmco2,iatmo2,iatmn2,iatmnco2,iatmc13,iatmc14,iatmbromo + use mo_param1_bgc, only: iatmco2,iatmo2,iatmn2,iatmn2o,iatmnh3,iatmnco2,iatmc13,iatmc14,iatmbromo use mo_param_bgc, only: atm_o2,atm_n2,atm_co2_nat,atm_c13,atm_c14,c14fac,atm_bromo,atm_n2o,atm_nh3 use mo_carbch, only: atm,atm_co2 @@ -69,10 +69,10 @@ subroutine ini_fields_atm(kpie,kpje) if (use_BROMO) then atm(i,j,iatmbromo)= atm_bromo endif -#ifdef extNcycle + if (use_extNcycle) then atm(i,j,iatmnh3) = atm_nh3 atm(i,j,iatmn2o) = atm_n2o -#endif + endif enddo enddo end subroutine ini_fields_atm @@ -94,7 +94,7 @@ subroutine ini_fields_ocean(kpaufr,kpie,kpje,kpke,kbnd,pddpo,prho,omask,pglon,pg use mo_param_bgc, only: fesoly,cellmass,fractdim,bifr13_ini,bifr14_ini,c14fac,re1312,re14to use mo_biomod, only: abs_oce use mo_control_bgc, only: rmasks,use_FB_BGC_OCE,use_cisonew,use_AGG,use_CFC,use_natDIC, & - use_BROMO, use_sedbypass + use_BROMO, use_sedbypass,use_extNcycle use mo_param1_bgc, only: ialkali,ian2o,iano3,icalc,idet,idicsat,idms,idoc,ifdust,igasnit, & iiron,iopal,ioxygen,iphosph,iphy,iprefalk,iprefdic,iprefo2,iprefpo4, & isco212,isilica,izoo,iadust,inos,ibromo,icfc11,icfc12,isf6, & @@ -102,14 +102,12 @@ subroutine ini_fields_ocean(kpaufr,kpie,kpje,kpke,kbnd,pddpo,prho,omask,pglon,pg isco213,isco214,izoo13,izoo14,safediv,inatcalc, & ipowaal,ipowaic,ipowaox,ipowaph,ipowasi,ipown2,ipowno3,isssc12, & issso12,issssil,issster,ks,nsedtra,ipowc13,ipowc13,issso13,issso13, & - isssc13,ipowc14,isssc14,issso14,iprefsilica + isssc13,ipowc14,isssc14,issso14,iprefsilica,iano2,ianh4 use mo_vgrid, only: kmle,kbo use mo_carbch, only: nathi,natco3 use mo_sedmnt, only: sedhpl,burial,powtra,sedlay use mo_profile_gd, only: profile_gd -#ifdef extNcycle - use mo_param1_bgc, only: iano2,ianh4 -#endif + ! Arguments integer, intent(in) :: kpaufr ! 1/0 flag, 1 indicating a restart run integer, intent(in) :: kpie ! 1st dimension of model grid. @@ -235,11 +233,11 @@ subroutine ini_fields_ocean(kpaufr,kpie,kpje,kpke,kbnd,pddpo,prho,omask,pglon,pg ! Initialise to 0,01 pmol L-1 (Stemmler et al., 2015) => mol/kg ocetra(i,j,k,ibromo)= 1.e-14/prho(i,j,k) endif -#ifdef extNcycle - ocetra(i,j,k,iano2) =1.e-9 ! expecting fast cycling - ocetra(i,j,k,ianh4) =0.5e-9 ! expecting fast cycling - ocetra(i,j,k,ian2o) =6.e-9 ! 6 to 8 nmol/kg = ca. value in near surface regions Toyoda et al. 2019, prevent from too long outgassing -#endif + if (use_extNcycle) then + ocetra(i,j,k,iano2) =1.e-9 ! expecting fast cycling + ocetra(i,j,k,ianh4) =0.5e-9 ! expecting fast cycling + ocetra(i,j,k,ian2o) =6.e-9 ! 6 to 8 nmol/kg = ca. value in near surface regions Toyoda et al. 2019, prevent from too long outgassing + endif endif ! omask > 0.5 enddo enddo diff --git a/hamocc/mo_inventory_bgc.F90 b/hamocc/mo_inventory_bgc.F90 index baefe44b..b9c0913f 100644 --- a/hamocc/mo_inventory_bgc.F90 +++ b/hamocc/mo_inventory_bgc.F90 @@ -38,30 +38,26 @@ subroutine inventory_bgc(kpie,kpje,kpke,dlxp,dlyp,ddpo,omask,iogrp) !*********************************************************************************************** use mod_xc, only: mnproc,ips,nbdy,xcsum - use mo_carbch, only: atm,atmflx,co3,hi,ndepnoyflx,rivinflx,ocetra,sedfluxo + use mo_carbch, only: atm,atmflx,co3,hi,ndepnoyflx,rivinflx,ocetra,sedfluxo,ndepnhxflx use mo_sedmnt, only: prcaca,prorca,silpro use mo_biomod, only: expoor,expoca,exposi use mo_param_bgc, only: rcar,rnit use mo_control_bgc, only: do_ndep,do_rivinpt,io_stdo_bgc use mo_bgcmean, only: bgct2d,jco2flux,jirdin,jn2flux,jn2oflux,jndepnoy,jndepnhx, & - jo2flux,jprcaca, & + jo2flux,jprcaca,jnh3flux, & jprorca,jsilpro,nbgcmax,glb_inventory use mo_param1_bgc, only: ialkali,ian2o,iano3,iatmco2,iatmn2,iatmn2o,iatmo2,icalc,idet,idoc, & igasnit,iopal,ioxygen,iphosph,iphy,ipowaic,ipowaox,ipowaph,ipowasi, & ipown2,ipowno3,isco212,isilica,isssc12,issso12,issssil,izoo, & - irdin,irdip,irsi,iralk,irdoc,irdet,nocetra,npowtra,nsedtra,nriv + irdin,irdip,irsi,iralk,irdoc,irdet,nocetra,npowtra,nsedtra,nriv, & + ianh4,iano2,iatmnh3,ipownh4,ipown2o,ipowno2 use mo_vgrid, only: dp_min ! NOT sedbypass use mo_param1_bgc, only: ks use mo_sedmnt, only: porwat,seddw,sedlay,burial,sedhpl,powtra,porsol use mo_control_bgc, only: use_PBGC_CK_TIMESTEP,use_BOXATM,use_sedbypass,use_cisonew,use_AGG, & - use_CFC,use_natDIC,use_BROMO -#ifdef extNcycle - use mo_carbch, only: ndepnhxflx - use mo_param1_bgc, only: ianh4,iano2,iatmnh3,ipownh4,ipown2o,ipowno2 - use mo_bgcmean, only: jnh3flux -#endif + use_CFC,use_natDIC,use_BROMO,use_extNcycle ! Arguments integer, intent(in) :: kpie,kpje,kpke @@ -300,16 +296,16 @@ subroutine inventory_bgc(kpie,kpje,kpke,dlxp,dlyp,ddpo,omask,iogrp) so2flux = sum2d(atmflx(:,:,iatmo2)) sn2flux = sum2d(atmflx(:,:,iatmn2)) sn2oflux = sum2d(atmflx(:,:,iatmn2o)) -#ifdef extNcycle - snh3flux = sum2d(atmflx(:,:,iatmnh3)) -#endif + if (use_extNcycle) then + snh3flux = sum2d(atmflx(:,:,iatmnh3)) + endif ! nitrogen deposition if(do_ndep) then sndepnoyflux = sum2d(ndepnoyflx) -#ifdef extNcycle + if (use_extNcycle) then sndepnhxflux = sum2d(ndepnhxflx) -#endif + endif endif ! river fluxes @@ -322,16 +318,16 @@ subroutine inventory_bgc(kpie,kpje,kpke,dlxp,dlyp,ddpo,omask,iogrp) so2flux = sum2d(bgct2d(:,:,jo2flux)) sn2flux = sum2d(bgct2d(:,:,jn2flux)) sn2oflux = sum2d(bgct2d(:,:,jn2oflux)) -#ifdef extNcycle + if (use_extNcycle) then snh3flux = sum2d(bgct2d(:,:,jnh3flux)) -#endif + endif ! nitrogen deposition fluxes if(do_ndep) then sndepnoyflux = sum2d(bgct2d(:,:,jndepnoy)) -#ifdef extNcycle + if (use_extNcycle) then sndepnhxflux = sum2d(bgct2d(:,:,jndepnhx)) -#endif + endif endif ! River fluxes @@ -387,11 +383,11 @@ subroutine inventory_bgc(kpie,kpje,kpke,dlxp,dlyp,ddpo,omask,iogrp) else totalnitr = totalnitr + sn2flux*2+sn2oflux*2 endif -#ifdef extNcycle + if (use_extNcycle) then totalnitr = totalnitr + zocetratot(ianh4)+zocetratot(iano2)+snh3flux& & - sndepnhxflux & - & +zpowtratot(ipownh4)+zpowtratot(ipown2o)*2+zpowtratot(ipowno2) -#endif + & +zpowtratot(ipownh4)+zpowtratot(ipown2o)*2+zpowtratot(ipowno2) + endif totalphos= & zocetratot(idet)+zocetratot(idoc)+zocetratot(iphy) & @@ -422,9 +418,9 @@ subroutine inventory_bgc(kpie,kpje,kpke,dlxp,dlyp,ddpo,omask,iogrp) else totaloxy = totaloxy + so2flux+sn2oflux*0.5+co2flux endif -#ifdef extNcycle + if (use_extNcycle) then totaloxy = totaloxy + zocetratot(iano2)+zpowtratot(ipown2o)*0.5+zpowtratot(ipowno2) -#endif + endif if (do_rivinpt) then totalcarbon = totalcarbon- (srivflux(irdoc)+srivflux(irdet))*rcar & @@ -597,9 +593,9 @@ subroutine write_stdout ! write(io_stdo_bgc,*) 'O2 Flux :',so2flux ! write(io_stdo_bgc,*) 'N2 Flux :',sn2flux ! write(io_stdo_bgc,*) 'N2O Flux :',sn2oflux -#ifdef extNcycle - ! write(io_stdo_bgc,*) 'NH3 Flux :',snh3flux -#endif + if (use_extNcycle) then + ! write(io_stdo_bgc,*) 'NH3 Flux :',snh3flux + endif ! write(io_stdo_bgc,*) ' ' if (use_BOXATM) then ! write(io_stdo_bgc,*) 'global atm. CO2[ppm] / kmol: ', & @@ -617,9 +613,9 @@ subroutine write_stdout if(do_ndep) then write(io_stdo_bgc,*) 'NdepNOyFlux :',sndepnoyflux -#ifdef extNcycle + if (use_extNcycle) then write(io_stdo_bgc,*) 'NdepNHxFlux :',sndepnhxflux -#endif + endif endif ! riverine fluxes @@ -788,10 +784,10 @@ subroutine write_netcdf(iogrp) ! BROMO integer :: zt_bromo_varid, zc_bromo_varid ! Bromoform - + ! extNcycle - integer :: zt_nh4_varid, zc_nh4_varid ! Ammonium (NH4+) - integer :: zt_ano2_varid, zc_ano2_varid ! Nitrite (NO2-) + integer :: zt_nh4_varid, zc_nh4_varid ! Ammonium (NH4+) + integer :: zt_ano2_varid, zc_ano2_varid ! Nitrite (NO2-) !--- sum of inventory integer :: totcarb_varid, totphos_varid, totsili_varid, totnitr_varid @@ -1428,7 +1424,7 @@ subroutine write_netcdf(iogrp) & 'Mean bromoform concentration') ) call nccheck( NF90_PUT_ATT(ncid, zc_bromo_varid, 'units', 'kmol/m^3') ) endif -#ifdef extNcycle + if (use_extNcycle) then call nccheck( NF90_DEF_VAR(ncid, 'zt_nh4', NF90_DOUBLE, & & time_dimid, zt_nh4_varid) ) call nccheck( NF90_PUT_ATT(ncid, zt_nh4_varid, 'long_name', & @@ -1440,7 +1436,7 @@ subroutine write_netcdf(iogrp) call nccheck( NF90_PUT_ATT(ncid, zc_nh4_varid, 'long_name', & & 'Mean ammonium concentration') ) call nccheck( NF90_PUT_ATT(ncid, zc_nh4_varid, 'units', 'kmol/m^3') ) - + call nccheck( NF90_DEF_VAR(ncid, 'zt_ano2', NF90_DOUBLE, & & time_dimid, zt_ano2_varid) ) call nccheck( NF90_PUT_ATT(ncid, zt_ano2_varid, 'long_name', & @@ -1452,7 +1448,7 @@ subroutine write_netcdf(iogrp) call nccheck( NF90_PUT_ATT(ncid, zc_ano2_varid, 'long_name', & & 'Mean nitrite concentration') ) call nccheck( NF90_PUT_ATT(ncid, zc_ano2_varid, 'units', 'kmol/m^3') ) -#endif + endif !--- Define variables : sum of inventory call nccheck( NF90_DEF_VAR(ncid, 'totcarb', NF90_DOUBLE, time_dimid, & & totcarb_varid) ) @@ -1647,12 +1643,12 @@ subroutine write_netcdf(iogrp) call nccheck( NF90_INQ_VARID(ncid, "zt_bromo", zt_bromo_varid) ) call nccheck( NF90_INQ_VARID(ncid, "zc_bromo", zc_bromo_varid) ) endif -#ifdef extNcycle + if (use_extNcycle) then call nccheck( NF90_INQ_VARID(ncid, "zt_nh4", zt_nh4_varid) ) call nccheck( NF90_INQ_VARID(ncid, "zc_nh4", zc_nh4_varid) ) call nccheck( NF90_INQ_VARID(ncid, "zt_ano2", zt_ano2_varid) ) call nccheck( NF90_INQ_VARID(ncid, "zc_ano2", zc_ano2_varid) ) -#endif + endif !--- Inquire varid : sum of inventory call nccheck( NF90_INQ_VARID(ncid, "totcarb", totcarb_varid) ) call nccheck( NF90_INQ_VARID(ncid, "totphos", totphos_varid) ) @@ -1882,7 +1878,7 @@ subroutine write_netcdf(iogrp) call nccheck( NF90_PUT_VAR(ncid, zc_bromo_varid, & & zocetratoc(ibromo), start = wrstart) ) endif -#ifdef extNcycle + if (use_extNcycle) then call nccheck( NF90_PUT_VAR(ncid, zt_nh4_varid, & & zocetratot(ianh4), start = wrstart) ) call nccheck( NF90_PUT_VAR(ncid, zc_nh4_varid, & @@ -1891,7 +1887,7 @@ subroutine write_netcdf(iogrp) & zocetratot(iano2), start = wrstart) ) call nccheck( NF90_PUT_VAR(ncid, zc_ano2_varid, & & zocetratoc(iano2), start = wrstart) ) -#endif + endif !--- Write data : sum of inventory call nccheck( NF90_PUT_VAR(ncid, totcarb_varid, totalcarbon, & & start = wrstart) ) diff --git a/hamocc/mo_ncout_hamocc.F90 b/hamocc/mo_ncout_hamocc.F90 index fdfe104a..7da786f4 100644 --- a/hamocc/mo_ncout_hamocc.F90 +++ b/hamocc/mo_ncout_hamocc.F90 @@ -35,11 +35,12 @@ subroutine ncwrt_bgc(iogrp) use mod_grid, only: depths use mod_dia, only: diafnm,sigmar1,iotype,ddm,depthslev,depthslev_bnds use mo_control_bgc, only: dtbgc,use_cisonew,use_AGG,use_CFC,use_natDIC,use_BROMO, & - use_sedbypass,use_BOXATM,lm4ago + use_sedbypass,use_BOXATM,lm4ago,use_extNcycle use mo_vgrid, only: k0100,k0500,k1000,k2000,k4000 use mo_param1_bgc, only: ks + use mo_param_bgc, only: c14fac use mod_nctools, only: ncwrt1,ncdims,nctime,ncfcls,ncfopn,ncdimc - use mo_bgcmean, only: domassfluxes,flx_ndepnoy,flx_oalk, & + use mo_bgcmean, only: domassfluxes,flx_ndepnoy,flx_oalk, & flx_cal0100,flx_cal0500,flx_cal1000, & flx_cal2000,flx_cal4000,flx_cal_bot, & flx_car0100,flx_car0500,flx_car1000, & @@ -169,52 +170,47 @@ subroutine ncwrt_bgc(iogrp) jlvl_agg_ws,jlvl_dynvis,jlvl_agg_stick, & jlvl_agg_stickf,jlvl_agg_dmax,jlvl_agg_avdp, & jlvl_agg_avrhop,jlvl_agg_avdC,jlvl_agg_df, & - jlvl_agg_b,jlvl_agg_Vrhof,jlvl_agg_Vpor -#ifdef extNcycle - use mo_bgcmean, only: janh4,jano2,jlvlanh4,jlvlano2,jsrfanh4,jsrfpnh3, & - & jsrfano2,janh3fx,srf_pnh3,srf_anh4,srf_ano2, & - & srf_anh3fx,lyr_anh4,lyr_ano2,lvl_anh4, & - & lvl_ano2, & - & LYR_nitr_NH4,LYR_nitr_NO2,LYR_nitr_N2O_prod, & - & LYR_nitr_NH4_OM,LYR_nitr_NO2_OM, & - & LYR_denit_NO3,LYR_denit_NO2,LYR_denit_N2O, & - & LYR_DNRA_NO2,LYR_anmx_N2_prod, & - & LYR_anmx_OM_prod,LYR_phosy_NH4, & - & LYR_phosy_NO3,LYR_remin_aerob,LYR_remin_sulf, & - & LVL_nitr_NH4,LVL_nitr_NO2,LVL_nitr_N2O_prod, & - & LVL_nitr_NH4_OM,LVL_nitr_NO2_OM, & - & LVL_denit_NO3,LVL_denit_NO2,LVL_denit_N2O, & - & LVL_DNRA_NO2,LVL_anmx_N2_prod, & - & LVL_anmx_OM_prod,LVL_phosy_NH4, & - & LVL_phosy_NO3,LVL_remin_aerob,LVL_remin_sulf, & - & jnitr_NH4,jnitr_NO2,jnitr_N2O_prod, & - & jnitr_NH4_OM,jnitr_NO2_OM,jdenit_NO3, & - & jdenit_NO2,jdenit_N2O,jDNRA_NO2, & - & janmx_N2_prod,janmx_OM_prod,jphosy_NH4, & - & jphosy_NO3,jremin_aerob,jremin_sulf, & - & jlvl_nitr_NH4,jlvl_nitr_NO2, & - & jlvl_nitr_N2O_prod,jlvl_nitr_NH4_OM, & - & jlvl_nitr_NO2_OM,jlvl_denit_NO3, & - & jlvl_denit_NO2,jlvl_denit_N2O,jlvl_DNRA_NO2, & - & jlvl_anmx_N2_prod,jlvl_anmx_OM_prod, & - & jlvl_phosy_NH4,jlvl_phosy_NO3, & - & jlvl_remin_aerob,jlvl_remin_sulf,jatmnh3,jatmn2o, & - & srf_atmnh3,srf_atmn2o,flx_ndepnhx,jndepnhxfx -#endif -#if defined(extNcycle) && ! defined(sedbypass) - use mo_bgcmean, only: jpownh4,jpown2o,jpowno2,jsdm_nitr_NH4,jsdm_nitr_NO2, & - & jsdm_nitr_N2O_prod,jsdm_nitr_NH4_OM,jsdm_nitr_NO2_OM, & - & jsdm_denit_NO3,jsdm_denit_NO2,jsdm_denit_N2O, & - & jsdm_DNRA_NO2,jsdm_anmx_N2_prod,jsdm_anmx_OM_prod, & - & jsdm_remin_aerob,jsdm_remin_sulf, SDM_POWNH4,SDM_POWN2O,& - & SDM_POWNO2,SDM_nitr_NH4,SDM_nitr_NO2,SDM_nitr_N2O_prod, & - & SDM_nitr_NH4_OM,SDM_nitr_NO2_OM,SDM_denit_NO3, & - & SDM_denit_NO2,SDM_denit_N2O,SDM_DNRA_NO2, & - & SDM_anmx_N2_prod,SDM_anmx_OM_prod,SDM_remin_aerob, & - & SDM_remin_sulf,jsediffnh4,jsediffn2o,jsediffno2, & - & FLX_SEDIFFNH4,FLX_SEDIFFN2O,FLX_SEDIFFNO2 -#endif - use mo_param_bgc, only: c14fac + jlvl_agg_b,jlvl_agg_Vrhof,jlvl_agg_Vpor, & + janh4,jano2,jlvlanh4,jlvlano2,jsrfanh4,jsrfpnh3, & + jsrfano2,janh3fx,srf_pnh3,srf_anh4,srf_ano2, & + srf_anh3fx,lyr_anh4,lyr_ano2,lvl_anh4, & + lvl_ano2, & + LYR_nitr_NH4,LYR_nitr_NO2,LYR_nitr_N2O_prod, & + LYR_nitr_NH4_OM,LYR_nitr_NO2_OM, & + LYR_denit_NO3,LYR_denit_NO2,LYR_denit_N2O, & + LYR_DNRA_NO2,LYR_anmx_N2_prod, & + LYR_anmx_OM_prod,LYR_phosy_NH4, & + LYR_phosy_NO3,LYR_remin_aerob,LYR_remin_sulf, & + LVL_nitr_NH4,LVL_nitr_NO2,LVL_nitr_N2O_prod, & + LVL_nitr_NH4_OM,LVL_nitr_NO2_OM, & + LVL_denit_NO3,LVL_denit_NO2,LVL_denit_N2O, & + LVL_DNRA_NO2,LVL_anmx_N2_prod, & + LVL_anmx_OM_prod,LVL_phosy_NH4, & + LVL_phosy_NO3,LVL_remin_aerob,LVL_remin_sulf, & + jnitr_NH4,jnitr_NO2,jnitr_N2O_prod, & + jnitr_NH4_OM,jnitr_NO2_OM,jdenit_NO3, & + jdenit_NO2,jdenit_N2O,jDNRA_NO2, & + janmx_N2_prod,janmx_OM_prod,jphosy_NH4, & + jphosy_NO3,jremin_aerob,jremin_sulf, & + jlvl_nitr_NH4,jlvl_nitr_NO2, & + jlvl_nitr_N2O_prod,jlvl_nitr_NH4_OM, & + jlvl_nitr_NO2_OM,jlvl_denit_NO3, & + jlvl_denit_NO2,jlvl_denit_N2O,jlvl_DNRA_NO2, & + jlvl_anmx_N2_prod,jlvl_anmx_OM_prod, & + jlvl_phosy_NH4,jlvl_phosy_NO3, & + jlvl_remin_aerob,jlvl_remin_sulf,jatmnh3,jatmn2o, & + srf_atmnh3,srf_atmn2o,flx_ndepnhx,jndepnhxfx, & + jpownh4,jpown2o,jpowno2,jsdm_nitr_NH4,jsdm_nitr_NO2, & + jsdm_nitr_N2O_prod,jsdm_nitr_NH4_OM,jsdm_nitr_NO2_OM, & + jsdm_denit_NO3,jsdm_denit_NO2,jsdm_denit_N2O, & + jsdm_DNRA_NO2,jsdm_anmx_N2_prod,jsdm_anmx_OM_prod, & + jsdm_remin_aerob,jsdm_remin_sulf, SDM_POWNH4,SDM_POWN2O, & + SDM_POWNO2,SDM_nitr_NH4,SDM_nitr_NO2,SDM_nitr_N2O_prod, & + SDM_nitr_NH4_OM,SDM_nitr_NO2_OM,SDM_denit_NO3, & + SDM_denit_NO2,SDM_denit_N2O,SDM_DNRA_NO2, & + SDM_anmx_N2_prod,SDM_anmx_OM_prod,SDM_remin_aerob, & + SDM_remin_sulf,jsediffnh4,jsediffn2o,jsediffno2, & + FLX_SEDIFFNH4,FLX_SEDIFFN2O,FLX_SEDIFFNO2 ! Arguments integer :: i,j,k,l,nt @@ -356,7 +352,7 @@ subroutine ncwrt_bgc(iogrp) if (use_BROMO) then call finlyr(jbromo(iogrp),jdp(iogrp)) endif -#ifdef extNcycle + if (use_extNcycle) then call finlyr(janh4(iogrp),jdp(iogrp)) call finlyr(jano2(iogrp),jdp(iogrp)) call finlyr(jnitr_NH4(iogrp),jdp(iogrp)) @@ -374,7 +370,7 @@ subroutine ncwrt_bgc(iogrp) call finlyr(jphosy_NO3(iogrp),jdp(iogrp)) call finlyr(jremin_aerob(iogrp),jdp(iogrp)) call finlyr(jremin_sulf(iogrp),jdp(iogrp)) -#endif + endif if(lm4ago)then ! M4AGO call finlyr(jagg_ws(iogrp),jdp(iogrp)) @@ -471,7 +467,7 @@ subroutine ncwrt_bgc(iogrp) if (use_BROMO) then call msklvl(jlvlbromo(iogrp),depths) endif -#ifdef extNcycle + if (use_extNcycle) then call msklvl(jlvlanh4(iogrp),depths) call msklvl(jlvlano2(iogrp),depths) call msklvl(jlvl_nitr_NH4(iogrp),depths) @@ -489,7 +485,7 @@ subroutine ncwrt_bgc(iogrp) call msklvl(jlvl_phosy_NO3(iogrp),depths) call msklvl(jlvl_remin_aerob(iogrp),depths) call msklvl(jlvl_remin_sulf(iogrp),depths) -#endif + endif if(lm4ago)then ! M4AGO call msklvl(jlvl_agg_ws(iogrp),depths) @@ -581,12 +577,12 @@ subroutine ncwrt_bgc(iogrp) call wrtsrf(jburflxsssc12(iogrp),FLX_BURSSSC12(iogrp),rnacc*1e3/dtbgc,0.,cmpflg,'burfsssc12') call wrtsrf(jburflxssssil(iogrp),FLX_BURSSSSIL(iogrp),rnacc*1e3/dtbgc,0.,cmpflg,'burfssssil') call wrtsrf(jburflxssster(iogrp),FLX_BURSSSTER(iogrp),rnacc*1e3/dtbgc,0.,cmpflg,'burfssster') + if (use_extNcycle) then + call wrtsrf(jsediffnh4(iogrp), FLX_SEDIFFNH4(iogrp),rnacc*1e3/dtbgc,0.,cmpflg,'sedfnh4') + call wrtsrf(jsediffn2o(iogrp), FLX_SEDIFFN2O(iogrp),rnacc*1e3/dtbgc,0.,cmpflg,'sedfn2o') + call wrtsrf(jsediffno2(iogrp), FLX_SEDIFFNO2(iogrp),rnacc*1e3/dtbgc,0.,cmpflg,'sedfno2') + endif endif -#if defined(extNcycle) && ! defined(sedbypass) - call wrtsrf(jsediffnh4(iogrp), FLX_SEDIFFNH4(iogrp),rnacc*1e3/dtbgc,0.,cmpflg,'sedfnh4') - call wrtsrf(jsediffn2o(iogrp), FLX_SEDIFFN2O(iogrp),rnacc*1e3/dtbgc,0.,cmpflg,'sedfn2o') - call wrtsrf(jsediffno2(iogrp), FLX_SEDIFFNO2(iogrp),rnacc*1e3/dtbgc,0.,cmpflg,'sedfno2') -#endif if (use_cisonew) then call wrtsrf(jco213fxd(iogrp), SRF_CO213FXD(iogrp), rnacc*12./dtbgc,0.,cmpflg,'co213fxd') call wrtsrf(jco213fxu(iogrp), SRF_CO213FXU(iogrp), rnacc*12./dtbgc,0.,cmpflg,'co213fxu') @@ -621,15 +617,16 @@ subroutine ncwrt_bgc(iogrp) call wrtsrf(jatmc13(iogrp), SRF_ATMC13(iogrp), rnacc, 0.,cmpflg,'atmc13') call wrtsrf(jatmc14(iogrp), SRF_ATMC14(iogrp), rnacc, 0.,cmpflg,'atmc14') endif -#ifdef extNcycle + if (use_extNcycle) then call wrtsrf(jsrfanh4(iogrp), SRF_ANH4(iogrp), rnacc*1e3, 0.,cmpflg,'srfnh4') call wrtsrf(jsrfpnh3(iogrp), SRF_PNH3(iogrp), rnacc, 0.,cmpflg,'pnh3') call wrtsrf(jsrfano2(iogrp), SRF_ANO2(iogrp), rnacc*1e3, 0.,cmpflg,'srfno2') call wrtsrf(janh3fx(iogrp), SRF_ANH3FX(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'nh3flux') call wrtsrf(jatmnh3(iogrp), SRF_ATMNH3(iogrp), rnacc, 0.,cmpflg,'atmnh3') call wrtsrf(jatmn2o(iogrp), SRF_ATMN2O(iogrp), rnacc, 0.,cmpflg,'atmn2o') - call wrtsrf(jndepnhxfx(iogrp), FLX_NDEPNHX(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'ndepnhx') -#endif + call wrtsrf(jndepnhxfx(iogrp), FLX_NDEPNHX(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'ndepnhx') + endif + ! --- Store 3d layer fields call wrtlyr(jdp(iogrp), LYR_DP(iogrp), rnacc, 0.,cmpflg,'pddpo') call wrtlyr(jdic(iogrp), LYR_DIC(iogrp), 1e3, 0.,cmpflg,'dissic') @@ -694,7 +691,7 @@ subroutine ncwrt_bgc(iogrp) if (use_BROMO) then call wrtlyr(jbromo(iogrp), LYR_BROMO(iogrp), 1e3, 0.,cmpflg,'bromo') endif -#ifdef extNcycle + if (use_extNcycle) then call wrtlyr(janh4(iogrp), LYR_ANH4(iogrp), 1e3, 0.,cmpflg,'nh4') call wrtlyr(jano2(iogrp), LYR_ANO2(iogrp), 1e3, 0.,cmpflg,'no2') call wrtlyr(jnitr_NH4(iogrp), LYR_nitr_NH4(iogrp), 1e3/dtbgc, 0.,cmpflg,'nh4nitr') @@ -712,7 +709,7 @@ subroutine ncwrt_bgc(iogrp) call wrtlyr(jphosy_NO3(iogrp), LYR_phosy_NO3(iogrp),1e3/dtbgc, 0.,cmpflg,'phosy_no3') call wrtlyr(jremin_aerob(iogrp), LYR_remin_aerob(iogrp),1e3/dtbgc, 0.,cmpflg,'remina') call wrtlyr(jremin_sulf(iogrp), LYR_remin_sulf(iogrp),1e3/dtbgc, 0.,cmpflg,'remins') -#endif + endif if(lm4ago)then ! M4AGO call wrtlyr(jagg_ws(iogrp), LYR_agg_ws(iogrp), 1., 0.,cmpflg,'agg_ws') @@ -792,7 +789,7 @@ subroutine ncwrt_bgc(iogrp) if (use_BROMO) then call wrtlvl(jlvlbromo(iogrp), LVL_BROMO(iogrp), rnacc*1e3, 0.,cmpflg,'bromolvl') endif -#ifdef extNcycle + if (use_extNcycle) then call wrtlvl(jlvlanh4(iogrp), LVL_ANH4(iogrp), rnacc*1e3, 0.,cmpflg,'nh4lvl') call wrtlvl(jlvlano2(iogrp), LVL_ANO2(iogrp), rnacc*1e3, 0.,cmpflg,'no2lvl') call wrtlvl(jlvl_nitr_NH4(iogrp), LVL_nitr_NH4(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'nh4nitrlvl') @@ -810,7 +807,7 @@ subroutine ncwrt_bgc(iogrp) call wrtlvl(jlvl_phosy_NO3(iogrp), LVL_phosy_NO3(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'phosy_no3lvl') call wrtlvl(jlvl_remin_aerob(iogrp), LVL_remin_aerob(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'reminalvl') call wrtlvl(jlvl_remin_sulf(iogrp), LVL_remin_sulf(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'reminslvl') -#endif + endif if(lm4ago)then ! M4AGO call wrtlvl(jlvl_agg_ws(iogrp), LVL_agg_ws(iogrp), rnacc, 0.,cmpflg,'agg_wslvl') @@ -846,25 +843,25 @@ subroutine ncwrt_bgc(iogrp) call wrtbur(jbursssc12(iogrp), BUR_SSSC12(iogrp), rnacc*1e3, 0.,cmpflg,'burc12') call wrtbur(jburssssil(iogrp), BUR_SSSSIL(iogrp), rnacc*1e3, 0.,cmpflg,'bursil') call wrtbur(jburssster(iogrp), BUR_SSSTER(iogrp), rnacc, 0.,cmpflg,'burter') + if (use_extNcycle) then + call wrtsdm(jpownh4(iogrp), SDM_POWNH4(iogrp), rnacc*1e3, 0.,cmpflg,'pownh4') + call wrtsdm(jpown2o(iogrp), SDM_POWN2O(iogrp), rnacc*1e3, 0.,cmpflg,'pown2o') + call wrtsdm(jpowno2(iogrp), SDM_POWNO2(iogrp), rnacc*1e3, 0.,cmpflg,'powno2') + call wrtsdm(jsdm_nitr_NH4(iogrp), sdm_nitr_NH4(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'nh4nitrsdm') + call wrtsdm(jsdm_nitr_NO2(iogrp), sdm_nitr_NO2(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'no2nitrsdm') + call wrtsdm(jsdm_nitr_N2O_prod(iogrp),sdm_nitr_N2O_prod(iogrp),rnacc*1e3/dtbgc,0.,cmpflg,'nitr_n2osdm') + call wrtsdm(jsdm_nitr_NH4_OM(iogrp), sdm_nitr_NH4_OM(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'nh4nitr_omsdm') + call wrtsdm(jsdm_nitr_NO2_OM(iogrp), sdm_nitr_NO2_OM(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'no2nitr_omsdm') + call wrtsdm(jsdm_denit_NO3(iogrp), sdm_denit_NO3(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'no3denitsdm') + call wrtsdm(jsdm_denit_NO2(iogrp), sdm_denit_NO2(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'no2denitsdm') + call wrtsdm(jsdm_denit_N2O(iogrp), sdm_denit_N2O(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'n2odenitsdm') + call wrtsdm(jsdm_DNRA_NO2(iogrp), sdm_DNRA_NO2(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'no2dnrasdm') + call wrtsdm(jsdm_anmx_N2_prod(iogrp), sdm_anmx_N2_prod(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'anmx_n2sdm') + call wrtsdm(jsdm_anmx_OM_prod(iogrp), sdm_anmx_OM_prod(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'anmx_omsdm') + call wrtsdm(jsdm_remin_aerob(iogrp), sdm_remin_aerob(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'reminasdm') + call wrtsdm(jsdm_remin_sulf(iogrp), sdm_remin_sulf(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'reminssdm') + endif endif -#if defined(extNcycle) && ! defined(sedbypass) - call wrtsdm(jpownh4(iogrp), SDM_POWNH4(iogrp), rnacc*1e3, 0.,cmpflg,'pownh4') - call wrtsdm(jpown2o(iogrp), SDM_POWN2O(iogrp), rnacc*1e3, 0.,cmpflg,'pown2o') - call wrtsdm(jpowno2(iogrp), SDM_POWNO2(iogrp), rnacc*1e3, 0.,cmpflg,'powno2') - call wrtsdm(jsdm_nitr_NH4(iogrp), sdm_nitr_NH4(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'nh4nitrsdm') - call wrtsdm(jsdm_nitr_NO2(iogrp), sdm_nitr_NO2(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'no2nitrsdm') - call wrtsdm(jsdm_nitr_N2O_prod(iogrp),sdm_nitr_N2O_prod(iogrp),rnacc*1e3/dtbgc,0.,cmpflg,'nitr_n2osdm') - call wrtsdm(jsdm_nitr_NH4_OM(iogrp), sdm_nitr_NH4_OM(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'nh4nitr_omsdm') - call wrtsdm(jsdm_nitr_NO2_OM(iogrp), sdm_nitr_NO2_OM(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'no2nitr_omsdm') - call wrtsdm(jsdm_denit_NO3(iogrp), sdm_denit_NO3(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'no3denitsdm') - call wrtsdm(jsdm_denit_NO2(iogrp), sdm_denit_NO2(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'no2denitsdm') - call wrtsdm(jsdm_denit_N2O(iogrp), sdm_denit_N2O(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'n2odenitsdm') - call wrtsdm(jsdm_DNRA_NO2(iogrp), sdm_DNRA_NO2(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'no2dnrasdm') - call wrtsdm(jsdm_anmx_N2_prod(iogrp), sdm_anmx_N2_prod(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'anmx_n2sdm') - call wrtsdm(jsdm_anmx_OM_prod(iogrp), sdm_anmx_OM_prod(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'anmx_omsdm') - call wrtsdm(jsdm_remin_aerob(iogrp), sdm_remin_aerob(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'reminasdm') - call wrtsdm(jsdm_remin_sulf(iogrp), sdm_remin_sulf(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'reminssdm') -#endif ! --- close netcdf file call ncfcls @@ -971,7 +968,7 @@ subroutine ncwrt_bgc(iogrp) call inisrf(jatmc13(iogrp),0.) call inisrf(jatmc14(iogrp),0.) endif -#ifdef extNcycle + if (use_extNcycle) then call inisrf(jsrfanh4(iogrp),0.) call inisrf(jsrfpnh3(iogrp),0.) call inisrf(jsrfano2(iogrp),0.) @@ -979,12 +976,12 @@ subroutine ncwrt_bgc(iogrp) call inisrf(jatmnh3(iogrp),0.) call inisrf(jatmn2o(iogrp),0.) call inisrf(jndepnhxfx(iogrp),0.) -#endif -#if defined(extNcycle) && ! defined(sedbypass) - call inisrf(jsediffnh4(iogrp),0.) - call inisrf(jsediffn2o(iogrp),0.) - call inisrf(jsediffno2(iogrp),0.) -#endif + if (.not. use_sedbypass) then + call inisrf(jsediffnh4(iogrp),0.) + call inisrf(jsediffn2o(iogrp),0.) + call inisrf(jsediffno2(iogrp),0.) + endif + endif call inilyr(jdp(iogrp),0.) call inilyr(jdic(iogrp),0.) call inilyr(jalkali(iogrp),0.) @@ -1048,9 +1045,9 @@ subroutine ncwrt_bgc(iogrp) if (use_BROMO) then call inilyr(jbromo(iogrp),0.) endif -#ifdef extNcycle - call inilyr(janh4(iogrp),0.) - call inilyr(jano2(iogrp),0.) + if (use_extNcycle) then + call inilyr(janh4(iogrp),0.) + call inilyr(jano2(iogrp),0.) call inilyr(jnitr_NH4(iogrp),0.) call inilyr(jnitr_NO2(iogrp),0.) call inilyr(jnitr_N2O_prod(iogrp),0.) @@ -1065,8 +1062,8 @@ subroutine ncwrt_bgc(iogrp) call inilyr(jphosy_NH4(iogrp),0.) call inilyr(jphosy_NO3(iogrp),0.) call inilyr(jremin_aerob(iogrp),0.) - call inilyr(jremin_sulf(iogrp),0.) -#endif + call inilyr(jremin_sulf(iogrp),0.) + endif if(lm4ago)then ! M4AGO call inilyr(jagg_ws(iogrp),0.) @@ -1144,9 +1141,9 @@ subroutine ncwrt_bgc(iogrp) if (use_BROMO) then call inilvl(jlvlbromo(iogrp),0.) endif -#ifdef extNcycle - call inilvl(jlvlanh4(iogrp),0.) - call inilvl(jlvlano2(iogrp),0.) + if (use_extNcycle) then + call inilvl(jlvlanh4(iogrp),0.) + call inilvl(jlvlano2(iogrp),0.) call inilvl(jlvl_nitr_NH4(iogrp),0.) call inilvl(jlvl_nitr_NO2(iogrp),0.) call inilvl(jlvl_nitr_N2O_prod(iogrp),0.) @@ -1161,8 +1158,8 @@ subroutine ncwrt_bgc(iogrp) call inilvl(jlvl_phosy_NH4(iogrp),0.) call inilvl(jlvl_phosy_NO3(iogrp),0.) call inilvl(jlvl_remin_aerob(iogrp),0.) - call inilvl(jlvl_remin_sulf(iogrp),0.) -#endif + call inilvl(jlvl_remin_sulf(iogrp),0.) + endif if(lm4ago)then ! M4AGO call inilvl(jlvl_agg_ws(iogrp),0.) @@ -1196,25 +1193,25 @@ subroutine ncwrt_bgc(iogrp) call inibur(jbursssc12(iogrp),0.) call inibur(jburssssil(iogrp),0.) call inibur(jburssster(iogrp),0.) + if (use_extNcycle) then + call inisdm(jpownh4(iogrp),0.) + call inisdm(jpown2o(iogrp),0.) + call inisdm(jpowno2(iogrp),0.) + call inisdm(jsdm_nitr_NH4(iogrp),0.) + call inisdm(jsdm_nitr_NO2(iogrp),0.) + call inisdm(jsdm_nitr_N2O_prod(iogrp),0.) + call inisdm(jsdm_nitr_NH4_OM(iogrp),0.) + call inisdm(jsdm_nitr_NO2_OM(iogrp),0.) + call inisdm(jsdm_denit_NO3(iogrp),0.) + call inisdm(jsdm_denit_NO2(iogrp),0.) + call inisdm(jsdm_denit_N2O(iogrp),0.) + call inisdm(jsdm_DNRA_NO2(iogrp),0.) + call inisdm(jsdm_anmx_N2_prod(iogrp),0.) + call inisdm(jsdm_anmx_OM_prod(iogrp),0.) + call inisdm(jsdm_remin_aerob(iogrp),0.) + call inisdm(jsdm_remin_sulf(iogrp),0.) + endif endif -#if defined(extNcycle) && ! defined(sedbypass) - call inisdm(jpownh4(iogrp),0.) - call inisdm(jpown2o(iogrp),0.) - call inisdm(jpowno2(iogrp),0.) - call inisdm(jsdm_nitr_NH4(iogrp),0.) - call inisdm(jsdm_nitr_NO2(iogrp),0.) - call inisdm(jsdm_nitr_N2O_prod(iogrp),0.) - call inisdm(jsdm_nitr_NH4_OM(iogrp),0.) - call inisdm(jsdm_nitr_NO2_OM(iogrp),0.) - call inisdm(jsdm_denit_NO3(iogrp),0.) - call inisdm(jsdm_denit_NO2(iogrp),0.) - call inisdm(jsdm_denit_N2O(iogrp),0.) - call inisdm(jsdm_DNRA_NO2(iogrp),0.) - call inisdm(jsdm_anmx_N2_prod(iogrp),0.) - call inisdm(jsdm_anmx_OM_prod(iogrp),0.) - call inisdm(jsdm_remin_aerob(iogrp),0.) - call inisdm(jsdm_remin_sulf(iogrp),0.) -#endif nacc_bgc(iogrp)=0 end subroutine ncwrt_bgc @@ -1280,53 +1277,49 @@ subroutine hamoccvardef(iogrp,timeunits,calendar,cmpflg) lvl_agg_ws,lvl_dynvis,lvl_agg_stick, & lvl_agg_stickf,lvl_agg_dmax,lvl_agg_avdp, & lvl_agg_avrhop,lvl_agg_avdC,lvl_agg_df, & - lvl_agg_b,lvl_agg_Vrhof,lvl_agg_Vpor -#ifdef extNcycle - use mo_bgcmean, only: janh4,jano2,jlvlanh4,jlvlano2,jsrfanh4, & - & jsrfano2,janh3fx,srf_pnh3,srf_anh4,srf_ano2, & - & srf_anh3fx,lyr_anh4,lyr_ano2,lvl_anh4, & - & lvl_ano2, & - & LYR_nitr_NH4,LYR_nitr_NO2,LYR_nitr_N2O_prod, & - & LYR_nitr_NH4_OM,LYR_nitr_NO2_OM, & - & LYR_denit_NO3,LYR_denit_NO2,LYR_denit_N2O, & - & LYR_DNRA_NO2,LYR_anmx_N2_prod, & - & LYR_anmx_OM_prod,LYR_phosy_NH4, & - & LYR_phosy_NO3,LYR_remin_aerob,LYR_remin_sulf, & - & LVL_nitr_NH4,LVL_nitr_NO2,LVL_nitr_N2O_prod, & - & LVL_nitr_NH4_OM,LVL_nitr_NO2_OM, & - & LVL_denit_NO3,LVL_denit_NO2,LVL_denit_N2O, & - & LVL_DNRA_NO2,LVL_anmx_N2_prod, & - & LVL_anmx_OM_prod,LVL_phosy_NH4, & - & LVL_phosy_NO3,LVL_remin_aerob,LVL_remin_sulf, & - & jnitr_NH4,jnitr_NO2,jnitr_N2O_prod, & - & jnitr_NH4_OM,jnitr_NO2_OM,jdenit_NO3, & - & jdenit_NO2,jdenit_N2O,jDNRA_NO2, & - & janmx_N2_prod,janmx_OM_prod,jphosy_NH4, & - & jphosy_NO3,jremin_aerob,jremin_sulf, & - & jlvl_nitr_NH4,jlvl_nitr_NO2, & - & jlvl_nitr_N2O_prod,jlvl_nitr_NH4_OM, & - & jlvl_nitr_NO2_OM,jlvl_denit_NO3, & - & jlvl_denit_NO2,jlvl_denit_N2O,jlvl_DNRA_NO2, & - & jlvl_anmx_N2_prod,jlvl_anmx_OM_prod, & - & jlvl_phosy_NH4,jlvl_phosy_NO3, & - & jlvl_remin_aerob,jlvl_remin_sulf,srf_atmnh3, & - & srf_atmn2o,flx_ndepnhx -#endif -#if defined(extNcycle) && ! defined(sedbypass) - use mo_bgcmean, only: jpownh4,jpown2o,jpowno2,jsdm_nitr_NH4,jsdm_nitr_NO2, & - & jsdm_nitr_N2O_prod,jsdm_nitr_NH4_OM,jsdm_nitr_NO2_OM, & - & jsdm_denit_NO3,jsdm_denit_NO2,jsdm_denit_N2O, & - & jsdm_DNRA_NO2,jsdm_anmx_N2_prod,jsdm_anmx_OM_prod, & - & jsdm_remin_aerob,jsdm_remin_sulf, SDM_POWNH4,SDM_POWN2O,& - & SDM_POWNO2,SDM_nitr_NH4,SDM_nitr_NO2,SDM_nitr_N2O_prod, & - & SDM_nitr_NH4_OM,SDM_nitr_NO2_OM,SDM_denit_NO3, & - & SDM_denit_NO2,SDM_denit_N2O,SDM_DNRA_NO2, & - & SDM_anmx_N2_prod,SDM_anmx_OM_prod,SDM_remin_aerob, & - & SDM_remin_sulf,jsediffnh4,jsediffn2o,jsediffno2, & - & FLX_SEDIFFNH4,FLX_SEDIFFN2O,FLX_SEDIFFNO2 -#endif + lvl_agg_b,lvl_agg_Vrhof,lvl_agg_Vpor, & + janh4,jano2,jlvlanh4,jlvlano2,jsrfanh4, & + jsrfano2,janh3fx,srf_pnh3,srf_anh4,srf_ano2, & + srf_anh3fx,lyr_anh4,lyr_ano2,lvl_anh4, & + lvl_ano2, & + LYR_nitr_NH4,LYR_nitr_NO2,LYR_nitr_N2O_prod, & + LYR_nitr_NH4_OM,LYR_nitr_NO2_OM, & + LYR_denit_NO3,LYR_denit_NO2,LYR_denit_N2O, & + LYR_DNRA_NO2,LYR_anmx_N2_prod, & + LYR_anmx_OM_prod,LYR_phosy_NH4, & + LYR_phosy_NO3,LYR_remin_aerob,LYR_remin_sulf, & + LVL_nitr_NH4,LVL_nitr_NO2,LVL_nitr_N2O_prod, & + LVL_nitr_NH4_OM,LVL_nitr_NO2_OM, & + LVL_denit_NO3,LVL_denit_NO2,LVL_denit_N2O, & + LVL_DNRA_NO2,LVL_anmx_N2_prod, & + LVL_anmx_OM_prod,LVL_phosy_NH4, & + LVL_phosy_NO3,LVL_remin_aerob,LVL_remin_sulf, & + jnitr_NH4,jnitr_NO2,jnitr_N2O_prod, & + jnitr_NH4_OM,jnitr_NO2_OM,jdenit_NO3, & + jdenit_NO2,jdenit_N2O,jDNRA_NO2, & + janmx_N2_prod,janmx_OM_prod,jphosy_NH4, & + jphosy_NO3,jremin_aerob,jremin_sulf, & + jlvl_nitr_NH4,jlvl_nitr_NO2, & + jlvl_nitr_N2O_prod,jlvl_nitr_NH4_OM, & + jlvl_nitr_NO2_OM,jlvl_denit_NO3, & + jlvl_denit_NO2,jlvl_denit_N2O,jlvl_DNRA_NO2, & + jlvl_anmx_N2_prod,jlvl_anmx_OM_prod, & + jlvl_phosy_NH4,jlvl_phosy_NO3, & + jlvl_remin_aerob,jlvl_remin_sulf,srf_atmnh3, & + srf_atmn2o,flx_ndepnhx, & + jpownh4,jpown2o,jpowno2,jsdm_nitr_NH4,jsdm_nitr_NO2, & + jsdm_nitr_N2O_prod,jsdm_nitr_NH4_OM,jsdm_nitr_NO2_OM, & + jsdm_denit_NO3,jsdm_denit_NO2,jsdm_denit_N2O, & + jsdm_DNRA_NO2,jsdm_anmx_N2_prod,jsdm_anmx_OM_prod, & + jsdm_remin_aerob,jsdm_remin_sulf, SDM_POWNH4,SDM_POWN2O, & + SDM_POWNO2,SDM_nitr_NH4,SDM_nitr_NO2,SDM_nitr_N2O_prod, & + SDM_nitr_NH4_OM,SDM_nitr_NO2_OM,SDM_denit_NO3, & + SDM_denit_NO2,SDM_denit_N2O,SDM_DNRA_NO2, & + SDM_anmx_N2_prod,SDM_anmx_OM_prod,SDM_remin_aerob, & + SDM_remin_sulf,jsediffnh4,jsediffn2o,jsediffno2, & + FLX_SEDIFFNH4,FLX_SEDIFFN2O,FLX_SEDIFFNO2 use mo_control_bgc, only: use_cisonew,use_AGG,use_CFC,use_natDIC,use_BROMO, & - use_sedbypass,use_BOXATM + use_sedbypass,use_BOXATM,use_extNcycle ! Arguments integer :: iogrp,cmpflg @@ -1487,18 +1480,18 @@ subroutine hamoccvardef(iogrp,timeunits,calendar,cmpflg) call ncdefvar3d(FLX_BURSSSTER(iogrp),cmpflg,'p','burfssster', & & 'Clay burial flux to burial layer (positive downwards)', & & ' ','g m-2 s-1',0) + if (use_extNcycle) then + call ncdefvar3d(FLX_SEDIFFNH4(iogrp),cmpflg,'p','sedfnh4', & + & 'diffusive ammonium flux to sediment (positive downwards)', & + & ' ','mol NH4 m-2 s-1',0) + call ncdefvar3d(FLX_SEDIFFN2O(iogrp),cmpflg,'p','sedfn2o', & + & 'diffusive nitrous oxide flux to sediment (positive downwards)',& + & ' ','mol N2O m-2 s-1',0) + call ncdefvar3d(FLX_SEDIFFNO2(iogrp),cmpflg,'p','sedfno2', & + & 'diffusive nitrite flux to sediment (positive downwards)', & + & ' ','mol NO2 m-2 s-1',0) + endif endif -#if defined(extNcycle) && ! defined(sedbypass) - call ncdefvar3d(FLX_SEDIFFNH4(iogrp),cmpflg,'p','sedfnh4', & - & 'diffusive ammonium flux to sediment (positive downwards)', & - & ' ','mol NH4 m-2 s-1',0) - call ncdefvar3d(FLX_SEDIFFN2O(iogrp),cmpflg,'p','sedfn2o', & - & 'diffusive nitrous oxide flux to sediment (positive downwards)', & - & ' ','mol N2O m-2 s-1',0) - call ncdefvar3d(FLX_SEDIFFNO2(iogrp),cmpflg,'p','sedfno2', & - & 'diffusive nitrite flux to sediment (positive downwards)', & - & ' ','mol NO2 m-2 s-1',0) -#endif if (use_cisonew) then call ncdefvar3d(SRF_CO213FXD(iogrp),cmpflg,'p','co213fxd', & & 'Downward 13CO2 flux',' ','kg C m-2 s-1',0) @@ -1557,22 +1550,22 @@ subroutine hamoccvardef(iogrp,timeunits,calendar,cmpflg) call ncdefvar3d(SRF_ATMC14(iogrp),cmpflg,'p', & & 'atmc14','Atmospheric 14CO2',' ','ppm',0) endif -#ifdef extNcycle - call ncdefvar3d(SRF_PNH3(iogrp),cmpflg,'p', & - & 'pnh3','Surface pNH3',' ','natm',0) - call ncdefvar3d(SRF_ANH4(iogrp),cmpflg,'p','srfnh4', & - & 'Surface ammonium',' ','mol N m-3',0) - call ncdefvar3d(SRF_ANO2(iogrp),cmpflg,'p','srfno2', & - & 'Surface nitrite',' ','mol N m-3',0) - call ncdefvar3d(SRF_ANH3FX(iogrp),cmpflg,'p','nh3flux', & - & 'NH3 flux',' ','mol NH3 m-2 s-1',0) - call ncdefvar3d(SRF_ATMNH3(iogrp),cmpflg,'p', & - & 'atmnh3','Atmospheric ammonia',' ','ppt',0) - call ncdefvar3d(SRF_ATMN2O(iogrp),cmpflg,'p', & - & 'atmn2o','Atmospheric nitrous oxide',' ','ppt',0) - call ncdefvar3d(FLX_NDEPNHX(iogrp),cmpflg,'p','ndepnhx', & - & 'Nitrogen NHx deposition flux',' ','mol N m-2 s-1',0) -#endif + if (use_extNcycle) then + call ncdefvar3d(SRF_PNH3(iogrp),cmpflg,'p', & + & 'pnh3','Surface pNH3',' ','natm',0) + call ncdefvar3d(SRF_ANH4(iogrp),cmpflg,'p','srfnh4', & + & 'Surface ammonium',' ','mol N m-3',0) + call ncdefvar3d(SRF_ANO2(iogrp),cmpflg,'p','srfno2', & + & 'Surface nitrite',' ','mol N m-3',0) + call ncdefvar3d(SRF_ANH3FX(iogrp),cmpflg,'p','nh3flux', & + & 'NH3 flux',' ','mol NH3 m-2 s-1',0) + call ncdefvar3d(SRF_ATMNH3(iogrp),cmpflg,'p', & + & 'atmnh3','Atmospheric ammonia',' ','ppt',0) + call ncdefvar3d(SRF_ATMN2O(iogrp),cmpflg,'p', & + & 'atmn2o','Atmospheric nitrous oxide',' ','ppt',0) + call ncdefvar3d(FLX_NDEPNHX(iogrp),cmpflg,'p','ndepnhx', & + & 'Nitrogen NHx deposition flux',' ','mol N m-2 s-1',0) + endif ! --- define 3d layer fields call ncdefvar3d(LYR_DP(iogrp),cmpflg,'p', & @@ -1691,7 +1684,7 @@ subroutine hamoccvardef(iogrp,timeunits,calendar,cmpflg) call ncdefvar3d(LYR_BROMO(iogrp),cmpflg,'p', & & 'bromo','Bromoform',' ','mol CHBr3 m-3',1) endif -#ifdef extNcycle + if (use_extNcycle) then call ncdefvar3d(LYR_ANH4(iogrp),cmpflg,'p', & & 'nh4','Ammonium',' ','mol N m-3',1) call ncdefvar3d(LYR_ANO2(iogrp),cmpflg,'p', & @@ -1729,7 +1722,7 @@ subroutine hamoccvardef(iogrp,timeunits,calendar,cmpflg) & 'remina','Aerob remineralization rate',' ','mol N m-3 s-1',1) call ncdefvar3d(LYR_remin_sulf(iogrp),cmpflg,'p', & & 'remins','Sulfate remineralization rate',' ','mol P m-3 s-1',1) -#endif + endif if(lm4ago)then ! M4AGO call ncdefvar3d(LYR_agg_ws(iogrp),cmpflg,'p', & @@ -1872,7 +1865,7 @@ subroutine hamoccvardef(iogrp,timeunits,calendar,cmpflg) call ncdefvar3d(LVL_BROMO(iogrp),cmpflg,'p', & & 'bromolvl','Bromoform',' ','mol CHBr3 m-3',2) endif -#ifdef extNcycle + if (use_extNcycle) then call ncdefvar3d(LVL_ANH4(iogrp),cmpflg,'p', & & 'nh4lvl','Ammonium',' ','mol N m-3',2) call ncdefvar3d(LVL_ANO2(iogrp),cmpflg,'p', & @@ -1916,7 +1909,7 @@ subroutine hamoccvardef(iogrp,timeunits,calendar,cmpflg) call ncdefvar3d(LVL_remin_sulf(iogrp),cmpflg,'p', & & 'reminslvl','Sulfate remineralization rate',' ', & & 'mol P m-3 s-1',2) -#endif + endif if(lm4ago)then ! M4AGO call ncdefvar3d(LVL_agg_ws(iogrp),cmpflg,'p', & @@ -1978,49 +1971,49 @@ subroutine hamoccvardef(iogrp,timeunits,calendar,cmpflg) & cmpflg,'p','bursil','Burial silicate',' ','mol Si m-2',4) call ncdefvar3d(BUR_SSSTER(iogrp), & & cmpflg,'p','burter','Burial clay',' ','kg m-2',4) + if (use_extNcycle) then + call ncdefvar3d(SDM_POWNH4(iogrp),cmpflg,'p', & + & 'pownh4','PoWa ammonium',' ','mol N m-3',3) + call ncdefvar3d(SDM_POWN2O(iogrp),cmpflg,'p', & + & 'pown2o','PoWa nitrous oxide',' ','mol N m-3',3) + call ncdefvar3d(SDM_POWNO2(iogrp),cmpflg,'p', & + & 'powno2','PoWa nitrite',' ','mol N m-3',3) + call ncdefvar3d(sdm_nitr_NH4(iogrp),cmpflg,'p', & + & 'nh4nitrsdm','NH4 nitrification rate sediment',' ','mol N m-3 s-1',3) + call ncdefvar3d(sdm_nitr_NO2(iogrp),cmpflg,'p', & + & 'no2nitrsdm','NO2 nitrification rate sediment',' ','mol N m-3 s-1',3) + call ncdefvar3d(sdm_nitr_N2O_prod(iogrp),cmpflg,'p', & + & 'nitr_n2osdm','N2O prod during NH4 nitrification sediment',' ', & + & 'mol N2O m-3 s-1',3) + call ncdefvar3d(sdm_nitr_NH4_OM(iogrp),cmpflg,'p', & + & 'nh4nitr_omsdm','OM production during NH4 nitrification sediment',' ', & + & 'mol P m-3 s-1',3) + call ncdefvar3d(sdm_nitr_NO2_OM(iogrp),cmpflg,'p', & + & 'no2nitr_omsdm','OM production during NO2 nitrification sediment',' ', & + & 'mol P m-3 s-1',3) + call ncdefvar3d(sdm_denit_NO3(iogrp),cmpflg,'p', & + & 'no3denitsdm','NO3 denitrification rate sediment',' ','mol N m-3 s-1',3) + call ncdefvar3d(sdm_denit_NO2(iogrp),cmpflg,'p', & + & 'no2denitsdm','NO2 denitrification rate sediment',' ','mol N m-3 s-1',3) + call ncdefvar3d(sdm_denit_N2O(iogrp),cmpflg,'p', & + & 'n2odenitsdm','N2O denitrification rate sediment',' ', & + & 'mol N2O m-3 s-1',3) + call ncdefvar3d(sdm_DNRA_NO2(iogrp),cmpflg,'p', & + & 'no2dnrasdm','NO2 DNRA rate sediment',' ','mol N m-3 s-1',3) + call ncdefvar3d(sdm_anmx_N2_prod(iogrp),cmpflg,'p', & + & 'anmx_n2sdm','Anammox N2 production rate sediment',' ', & + & 'mol N2 m-3 s-1',3) + call ncdefvar3d(sdm_anmx_OM_prod(iogrp),cmpflg,'p', & + & 'anmx_omsdm','Anammox OM production rate sediment',' ', & + & 'mol P m-3 s-1',3) + call ncdefvar3d(sdm_remin_aerob(iogrp),cmpflg,'p', & + & 'reminasdm','Aerob remineralization rate sediment',' ', & + & 'mol N m-3 s-1',3) + call ncdefvar3d(sdm_remin_sulf(iogrp),cmpflg,'p', & + & 'reminssdm','Sulfate remineralization rate sediment',' ', & + & 'mol P m-3 s-1',3) + endif endif -#if defined(extNcycle) && ! defined(sedbypass) - call ncdefvar3d(SDM_POWNH4(iogrp),cmpflg,'p', & - & 'pownh4','PoWa ammonium',' ','mol N m-3',3) - call ncdefvar3d(SDM_POWN2O(iogrp),cmpflg,'p', & - & 'pown2o','PoWa nitrous oxide',' ','mol N m-3',3) - call ncdefvar3d(SDM_POWNO2(iogrp),cmpflg,'p', & - & 'powno2','PoWa nitrite',' ','mol N m-3',3) - call ncdefvar3d(sdm_nitr_NH4(iogrp),cmpflg,'p', & - & 'nh4nitrsdm','NH4 nitrification rate sediment',' ','mol N m-3 s-1',3) - call ncdefvar3d(sdm_nitr_NO2(iogrp),cmpflg,'p', & - & 'no2nitrsdm','NO2 nitrification rate sediment',' ','mol N m-3 s-1',3) - call ncdefvar3d(sdm_nitr_N2O_prod(iogrp),cmpflg,'p', & - & 'nitr_n2osdm','N2O prod during NH4 nitrification sediment',' ', & - & 'mol N2O m-3 s-1',3) - call ncdefvar3d(sdm_nitr_NH4_OM(iogrp),cmpflg,'p', & - & 'nh4nitr_omsdm','OM production during NH4 nitrification sediment',' ', & - & 'mol P m-3 s-1',3) - call ncdefvar3d(sdm_nitr_NO2_OM(iogrp),cmpflg,'p', & - & 'no2nitr_omsdm','OM production during NO2 nitrification sediment',' ', & - & 'mol P m-3 s-1',3) - call ncdefvar3d(sdm_denit_NO3(iogrp),cmpflg,'p', & - & 'no3denitsdm','NO3 denitrification rate sediment',' ','mol N m-3 s-1',3) - call ncdefvar3d(sdm_denit_NO2(iogrp),cmpflg,'p', & - & 'no2denitsdm','NO2 denitrification rate sediment',' ','mol N m-3 s-1',3) - call ncdefvar3d(sdm_denit_N2O(iogrp),cmpflg,'p', & - & 'n2odenitsdm','N2O denitrification rate sediment',' ', & - & 'mol N2O m-3 s-1',3) - call ncdefvar3d(sdm_DNRA_NO2(iogrp),cmpflg,'p', & - & 'no2dnrasdm','NO2 DNRA rate sediment',' ','mol N m-3 s-1',3) - call ncdefvar3d(sdm_anmx_N2_prod(iogrp),cmpflg,'p', & - & 'anmx_n2sdm','Anammox N2 production rate sediment',' ', & - & 'mol N2 m-3 s-1',3) - call ncdefvar3d(sdm_anmx_OM_prod(iogrp),cmpflg,'p', & - & 'anmx_omsdm','Anammox OM production rate sediment',' ', & - & 'mol P m-3 s-1',3) - call ncdefvar3d(sdm_remin_aerob(iogrp),cmpflg,'p', & - & 'reminasdm','Aerob remineralization rate sediment',' ', & - & 'mol N m-3 s-1',3) - call ncdefvar3d(sdm_remin_sulf(iogrp),cmpflg,'p', & - & 'reminssdm','Sulfate remineralization rate sediment',' ', & - & 'mol P m-3 s-1',3) -#endif ! --- enddef netcdf file call ncedef diff --git a/hamocc/mo_ocprod.F90 b/hamocc/mo_ocprod.F90 index c9a7705d..465df46b 100644 --- a/hamocc/mo_ocprod.F90 +++ b/hamocc/mo_ocprod.F90 @@ -81,28 +81,27 @@ subroutine ocprod(kpie,kpje,kpke,kbnd,pdlxp,pdlyp,pddpo,omask,ptho,pi_ph,psao,pp carflx0100,carflx0500,carflx1000,carflx2000,carflx4000,carflx_bot, & expoor,exposi,expoca,intdnit,intdms_bac,intdmsprod,intdms_uv, & intphosy,int_chbr3_prod,int_chbr3_uv, & - phosy3d,abs_oce,strahl,asize3d,wmass,wnumb,eps3d + phosy3d,abs_oce,strahl,asize3d,wmass,wnumb,eps3d,phosy_NH4, & + phosy_NO3, remin_aerob,remin_sulf use mo_param1_bgc, only: ialkali,ian2o,iano3,icalc,idet,idms,idoc,ifdust, & igasnit,iiron,iopal,ioxygen,iphosph,iphy,isco212, & isilica,izoo,iadust,inos,ibromo, & icalc13,icalc14,idet13,idet14,idoc13,idoc14, & iphy13,iphy14,isco213,isco214,izoo13,izoo14,safediv, & - inatalkali,inatcalc,inatsco212 + inatalkali,inatcalc,inatsco212,ianh4 use mo_control_bgc, only: dtb,io_stdo_bgc,with_dmsph, & use_BROMO,use_AGG,use_PBGC_OCNP_TIMESTEP,use_FB_BGC_OCE, & - use_AGG,use_cisonew,use_natDIC, use_WLIN,use_sedbypass,lm4ago + use_AGG,use_cisonew,use_natDIC, use_WLIN,use_sedbypass,lm4ago, & + use_extNcycle use mo_vgrid, only: dp_min,dp_min_sink,k0100,k0500,k1000,k2000,k4000,kwrbioz,ptiestu use mo_vgrid, only: kmle use mo_clim_swa, only: swa_clim use mo_inventory_bgc, only: inventory_bgc use mo_m4ago, only: mean_aggregate_sinking_speed,ws_agg,POM_remin_q10,POM_remin_Tref, & opal_remin_q10,opal_remin_Tref -#ifdef extNcycle - use mo_extNwatercol,only: nitrification,denit_NO3_to_NO2,anammox,denit_dnra,extN_inv_check - use mo_extNwatercol,only: bkphyanh4,bkphyano3,bkphosph,bkiron,ro2utammo - use mo_param1_bgc, only: ianh4 - use mo_biomod, only: phosy_NH4, phosy_NO3, remin_aerob,remin_sulf -#endif + use mo_extNwatercol, only: nitrification,denit_NO3_to_NO2,anammox,denit_dnra,extN_inv_check + use mo_extNwatercol, only: bkphyanh4,bkphyano3,bkphosph,bkiron,ro2utammo + ! Arguments integer, intent(in) :: kpie ! 1st dimension of model grid. @@ -178,10 +177,9 @@ subroutine ocprod(kpie,kpje,kpke,kbnd,pdlxp,pdlyp,pddpo,omask,ptho,pi_ph,psao,pp ! BROMO real :: bro_beta,bro_uv real :: abs_uv(kpie,kpje,kpke) -#ifdef extNcycle + ! extNcycle character(len=:), allocatable :: inv_message - real :: ano3up_inh,nutlim,anh4lim,nlim,grlim,nh4uptfrac -#endif + real :: ano3up_inh,nutlim,anh4lim,nlim,grlim,nh4uptfrac ! set variables for diagnostic output to zero expoor (:,:) = 0. @@ -217,12 +215,12 @@ subroutine ocprod(kpie,kpje,kpke,kbnd,pdlxp,pdlyp,pddpo,omask,ptho,pi_ph,psao,pp eps3d(:,:,:) = 0. asize3d(:,:,:) = 0. endif -#ifdef extNcycle + if (use_extNcycle) then phosy_NH4(:,:,:) = 0. phosy_NO3(:,:,:) = 0. remin_aerob(:,:,:) = 0. remin_sulf(:,:,:) = 0. -#endif + endif if (use_PBGC_OCNP_TIMESTEP) then if (mnproc == 1) then @@ -285,8 +283,8 @@ subroutine ocprod(kpie,kpje,kpke,kbnd,pdlxp,pdlyp,pddpo,omask,ptho,pi_ph,psao,pp !$OMP END PARALLEL DO if (lm4ago) then - ! even though we loose detritus, etc. we call the calculation for settling velocity by M4AGO here - ! to enable further future development... - assuming that the operator splitting decently functions + ! even though we loose detritus, etc. we call the calculation for settling velocity by M4AGO here + ! to enable further future development... - assuming that the operator splitting decently functions call mean_aggregate_sinking_speed(kpie, kpje, kpke, kbnd, pddpo, omask, ptho, psao, ppao, prho) endif @@ -302,9 +300,7 @@ subroutine ocprod(kpie,kpje,kpke,kbnd,pdlxp,pdlyp,pddpo,omask,ptho,pi_ph,psao,pp !$OMP ,delcar13,delcar14,dtr13,dtr14,bifr13,bifr14,bifr13_perm & !$OMP ,growth_co2,phygrowth & !$OMP ,bro_beta,bro_uv & -#ifdef extNcycle - !$OMP , ano3up_inh,nutlim,anh4lim,nlim,grlim,nh4uptfrac & -#endif + !$OMP ,ano3up_inh,nutlim,anh4lim,nlim,grlim,nh4uptfrac & !$OMP ,i,k) loop1: do j = 1,kpje @@ -329,28 +325,29 @@ subroutine ocprod(kpie,kpje,kpke,kbnd,pdlxp,pdlyp,pddpo,omask,ptho,pi_ph,psao,pp avgra = max(grami,ocetra(i,j,k,izoo)) ! 'available' zooplankton avsil = max(0.,ocetra(i,j,k,isilica)) avdic = max(0.,ocetra(i,j,k,isco212)) -#ifdef extNcycle - ano3up_inh = bkphyanh4/(bkphyanh4 + ocetra(i,j,k,ianh4)) ! inhibition of NO3 uptake - nutlim = min(ocetra(i,j,k,iphosph)/(ocetra(i,j,k,iphosph)+bkphosph),ocetra(i,j,k,iiron)/(ocetra(i,j,k,iiron)+bkiron)) + if (use_extNcycle)then + ano3up_inh = bkphyanh4/(bkphyanh4 + ocetra(i,j,k,ianh4)) ! inhibition of NO3 uptake + nutlim = min(ocetra(i,j,k,iphosph)/(ocetra(i,j,k,iphosph)+bkphosph), & + ocetra(i,j,k,iiron)/(ocetra(i,j,k,iiron)+bkiron)) anh4lim = ocetra(i,j,k,ianh4)/(ocetra(i,j,k,ianh4) + bkphyanh4) nlim = ano3up_inh*ocetra(i,j,k,iano3)/(ocetra(i,j,k,iano3) + bkphyano3) + anh4lim grlim = min(nutlim,nlim) ! growth limitation nh4uptfrac = 1. - if(nlim .gt. 1.e-18) nh4uptfrac = anh4lim/nlim + if(nlim .gt. 1.e-18) nh4uptfrac = anh4lim/nlim ! re-check avnut - can sum N avail exceed indiv. contrib? avanut = max(0.,min(ocetra(i,j,k,iphosph), ocetra(i,j,k,iiron)/riron, & & rnoi*((1.-nh4uptfrac)*ocetra(i,j,k,iano3) + nh4uptfrac*ocetra(i,j,k,ianh4)))) - xn = avphy/(1. - pho*grlim) ! phytoplankton growth + xn = avphy/(1. - pho*grlim) ! phytoplankton growth phosy = max(0.,min(xn-avphy,avanut)) ! limit PP growth to available nutr. -#else - avanut = max(0.,min(ocetra(i,j,k,iphosph),rnoi*ocetra(i,j,k,iano3))) - avanfe = max(0.,min(avanut,ocetra(i,j,k,iiron)/riron)) - xa = avanfe - xn = xa/(1.+pho*avphy/(xa+bkphy)) - phosy = max(0.,xa-xn) -#endif + else + avanut = max(0.,min(ocetra(i,j,k,iphosph),rnoi*ocetra(i,j,k,iano3))) + avanfe = max(0.,min(avanut,ocetra(i,j,k,iiron)/riron)) + xa = avanfe + xn = xa/(1.+pho*avphy/(xa+bkphy)) + phosy = max(0.,xa-xn) + endif phosy = MERGE(avdic/rcar, phosy, avdic <= rcar*phosy) ! limit phosy by available DIC ya = avphy+phosy yn = (ya+grazra*avgra*phytomi/(avphy+bkzoo))/(1.+grazra*avgra/(avphy+bkzoo)) @@ -450,16 +447,16 @@ subroutine ocprod(kpie,kpje,kpke,kbnd,pdlxp,pdlyp,pddpo,omask,ptho,pi_ph,psao,pp dtr = bacfra-phosy+graton+ecan*zoomor ocetra(i,j,k,iphosph) = ocetra(i,j,k,iphosph)+dtr -#ifndef extNcycle + if (.not. use_extNcycle) then ocetra(i,j,k,iano3) = ocetra(i,j,k,iano3)+dtr*rnit ocetra(i,j,k,ialkali) = ocetra(i,j,k,ialkali)-2.*delcar-(rnit+1)*dtr ocetra(i,j,k,ioxygen) = ocetra(i,j,k,ioxygen)-dtr*ro2ut -#else + else ocetra(i,j,k,iano3) = ocetra(i,j,k,iano3) - (1.-nh4uptfrac)*phosy*rnit ocetra(i,j,k,ianh4) = ocetra(i,j,k,ianh4) - nh4uptfrac*phosy*rnit + (dtr+phosy)*rnit - ocetra(i,j,k,ialkali) = ocetra(i,j,k,ialkali) - nh4uptfrac*phosy*(rnit-1.) & ! NH4 + PO4 Uptake + ocetra(i,j,k,ialkali) = ocetra(i,j,k,ialkali) - nh4uptfrac*phosy*(rnit-1.) & ! NH4 + PO4 Uptake & + (1.-nh4uptfrac)*phosy*(rnit+1.) & ! NO3 + PO4 Uptake - & + (dtr+phosy)*(rnit-1.) - 2.*delcar ! Remin to (NH4 + PO4) and CaCO3 formation + & + (dtr+phosy)*(rnit-1.) - 2.*delcar ! Remin to (NH4 + PO4) and CaCO3 formation ocetra(i,j,k,ioxygen) = ocetra(i,j,k,ioxygen) + nh4uptfrac*phosy*ro2utammo & ! NH4 uptake & + (1.-nh4uptfrac)*phosy*ro2ut & ! NO3 uptake & - (dtr+phosy)*ro2utammo ! Remin to NH4 @@ -467,7 +464,7 @@ subroutine ocprod(kpie,kpje,kpke,kbnd,pdlxp,pdlyp,pddpo,omask,ptho,pi_ph,psao,pp phosy_NH4(i,j,k) = nh4uptfrac*phosy*rnit ! kmol N/m3/dtb - NH4 uptake during PP growth phosy_NO3(i,j,k) = (1.-nh4uptfrac)*phosy*rnit ! kmol N/m3/dtb - NO3 uptake during PP growth remin_aerob(i,j,k) = (dtr+phosy)*rnit ! kmol N/m3/dtb - Aerob remin to ammonium (var. sources) -#endif + endif ocetra(i,j,k,idet) = ocetra(i,j,k,idet)+export ocetra(i,j,k,idms) = ocetra(i,j,k,idms)+dmsprod-dms_bac-dms_uv ocetra(i,j,k,isco212) = ocetra(i,j,k,isco212)-delcar+rcar*dtr @@ -635,27 +632,27 @@ subroutine ocprod(kpie,kpje,kpke,kbnd,pdlxp,pdlyp,pddpo,omask,ptho,pi_ph,psao,pp if(ocetra(i,j,k,ioxygen) > 5.e-8) then if(lm4ago) then -#ifndef extNcycle + if (.not. use_extNcycle) then ! M4AGO comes with O2-lim o2lim = ocetra(i,j,k,ioxygen)/(ocetra(i,j,k,ioxygen) + bkox_drempoc) pocrem = o2lim*drempoc*POM_remin_q10**((ptho(i,j,k)-POM_remin_Tref)/10.)*ocetra(i,j,k,idet) -#else - ! nitrogen always accounts for O2-lim - see below + else + ! nitrogen always accounts for O2-lim - see below pocrem = drempoc*POM_remin_q10**((ptho(i,j,k)-POM_remin_Tref)/10.)*ocetra(i,j,k,idet) -#endif + endif else pocrem = drempoc*ocetra(i,j,k,idet) - endif -#ifndef extNcycle - pocrem = MIN(pocrem,0.33*ocetra(i,j,k,ioxygen)/ro2ut) - docrem = MIN( remido*ocetra(i,j,k,idoc),0.33*ocetra(i,j,k,ioxygen)/ro2ut) - phyrem = MIN(0.5*dyphy*phythresh, 0.33*ocetra(i,j,k,ioxygen)/ro2ut) -#else + endif + if (.not. use_extNcycle) then + pocrem = min(pocrem,0.33*ocetra(i,j,k,ioxygen)/ro2ut) + docrem = min( remido*ocetra(i,j,k,idoc),0.33*ocetra(i,j,k,ioxygen)/ro2ut) + phyrem = min(0.5*dyphy*phythresh, 0.33*ocetra(i,j,k,ioxygen)/ro2ut) + else o2lim = ocetra(i,j,k,ioxygen)/(ocetra(i,j,k,ioxygen) + bkox_drempoc) - pocrem = MIN(o2lim*pocrem,0.33*ocetra(i,j,k,ioxygen)/ro2utammo) - docrem = MIN(remido*ocetra(i,j,k,idoc),0.33*ocetra(i,j,k,ioxygen)/ro2utammo) - phyrem = MIN(0.5*dyphy*phythresh, 0.33*ocetra(i,j,k,ioxygen)/ro2utammo) -#endif + pocrem = min(o2lim*pocrem,0.33*ocetra(i,j,k,ioxygen)/ro2utammo) + docrem = min(remido*ocetra(i,j,k,idoc),0.33*ocetra(i,j,k,ioxygen)/ro2utammo) + phyrem = min(0.5*dyphy*phythresh, 0.33*ocetra(i,j,k,ioxygen)/ro2utammo) + endif if (use_cisonew) then pocrem13 = pocrem*rdet13 @@ -686,17 +683,17 @@ subroutine ocprod(kpie,kpje,kpke,kbnd,pdlxp,pdlyp,pddpo,omask,ptho,pi_ph,psao,pp remin = pocrem + docrem + phyrem ocetra(i,j,k,iphosph) = ocetra(i,j,k,iphosph)+remin -#ifndef extNcycle + if (.not. use_extNcycle) then ocetra(i,j,k,iano3) = ocetra(i,j,k,iano3)+remin*rnit ocetra(i,j,k,ialkali) = ocetra(i,j,k,ialkali)-(rnit+1)*remin ocetra(i,j,k,ioxygen) = ocetra(i,j,k,ioxygen)-ro2ut*remin -#else + else ocetra(i,j,k,ianh4) = ocetra(i,j,k,ianh4) + remin*rnit ocetra(i,j,k,ialkali) = ocetra(i,j,k,ialkali) + (rnit-1.)*remin ocetra(i,j,k,ioxygen) = ocetra(i,j,k,ioxygen) - ro2utammo*remin remin_aerob(i,j,k) = remin*rnit ! kmol/NH4/dtb - remin to NH4 from various sources -#endif - ocetra(i,j,k,isco212) = ocetra(i,j,k,isco212)+rcar*remin + endif + ocetra(i,j,k,isco212) = ocetra(i,j,k,isco212)+rcar*remin ocetra(i,j,k,iiron) = ocetra(i,j,k,iiron)+remin*riron & & -relaxfe*max(ocetra(i,j,k,iiron)-fesoly,0.) if (use_natDIC) then @@ -720,25 +717,25 @@ subroutine ocprod(kpie,kpje,kpke,kbnd,pdlxp,pdlyp,pddpo,omask,ptho,pi_ph,psao,pp ! so the expression dremopal*(Si(OH)4sat-Si(OH)4) would change the ! rate only from 0 to 100% !*********************************************************************** - if(lm4ago)then + if (lm4ago) then opalrem = dremopal*opal_remin_q10**((ptho(i,j,k)-opal_remin_Tref)/10.)*ocetra(i,j,k,iopal) else opalrem = dremopal*0.1*(temp+3.)*ocetra(i,j,k,iopal) - endif + endif ocetra(i,j,k,iopal) = ocetra(i,j,k,iopal)-opalrem ocetra(i,j,k,isilica) = ocetra(i,j,k,isilica)+opalrem -#ifndef extNcycle - !*********************************************************************** - ! There is about 1.e4 O2 on 1 N2O molecule (Broeker&Peng) - ! refra : Tim Rixton, private communication - !*********************************************************************** - aou = satoxy(i,j,k)-ocetra(i,j,k,ioxygen) - refra = 1.+3.*(0.5+sign(0.5,aou-1.97e-4)) - ocetra(i,j,k,ian2o) = ocetra(i,j,k,ian2o)+remin*1.e-4*ro2ut*refra - ocetra(i,j,k,igasnit) = ocetra(i,j,k,igasnit)-remin*1.e-4*ro2ut*refra - ocetra(i,j,k,ioxygen) = ocetra(i,j,k,ioxygen)-remin*1.e-4*ro2ut*refra*0.5 -#endif + if (.not. use_extNcycle) then + !*********************************************************************** + ! There is about 1.e4 O2 on 1 N2O molecule (Broeker&Peng) + ! refra : Tim Rixton, private communication + !*********************************************************************** + aou = satoxy(i,j,k)-ocetra(i,j,k,ioxygen) + refra = 1.+3.*(0.5+sign(0.5,aou-1.97e-4)) + ocetra(i,j,k,ian2o) = ocetra(i,j,k,ian2o)+remin*1.e-4*ro2ut*refra + ocetra(i,j,k,igasnit) = ocetra(i,j,k,igasnit)-remin*1.e-4*ro2ut*refra + ocetra(i,j,k,ioxygen) = ocetra(i,j,k,ioxygen)-remin*1.e-4*ro2ut*refra*0.5 + endif dms_bac = dmsp3 * dtb * abs(temp+3.) * ocetra(i,j,k,idms) & & * (ocetra(i,j,k,idms) / (dmsp6+ocetra(i,j,k,idms))) @@ -780,93 +777,92 @@ subroutine ocprod(kpie,kpje,kpke,kbnd,pdlxp,pdlyp,pddpo,omask,ptho,pi_ph,psao,pp call inventory_bgc(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask,0) endif -#ifndef extNcycle -! =====>>>> Regular CMIP6 iHAMOCC version for denitrification wo extended nitrogen cycle =====>>>> - !$OMP PARALLEL DO PRIVATE(remin,remin2o,dz,avmass,avnos,rem13,rem14,i,k) - loop3: do j = 1,kpje - do i = 1,kpie - do k = kwrbioz(i,j)+1,kpke - if(omask(i,j) > 0.5) then - if(ocetra(i,j,k,ioxygen) < 5.e-7 .and. pddpo(i,j,k) > dp_min) then - if (use_AGG) then - avmass = ocetra(i,j,k,iphy) + ocetra(i,j,k,idet) - endif + if (.not. use_extNcycle) then + ! =====>>>> Regular CMIP6 iHAMOCC version for denitrification wo extended nitrogen cycle =====>>>> + !$OMP PARALLEL DO PRIVATE(remin,remin2o,dz,avmass,avnos,rem13,rem14,i,k) + loop3: do j = 1,kpje + do i = 1,kpie + do k = kwrbioz(i,j)+1,kpke + if(omask(i,j) > 0.5) then + if(ocetra(i,j,k,ioxygen) < 5.e-7 .and. pddpo(i,j,k) > dp_min) then + if (use_AGG) then + avmass = ocetra(i,j,k,iphy) + ocetra(i,j,k,idet) + endif - remin = drempoc_anaerob*min(ocetra(i,j,k,idet),0.5 *ocetra(i,j,k,iano3)/rdnit1) - remin2o = dremn2o*min(ocetra(i,j,k,idet),0.003 *ocetra(i,j,k,ian2o)/rdn2o1) + remin = drempoc_anaerob*min(ocetra(i,j,k,idet),0.5 *ocetra(i,j,k,iano3)/rdnit1) + remin2o = dremn2o*min(ocetra(i,j,k,idet),0.003 *ocetra(i,j,k,ian2o)/rdn2o1) - if (use_cisonew) then - rem13 = (remin+remin2o)*ocetra(i,j,k,idet13)/(ocetra(i,j,k,idet)+safediv) - rem14 = (remin+remin2o)*ocetra(i,j,k,idet14)/(ocetra(i,j,k,idet)+safediv) - endif - ocetra(i,j,k,ialkali) = ocetra(i,j,k,ialkali)+(rdnit1-1)*remin-remin2o - ocetra(i,j,k,isco212) = ocetra(i,j,k,isco212)+rcar*(remin+remin2o) - ocetra(i,j,k,idet) = ocetra(i,j,k,idet)-(remin+remin2o) - ocetra(i,j,k,iphosph) = ocetra(i,j,k,iphosph)+(remin+remin2o) - ocetra(i,j,k,iano3) = ocetra(i,j,k,iano3)-rdnit1*remin - ocetra(i,j,k,igasnit) = ocetra(i,j,k,igasnit)+rdnit2*remin+rdn2o2*remin2o - ocetra(i,j,k,iiron) = ocetra(i,j,k,iiron)+riron*(remin+remin2o) - ocetra(i,j,k,ian2o) = ocetra(i,j,k,ian2o)-rdn2o1*remin2o - if (use_natDIC) then - ocetra(i,j,k,inatalkali) = ocetra(i,j,k,inatalkali)+(rdnit1-1)*remin-remin2o - ocetra(i,j,k,inatsco212) = ocetra(i,j,k,inatsco212)+rcar*(remin+remin2o) - endif - if (use_cisonew) then - ocetra(i,j,k,isco213) = ocetra(i,j,k,isco213)+rcar*rem13 - ocetra(i,j,k,isco214) = ocetra(i,j,k,isco214)+rcar*rem14 - ocetra(i,j,k,idet13) = ocetra(i,j,k,idet13)-rem13 - ocetra(i,j,k,idet14) = ocetra(i,j,k,idet14)-rem14 - endif + if (use_cisonew) then + rem13 = (remin+remin2o)*ocetra(i,j,k,idet13)/(ocetra(i,j,k,idet)+safediv) + rem14 = (remin+remin2o)*ocetra(i,j,k,idet14)/(ocetra(i,j,k,idet)+safediv) + endif + ocetra(i,j,k,ialkali) = ocetra(i,j,k,ialkali)+(rdnit1-1)*remin-remin2o + ocetra(i,j,k,isco212) = ocetra(i,j,k,isco212)+rcar*(remin+remin2o) + ocetra(i,j,k,idet) = ocetra(i,j,k,idet)-(remin+remin2o) + ocetra(i,j,k,iphosph) = ocetra(i,j,k,iphosph)+(remin+remin2o) + ocetra(i,j,k,iano3) = ocetra(i,j,k,iano3)-rdnit1*remin + ocetra(i,j,k,igasnit) = ocetra(i,j,k,igasnit)+rdnit2*remin+rdn2o2*remin2o + ocetra(i,j,k,iiron) = ocetra(i,j,k,iiron)+riron*(remin+remin2o) + ocetra(i,j,k,ian2o) = ocetra(i,j,k,ian2o)-rdn2o1*remin2o + if (use_natDIC) then + ocetra(i,j,k,inatalkali) = ocetra(i,j,k,inatalkali)+(rdnit1-1)*remin-remin2o + ocetra(i,j,k,inatsco212) = ocetra(i,j,k,inatsco212)+rcar*(remin+remin2o) + endif + if (use_cisonew) then + ocetra(i,j,k,isco213) = ocetra(i,j,k,isco213)+rcar*rem13 + ocetra(i,j,k,isco214) = ocetra(i,j,k,isco214)+rcar*rem14 + ocetra(i,j,k,idet13) = ocetra(i,j,k,idet13)-rem13 + ocetra(i,j,k,idet14) = ocetra(i,j,k,idet14)-rem14 + endif - ! nitrate loss through denitrification in kmol N m-2 - dz = pddpo(i,j,k) - intdnit(i,j) = intdnit(i,j) + rdnit0*remin*dz + ! nitrate loss through denitrification in kmol N m-2 + dz = pddpo(i,j,k) + intdnit(i,j) = intdnit(i,j) + rdnit0*remin*dz - if (use_AGG) then - !*********************************************************************** - ! loss of snow numbers due to remineralization of poc - ! NOTE that remin is in kmol/m3. Thus divide by avmass (kmol/m3) - !*********************************************************************** - if(avmass > 0.) then - avnos = ocetra(i,j,k,inos) - ocetra(i,j,k,inos) = ocetra(i,j,k,inos)-(remin+remin2o)*avnos/avmass - endif - endif/*AGG*/ + if (use_AGG) then + !*********************************************************************** + ! loss of snow numbers due to remineralization of poc + ! NOTE that remin is in kmol/m3. Thus divide by avmass (kmol/m3) + !*********************************************************************** + if(avmass > 0.) then + avnos = ocetra(i,j,k,inos) + ocetra(i,j,k,inos) = ocetra(i,j,k,inos)-(remin+remin2o)*avnos/avmass + endif + endif/*AGG*/ + endif endif - endif + enddo enddo - enddo - enddo loop3 - !$OMP END PARALLEL DO - + enddo loop3 + !$OMP END PARALLEL DO - if (use_PBGC_OCNP_TIMESTEP) then - if (mnproc == 1) then - write(io_stdo_bgc,*)' ' - write(io_stdo_bgc,*)'in OCRPOD after remin n2o' + if (use_PBGC_OCNP_TIMESTEP) then + if (mnproc == 1) then + write(io_stdo_bgc,*)' ' + write(io_stdo_bgc,*)'in OCRPOD after remin n2o' + endif + call inventory_bgc(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask,0) endif - call inventory_bgc(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask,0) + ! <<<<===== end of CMIP6 version denitrification processes without extended nitrogen cycle <<<<===== + else + !======>>>> extended nitrogen cycle processes (aerobic and anaerobic) that follow ammonification + inv_message = 'in OCPROD after extNcycle nitrification' + call nitrification(kpie,kpje,kpke,kbnd,pddpo,omask,ptho) + call extN_inv_check(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask,inv_message) + + inv_message = 'in OCPROD after extNcycle denitrification NO3 -> NO2' + call denit_NO3_to_NO2(kpie,kpje,kpke,kbnd,pddpo,omask,ptho) + call extN_inv_check(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask,inv_message) + + inv_message = 'in OCPROD after extNcycle anammox' + call anammox(kpie,kpje,kpke,kbnd,pddpo,omask,ptho) + call extN_inv_check(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask,inv_message) + + inv_message = 'in OCPROD after extNcycle denitrification / DNRA' + call denit_dnra(kpie,kpje,kpke,kbnd,pddpo,omask,ptho) + call extN_inv_check(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask,inv_message) endif -! <<<<===== end of CMIP6 version denitrification processes without extended nitrogen cycle <<<<===== -#else - !======>>>> extended nitrogen cycle processes (aerobic and anaerobic) that follow ammonification - inv_message = 'in OCPROD after extNcycle nitrification' - CALL nitrification(kpie,kpje,kpke,kbnd,pddpo,omask,ptho) - CALL extN_inv_check(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask,inv_message) - - inv_message = 'in OCPROD after extNcycle denitrification NO3 -> NO2' - CALL denit_NO3_to_NO2(kpie,kpje,kpke,kbnd,pddpo,omask,ptho) - CALL extN_inv_check(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask,inv_message) - - inv_message = 'in OCPROD after extNcycle anammox' - CALL anammox(kpie,kpje,kpke,kbnd,pddpo,omask,ptho) - CALL extN_inv_check(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask,inv_message) - - inv_message = 'in OCPROD after extNcycle denitrification / DNRA' - CALL denit_dnra(kpie,kpje,kpke,kbnd,pddpo,omask,ptho) - CALL extN_inv_check(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask,inv_message) -#endif !sulphate reduction ! introduced 11.5.2007 to improve poc-remineralisation in the ! oxygen minimum zone in the subsurface equatorial Pacific @@ -907,10 +903,10 @@ subroutine ocprod(kpie,kpje,kpke,kbnd,pdlxp,pdlyp,pddpo,omask,ptho,pi_ph,psao,pp ocetra(i,j,k,isco213) = ocetra(i,j,k,isco213)+rcar*rem13 ocetra(i,j,k,isco214) = ocetra(i,j,k,isco214)+rcar*rem14 endif -#ifdef extNcycle - ! Output - remin_sulf(i,j,k) = remin ! kmol P/m3/dtb -#endif + if (use_extNcycle) then + ! Output + remin_sulf(i,j,k) = remin ! kmol P/m3/dtb + endif if (use_AGG) then !*********************************************************************** ! loss of snow numbers due to remineralization of poc diff --git a/hamocc/mo_param_bgc.F90 b/hamocc/mo_param_bgc.F90 index abb4cb14..f4e6dc3a 100644 --- a/hamocc/mo_param_bgc.F90 +++ b/hamocc/mo_param_bgc.F90 @@ -38,7 +38,6 @@ module mo_param_bgc use_BOXATM,use_CFC,use_PBGC_CK_TIMESTEP, & use_sedbypass,with_dmsph,use_PBGC_OCNP_TIMESTEP,ocn_co2_type,lm4ago, & leuphotic_cya,do_ndep_coupled,do_n2onh3_coupled,use_extNcycle - use mod_xc, only: mnproc ! use mo_m4ago, only: init_m4ago_nml_params, init_m4ago_params use mo_param1_bgc, only: iatmnh3,iatmn2o @@ -444,13 +443,13 @@ subroutine calc_param_biol() endif ! M4AGO parameters ! call init_m4ago_nml_params() -#ifdef extNcycle + if (use_extNcycle) then ! initialize the extended nitrogen cycle parameters - first water column, then sediment, ! since sediment relies on water column parameters for the extended nitrogen cycle ! Sediment also relies on M4AGO being initialized (POM_remin_q10 and POM_remin_Tref) ! call extNwatercol_param_init() ! call extNsediment_param_init() -#endif + endif end subroutine calc_param_biol !******************************************************************** @@ -530,10 +529,10 @@ subroutine rates_2_timestep() disso_poc = disso_poc * dtbgc ! 1/(kmol O2/m3 time step) Degradation rate constant of POP disso_caco3 = disso_caco3 * dtbgc ! 1/(kmol CO3--/m3 time step) Dissolution rate constant of CaCO3 sed_denit = sed_denit * dtbgc ! 1/time step Denitrification rate constant of POP -#ifdef extNcycle + if (use_extNcycle) then ! call extNwatercol_param_update() ! call extNsediment_param_update() -#endif + endif end subroutine rates_2_timestep !******************************************************************** @@ -770,10 +769,10 @@ subroutine write_parambgc() write(io_stdo_bgc,*) '* calcdens = ',calcdens write(io_stdo_bgc,*) '* claydens = ',claydens endif -#ifdef extNcycle + if (use_extNcycle) then ! call extNwatercol_param_write() ! call extNsediment_param_write() -#endif + endif end subroutine write_parambgc end module mo_param_bgc diff --git a/hamocc/mo_powach.F90 b/hamocc/mo_powach.F90 index 5b7825fc..10fb1f1a 100644 --- a/hamocc/mo_powach.F90 +++ b/hamocc/mo_powach.F90 @@ -32,10 +32,10 @@ subroutine powach(kpie,kpje,kpke,kbnd,prho,omask,psao,ptho,lspin) ! Modified: S.Legutke, *MPI-MaD, HH* 10.04.01 !*********************************************************************************************** - use mo_control_bgc, only: dtbgc,use_cisonew + use mo_control_bgc, only: dtbgc,use_cisonew,use_extNcycle use mo_param1_bgc, only: ioxygen,ipowaal,ipowaic,ipowaox,ipowaph,ipowasi,ipown2,ipowno3, & isilica,isssc12,issso12,issssil,issster,ks,ipowc13,ipowc14,isssc13, & - isssc14,issso13,issso14,safediv + isssc14,issso13,issso14,safediv,ipownh4 use mo_carbch, only: co3,keqb,ocetra,sedfluxo use mo_chemcon, only: calcon use mo_param_bgc, only: rnit,rcar,rdnit1,rdnit2,ro2ut,disso_sil,silsat,disso_poc,sed_denit, & @@ -46,13 +46,12 @@ subroutine powach(kpie,kpje,kpke,kbnd,prho,omask,psao,ptho,lspin) use mo_powadi, only: powadi use mo_carchm, only: carchm_solve use mo_dipowa, only: dipowa -#ifdef extNcycle - use mo_param1_bgc, only: ipownh4 + use mo_extNwatercol, only: ro2utammo use mo_extNsediment, only: extNsediment_param_init,sed_nitrification,sed_denit_NO3_to_NO2,sed_anammox,sed_denit_DNRA, & & extNsed_diagnostics,ised_remin_aerob,ised_remin_sulf,POM_remin_q10_sed,POM_remin_Tref_sed, & & bkox_drempoc_sed -#endif + ! Arguments integer, intent(in) :: kpie ! 1st dimension of model grid. @@ -62,7 +61,7 @@ subroutine powach(kpie,kpje,kpke,kbnd,prho,omask,psao,ptho,lspin) real, intent(in) :: prho(kpie,kpje,kpke) ! seawater density [g/cm^3]. real, intent(in) :: omask(kpie,kpje) ! land/ocean mask. real, intent(in) :: psao(1-kbnd:kpie+kbnd,1-kbnd:kpje+kbnd,kpke) ! salinity [psu]. - real, intent(in) :: ptho(1-kbnd:kpie+kbnd,1-kbnd:kpje+kbnd,kpke) ! Pot. temperature [deg C]. + real, intent(in) :: ptho(1-kbnd:kpie+kbnd,1-kbnd:kpje+kbnd,kpke) ! Pot. temperature [deg C]. logical, intent(in) :: lspin ! Local variables @@ -90,15 +89,15 @@ subroutine powach(kpie,kpje,kpke,kbnd,prho,omask,psao,ptho,lspin) ! RJ: This loop must go from 1 to kpje in the parallel version, ! otherways we had to do a boundary exchange - !$OMP PARALLEL DO & - !$OMP&PRIVATE(sedb1,sediso,solrat,powcar,aerob,anaerob, & - !$OMP& ex_dalk,ex_ddic,ex_disso_poc, & - !$OMP& dissot,undsa,posol, & - !$OMP& umfa,denit,saln,rrho,alk,c,sit,pt, & - !$OMP& K1,K2,Kb,Kw,Ks1,Kf,Ksi,K1p,K2p,K3p, & - !$OMP& ah1,ac,cu,cb,cc,satlev, & - !$OMP& ratc13,ratc14,rato13,rato14,poso13,poso14, & - !$OMP& k,i) + !$OMP PARALLEL DO & + !$OMP& PRIVATE(sedb1,sediso,solrat,powcar,aerob,anaerob, & + !$OMP& ex_dalk,ex_ddic,ex_disso_poc, & + !$OMP& dissot,undsa,posol, & + !$OMP& umfa,denit,saln,rrho,alk,c,sit,pt, & + !$OMP& K1,K2,Kb,Kw,Ks1,Kf,Ksi,K1p,K2p,K3p, & + !$OMP& ah1,ac,cu,cb,cc,satlev, & + !$OMP& ratc13,ratc14,rato13,rato14,poso13,poso14, & + !$OMP& k,i) j_loop: do j = 1, kpje @@ -106,12 +105,12 @@ subroutine powach(kpie,kpje,kpke,kbnd,prho,omask,psao,ptho,lspin) do i = 1, kpie solrat(i,k) = 0. powcar(i,k) = 0. -#ifndef extNcycle - anaerob(i,k)= 0. -#else - ex_ddic(i,k)=0. - ex_dalk(i,k)=0. -#endif + if (use_extNcycle) then + ex_ddic(i,k) = 0. + ex_dalk(i,k) = 0. + else + anaerob(i,k) = 0. + endif aerob(i,k) = 0. sulf(i,k) = 0. if (use_cisonew) then @@ -221,13 +220,13 @@ subroutine powach(kpie,kpje,kpke,kbnd,prho,omask,psao,ptho,lspin) if(omask(i,j) > 0.5) then undsa = powtra(i,j,1,ipowaox) sedb1(i,0) = bolay(i,j) * ocetra(i,j,kbo(i,j),ioxygen) -#ifndef extNcyce + if ( .not. use_extNcycle) then solrat(i,1) = ( sedlay(i,j,1,issso12) + prorca(i,j) & & / (porsol(i,j,1) * seddw(1)) ) & & * ro2ut * dissot / (1. + dissot * undsa) & & * porsol(i,j,1) / porwat(i,j,1) -#else - ! extended nitrogen cycle - 140mol O2/mol POP O2-consumption + else + ! extended nitrogen cycle - 140mol O2/mol POP O2-consumption ! O2 and T-dep ex_disso_poc = dissot * powtra(i,j,k,ipowaox)/(powtra(i,j,k,ipowaox) + bkox_drempoc_sed) & ! oxygen limitation & * POM_remin_q10_sed**((ptho(i,j,kbo(i,j))-POM_remin_Tref_sed)/10.) ! T-dep @@ -235,7 +234,7 @@ subroutine powach(kpie,kpje,kpke,kbnd,prho,omask,psao,ptho,lspin) & / (porsol(i,j,1) * seddw(1)) ) & & * ro2utammo * ex_disso_poc / (1. + ex_disso_poc * undsa) & & * porsol(i,j,1) / porwat(i,j,1) -#endif + endif endif enddo @@ -248,16 +247,16 @@ subroutine powach(kpie,kpje,kpke,kbnd,prho,omask,psao,ptho,lspin) if(omask(i,j) > 0.5) then undsa = powtra(i,j,k,ipowaox) sedb1(i,k) = seddw(k) * porwat(i,j,k) * powtra(i,j,k,ipowaox) -#ifndef extNcycle + if ( .not. use_extNcycle) then if (k > 1) solrat(i,k) = sedlay(i,j,k,issso12) * ro2ut * dissot & & / (1. + dissot*undsa) * porsol(i,j,k) / porwat(i,j,k) -#else - ! extended nitrogen cycle - 140mol O2/mol POP O2-consumption + else + ! extended nitrogen cycle - 140mol O2/mol POP O2-consumption ex_disso_poc = dissot * powtra(i,j,k,ipowaox)/(powtra(i,j,k,ipowaox) + bkox_drempoc_sed) & ! oxygen limitation & * POM_remin_q10_sed**((ptho(i,j,kbo(i,j))-POM_remin_Tref_sed)/10.) ! T-dep if (k > 1) solrat(i,k) = sedlay(i,j,k,issso12) * ro2utammo * ex_disso_poc & & / (1. + ex_disso_poc*undsa) * porsol(i,j,k) / porwat(i,j,k) -#endif + endif endif enddo enddo @@ -293,13 +292,13 @@ subroutine powach(kpie,kpje,kpke,kbnd,prho,omask,psao,ptho,lspin) do i = 1, kpie if(omask(i,j) > 0.5) then umfa = porsol(i,j,k) / porwat(i,j,k) -#ifndef extNcycle - solrat(i,k) = sedlay(i,j,k,issso12) * dissot/(1. + dissot*sediso(i,k)) -#else - ex_disso_poc = dissot * powtra(i,j,k,ipowaox)/(powtra(i,j,k,ipowaox) + bkox_drempoc_sed) & ! oxygen limitation - & * POM_remin_q10_sed**((ptho(i,j,kbo(i,j))-POM_remin_Tref_sed)/10.) ! T-dep - solrat(i,k) = sedlay(i,j,k,issso12) * ex_disso_poc/(1. + ex_disso_poc*sediso(i,k)) -#endif + if (.not. use_extNcycle) then + solrat(i,k) = sedlay(i,j,k,issso12) * dissot/(1. + dissot*sediso(i,k)) + else + ex_disso_poc = dissot * powtra(i,j,k,ipowaox)/(powtra(i,j,k,ipowaox) + bkox_drempoc_sed) & ! oxygen limitation + & * POM_remin_q10_sed**((ptho(i,j,kbo(i,j))-POM_remin_Tref_sed)/10.) ! T-dep + solrat(i,k) = sedlay(i,j,k,issso12) * ex_disso_poc/(1. + ex_disso_poc*sediso(i,k)) + endif posol = sediso(i,k)*solrat(i,k) if (use_cisonew) then rato13 = sedlay(i,j,k,issso13) / (sedlay(i,j,k,issso12) + safediv) @@ -311,15 +310,15 @@ subroutine powach(kpie,kpje,kpke,kbnd,prho,omask,psao,ptho,lspin) endif sedlay(i,j,k,issso12) = sedlay(i,j,k,issso12) - posol powtra(i,j,k,ipowaph) = powtra(i,j,k,ipowaph) + posol*umfa -#ifndef extNcycle + if (.not. use_extNcycle) then powtra(i,j,k,ipowno3) = powtra(i,j,k,ipowno3) + posol*rnit*umfa aerob(i,k) = posol*umfa !this has P units: kmol P/m3 of pore water -#else + else powtra(i,j,k,ipownh4) = powtra(i,j,k,ipownh4) + posol*rnit*umfa ex_ddic(i,k) = rcar*posol*umfa ! C-units kmol C/m3 of pore water ex_dalk(i,k) = (rnit-1.)*posol*umfa ! alkalinity units extNsed_diagnostics(i,j,k,ised_remin_aerob) = posol*rnit*umfa ! Output -#endif + endif powtra(i,j,k,ipowaox) = sediso(i,k) if (use_cisonew) then sedlay(i,j,k,issso13) = sedlay(i,j,k,issso13) - poso13 @@ -331,46 +330,45 @@ subroutine powach(kpie,kpje,kpke,kbnd,prho,omask,psao,ptho,lspin) ! Calculate nitrate reduction under anaerobic conditions explicitely !******************************************************************* -#ifndef extNcycle - ! Denitrification rate constant of POP (disso) [1/sec]*dtbgc - denit = sed_denit - - ! Store flux in array anaerob, for later computation of DIC and alkalinity. - do k = 1, ks - do i = 1, kpie - if(omask(i,j) > 0.5) then - if(powtra(i,j,k,ipowaox) < 1.e-6) then - posol = denit * min(0.25*powtra(i,j,k,ipowno3)/rdnit2, sedlay(i,j,k,issso12)) - umfa = porsol(i,j,k)/porwat(i,j,k) - anaerob(i,k) = posol*umfa !this has P units: kmol P/m3 of pore water - if (use_cisonew) then - rato13 = sedlay(i,j,k,issso13) / (sedlay(i,j,k,issso12) + safediv) - rato14 = sedlay(i,j,k,issso14) / (sedlay(i,j,k,issso12) + safediv) - poso13 = posol * rato13 - poso14 = posol * rato14 - anaerob13(i,k) = poso13*umfa !this has P units: kmol P/m3 of pore water - anaerob14(i,k) = poso14*umfa !this has P units: kmol P/m3 of pore water - endif - sedlay(i,j,k,issso12) = sedlay(i,j,k,issso12) - posol - powtra(i,j,k,ipowaph) = powtra(i,j,k,ipowaph) + posol*umfa - powtra(i,j,k,ipowno3) = powtra(i,j,k,ipowno3) - rdnit1*posol*umfa - powtra(i,j,k,ipown2) = powtra(i,j,k,ipown2) + rdnit2*posol*umfa - if (use_cisonew) then - sedlay(i,j,k,issso13) = sedlay(i,j,k,issso13) - poso13 - sedlay(i,j,k,issso14) = sedlay(i,j,k,issso14) - poso14 + if (.not. use_extNcycle) then + ! Denitrification rate constant of POP (disso) [1/sec]*dtbgc + denit = sed_denit + + ! Store flux in array anaerob, for later computation of DIC and alkalinity. + do k = 1, ks + do i = 1, kpie + if(omask(i,j) > 0.5) then + if(powtra(i,j,k,ipowaox) < 1.e-6) then + posol = denit * min(0.25*powtra(i,j,k,ipowno3)/rdnit2, sedlay(i,j,k,issso12)) + umfa = porsol(i,j,k)/porwat(i,j,k) + anaerob(i,k) = posol*umfa !this has P units: kmol P/m3 of pore water + if (use_cisonew) then + rato13 = sedlay(i,j,k,issso13) / (sedlay(i,j,k,issso12) + safediv) + rato14 = sedlay(i,j,k,issso14) / (sedlay(i,j,k,issso12) + safediv) + poso13 = posol * rato13 + poso14 = posol * rato14 + anaerob13(i,k) = poso13*umfa !this has P units: kmol P/m3 of pore water + anaerob14(i,k) = poso14*umfa !this has P units: kmol P/m3 of pore water + endif + sedlay(i,j,k,issso12) = sedlay(i,j,k,issso12) - posol + powtra(i,j,k,ipowaph) = powtra(i,j,k,ipowaph) + posol*umfa + powtra(i,j,k,ipowno3) = powtra(i,j,k,ipowno3) - rdnit1*posol*umfa + powtra(i,j,k,ipown2) = powtra(i,j,k,ipown2) + rdnit2*posol*umfa + if (use_cisonew) then + sedlay(i,j,k,issso13) = sedlay(i,j,k,issso13) - poso13 + sedlay(i,j,k,issso14) = sedlay(i,j,k,issso14) - poso14 + endif endif endif - endif + enddo enddo - enddo -#else - !======>>>> extended nitrogen cycle processes (aerobic and anaerobic) that follow ammonification - call sed_nitrification(j,kpie,kpje,kpke,kbnd,ptho,omask,ex_ddic,ex_dalk) - call sed_denit_NO3_to_NO2(j,kpie,kpje,kpke,kbnd,ptho,omask,ex_ddic,ex_dalk) - call sed_anammox(j,kpie,kpje,kpke,kbnd,ptho,omask,ex_ddic,ex_dalk) - call sed_denit_dnra(j,kpie,kpje,kpke,kbnd,ptho,omask,ex_ddic,ex_dalk) -#endif - + else + !======>>>> extended nitrogen cycle processes (aerobic and anaerobic) that follow ammonification + call sed_nitrification(j,kpie,kpje,kpke,kbnd,ptho,omask,ex_ddic,ex_dalk) + call sed_denit_NO3_to_NO2(j,kpie,kpje,kpke,kbnd,ptho,omask,ex_ddic,ex_dalk) + call sed_anammox(j,kpie,kpje,kpke,kbnd,ptho,omask,ex_ddic,ex_dalk) + call sed_denit_dnra(j,kpie,kpje,kpke,kbnd,ptho,omask,ex_ddic,ex_dalk) + endif ! sulphate reduction in sediments do k = 1, ks @@ -395,9 +393,9 @@ subroutine powach(kpie,kpje,kpke,kbnd,prho,omask,psao,ptho,lspin) sedlay(i,j,k,issso13) = sedlay(i,j,k,issso13) - poso13 sedlay(i,j,k,issso14) = sedlay(i,j,k,issso14) - poso14 endif -#ifdef extNcycle + if (use_extNcycle) then extNsed_diagnostics(i,j,k,ised_remin_sulf) = posol*umfa ! Output -#endif + endif endif endif enddo @@ -416,13 +414,13 @@ subroutine powach(kpie,kpje,kpke,kbnd,prho,omask,psao,ptho,lspin) if(omask(i,j) > 0.5) then saln= min( 40., max( 0., psao(i,j,kbo(i,j)))) rrho= prho(i,j,kbo(i,j)) -#ifdef extNcycle + if (use_extNcycle) then alk = (powtra(i,j,k,ipowaal) - (sulf(i,k)+aerob(i,k))*(rnit+1.) + ex_dalk(i,k)) / rrho c = (powtra(i,j,k,ipowaic) + (aerob(i,k)+sulf(i,k))*rcar + ex_ddic(i,k)) / rrho -#else + else alk = (powtra(i,j,k,ipowaal) - (sulf(i,k)+aerob(i,k))*(rnit+1.) + anaerob(i,k)*(rdnit1-1.)) / rrho c = (powtra(i,j,k,ipowaic) + (anaerob(i,k)+aerob(i,k)+sulf(i,k))*rcar) / rrho -#endif + endif sit = powtra(i,j,k,ipowasi) / rrho pt = powtra(i,j,k,ipowaph) / rrho ah1 = sedhpl(i,j,k) @@ -527,17 +525,17 @@ subroutine powach(kpie,kpje,kpke,kbnd,prho,omask,psao,ptho,lspin) poso14 = posol * ratc14 endif sedlay(i,j,k,isssc12) = sedlay(i,j,k,isssc12) - posol -#ifdef extNcycle + if (use_extNcycle) then powtra(i,j,k,ipowaic) = powtra(i,j,k,ipowaic) & & + posol * umfa + (aerob(i,k) + sulf(i,k)) * rcar + ex_ddic(i,k) powtra(i,j,k,ipowaal) = powtra(i,j,k,ipowaal) & & + 2. * posol * umfa - (rnit+1.)*(aerob(i,k) + sulf(i,k)) + ex_dalk(i,k) -#else + else powtra(i,j,k,ipowaic) = powtra(i,j,k,ipowaic) & & + posol * umfa + (aerob(i,k) + anaerob(i,k) + sulf(i,k)) * rcar powtra(i,j,k,ipowaal) = powtra(i,j,k,ipowaal) & & + 2. * posol * umfa - (rnit+1.)*(aerob(i,k) + sulf(i,k)) + (rdnit1-1.)*anaerob(i,k) -#endif + endif if (use_cisonew) then sedlay(i,j,k,isssc13) = sedlay(i,j,k,isssc13) - poso13 sedlay(i,j,k,isssc14) = sedlay(i,j,k,isssc14) - poso14 diff --git a/hamocc/mo_read_ndep.F90 b/hamocc/mo_read_ndep.F90 index 96d1f320..a3eb8728 100644 --- a/hamocc/mo_read_ndep.F90 +++ b/hamocc/mo_read_ndep.F90 @@ -21,14 +21,14 @@ module mo_read_ndep !************************************************************************************************* ! Routines for reading nitrogen deposition fluxes from netcdf files ! - ! N-deposition is activated through a logical switch 'do_ndep' read from HAMOCC's bgcnml - ! namelist. When coupled to NorESM, this is achieved by setting BLOM_N_DEPOSITION to + ! N-deposition is activated through a logical switch 'do_ndep' read from HAMOCC's bgcnml + ! namelist. When coupled to NorESM, this is achieved by setting BLOM_N_DEPOSITION to ! TRUE in env_run.xml. ! ! The routine get_ndep reads nitrogen deposition from file. The n-deposition ! field is then passed to hamocc4bcm where it is applied to the top-most model - ! layer by a call to apply_ndep (mo_apply_ndep). If N deposition is acitvated, a - ! valid filename (including the full path) needs to be provided via HAMOCC's bgcnml + ! layer by a call to apply_ndep (mo_apply_ndep). If N deposition is acitvated, a + ! valid filename (including the full path) needs to be provided via HAMOCC's bgcnml ! namelist (variable ndepfile). If the input file is not found, an error will be issued. ! The input data must be already pre-interpolated to the ocean grid. ! @@ -55,7 +55,7 @@ module mo_read_ndep public :: ini_read_ndep ! Initialise the module public :: get_ndep ! Read and return n-deposition data for a given month. public :: ndepfile - + character(len=512) :: ndepfile='' real, allocatable :: ndepread(:,:) real, allocatable :: noydepread(:,:) @@ -75,7 +75,7 @@ subroutine ini_read_ndep(kpie,kpje) !*********************************************************************************************** use mod_xc, only: mnproc,xchalt - use mo_control_bgc, only: io_stdo_bgc,do_ndep,do_ndep_coupled + use mo_control_bgc, only: io_stdo_bgc,do_ndep,do_ndep_coupled,use_extNcycle use mod_dia, only: iotype use mod_nctools, only: ncfopn,ncgeti,ncfcls use mo_netcdf_bgcrw, only: read_netcdf_var @@ -123,39 +123,36 @@ subroutine ini_read_ndep(kpie,kpje) stop '(ini_read_ndep)' endif -#ifdef extNcycle - ! Allocate field to hold N-deposition fluxes - IF (mnproc.eq.1) THEN - WRITE(io_stdo_bgc,*)'Memory allocation for variable nhxdepread ...' - WRITE(io_stdo_bgc,*)'First dimension : ',kpie - WRITE(io_stdo_bgc,*)'Second dimension : ',kpje - ENDIF - - ALLOCATE (nhxdepread(kpie,kpje),stat=errstat) - if(errstat.ne.0) stop 'not enough memory nhxdepread' - nhxdepread(:,:) = 0.0 - - IF (mnproc.eq.1) THEN - WRITE(io_stdo_bgc,*)'Memory allocation for variable noydepread ...' - WRITE(io_stdo_bgc,*)'First dimension : ',kpie - WRITE(io_stdo_bgc,*)'Second dimension : ',kpje - ENDIF - - ALLOCATE (noydepread(kpie,kpje),stat=errstat) - if(errstat.ne.0) stop 'not enough memory noydepread' - noydepread(:,:) = 0.0 -#else - ! Allocate field to hold N-deposition fluxes - if (mnproc.eq.1) then - write(io_stdo_bgc,*)'Memory allocation for variable ndepread ...' - write(io_stdo_bgc,*)'First dimension : ',kpie - write(io_stdo_bgc,*)'Second dimension : ',kpje + if (use_extNcycle) then + ! Allocate field to hold N-deposition fluxes + if (mnproc.eq.1) then + write(io_stdo_bgc,*)'Memory allocation for variable nhxdepread ...' + write(io_stdo_bgc,*)'First dimension : ',kpie + write(io_stdo_bgc,*)'Second dimension : ',kpje + endif + allocate (nhxdepread(kpie,kpje),stat=errstat) + if(errstat.ne.0) stop 'not enough memory nhxdepread' + nhxdepread(:,:) = 0.0 + + if (mnproc.eq.1) then + write(io_stdo_bgc,*)'Memory allocation for variable noydepread ...' + write(io_stdo_bgc,*)'First dimension : ',kpie + write(io_stdo_bgc,*)'Second dimension : ',kpje + endif + allocate (noydepread(kpie,kpje),stat=errstat) + if(errstat.ne.0) stop 'not enough memory noydepread' + noydepread(:,:) = 0.0 + else + ! Allocate field to hold N-deposition fluxes + if (mnproc.eq.1) then + write(io_stdo_bgc,*)'Memory allocation for variable ndepread ...' + write(io_stdo_bgc,*)'First dimension : ',kpie + write(io_stdo_bgc,*)'Second dimension : ',kpje + endif + allocate (ndepread(kpie,kpje),stat=errstat) + if(errstat.ne.0) stop 'not enough memory ndep' + ndepread(:,:) = 0.0 endif -#endif - - allocate (ndepread(kpie,kpje),stat=errstat) - if(errstat.ne.0) stop 'not enough memory ndep' - ndepread(:,:) = 0.0 ! read start and end year of n-deposition file call ncfopn(trim(ndepfile),'r',' ',1,iotype) @@ -185,12 +182,9 @@ subroutine get_ndep(kpie,kpje,kplyear,kplmon,omask,ndep) use mod_xc, only: mnproc use netcdf, only: nf90_open,nf90_close,nf90_nowrite - use mo_control_bgc, only: io_stdo_bgc,do_ndep + use mo_control_bgc, only: io_stdo_bgc,do_ndep,use_extNcycle use mo_netcdf_bgcrw, only: read_netcdf_var - use mo_param1_bgc, only: nndep,idepnoy -#ifdef extNcycle - use mo_param1_bgc, only: idepnhx -#endif + use mo_param1_bgc, only: nndep,idepnoy,idepnhx ! Arguments integer, intent(in) :: kpie ! 1st dimension of model grid. @@ -216,12 +210,12 @@ subroutine get_ndep(kpie,kpje,kplyear,kplmon,omask,ndep) write(io_stdo_bgc,*) 'Read N deposition month ',month_in_file,' from file ',trim(ndepfile) endif ncstat=nf90_open(trim(ndepfile),nf90_nowrite,ncid) -#ifdef extNcycle - call read_netcdf_var(ncid,'nhxdep',nhxdepread,1,month_in_file,0) - call read_netcdf_var(ncid,'noydep',noydepread,1,month_in_file,0) -#else - call read_netcdf_var(ncid,'ndep',ndepread,1,month_in_file,0) -#endif + if (use_extNcycle) then + call read_netcdf_var(ncid,'nhxdep',nhxdepread,1,month_in_file,0) + call read_netcdf_var(ncid,'noydep',noydepread,1,month_in_file,0) + else + call read_netcdf_var(ncid,'ndep',ndepread,1,month_in_file,0) + endif ncstat=nf90_close(ncid) oldmonth=kplmon endif @@ -230,12 +224,12 @@ subroutine get_ndep(kpie,kpje,kplyear,kplmon,omask,ndep) ! 1 = NO3; 2 = NH4 do j=1,kpje do i=1,kpie -#ifdef extNcycle - ndep(i,j,idepnoy) = noydepread(i,j) - ndep(i,j,idepnhx) = nhxdepread(i,j) -#else - ndep(i,j,idepnoy) = ndepread(i,j) -#endif + if (use_extNcycle) then + ndep(i,j,idepnoy) = noydepread(i,j) + ndep(i,j,idepnhx) = nhxdepread(i,j) + else + ndep(i,j,idepnoy) = ndepread(i,j) + endif enddo enddo !$OMP END PARALLEL DO From 343c8c55fd8c16cb96da33ec227d4a24cbefc66e Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Mon, 22 Jan 2024 11:58:55 +0100 Subject: [PATCH 323/366] move initialization of M4AGO-params out of mo_param_bgc & mv remin/dissol parameters into mo_param_bgc --- hamocc/mo_extNsediment.F90 | 3 +-- hamocc/mo_hamocc_init.F90 | 6 +++++- hamocc/mo_m4ago.F90 | 6 +----- hamocc/mo_ocprod.F90 | 8 ++++---- hamocc/mo_param_bgc.F90 | 9 ++++++++- 5 files changed, 19 insertions(+), 13 deletions(-) diff --git a/hamocc/mo_extNsediment.F90 b/hamocc/mo_extNsediment.F90 index e4a8b282..32d60b16 100644 --- a/hamocc/mo_extNsediment.F90 +++ b/hamocc/mo_extNsediment.F90 @@ -131,8 +131,7 @@ subroutine extNsediment_param_init() & q10dnra,Trefdnra,bkoxdnra,bkdnra, & & q10anh4nitr,Trefanh4nitr,bkoxamox,bkanh4nitr,bkamoxn2o,bkyamox,n2omaxy,n2oybeta, & & q10ano2nitr,Trefano2nitr,bkoxnitr,bkano2nitr,NOB2AOAy,rno2anmx,rnh4anmx - use mo_m4ago, only: POM_remin_q10,POM_remin_Tref - use mo_param_bgc, only: bkox_drempoc + use mo_param_bgc, only: bkox_drempoc,POM_remin_q10,POM_remin_Tref implicit none diff --git a/hamocc/mo_hamocc_init.F90 b/hamocc/mo_hamocc_init.F90 index b23ae8c1..dcbb90a1 100644 --- a/hamocc/mo_hamocc_init.F90 +++ b/hamocc/mo_hamocc_init.F90 @@ -64,7 +64,7 @@ subroutine hamocc_init(read_rest,rstfnm_hamocc) sedlay2,powtra2,burial2,blom2hamocc,atm2 use mo_ini_fields, only: ini_fields_ocean,ini_fields_atm use mo_aufr_bgc, only: aufr_bgc - use mo_m4ago, only: alloc_mem_m4ago + use mo_m4ago, only: alloc_mem_m4ago,init_m4ago_nml_params, init_m4ago_params use mo_extNsediment,only: alloc_mem_extNsediment_diag @@ -177,6 +177,10 @@ subroutine hamocc_init(read_rest,rstfnm_hamocc) ! --- Initialize parameters ! call ini_parambgc(idm,jdm) + if (lm4ago) then + call init_m4ago_nml_params + call init_m4ago_params + endif ! --- Initialize atmospheric fields with (updated) parameter values call ini_fields_atm(idm,jdm) diff --git a/hamocc/mo_m4ago.F90 b/hamocc/mo_m4ago.F90 index da8b9513..8b554a6e 100644 --- a/hamocc/mo_m4ago.F90 +++ b/hamocc/mo_m4ago.F90 @@ -83,7 +83,7 @@ MODULE mo_m4ago PUBLIC :: mean_aggregate_sinking_speed, init_m4ago_nml_params, init_m4ago_params, alloc_mem_m4ago ! Public fields and parameters - PUBLIC :: ws_agg, POM_remin_q10, POM_remin_Tref, opal_remin_q10, opal_remin_Tref, & + PUBLIC :: ws_agg, & aggregate_diagnostics,kav_dp,kav_rho_p,kav_d_C,kws_agg,kdf_agg,kstickiness_agg,kb_agg,kstickiness_frustule, & & kLmax_agg,kdynvis,kav_rhof_V,kav_por_V @@ -209,10 +209,6 @@ SUBROUTINE init_m4ago_nml_params agg_Re_crit = 20. ! critical particle Reynolds number for limiting nr-distribution - POM_remin_q10 = 2.1 ! Bidle et al. 2002: Regulation of Oceanic Silicon... - opal_remin_q10 = 2.6 ! Bidle et al. 2002: Regulation of Oceanic Silicon... - POM_remin_Tref = 10. - opal_remin_Tref = 10. END SUBROUTINE init_m4ago_nml_params SUBROUTINE init_m4ago_params diff --git a/hamocc/mo_ocprod.F90 b/hamocc/mo_ocprod.F90 index 465df46b..295ba53d 100644 --- a/hamocc/mo_ocprod.F90 +++ b/hamocc/mo_ocprod.F90 @@ -75,7 +75,8 @@ subroutine ocprod(kpie,kpje,kpke,kbnd,pdlxp,pdlyp,pddpo,omask,ptho,pi_ph,psao,pp fse,fsh,nmldmin,plower,pupper,sinkexp,stick,tmfac, & tsfac,vsmall,zdis,wmin,wmax,wlin,rbro, & dmsp1,dmsp2,dmsp3,dmsp4,dmsp5,dmsp6,dms_gamma, & - fbro1,fbro2,atten_f,atten_c,atten_uv,atten_w,bkopal,bkphy,bkzoo + fbro1,fbro2,atten_f,atten_c,atten_uv,atten_w,bkopal,bkphy,bkzoo, & + POM_remin_q10,POM_remin_Tref,opal_remin_q10,opal_remin_Tref use mo_biomod, only: bsiflx0100,bsiflx0500,bsiflx1000,bsiflx2000,bsiflx4000,bsiflx_bot, & calflx0100,calflx0500,calflx1000,calflx2000,calflx4000,calflx_bot, & carflx0100,carflx0500,carflx1000,carflx2000,carflx4000,carflx_bot, & @@ -97,8 +98,7 @@ subroutine ocprod(kpie,kpje,kpke,kbnd,pdlxp,pdlyp,pddpo,omask,ptho,pi_ph,psao,pp use mo_vgrid, only: kmle use mo_clim_swa, only: swa_clim use mo_inventory_bgc, only: inventory_bgc - use mo_m4ago, only: mean_aggregate_sinking_speed,ws_agg,POM_remin_q10,POM_remin_Tref, & - opal_remin_q10,opal_remin_Tref + use mo_m4ago, only: mean_aggregate_sinking_speed,ws_agg use mo_extNwatercol, only: nitrification,denit_NO3_to_NO2,anammox,denit_dnra,extN_inv_check use mo_extNwatercol, only: bkphyanh4,bkphyano3,bkphosph,bkiron,ro2utammo @@ -115,7 +115,7 @@ subroutine ocprod(kpie,kpje,kpke,kbnd,pdlxp,pdlyp,pddpo,omask,ptho,pi_ph,psao,pp real, intent(in) :: ptho(1-kbnd:kpie+kbnd,1-kbnd:kpje+kbnd,kpke) ! potential temperature [deg C]. real, intent(in) :: pi_ph(kpie,kpje) real, intent(in) :: psao(1-kbnd:kpie+kbnd,1-kbnd:kpje+kbnd,kpke) ! salinity [psu]. - real, intent(in) :: ppao(1-kbnd:kpie+kbnd,1-kbnd:kpje+kbnd) ! sea level pressure [Pascal]. + real, intent(in) :: ppao(1-kbnd:kpie+kbnd,1-kbnd:kpje+kbnd) ! sea level pressure [Pascal]. real, intent(in) :: prho(kpie,kpje,kpke) ! density [kg/m^3]. ! Local variables diff --git a/hamocc/mo_param_bgc.F90 b/hamocc/mo_param_bgc.F90 index f4e6dc3a..355ab6e5 100644 --- a/hamocc/mo_param_bgc.F90 +++ b/hamocc/mo_param_bgc.F90 @@ -86,6 +86,8 @@ module mo_param_bgc public :: sed_denit,calcwei,opalwei,orgwei public :: calcdens,opaldens,orgdens,claydens public :: dmsp1,dmsp2,dmsp3,dmsp4,dmsp5,dmsp6,dms_gamma + public :: POM_remin_q10,opal_remin_q10,POM_remin_Tref,opal_remin_Tref + !******************************************************************** ! Stoichiometry and fixed parameters @@ -229,6 +231,11 @@ module mo_param_bgc real, protected :: dremopal = 0.003 ! 1/d Dissolution rate for opal real, protected :: dremn2o = 0.01 ! 1/d Remineralization rate of detritus on N2O real, protected :: dremsul = 0.005 ! 1/d Remineralization rate for sulphate reduction + real, protected :: POM_remin_q10 = 2.1 ! Bidle et al. 2002: Regulation of Oceanic Silicon... + real, protected :: opal_remin_q10 = 2.6 ! Bidle et al. 2002: Regulation of Oceanic Silicon... + real, protected :: POM_remin_Tref = 10. ! [deg C] reference temperatue for Q10-dep. POC remin + real, protected :: opal_remin_Tref = 10. ! [deg C] reference temperature for Q10-dep. opal dissolution + !******************************************************************** ! Parameters for DMS and BrO schemes @@ -617,7 +624,7 @@ subroutine write_parambgc() write(io_stdo_bgc,*) '* leuphotic_cya = ',leuphotic_cya write(io_stdo_bgc,*) '* lm4ago = ',lm4ago if (use_extNcycle) then - write(io_stdo_bgc,*) '* do_ndep_coupled = ',do_ndep_coupled + write(io_stdo_bgc,*) '* do_ndep_coupled = ',do_ndep_coupled write(io_stdo_bgc,*) '* do_n2onh3_coupled = ',do_n2onh3_coupled endif write(io_stdo_bgc,*) '* ' From 09bba8fb525834c79797f4cab7fdddd27d49cfee Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Mon, 22 Jan 2024 13:25:46 +0100 Subject: [PATCH 324/366] small fix --- hamocc/mo_m4ago.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/hamocc/mo_m4ago.F90 b/hamocc/mo_m4ago.F90 index 8b554a6e..27b55240 100644 --- a/hamocc/mo_m4ago.F90 +++ b/hamocc/mo_m4ago.F90 @@ -83,7 +83,7 @@ MODULE mo_m4ago PUBLIC :: mean_aggregate_sinking_speed, init_m4ago_nml_params, init_m4ago_params, alloc_mem_m4ago ! Public fields and parameters - PUBLIC :: ws_agg, + PUBLIC :: ws_agg,& & aggregate_diagnostics,kav_dp,kav_rho_p,kav_d_C,kws_agg,kdf_agg,kstickiness_agg,kb_agg,kstickiness_frustule, & & kLmax_agg,kdynvis,kav_rhof_V,kav_por_V From 130fbe97c1259a9507a818d580fb3cf5815513df Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Mon, 22 Jan 2024 15:55:56 +0100 Subject: [PATCH 325/366] move water column extended nitrogen cycle parameters to mo_param_bgc --- hamocc/mo_extNsediment.F90 | 11 +- hamocc/mo_extNwatercol.F90 | 251 +++---------------------------------- hamocc/mo_ocprod.F90 | 4 +- hamocc/mo_param_bgc.F90 | 186 +++++++++++++++++++++++++-- hamocc/mo_powach.F90 | 9 +- 5 files changed, 206 insertions(+), 255 deletions(-) diff --git a/hamocc/mo_extNsediment.F90 b/hamocc/mo_extNsediment.F90 index 32d60b16..393a3e0c 100644 --- a/hamocc/mo_extNsediment.F90 +++ b/hamocc/mo_extNsediment.F90 @@ -44,11 +44,12 @@ MODULE mo_extNsediment !********************************************************************** use mo_param1_bgc, only: issso12,ipowaic,ipowaal,ipowaph,ipowaox,ipown2,ipowno3,ipownh4,ipown2o,ipowno2,ks use mo_vgrid, only: kbo - use mo_param_bgc, only: rnit,rcar,rnoi + use mo_param_bgc, only: rnit,rcar,rnoi, & + & rc2n,ro2utammo,ro2nnit,rnoxp,rnoxpi,rno2anmx,rno2anmxi,rnh4anmx, & + & rnh4anmxi,rno2dnra,rno2dnrai,rnh4dnra,rnh4dnrai,rnm1 + use mo_control_bgc, only: io_stdo_bgc,dtb use mo_sedmnt, only: powtra,sedlay,porsol,porwat - use mo_extNwatercol,only: rc2n,ro2utammo,ro2nnit,rnoxp,rnoxpi,rno2anmx,rno2anmxi,rnh4anmx, & - & rnh4anmxi,rno2dnra,rno2dnrai,rnh4dnra,rnh4dnrai,rnm1 implicit none @@ -124,13 +125,13 @@ end subroutine alloc_mem_extNsediment_diag ! ================================================================================================================================ subroutine extNsediment_param_init() - use mo_extNwatercol,only: q10ano3denit,sc_ano3denit,Trefano3denit,bkano3denit, & + use mo_param_bgc,only: q10ano3denit,sc_ano3denit,Trefano3denit,bkano3denit, & & q10anmx,Trefanmx,alphaanmx,bkoxanmx,bkano2anmx, & & q10ano2denit,Trefano2denit,bkoxano2denit,bkano2denit, & & q10an2odenit,Trefan2odenit,bkoxan2odenit,bkan2odenit, & & q10dnra,Trefdnra,bkoxdnra,bkdnra, & & q10anh4nitr,Trefanh4nitr,bkoxamox,bkanh4nitr,bkamoxn2o,bkyamox,n2omaxy,n2oybeta, & - & q10ano2nitr,Trefano2nitr,bkoxnitr,bkano2nitr,NOB2AOAy,rno2anmx,rnh4anmx + & q10ano2nitr,Trefano2nitr,bkoxnitr,bkano2nitr,NOB2AOAy,rno2anmx,rnh4anmx use mo_param_bgc, only: bkox_drempoc,POM_remin_q10,POM_remin_Tref implicit none diff --git a/hamocc/mo_extNwatercol.F90 b/hamocc/mo_extNwatercol.F90 index ed55341c..72c1df55 100644 --- a/hamocc/mo_extNwatercol.F90 +++ b/hamocc/mo_extNwatercol.F90 @@ -54,245 +54,32 @@ MODULE mo_extNwatercol use mo_control_bgc, only: io_stdo_bgc,dtb use mo_param1_bgc, only: ialkali,ianh4,iano2,ian2o,iano3,idet,igasnit,iiron,ioxygen,iphosph,isco212 use mo_carbch, only: ocetra - use mo_param_bgc, only: riron,rnit,rcar,rnoi - use mo_biomod, only: nitr_NH4,nitr_NO2,nitr_N2O_prod,nitr_NH4_OM,nitr_NO2_OM,denit_NO3,denit_NO2, & - & denit_N2O,DNRA_NO2,anmx_N2_prod,anmx_OM_prod - + use mo_param_bgc, only: riron,rnit,rcar,rnoi, & + & q10ano3denit,sc_ano3denit,Trefano3denit,rano3denit,bkano3denit, & + & rano2anmx,q10anmx,Trefanmx,alphaanmx,bkoxanmx,bkano2anmx,bkanh4anmx, & + & rano2denit,q10ano2denit,Trefano2denit,bkoxano2denit,bkano2denit, & + & ran2odenit,q10an2odenit,Trefan2odenit,bkoxan2odenit,bkan2odenit, & + & rdnra,q10dnra,Trefdnra,bkoxdnra,bkdnra,ranh4nitr,q10anh4nitr, & + & Trefanh4nitr,bkoxamox,bkanh4nitr,bkamoxn2o,bkyamox, & + & rano2nitr,q10ano2nitr,Trefano2nitr,bkoxnitr,bkano2nitr,n2omaxy, & + & n2oybeta,NOB2AOAy,bn2o,mufn2o, & + & rc2n,ro2nnit,rnoxp,rnoxpi,rno2anmx,rno2anmxi,rnh4anmx, & + & rnh4anmxi,rno2dnra,rno2dnrai,rnh4dnra,rnh4dnrai,rnm1, & + & bkphyanh4,bkphyano3,bkphosph,bkiron,ro2utammo + use mo_biomod, only: nitr_NH4,nitr_NO2,nitr_N2O_prod,nitr_NH4_OM,nitr_NO2_OM,denit_NO3, & + & denit_NO2,denit_N2O,DNRA_NO2,anmx_N2_prod,anmx_OM_prod implicit none private ! public functions - public :: extNwatercol_param_init,nitrification,denit_NO3_to_NO2,& - & anammox,denit_dnra,extN_inv_check,extNwatercol_param_update,extNwatercol_param_write - - ! public parameters for primary production - public :: bkphyanh4,bkphyano3,bkphosph,bkiron,ro2utammo - - ! Public parameters for extended nitrogen cycle in the sediment. - ! The basic idea is that we have the same temperature dependence - ! and same nutrient sensitivities, - ! while only the rates vary between sediment and water column - ! (Thus far, we keep the rates public in order to enable to write them to the log in beleg_parm) - public :: q10ano3denit,sc_ano3denit,Trefano3denit,rano3denit,bkano3denit, & - & rano2anmx,q10anmx,Trefanmx,alphaanmx,bkoxanmx,bkano2anmx,bkanh4anmx, & - & rano2denit,q10ano2denit,Trefano2denit,bkoxano2denit,bkano2denit, & - & ran2odenit,q10an2odenit,Trefan2odenit,bkoxan2odenit,bkan2odenit, & - & rdnra,q10dnra,Trefdnra,bkoxdnra,bkdnra,ranh4nitr,q10anh4nitr, & - & Trefanh4nitr,bkoxamox,bkanh4nitr,bkamoxn2o,bkyamox, & - & rano2nitr,q10ano2nitr,Trefano2nitr,bkoxnitr,bkano2nitr,n2omaxy, & - & n2oybeta,NOB2AOAy,bn2o,mufn2o, & - & rc2n,ro2nnit,rnoxp,rnoxpi,rno2anmx,rno2anmxi,rnh4anmx, & - & rnh4anmxi,rno2dnra,rno2dnrai,rnh4dnra,rnh4dnrai,rnm1 - - - real :: q10ano3denit,sc_ano3denit,Trefano3denit,rano3denit,bkano3denit, & - & rano2anmx,q10anmx,Trefanmx,alphaanmx,bkoxanmx,bkano2anmx,bkanh4anmx, & - & rano2denit,q10ano2denit,Trefano2denit,bkoxano2denit,bkano2denit, & - & ran2odenit,q10an2odenit,Trefan2odenit,bkoxan2odenit,bkan2odenit, & - & rdnra,q10dnra,Trefdnra,bkoxdnra,bkdnra,ranh4nitr,q10anh4nitr, & - & Trefanh4nitr,bkoxamox,bkanh4nitr,bkamoxn2o,bkyamox, & - & rano2nitr,q10ano2nitr,Trefano2nitr,bkoxnitr,bkano2nitr,n2omaxy, & - & n2oybeta,bkphyanh4,bkphyano3,bkphosph,bkiron,NOB2AOAy,bn2o,mufn2o!,bkamoxno2, - - real :: rc2n,ro2utammo,ro2nnit,rnoxp,rnoxpi,rno2anmx,rno2anmxi,rnh4anmx, & - & rnh4anmxi,rno2dnra,rno2dnrai,rnh4dnra,rnh4dnrai,rnm1 - - real :: eps,minlim - - CONTAINS + public :: nitrification,denit_NO3_to_NO2,anammox,denit_dnra,extN_inv_check -!================================================================================================================================== - subroutine extNwatercol_param_init() - !=========================================================================== - ! Initialization of model parameters for the extended nitrogen cycle - rc2n = rcar/rnit ! iHAMOCC C:N ratio - ro2utammo = 140. ! Oxygen utilization per mol detritus during ammonification - ro2nnit = ro2utammo/rnit ! - rnoxp = 280. ! consumption of NOx per mol detritus during denitrification - rnoxpi = 1./rnoxp ! inverse - rno2anmx = 1144. ! consumption of NO2 per mol organic production by anammox - rno2anmxi = 1./rno2anmx ! inverse - rnh4anmx = 880. ! consumption of NH4 per mol organic production by anammox - rnh4anmxi = 1./rnh4anmx ! inverse - rno2dnra = 93. + 1./3. ! consumption of NO2 per mol OM degradation during DNRA - rno2dnrai = 1./rno2dnra ! inverse - rnh4dnra = rno2dnra + rnit ! production of NH4 per mol OM during DNRA - rnh4dnrai = 1./rnh4dnra ! inverse - rnm1 = rnit - 1. - - ! Phytoplankton growth - bkphyanh4 = 0.12e-6 ! Half-saturation constant for NH4 uptake by bulk phytoplankton (kmol/m3) - bkphyano3 = 0.16e-6 ! Half-saturation constant for NO3 uptake by bulk phytoplankton (kmol/m3) - bkphosph = 0.01e-6 ! Half-saturation constant for PO4 uptake by bulk phytoplankton (kmol/m3) - bkiron = bkphosph*riron ! Half-saturation constant for Fe uptake by bulk phytoplankton (kmol/m3) - - ! === Denitrification step NO3 -> NO2: - !rano3denit = 0.15*dtb ! Maximum growth rate denitrification on NO3 at reference T (1/d -> 1/dt) - rano3denit = 0.05 ! Maximum growth rate denitrification on NO3 at reference T (1/d -> 1/dt) - q10ano3denit = 2. ! Q10 factor for denitrification on NO3 (-) - Trefano3denit = 10. ! Reference temperature for denitrification on NO3 (degr C) - !sc_ano3denit = 0.05e6 ! Shape factor for NO3 denitrification oxygen inhibition function (m3/kmol) - sc_ano3denit = 0.12e6 ! Shape factor for NO3 denitrification oxygen inhibition function (m3/kmol) - bkano3denit = 5.e-6 ! Half-saturation constant for NO3 denitrification (kmol/m3) - - ! === Anammox - rano2anmx = 0.05 ! Maximum growth rate for anammox at reference T (1/d -> 1/dt) - q10anmx = 1.6 ! Q10 factor for anammox (-) - Trefanmx = 10. ! Reference temperature for anammox (degr C) - alphaanmx = 0.45e6 ! Shape factor for anammox oxygen inhibition function (m3/kmol) - bkoxanmx = 11.3e-6 ! Half-saturation constant for oxygen inhibition function (kmol/m3) - bkano2anmx = 5.e-6 ! Half-saturation constant for NO2 limitation (kmol/m3) - bkanh4anmx = bkano2anmx * rnh4anmx/rno2anmx !Half-saturation constant for NH4 limitation of anammox (kmol/m3) - - ! === Denitrification step NO2 -> N2O - rano2denit = 0.12 ! Maximum growth rate denitrification on NO2 at reference T (1/d -> 1/dt) - q10ano2denit = 2.0 ! Q10 factor for denitrification on NO2 (-) - Trefano2denit = 10. ! Reference temperature for denitrification on NO2 (degr C) - bkoxano2denit = 2.e-6 ! Half-saturation constant for (quadratic) oxygen inhibition function of denitrification on NO2 (kmol/m3) - bkano2denit = 5.6e-6 ! Half-saturation constant for denitrification on NO2 (kmol/m3) - - ! === Denitrification step N2O -> N2 - ran2odenit = 0.16 ! Maximum growth rate denitrification on N2O at reference T (1/d -> 1/dt) - q10an2odenit = 3. ! Q1- factor for denitrificationj on N2O (-) - Trefan2odenit = 10. ! Reference temperature for denitrification on N2O (degr C) - bkoxan2odenit = 5.e-6 ! Half-saturation constant for (quadratic) oxygen inhibition function of denitrification on N2O (kmol/m3) - bkan2odenit = 1.e-6 ! Half-saturation constant for denitrification on N2O (kmol/m3) - - ! === DNRA NO2 -> NH4 - rdnra = 0.1 ! Maximum growth rate DNRA on NO2 at reference T (1/d -> 1/dt) - q10dnra = 2. ! Q10 factor for DNRA on NO2 (-) - Trefdnra = 10. ! Reference temperature for DNRA (degr C) - bkoxdnra = 2.5e-6 ! Half saturation constant for (quadratic) oxygen inhibition function of DNRA on NO2 (kmol/m3) - bkdnra = 0.05e-6 ! Half-saturation constant for DNRA on NO2 (kmol/m3) - - ! === Nitrification on NH4 - ranh4nitr = 1. ! Maximum growth rate nitrification on NH4 at reference T (1/d -> 1/dt) - q10anh4nitr = 3.3 ! Q10 factor for nitrification on NH4 (-) - Trefanh4nitr = 20. ! Reference temperature for nitrification on NH4 (degr C) - bkoxamox = 0.333e-6 ! Half-saturation constant for oxygen limitation of nitrification on NH4 (kmol/m3) - bkanh4nitr = 0.133e-6 ! Half-saturation constant for nitrification on NH4 (kmol/m3) -!====== -! OLD VERSION OF pathway splitting function - !bkamoxn2o = 0.453e-6 ! Half saturation constant for O2 in pathway splitting function N2O for nitrification on NH4 (kmol/m3) -! NEW version similar to Santoros 2021, Ji 2018: - bkamoxn2o = 0.5e-6 ! Half saturation constant for NH4 in pathway splitting function N2O for nitrification on NH4 (kmol/m3) - mufn2o = 0.11/(50.*1e6*bkoxamox) !=6.61e-3 0.11/(50*1e6)=2.2e-9 - ~Santoro et al. 2011 with simple MM, - bn2o = 0.077/(50.*mufn2o) !=0.2331 - before set to 0.3 - base fraction entering N2O -!====== - !bkamoxno2 = 0.479e-6 ! Half saturation constant for pathway splitting function N2O for nitrification on NH4 (kmol/m3) -! bkamoxno2 = 0.1e-6 ! Half saturation constant for pathway splitting function N2O for nitrification on NH4 (kmol/m3) - n2omaxy = 0.003 ! Maximum yield of OM on NH4 nitrification (-) - n2oybeta = 18. ! Decay factor for inhibition function for yield during nitrification on NH4 (kmol/m3) - bkyamox = 0.333e-6 ! Half saturation constant for pathway splitting function OM-yield for nitrification on NH4 (kmol/m3) - - ! === Nitrification on NO2 - rano2nitr = 1.54 ! Maximum growth rate nitrification on NO2 at reference T (1/d -> 1/dt) - q10ano2nitr = 2.7 ! Q10 factor for nitrification on NO2 (-) - Trefano2nitr = 20. ! Reference temperature for nitrification on NO2 (degr C) - bkoxnitr = 0.788e-6 ! Half-saturation constant for oxygen limitation of nitrification on NO2 (kmol/m3) - bkano2nitr = 0.287e-6 ! Half-saturation constant for NO2 for nitrification on NO2 (kmol/m3) - NOB2AOAy = 0.44 ! Ratio of NOB versus AOA yield per energy source ~0.043/0.098 according to Zakem et al. 2022 - - eps = 1.e-25 ! safe division etc. - minlim = 1.e-9 ! minimum for limitation functions (e.g. nutlim or oxlim/inh can only decrease to minlim) - !=========================================================================== - - ! Tweaked parameters: - rano3denit = 0.0005 ! Maximum growth rate denitrification on NO3 at reference T (1/d -> 1/dt) - rano2anmx = 0.001 ! Maximum growth rate for anammox at reference T (1/d -> 1/dt) - rano2denit = 0.001 ! Maximum growth rate denitrification on NO2 at reference T (1/d -> 1/dt) - ran2odenit = 0.0012 ! Maximum growth rate denitrification on N2O at reference T (1/d -> 1/dt) - rdnra = 0.001 ! Maximum growth rate DNRA on NO2 at reference T (1/d -> 1/dt) - - end subroutine extNwatercol_param_init - -!================================================================================================================================== - subroutine extNwatercol_param_update() - - rano3denit = rano3denit *dtb ! Maximum growth rate denitrification on NO3 at reference T (1/d -> 1/dt) - rano2anmx = rano2anmx *dtb ! Maximum growth rate for anammox at reference T (1/d -> 1/dt) - rano2denit = rano2denit *dtb ! Maximum growth rate denitrification on NO2 at reference T (1/d -> 1/dt) - ran2odenit = ran2odenit *dtb ! Maximum growth rate denitrification on N2O at reference T (1/d -> 1/dt) - rdnra = rdnra *dtb ! Maximum growth rate DNRA on NO2 at reference T (1/d -> 1/dt) - ranh4nitr = ranh4nitr *dtb ! Maximum growth rate nitrification on NH4 at reference T (1/d -> 1/dt) - rano2nitr = rano2nitr *dtb ! Maximum growth rate nitrification on NO2 at reference T (1/d -> 1/dt) - - end subroutine extNwatercol_param_update + real :: eps = 1.e-25 + real :: minlim = 1.e-9 -!================================================================================================================================== - subroutine extNwatercol_param_write() - - REAL :: dtbinv - dtbinv = 1./dtb - WRITE(io_stdo_bgc,*) '****************************************************************' - WRITE(io_stdo_bgc,*) '* HAMOCC extended nitrogen cycle parameters water column:' - WRITE(io_stdo_bgc,*) '* rc2n = ',rc2n - WRITE(io_stdo_bgc,*) '* ro2utammo = ',ro2utammo - WRITE(io_stdo_bgc,*) '* ro2nnit = ',ro2nnit - WRITE(io_stdo_bgc,*) '* rnoxp = ',rnoxp - WRITE(io_stdo_bgc,*) '* rnoxpi = ',rnoxpi - WRITE(io_stdo_bgc,*) '* rno2anmx = ',rno2anmx - WRITE(io_stdo_bgc,*) '* rno2anmxi = ',rno2anmxi - WRITE(io_stdo_bgc,*) '* rnh4anmx = ',rnh4anmx - WRITE(io_stdo_bgc,*) '* rnh4anmxi = ',rnh4anmxi - WRITE(io_stdo_bgc,*) '* rno2dnra = ',rno2dnra - WRITE(io_stdo_bgc,*) '* rno2dnrai = ',rno2dnrai - WRITE(io_stdo_bgc,*) '* rnh4dnra = ',rnh4dnra - WRITE(io_stdo_bgc,*) '* rnh4dnrai = ',rnh4dnrai - WRITE(io_stdo_bgc,*) '* rnm1 = ',rnm1 - WRITE(io_stdo_bgc,*) '* bkphyanh4 = ',bkphyanh4 - WRITE(io_stdo_bgc,*) '* bkphyano3 = ',bkphyano3 - WRITE(io_stdo_bgc,*) '* bkphosph = ',bkphosph - WRITE(io_stdo_bgc,*) '* bkiron = ',bkiron - WRITE(io_stdo_bgc,*) '* rano3denit = ',rano3denit *dtbinv - WRITE(io_stdo_bgc,*) '* q10ano3denit = ',q10ano3denit - WRITE(io_stdo_bgc,*) '* Trefano3denit = ',Trefano3denit - WRITE(io_stdo_bgc,*) '* sc_ano3denit = ',sc_ano3denit - WRITE(io_stdo_bgc,*) '* bkano3denit = ',bkano3denit - WRITE(io_stdo_bgc,*) '* rano2anmx = ',rano2anmx *dtbinv - WRITE(io_stdo_bgc,*) '* q10anmx = ',q10anmx - WRITE(io_stdo_bgc,*) '* Trefanmx = ',Trefanmx - WRITE(io_stdo_bgc,*) '* alphaanmx = ',alphaanmx - WRITE(io_stdo_bgc,*) '* bkoxanmx = ',bkoxanmx - WRITE(io_stdo_bgc,*) '* bkano2anmx = ',bkano2anmx - WRITE(io_stdo_bgc,*) '* bkanh4anmx = ',bkanh4anmx - WRITE(io_stdo_bgc,*) '* rano2denit = ',rano2denit *dtbinv - WRITE(io_stdo_bgc,*) '* q10ano2denit = ',q10ano2denit - WRITE(io_stdo_bgc,*) '* Trefano2denit = ',Trefano2denit - WRITE(io_stdo_bgc,*) '* bkoxano2denit = ',bkoxano2denit - WRITE(io_stdo_bgc,*) '* bkano2denit = ',bkano2denit - WRITE(io_stdo_bgc,*) '* ran2odenit = ',ran2odenit *dtbinv - WRITE(io_stdo_bgc,*) '* q10an2odenit = ',q10an2odenit - WRITE(io_stdo_bgc,*) '* Trefan2odenit = ',Trefan2odenit - WRITE(io_stdo_bgc,*) '* bkoxan2odenit = ',bkoxan2odenit - WRITE(io_stdo_bgc,*) '* bkan2odenit = ',bkan2odenit - WRITE(io_stdo_bgc,*) '* rdnra = ',rdnra *dtbinv - WRITE(io_stdo_bgc,*) '* q10dnra = ',q10dnra - WRITE(io_stdo_bgc,*) '* Trefdnra = ',Trefdnra - WRITE(io_stdo_bgc,*) '* bkoxdnra = ',bkoxdnra - WRITE(io_stdo_bgc,*) '* bkdnra = ',bkdnra - WRITE(io_stdo_bgc,*) '* ranh4nitr = ',ranh4nitr *dtbinv - WRITE(io_stdo_bgc,*) '* q10anh4nitr = ',q10anh4nitr - WRITE(io_stdo_bgc,*) '* Trefanh4nitr = ',Trefanh4nitr - WRITE(io_stdo_bgc,*) '* bkoxamox = ',bkoxamox - WRITE(io_stdo_bgc,*) '* bkanh4nitr = ',bkanh4nitr - WRITE(io_stdo_bgc,*) '* bkamoxn2o = ',bkamoxn2o - WRITE(io_stdo_bgc,*) '* mufn2o = ',mufn2o - WRITE(io_stdo_bgc,*) '* bn2o = ',bn2o - WRITE(io_stdo_bgc,*) '* n2omaxy = ',n2omaxy - WRITE(io_stdo_bgc,*) '* n2oybeta = ',n2oybeta - WRITE(io_stdo_bgc,*) '* bkyamox = ',bkyamox - WRITE(io_stdo_bgc,*) '* rano2nitr = ',rano2nitr *dtbinv - WRITE(io_stdo_bgc,*) '* q10ano2nitr = ',q10ano2nitr - WRITE(io_stdo_bgc,*) '* Trefano2nitr = ',Trefano2nitr - WRITE(io_stdo_bgc,*) '* bkoxnitr = ',bkoxnitr - WRITE(io_stdo_bgc,*) '* bkano2nitr = ',bkano2nitr - WRITE(io_stdo_bgc,*) '* NOB2AOAy = ',NOB2AOAy - - end subroutine extNwatercol_param_write + CONTAINS -!================================================================================================================================== subroutine nitrification(kpie,kpje,kpke,kbnd,pddpo,omask,ptho) ! Nitrification processes (NH4 -> NO2, NO2 -> NO3) accompanied ! by dark carbon fixation and O2-dependent N2O production @@ -697,5 +484,3 @@ end subroutine extN_inv_check !================================================================================================================================== END MODULE - - diff --git a/hamocc/mo_ocprod.F90 b/hamocc/mo_ocprod.F90 index 295ba53d..c4a00119 100644 --- a/hamocc/mo_ocprod.F90 +++ b/hamocc/mo_ocprod.F90 @@ -76,7 +76,8 @@ subroutine ocprod(kpie,kpje,kpke,kbnd,pdlxp,pdlyp,pddpo,omask,ptho,pi_ph,psao,pp tsfac,vsmall,zdis,wmin,wmax,wlin,rbro, & dmsp1,dmsp2,dmsp3,dmsp4,dmsp5,dmsp6,dms_gamma, & fbro1,fbro2,atten_f,atten_c,atten_uv,atten_w,bkopal,bkphy,bkzoo, & - POM_remin_q10,POM_remin_Tref,opal_remin_q10,opal_remin_Tref + POM_remin_q10,POM_remin_Tref,opal_remin_q10,opal_remin_Tref, & + bkphyanh4,bkphyano3,bkphosph,bkiron,ro2utammo use mo_biomod, only: bsiflx0100,bsiflx0500,bsiflx1000,bsiflx2000,bsiflx4000,bsiflx_bot, & calflx0100,calflx0500,calflx1000,calflx2000,calflx4000,calflx_bot, & carflx0100,carflx0500,carflx1000,carflx2000,carflx4000,carflx_bot, & @@ -100,7 +101,6 @@ subroutine ocprod(kpie,kpje,kpke,kbnd,pdlxp,pdlyp,pddpo,omask,ptho,pi_ph,psao,pp use mo_inventory_bgc, only: inventory_bgc use mo_m4ago, only: mean_aggregate_sinking_speed,ws_agg use mo_extNwatercol, only: nitrification,denit_NO3_to_NO2,anammox,denit_dnra,extN_inv_check - use mo_extNwatercol, only: bkphyanh4,bkphyano3,bkphosph,bkiron,ro2utammo ! Arguments diff --git a/hamocc/mo_param_bgc.F90 b/hamocc/mo_param_bgc.F90 index 355ab6e5..cc1dc698 100644 --- a/hamocc/mo_param_bgc.F90 +++ b/hamocc/mo_param_bgc.F90 @@ -39,7 +39,6 @@ module mo_param_bgc use_sedbypass,with_dmsph,use_PBGC_OCNP_TIMESTEP,ocn_co2_type,lm4ago, & leuphotic_cya,do_ndep_coupled,do_n2onh3_coupled,use_extNcycle use mod_xc, only: mnproc -! use mo_m4ago, only: init_m4ago_nml_params, init_m4ago_params use mo_param1_bgc, only: iatmnh3,iatmn2o ! use mo_extNwatercol,only: extNwatercol_param_init,extNwatercol_param_update,extNwatercol_param_write, & ! rano3denit,rano2anmx,rano2denit,ran2odenit,rdnra,ranh4nitr,rano2nitr @@ -88,6 +87,19 @@ module mo_param_bgc public :: dmsp1,dmsp2,dmsp3,dmsp4,dmsp5,dmsp6,dms_gamma public :: POM_remin_q10,opal_remin_q10,POM_remin_Tref,opal_remin_Tref + ! extended nitrogen cycle + public :: q10ano3denit,sc_ano3denit,Trefano3denit,rano3denit,bkano3denit, & + & rano2anmx,q10anmx,Trefanmx,alphaanmx,bkoxanmx,bkano2anmx,bkanh4anmx, & + & rano2denit,q10ano2denit,Trefano2denit,bkoxano2denit,bkano2denit, & + & ran2odenit,q10an2odenit,Trefan2odenit,bkoxan2odenit,bkan2odenit, & + & rdnra,q10dnra,Trefdnra,bkoxdnra,bkdnra,ranh4nitr,q10anh4nitr, & + & Trefanh4nitr,bkoxamox,bkanh4nitr,bkamoxn2o,bkyamox, & + & rano2nitr,q10ano2nitr,Trefano2nitr,bkoxnitr,bkano2nitr,n2omaxy, & + & n2oybeta,NOB2AOAy,bn2o,mufn2o, & + & rc2n,ro2nnit,rnoxp,rnoxpi,rno2anmx,rno2anmxi,rnh4anmx, & + & rnh4anmxi,rno2dnra,rno2dnrai,rnh4dnra,rnh4dnrai,rnm1, & + & bkphyanh4,bkphyano3,bkphosph,bkiron,ro2utammo + !******************************************************************** ! Stoichiometry and fixed parameters @@ -116,6 +128,22 @@ module mo_param_bgc ! Decay parameter for C14, HalfLive = 5700 years real, parameter :: c14_t_half = 5700.*365. ! Half life of 14C [days] + ! Extended nitrogen cycle + real, parameter :: rc2n = rcar/rnit ! iHAMOCC C:N ratio + real, parameter :: ro2utammo = 140. ! Oxygen utilization per mol detritus during ammonification + real, parameter :: ro2nnit = ro2utammo/rnit ! + real, parameter :: rnoxp = 280. ! consumption of NOx per mol detritus during denitrification + real, parameter :: rnoxpi = 1./rnoxp ! inverse + real, parameter :: rno2anmx = 1144. ! consumption of NO2 per mol organic production by anammox + real, parameter :: rno2anmxi = 1./rno2anmx ! inverse + real, parameter :: rnh4anmx = 880. ! consumption of NH4 per mol organic production by anammox + real, parameter :: rnh4anmxi = 1./rnh4anmx ! inverse + real, parameter :: rno2dnra = 93. + 1./3. ! consumption of NO2 per mol OM degradation during DNRA + real, parameter :: rno2dnrai = 1./rno2dnra ! inverse + real, parameter :: rnh4dnra = rno2dnra + rnit ! production of NH4 per mol OM during DNRA + real, parameter :: rnh4dnrai = 1./rnh4dnra ! inverse + real, parameter :: rnm1 = rnit - 1. + !******************************************************************** ! Atmosphere: !******************************************************************** @@ -236,6 +264,73 @@ module mo_param_bgc real, protected :: POM_remin_Tref = 10. ! [deg C] reference temperatue for Q10-dep. POC remin real, protected :: opal_remin_Tref = 10. ! [deg C] reference temperature for Q10-dep. opal dissolution + !******************************************************************** + ! Extended nitrogen cycle + !******************************************************************** + ! Phytoplankton growth + real, protected :: bkphyanh4 = 0.12e-6 ! Half-saturation constant for NH4 uptake by bulk phytoplankton (kmol/m3) + real, protected :: bkphyano3 = 0.16e-6 ! Half-saturation constant for NO3 uptake by bulk phytoplankton (kmol/m3) + real, protected :: bkphosph = 0.01e-6 ! Half-saturation constant for PO4 uptake by bulk phytoplankton (kmol/m3) + real, protected :: bkiron ! = bkphosph*riron - Half-saturation constant for Fe uptake by bulk phytoplankton (kmol/m3) + + ! === Denitrification step NO3 -> NO2: + real, protected :: rano3denit = 0.05 ! Maximum growth rate denitrification on NO3 at reference T (1/d -> 1/dt) + real, protected :: q10ano3denit = 2. ! Q10 factor for denitrification on NO3 (-) + real, protected :: Trefano3denit = 10. ! Reference temperature for denitrification on NO3 (degr C) + real, protected :: sc_ano3denit = 0.12e6 ! Shape factor for NO3 denitrification oxygen inhibition function (m3/kmol) + real, protected :: bkano3denit = 5.e-6 ! Half-saturation constant for NO3 denitrification (kmol/m3) + + ! === Anammox + real, protected :: rano2anmx = 0.05 ! Maximum growth rate for anammox at reference T (1/d -> 1/dt) + real, protected :: q10anmx = 1.6 ! Q10 factor for anammox (-) + real, protected :: Trefanmx = 10. ! Reference temperature for anammox (degr C) + real, protected :: alphaanmx = 0.45e6 ! Shape factor for anammox oxygen inhibition function (m3/kmol) + real, protected :: bkoxanmx = 11.3e-6 ! Half-saturation constant for oxygen inhibition function (kmol/m3) + real, protected :: bkano2anmx = 5.e-6 ! Half-saturation constant for NO2 limitation (kmol/m3) + real, protected :: bkanh4anmx ! = bkano2anmx * rnh4anmx/rno2anmx !Half-saturation constant for NH4 limitation of anammox (kmol/m3) + + ! === Denitrification step NO2 -> N2O + real, protected :: rano2denit = 0.12 ! Maximum growth rate denitrification on NO2 at reference T (1/d -> 1/dt) + real, protected :: q10ano2denit = 2.0 ! Q10 factor for denitrification on NO2 (-) + real, protected :: Trefano2denit = 10. ! Reference temperature for denitrification on NO2 (degr C) + real, protected :: bkoxano2denit = 2.e-6 ! Half-saturation constant for (quadratic) oxygen inhibition function of denitrification on NO2 (kmol/m3) + real, protected :: bkano2denit = 5.6e-6 ! Half-saturation constant for denitrification on NO2 (kmol/m3) + + ! === Denitrification step N2O -> N2 + real, protected :: ran2odenit = 0.16 ! Maximum growth rate denitrification on N2O at reference T (1/d -> 1/dt) + real, protected :: q10an2odenit = 3. ! Q1- factor for denitrificationj on N2O (-) + real, protected :: Trefan2odenit = 10. ! Reference temperature for denitrification on N2O (degr C) + real, protected :: bkoxan2odenit = 5.e-6 ! Half-saturation constant for (quadratic) oxygen inhibition function of denitrification on N2O (kmol/m3) + real, protected :: bkan2odenit = 1.e-6 ! Half-saturation constant for denitrification on N2O (kmol/m3) + + ! === DNRA NO2 -> NH4 + real, protected :: rdnra = 0.1 ! Maximum growth rate DNRA on NO2 at reference T (1/d -> 1/dt) + real, protected :: q10dnra = 2. ! Q10 factor for DNRA on NO2 (-) + real, protected :: Trefdnra = 10. ! Reference temperature for DNRA (degr C) + real, protected :: bkoxdnra = 2.5e-6 ! Half saturation constant for (quadratic) oxygen inhibition function of DNRA on NO2 (kmol/m3) + real, protected :: bkdnra = 0.05e-6 ! Half-saturation constant for DNRA on NO2 (kmol/m3) + + ! === Nitrification on NH4 + real, protected :: ranh4nitr = 1. ! Maximum growth rate nitrification on NH4 at reference T (1/d -> 1/dt) + real, protected :: q10anh4nitr = 3.3 ! Q10 factor for nitrification on NH4 (-) + real, protected :: Trefanh4nitr = 20. ! Reference temperature for nitrification on NH4 (degr C) + real, protected :: bkoxamox = 0.333e-6 ! Half-saturation constant for oxygen limitation of nitrification on NH4 (kmol/m3) + real, protected :: bkanh4nitr = 0.133e-6 ! Half-saturation constant for nitrification on NH4 (kmol/m3) + real, protected :: bkamoxn2o = 0.5e-6 ! Half saturation constant for NH4 in pathway splitting function N2O for nitrification on NH4 (kmol/m3) + real, protected :: mufn2o ! = 0.11/(50.*1e6*bkoxamox) !=6.61e-3 0.11/(50*1e6)=2.2e-9 - ~Santoro et al. 2011 with simple MM, + real, protected :: bn2o ! = 0.077/(50.*mufn2o) !=0.2331 - before set to 0.3 - base fraction entering N2O + real, protected :: n2omaxy = 0.003 ! Maximum yield of OM on NH4 nitrification (-) + real, protected :: n2oybeta = 18. ! Decay factor for inhibition function for yield during nitrification on NH4 (kmol/m3) + real, protected :: bkyamox = 0.333e-6 ! Half saturation constant for pathway splitting function OM-yield for nitrification on NH4 (kmol/m3) + + ! === Nitrification on NO2 + real, protected :: rano2nitr = 1.54 ! Maximum growth rate nitrification on NO2 at reference T (1/d -> 1/dt) + real, protected :: q10ano2nitr = 2.7 ! Q10 factor for nitrification on NO2 (-) + real, protected :: Trefano2nitr = 20. ! Reference temperature for nitrification on NO2 (degr C) + real, protected :: bkoxnitr = 0.788e-6 ! Half-saturation constant for oxygen limitation of nitrification on NO2 (kmol/m3) + real, protected :: bkano2nitr = 0.287e-6 ! Half-saturation constant for NO2 for nitrification on NO2 (kmol/m3) + real, protected :: NOB2AOAy = 0.44 ! Ratio of NOB versus AOA yield per energy source ~0.043/0.098 according to Zakem et al. 2022 + !******************************************************************** ! Parameters for DMS and BrO schemes @@ -448,14 +543,11 @@ subroutine calc_param_biol() drempoc = 0.12 dremopal = 0.023 endif - ! M4AGO parameters -! call init_m4ago_nml_params() if (use_extNcycle) then - ! initialize the extended nitrogen cycle parameters - first water column, then sediment, - ! since sediment relies on water column parameters for the extended nitrogen cycle - ! Sediment also relies on M4AGO being initialized (POM_remin_q10 and POM_remin_Tref) -! call extNwatercol_param_init() -! call extNsediment_param_init() + bkiron = bkphosph*riron ! Half-saturation constant for Fe uptake by bulk phytoplankton (kmol/m3) + bkanh4anmx = bkano2anmx * rnh4anmx/rno2anmx ! Half-saturation constant for NH4 limitation of anammox (kmol/m3) + mufn2o = 0.11/(50.*1e6*bkoxamox) ! =6.61e-3 0.11/(50*1e6)=2.2e-9 - ~Santoro et al. 2011 with simple MM, + bn2o = 0.077/(50.*mufn2o) ! =0.2331 - before set to 0.3 - base fraction entering N2O endif end subroutine calc_param_biol @@ -497,6 +589,16 @@ subroutine rates_2_timestep() dremn2o = dremn2o*dtb ! 1/d to 1/time step Remineralization rate of detritus on N2O dremsul = dremsul*dtb ! 1/d to 1/time step Remineralization rate for sulphate reduction + ! Extended nitrogen cyle + rano3denit = rano3denit *dtb ! Maximum growth rate denitrification on NO3 at reference T (1/d -> 1/dt) + rano2anmx = rano2anmx *dtb ! Maximum growth rate for anammox at reference T (1/d -> 1/dt) + rano2denit = rano2denit *dtb ! Maximum growth rate denitrification on NO2 at reference T (1/d -> 1/dt) + ran2odenit = ran2odenit *dtb ! Maximum growth rate denitrification on N2O at reference T (1/d -> 1/dt) + rdnra = rdnra *dtb ! Maximum growth rate DNRA on NO2 at reference T (1/d -> 1/dt) + ranh4nitr = ranh4nitr *dtb ! Maximum growth rate nitrification on NH4 at reference T (1/d -> 1/dt) + rano2nitr = rano2nitr *dtb ! Maximum growth rate nitrification on NO2 at reference T (1/d -> 1/dt) + + !******************************************************************** ! Parameters for DMS and BrO schemes !******************************************************************** @@ -650,7 +752,7 @@ subroutine write_parambgc() endif write(io_stdo_bgc,*) '* atm_o2 = ',atm_o2 write(io_stdo_bgc,*) '* atm_n2 = ',atm_n2 - WRITE(io_stdo_bgc,*) '* atm_n2o = ',atm_n2o + write(io_stdo_bgc,*) '* atm_n2o = ',atm_n2o if (use_extNcycle) then write(io_stdo_bgc,*) '* atm_nh3 = ',atm_nh3 endif @@ -777,7 +879,71 @@ subroutine write_parambgc() write(io_stdo_bgc,*) '* claydens = ',claydens endif if (use_extNcycle) then -! call extNwatercol_param_write() + write(io_stdo_bgc,*) '*********************************************************' + write(io_stdo_bgc,*) '* HAMOCC extended nitrogen cycle parameters water column:' + write(io_stdo_bgc,*) '* rc2n = ',rc2n + write(io_stdo_bgc,*) '* ro2utammo = ',ro2utammo + write(io_stdo_bgc,*) '* ro2nnit = ',ro2nnit + write(io_stdo_bgc,*) '* rnoxp = ',rnoxp + write(io_stdo_bgc,*) '* rnoxpi = ',rnoxpi + write(io_stdo_bgc,*) '* rno2anmx = ',rno2anmx + write(io_stdo_bgc,*) '* rno2anmxi = ',rno2anmxi + write(io_stdo_bgc,*) '* rnh4anmx = ',rnh4anmx + write(io_stdo_bgc,*) '* rnh4anmxi = ',rnh4anmxi + write(io_stdo_bgc,*) '* rno2dnra = ',rno2dnra + write(io_stdo_bgc,*) '* rno2dnrai = ',rno2dnrai + write(io_stdo_bgc,*) '* rnh4dnra = ',rnh4dnra + write(io_stdo_bgc,*) '* rnh4dnrai = ',rnh4dnrai + write(io_stdo_bgc,*) '* rnm1 = ',rnm1 + write(io_stdo_bgc,*) '* bkphyanh4 = ',bkphyanh4 + write(io_stdo_bgc,*) '* bkphyano3 = ',bkphyano3 + write(io_stdo_bgc,*) '* bkphosph = ',bkphosph + write(io_stdo_bgc,*) '* bkiron = ',bkiron + write(io_stdo_bgc,*) '* rano3denit = ',rano3denit *dtbinv + write(io_stdo_bgc,*) '* q10ano3denit = ',q10ano3denit + write(io_stdo_bgc,*) '* Trefano3denit = ',Trefano3denit + write(io_stdo_bgc,*) '* sc_ano3denit = ',sc_ano3denit + write(io_stdo_bgc,*) '* bkano3denit = ',bkano3denit + write(io_stdo_bgc,*) '* rano2anmx = ',rano2anmx *dtbinv + write(io_stdo_bgc,*) '* q10anmx = ',q10anmx + write(io_stdo_bgc,*) '* Trefanmx = ',Trefanmx + write(io_stdo_bgc,*) '* alphaanmx = ',alphaanmx + write(io_stdo_bgc,*) '* bkoxanmx = ',bkoxanmx + write(io_stdo_bgc,*) '* bkano2anmx = ',bkano2anmx + write(io_stdo_bgc,*) '* bkanh4anmx = ',bkanh4anmx + write(io_stdo_bgc,*) '* rano2denit = ',rano2denit *dtbinv + write(io_stdo_bgc,*) '* q10ano2denit = ',q10ano2denit + write(io_stdo_bgc,*) '* Trefano2denit = ',Trefano2denit + write(io_stdo_bgc,*) '* bkoxano2denit = ',bkoxano2denit + write(io_stdo_bgc,*) '* bkano2denit = ',bkano2denit + write(io_stdo_bgc,*) '* ran2odenit = ',ran2odenit *dtbinv + write(io_stdo_bgc,*) '* q10an2odenit = ',q10an2odenit + write(io_stdo_bgc,*) '* Trefan2odenit = ',Trefan2odenit + write(io_stdo_bgc,*) '* bkoxan2odenit = ',bkoxan2odenit + write(io_stdo_bgc,*) '* bkan2odenit = ',bkan2odenit + write(io_stdo_bgc,*) '* rdnra = ',rdnra *dtbinv + write(io_stdo_bgc,*) '* q10dnra = ',q10dnra + write(io_stdo_bgc,*) '* Trefdnra = ',Trefdnra + write(io_stdo_bgc,*) '* bkoxdnra = ',bkoxdnra + write(io_stdo_bgc,*) '* bkdnra = ',bkdnra + write(io_stdo_bgc,*) '* ranh4nitr = ',ranh4nitr *dtbinv + write(io_stdo_bgc,*) '* q10anh4nitr = ',q10anh4nitr + write(io_stdo_bgc,*) '* Trefanh4nitr = ',Trefanh4nitr + write(io_stdo_bgc,*) '* bkoxamox = ',bkoxamox + write(io_stdo_bgc,*) '* bkanh4nitr = ',bkanh4nitr + write(io_stdo_bgc,*) '* bkamoxn2o = ',bkamoxn2o + write(io_stdo_bgc,*) '* mufn2o = ',mufn2o + write(io_stdo_bgc,*) '* bn2o = ',bn2o + write(io_stdo_bgc,*) '* n2omaxy = ',n2omaxy + write(io_stdo_bgc,*) '* n2oybeta = ',n2oybeta + write(io_stdo_bgc,*) '* bkyamox = ',bkyamox + write(io_stdo_bgc,*) '* rano2nitr = ',rano2nitr *dtbinv + write(io_stdo_bgc,*) '* q10ano2nitr = ',q10ano2nitr + write(io_stdo_bgc,*) '* Trefano2nitr = ',Trefano2nitr + write(io_stdo_bgc,*) '* bkoxnitr = ',bkoxnitr + write(io_stdo_bgc,*) '* bkano2nitr = ',bkano2nitr + write(io_stdo_bgc,*) '* NOB2AOAy = ',NOB2AOAy + ! call extNsediment_param_write() endif end subroutine write_parambgc diff --git a/hamocc/mo_powach.F90 b/hamocc/mo_powach.F90 index 10fb1f1a..cc04b067 100644 --- a/hamocc/mo_powach.F90 +++ b/hamocc/mo_powach.F90 @@ -39,7 +39,7 @@ subroutine powach(kpie,kpje,kpke,kbnd,prho,omask,psao,ptho,lspin) use mo_carbch, only: co3,keqb,ocetra,sedfluxo use mo_chemcon, only: calcon use mo_param_bgc, only: rnit,rcar,rdnit1,rdnit2,ro2ut,disso_sil,silsat,disso_poc,sed_denit, & - disso_caco3 + disso_caco3,ro2utammo use mo_sedmnt, only: porwat,porsol,powtra,produs,prcaca,prorca,seddw,sedhpl,sedlay, & silpro,pror13,pror14,prca13,prca14 use mo_vgrid, only: kbo,bolay @@ -47,10 +47,9 @@ subroutine powach(kpie,kpje,kpke,kbnd,prho,omask,psao,ptho,lspin) use mo_carchm, only: carchm_solve use mo_dipowa, only: dipowa - use mo_extNwatercol, only: ro2utammo - use mo_extNsediment, only: extNsediment_param_init,sed_nitrification,sed_denit_NO3_to_NO2,sed_anammox,sed_denit_DNRA, & - & extNsed_diagnostics,ised_remin_aerob,ised_remin_sulf,POM_remin_q10_sed,POM_remin_Tref_sed, & - & bkox_drempoc_sed + use mo_extNsediment,only: extNsediment_param_init,sed_nitrification,sed_denit_NO3_to_NO2,sed_anammox,sed_denit_DNRA, & + & extNsed_diagnostics,ised_remin_aerob,ised_remin_sulf,POM_remin_q10_sed,POM_remin_Tref_sed, & + & bkox_drempoc_sed ! Arguments From 59ad3b5c0363a14d09caed316fae6c651626e85d Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Mon, 22 Jan 2024 16:19:47 +0100 Subject: [PATCH 326/366] move extended nitrogen cycle sediment parameters to mo_param_bgc --- hamocc/mo_extNsediment.F90 | 194 +++-------------------------- hamocc/mo_param_bgc.F90 | 241 ++++++++++++++++++++++++++++--------- hamocc/mo_powach.F90 | 10 +- 3 files changed, 203 insertions(+), 242 deletions(-) diff --git a/hamocc/mo_extNsediment.F90 b/hamocc/mo_extNsediment.F90 index 393a3e0c..bc165ff4 100644 --- a/hamocc/mo_extNsediment.F90 +++ b/hamocc/mo_extNsediment.F90 @@ -45,9 +45,16 @@ MODULE mo_extNsediment use mo_param1_bgc, only: issso12,ipowaic,ipowaal,ipowaph,ipowaox,ipown2,ipowno3,ipownh4,ipown2o,ipowno2,ks use mo_vgrid, only: kbo use mo_param_bgc, only: rnit,rcar,rnoi, & - & rc2n,ro2utammo,ro2nnit,rnoxp,rnoxpi,rno2anmx,rno2anmxi,rnh4anmx, & - & rnh4anmxi,rno2dnra,rno2dnrai,rnh4dnra,rnh4dnrai,rnm1 - + & rc2n,ro2utammo,ro2nnit,rnoxp,rnoxpi,rno2anmx,rno2anmxi,rnh4anmx, & + & rnh4anmxi,rno2dnra,rno2dnrai,rnh4dnra,rnh4dnrai,rnm1, & + & q10ano3denit_sed,sc_ano3denit_sed,Trefano3denit_sed,rano3denit_sed,bkano3denit_sed, & + & rano2anmx_sed,q10anmx_sed,Trefanmx_sed,alphaanmx_sed,bkoxanmx_sed,bkano2anmx_sed,bkanh4anmx_sed, & + & rano2denit_sed,q10ano2denit_sed,Trefano2denit_sed,bkoxano2denit_sed,bkano2denit_sed, & + & ran2odenit_sed,q10an2odenit_sed,Trefan2odenit_sed,bkoxan2odenit_sed,bkan2odenit_sed, & + & rdnra_sed,q10dnra_sed,Trefdnra_sed,bkoxdnra_sed,bkdnra_sed,ranh4nitr_sed,q10anh4nitr_sed, & + & Trefanh4nitr_sed,bkoxamox_sed,bkanh4nitr_sed,bkamoxn2o_sed,bkyamox_sed, & + & rano2nitr_sed,q10ano2nitr_sed,Trefano2nitr_sed,bkoxnitr_sed,bkano2nitr_sed,n2omaxy_sed, & + & n2oybeta_sed,NOB2AOAy_sed,bn2o_sed,mufn2o_sed,POM_remin_q10_sed, POM_remin_Tref_sed,bkox_drempoc_sed use mo_control_bgc, only: io_stdo_bgc,dtb use mo_sedmnt, only: powtra,sedlay,porsol,porwat @@ -56,25 +63,11 @@ MODULE mo_extNsediment private ! public functions - public :: extNsediment_param_init,sed_nitrification,sed_denit_NO3_to_NO2,sed_anammox,sed_denit_DNRA,alloc_mem_extNsediment_diag, & - extNsediment_param_update,extNsediment_param_write + public :: sed_nitrification,sed_denit_NO3_to_NO2,sed_anammox,sed_denit_DNRA,alloc_mem_extNsediment_diag ! public parameters and fields public :: ised_nitr_NH4,ised_nitr_NO2,ised_nitr_N2O_prod,ised_nitr_NH4_OM,ised_nitr_NO2_OM,ised_denit_NO3,ised_denit_NO2, & - ised_denit_N2O,ised_DNRA_NO2,ised_anmx_N2_prod,ised_anmx_OM_prod,ised_remin_aerob,ised_remin_sulf,extNsed_diagnostics, & - POM_remin_q10_sed, POM_remin_Tref_sed,bkox_drempoc_sed, & - rano3denit_sed,rano2anmx_sed,rano2denit_sed,ran2odenit_sed,rdnra_sed,ranh4nitr_sed,rano2nitr_sed - - - ! extended nitrogen cycle sediment parameters - real :: q10ano3denit_sed,sc_ano3denit_sed,Trefano3denit_sed,rano3denit_sed,bkano3denit_sed, & - & rano2anmx_sed,q10anmx_sed,Trefanmx_sed,alphaanmx_sed,bkoxanmx_sed,bkano2anmx_sed,bkanh4anmx_sed, & - & rano2denit_sed,q10ano2denit_sed,Trefano2denit_sed,bkoxano2denit_sed,bkano2denit_sed, & - & ran2odenit_sed,q10an2odenit_sed,Trefan2odenit_sed,bkoxan2odenit_sed,bkan2odenit_sed, & - & rdnra_sed,q10dnra_sed,Trefdnra_sed,bkoxdnra_sed,bkdnra_sed,ranh4nitr_sed,q10anh4nitr_sed, & - & Trefanh4nitr_sed,bkoxamox_sed,bkanh4nitr_sed,bkamoxn2o_sed,bkyamox_sed, & - & rano2nitr_sed,q10ano2nitr_sed,Trefano2nitr_sed,bkoxnitr_sed,bkano2nitr_sed,n2omaxy_sed, & - & n2oybeta_sed,NOB2AOAy_sed,bn2o_sed,mufn2o_sed,POM_remin_q10_sed, POM_remin_Tref_sed,bkox_drempoc_sed + ised_denit_N2O,ised_DNRA_NO2,ised_anmx_N2_prod,ised_anmx_OM_prod,ised_remin_aerob,ised_remin_sulf,extNsed_diagnostics ! output real, dimension (:,:,:,:), allocatable :: extNsed_diagnostics @@ -94,7 +87,8 @@ MODULE mo_extNsediment ised_remin_sulf = 13, & n_seddiag = 13 - real :: eps,minlim + real :: eps = 1.e-25 + real :: minlim = 1.e-9 contains @@ -123,166 +117,6 @@ subroutine alloc_mem_extNsediment_diag(kpie,kpje,ksed) end subroutine alloc_mem_extNsediment_diag - ! ================================================================================================================================ - subroutine extNsediment_param_init() - use mo_param_bgc,only: q10ano3denit,sc_ano3denit,Trefano3denit,bkano3denit, & - & q10anmx,Trefanmx,alphaanmx,bkoxanmx,bkano2anmx, & - & q10ano2denit,Trefano2denit,bkoxano2denit,bkano2denit, & - & q10an2odenit,Trefan2odenit,bkoxan2odenit,bkan2odenit, & - & q10dnra,Trefdnra,bkoxdnra,bkdnra, & - & q10anh4nitr,Trefanh4nitr,bkoxamox,bkanh4nitr,bkamoxn2o,bkyamox,n2omaxy,n2oybeta, & - & q10ano2nitr,Trefano2nitr,bkoxnitr,bkano2nitr,NOB2AOAy,rno2anmx,rnh4anmx - use mo_param_bgc, only: bkox_drempoc,POM_remin_q10,POM_remin_Tref - - implicit none - - ! === Ammonification in the sediment - POM_remin_q10_sed = POM_remin_q10 ! ammonification Q10 in sediment - POM_remin_Tref_sed = POM_remin_Tref ! ammonification Tref in sediment - bkox_drempoc_sed = bkox_drempoc ! half saturation constant for O2 limitatio of ammonification in sediment - - ! === Denitrification step NO3 -> NO2: - !rano3denit_sed = 0.15*dtb ! Maximum growth rate denitrification on NO3 at reference T (1/d -> 1/dt) - rano3denit_sed = 0.05 ! Maximum growth rate denitrification on NO3 at reference T (1/d -> 1/dt) - q10ano3denit_sed = q10ano3denit ! Q10 factor for denitrification on NO3 (-) - Trefano3denit_sed = Trefano3denit ! Reference temperature for denitrification on NO3 (degr C) - !sc_ano3denit_sed = 0.05e6 ! Shape factor for NO3 denitrification oxygen inhibition function (m3/kmol) - sc_ano3denit_sed = sc_ano3denit ! Shape factor for NO3 denitrification oxygen inhibition function (m3/kmol) - bkano3denit_sed = bkano3denit ! Half-saturation constant for NO3 denitrification (kmol/m3) - - ! === Anammox - rano2anmx_sed = 0.05 ! Maximum growth rate for anammox at reference T (1/d -> 1/dt) - q10anmx_sed = q10anmx ! Q10 factor for anammox (-) - Trefanmx_sed = Trefanmx ! Reference temperature for anammox (degr C) - alphaanmx_sed = alphaanmx ! Shape factor for anammox oxygen inhibition function (m3/kmol) - bkoxanmx_sed = bkoxanmx ! Half-saturation constant for oxygen inhibition function (kmol/m3) - bkano2anmx_sed = bkano2anmx ! Half-saturation constant for NO2 limitation (kmol/m3) - bkanh4anmx_sed = bkano2anmx_sed * rnh4anmx/rno2anmx !Half-saturation constant for NH4 limitation of anammox (kmol/m3) - - ! === Denitrification step NO2 -> N2O - rano2denit_sed = 0.12 ! Maximum growth rate denitrification on NO2 at reference T (1/d -> 1/dt) - q10ano2denit_sed = q10ano2denit ! Q10 factor for denitrification on NO2 (-) - Trefano2denit_sed = Trefano2denit ! Reference temperature for denitrification on NO2 (degr C) - bkoxano2denit_sed = bkoxano2denit ! Half-saturation constant for (quadratic) oxygen inhibition function of denitrification on NO2 (kmol/m3) - bkano2denit_sed = bkano2denit ! Half-saturation constant for denitrification on NO2 (kmol/m3) - - ! === Denitrification step N2O -> N2 - ran2odenit_sed = 0.16 ! Maximum growth rate denitrification on N2O at reference T (1/d -> 1/dt) - q10an2odenit_sed = q10an2odenit ! Q1- factor for denitrificationj on N2O (-) - Trefan2odenit_sed = Trefan2odenit ! Reference temperature for denitrification on N2O (degr C) - bkoxan2odenit_sed = bkoxan2odenit ! Half-saturation constant for (quadratic) oxygen inhibition function of denitrification on N2O (kmol/m3) - bkan2odenit_sed = bkan2odenit ! Half-saturation constant for denitrification on N2O (kmol/m3) - - ! === DNRA NO2 -> NH4 - rdnra_sed = 0.1 ! Maximum growth rate DNRA on NO2 at reference T (1/d -> 1/dt) - q10dnra_sed = q10dnra ! Q10 factor for DNRA on NO2 (-) - Trefdnra_sed = Trefdnra ! Reference temperature for DNRA (degr C) - bkoxdnra_sed = bkoxdnra ! Half saturation constant for (quadratic) oxygen inhibition function of DNRA on NO2 (kmol/m3) - bkdnra_sed = bkdnra ! Half-saturation constant for DNRA on NO2 (kmol/m3) - - ! === Nitrification on NH4 - ranh4nitr_sed = 1. ! Maximum growth rate nitrification on NH4 at reference T (1/d -> 1/dt) - q10anh4nitr_sed = q10anh4nitr ! Q10 factor for nitrification on NH4 (-) - Trefanh4nitr_sed = Trefanh4nitr ! Reference temperature for nitrification on NH4 (degr C) - bkoxamox_sed = bkoxamox ! Half-saturation constant for oxygen limitation of nitrification on NH4 (kmol/m3) - bkanh4nitr_sed = bkanh4nitr ! Half-saturation constant for nitrification on NH4 (kmol/m3) -!====== -! OLD VERSION OF pathway splitting function - !bkamoxn2o_sed = 0.453e-6 ! Half saturation constant for O2 in pathway splitting function N2O for nitrification on NH4 (kmol/m3) -! NEW version similar to Santoros 2021, Ji 2018: - bkamoxn2o_sed = bkamoxn2o ! Half saturation constant for NH4 in pathway splitting function N2O for nitrification on NH4 (kmol/m3) - mufn2o_sed = 0.11/(50.*1e6*bkoxamox_sed) !=6.61e-3 0.11/(50*1e6)=2.2e-9 - ~Santoro et al. 2011 with simple MM, - bn2o_sed = 0.077/(50.*mufn2o_sed) !=0.2331 - before set to 0.3 - base fraction entering N2O -!====== - !bkamoxno2_sed = 0.479e-6 ! Half saturation constant for pathway splitting function N2O for nitrification on NH4 (kmol/m3) - ! bkamoxno2_sed = bkamoxno2 ! Half saturation constant for pathway splitting function N2O for nitrification on NH4 (kmol/m3) - n2omaxy_sed = n2omaxy ! Maximum yield of OM on NH4 nitrification (-) - n2oybeta_sed = n2oybeta ! Decay factor for inhibition function for yield during nitrification on NH4 (kmol/m3) - bkyamox_sed = bkyamox ! Half saturation constant for pathway splitting function OM-yield for nitrification on NH4 (kmol/m3) - - ! === Nitrification on NO2 - rano2nitr_sed = 1.54 ! Maximum growth rate nitrification on NO2 at reference T (1/d -> 1/dt) - q10ano2nitr_sed = q10ano2nitr ! Q10 factor for nitrification on NO2 (-) - Trefano2nitr_sed = Trefano2nitr ! Reference temperature for nitrification on NO2 (degr C) - bkoxnitr_sed = bkoxnitr ! Half-saturation constant for oxygen limitation of nitrification on NO2 (kmol/m3) - bkano2nitr_sed = bkano2nitr ! Half-saturation constant for NO2 for nitrification on NO2 (kmol/m3) - NOB2AOAy_sed = NOB2AOAy ! Ratio of NOB versus AOA yield per energy source ~0.043/0.098 according to Zakem et al. 2022 - - eps = 1.e-25 ! safe division etc. - minlim = 1.e-9 ! minimum for limitation functions (e.g. nutlim or oxlim/inh can only decrease to minlim) - end subroutine extNsediment_param_init - - ! ================================================================================================================================ - subroutine extNsediment_param_update() - - rano3denit_sed = rano3denit_sed *dtb ! Maximum growth rate denitrification on NO3 at reference T (1/d -> 1/dt) - rano2anmx_sed = rano2anmx_sed *dtb ! Maximum growth rate for anammox at reference T (1/d -> 1/dt) - rano2denit_sed = rano2denit_sed *dtb ! Maximum growth rate denitrification on NO2 at reference T (1/d -> 1/dt) - ran2odenit_sed = ran2odenit_sed *dtb ! Maximum growth rate denitrification on N2O at reference T (1/d -> 1/dt) - rdnra_sed = rdnra_sed *dtb ! Maximum growth rate DNRA on NO2 at reference T (1/d -> 1/dt) - ranh4nitr_sed = ranh4nitr_sed *dtb ! Maximum growth rate nitrification on NH4 at reference T (1/d -> 1/dt) - rano2nitr_sed = rano2nitr_sed *dtb ! Maximum growth rate nitrification on NO2 at reference T (1/d -> 1/dt) - - end subroutine extNsediment_param_update - - ! ================================================================================================================================ - subroutine extNsediment_param_write() - - REAL :: dtbinv - dtbinv = 1./dtb - - WRITE(io_stdo_bgc,*) '****************************************************************' - WRITE(io_stdo_bgc,*) '* HAMOCC extended nitrogen cycle parameters sediment:' - WRITE(io_stdo_bgc,*) '* POM_remin_q10_sed = ', POM_remin_q10_sed - WRITE(io_stdo_bgc,*) '* POM_remin_Tref_sed= ', POM_remin_Tref_sed - WRITE(io_stdo_bgc,*) '* bkox_drempoc_sed = ', bkox_drempoc_sed - WRITE(io_stdo_bgc,*) '* rano3denit_sed = ',rano3denit_sed *dtbinv - WRITE(io_stdo_bgc,*) '* q10ano3denit_sed = ',q10ano3denit_sed - WRITE(io_stdo_bgc,*) '* Trefano3denit_sed = ',Trefano3denit_sed - WRITE(io_stdo_bgc,*) '* sc_ano3denit_sed = ',sc_ano3denit_sed - WRITE(io_stdo_bgc,*) '* bkano3denit_sed = ',bkano3denit_sed - WRITE(io_stdo_bgc,*) '* rano2anmx_sed = ',rano2anmx_sed *dtbinv - WRITE(io_stdo_bgc,*) '* q10anmx_sed = ',q10anmx_sed - WRITE(io_stdo_bgc,*) '* Trefanmx_sed = ',Trefanmx_sed - WRITE(io_stdo_bgc,*) '* alphaanmx_sed = ',alphaanmx_sed - WRITE(io_stdo_bgc,*) '* bkoxanmx_sed = ',bkoxanmx_sed - WRITE(io_stdo_bgc,*) '* bkano2anmx_sed = ',bkano2anmx_sed - WRITE(io_stdo_bgc,*) '* bkanh4anmx_sed = ',bkanh4anmx_sed - WRITE(io_stdo_bgc,*) '* rano2denit_sed = ',rano2denit_sed *dtbinv - WRITE(io_stdo_bgc,*) '* q10ano2denit_sed = ',q10ano2denit_sed - WRITE(io_stdo_bgc,*) '* Trefano2denit_sed = ',Trefano2denit_sed - WRITE(io_stdo_bgc,*) '* bkoxano2denit_sed = ',bkoxano2denit_sed - WRITE(io_stdo_bgc,*) '* bkano2denit_sed = ',bkano2denit_sed - WRITE(io_stdo_bgc,*) '* ran2odenit_sed = ',ran2odenit_sed *dtbinv - WRITE(io_stdo_bgc,*) '* q10an2odenit_sed = ',q10an2odenit_sed - WRITE(io_stdo_bgc,*) '* Trefan2odenit_sed = ',Trefan2odenit_sed - WRITE(io_stdo_bgc,*) '* bkoxan2odenit_sed = ',bkoxan2odenit_sed - WRITE(io_stdo_bgc,*) '* bkan2odenit_sed = ',bkan2odenit_sed - WRITE(io_stdo_bgc,*) '* rdnra_sed = ',rdnra_sed *dtbinv - WRITE(io_stdo_bgc,*) '* q10dnra_sed = ',q10dnra_sed - WRITE(io_stdo_bgc,*) '* Trefdnra_sed = ',Trefdnra_sed - WRITE(io_stdo_bgc,*) '* bkoxdnra_sed = ',bkoxdnra_sed - WRITE(io_stdo_bgc,*) '* bkdnra_sed = ',bkdnra_sed - WRITE(io_stdo_bgc,*) '* ranh4nitr_sed = ',ranh4nitr_sed *dtbinv - WRITE(io_stdo_bgc,*) '* q10anh4nitr_sed = ',q10anh4nitr_sed - WRITE(io_stdo_bgc,*) '* Trefanh4nitr_sed = ',Trefanh4nitr_sed - WRITE(io_stdo_bgc,*) '* bkoxamox_sed = ',bkoxamox_sed - WRITE(io_stdo_bgc,*) '* bkanh4nitr_sed = ',bkanh4nitr_sed - WRITE(io_stdo_bgc,*) '* bkamoxn2o_sed = ',bkamoxn2o_sed - WRITE(io_stdo_bgc,*) '* mufn2o_sed = ',mufn2o_sed - WRITE(io_stdo_bgc,*) '* bn2o_sed = ',bn2o_sed - WRITE(io_stdo_bgc,*) '* n2omaxy_sed = ',n2omaxy_sed - WRITE(io_stdo_bgc,*) '* n2oybeta_sed = ',n2oybeta_sed - WRITE(io_stdo_bgc,*) '* bkyamox_sed = ',bkyamox_sed - WRITE(io_stdo_bgc,*) '* rano2nitr_sed = ',rano2nitr_sed *dtbinv - WRITE(io_stdo_bgc,*) '* q10ano2nitr_sed = ',q10ano2nitr_sed - WRITE(io_stdo_bgc,*) '* Trefano2nitr_sed = ',Trefano2nitr_sed - WRITE(io_stdo_bgc,*) '* bkoxnitr_sed = ',bkoxnitr_sed - WRITE(io_stdo_bgc,*) '* bkano2nitr_sed = ',bkano2nitr_sed - WRITE(io_stdo_bgc,*) '* NOB2AOAy_sed = ',NOB2AOAy_sed - - end subroutine extNsediment_param_write - ! ================================================================================================================================ subroutine sed_nitrification(j,kpie,kpje,kpke,kbnd,ptho,omask,ex_ddic,ex_dalk) integer, intent(in) :: j,kpie,kpje,kpke,kbnd diff --git a/hamocc/mo_param_bgc.F90 b/hamocc/mo_param_bgc.F90 index cc1dc698..bd787ce2 100644 --- a/hamocc/mo_param_bgc.F90 +++ b/hamocc/mo_param_bgc.F90 @@ -40,10 +40,6 @@ module mo_param_bgc leuphotic_cya,do_ndep_coupled,do_n2onh3_coupled,use_extNcycle use mod_xc, only: mnproc use mo_param1_bgc, only: iatmnh3,iatmn2o -! use mo_extNwatercol,only: extNwatercol_param_init,extNwatercol_param_update,extNwatercol_param_write, & -! rano3denit,rano2anmx,rano2denit,ran2odenit,rdnra,ranh4nitr,rano2nitr -! use mo_extNsediment,only: extNsediment_param_init,extNsediment_param_update,extNsediment_param_write, & -! rano3denit_sed,rano2anmx_sed,rano2denit_sed,ran2odenit_sed,rdnra_sed,ranh4nitr_sed,rano2nitr_sed implicit none private @@ -88,17 +84,28 @@ module mo_param_bgc public :: POM_remin_q10,opal_remin_q10,POM_remin_Tref,opal_remin_Tref ! extended nitrogen cycle - public :: q10ano3denit,sc_ano3denit,Trefano3denit,rano3denit,bkano3denit, & - & rano2anmx,q10anmx,Trefanmx,alphaanmx,bkoxanmx,bkano2anmx,bkanh4anmx, & - & rano2denit,q10ano2denit,Trefano2denit,bkoxano2denit,bkano2denit, & - & ran2odenit,q10an2odenit,Trefan2odenit,bkoxan2odenit,bkan2odenit, & - & rdnra,q10dnra,Trefdnra,bkoxdnra,bkdnra,ranh4nitr,q10anh4nitr, & - & Trefanh4nitr,bkoxamox,bkanh4nitr,bkamoxn2o,bkyamox, & - & rano2nitr,q10ano2nitr,Trefano2nitr,bkoxnitr,bkano2nitr,n2omaxy, & - & n2oybeta,NOB2AOAy,bn2o,mufn2o, & - & rc2n,ro2nnit,rnoxp,rnoxpi,rno2anmx,rno2anmxi,rnh4anmx, & - & rnh4anmxi,rno2dnra,rno2dnrai,rnh4dnra,rnh4dnrai,rnm1, & - & bkphyanh4,bkphyano3,bkphosph,bkiron,ro2utammo + public :: q10ano3denit,sc_ano3denit,Trefano3denit,rano3denit,bkano3denit, & + & rano2anmx,q10anmx,Trefanmx,alphaanmx,bkoxanmx,bkano2anmx,bkanh4anmx, & + & rano2denit,q10ano2denit,Trefano2denit,bkoxano2denit,bkano2denit, & + & ran2odenit,q10an2odenit,Trefan2odenit,bkoxan2odenit,bkan2odenit, & + & rdnra,q10dnra,Trefdnra,bkoxdnra,bkdnra,ranh4nitr,q10anh4nitr, & + & Trefanh4nitr,bkoxamox,bkanh4nitr,bkamoxn2o,bkyamox, & + & rano2nitr,q10ano2nitr,Trefano2nitr,bkoxnitr,bkano2nitr,n2omaxy, & + & n2oybeta,NOB2AOAy,bn2o,mufn2o, & + & rc2n,ro2nnit,rnoxp,rnoxpi,rno2anmx,rno2anmxi,rnh4anmx, & + & rnh4anmxi,rno2dnra,rno2dnrai,rnh4dnra,rnh4dnrai,rnm1, & + & bkphyanh4,bkphyano3,bkphosph,bkiron,ro2utammo, & + & q10ano3denit_sed,sc_ano3denit_sed,Trefano3denit_sed,rano3denit_sed, & + & bkano3denit_sed,rano2anmx_sed,q10anmx_sed,Trefanmx_sed,alphaanmx_sed,& + & bkoxanmx_sed,bkano2anmx_sed,bkanh4anmx_sed,rano2denit_sed, & + & q10ano2denit_sed,Trefano2denit_sed,bkoxano2denit_sed,bkano2denit_sed,& + & ran2odenit_sed,q10an2odenit_sed,Trefan2odenit_sed,bkoxan2odenit_sed, & + & bkan2odenit_sed,rdnra_sed,q10dnra_sed,Trefdnra_sed,bkoxdnra_sed, & + & bkdnra_sed,ranh4nitr_sed,q10anh4nitr_sed,Trefanh4nitr_sed, & + & bkoxamox_sed,bkanh4nitr_sed,bkamoxn2o_sed,bkyamox_sed, & + & rano2nitr_sed,q10ano2nitr_sed,Trefano2nitr_sed,bkoxnitr_sed, & + & bkano2nitr_sed,n2omaxy_sed,n2oybeta_sed,NOB2AOAy_sed,bn2o_sed, & + & mufn2o_sed,POM_remin_q10_sed, POM_remin_Tref_sed,bkox_drempoc_sed !******************************************************************** @@ -251,18 +258,18 @@ module mo_param_bgc !******************************************************************** ! Remineralization and dissolution parameters !******************************************************************** - real, protected :: remido = 0.004 ! 1/d - remineralization rate (of DOM) + real, protected :: remido = 0.004 ! 1/d - remineralization rate (of DOM) ! deep sea remineralisation constants - real, protected :: drempoc = 0.025 ! 1/d Aerob remineralization rate detritus - real, protected :: drempoc_anaerob = 1.25e-3 ! =0.05*drempoc - remin in sub-/anoxic environm. - not be overwritten by lm4ago - real, protected :: bkox_drempoc = 1e-7 ! half-saturation constant for oxygen for ammonification (aerobic remin via drempoc) - real, protected :: dremopal = 0.003 ! 1/d Dissolution rate for opal - real, protected :: dremn2o = 0.01 ! 1/d Remineralization rate of detritus on N2O - real, protected :: dremsul = 0.005 ! 1/d Remineralization rate for sulphate reduction - real, protected :: POM_remin_q10 = 2.1 ! Bidle et al. 2002: Regulation of Oceanic Silicon... - real, protected :: opal_remin_q10 = 2.6 ! Bidle et al. 2002: Regulation of Oceanic Silicon... - real, protected :: POM_remin_Tref = 10. ! [deg C] reference temperatue for Q10-dep. POC remin - real, protected :: opal_remin_Tref = 10. ! [deg C] reference temperature for Q10-dep. opal dissolution + real, protected :: drempoc = 0.025 ! 1/d Aerob remineralization rate detritus + real, protected :: drempoc_anaerob = 1.25e-3 ! =0.05*drempoc - remin in sub-/anoxic environm. - not be overwritten by lm4ago + real, protected :: bkox_drempoc = 1e-7 ! half-saturation constant for oxygen for ammonification (aerobic remin via drempoc) + real, protected :: dremopal = 0.003 ! 1/d Dissolution rate for opal + real, protected :: dremn2o = 0.01 ! 1/d Remineralization rate of detritus on N2O + real, protected :: dremsul = 0.005 ! 1/d Remineralization rate for sulphate reduction + real, protected :: POM_remin_q10 = 2.1 ! Bidle et al. 2002: Regulation of Oceanic Silicon... + real, protected :: opal_remin_q10 = 2.6 ! Bidle et al. 2002: Regulation of Oceanic Silicon... + real, protected :: POM_remin_Tref = 10. ! [deg C] reference temperatue for Q10-dep. POC remin + real, protected :: opal_remin_Tref = 10. ! [deg C] reference temperature for Q10-dep. opal dissolution !******************************************************************** ! Extended nitrogen cycle @@ -276,7 +283,7 @@ module mo_param_bgc ! === Denitrification step NO3 -> NO2: real, protected :: rano3denit = 0.05 ! Maximum growth rate denitrification on NO3 at reference T (1/d -> 1/dt) real, protected :: q10ano3denit = 2. ! Q10 factor for denitrification on NO3 (-) - real, protected :: Trefano3denit = 10. ! Reference temperature for denitrification on NO3 (degr C) + real, protected :: Trefano3denit = 10. ! Reference temperature for denitrification on NO3 (degr C) real, protected :: sc_ano3denit = 0.12e6 ! Shape factor for NO3 denitrification oxygen inhibition function (m3/kmol) real, protected :: bkano3denit = 5.e-6 ! Half-saturation constant for NO3 denitrification (kmol/m3) @@ -290,7 +297,7 @@ module mo_param_bgc real, protected :: bkanh4anmx ! = bkano2anmx * rnh4anmx/rno2anmx !Half-saturation constant for NH4 limitation of anammox (kmol/m3) ! === Denitrification step NO2 -> N2O - real, protected :: rano2denit = 0.12 ! Maximum growth rate denitrification on NO2 at reference T (1/d -> 1/dt) + real, protected :: rano2denit = 0.12 ! Maximum growth rate denitrification on NO2 at reference T (1/d -> 1/dt) real, protected :: q10ano2denit = 2.0 ! Q10 factor for denitrification on NO2 (-) real, protected :: Trefano2denit = 10. ! Reference temperature for denitrification on NO2 (degr C) real, protected :: bkoxano2denit = 2.e-6 ! Half-saturation constant for (quadratic) oxygen inhibition function of denitrification on NO2 (kmol/m3) @@ -311,26 +318,88 @@ module mo_param_bgc real, protected :: bkdnra = 0.05e-6 ! Half-saturation constant for DNRA on NO2 (kmol/m3) ! === Nitrification on NH4 - real, protected :: ranh4nitr = 1. ! Maximum growth rate nitrification on NH4 at reference T (1/d -> 1/dt) + real, protected :: ranh4nitr = 1. ! Maximum growth rate nitrification on NH4 at reference T (1/d -> 1/dt) real, protected :: q10anh4nitr = 3.3 ! Q10 factor for nitrification on NH4 (-) real, protected :: Trefanh4nitr = 20. ! Reference temperature for nitrification on NH4 (degr C) real, protected :: bkoxamox = 0.333e-6 ! Half-saturation constant for oxygen limitation of nitrification on NH4 (kmol/m3) real, protected :: bkanh4nitr = 0.133e-6 ! Half-saturation constant for nitrification on NH4 (kmol/m3) real, protected :: bkamoxn2o = 0.5e-6 ! Half saturation constant for NH4 in pathway splitting function N2O for nitrification on NH4 (kmol/m3) - real, protected :: mufn2o ! = 0.11/(50.*1e6*bkoxamox) !=6.61e-3 0.11/(50*1e6)=2.2e-9 - ~Santoro et al. 2011 with simple MM, - real, protected :: bn2o ! = 0.077/(50.*mufn2o) !=0.2331 - before set to 0.3 - base fraction entering N2O + real, protected :: mufn2o ! = 0.11/(50.*1e6*bkoxamox) !=6.61e-3 0.11/(50*1e6)=2.2e-9 - ~Santoro et al. 2011 with simple MM, + real, protected :: bn2o ! = 0.077/(50.*mufn2o) !=0.2331 - before set to 0.3 - base fraction entering N2O real, protected :: n2omaxy = 0.003 ! Maximum yield of OM on NH4 nitrification (-) real, protected :: n2oybeta = 18. ! Decay factor for inhibition function for yield during nitrification on NH4 (kmol/m3) real, protected :: bkyamox = 0.333e-6 ! Half saturation constant for pathway splitting function OM-yield for nitrification on NH4 (kmol/m3) ! === Nitrification on NO2 - real, protected :: rano2nitr = 1.54 ! Maximum growth rate nitrification on NO2 at reference T (1/d -> 1/dt) + real, protected :: rano2nitr = 1.54 ! Maximum growth rate nitrification on NO2 at reference T (1/d -> 1/dt) real, protected :: q10ano2nitr = 2.7 ! Q10 factor for nitrification on NO2 (-) real, protected :: Trefano2nitr = 20. ! Reference temperature for nitrification on NO2 (degr C) real, protected :: bkoxnitr = 0.788e-6 ! Half-saturation constant for oxygen limitation of nitrification on NO2 (kmol/m3) real, protected :: bkano2nitr = 0.287e-6 ! Half-saturation constant for NO2 for nitrification on NO2 (kmol/m3) real, protected :: NOB2AOAy = 0.44 ! Ratio of NOB versus AOA yield per energy source ~0.043/0.098 according to Zakem et al. 2022 + ! === Ammonification in the sediment + real, protected :: POM_remin_q10_sed = 2.1 ! ammonification Q10 in sediment + real, protected :: POM_remin_Tref_sed = 10. ! ammonification Tref in sediment + real, protected :: bkox_drempoc_sed = 1e-7 ! half saturation constant for O2 limitatio of ammonification in sediment + + ! === Denitrification step NO3 -> NO2: + real, protected :: rano3denit_sed = 0.05 ! Maximum growth rate denitrification on NO3 at reference T (1/d -> 1/dt) + real, protected :: q10ano3denit_sed = 2. ! Q10 factor for denitrification on NO3 (-) + real, protected :: Trefano3denit_sed = 10. ! Reference temperature for denitrification on NO3 (degr C) + real, protected :: sc_ano3denit_sed = 0.12e6 ! Shape factor for NO3 denitrification oxygen inhibition function (m3/kmol) + real, protected :: bkano3denit_sed = 5.e-6 ! Half-saturation constant for NO3 denitrification (kmol/m3) + + ! === Anammox + real, protected :: rano2anmx_sed = 0.05 ! Maximum growth rate for anammox at reference T (1/d -> 1/dt) + real, protected :: q10anmx_sed = 1.6 ! Q10 factor for anammox (-) + real, protected :: Trefanmx_sed = 10. ! Reference temperature for anammox (degr C) + real, protected :: alphaanmx_sed = 0.45e6 ! Shape factor for anammox oxygen inhibition function (m3/kmol) + real, protected :: bkoxanmx_sed = 11.3e-6 ! Half-saturation constant for oxygen inhibition function (kmol/m3) + real, protected :: bkano2anmx_sed = 5.e-6 ! Half-saturation constant for NO2 limitation (kmol/m3) + real, protected :: bkanh4anmx_sed ! = bkano2anmx_sed * rnh4anmx/rno2anmx !Half-saturation constant for NH4 limitation of anammox (kmol/m3) + + ! === Denitrification step NO2 -> N2O + real, protected :: rano2denit_sed = 0.12 ! Maximum growth rate denitrification on NO2 at reference T (1/d -> 1/dt) + real, protected :: q10ano2denit_sed = 2. ! Q10 factor for denitrification on NO2 (-) + real, protected :: Trefano2denit_sed = 10. ! Reference temperature for denitrification on NO2 (degr C) + real, protected :: bkoxano2denit_sed = 2.e-6 ! Half-saturation constant for (quadratic) oxygen inhibition function of denitrification on NO2 (kmol/m3) + real, protected :: bkano2denit_sed = 5.6e-6 ! Half-saturation constant for denitrification on NO2 (kmol/m3) + + ! === Denitrification step N2O -> N2 + real, protected :: ran2odenit_sed = 0.16 ! Maximum growth rate denitrification on N2O at reference T (1/d -> 1/dt) + real, protected :: q10an2odenit_sed = 3. ! Q10 factor for denitrificationj on N2O (-) + real, protected :: Trefan2odenit_sed = 10. ! Reference temperature for denitrification on N2O (degr C) + real, protected :: bkoxan2odenit_sed = 5.e-6 ! Half-saturation constant for (quadratic) oxygen inhibition function of denitrification on N2O (kmol/m3) + real, protected :: bkan2odenit_sed = 1.e-6 ! Half-saturation constant for denitrification on N2O (kmol/m3) + + ! === DNRA NO2 -> NH4 + real, protected :: rdnra_sed = 0.1 ! Maximum growth rate DNRA on NO2 at reference T (1/d -> 1/dt) + real, protected :: q10dnra_sed = 2. ! Q10 factor for DNRA on NO2 (-) + real, protected :: Trefdnra_sed = 10. ! Reference temperature for DNRA (degr C) + real, protected :: bkoxdnra_sed = 2.5e-6 ! Half saturation constant for (quadratic) oxygen inhibition function of DNRA on NO2 (kmol/m3) + real, protected :: bkdnra_sed = 0.05e-6 ! Half-saturation constant for DNRA on NO2 (kmol/m3) + + ! === Nitrification on NH4 + real, protected :: ranh4nitr_sed = 1. ! Maximum growth rate nitrification on NH4 at reference T (1/d -> 1/dt) + real, protected :: q10anh4nitr_sed = 3.3 ! Q10 factor for nitrification on NH4 (-) + real, protected :: Trefanh4nitr_sed = 20. ! Reference temperature for nitrification on NH4 (degr C) + real, protected :: bkoxamox_sed = 0.333e-6 ! Half-saturation constant for oxygen limitation of nitrification on NH4 (kmol/m3) + real, protected :: bkanh4nitr_sed = 0.133e-6 ! Half-saturation constant for nitrification on NH4 (kmol/m3) + real, protected :: bkamoxn2o_sed = 0.5e-6 ! Half saturation constant for NH4 in pathway splitting function N2O for nitrification on NH4 (kmol/m3) + real, protected :: mufn2o_sed ! = 0.11/(50.*1e6*bkoxamox_sed) !=6.61e-3 0.11/(50*1e6)=2.2e-9 - ~Santoro et al. 2011 with simple MM + real, protected :: bn2o_sed ! = 0.077/(50.*mufn2o_sed) !=0.2331 - before set to 0.3 - base fraction entering N2O + real, protected :: n2omaxy_sed = 0.003 ! Maximum yield of OM on NH4 nitrification (-) + real, protected :: n2oybeta_sed = 18. ! Decay factor for inhibition function for yield during nitrification on NH4 (kmol/m3) + real, protected :: bkyamox_sed = 0.333e-6 ! Half saturation constant for pathway splitting function OM-yield for nitrification on NH4 (kmol/m3) + + ! === Nitrification on NO2 + real, protected :: rano2nitr_sed = 1.54 ! Maximum growth rate nitrification on NO2 at reference T (1/d -> 1/dt) + real, protected :: q10ano2nitr_sed = 2.7 ! Q10 factor for nitrification on NO2 (-) + real, protected :: Trefano2nitr_sed = 20. ! Reference temperature for nitrification on NO2 (degr C) + real, protected :: bkoxnitr_sed = 0.788e-6 ! Half-saturation constant for oxygen limitation of nitrification on NO2 (kmol/m3) + real, protected :: bkano2nitr_sed = 0.287e-6 ! Half-saturation constant for NO2 for nitrification on NO2 (kmol/m3) + real, protected :: NOB2AOAy_sed = 0.44 ! Ratio of NOB versus AOA yield per energy source ~0.043/0.098 according to Zakem et al. 2022 !******************************************************************** ! Parameters for DMS and BrO schemes @@ -360,14 +429,14 @@ module mo_param_bgc real, protected :: wpoc_const = 5. ! m/d Sinking speed of detritus iris : 5. real, protected :: wcal_const = 30. ! m/d Sinking speed of CaCO3 shell material real, protected :: wopal_const = 30. ! m/d Sinking speed of opal iris : 60 - real, protected :: wdust_const ! m/d Sinking speed of dust + real, protected :: wdust_const ! m/d Sinking speed of dust real, protected :: wmin = 1. ! m/d minimum sinking speed real, protected :: wmax = 60. ! m/d maximum sinking speed real, protected :: wlin = 60./2400. ! m/d/m constant describing incr. with depth, r/a=1.0 real, protected :: dustd1 = 0.0001 ! cm = 1 um, boundary between clay and silt - real, protected :: dustd2 ! dust diameter squared - real, protected :: dustd3 ! dust diameter cubed - real, protected :: dustsink ! sinking speed of dust (used use_AGG) + real, protected :: dustd2 ! dust diameter squared + real, protected :: dustd3 ! dust diameter cubed + real, protected :: dustsink ! sinking speed of dust (used use_AGG) real, protected :: SinkExp, FractDim, Stick, cellmass real, protected :: fsh, fse,alow1, alow2,alow3,alar1,alar2,alar3,TSFac,TMFac @@ -436,7 +505,6 @@ subroutine ini_parambgc(kpie,kpje) call calc_param_atm() ! calculate atmospheric parameters after updating parameters via nml call calc_param_biol() ! potentially readjust namlist parameter-dependent parameters call rates_2_timestep() ! Converting rates from /d... to /dtb -! call init_m4ago_params() ! Initialize M4AGO parameters relying on nml parameters call write_parambgc() ! write out used parameters and calculate back rates from /dtb to /d.. end subroutine ini_parambgc @@ -494,6 +562,12 @@ subroutine ini_param_biol() rcalc = 40. ! iris 40 !calcium carbonate to organic phosphorous production ratio ropal = 30. ! iris 25 !opal to organic phosphorous production ratio endif + + if (lm4ago) then + ! reset drempoc and dremopal for Q10 T-dep remin/dissolution + drempoc = 0.12 + dremopal = 0.023 + endif end subroutine ini_param_biol !******************************************************************** @@ -508,14 +582,18 @@ subroutine read_bgcnamelist() namelist /bgcparams/ bkphy,dyphy,bluefix,bkzoo,grazra,spemor,gammap,gammaz, & ecan,zinges,epsher,bkopal,rcalc,ropal, & remido,drempoc,dremopal,dremn2o,dremsul,fetune,relaxfe, & - wmin,wmax,wlin,wpoc_const,wcal_const,wopal_const + wmin,wmax,wlin,wpoc_const,wcal_const,wopal_const, & + rano3denit,rano2anmx,rano2denit,ran2odenit,rdnra, & + ranh4nitr,rano2nitr,rano3denit_sed,rano2anmx_sed, & + rano2denit_sed,ran2odenit_sed,rdnra_sed,ranh4nitr_sed, & + rano2nitr_sed,atm_nh3,atm_n2o open (newunit=iounit, file=bgc_namelist, status='old',action='read') read (unit=iounit, nml=BGCPARAMS) close(unit=iounit) if (mnproc.eq.1) then - write(io_stdo_bgc,*) + write(io_stdo_bgc,*) write(io_stdo_bgc,*)'********************************************' write(io_stdo_bgc,*) 'iHAMOCC: read namelist bgcparams' write(io_stdo_bgc,nml=BGCPARAMS) @@ -538,16 +616,14 @@ subroutine calc_param_biol() * (claydens - 1025.) / 1.567 * 1000. & ! excess density / dyn. visc. * dustd2 * 1.e-4) ! m/d - if(lm4ago)then - ! reset drempoc and dremopal for T-dep remin/dissolution - drempoc = 0.12 - dremopal = 0.023 - endif if (use_extNcycle) then bkiron = bkphosph*riron ! Half-saturation constant for Fe uptake by bulk phytoplankton (kmol/m3) bkanh4anmx = bkano2anmx * rnh4anmx/rno2anmx ! Half-saturation constant for NH4 limitation of anammox (kmol/m3) mufn2o = 0.11/(50.*1e6*bkoxamox) ! =6.61e-3 0.11/(50*1e6)=2.2e-9 - ~Santoro et al. 2011 with simple MM, bn2o = 0.077/(50.*mufn2o) ! =0.2331 - before set to 0.3 - base fraction entering N2O + bkanh4anmx_sed = bkano2anmx_sed * rnh4anmx/rno2anmx !Half-saturation constant for NH4 limitation of anammox (kmol/m3) + mufn2o_sed = 0.11/(50.*1e6*bkoxamox_sed) !=6.61e-3 0.11/(50*1e6)=2.2e-9 - ~Santoro et al. 2011 with simple MM + bn2o_sed = 0.077/(50.*mufn2o_sed) !=0.2331 - before set to 0.3 - base fraction entering N2O endif end subroutine calc_param_biol @@ -589,15 +665,6 @@ subroutine rates_2_timestep() dremn2o = dremn2o*dtb ! 1/d to 1/time step Remineralization rate of detritus on N2O dremsul = dremsul*dtb ! 1/d to 1/time step Remineralization rate for sulphate reduction - ! Extended nitrogen cyle - rano3denit = rano3denit *dtb ! Maximum growth rate denitrification on NO3 at reference T (1/d -> 1/dt) - rano2anmx = rano2anmx *dtb ! Maximum growth rate for anammox at reference T (1/d -> 1/dt) - rano2denit = rano2denit *dtb ! Maximum growth rate denitrification on NO2 at reference T (1/d -> 1/dt) - ran2odenit = ran2odenit *dtb ! Maximum growth rate denitrification on N2O at reference T (1/d -> 1/dt) - rdnra = rdnra *dtb ! Maximum growth rate DNRA on NO2 at reference T (1/d -> 1/dt) - ranh4nitr = ranh4nitr *dtb ! Maximum growth rate nitrification on NH4 at reference T (1/d -> 1/dt) - rano2nitr = rano2nitr *dtb ! Maximum growth rate nitrification on NO2 at reference T (1/d -> 1/dt) - !******************************************************************** ! Parameters for DMS and BrO schemes @@ -638,9 +705,23 @@ subroutine rates_2_timestep() disso_poc = disso_poc * dtbgc ! 1/(kmol O2/m3 time step) Degradation rate constant of POP disso_caco3 = disso_caco3 * dtbgc ! 1/(kmol CO3--/m3 time step) Dissolution rate constant of CaCO3 sed_denit = sed_denit * dtbgc ! 1/time step Denitrification rate constant of POP + if (use_extNcycle) then -! call extNwatercol_param_update() -! call extNsediment_param_update() + rano3denit = rano3denit *dtb ! Maximum growth rate denitrification on NO3 at reference T (1/d -> 1/dt) + rano2anmx = rano2anmx *dtb ! Maximum growth rate for anammox at reference T (1/d -> 1/dt) + rano2denit = rano2denit *dtb ! Maximum growth rate denitrification on NO2 at reference T (1/d -> 1/dt) + ran2odenit = ran2odenit *dtb ! Maximum growth rate denitrification on N2O at reference T (1/d -> 1/dt) + rdnra = rdnra *dtb ! Maximum growth rate DNRA on NO2 at reference T (1/d -> 1/dt) + ranh4nitr = ranh4nitr *dtb ! Maximum growth rate nitrification on NH4 at reference T (1/d -> 1/dt) + rano2nitr = rano2nitr *dtb ! Maximum growth rate nitrification on NO2 at reference T (1/d -> 1/dt) + + rano3denit_sed = rano3denit_sed *dtb ! Maximum growth rate denitrification on NO3 at reference T (1/d -> 1/dt) + rano2anmx_sed = rano2anmx_sed *dtb ! Maximum growth rate for anammox at reference T (1/d -> 1/dt) + rano2denit_sed = rano2denit_sed *dtb ! Maximum growth rate denitrification on NO2 at reference T (1/d -> 1/dt) + ran2odenit_sed = ran2odenit_sed *dtb ! Maximum growth rate denitrification on N2O at reference T (1/d -> 1/dt) + rdnra_sed = rdnra_sed *dtb ! Maximum growth rate DNRA on NO2 at reference T (1/d -> 1/dt) + ranh4nitr_sed = ranh4nitr_sed *dtb ! Maximum growth rate nitrification on NH4 at reference T (1/d -> 1/dt) + rano2nitr_sed = rano2nitr_sed *dtb ! Maximum growth rate nitrification on NO2 at reference T (1/d -> 1/dt) endif end subroutine rates_2_timestep @@ -944,7 +1025,55 @@ subroutine write_parambgc() write(io_stdo_bgc,*) '* bkano2nitr = ',bkano2nitr write(io_stdo_bgc,*) '* NOB2AOAy = ',NOB2AOAy -! call extNsediment_param_write() + write(io_stdo_bgc,*) '****************************************************************' + write(io_stdo_bgc,*) '* HAMOCC extended nitrogen cycle parameters sediment:' + write(io_stdo_bgc,*) '* POM_remin_q10_sed = ',POM_remin_q10_sed + write(io_stdo_bgc,*) '* POM_remin_Tref_sed= ',POM_remin_Tref_sed + write(io_stdo_bgc,*) '* bkox_drempoc_sed = ',bkox_drempoc_sed + write(io_stdo_bgc,*) '* rano3denit_sed = ',rano3denit_sed *dtbinv + write(io_stdo_bgc,*) '* q10ano3denit_sed = ',q10ano3denit_sed + write(io_stdo_bgc,*) '* Trefano3denit_sed = ',Trefano3denit_sed + write(io_stdo_bgc,*) '* sc_ano3denit_sed = ',sc_ano3denit_sed + write(io_stdo_bgc,*) '* bkano3denit_sed = ',bkano3denit_sed + write(io_stdo_bgc,*) '* rano2anmx_sed = ',rano2anmx_sed *dtbinv + write(io_stdo_bgc,*) '* q10anmx_sed = ',q10anmx_sed + write(io_stdo_bgc,*) '* Trefanmx_sed = ',Trefanmx_sed + write(io_stdo_bgc,*) '* alphaanmx_sed = ',alphaanmx_sed + write(io_stdo_bgc,*) '* bkoxanmx_sed = ',bkoxanmx_sed + write(io_stdo_bgc,*) '* bkano2anmx_sed = ',bkano2anmx_sed + write(io_stdo_bgc,*) '* bkanh4anmx_sed = ',bkanh4anmx_sed + write(io_stdo_bgc,*) '* rano2denit_sed = ',rano2denit_sed *dtbinv + write(io_stdo_bgc,*) '* q10ano2denit_sed = ',q10ano2denit_sed + write(io_stdo_bgc,*) '* Trefano2denit_sed = ',Trefano2denit_sed + write(io_stdo_bgc,*) '* bkoxano2denit_sed = ',bkoxano2denit_sed + write(io_stdo_bgc,*) '* bkano2denit_sed = ',bkano2denit_sed + write(io_stdo_bgc,*) '* ran2odenit_sed = ',ran2odenit_sed *dtbinv + write(io_stdo_bgc,*) '* q10an2odenit_sed = ',q10an2odenit_sed + write(io_stdo_bgc,*) '* Trefan2odenit_sed = ',Trefan2odenit_sed + write(io_stdo_bgc,*) '* bkoxan2odenit_sed = ',bkoxan2odenit_sed + write(io_stdo_bgc,*) '* bkan2odenit_sed = ',bkan2odenit_sed + write(io_stdo_bgc,*) '* rdnra_sed = ',rdnra_sed *dtbinv + write(io_stdo_bgc,*) '* q10dnra_sed = ',q10dnra_sed + write(io_stdo_bgc,*) '* Trefdnra_sed = ',Trefdnra_sed + write(io_stdo_bgc,*) '* bkoxdnra_sed = ',bkoxdnra_sed + write(io_stdo_bgc,*) '* bkdnra_sed = ',bkdnra_sed + write(io_stdo_bgc,*) '* ranh4nitr_sed = ',ranh4nitr_sed *dtbinv + write(io_stdo_bgc,*) '* q10anh4nitr_sed = ',q10anh4nitr_sed + write(io_stdo_bgc,*) '* Trefanh4nitr_sed = ',Trefanh4nitr_sed + write(io_stdo_bgc,*) '* bkoxamox_sed = ',bkoxamox_sed + write(io_stdo_bgc,*) '* bkanh4nitr_sed = ',bkanh4nitr_sed + write(io_stdo_bgc,*) '* bkamoxn2o_sed = ',bkamoxn2o_sed + write(io_stdo_bgc,*) '* mufn2o_sed = ',mufn2o_sed + write(io_stdo_bgc,*) '* bn2o_sed = ',bn2o_sed + write(io_stdo_bgc,*) '* n2omaxy_sed = ',n2omaxy_sed + write(io_stdo_bgc,*) '* n2oybeta_sed = ',n2oybeta_sed + write(io_stdo_bgc,*) '* bkyamox_sed = ',bkyamox_sed + write(io_stdo_bgc,*) '* rano2nitr_sed = ',rano2nitr_sed *dtbinv + write(io_stdo_bgc,*) '* q10ano2nitr_sed = ',q10ano2nitr_sed + write(io_stdo_bgc,*) '* Trefano2nitr_sed = ',Trefano2nitr_sed + write(io_stdo_bgc,*) '* bkoxnitr_sed = ',bkoxnitr_sed + write(io_stdo_bgc,*) '* bkano2nitr_sed = ',bkano2nitr_sed + write(io_stdo_bgc,*) '* NOB2AOAy_sed = ',NOB2AOAy_sed endif end subroutine write_parambgc diff --git a/hamocc/mo_powach.F90 b/hamocc/mo_powach.F90 index cc04b067..84cfc0ed 100644 --- a/hamocc/mo_powach.F90 +++ b/hamocc/mo_powach.F90 @@ -39,18 +39,16 @@ subroutine powach(kpie,kpje,kpke,kbnd,prho,omask,psao,ptho,lspin) use mo_carbch, only: co3,keqb,ocetra,sedfluxo use mo_chemcon, only: calcon use mo_param_bgc, only: rnit,rcar,rdnit1,rdnit2,ro2ut,disso_sil,silsat,disso_poc,sed_denit, & - disso_caco3,ro2utammo + & disso_caco3,ro2utammo, & + & POM_remin_q10_sed,POM_remin_Tref_sed,bkox_drempoc_sed use mo_sedmnt, only: porwat,porsol,powtra,produs,prcaca,prorca,seddw,sedhpl,sedlay, & silpro,pror13,pror14,prca13,prca14 use mo_vgrid, only: kbo,bolay use mo_powadi, only: powadi use mo_carchm, only: carchm_solve use mo_dipowa, only: dipowa - - use mo_extNsediment,only: extNsediment_param_init,sed_nitrification,sed_denit_NO3_to_NO2,sed_anammox,sed_denit_DNRA, & - & extNsed_diagnostics,ised_remin_aerob,ised_remin_sulf,POM_remin_q10_sed,POM_remin_Tref_sed, & - & bkox_drempoc_sed - + use mo_extNsediment,only: sed_nitrification,sed_denit_NO3_to_NO2,sed_anammox,sed_denit_DNRA, & + & extNsed_diagnostics,ised_remin_aerob,ised_remin_sulf ! Arguments integer, intent(in) :: kpie ! 1st dimension of model grid. From 67077361ddba3da3124fd0c3c15a599a1c0d1a09 Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Tue, 23 Jan 2024 13:04:05 +0100 Subject: [PATCH 327/366] Add extended nitrogen cycle & M4AGO switches + output to cime configuration and namelist definition files --- cime_config/buildnml | 2 + cime_config/config_component.xml | 42 + cime_config/namelist_definition_blom.xml | 1509 +++++++++++++++++++--- cime_config/ocn_in.readme | 12 +- 4 files changed, 1388 insertions(+), 177 deletions(-) diff --git a/cime_config/buildnml b/cime_config/buildnml index 4e610f77..b69dddab 100755 --- a/cime_config/buildnml +++ b/cime_config/buildnml @@ -79,6 +79,7 @@ def buildnml(case, caseroot, compname): blom_coupling = case.get_value("BLOM_COUPLING") blom_tracer_modules = case.get_value("BLOM_TRACER_MODULES") hamocc_ciso = case.get_value("HAMOCC_CISO") + hamocc_extncycle = case.get_value("HAMOCC_EXTNCYCLE") hamocc_sedbypass = case.get_value("HAMOCC_SEDBYPASS") hamocc_sedspinup = case.get_value("HAMOCC_SEDSPINUP") hamocc_sedspinup_yr_start = case.get_value("HAMOCC_SEDSPINUP_YR_START") @@ -182,6 +183,7 @@ def buildnml(case, caseroot, compname): config["blom_coupling"] = blom_coupling config["blom_tracer_modules"] = blom_tracer_modules config["hamocc_ciso"] = "yes" if hamocc_ciso else "no" + config["hamocc_extncycle"] = "yes" if hamocc_extncycle else "no" config["hamocc_sedbypass"] = "yes" if hamocc_sedbypass else "no" config["hamocc_sedspinup"] = "yes" if hamocc_sedspinup else "no" config["hamocc_sedspinup_yr_start"] = hamocc_sedspinup_yr_start diff --git a/cime_config/config_component.xml b/cime_config/config_component.xml index f543d3f2..d3312b8b 100644 --- a/cime_config/config_component.xml +++ b/cime_config/config_component.xml @@ -131,6 +131,48 @@ Scenario for nitrogen deposition data. Requires module ecosys + + logical + TRUE,FALSE + FALSE + run_component_blom + env_run.xml + Set preprocessor option to activate the extended nitrogen cycle code. Requires module ecosys + + + + logical + TRUE,FALSE + FALSE + + TRUE + + run_component_blom + env_run.xml + Nitrogen deposition coupled from atmopshere. Requires module ecosys and extncycle + + + + logical + TRUE,FALSE + FALSE + + TRUE + + run_component_blom + env_run.xml + N2O and NH3 fluxes coupled from atmopshere. Requires module ecosys and extncycle + + + + logical + TRUE,FALSE + FALSE + run_component_blom + env_run.xml + Set preprocessor option to activate the M4AGO sinking scheme. Requires module ecosys + + logical TRUE,FALSE diff --git a/cime_config/namelist_definition_blom.xml b/cime_config/namelist_definition_blom.xml index b5f1322e..87dfe7e1 100644 --- a/cime_config/namelist_definition_blom.xml +++ b/cime_config/namelist_definition_blom.xml @@ -3580,6 +3580,49 @@ File name (incl. full path) for atmopheric N-deposition data + + logical + bgcnml + bgcnml + + .false. + .true. + + Switch to couple nitrogen deposition. Requires do_ndep. + + + + logical + bgcnml + bgcnml + + .false. + .true. + + Switch to couple N2O and NH3 fluxes + + + + logical + bgcnml + bgcnml + + .false. + .true. + + Switch for M4AGO settling scheme + + + + logical + bgcnml + bgcnml + + .false. + + Switch for cyano-bluefix in euphotic zone only + + logical bgcnml @@ -4371,6 +4414,30 @@ Nitrate (no3) [mol N m-3] + + integer(3) + diabgc + diabgc + + 0,2,2 + 4,2,2 + 0,0,0 + + Surface nitrite concentration [mol NO2 m-3] - extended N cycle only + + + + integer(3) + diabgc + diabgc + + 0,2,2 + 4,2,2 + 0,0,0 + + Surface ammonium concentration [mol NH4 m-3] - extended N cycle only + + integer(3) diabgc @@ -4561,8 +4628,8 @@ 0,0,0 Upward CO2 flux (co2fxu) [kg C m-2 s-1] - - + + integer(3) diabgc @@ -4587,18 +4654,54 @@ Nitrogen flux (fgn2) [mol N2 m-2 s-1] + + integer(3) + diabgc + diabgc + + 0,2,2 + 4,2,2 + 0,0,0 + + Surface pN2O under moist air [uatm] + + integer(3) diabgc diabgc - 0,0,2 + 0,2,2 4,2,2 0,0,0 Nitrous oxide flux [mol N2O m-2 s-1] + + integer(3) + diabgc + diabgc + + 0,2,2 + 4,2,2 + 0,0,0 + + Surface pNH3 under moist air [natm] + + + + integer(3) + diabgc + diabgc + + 0,2,2 + 4,2,2 + 0,0,0 + + Ammonia flux [mol NH3 m-2 s-1] + + integer(3) diabgc @@ -4695,6 +4798,30 @@ Atmospheric N2 (atmn2) [ppm] + + integer(3) + diabgc + diabgc + + 0,2,2 + 4,2,2 + 0,0,0 + + Atmospheric NH3 [ppt] + + + + integer(3) + diabgc + diabgc + + 0,2,2 + 4,2,2 + 0,0,0 + + Atmospheric N2O [ppt] + + integer(3) diabgc @@ -4839,6 +4966,18 @@ SF6 flux [mol SF6 m-2 s-1] + + integer(3) + diabgc + diabgc + + 0,0,2 + 4,2,2 + 0,0,0 + + Atmospheric bromoform [ppt] + + integer(3) diabgc @@ -4922,19 +5061,31 @@ Vertically integrated denitrification - - + + integer(3) diabgc diabgc 0,0,0 0,2,2 - 4,2,2 + 4,2,2 - Nitrogen deposition flux [mol N m-2 s-1] + NOy nitrogen deposition flux [mol N m-2 s-1] + + integer(3) + diabgc + diabgc + + 0,2,2 + 4,2,2 + 0,0,0 + + NHx nitrogen deposition flux [mol N m-2 s-1] - extended N cycle only + + integer(3) diabgc @@ -5259,557 +5410,1277 @@ add desc - + integer(3) diabgc diabgc 0,0,2 - 2,0,2 + 4,2,2 0,0,0 - add desc + Nitrite concentration [mol NO2 m-3] - extended N cycle only - + integer(3) diabgc diabgc 0,0,2 - 2,0,2 + 4,2,2 0,0,0 - add desc + denitrification rate on N20 [mol N20 m-3 s-1] - ext. N cycle only - - + + integer(3) diabgc diabgc 0,0,2 - 2,0,2 + 4,2,2 0,0,0 - add desc - - - + Ammonium concentration [mol NH4 m-3] - extended N cycle only + + + integer(3) diabgc diabgc 0,0,2 - 2,0,2 + 4,2,2 0,0,0 - add desc + nitrification rate on NH4 [mol NH4 m-3 s-1] - extended N cycle only - + integer(3) diabgc diabgc 0,0,2 - 2,0,2 + 4,2,2 0,0,0 - CaCO3 shells (calc) [mol C m-3] + nitrification rate on NO2 [mol NO2 m-3 s-1] - extended N cycle only - + integer(3) diabgc diabgc 0,0,2 - 2,0,2 + 4,2,2 0,0,0 - Opal shells (opal) [mol Si m-3] + N2O production rate during nitrification on NH4 [mol N2O m-3 s-1] - ext. N cycle only - + integer(3) diabgc diabgc 0,0,2 - 2,0,2 + 4,2,2 0,0,0 - Carbonate ions (co3) [mol C m-3] + detritus production during nitrification on NH4 [mol P m-3 s-1] - ext. N cycle only - + integer(3) diabgc diabgc - 0,0,0 - 0,0,0 + 0,0,2 + 4,2,2 0,0,0 - Nitrous oxide concentration [mol N2O m-3] + detritus production during nitrification on NO2 [mol P m-3 s-1] - ext. N cycle only - + integer(3) diabgc diabgc 0,0,2 - 2,0,2 + 4,2,2 0,0,0 - add desc + denitrification rate on NO3 [mol NO3 m-3 s-1] - ext. N cycle only - + integer(3) diabgc diabgc 0,0,2 - 2,0,2 + 4,2,2 0,0,0 - Calcite saturation state (omegac) [1] + denitrification rate on NO2 [mol NO2 m-3 s-1] - ext. N cycle only - + integer(3) diabgc diabgc 0,0,2 - 2,0,2 + 4,2,2 0,0,0 - Natural aragonite saturation state (natomegaa) [1] + denitrification rate on N20 [mol N20 m-3 s-1] - ext. N cycle only - + integer(3) diabgc diabgc - 0,0,4 - 4,0,4 + 0,0,2 + 4,2,2 0,0,0 - preformed oxygen (p_o2) [mol O2 m-3] + DNRA on NO2 [mol NO2 m-3 s-1] - ext. N cycle only - + integer(3) diabgc diabgc - 0,0,4 - 4,0,4 + 0,0,2 + 4,2,2 0,0,0 - Saturated oxygen (satoxy) [mol O2 m-3] + anammox N2 production [mol N2 m-3 s-1] - ext. N cycle only - + integer(3) diabgc diabgc 0,0,2 - 2,0,2 + 4,2,2 0,0,0 - add desc + anammox detritus production [mol P m-3 s-1] - ext. N cycle only - + integer(3) diabgc diabgc 0,0,2 - 2,0,2 + 4,2,2 0,0,0 - preformed alkalinity (p_talk) [eq m-3] + PP consumption of NH4 [mol NH4 m-3 s-1] - ext. N cycle only - + integer(3) diabgc diabgc 0,0,2 - 2,0,2 + 4,2,2 0,0,0 - preformed DIC (p_dic) [mol C m-3] + PP consumption of NH4 [mol NH4 m-3 s-1] - ext. N cycle only - + integer(3) diabgc diabgc 0,0,2 - 2,0,2 + 4,2,2 0,0,0 - saturated DIC (dic_sat) [mol C m-3] + aerob remineralization rate (sev. sources) [mol NH4 m-3 s-1] - ext. N cycle only - + integer(3) diabgc diabgc 0,0,2 - 2,0,2 + 4,2,2 0,0,0 - Natural dissolved carbon (natdissic) [mol C m-3] - + sulfate-based remin rate on det [mol P m-3 s-1] - ext. N cycle only + - + integer(3) diabgc diabgc 0,0,2 - 2,0,2 + 4,2,2 0,0,0 - Natural alkalinity (nattalk) [eq m-3] + M4AGO aggregate mean settling velocity [m/d] - + integer(3) diabgc diabgc 0,0,2 - 2,0,2 + 4,2,2 0,0,0 - Natural carbonate ion concentration (natco3) [mol C m-3] + molecular dynamic viscosity of sea water [kg m-1 s-1] - + integer(3) diabgc diabgc 0,0,2 - 2,0,2 + 4,2,2 0,0,0 - Natural CaCO3 shells (natcalc) [mol C m-3] + stickiness of opal frustule [-] - + integer(3) diabgc diabgc 0,0,2 - 2,0,2 + 4,2,2 0,0,0 - Natural pH (natph) [-log10([h+])] + stickiness of opal frustule [-] - + integer(3) diabgc diabgc 0,0,2 - 2,0,2 + 4,2,2 0,0,0 - Natural calcite saturation state (natomegac) [1] + maximum aggregate diameter [m] - + integer(3) diabgc diabgc 0,0,2 - 2,0,2 + 4,2,2 0,0,0 - Natural aragonite saturation state (natomegaa) [1] + mean primary particle diameter [m] - + integer(3) diabgc diabgc 0,0,2 - 2,0,2 + 4,2,2 0,0,0 - Dissolved C13 (dissic13) [mol C m-3] + mean primary particle density [kg/m3] - + integer(3) diabgc diabgc 0,0,2 - 2,0,2 + 4,2,2 0,0,0 - Dissolved C14 (dissic14) [mol C m-3] + concentration weighted mean diameter of aggregates [m] - + integer(3) diabgc diabgc 0,0,2 - 0,0,2 + 4,2,2 0,0,0 - at-depth variable sediment porosity (as opposed to default: only depth) + fractal dimension of aggregates [-] - + integer(3) diabgc diabgc 0,0,2 - 0,0,2 + 4,2,2 0,0,0 - delta 14C of DIC [1] + slope of aggregate number distribution [-] - + integer(3) diabgc diabgc 0,0,2 - 0,0,2 + 4,2,2 0,0,0 - Delta 14C of DIC [1] + Volume-weighted mean aggregate density [kg m-3] - + integer(3) diabgc diabgc 0,0,2 - 0,0,2 + 4,2,2 0,0,0 - Particulate organic carbon 13 (detoc13) [mol C m-3] - - - + Volume-weighted mean aggregate porosity [-] + + + integer(3) diabgc diabgc 0,0,2 - 0,0,2 + 2,0,2 0,0,0 - Dissolved organic carbon 13 (dissoc13) [mol C m-3] + add desc - + integer(3) diabgc diabgc 0,0,2 - 0,0,2 + 2,0,2 0,0,0 - Particulate inorganic carbon 13 (calc13) [mol C m-3] + add desc - + integer(3) diabgc diabgc 0,0,2 - 0,0,2 + 2,0,2 0,0,0 - 13C of phytoplankton biomass (phyc13) [mol C m-3] + add desc - + integer(3) diabgc diabgc 0,0,2 - 0,0,2 + 2,0,2 0,0,0 - 13C of zootoplankton biomass (zooc13) [mol C m-3] + add desc - + integer(3) diabgc diabgc 0,0,2 - 0,0,2 + 2,0,2 0,0,0 - CFC11 concentration [mol CFC11 m-3] + CaCO3 shells (calc) [mol C m-3] - + integer(3) diabgc diabgc 0,0,2 - 0,0,2 + 2,0,2 0,0,0 - CFC12 concentration [mol CFC12 m-3] + Opal shells (opal) [mol Si m-3] - + integer(3) diabgc diabgc 0,0,2 - 0,0,2 + 2,0,2 0,0,0 - SF6 concentration [mol SF6 m-3] + Carbonate ions (co3) [mol C m-3] - + + integer(3) + diabgc + diabgc + + 0,0,0 + 0,0,0 + 0,0,0 + + Nitrous oxide concentration [mol N2O m-3] + + + integer(3) diabgc diabgc 0,0,2 - 0,0,2 + 2,0,2 0,0,0 - index of point diagnostics (i) + add desc - + integer(3) diabgc diabgc 0,0,2 - 0,0,2 + 2,0,2 0,0,0 - Mass sinking velocity (aggregate scheme) [m d-1] + Calcite saturation state (omegac) [1] - + integer(3) diabgc diabgc 0,0,2 - 0,0,2 + 2,0,2 0,0,0 - Number sinking velocity (aggregate scheme) [m d-1] + Natural aragonite saturation state (natomegaa) [1] - + integer(3) diabgc diabgc - 0,0,0 - 0,0,0 + 0,0,4 + 4,0,4 0,0,0 - Epsilon exponent (aggregate scheme) [1] + preformed oxygen (p_o2) [mol O2 m-3] - + integer(3) diabgc diabgc - 0,0,0 - 0,0,0 + 0,0,4 + 4,0,4 0,0,0 - Average particle size (aggregate scheme) + Saturated oxygen (satoxy) [mol O2 m-3] - + integer(3) diabgc diabgc 0,0,2 + 2,0,2 + 0,0,0 add desc - + integer(3) diabgc diabgc - 0,2,2 - 0,2,2 + 0,0,4 + 4,2,2 0,0,0 - add desc + Pre-formed silica [mol m-3] + + + + integer(3) + diabgc + diabgc + + 0,0,2 + 2,0,2 + 0,0,0 + + preformed alkalinity (p_talk) [eq m-3] - + integer(3) diabgc diabgc - 0,2,2 - 4,2,2 + 0,0,2 + 2,0,2 0,0,0 - Phytoplankton (phyc) [mol C m-3] + preformed DIC (p_dic) [mol C m-3] - + integer(3) diabgc diabgc - 0,2,2 - 4,2,2 + 0,0,2 + 2,0,2 0,0,0 - Zooplankton (zooc) [mol C m-3] + saturated DIC (dic_sat) [mol C m-3] + + + + integer(3) + diabgc + diabgc + + 0,0,2 + 2,0,2 + 0,0,0 + + Natural dissolved carbon (natdissic) [mol C m-3] + + + + integer(3) + diabgc + diabgc + + 0,0,2 + 2,0,2 + 0,0,0 + + Natural alkalinity (nattalk) [eq m-3] + + + + integer(3) + diabgc + diabgc + + 0,0,2 + 2,0,2 + 0,0,0 + + Natural carbonate ion concentration (natco3) [mol C m-3] + + + + integer(3) + diabgc + diabgc + + 0,0,2 + 2,0,2 + 0,0,0 + + Natural CaCO3 shells (natcalc) [mol C m-3] + + + + integer(3) + diabgc + diabgc + + 0,0,2 + 2,0,2 + 0,0,0 + + Natural pH (natph) [-log10([h+])] + + + + integer(3) + diabgc + diabgc + + 0,0,2 + 2,0,2 + 0,0,0 + + Natural calcite saturation state (natomegac) [1] + + + + integer(3) + diabgc + diabgc + + 0,0,2 + 2,0,2 + 0,0,0 + + Natural aragonite saturation state (natomegaa) [1] + + + + integer(3) + diabgc + diabgc + + 0,0,2 + 2,0,2 + 0,0,0 + + Dissolved C13 (dissic13) [mol C m-3] + + + + integer(3) + diabgc + diabgc + + 0,0,2 + 2,0,2 + 0,0,0 + + Dissolved C14 (dissic14) [mol C m-3] + + + + integer(3) + diabgc + diabgc + + 0,0,2 + 0,0,2 + 0,0,0 + + at-depth variable sediment porosity (as opposed to default: only depth) + + + + integer(3) + diabgc + diabgc + + 0,0,2 + 0,0,2 + 0,0,0 + + delta 14C of DIC [1] + + + + integer(3) + diabgc + diabgc + + 0,0,2 + 0,0,2 + 0,0,0 + + Delta 14C of DIC [1] + + + + integer(3) + diabgc + diabgc + + 0,0,2 + 0,0,2 + 0,0,0 + + Particulate organic carbon 13 (detoc13) [mol C m-3] + + + + integer(3) + diabgc + diabgc + + 0,0,2 + 0,0,2 + 0,0,0 + + Dissolved organic carbon 13 (dissoc13) [mol C m-3] + + + + integer(3) + diabgc + diabgc + + 0,0,2 + 0,0,2 + 0,0,0 + + Particulate inorganic carbon 13 (calc13) [mol C m-3] + + + + integer(3) + diabgc + diabgc + + 0,0,2 + 0,0,2 + 0,0,0 + + 13C of phytoplankton biomass (phyc13) [mol C m-3] + + + + integer(3) + diabgc + diabgc + + 0,0,2 + 0,0,2 + 0,0,0 + + 13C of zootoplankton biomass (zooc13) [mol C m-3] + + + + integer(3) + diabgc + diabgc + + 0,0,2 + 0,0,2 + 0,0,0 + + CFC11 concentration [mol CFC11 m-3] + + + + integer(3) + diabgc + diabgc + + 0,0,2 + 0,0,2 + 0,0,0 + + CFC12 concentration [mol CFC12 m-3] + + + + integer(3) + diabgc + diabgc + + 0,0,2 + 0,0,2 + 0,0,0 + + SF6 concentration [mol SF6 m-3] + + + + integer(3) + diabgc + diabgc + + 0,0,2 + 0,0,2 + 0,0,0 + + index of point diagnostics (i) + + + + integer(3) + diabgc + diabgc + + 0,0,2 + 0,0,2 + 0,0,0 + + Mass sinking velocity (aggregate scheme) [m d-1] + + + + integer(3) + diabgc + diabgc + + 0,0,2 + 0,0,2 + 0,0,0 + + Number sinking velocity (aggregate scheme) [m d-1] + + + + integer(3) + diabgc + diabgc + + 0,0,0 + 0,0,0 + 0,0,0 + + Epsilon exponent (aggregate scheme) [1] + + + + integer(3) + diabgc + diabgc + + 0,0,0 + 0,0,0 + 0,0,0 + + Average particle size (aggregate scheme) + + + + integer(3) + diabgc + diabgc + + 0,0,2 + + add desc + + + + integer(3) + diabgc + diabgc + + 0,2,2 + 0,2,2 + 0,0,0 + + add desc + + + + integer(3) + diabgc + diabgc + + 0,2,2 + 4,2,2 + 0,0,0 + + Phytoplankton (phyc) [mol C m-3] + + + + integer(3) + diabgc + diabgc + + 0,2,2 + 4,2,2 + 0,0,0 + + Zooplankton (zooc) [mol C m-3] + + + + integer(3) + diabgc + diabgc + + 0,2,2 + 4,2,2 + 0,0,0 + + Dissolved organic carbon (dissoc) [mol C m-3] + + + + integer(3) + diabgc + diabgc + + 0,2,2 + 4,2,2 + 0,0,0 + + Primary production (pp) [mol C m-3 s-1] + + + + integer(3) + diabgc + diabgc + + 0,2,2 + 4,2,2 + 0,0,0 + + Phosphorus (po4) [mol P m-3] + + + + integer(3) + diabgc + diabgc + + 0,4,4 + 4,4,4 + 0,0,0 + + Oxygen (o2) [mol O2 m-3] + + + + integer(3) + diabgc + diabgc + + 0,2,2 + 4,2,2 + 0,0,0 + + eposition + + + + integer(3) + diabgc + diabgc + + 0,2,2 + 4,2,2 + 0,0,0 + + Nitrate (no3) [mol N m-3] + + + + integer(3) + diabgc + diabgc + + 0,2,2 + 4,2,2 + 0,0,0 + + Nitrite concentration [mol NO2 m-3] - extended N cycle only + + + + integer(3) + diabgc + diabgc + + 0,2,2 + 4,2,2 + 0,0,0 + + Ammonium concentration [mol NH4 m-3] - extended N cycle only + + + + integer(3) + diabgc + diabgc + + 0,2,2 + 4,2,2 + 0,0,0 + + nitrification rate on NH4 [mol NH4 m-3 s-1] - extended N cycle only + + + + integer(3) + diabgc + diabgc + + 0,2,2 + 4,2,2 + 0,0,0 + + nitrification rate on NO2 [mol NO2 m-3 s-1] - extended N cycle only + + + + integer(3) + diabgc + diabgc + + 0,2,2 + 4,2,2 + 0,0,0 + + N2O production rate during nitrification on NH4 [mol N2O m-3 s-1] - ext. N cycle only + + + + integer(3) + diabgc + diabgc + + 0,2,2 + 4,2,2 + 0,0,0 + + detritus production during nitrification on NH4 [mol P m-3 s-1] - ext. N cycle only + + + + integer(3) + diabgc + diabgc + + 0,2,2 + 4,2,2 + 0,0,0 + + detritus production during nitrification on NO2 [mol P m-3 s-1] - ext. N cycle only + + + + integer(3) + diabgc + diabgc + + 0,2,2 + 4,2,2 + 0,0,0 + + denitrification rate on NO3 [mol NO3 m-3 s-1] - ext. N cycle only + + + + integer(3) + diabgc + diabgc + + 0,2,2 + 4,2,2 + 0,0,0 + + denitrification rate on NO2 [mol NO2 m-3 s-1] - ext. N cycle only + + + + integer(3) + diabgc + diabgc + + 0,2,2 + 4,2,2 + 0,0,0 + + denitrification rate on N20 [mol N20 m-3 s-1] - ext. N cycle only + + + + integer(3) + diabgc + diabgc + + 0,2,2 + 4,2,2 + 0,0,0 + + DNRA on NO2 [mol NO2 m-3 s-1] - ext. N cycle only + + + + integer(3) + diabgc + diabgc + + 0,2,2 + 4,2,2 + 0,0,0 + + anammox N2 production [mol N2 m-3 s-1] - ext. N cycle only + + + + integer(3) + diabgc + diabgc + + 0,2,2 + 4,2,2 + 0,0,0 + + anammox detritus production [mol P m-3 s-1] - ext. N cycle only + + + + integer(3) + diabgc + diabgc + + 0,2,2 + 4,2,2 + 0,0,0 + + PP consumption of NH4 [mol NH4 m-3 s-1] - ext. N cycle only + + + + integer(3) + diabgc + diabgc + + 0,2,2 + 4,2,2 + 0,0,0 + + PP consumption of NH4 [mol NH4 m-3 s-1] - ext. N cycle only + + + + integer(3) + diabgc + diabgc + + 0,2,2 + 4,2,2 + 0,0,0 + + aerob remineralization rate (sev. sources) [mol NH4 m-3 s-1] - ext. N cycle only + + + + integer(3) + diabgc + diabgc + + 0,2,2 + 4,2,2 + 0,0,0 + + sulfate-based remin rate on det [mol P m-3 s-1] - ext. N cycle only + + + + integer(3) + diabgc + diabgc + + 0,2,2 + 4,2,2 + 0,0,0 + + M4AGO aggregate mean settling velocity [m/d] + + + + integer(3) + diabgc + diabgc + + 0,2,2 + 4,2,2 + 0,0,0 + + molecular dynamic viscosity of sea water [kg m-1 s-1] + + + + integer(3) + diabgc + diabgc + + 0,0,2 + 4,2,2 + 0,0,0 + + stickiness of opal frustule [-] + + + + integer(3) + diabgc + diabgc + + 0,0,2 + 4,2,2 + 0,0,0 + + stickiness of opal frustule [-] + + + + integer(3) + diabgc + diabgc + + 0,2,2 + 4,2,2 + 0,0,0 + + maximum aggregate diameter [m] + + + + integer(3) + diabgc + diabgc + + 0,2,2 + 4,2,2 + 0,0,0 + + mean primary particle diameter [m] - + integer(3) diabgc diabgc @@ -5818,22 +6689,22 @@ 4,2,2 0,0,0 - Dissolved organic carbon (dissoc) [mol C m-3] + mean primary particle density [kg/m3] - + integer(3) diabgc diabgc - 0,2,2 + 0,0,2 4,2,2 0,0,0 - Primary production (pp) [mol C m-3 s-1] + concentration weighted mean diameter of aggregates [m] - + integer(3) diabgc diabgc @@ -5842,22 +6713,22 @@ 4,2,2 0,0,0 - Phosphorus (po4) [mol P m-3] + fractal dimension of aggregates [-] - + integer(3) diabgc diabgc - 0,4,4 - 4,4,4 + 0,2,2 + 4,2,2 0,0,0 - Oxygen (o2) [mol O2 m-3] + slope of aggregate number distribution [-] - + integer(3) diabgc diabgc @@ -5866,21 +6737,21 @@ 4,2,2 0,0,0 - eposition + Volume-weighted mean aggregate density [kg m-3] - + integer(3) diabgc diabgc - 0,2,2 + 0,0,2 4,2,2 0,0,0 - Nitrate (no3) [mol N m-3] - - + Volume-weighted mean aggregate porosity [-] + + integer(3) diabgc @@ -6047,6 +6918,18 @@ preformed phosphate (p_po4) [mol PO4 m-3] + + integer(3) + diabgc + diabgc + + 0,4,4 + 4,2,2 + 0,0,0 + + Pre-formed silica [mol m-3] + + integer(3) diabgc @@ -6442,6 +7325,42 @@ sediment - water-column diffusive flux of nitrate [mol NO3 m-2 s-1] + + + integer(3) + diabgc + diabgc + + 0,0,2 + 4,2,2 + 0,0,0 + + Sediment - water-column diffusive flux of ammonium [mol NH4 m-2 s-1] + + + + integer(3) + diabgc + diabgc + + 0,0,2 + 4,2,2 + 0,0,0 + + Sediment - water-column diffusive flux of N2O [mol N2O m-2 s-1] + + + + integer(3) + diabgc + diabgc + + 0,0,2 + 4,2,2 + 0,0,0 + + Sediment - water-column diffusive flux of nitrite [mol NO2 m-2 s-1] + integer(3) @@ -6455,6 +7374,54 @@ sediment - water-column diffusive flux of silica [mol Si m-2 s-1] + + integer(3) + diabgc + diabgc + + 0,0,2 + 4,2,2 + 0,0,0 + + burial fluxes organic carbon [mol P m-2 s-1] + + + + integer(3) + diabgc + diabgc + + 0,0,2 + 4,2,2 + 0,0,0 + + burial fluxes of calcium carbonate [mol Ca m-2 s-1] + + + + integer(3) + diabgc + diabgc + + 0,0,2 + 4,2,2 + 0,0,0 + + burial fluxes of silicate [mol Si m-2 s-1] + + + + integer(3) + diabgc + diabgc + + 0,0,2 + 4,2,2 + 0,0,0 + + burial fluxes of clay [g m-2 s-1] + + integer(3) diabgc @@ -6527,6 +7494,198 @@ (powno3)[mol N m-3] + + integer(3) + diabgc + diabgc + + 0,0,2 + 4,2,2 + 0,0,0 + + (pownh4) [mol NH4 m-3] - extended N cycle only + + + + integer(3) + diabgc + diabgc + + 0,0,2 + 4,2,2 + 0,0,0 + + (pown2o) [mol N2O m-3] - extended N cycle only + + + + integer(3) + diabgc + diabgc + + 0,0,2 + 4,2,2 + 0,0,0 + + (powno2) [mol NO2 m-3] - extended N cycle only + + + + integer(3) + diabgc + diabgc + + 0,0,2 + 4,2,2 + 0,0,0 + + nitrification rate on NH4 [mol NH4 m-3 s-1] - extended N cycle only + + + + integer(3) + diabgc + diabgc + + 0,0,2 + 4,2,2 + 0,0,0 + + nitrification rate on NO2 [mol NO2 m-3 s-1] - extended N cycle only + + + + integer(3) + diabgc + diabgc + + 0,0,2 + 4,2,2 + 0,0,0 + + N2O production rate during nitrification on NH4 [mol N2O m-3 s-1] - ext. N cycle only + + + + integer(3) + diabgc + diabgc + + 0,0,2 + 4,2,2 + 0,0,0 + + detritus production during nitrification on NH4 [mol P m-3 s-1] - ext. N cycle only + + + + integer(3) + diabgc + diabgc + + 0,0,2 + 4,2,2 + 0,0,0 + + detritus production during nitrification on NO2 [mol P m-3 s-1] - ext. N cycle only + + + + integer(3) + diabgc + diabgc + + 0,0,2 + 4,2,2 + 0,0,0 + + denitrification rate on NO3 [mol NO3 m-3 s-1] - ext. N cycle only + + + + integer(3) + diabgc + diabgc + + 0,0,2 + 4,2,2 + 0,0,0 + + denitrification rate on NO2 [mol NO2 m-3 s-1] - ext. N cycle only + + + + integer(3) + diabgc + diabgc + + 0,0,2 + 4,2,2 + 0,0,0 + + denitrification rate on N20 [mol N20 m-3 s-1] - ext. N cycle only + + + + integer(3) + diabgc + diabgc + + 0,0,2 + 4,2,2 + 0,0,0 + + DNRA on NO2 [mol NO2 m-3 s-1] - ext. N cycle only + + + + integer(3) + diabgc + diabgc + + 0,0,2 + 4,2,2 + 0,0,0 + + anammox N2 production [mol N2 m-3 s-1] - ext. N cycle only + + + + integer(3) + diabgc + diabgc + + 0,0,2 + 4,2,2 + 0,0,0 + + anammox detritus production [mol P m-3 s-1] - ext. N cycle only + + + + integer(3) + diabgc + diabgc + + 0,0,2 + 4,2,2 + 0,0,0 + + aerob remineralization rate (sev. sources) [mol NH4 m-3 s-1] - ext. N cycle only + + + + integer(3) + diabgc + diabgc + + 0,0,2 + 4,2,2 + 0,0,0 + + sulfate-based remin rate on det [mol P m-3 s-1] - ext. N cycle only + + integer(3) diabgc diff --git a/cime_config/ocn_in.readme b/cime_config/ocn_in.readme index fc56c6af..cb4cca5d 100644 --- a/cime_config/ocn_in.readme +++ b/cime_config/ocn_in.readme @@ -403,7 +403,7 @@ ! Namelist acronyms: ! GLB_ - global parameters i.e. valid for entire output group ! SRF_ - surface variables (includes some non-surface 2d fields) -! FLX_ - interior ocean particle fuxes at different depth (2d) +! FLX_ - (interior) ocean (particle) fluxes at different depth (2d) ! INT_ - vertically integrated fields (2d) ! LYR_ - 3d fields with sigma layers as vertical coordinate ! LVL_ - 3d fields with levitus levels as vertical coordinate @@ -436,6 +436,8 @@ ! ALKALI - Alkalinity (talk) [eq m-3] ! OXYGEN - Oxygen (o2) [mol O2 m-3] ! ANO3 - Nitrate (no3) [mol N m-3] +! ANO2 - Nitrite (no2) [mol N m-3] - extended N cycle only +! ANH4 - Ammonium (nh4) [mol N m-3] - extended N cycle only ! PHOSPH - Phosphorus (po4) [mol P m-3] ! IRON - Dissolved iron (dfe) [mol Fe m-3] ! SILICA - Silicate (si) [mol Si m-3] @@ -450,6 +452,7 @@ ! PREFO2 - preformed oxygen (p_o2) [mol O2 m-3] ! O2SAT - Saturated oxygen (satoxy) [mol O2 m-3] ! PREFPO4 - preformed phosphate (p_po4) [mol PO4 m-3] +! PREFSILICA - preformed silica (p_si) [mol Si m-3] ! PREFALK - preformed alkalinity (p_talk) [eq m-3] ! PREFDIC - preformed DIC (p_dic) [mol C m-3] ! DICSAT - saturated DIC (dic_sat) [mol C m-3] @@ -559,9 +562,11 @@ ! NFIX - Vertically integrated nitrogen fixation ! DNIT - Vertically integrated denitrification ! +! ! Particle fluxes (FLX, e.g CARFLX****, where ****=0100,0500,1000,2000,4000, or _BOT), ! diffusive fluxes at the sediment - water-column interface (SEDIFF*), and other fluxes -! NDEP - Nitrogen deposition flux [mol N m-2 s-1] +! NDEPNOY - Nitrogen deposition flux in form of nitrate [mol N m-2 s-1] +! NDEPNHX - Nitrogen deposition flux in form of ammonium [mol N m-2 s-1] ! OALK - Flux of alkalinity due to ocean alkalinization [mol N m-2 s-1] ! CARFLX**** - POC flux at **** metres depth [mol C m-2 s-1] ! BSIFLX**** - Biogenic silica flux at **** metres depth [mol Si m-2 s-1] @@ -572,6 +577,9 @@ ! SEDIFFOX - sediment - water-column diffusive flux of oxygen [mol O2 m-2 s-1] ! SEDIFFN2 - sediment - water-column diffusive flux of N2 [mol N2 m-2 s-1] ! SEDIFFNO3 - sediment - water-column diffusive flux of nitrate [mol NO3 m-2 s-1] +! SEDIFFNO2 - sediment - water-column diffusive flux of nitrite [mol NO2 m-2 s-1] - extended N cycle only +! SEDIFFN2O - sediment - water-column diffusive flux of N2O [mol N2O m-2 s-1] - extended N cycle only +! SEDIFFNH4 - sediment - water-column diffusive flux of ammonium [mol NH4 m-2 s-1] - extended N cycle only ! SEDIFFSI - sediment - water-column diffusive flux of silica [mol Si m-2 s-1] ! FLX_BURSSO12 - burial fluxes organic carbon [mol P m-2 s-1] ! FLX_BURSSSC12 - burial fluxes of calcium carbonate [mol Ca m-2 s-1] From 739cfd506299889f905aff77e13cca3e4c8db66f Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Tue, 23 Jan 2024 15:57:58 +0100 Subject: [PATCH 328/366] tidy up a bit --- hamocc/mo_apply_ndep.F90 | 2 +- hamocc/mo_aufr_bgc.F90 | 16 ++++++++-------- hamocc/mo_aufw_bgc.F90 | 2 +- hamocc/mo_bgcmean.F90 | 4 ++-- hamocc/mo_carchm.F90 | 4 ++-- hamocc/mo_cyano.F90 | 10 +++++----- hamocc/mo_hamocc_init.F90 | 4 +++- hamocc/mo_inventory_bgc.F90 | 5 ++--- hamocc/mo_ncout_hamocc.F90 | 25 ++++++++++++++---------- hamocc/mo_ocprod.F90 | 6 +++--- hamocc/mo_param_bgc.F90 | 3 +-- hamocc/mo_powach.F90 | 38 ++++++++++++++++++------------------- hamocc/mo_read_ndep.F90 | 4 ++-- 13 files changed, 64 insertions(+), 59 deletions(-) diff --git a/hamocc/mo_apply_ndep.F90 b/hamocc/mo_apply_ndep.F90 index 655e4a1f..b20cc5f5 100644 --- a/hamocc/mo_apply_ndep.F90 +++ b/hamocc/mo_apply_ndep.F90 @@ -77,7 +77,7 @@ subroutine apply_ndep(kpie,kpje,kpke,pddpo,omask,ndep) endif if (.not. do_ndep) return - ! deposite N in topmost layer + ! deposit N in topmost layer do j=1,kpje do i=1,kpie if (omask(i,j).gt.0.5) then diff --git a/hamocc/mo_aufr_bgc.F90 b/hamocc/mo_aufr_bgc.F90 index a7d11884..179d3d01 100644 --- a/hamocc/mo_aufr_bgc.F90 +++ b/hamocc/mo_aufr_bgc.F90 @@ -123,7 +123,7 @@ subroutine aufr_bgc(kpie,kpje,kpke,ntr,ntrbgc,itrbgc,trc,kplyear,kplmon,kplday,o integer :: restday ! day of restart file integer :: restdtoce ! time step number from bgc ocean file integer :: idate(5),i,j,k - logical :: lread_cfc,lread_nat,lread_iso,lread_atm,lread_bro,lread_extn,lread_pref + logical :: lread_cfc,lread_nat,lread_iso,lread_atm,lread_bro,lread_extn,lread_prefsi real :: rco213,rco214,alpha14,beta13,beta14,d13C_atm,d14cat integer :: ncid,ncstat,ncvarid @@ -363,18 +363,18 @@ subroutine aufr_bgc(kpie,kpje,kpke,ntr,ntrbgc,itrbgc,trc,kplyear,kplmon,kplday,o endif endif - lread_pref=.true. + lread_prefsi=.true. if(IOTYPE==0) then if(mnproc==1) ncstat=nf90_inq_varid(ncid,'prefsilica',ncvarid) call xcbcst(ncstat) - if(ncstat.ne.nf90_noerr) lread_pref=.false. + if(ncstat.ne.nf90_noerr) lread_prefsi=.false. else if(IOTYPE==1) then #ifdef PNETCDF ncstat=nfmpi_inq_varid(ncid,'prefsilica',ncvarid) - if(ncstat.ne.nf_noerr) lread_pref=.false. + if(ncstat.ne.nf_noerr) lread_prefsi=.false. #endif endif - if(mnproc==1 .and. .not. lread_pref) then + if(mnproc==1 .and. .not. lread_prefsi) then write(io_stdo_bgc,*) ' ' write(io_stdo_bgc,*) 'AUFR_BGC info: preformed silica not in restart file ' write(io_stdo_bgc,*) 'Initialising preformed tracer from scratch' @@ -405,7 +405,7 @@ subroutine aufr_bgc(kpie,kpje,kpke,ntr,ntrbgc,itrbgc,trc,kplyear,kplmon,kplday,o call read_netcdf_var(ncid,'prefalk',locetra(1,1,1,iprefalk),2*kpke,0,iotype) call read_netcdf_var(ncid,'prefdic',locetra(1,1,1,iprefdic),2*kpke,0,iotype) call read_netcdf_var(ncid,'dicsat',locetra(1,1,1,idicsat),2*kpke,0,iotype) - if(lread_pref) then + if(lread_prefsi) then call read_netcdf_var(ncid,'prefsilica',locetra(1,1,1,iprefsilica),2*kpke,0,iotype) endif @@ -450,8 +450,8 @@ subroutine aufr_bgc(kpie,kpje,kpke,ntr,ntrbgc,itrbgc,trc,kplyear,kplmon,kplday,o endif if (use_extNcycle) then if(lread_extn) then - call read_netcdf_var(ncid,'anh4',locetra(1,1,1,ianh4),2*kpke,0,iotype) - call read_netcdf_var(ncid,'ano2',locetra(1,1,1,iano2),2*kpke,0,iotype) + call read_netcdf_var(ncid,'anh4',locetra(1,1,1,ianh4),2*kpke,0,iotype) + call read_netcdf_var(ncid,'ano2',locetra(1,1,1,iano2),2*kpke,0,iotype) endif endif diff --git a/hamocc/mo_aufw_bgc.F90 b/hamocc/mo_aufw_bgc.F90 index 14bf0974..d92c67b4 100644 --- a/hamocc/mo_aufw_bgc.F90 +++ b/hamocc/mo_aufw_bgc.F90 @@ -805,7 +805,7 @@ subroutine aufw_bgc(kpie,kpje,kpke,ntr,ntrbgc,itrbgc,trc, endif ! - ! Write restart data : diagtnostic ocean fields + ! Write restart data : diagnostic ocean fields ! call write_netcdf_var(ncid,'hi',hi(1,1,1),kpke,0) call write_netcdf_var(ncid,'co3',co3(1,1,1),kpke,0) diff --git a/hamocc/mo_bgcmean.F90 b/hamocc/mo_bgcmean.F90 index 8d41fea1..42778e96 100644 --- a/hamocc/mo_bgcmean.F90 +++ b/hamocc/mo_bgcmean.F90 @@ -665,7 +665,7 @@ module mo_bgcmean & jssster = 0 , & & jpownh4 = 0 , & & jpown2o = 0 , & - & jpowno2 = 0 , & + & jpowno2 = 0 , & & jsdm_nitr_NH4 = 0 , & & jsdm_nitr_NO2 = 0 , & & jsdm_nitr_N2O_prod = 0 , & @@ -678,7 +678,7 @@ module mo_bgcmean & jsdm_anmx_N2_prod = 0 , & & jsdm_anmx_OM_prod = 0 , & & jsdm_remin_aerob = 0 , & - & jsdm_remin_sulf = 0 + & jsdm_remin_sulf = 0 integer :: nbgct_sed diff --git a/hamocc/mo_carchm.F90 b/hamocc/mo_carchm.F90 index 5136e623..75350a70 100644 --- a/hamocc/mo_carchm.F90 +++ b/hamocc/mo_carchm.F90 @@ -140,7 +140,7 @@ subroutine carchm(kpie,kpje,kpke,kbnd,pdlxp,pdlyp,pddpo,prho,pglat,omask,psicomo ! extNcycle real :: flx_nh3,sch_nh3_a,sch_nh3_w,kw_nh3,ka_nh3,atnh3,diff_nh3_a,diff_nh3_w,mu_air,mu_w,p_dbar,rho_air real :: h_nh3,hstar_nh3,pKa_nh3,eps_safe,Kh_nh3,cD_wind,u_star - eps_safe = EPSILON(1.) + eps_safe = epsilon(1.) ! set variables for diagnostic output to zero atmflx (:,:,:)=0. @@ -516,7 +516,7 @@ subroutine carchm(kpie,kpje,kpke,kbnd,pdlxp,pdlyp,pddpo,prho,pglat,omask,psicomo atmflx(i,j,iatmbromo) = -flx_bromo endif if (use_extNcycle) then - ! surface flux NH3: STILL REQUIRES TO CHECK CONVERSION FACTOR FOR atNH3 (currently assumed atNH3 in pptv) + ! surface flux NH3 - currently assumed atNH3 in pptv flx_nh3 = Kh_nh3*dtbgc*(atnh3*1e-12*ppao(i,j)*1e-5/(tk*0.08314510) - hstar_nh3*ocetra(i,j,1,ianh4)) ocetra(i,j,1,ianh4) = ocetra(i,j,1,ianh4) + flx_nh3/pddpo(i,j,1) diff --git a/hamocc/mo_cyano.F90 b/hamocc/mo_cyano.F90 index 4682ed61..a40783a9 100644 --- a/hamocc/mo_cyano.F90 +++ b/hamocc/mo_cyano.F90 @@ -88,12 +88,12 @@ subroutine cyano(kpie,kpje,kpke,kbnd,pddpo,omask,ptho) ttemp = min(40.,max(-3.,ptho(i,j,k))) ! Temperature dependence of nitrogen fixation, Kriest and Oschlies 2015. - nfixtfac = MAX(0.0,tf2*ttemp*ttemp + tf1*ttemp + tf0)/tff + nfixtfac = max(0.0,tf2*ttemp*ttemp + tf1*ttemp + tf0)/tff if (.not. use_extNcycle) then oldocetra = ocetra(i,j,k,iano3) - ocetra(i,j,k,iano3)=ocetra(i,j,k,iano3)*(1.-bluefix*nfixtfac) & - & +bluefix*nfixtfac*rnit*ocetra(i,j,k,iphosph) + ocetra(i,j,k,iano3)=ocetra(i,j,k,iano3)*(1.-bluefix*nfixtfac) & + +bluefix*nfixtfac*rnit*ocetra(i,j,k,iphosph) dansp=ocetra(i,j,k,iano3)-oldocetra ! Note: to fix one mole N2 requires: N2+H2O+y*O2 = 2* HNO3 <-> y=2.5 mole O2. ! I.e., to release one mole HNO3 = H+ + NO3- requires 1.25 mole O2 @@ -103,8 +103,8 @@ subroutine cyano(kpie,kpje,kpke,kbnd,pddpo,omask,ptho) dalk = -dansp else oldocetra = ocetra(i,j,k,ianh4) - ocetra(i,j,k,ianh4)=ocetra(i,j,k,ianh4)*(1.-bluefix*nfixtfac) & - & +bluefix*nfixtfac*rnit*ocetra(i,j,k,iphosph) + ocetra(i,j,k,ianh4)=ocetra(i,j,k,ianh4)*(1.-bluefix*nfixtfac) & + +bluefix*nfixtfac*rnit*ocetra(i,j,k,iphosph) dansp=ocetra(i,j,k,ianh4)-oldocetra dox = dansp*0.75 dalk = dansp diff --git a/hamocc/mo_hamocc_init.F90 b/hamocc/mo_hamocc_init.F90 index dcbb90a1..fe8a6faf 100644 --- a/hamocc/mo_hamocc_init.F90 +++ b/hamocc/mo_hamocc_init.F90 @@ -139,7 +139,9 @@ subroutine hamocc_init(read_rest,rstfnm_hamocc) call alloc_mem_biomod(idm,jdm,kdm) call alloc_mem_sedmnt(idm,jdm) call alloc_mem_carbch(idm,jdm,kdm) - call alloc_mem_M4AGO(idm,jdm,kdm) + if (lm4ago) then + call alloc_mem_M4AGO(idm,jdm,kdm) + endif if (use_extNcycle .and. .not. use_sedbypass) then call alloc_mem_extNsediment_diag(idm,jdm,ks) endif diff --git a/hamocc/mo_inventory_bgc.F90 b/hamocc/mo_inventory_bgc.F90 index b9c0913f..263e7a15 100644 --- a/hamocc/mo_inventory_bgc.F90 +++ b/hamocc/mo_inventory_bgc.F90 @@ -50,7 +50,7 @@ subroutine inventory_bgc(kpie,kpje,kpke,dlxp,dlyp,ddpo,omask,iogrp) igasnit,iopal,ioxygen,iphosph,iphy,ipowaic,ipowaox,ipowaph,ipowasi, & ipown2,ipowno3,isco212,isilica,isssc12,issso12,issssil,izoo, & irdin,irdip,irsi,iralk,irdoc,irdet,nocetra,npowtra,nsedtra,nriv, & - ianh4,iano2,iatmnh3,ipownh4,ipown2o,ipowno2 + ianh4,iano2,iatmnh3,ipownh4,ipown2o,ipowno2 use mo_vgrid, only: dp_min ! NOT sedbypass @@ -680,10 +680,9 @@ subroutine write_netcdf(iogrp) use mo_param1_bgc, only: idicsat,idms,ifdust,iiron,iprefalk,iprefdic,iprefo2,iprefpo4, & iadust,inos,ibromo,icfc11,icfc12,isf6,icalc13,icalc14,idet13, & idet14,idoc13,idoc14,iphy13,iphy14,isco213,isco214,izoo13,izoo14, & - inatalkali,inatcalc,inatsco212 + inatalkali,inatcalc,inatsco212,ianh4,iano2 use mo_control_bgc,only: use_PBGC_CK_TIMESTEP,use_BOXATM,use_sedbypass,use_cisonew,use_AGG, & use_CFC,use_natDIC,use_BROMO - use mo_param1_bgc, only: ianh4,iano2 implicit none diff --git a/hamocc/mo_ncout_hamocc.F90 b/hamocc/mo_ncout_hamocc.F90 index 7da786f4..1bc16e3a 100644 --- a/hamocc/mo_ncout_hamocc.F90 +++ b/hamocc/mo_ncout_hamocc.F90 @@ -1224,10 +1224,10 @@ subroutine hamoccvardef(iogrp,timeunits,calendar,cmpflg) use mod_nctools, only: ncdefvar,ncattr,ncfopn,ncdimc,ncdims, & nctime,ncfcls,ncedef,ncdefvar3d,ndouble - use mo_control_bgc,only:lm4ago + use mo_control_bgc, only: lm4ago use mo_bgcmean, only: srf_kwco2,srf_pco2,srf_dmsflux,srf_co2fxd, & srf_kwco2khm,srf_co2kh,srf_co2khm,srf_pco2m, & - srf_co2fxu,srf_oxflux,srf_niflux,srf_pn2om,srf_dms,srf_dmsprod, & + srf_co2fxu,srf_oxflux,srf_niflux,srf_pn2om,srf_dms,srf_dmsprod, & srf_dms_bac,srf_dms_uv,srf_export,srf_exposi,srf_expoca, & srf_dic,srf_alkali,srf_phosph,srf_oxygen,srf_ano3,srf_silica, & srf_iron,srf_phyto,srf_ph,int_phosy,int_nfix,int_dnit, & @@ -1979,22 +1979,26 @@ subroutine hamoccvardef(iogrp,timeunits,calendar,cmpflg) call ncdefvar3d(SDM_POWNO2(iogrp),cmpflg,'p', & & 'powno2','PoWa nitrite',' ','mol N m-3',3) call ncdefvar3d(sdm_nitr_NH4(iogrp),cmpflg,'p', & - & 'nh4nitrsdm','NH4 nitrification rate sediment',' ','mol N m-3 s-1',3) + & 'nh4nitrsdm','NH4 nitrification rate sediment',' ', & + & 'mol N m-3 s-1',3) call ncdefvar3d(sdm_nitr_NO2(iogrp),cmpflg,'p', & - & 'no2nitrsdm','NO2 nitrification rate sediment',' ','mol N m-3 s-1',3) + & 'no2nitrsdm','NO2 nitrification rate sediment',' ', & + & 'mol N m-3 s-1',3) call ncdefvar3d(sdm_nitr_N2O_prod(iogrp),cmpflg,'p', & & 'nitr_n2osdm','N2O prod during NH4 nitrification sediment',' ', & & 'mol N2O m-3 s-1',3) call ncdefvar3d(sdm_nitr_NH4_OM(iogrp),cmpflg,'p', & - & 'nh4nitr_omsdm','OM production during NH4 nitrification sediment',' ', & - & 'mol P m-3 s-1',3) + & 'nh4nitr_omsdm','OM production during NH4 nitrification sediment',& + & ' ','mol P m-3 s-1',3) call ncdefvar3d(sdm_nitr_NO2_OM(iogrp),cmpflg,'p', & - & 'no2nitr_omsdm','OM production during NO2 nitrification sediment',' ', & - & 'mol P m-3 s-1',3) + & 'no2nitr_omsdm','OM production during NO2 nitrification sediment',& + & ' ','mol P m-3 s-1',3) call ncdefvar3d(sdm_denit_NO3(iogrp),cmpflg,'p', & - & 'no3denitsdm','NO3 denitrification rate sediment',' ','mol N m-3 s-1',3) + & 'no3denitsdm','NO3 denitrification rate sediment',' ', & + & 'mol N m-3 s-1',3) call ncdefvar3d(sdm_denit_NO2(iogrp),cmpflg,'p', & - & 'no2denitsdm','NO2 denitrification rate sediment',' ','mol N m-3 s-1',3) + & 'no2denitsdm','NO2 denitrification rate sediment',' ', & + & 'mol N m-3 s-1',3) call ncdefvar3d(sdm_denit_N2O(iogrp),cmpflg,'p', & & 'n2odenitsdm','N2O denitrification rate sediment',' ', & & 'mol N2O m-3 s-1',3) @@ -2014,6 +2018,7 @@ subroutine hamoccvardef(iogrp,timeunits,calendar,cmpflg) & 'mol P m-3 s-1',3) endif endif + ! --- enddef netcdf file call ncedef diff --git a/hamocc/mo_ocprod.F90 b/hamocc/mo_ocprod.F90 index c4a00119..24d3f271 100644 --- a/hamocc/mo_ocprod.F90 +++ b/hamocc/mo_ocprod.F90 @@ -116,7 +116,7 @@ subroutine ocprod(kpie,kpje,kpke,kbnd,pdlxp,pdlyp,pddpo,omask,ptho,pi_ph,psao,pp real, intent(in) :: pi_ph(kpie,kpje) real, intent(in) :: psao(1-kbnd:kpie+kbnd,1-kbnd:kpje+kbnd,kpke) ! salinity [psu]. real, intent(in) :: ppao(1-kbnd:kpie+kbnd,1-kbnd:kpje+kbnd) ! sea level pressure [Pascal]. - real, intent(in) :: prho(kpie,kpje,kpke) ! density [kg/m^3]. + real, intent(in) :: prho(kpie,kpje,kpke) ! density [g/cm^3]. ! Local variables integer, parameter :: nsinkmax = 12 @@ -649,8 +649,8 @@ subroutine ocprod(kpie,kpje,kpke,kbnd,pdlxp,pdlyp,pddpo,omask,ptho,pi_ph,psao,pp phyrem = min(0.5*dyphy*phythresh, 0.33*ocetra(i,j,k,ioxygen)/ro2ut) else o2lim = ocetra(i,j,k,ioxygen)/(ocetra(i,j,k,ioxygen) + bkox_drempoc) - pocrem = min(o2lim*pocrem,0.33*ocetra(i,j,k,ioxygen)/ro2utammo) - docrem = min(remido*ocetra(i,j,k,idoc),0.33*ocetra(i,j,k,ioxygen)/ro2utammo) + pocrem = min(o2lim*pocrem, 0.33*ocetra(i,j,k,ioxygen)/ro2utammo) + docrem = min(remido*ocetra(i,j,k,idoc), 0.33*ocetra(i,j,k,ioxygen)/ro2utammo) phyrem = min(0.5*dyphy*phythresh, 0.33*ocetra(i,j,k,ioxygen)/ro2utammo) endif diff --git a/hamocc/mo_param_bgc.F90 b/hamocc/mo_param_bgc.F90 index bd787ce2..e138487e 100644 --- a/hamocc/mo_param_bgc.F90 +++ b/hamocc/mo_param_bgc.F90 @@ -39,7 +39,6 @@ module mo_param_bgc use_sedbypass,with_dmsph,use_PBGC_OCNP_TIMESTEP,ocn_co2_type,lm4ago, & leuphotic_cya,do_ndep_coupled,do_n2onh3_coupled,use_extNcycle use mod_xc, only: mnproc - use mo_param1_bgc, only: iatmnh3,iatmn2o implicit none private @@ -665,7 +664,6 @@ subroutine rates_2_timestep() dremn2o = dremn2o*dtb ! 1/d to 1/time step Remineralization rate of detritus on N2O dremsul = dremsul*dtb ! 1/d to 1/time step Remineralization rate for sulphate reduction - !******************************************************************** ! Parameters for DMS and BrO schemes !******************************************************************** @@ -792,6 +790,7 @@ subroutine write_parambgc() write(io_stdo_bgc,*) '* use_natDIC = ',use_natDIC write(io_stdo_bgc,*) '* use_CFC = ',use_CFC write(io_stdo_bgc,*) '* use_cisonew = ',use_cisonew + write(io_stdo_bgc,*) '* use_extNcycle = ',use_extNcycle write(io_stdo_bgc,*) '* use_PBGC_OCNP_TIMESTEP = ',use_PBGC_OCNP_TIMESTEP write(io_stdo_bgc,*) '* use_PBGC_CK_TIMESTEP = ',use_PBGC_CK_TIMESTEP write(io_stdo_bgc,*) '* use_FB_BGC_OCE BROMO = ',use_FB_BGC_OCE diff --git a/hamocc/mo_powach.F90 b/hamocc/mo_powach.F90 index 84cfc0ed..7879774d 100644 --- a/hamocc/mo_powach.F90 +++ b/hamocc/mo_powach.F90 @@ -218,18 +218,18 @@ subroutine powach(kpie,kpje,kpke,kbnd,prho,omask,psao,ptho,lspin) undsa = powtra(i,j,1,ipowaox) sedb1(i,0) = bolay(i,j) * ocetra(i,j,kbo(i,j),ioxygen) if ( .not. use_extNcycle) then - solrat(i,1) = ( sedlay(i,j,1,issso12) + prorca(i,j) & - & / (porsol(i,j,1) * seddw(1)) ) & - & * ro2ut * dissot / (1. + dissot * undsa) & - & * porsol(i,j,1) / porwat(i,j,1) + solrat(i,1) = ( sedlay(i,j,1,issso12) + prorca(i,j) & + & / (porsol(i,j,1) * seddw(1)) ) & + & * ro2ut * dissot / (1. + dissot * undsa) & + & * porsol(i,j,1) / porwat(i,j,1) else ! extended nitrogen cycle - 140mol O2/mol POP O2-consumption ! O2 and T-dep - ex_disso_poc = dissot * powtra(i,j,k,ipowaox)/(powtra(i,j,k,ipowaox) + bkox_drempoc_sed) & ! oxygen limitation - & * POM_remin_q10_sed**((ptho(i,j,kbo(i,j))-POM_remin_Tref_sed)/10.) ! T-dep - solrat(i,1) = ( sedlay(i,j,1,issso12) + prorca(i,j) & - & / (porsol(i,j,1) * seddw(1)) ) & - & * ro2utammo * ex_disso_poc / (1. + ex_disso_poc * undsa) & + ex_disso_poc = dissot*powtra(i,j,k,ipowaox)/(powtra(i,j,k,ipowaox) + bkox_drempoc_sed) & ! oxygen limitation + & *POM_remin_q10_sed**((ptho(i,j,kbo(i,j))-POM_remin_Tref_sed)/10.) ! T-dep + solrat(i,1) = ( sedlay(i,j,1,issso12) + prorca(i,j) & + & / (porsol(i,j,1) * seddw(1)) ) & + & * ro2utammo * ex_disso_poc / (1. + ex_disso_poc * undsa) & & * porsol(i,j,1) / porwat(i,j,1) endif endif @@ -245,14 +245,14 @@ subroutine powach(kpie,kpje,kpke,kbnd,prho,omask,psao,ptho,lspin) undsa = powtra(i,j,k,ipowaox) sedb1(i,k) = seddw(k) * porwat(i,j,k) * powtra(i,j,k,ipowaox) if ( .not. use_extNcycle) then - if (k > 1) solrat(i,k) = sedlay(i,j,k,issso12) * ro2ut * dissot & - & / (1. + dissot*undsa) * porsol(i,j,k) / porwat(i,j,k) + if (k > 1) solrat(i,k) = sedlay(i,j,k,issso12) * ro2ut * dissot & + & / (1. + dissot*undsa) * porsol(i,j,k) / porwat(i,j,k) else ! extended nitrogen cycle - 140mol O2/mol POP O2-consumption - ex_disso_poc = dissot * powtra(i,j,k,ipowaox)/(powtra(i,j,k,ipowaox) + bkox_drempoc_sed) & ! oxygen limitation - & * POM_remin_q10_sed**((ptho(i,j,kbo(i,j))-POM_remin_Tref_sed)/10.) ! T-dep - if (k > 1) solrat(i,k) = sedlay(i,j,k,issso12) * ro2utammo * ex_disso_poc & - & / (1. + ex_disso_poc*undsa) * porsol(i,j,k) / porwat(i,j,k) + ex_disso_poc = dissot*powtra(i,j,k,ipowaox)/(powtra(i,j,k,ipowaox)+bkox_drempoc_sed) & ! oxygen limitation + & *POM_remin_q10_sed**((ptho(i,j,kbo(i,j))-POM_remin_Tref_sed)/10.) ! T-dep + if (k > 1) solrat(i,k) = sedlay(i,j,k,issso12) * ro2utammo * ex_disso_poc & + & /(1. + ex_disso_poc*undsa) * porsol(i,j,k) / porwat(i,j,k) endif endif enddo @@ -523,14 +523,14 @@ subroutine powach(kpie,kpje,kpke,kbnd,prho,omask,psao,ptho,lspin) endif sedlay(i,j,k,isssc12) = sedlay(i,j,k,isssc12) - posol if (use_extNcycle) then - powtra(i,j,k,ipowaic) = powtra(i,j,k,ipowaic) & + powtra(i,j,k,ipowaic) = powtra(i,j,k,ipowaic) & & + posol * umfa + (aerob(i,k) + sulf(i,k)) * rcar + ex_ddic(i,k) - powtra(i,j,k,ipowaal) = powtra(i,j,k,ipowaal) & + powtra(i,j,k,ipowaal) = powtra(i,j,k,ipowaal) & & + 2. * posol * umfa - (rnit+1.)*(aerob(i,k) + sulf(i,k)) + ex_dalk(i,k) else - powtra(i,j,k,ipowaic) = powtra(i,j,k,ipowaic) & + powtra(i,j,k,ipowaic) = powtra(i,j,k,ipowaic) & & + posol * umfa + (aerob(i,k) + anaerob(i,k) + sulf(i,k)) * rcar - powtra(i,j,k,ipowaal) = powtra(i,j,k,ipowaal) & + powtra(i,j,k,ipowaal) = powtra(i,j,k,ipowaal) & & + 2. * posol * umfa - (rnit+1.)*(aerob(i,k) + sulf(i,k)) + (rdnit1-1.)*anaerob(i,k) endif if (use_cisonew) then diff --git a/hamocc/mo_read_ndep.F90 b/hamocc/mo_read_ndep.F90 index a3eb8728..dda0e245 100644 --- a/hamocc/mo_read_ndep.F90 +++ b/hamocc/mo_read_ndep.F90 @@ -220,7 +220,7 @@ subroutine get_ndep(kpie,kpje,kplyear,kplmon,omask,ndep) oldmonth=kplmon endif -!$OMP PARALLEL DO PRIVATE(i) + !$OMP PARALLEL DO PRIVATE(i) ! 1 = NO3; 2 = NH4 do j=1,kpje do i=1,kpie @@ -232,7 +232,7 @@ subroutine get_ndep(kpie,kpje,kplyear,kplmon,omask,ndep) endif enddo enddo -!$OMP END PARALLEL DO + !$OMP END PARALLEL DO end subroutine get_ndep From 8ea4785b9c4ce908a6262a401b58cd865f45bbd8 Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Tue, 23 Jan 2024 15:58:45 +0100 Subject: [PATCH 329/366] fix sediment-water interface --- hamocc/mo_powach.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/hamocc/mo_powach.F90 b/hamocc/mo_powach.F90 index 7879774d..d4d041b2 100644 --- a/hamocc/mo_powach.F90 +++ b/hamocc/mo_powach.F90 @@ -225,7 +225,7 @@ subroutine powach(kpie,kpje,kpke,kbnd,prho,omask,psao,ptho,lspin) else ! extended nitrogen cycle - 140mol O2/mol POP O2-consumption ! O2 and T-dep - ex_disso_poc = dissot*powtra(i,j,k,ipowaox)/(powtra(i,j,k,ipowaox) + bkox_drempoc_sed) & ! oxygen limitation + ex_disso_poc = dissot*powtra(i,j,1,ipowaox)/(powtra(i,j,1,ipowaox) + bkox_drempoc_sed) & ! oxygen limitation & *POM_remin_q10_sed**((ptho(i,j,kbo(i,j))-POM_remin_Tref_sed)/10.) ! T-dep solrat(i,1) = ( sedlay(i,j,1,issso12) + prorca(i,j) & & / (porsol(i,j,1) * seddw(1)) ) & From 5d464cc3b158aa6f5089bb8f4c0829f8de9dc2e6 Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Tue, 23 Jan 2024 16:27:12 +0100 Subject: [PATCH 330/366] fix sediment-water interface --- hamocc/powach.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/hamocc/powach.F90 b/hamocc/powach.F90 index 544146bf..834a0244 100644 --- a/hamocc/powach.F90 +++ b/hamocc/powach.F90 @@ -284,7 +284,7 @@ subroutine powach(kpie,kpje,kpke,kbnd,prho,omask,psao,ptho,lspin) #else ! extended nitrogen cycle - 140mol O2/mol POP O2-consumption ! O2 and T-dep - ex_disso_poc = dissot * powtra(i,j,k,ipowaox)/(powtra(i,j,k,ipowaox) + bkox_drempoc_sed) & ! oxygen limitation + ex_disso_poc = dissot * powtra(i,j,1,ipowaox)/(powtra(i,j,1,ipowaox) + bkox_drempoc_sed) & ! oxygen limitation & * POM_remin_q10_sed**((ptho(i,j,kbo(i,j))-POM_remin_Tref_sed)/10.) ! T-dep solrat(i,1) = ( sedlay(i,j,1,issso12) + prorca(i,j) & & / (porsol(i,j,1) * seddw(1)) ) & From 2caf8eed5cee8da540b89e735ab917a91fe65397 Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Wed, 24 Jan 2024 13:54:18 +0100 Subject: [PATCH 331/366] cleaning, indenting, small letters - trying to comply to new coding style --- hamocc/mo_cyano.F90 | 28 ++++++++++++++-------------- 1 file changed, 14 insertions(+), 14 deletions(-) diff --git a/hamocc/mo_cyano.F90 b/hamocc/mo_cyano.F90 index a40783a9..93c72970 100644 --- a/hamocc/mo_cyano.F90 +++ b/hamocc/mo_cyano.F90 @@ -74,12 +74,12 @@ subroutine cyano(kpie,kpje,kpke,kbnd,pddpo,omask,ptho) ! do j=1,kpje do i=1,kpie - if (omask(i,j).gt.0.5) then + if (omask(i,j) > 0.5) then do k=1,merge(kwrbioz(i,j),kmle(i,j),leuphotic_cya) ! if leuphotic_cya=.true., do bluefix only in euphotic zone if (ocetra(i,j,k,iano3) < (rnit*ocetra(i,j,k,iphosph))) then if (use_extNcycle) then ! assuming nitrate and ammonium required for cyanobacteria growth (as bulk PP) - anavail = ocetra(i,j,k,iano3)+ocetra(i,j,k,ianh4) + anavail = ocetra(i,j,k,iano3) + ocetra(i,j,k,ianh4) else anavail = ocetra(i,j,k,iano3) endif @@ -92,9 +92,9 @@ subroutine cyano(kpie,kpje,kpke,kbnd,pddpo,omask,ptho) if (.not. use_extNcycle) then oldocetra = ocetra(i,j,k,iano3) - ocetra(i,j,k,iano3)=ocetra(i,j,k,iano3)*(1.-bluefix*nfixtfac) & - +bluefix*nfixtfac*rnit*ocetra(i,j,k,iphosph) - dansp=ocetra(i,j,k,iano3)-oldocetra + ocetra(i,j,k,iano3) = ocetra(i,j,k,iano3)*(1. - bluefix*nfixtfac) & + + bluefix*nfixtfac*rnit*ocetra(i,j,k,iphosph) + dansp = ocetra(i,j,k,iano3) - oldocetra ! Note: to fix one mole N2 requires: N2+H2O+y*O2 = 2* HNO3 <-> y=2.5 mole O2. ! I.e., to release one mole HNO3 = H+ + NO3- requires 1.25 mole O2 dox = -dansp*1.25 @@ -103,19 +103,19 @@ subroutine cyano(kpie,kpje,kpke,kbnd,pddpo,omask,ptho) dalk = -dansp else oldocetra = ocetra(i,j,k,ianh4) - ocetra(i,j,k,ianh4)=ocetra(i,j,k,ianh4)*(1.-bluefix*nfixtfac) & - +bluefix*nfixtfac*rnit*ocetra(i,j,k,iphosph) - dansp=ocetra(i,j,k,ianh4)-oldocetra - dox = dansp*0.75 - dalk = dansp + ocetra(i,j,k,ianh4) = ocetra(i,j,k,ianh4)*(1. - bluefix*nfixtfac) & + + bluefix*nfixtfac*rnit*ocetra(i,j,k,iphosph) + dansp = ocetra(i,j,k,ianh4) - oldocetra + dox = dansp*0.75 + dalk = dansp endif - ocetra(i,j,k,igasnit)=ocetra(i,j,k,igasnit)-dansp*(1./2.) + ocetra(i,j,k,igasnit) = ocetra(i,j,k,igasnit) - dansp*0.5 - ocetra(i,j,k,ioxygen)=ocetra(i,j,k,ioxygen)+dox + ocetra(i,j,k,ioxygen) = ocetra(i,j,k,ioxygen) + dox - ocetra(i,j,k,ialkali)=ocetra(i,j,k,ialkali)+dalk + ocetra(i,j,k,ialkali) = ocetra(i,j,k,ialkali) + dalk if (use_natDIC) then - ocetra(i,j,k,inatalkali)=ocetra(i,j,k,inatalkali)+dalk + ocetra(i,j,k,inatalkali) = ocetra(i,j,k,inatalkali) + dalk endif intnfix(i,j) = intnfix(i,j) + dansp*pddpo(i,j,k) From e63a86fe10c1c0601ed572717bbac87d9ec2a18a Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Wed, 24 Jan 2024 13:54:35 +0100 Subject: [PATCH 332/366] cleaning, indenting, small letters - trying to comply to new coding style --- hamocc/mo_extNsediment.F90 | 544 ++++++++++++++++++------------------- 1 file changed, 266 insertions(+), 278 deletions(-) diff --git a/hamocc/mo_extNsediment.F90 b/hamocc/mo_extNsediment.F90 index bc165ff4..4ea85cea 100644 --- a/hamocc/mo_extNsediment.F90 +++ b/hamocc/mo_extNsediment.F90 @@ -3,58 +3,60 @@ ! This file is part of BLOM/iHAMOCC. ! ! 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. +! 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 +! 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. +! more details. ! -! You should have received a copy of the GNU Lesser General Public License +! You should have received a copy of the GNU Lesser General Public License ! along with BLOM. If not, see https://www.gnu.org/licenses/. -MODULE mo_extNsediment +module mo_extNsediment !********************************************************************** ! - ! MODULE mo_extNsediment - extended nitrogen cycle processes + ! MODULE mo_extNsediment - extended nitrogen cycle processes ! in the sediment ! ! j.maerz 13.09.2022 ! ! Pupose: ! ------- - ! - initialization of sediment related parameters of the - ! extended nitrogen cycle ! - representation of microbial processes ! ! Description: ! ------------ ! The module holds the sequentially operated processes of: - ! - nitrification - ! - denitrification/dissimilatory nitrate reduction from NO3 to NO2 + ! - nitrification + ! - denitrification/dissimilatory nitrate reduction from NO3 to NO2 ! - anammox - ! - denitrification processes from NO2 -> N2O -> N2 and DNRA + ! - denitrification processes from NO2 -> N2O -> N2 and DNRA ! (dissimilatory nitrite reduction to ammonium) ! - ! The process of ammonification in the sediment for the extended - ! nitrogen cycle is handled inside powach.F90. + ! The process of ammonification in the sediment for the extended + ! nitrogen cycle is handled inside powach.F90. ! !********************************************************************** - use mo_param1_bgc, only: issso12,ipowaic,ipowaal,ipowaph,ipowaox,ipown2,ipowno3,ipownh4,ipown2o,ipowno2,ks + use mo_param1_bgc, only: issso12,ipowaic,ipowaal,ipowaph,ipowaox,ipown2,ipowno3,ipownh4,ipown2o,& + & ipowno2,ks use mo_vgrid, only: kbo - use mo_param_bgc, only: rnit,rcar,rnoi, & - & rc2n,ro2utammo,ro2nnit,rnoxp,rnoxpi,rno2anmx,rno2anmxi,rnh4anmx, & - & rnh4anmxi,rno2dnra,rno2dnrai,rnh4dnra,rnh4dnrai,rnm1, & - & q10ano3denit_sed,sc_ano3denit_sed,Trefano3denit_sed,rano3denit_sed,bkano3denit_sed, & - & rano2anmx_sed,q10anmx_sed,Trefanmx_sed,alphaanmx_sed,bkoxanmx_sed,bkano2anmx_sed,bkanh4anmx_sed, & - & rano2denit_sed,q10ano2denit_sed,Trefano2denit_sed,bkoxano2denit_sed,bkano2denit_sed, & - & ran2odenit_sed,q10an2odenit_sed,Trefan2odenit_sed,bkoxan2odenit_sed,bkan2odenit_sed, & - & rdnra_sed,q10dnra_sed,Trefdnra_sed,bkoxdnra_sed,bkdnra_sed,ranh4nitr_sed,q10anh4nitr_sed, & - & Trefanh4nitr_sed,bkoxamox_sed,bkanh4nitr_sed,bkamoxn2o_sed,bkyamox_sed, & - & rano2nitr_sed,q10ano2nitr_sed,Trefano2nitr_sed,bkoxnitr_sed,bkano2nitr_sed,n2omaxy_sed, & - & n2oybeta_sed,NOB2AOAy_sed,bn2o_sed,mufn2o_sed,POM_remin_q10_sed, POM_remin_Tref_sed,bkox_drempoc_sed + use mo_param_bgc, only: rnit,rcar,rnoi, & + & rc2n,ro2utammo,ro2nnit,rnoxp,rnoxpi,rno2anmx,rno2anmxi,rnh4anmx, & + & rnh4anmxi,rno2dnra,rno2dnrai,rnh4dnra,rnh4dnrai,rnm1, & + & q10ano3denit_sed,sc_ano3denit_sed,Trefano3denit_sed,rano3denit_sed, & + & bkano3denit_sed,rano2anmx_sed,q10anmx_sed,Trefanmx_sed,alphaanmx_sed, & + & bkoxanmx_sed,bkano2anmx_sed,bkanh4anmx_sed,rano2denit_sed, & + & q10ano2denit_sed,Trefano2denit_sed,bkoxano2denit_sed,bkano2denit_sed, & + & ran2odenit_sed,q10an2odenit_sed,Trefan2odenit_sed,bkoxan2odenit_sed, & + & bkan2odenit_sed,rdnra_sed,q10dnra_sed,Trefdnra_sed,bkoxdnra_sed, & + & bkdnra_sed,ranh4nitr_sed,q10anh4nitr_sed,Trefanh4nitr_sed,bkoxamox_sed,& + & bkanh4nitr_sed,bkamoxn2o_sed,bkyamox_sed,rano2nitr_sed,q10ano2nitr_sed,& + & Trefano2nitr_sed,bkoxnitr_sed,bkano2nitr_sed,n2omaxy_sed,n2oybeta_sed, & + & NOB2AOAy_sed,bn2o_sed,mufn2o_sed,POM_remin_q10_sed, POM_remin_Tref_sed,& + & bkox_drempoc_sed use mo_control_bgc, only: io_stdo_bgc,dtb use mo_sedmnt, only: powtra,sedlay,porsol,porwat @@ -63,16 +65,18 @@ MODULE mo_extNsediment private ! public functions - public :: sed_nitrification,sed_denit_NO3_to_NO2,sed_anammox,sed_denit_DNRA,alloc_mem_extNsediment_diag + public :: sed_nitrification,sed_denit_NO3_to_NO2,sed_anammox,sed_denit_DNRA, & + & alloc_mem_extNsediment_diag ! public parameters and fields - public :: ised_nitr_NH4,ised_nitr_NO2,ised_nitr_N2O_prod,ised_nitr_NH4_OM,ised_nitr_NO2_OM,ised_denit_NO3,ised_denit_NO2, & - ised_denit_N2O,ised_DNRA_NO2,ised_anmx_N2_prod,ised_anmx_OM_prod,ised_remin_aerob,ised_remin_sulf,extNsed_diagnostics + public :: ised_nitr_NH4,ised_nitr_NO2,ised_nitr_N2O_prod,ised_nitr_NH4_OM,ised_nitr_NO2_OM, & + & ised_denit_NO3,ised_denit_NO2,ised_denit_N2O,ised_DNRA_NO2,ised_anmx_N2_prod, & + & ised_anmx_OM_prod,ised_remin_aerob,ised_remin_sulf,extNsed_diagnostics ! output real, dimension (:,:,:,:), allocatable :: extNsed_diagnostics - integer, parameter :: & - ised_nitr_NH4 = 1, & + integer, parameter :: & + ised_nitr_NH4 = 1, & ised_nitr_NO2 = 2, & ised_nitr_N2O_prod = 3, & ised_nitr_NH4_OM = 4, & @@ -86,56 +90,55 @@ MODULE mo_extNsediment ised_remin_aerob = 12, & ised_remin_sulf = 13, & n_seddiag = 13 - + real :: eps = 1.e-25 real :: minlim = 1.e-9 - contains +contains ! ================================================================================================================================ subroutine alloc_mem_extNsediment_diag(kpie,kpje,ksed) - use mod_xc, only: mnproc - use mo_control_bgc, only: io_stdo_bgc - - implicit none + use mod_xc, only: mnproc + use mo_control_bgc, only: io_stdo_bgc - INTEGER, intent(in) :: kpie,kpje,ksed ! ksed = ks - INTEGER :: errstat + implicit none + integer, intent(in) :: kpie,kpje,ksed ! ksed = ks - IF (mnproc.eq.1) THEN - WRITE(io_stdo_bgc,*)'Memory allocation for sediment output of the extended nitrogen cycle ...' - WRITE(io_stdo_bgc,*)'First dimension : ',kpie - WRITE(io_stdo_bgc,*)'Second dimension : ',kpje - WRITE(io_stdo_bgc,*)'Third dimension : ',ksed - WRITE(io_stdo_bgc,*)'Fourth dimension : ',n_seddiag - ENDIF + integer :: errstat - ALLOCATE (extNsed_diagnostics(kpie,kpje,ksed,n_seddiag),stat=errstat) + if (mnproc.eq.1) then + write(io_stdo_bgc,*)'Memory allocation for sediment output of the extended nitrogen cycle ...' + write(io_stdo_bgc,*)'First dimension : ',kpie + write(io_stdo_bgc,*)'Second dimension : ',kpje + write(io_stdo_bgc,*)'Third dimension : ',ksed + write(io_stdo_bgc,*)'Fourth dimension : ',n_seddiag + endif - if(errstat.ne.0) stop 'not enough memory extended nitrogen cycle' + allocate (extNsed_diagnostics(kpie,kpje,ksed,n_seddiag),stat=errstat) + if(errstat.ne.0) stop 'not enough memory extended nitrogen cycle' end subroutine alloc_mem_extNsediment_diag - ! ================================================================================================================================ + ! ================================================================================================================================ subroutine sed_nitrification(j,kpie,kpje,kpke,kbnd,ptho,omask,ex_ddic,ex_dalk) integer, intent(in) :: j,kpie,kpje,kpke,kbnd real, intent(in) :: omask(kpie,kpje) real, intent(in) :: ptho(1-kbnd:kpie+kbnd,1-kbnd:kpje+kbnd,kpke) - ! for calculation of pore water DIC and alkalinity changes [P-units]! + ! for calculation of pore water DIC and alkalinity changes [P-units]! real, intent(inout) :: ex_ddic(kpie,ks) real, intent(inout) :: ex_dalk(kpie,ks) - + ! local variables integer :: i,k - real :: Tdepanh4,O2limanh4,nut1lim,anh4new,potdnh4amox,fdetamox,fno2,fn2o,ftotnh4 + real :: Tdepanh4,O2limanh4,nut1lim,anh4new,potdnh4amox,fdetamox,fno2,fn2o,ftotnh4 real :: Tdepano2,O2limano2,nut2lim,ano2new,potdno2nitr,fdetnitr,no2fn2o,no2fno2,no2fdetamox real :: amoxfrac,nitrfrac,totd,amox,nitr,temp,w2s do i = 1,kpie - do k = 1,ks - if(omask(i,j)>0.5) then + do k = 1,ks + if (omask(i,j) > 0.5) then potdnh4amox = 0. fn2o = 0. fno2 = 0. @@ -144,99 +147,93 @@ subroutine sed_nitrification(j,kpie,kpje,kpke,kbnd,ptho,omask,ex_ddic,ex_dalk) fdetnitr = 0. w2s = porwat(i,j,k) / porsol(i,j,k) -! if(ocetra(i,j,k,ioxygen)>minlim_oxnh4 .and. ocetra(i,j,k,ianh4)>minlim_nh4)then - temp = merge(ptho(i,j,kbo(i,j)),10.,ptho(i,j,kbo(i,j))<40.) - ! Ammonium oxidation step of nitrification - Tdepanh4 = q10anh4nitr_sed**((temp-Trefanh4nitr_sed)/10.) - O2limanh4 = powtra(i,j,k,ipowaox)/(powtra(i,j,k,ipowaox) + bkoxamox_sed) - nut1lim = powtra(i,j,k,ipownh4)/(powtra(i,j,k,ipownh4) + bkanh4nitr_sed) - anh4new = powtra(i,j,k,ipownh4)/(1. + ranh4nitr_sed*Tdepanh4*O2limanh4*nut1lim) - potdnh4amox = max(0.,powtra(i,j,k,ipownh4) - anh4new) - - ! pathway splitting functions according to Goreau 1980 - !===== - ! OLD version according to Goreau - !fn2o = 1. - ocetra(i,j,k,ioxygen)/(ocetra(i,j,k,ioxygen) + bkamoxn2o) - ! NEW version similar to Santoros et al. 2021, Ji et al. 2018 - fn2o = mufn2o_sed * (bn2o_sed + (1.-bn2o_sed)*bkoxamox_sed/(powtra(i,j,k,ipowaox)+bkoxamox_sed)) & - & * powtra(i,j,k,ipownh4)/(powtra(i,j,k,ipownh4)+bkamoxn2o_sed) - !===== - fno2 = powtra(i,j,k,ipowaox)/(powtra(i,j,k,ipowaox) + bkoxamox_sed) - fdetamox = n2omaxy_sed*2.*(1. + n2oybeta_sed)*powtra(i,j,k,ipowaox)*bkyamox_sed & - & /(powtra(i,j,k,ipowaox)**2 + 2.*powtra(i,j,k,ipowaox)*bkyamox_sed + bkyamox_sed**2) - - ! normalization of pathway splitting functions to sum=1 - ftotnh4 = fn2o + fno2 + fdetamox + eps - fn2o = fn2o/ftotnh4 - fno2 = fno2/ftotnh4 - fdetamox = 1. - (fn2o + fno2) -! endif - -! if(ocetra(i,j,k,ioxygen)>minlim_oxno2 .and. ocetra(i,j,k,iano2)>minlim_no2)then -! temp = merge(ptho(i,j,kbo(i,j)),10.,ptho(i,j,kbo(i,j))<40.) - ! NO2 oxidizing step of nitrification - Tdepano2 = q10ano2nitr_sed**((temp-Trefano2nitr_sed)/10.) - O2limano2 = powtra(i,j,k,ipowaox)/(powtra(i,j,k,ipowaox) + bkoxnitr_sed) - nut2lim = powtra(i,j,k,ipowno2)/(powtra(i,j,k,ipowno2) + bkano2nitr_sed) - ano2new = powtra(i,j,k,ipowno2)/(1. + rano2nitr_sed*Tdepano2*O2limano2*nut2lim) - potdno2nitr = max(0.,powtra(i,j,k,ipowno2) - ano2new) - - ! pathway splitting functions for NO2 nitrification - assuming to be the same as for NH4 - ! but with reduced OM gain per used NO2 as energy source (in amox: NH4) - - no2fn2o = mufn2o_sed * (bn2o_sed + (1.-bn2o_sed)*bkoxamox_sed/(powtra(i,j,k,ipowaox)+bkoxamox_sed)) & - & * powtra(i,j,k,ipownh4)/(powtra(i,j,k,ipownh4)+bkamoxn2o_sed) - no2fno2 = powtra(i,j,k,ipowaox)/(powtra(i,j,k,ipowaox) + bkoxamox_sed) - no2fdetamox = NOB2AOAy_sed*n2omaxy_sed*2.*(1. + n2oybeta_sed)*powtra(i,j,k,ipowaox)*bkyamox_sed & - & /(powtra(i,j,k,ipowaox)**2 + 2.*powtra(i,j,k,ipowaox)*bkyamox_sed + bkyamox_sed**2) - - fdetnitr = no2fdetamox/(no2fno2 + no2fn2o) ! yield to energy usage ratio for NO2 -> ratio equals 16:x -! endif + temp = merge(ptho(i,j,kbo(i,j)),10.,ptho(i,j,kbo(i,j))<40.) + ! Ammonium oxidation step of nitrification + Tdepanh4 = q10anh4nitr_sed**((temp-Trefanh4nitr_sed)/10.) + O2limanh4 = powtra(i,j,k,ipowaox)/(powtra(i,j,k,ipowaox) + bkoxamox_sed) + nut1lim = powtra(i,j,k,ipownh4)/(powtra(i,j,k,ipownh4) + bkanh4nitr_sed) + anh4new = powtra(i,j,k,ipownh4)/(1. + ranh4nitr_sed*Tdepanh4*O2limanh4*nut1lim) + potdnh4amox = max(0.,powtra(i,j,k,ipownh4) - anh4new) + + ! pathway splitting functions similar to Santoros et al. 2021, Ji et al. 2018 + fn2o = mufn2o_sed * (bn2o_sed + (1.-bn2o_sed)*bkoxamox_sed & + & /(powtra(i,j,k,ipowaox)+bkoxamox_sed)) & + & * powtra(i,j,k,ipownh4)/(powtra(i,j,k,ipownh4)+bkamoxn2o_sed) + + fno2 = powtra(i,j,k,ipowaox)/(powtra(i,j,k,ipowaox) + bkoxamox_sed) + fdetamox = n2omaxy_sed*2.*(1. + n2oybeta_sed)*powtra(i,j,k,ipowaox)*bkyamox_sed & + & /(powtra(i,j,k,ipowaox)**2 + 2.*powtra(i,j,k,ipowaox)*bkyamox_sed + bkyamox_sed**2) + + ! normalization of pathway splitting functions to sum=1 + ftotnh4 = fn2o + fno2 + fdetamox + eps + fn2o = fn2o/ftotnh4 + fno2 = fno2/ftotnh4 + fdetamox = 1. - (fn2o + fno2) + + ! NO2 oxidizing step of nitrification + Tdepano2 = q10ano2nitr_sed**((temp-Trefano2nitr_sed)/10.) + O2limano2 = powtra(i,j,k,ipowaox)/(powtra(i,j,k,ipowaox) + bkoxnitr_sed) + nut2lim = powtra(i,j,k,ipowno2)/(powtra(i,j,k,ipowno2) + bkano2nitr_sed) + ano2new = powtra(i,j,k,ipowno2)/(1. + rano2nitr_sed*Tdepano2*O2limano2*nut2lim) + potdno2nitr = max(0.,powtra(i,j,k,ipowno2) - ano2new) + + ! pathway splitting functions for NO2 nitrification - assuming to be the same as for NH4 + ! but with reduced OM gain per used NO2 as energy source (in amox: NH4) + no2fn2o = mufn2o_sed * (bn2o_sed + (1.-bn2o_sed)*bkoxamox_sed & + & /(powtra(i,j,k,ipowaox)+bkoxamox_sed)) & + & * powtra(i,j,k,ipownh4)/(powtra(i,j,k,ipownh4)+bkamoxn2o_sed) + no2fno2 = powtra(i,j,k,ipowaox)/(powtra(i,j,k,ipowaox) + bkoxamox_sed) + no2fdetamox = NOB2AOAy_sed*n2omaxy_sed*2.*(1. + n2oybeta_sed)*powtra(i,j,k,ipowaox)*bkyamox_sed & + & /(powtra(i,j,k,ipowaox)**2 + 2.*powtra(i,j,k,ipowaox)*bkyamox_sed + bkyamox_sed**2) + + fdetnitr = no2fdetamox/(no2fno2 + no2fn2o) ! yield to energy usage ratio for NO2 -> ratio equals 16:x ! limitation of the two processes through available nutrients, etc. totd = potdnh4amox + potdno2nitr amoxfrac = potdnh4amox/(totd + eps) nitrfrac = 1. - amoxfrac - - ! Account for potential earlier changes in DIC and alkalinity in finiding the minimum - totd = max(0., & - & min(totd, & - & powtra(i,j,k,ipownh4)/(amoxfrac + fdetnitr*nitrfrac + eps), & ! ammonium - & (powtra(i,j,k,ipowaic)+ex_ddic(i,k))/(rc2n*(fdetamox*amoxfrac + fdetnitr*nitrfrac) + eps), & ! CO2 - & powtra(i,j,k,ipowaph)/(rnoi*(fdetamox*amoxfrac + fdetnitr*nitrfrac) + eps), & ! PO4 - & powtra(i,j,k,ipowaox) & - & /((1.5*fno2 + fn2o - ro2nnit*fdetamox)*amoxfrac + (0.5 - ro2nnit*fdetnitr)*nitrfrac + eps), & ! O2 - & (powtra(i,j,k,ipowaal) + ex_dalk(i,k)) & - & /((2.*fno2 + fn2o + rnm1*rnoi*fdetamox)*amoxfrac + (rnm1*rnoi*fdetnitr)*nitrfrac + eps))) ! alkalinity - amox = amoxfrac*totd - nitr = nitrfrac*totd - - powtra(i,j,k,ipownh4) = powtra(i,j,k,ipownh4) - amox - fdetnitr*nitr - powtra(i,j,k,ipown2o) = powtra(i,j,k,ipown2o) + 0.5*fn2o*amox - powtra(i,j,k,ipowno2) = powtra(i,j,k,ipowno2) + fno2*amox - nitr - powtra(i,j,k,ipowno3) = powtra(i,j,k,ipowno3) + nitr - sedlay(i,j,k,issso12) = sedlay(i,j,k,issso12) + rnoi*(fdetamox*amox + fdetnitr*nitr) * w2s -! ocetra(i,j,k,isco212) = ocetra(i,j,k,isco212) - rc2n*(fdetamox*amox + fdetnitr*nitr) - powtra(i,j,k,ipowaph) = powtra(i,j,k,ipowaph) - rnoi*(fdetamox*amox + fdetnitr*nitr) -! ocetra(i,j,k,iiron) = ocetra(i,j,k,iiron) - riron*rnoi*(fdetamox*amox + fdetnitr*nitr) - powtra(i,j,k,ipowaox) = powtra(i,j,k,ipowaox) - (1.5*fno2 + fn2o - ro2nnit*fdetamox)*amox & + + ! Account for potential earlier changes in DIC and alkalinity in finiding the minimum + totd = max(0., & + & min(totd, & + & powtra(i,j,k,ipownh4)/(amoxfrac + fdetnitr*nitrfrac + eps), & ! ammonium + & (powtra(i,j,k,ipowaic) + ex_ddic(i,k)) & + & /(rc2n*(fdetamox*amoxfrac + fdetnitr*nitrfrac) & + & + eps), & ! CO2 + & powtra(i,j,k,ipowaph)/(rnoi*(fdetamox*amoxfrac+fdetnitr*nitrfrac) + eps), & ! PO4 + & powtra(i,j,k,ipowaox) & + & /((1.5*fno2 + fn2o - ro2nnit*fdetamox)*amoxfrac & + & + (0.5 - ro2nnit*fdetnitr)*nitrfrac + eps), & ! O2 + & (powtra(i,j,k,ipowaal) + ex_dalk(i,k)) & + & /((2.*fno2 + fn2o + rnm1*rnoi*fdetamox)*amoxfrac & + & + (rnm1*rnoi*fdetnitr)*nitrfrac + eps))) ! alkalinity + amox = amoxfrac*totd + nitr = nitrfrac*totd + + powtra(i,j,k,ipownh4) = powtra(i,j,k,ipownh4) - amox - fdetnitr*nitr + powtra(i,j,k,ipown2o) = powtra(i,j,k,ipown2o) + 0.5*fn2o*amox + powtra(i,j,k,ipowno2) = powtra(i,j,k,ipowno2) + fno2*amox - nitr + powtra(i,j,k,ipowno3) = powtra(i,j,k,ipowno3) + nitr + sedlay(i,j,k,issso12) = sedlay(i,j,k,issso12) + rnoi*(fdetamox*amox + fdetnitr*nitr)*w2s + powtra(i,j,k,ipowaph) = powtra(i,j,k,ipowaph) - rnoi*(fdetamox*amox + fdetnitr*nitr) + powtra(i,j,k,ipowaox) = powtra(i,j,k,ipowaox) - (1.5*fno2 + fn2o - ro2nnit*fdetamox)*amox& & - (0.5 - ro2nnit*fdetnitr)*nitr -! ocetra(i,j,k,ialkali) = ocetra(i,j,k,ialkali) - (2.*fno2 + fn2o + rnm1*rnoi*fdetamox)*amox - rnm1*rnoi*fdetnitr*nitr - ! update of DIC and alkalinity through ex_ddic and ex_dalk fields - ! at later stage, when undersaturation of CaCO3 has been calculted + ! update of DIC and alkalinity through ex_ddic and ex_dalk fields + ! at later stage, when undersaturation of CaCO3 has been calculted ex_ddic(i,k) = ex_ddic(i,k) - rc2n*(fdetamox*amox + fdetnitr*nitr) - ex_dalk(i,k) = ex_dalk(i,k) - (2.*fno2 + fn2o + rnm1*rnoi*fdetamox)*amox - rnm1*rnoi*fdetnitr*nitr + ex_dalk(i,k) = ex_dalk(i,k) - (2.*fno2 + fn2o + rnm1*rnoi*fdetamox)*amox & + - rnm1*rnoi*fdetnitr*nitr ! output: extNsed_diagnostics(i,j,k,ised_nitr_NH4) = amox extNsed_diagnostics(i,j,k,ised_nitr_NO2) = nitr extNsed_diagnostics(i,j,k,ised_nitr_N2O_prod) = 0.5*fn2o*amox - extNsed_diagnostics(i,j,k,ised_nitr_NH4_OM) = rnoi*fdetamox*amox * w2s + extNsed_diagnostics(i,j,k,ised_nitr_NH4_OM) = rnoi*fdetamox*amox * w2s extNsed_diagnostics(i,j,k,ised_nitr_NO2_OM) = rnoi*fdetnitr*nitr * w2s - endif + endif + enddo enddo - enddo end subroutine sed_nitrification ! ================================================================================================================================ @@ -244,7 +241,7 @@ subroutine sed_denit_NO3_to_NO2(j,kpie,kpje,kpke,kbnd,ptho,omask,ex_ddic,ex_dalk integer, intent(in) :: j,kpie,kpje,kpke,kbnd real, intent(in) :: omask(kpie,kpje) real, intent(in) :: ptho(1-kbnd:kpie+kbnd,1-kbnd:kpje+kbnd,kpke) - ! for calculation of pore water DIC and alkalinity changes [P-units]! + ! for calculation of pore water DIC and alkalinity changes [P-units]! real, intent(inout) :: ex_ddic(kpie,ks) real, intent(inout) :: ex_dalk(kpie,ks) @@ -253,37 +250,34 @@ subroutine sed_denit_NO3_to_NO2(j,kpie,kpje,kpke,kbnd,ptho,omask,ex_ddic,ex_dalk real :: Tdep,O2inhib,nutlim,ano3new,ano3denit,temp,s2w do i = 1,kpie - do k = 1,ks - if(omask(i,j)>0.5) then - s2w = porsol(i,j,k) / porwat(i,j,k) - temp = merge(ptho(i,j,kbo(i,j)),10.,ptho(i,j,kbo(i,j))<40.) - Tdep = q10ano3denit_sed**((temp-Trefano3denit_sed)/10.) - O2inhib = 1. - tanh(sc_ano3denit_sed*powtra(i,j,k,ipowaox)) - nutlim = powtra(i,j,k,ipowno3)/(powtra(i,j,k,ipowno3) + bkano3denit_sed) - - ano3new = powtra(i,j,k,ipowno3)/(1. + rano3denit_sed*Tdep*O2inhib*nutlim) - - ano3denit = max(0.,min(powtra(i,j,k,ipowno3) - ano3new, sedlay(i,j,k,issso12)*rnoxp*s2w)) - - powtra(i,j,k,ipowno3) = powtra(i,j,k,ipowno3) - ano3denit - powtra(i,j,k,ipowno2) = powtra(i,j,k,ipowno2) + ano3denit - sedlay(i,j,k,issso12) = sedlay(i,j,k,issso12) - ano3denit*rnoxpi/s2w - powtra(i,j,k,ipownh4) = powtra(i,j,k,ipownh4) + ano3denit*rnit*rnoxpi - powtra(i,j,k,ipowaph) = powtra(i,j,k,ipowaph) + ano3denit*rnoxpi - !ocetra(i,j,k,isco212) = ocetra(i,j,k,isco212) + ano3denit*rcar*rnoxpi - !ocetra(i,j,k,ialkali) = ocetra(i,j,k,ialkali) + ano3denit*rnm1*rnoxpi - - ! update of DIC and alkalinity through ex_ddic and ex_dalk fields - ! at later stage, when undersaturation of CaCO3 has been calculted - ex_ddic(i,k) = ex_ddic(i,k) + ano3denit*rcar*rnoxpi - ex_dalk(i,k) = ex_dalk(i,k) + ano3denit*rnm1*rnoxpi - - ! Output: - extNsed_diagnostics(i,j,k,ised_denit_NO3) = ano3denit - endif + do k = 1,ks + if (omask(i,j) > 0.5) then + s2w = porsol(i,j,k) / porwat(i,j,k) + temp = merge(ptho(i,j,kbo(i,j)),10.,ptho(i,j,kbo(i,j)) < 40.) + Tdep = q10ano3denit_sed**((temp-Trefano3denit_sed)/10.) + O2inhib = 1. - tanh(sc_ano3denit_sed*powtra(i,j,k,ipowaox)) + nutlim = powtra(i,j,k,ipowno3)/(powtra(i,j,k,ipowno3) + bkano3denit_sed) + + ano3new = powtra(i,j,k,ipowno3)/(1. + rano3denit_sed*Tdep*O2inhib*nutlim) + + ano3denit = max(0.,min(powtra(i,j,k,ipowno3) - ano3new, sedlay(i,j,k,issso12)*rnoxp*s2w)) + + powtra(i,j,k,ipowno3) = powtra(i,j,k,ipowno3) - ano3denit + powtra(i,j,k,ipowno2) = powtra(i,j,k,ipowno2) + ano3denit + sedlay(i,j,k,issso12) = sedlay(i,j,k,issso12) - ano3denit*rnoxpi/s2w + powtra(i,j,k,ipownh4) = powtra(i,j,k,ipownh4) + ano3denit*rnit*rnoxpi + powtra(i,j,k,ipowaph) = powtra(i,j,k,ipowaph) + ano3denit*rnoxpi + + ! update of DIC and alkalinity through ex_ddic and ex_dalk fields + ! at later stage, when undersaturation of CaCO3 has been calculted + ex_ddic(i,k) = ex_ddic(i,k) + ano3denit*rcar*rnoxpi + ex_dalk(i,k) = ex_dalk(i,k) + ano3denit*rnm1*rnoxpi + + ! Output: + extNsed_diagnostics(i,j,k,ised_denit_NO3) = ano3denit + endif + enddo enddo - enddo - end subroutine sed_denit_NO3_to_NO2 ! ================================================================================================================================ @@ -291,7 +285,7 @@ subroutine sed_anammox(j,kpie,kpje,kpke,kbnd,ptho,omask,ex_ddic,ex_dalk) integer, intent(in) :: j,kpie,kpje,kpke,kbnd real, intent(in) :: omask(kpie,kpje) real, intent(in) :: ptho(1-kbnd:kpie+kbnd,1-kbnd:kpje+kbnd,kpke) - ! for calculation of pore water DIC and alkalinity changes [P-units]! + ! for calculation of pore water DIC and alkalinity changes [P-units]! real, intent(inout) :: ex_ddic(kpie,ks) real, intent(inout) :: ex_dalk(kpie,ks) @@ -300,44 +294,43 @@ subroutine sed_anammox(j,kpie,kpje,kpke,kbnd,ptho,omask,ex_ddic,ex_dalk) real :: Tdep,O2inhib,nut1lim,nut2lim,ano2new,ano2anmx,temp,w2s do i = 1,kpie - do k = 1,ks - if(omask(i,j)>0.5) then - w2s = porwat(i,j,k) / porsol(i,j,k) - temp = merge(ptho(i,j,kbo(i,j)),10.,ptho(i,j,kbo(i,j))<40.) - Tdep = q10anmx_sed**((temp-Trefanmx_sed)/10.) - O2inhib = 1. - exp(alphaanmx_sed*(powtra(i,j,k,ipowaox)-bkoxanmx_sed)) & - & /(1.+ exp(alphaanmx_sed*(powtra(i,j,k,ipowaox)-bkoxanmx_sed))) - nut1lim = powtra(i,j,k,ipowno2)/(powtra(i,j,k,ipowno2)+bkano2anmx_sed) - nut2lim = powtra(i,j,k,ipownh4)/(powtra(i,j,k,ipownh4)+bkanh4anmx_sed) - - ano2new = powtra(i,j,k,ipowno2)/(1. + rano2anmx_sed*Tdep*O2inhib*nut1lim*nut2lim) - - ! Account for former changes in DIC and alkalinity - ano2anmx = max(0.,min(powtra(i,j,k,ipowno2) - ano2new, powtra(i,j,k,ipownh4)*rno2anmx*rnh4anmxi, & - (powtra(i,j,k,ipowaic)+ex_ddic(i,k))*rno2anmx/rcar, powtra(i,j,k,ipowaph)*rno2anmx, & - (powtra(i,j,k,ipowaal)+ex_dalk(i,k))*rno2anmx/rnm1)) - - powtra(i,j,k,ipowno2) = powtra(i,j,k,ipowno2) - ano2anmx - powtra(i,j,k,ipownh4) = powtra(i,j,k,ipownh4) - ano2anmx*rnh4anmx*rno2anmxi - powtra(i,j,k,ipown2) = powtra(i,j,k,ipown2) + ano2anmx*(rnh4anmx-rnit)*rno2anmxi - powtra(i,j,k,ipowno3) = powtra(i,j,k,ipowno3) + ano2anmx*rnoxp*rno2anmxi - sedlay(i,j,k,issso12) = sedlay(i,j,k,issso12) + ano2anmx*rno2anmxi*w2s - powtra(i,j,k,ipowaph) = powtra(i,j,k,ipowaph) - ano2anmx*rno2anmxi -! ocetra(i,j,k,isco212) = ocetra(i,j,k,isco212) - ano2anmx*rcar*rno2anmxi -! ocetra(i,j,k,ialkali) = ocetra(i,j,k,ialkali) - ano2anmx*rnm1*rno2anmxi - - ! update of DIC and alkalinity through ex_ddic and ex_dalk fields - ! at later stage, when undersaturation of CaCO3 has been calculted - ex_ddic(i,k) = ex_ddic(i,k) - ano2anmx*rcar*rno2anmxi - ex_dalk(i,k) = ex_dalk(i,k) - ano2anmx*rnm1*rno2anmxi - - ! Output: - extNsed_diagnostics(i,j,k,ised_anmx_N2_prod) = ano2anmx*(rnh4anmx-rnit)*rno2anmxi ! kmol N2/m3/dtb - N2 prod through anammox - extNsed_diagnostics(i,j,k,ised_anmx_OM_prod) = ano2anmx*rno2anmxi*w2s - endif + do k = 1,ks + if(omask(i,j)>0.5) then + w2s = porwat(i,j,k) / porsol(i,j,k) + temp = merge(ptho(i,j,kbo(i,j)),10.,ptho(i,j,kbo(i,j)) < 40.) + Tdep = q10anmx_sed**((temp-Trefanmx_sed)/10.) + O2inhib = 1. - exp(alphaanmx_sed*(powtra(i,j,k,ipowaox)-bkoxanmx_sed)) & + & /(1.+ exp(alphaanmx_sed*(powtra(i,j,k,ipowaox)-bkoxanmx_sed))) + nut1lim = powtra(i,j,k,ipowno2)/(powtra(i,j,k,ipowno2)+bkano2anmx_sed) + nut2lim = powtra(i,j,k,ipownh4)/(powtra(i,j,k,ipownh4)+bkanh4anmx_sed) + + ano2new = powtra(i,j,k,ipowno2)/(1. + rano2anmx_sed*Tdep*O2inhib*nut1lim*nut2lim) + + ! Account for former changes in DIC and alkalinity + ano2anmx = max(0.,min(powtra(i,j,k,ipowno2) - ano2new, & + powtra(i,j,k,ipownh4)*rno2anmx*rnh4anmxi, & + (powtra(i,j,k,ipowaic)+ex_ddic(i,k))*rno2anmx/rcar, & + powtra(i,j,k,ipowaph)*rno2anmx, & + (powtra(i,j,k,ipowaal)+ex_dalk(i,k))*rno2anmx/rnm1)) + + powtra(i,j,k,ipowno2) = powtra(i,j,k,ipowno2) - ano2anmx + powtra(i,j,k,ipownh4) = powtra(i,j,k,ipownh4) - ano2anmx*rnh4anmx*rno2anmxi + powtra(i,j,k,ipown2) = powtra(i,j,k,ipown2) + ano2anmx*(rnh4anmx-rnit)*rno2anmxi + powtra(i,j,k,ipowno3) = powtra(i,j,k,ipowno3) + ano2anmx*rnoxp*rno2anmxi + sedlay(i,j,k,issso12) = sedlay(i,j,k,issso12) + ano2anmx*rno2anmxi*w2s + powtra(i,j,k,ipowaph) = powtra(i,j,k,ipowaph) - ano2anmx*rno2anmxi + + ! update of DIC and alkalinity through ex_ddic and ex_dalk fields + ! at later stage, when undersaturation of CaCO3 has been calculted + ex_ddic(i,k) = ex_ddic(i,k) - ano2anmx*rcar*rno2anmxi + ex_dalk(i,k) = ex_dalk(i,k) - ano2anmx*rnm1*rno2anmxi + + ! Output: + extNsed_diagnostics(i,j,k,ised_anmx_N2_prod) = ano2anmx*(rnh4anmx-rnit)*rno2anmxi ! kmol N2/m3/dtb - N2 prod through anammox + extNsed_diagnostics(i,j,k,ised_anmx_OM_prod) = ano2anmx*rno2anmxi*w2s + endif + enddo enddo - enddo - end subroutine sed_anammox ! ================================================================================================================================ @@ -345,102 +338,97 @@ subroutine sed_denit_DNRA(j,kpie,kpje,kpke,kbnd,ptho,omask,ex_ddic,ex_dalk) integer, intent(in) :: j,kpie,kpje,kpke,kbnd real, intent(in) :: omask(kpie,kpje) real, intent(in) :: ptho(1-kbnd:kpie+kbnd,1-kbnd:kpje+kbnd,kpke) - ! for calculation of pore water DIC and alkalinity changes [P-units]! + ! for calculation of pore water DIC and alkalinity changes [P-units]! real, intent(inout) :: ex_ddic(kpie,ks) real, intent(inout) :: ex_dalk(kpie,ks) - + ! local variables integer :: i,k real :: Tdepano2,O2inhibano2,nutlimano2,rpotano2denit,ano2denit real :: Tdepdnra,O2inhibdnra,nutlimdnra,rpotano2dnra,ano2dnra - real :: fdenit,fdnra,potano2new,potdano2,potddet,fdetano2denit,fdetan2odenit,fdetdnra + real :: fdenit,fdnra,potano2new,potdano2,potddet,fdetano2denit,fdetan2odenit,fdetdnra real :: Tdepan2o,O2inhiban2o,nutliman2o,an2onew,an2odenit real :: temp,s2w do i = 1,kpie - do k = 1,ks - if(omask(i,j)>0.5) then + do k = 1,ks + if (omask(i,j) > 0.5) then potddet = 0. an2odenit = 0. ano2denit = 0. ano2dnra = 0. s2w = porsol(i,j,k) / porwat(i,j,k) -! if(0.<=ocetra(i,j,k,ioxygen) .and. ocetra(i,j,k,ioxygen)minlim_n2o)then - temp = merge(ptho(i,j,kbo(i,j)),10.,ptho(i,j,kbo(i,j))<40.) + temp = merge(ptho(i,j,kbo(i,j)),10.,ptho(i,j,kbo(i,j)) < 40.) + ! === denitrification on N2O - Tdepan2o = q10an2odenit_sed**((temp-Trefan2odenit_sed)/10.) - O2inhiban2o = bkoxan2odenit_sed**2/(powtra(i,j,k,ipowaox)**2 + bkoxan2odenit_sed**2) - nutliman2o = powtra(i,j,k,ipown2o)/(powtra(i,j,k,ipown2o) + bkan2odenit_sed) - an2onew = powtra(i,j,k,ipown2o)/(1. + ran2odenit_sed*Tdepan2o*O2inhiban2o*nutliman2o) - an2odenit = max(0.,min(powtra(i,j,k,ipown2o),powtra(i,j,k,ipown2o) - an2onew)) -! endif - -! if(0.<=ocetra(i,j,k,ioxygen) .and. ocetra(i,j,k,ioxygen)minlim_no2)then -! temp = merge(ptho(i,j,kbo(i,j)),10.,ptho(i,j,kbo(i,j))<40.) - ! denitrification on NO2 - Tdepano2 = q10ano2denit_sed**((temp-Trefano2denit_sed)/10.) - O2inhibano2 = bkoxano2denit_sed**2/(powtra(i,j,k,ipowaox)**2 + bkoxano2denit_sed**2) - nutlimano2 = powtra(i,j,k,ipowno2)/(powtra(i,j,k,ipowno2) + bkano2denit_sed) - rpotano2denit = max(0.,rano2denit_sed*Tdepano2*O2inhibano2*nutlimano2) ! potential rate of denit - - ! DNRA on NO2 - Tdepdnra = q10dnra_sed**((temp-Trefdnra_sed)/10.) - O2inhibdnra = bkoxdnra_sed**2/(powtra(i,j,k,ipowaox)**2 + bkoxdnra_sed**2) - nutlimdnra = powtra(i,j,k,ipowno2)/(powtra(i,j,k,ipowno2) + bkdnra_sed) - rpotano2dnra = max(0.,rdnra_sed*Tdepdnra*O2inhibdnra*nutlimdnra) ! pot. rate of dnra - - ! potential new conc of NO2 due to denitrification and DNRA - potano2new = powtra(i,j,k,ipowno2)/(1. + rpotano2denit + rpotano2dnra) - potdano2 = max(0.,min(powtra(i,j,k,ipowno2), powtra(i,j,k,ipowno2) - potano2new)) - - ! === limitation due to NO2: - ! fraction on potential change of NO2: - fdenit = rpotano2denit/(rpotano2denit + rpotano2dnra + eps) - fdnra = 1. - fdenit - - ! potential fractional change - ano2denit = fdenit * potdano2 - ano2dnra = fdnra * potdano2 - ! endif + Tdepan2o = q10an2odenit_sed**((temp-Trefan2odenit_sed)/10.) + O2inhiban2o = bkoxan2odenit_sed**2/(powtra(i,j,k,ipowaox)**2 + bkoxan2odenit_sed**2) + nutliman2o = powtra(i,j,k,ipown2o)/(powtra(i,j,k,ipown2o) + bkan2odenit_sed) + an2onew = powtra(i,j,k,ipown2o)/(1. + ran2odenit_sed*Tdepan2o*O2inhiban2o*nutliman2o) + an2odenit = max(0.,min(powtra(i,j,k,ipown2o),powtra(i,j,k,ipown2o) - an2onew)) + + ! denitrification on NO2 + Tdepano2 = q10ano2denit_sed**((temp-Trefano2denit_sed)/10.) + O2inhibano2 = bkoxano2denit_sed**2/(powtra(i,j,k,ipowaox)**2 + bkoxano2denit_sed**2) + nutlimano2 = powtra(i,j,k,ipowno2)/(powtra(i,j,k,ipowno2) + bkano2denit_sed) + rpotano2denit = max(0.,rano2denit_sed*Tdepano2*O2inhibano2*nutlimano2) ! potential rate of denit + + ! DNRA on NO2 + Tdepdnra = q10dnra_sed**((temp-Trefdnra_sed)/10.) + O2inhibdnra = bkoxdnra_sed**2/(powtra(i,j,k,ipowaox)**2 + bkoxdnra_sed**2) + nutlimdnra = powtra(i,j,k,ipowno2)/(powtra(i,j,k,ipowno2) + bkdnra_sed) + rpotano2dnra = max(0.,rdnra_sed*Tdepdnra*O2inhibdnra*nutlimdnra) ! pot. rate of dnra + + ! potential new conc of NO2 due to denitrification and DNRA + potano2new = powtra(i,j,k,ipowno2)/(1. + rpotano2denit + rpotano2dnra) + potdano2 = max(0.,min(powtra(i,j,k,ipowno2), powtra(i,j,k,ipowno2) - potano2new)) + + ! === limitation due to NO2: + ! fraction on potential change of NO2: + fdenit = rpotano2denit/(rpotano2denit + rpotano2dnra + eps) + fdnra = 1. - fdenit + + ! potential fractional change + ano2denit = fdenit * potdano2 + ano2dnra = fdnra * potdano2 ! limitation of processes due to detritus (based on pore water volume) - potddet = rnoxpi*(ano2denit + an2odenit) + rno2dnrai*ano2dnra ! P units + potddet = rnoxpi*(ano2denit + an2odenit) + rno2dnrai*ano2dnra ! P units fdetano2denit = rnoxpi*ano2denit/(potddet + eps) fdetan2odenit = rnoxpi*an2odenit/(potddet + eps) - fdetdnra = 1. - fdetano2denit - fdetan2odenit - potddet = max(0.,min(potddet,powtra(i,j,k,issso12)*s2w)) - -! if(potddet>0.)then - ! change of NO2 and N2O in N units - ano2denit = fdetano2denit*rnoxp*potddet - an2odenit = fdetan2odenit*rnoxp*potddet - ano2dnra = fdetdnra*rno2dnra*potddet - - ! change in tracer concentrations due to denit (NO2->N2O->N2) and DNRA (NO2->NH4) - powtra(i,j,k,ipowno2) = powtra(i,j,k,ipowno2) - ano2denit - ano2dnra - powtra(i,j,k,ipown2o) = powtra(i,j,k,ipown2o) - an2odenit + 0.5*ano2denit - powtra(i,j,k,ipown2) = powtra(i,j,k,ipown2) + an2odenit - powtra(i,j,k,ipownh4) = powtra(i,j,k,ipownh4) + rnit*rnoxpi*(ano2denit+an2odenit) + rnh4dnra*rno2dnrai*ano2dnra - sedlay(i,j,k,issso12) = sedlay(i,j,k,issso12) - ((ano2denit + an2odenit)*rnoxpi + ano2dnra*rno2dnrai)/s2w - powtra(i,j,k,ipowaph) = powtra(i,j,k,ipowaph) + (ano2denit + an2odenit)*rnoxpi + ano2dnra*rno2dnrai -! ocetra(i,j,k,isco212) = ocetra(i,j,k,isco212) + rcar*rnoxpi*(ano2denit + an2odenit) + rcar*rno2dnrai*ano2dnra -! ocetra(i,j,k,iiron) = ocetra(i,j,k,iiron) + riron*rnoxpi*(ano2denit + an2odenit) + riron*rno2dnrai*ano2dnra -! ocetra(i,j,k,ialkali) = ocetra(i,j,k,ialkali) + (295.*ano2denit + rnm1*an2odenit)*rnoxpi & -! & + (rno2dnra + rnh4dnra - 1.)*rno2dnrai * ano2dnra - - ! update of DIC and alkalinity through ex_ddic and ex_dalk fields - ! at later stage, when undersaturation of CaCO3 has been calculted - ex_ddic(i,k) = ex_ddic(i,k) + rcar*rnoxpi*(ano2denit + an2odenit) + rcar*rno2dnrai*ano2dnra - ex_dalk(i,k) = ex_dalk(i,k) + (295.*ano2denit + rnm1*an2odenit)*rnoxpi + (rno2dnra + rnh4dnra - 1.)*rno2dnrai * ano2dnra - - extNsed_diagnostics(i,j,k,ised_denit_NO2) = ano2denit - extNsed_diagnostics(i,j,k,ised_denit_N2O) = an2odenit - extNsed_diagnostics(i,j,k,ised_DNRA_NO2) = ano2dnra - endif + fdetdnra = 1. - fdetano2denit - fdetan2odenit + potddet = max(0.,min(potddet,powtra(i,j,k,issso12)*s2w)) + + ! change of NO2 and N2O in N units + ano2denit = fdetano2denit*rnoxp*potddet + an2odenit = fdetan2odenit*rnoxp*potddet + ano2dnra = fdetdnra*rno2dnra*potddet + + ! change in tracer concentrations due to denit (NO2->N2O->N2) and DNRA (NO2->NH4) + powtra(i,j,k,ipowno2) = powtra(i,j,k,ipowno2) - ano2denit - ano2dnra + powtra(i,j,k,ipown2o) = powtra(i,j,k,ipown2o) - an2odenit + 0.5*ano2denit + powtra(i,j,k,ipown2) = powtra(i,j,k,ipown2) + an2odenit + powtra(i,j,k,ipownh4) = powtra(i,j,k,ipownh4) + rnit*rnoxpi*(ano2denit+an2odenit) & + & + rnh4dnra*rno2dnrai*ano2dnra + sedlay(i,j,k,issso12) = sedlay(i,j,k,issso12) & + & - ((ano2denit + an2odenit)*rnoxpi + ano2dnra*rno2dnrai)/s2w + powtra(i,j,k,ipowaph) = powtra(i,j,k,ipowaph) + (ano2denit + an2odenit)*rnoxpi & + & + ano2dnra*rno2dnrai + + ! update of DIC and alkalinity through ex_ddic and ex_dalk fields + ! at later stage, when undersaturation of CaCO3 has been calculted + ex_ddic(i,k) = ex_ddic(i,k) + rcar*rnoxpi*(ano2denit + an2odenit) & + & + rcar*rno2dnrai*ano2dnra + ex_dalk(i,k) = ex_dalk(i,k) + (295.*ano2denit + rnm1*an2odenit)*rnoxpi & + & + (rno2dnra + rnh4dnra - 1.)*rno2dnrai*ano2dnra + + extNsed_diagnostics(i,j,k,ised_denit_NO2) = ano2denit + extNsed_diagnostics(i,j,k,ised_denit_N2O) = an2odenit + extNsed_diagnostics(i,j,k,ised_DNRA_NO2) = ano2dnra + endif + enddo enddo - enddo - end subroutine sed_denit_DNRA -END MODULE mo_extNsediment +end module mo_extNsediment From 908d1e15f12fea9907d7d2a4dd042fea608ffade Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Wed, 24 Jan 2024 13:54:52 +0100 Subject: [PATCH 333/366] cleaning, indenting, small letters - trying to comply to new coding style --- hamocc/mo_extNwatercol.F90 | 811 ++++++++++++++++++------------------- 1 file changed, 385 insertions(+), 426 deletions(-) diff --git a/hamocc/mo_extNwatercol.F90 b/hamocc/mo_extNwatercol.F90 index 72c1df55..113b0255 100644 --- a/hamocc/mo_extNwatercol.F90 +++ b/hamocc/mo_extNwatercol.F90 @@ -3,258 +3,234 @@ ! This file is part of BLOM/iHAMOCC. ! ! 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. +! 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 +! 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. +! more details. ! -! You should have received a copy of the GNU Lesser General Public License +! You should have received a copy of the GNU Lesser General Public License ! along with BLOM. If not, see https://www.gnu.org/licenses/. - MODULE mo_extNwatercol - !**************************************************************** - ! - ! MODULE mo_extNbioproc - (microbial) biological processes of the - ! extended nitrogen cycle - ! - ! j.maerz 25.04.2022 - ! - ! Purpose: - ! -------- - ! - initialization of parameters related to the extended nitrogen cycle - ! - representing major biological parts of the extended nitrogen cycle - ! - ! Description: - ! ------------ - ! The module holds the sequentially operated processes of - ! - nitrification - ! - denitrification/dissimilatory nitrate reduction from NO3 to NO2 - ! - anammox - ! - denitrification processes from NO2 -> N2O -> N2 and DNRA - ! (dissimilatory nitrite reduction to ammonium) - ! - ! The process of ammonium and nitrate uptake by phytoplankton - ! is handled in ocprod. - ! - ! Ammonification (PON -> NH4) is also handled in ocprod. - ! - ! Explicit cyanobacteria? - ! - ! The respective sediment processes are handled in: - ! - powach.F90 and - ! - mo_extNsediment.F90 - ! - !**************************************************************** - use mo_vgrid, only: dp_min - use mod_xc, only: mnproc - use mo_control_bgc, only: io_stdo_bgc,dtb - use mo_param1_bgc, only: ialkali,ianh4,iano2,ian2o,iano3,idet,igasnit,iiron,ioxygen,iphosph,isco212 - use mo_carbch, only: ocetra - use mo_param_bgc, only: riron,rnit,rcar,rnoi, & - & q10ano3denit,sc_ano3denit,Trefano3denit,rano3denit,bkano3denit, & - & rano2anmx,q10anmx,Trefanmx,alphaanmx,bkoxanmx,bkano2anmx,bkanh4anmx, & - & rano2denit,q10ano2denit,Trefano2denit,bkoxano2denit,bkano2denit, & - & ran2odenit,q10an2odenit,Trefan2odenit,bkoxan2odenit,bkan2odenit, & - & rdnra,q10dnra,Trefdnra,bkoxdnra,bkdnra,ranh4nitr,q10anh4nitr, & - & Trefanh4nitr,bkoxamox,bkanh4nitr,bkamoxn2o,bkyamox, & - & rano2nitr,q10ano2nitr,Trefano2nitr,bkoxnitr,bkano2nitr,n2omaxy, & - & n2oybeta,NOB2AOAy,bn2o,mufn2o, & - & rc2n,ro2nnit,rnoxp,rnoxpi,rno2anmx,rno2anmxi,rnh4anmx, & - & rnh4anmxi,rno2dnra,rno2dnrai,rnh4dnra,rnh4dnrai,rnm1, & - & bkphyanh4,bkphyano3,bkphosph,bkiron,ro2utammo - use mo_biomod, only: nitr_NH4,nitr_NO2,nitr_N2O_prod,nitr_NH4_OM,nitr_NO2_OM,denit_NO3, & - & denit_NO2,denit_N2O,DNRA_NO2,anmx_N2_prod,anmx_OM_prod - implicit none - - private - - ! public functions - public :: nitrification,denit_NO3_to_NO2,anammox,denit_dnra,extN_inv_check - - real :: eps = 1.e-25 - real :: minlim = 1.e-9 - - CONTAINS - - subroutine nitrification(kpie,kpje,kpke,kbnd,pddpo,omask,ptho) - ! Nitrification processes (NH4 -> NO2, NO2 -> NO3) accompanied - ! by dark carbon fixation and O2-dependent N2O production - - integer, intent(in) :: kpie,kpje,kpke,kbnd - real, intent(in) :: omask(kpie,kpje) - real, intent(in) :: pddpo(kpie,kpje,kpke) - real, intent(in) :: ptho(1-kbnd:kpie+kbnd,1-kbnd:kpje+kbnd,kpke) - - !local variables - integer :: i,j,k - real :: Tdepanh4,O2limanh4,nut1lim,anh4new,potdnh4amox,fdetamox,fno2,fn2o,ftotnh4 - real :: Tdepano2,O2limano2,nut2lim,ano2new,potdno2nitr,fdetnitr,ftotno2,no2fn2o,no2fno2,no2fdetamox - real :: amoxfrac,nitrfrac,totd,amox,nitr,temp - - real :: minlim_oxnh4,minlim_nh4,minlim_oxno2,minlim_no2 ! minimum conc for limitation functions - - minlim_oxnh4 = bkoxamox*minlim/(1. - minlim) - minlim_oxno2 = bkoxnitr*minlim/(1. - minlim) - minlim_nh4 = bkanh4nitr*minlim/(1. - minlim) - minlim_no2 = bkano2nitr*minlim/(1. - minlim) - - ! Set output-related fields to zero - nitr_NH4 = 0. - nitr_NO2 = 0. - nitr_N2O_prod = 0. - nitr_NH4_OM = 0. - nitr_NO2_OM = 0. - - !$OMP PARALLEL DO PRIVATE(i,k,Tdepanh4,O2limanh4,nut1lim,anh4new,potdnh4amox,fdetamox,fno2,fn2o,ftotnh4, & - !$OMP Tdepano2,O2limano2,nut2lim,ano2new,potdno2nitr,fdetnitr,ftotno2,amoxfrac, & - !$OMP nitrfrac,totd,amox,nitr,temp,no2fn2o,no2fno2,no2fdetamox) - - do j = 1,kpje +module mo_extNwatercol + !**************************************************************** + ! + ! MODULE mo_extNwatercol - (microbial) biological processes of the + ! extended nitrogen cycle + ! + ! j.maerz 25.04.2022 + ! + ! Purpose: + ! -------- + ! - representing major biological parts of the extended nitrogen cycle + ! + ! Description: + ! ------------ + ! The module holds the sequentially operated processes of + ! - nitrification + ! - denitrification/dissimilatory nitrate reduction from NO3 to NO2 + ! - anammox + ! - denitrification processes from NO2 -> N2O -> N2 and DNRA + ! (dissimilatory nitrite reduction to ammonium) + ! + ! The process of ammonium and nitrate uptake by phytoplankton + ! is handled in ocprod. + ! + ! Ammonification (PON -> NH4) is also handled in ocprod. + ! + ! The respective sediment processes are handled in: + ! - powach.F90 and + ! - mo_extNsediment.F90 + ! + !**************************************************************** + use mo_vgrid, only: dp_min + use mod_xc, only: mnproc + use mo_control_bgc, only: io_stdo_bgc,dtb + use mo_param1_bgc, only: ialkali,ianh4,iano2,ian2o,iano3,idet,igasnit,iiron,ioxygen,iphosph, & + & isco212 + use mo_carbch, only: ocetra + use mo_param_bgc, only: riron,rnit,rcar,rnoi, & + & q10ano3denit,sc_ano3denit,Trefano3denit,rano3denit,bkano3denit, & + & rano2anmx,q10anmx,Trefanmx,alphaanmx,bkoxanmx,bkano2anmx,bkanh4anmx, & + & rano2denit,q10ano2denit,Trefano2denit,bkoxano2denit,bkano2denit, & + & ran2odenit,q10an2odenit,Trefan2odenit,bkoxan2odenit,bkan2odenit, & + & rdnra,q10dnra,Trefdnra,bkoxdnra,bkdnra,ranh4nitr,q10anh4nitr, & + & Trefanh4nitr,bkoxamox,bkanh4nitr,bkamoxn2o,bkyamox, & + & rano2nitr,q10ano2nitr,Trefano2nitr,bkoxnitr,bkano2nitr,n2omaxy, & + & n2oybeta,NOB2AOAy,bn2o,mufn2o, & + & rc2n,ro2nnit,rnoxp,rnoxpi,rno2anmx,rno2anmxi,rnh4anmx, & + & rnh4anmxi,rno2dnra,rno2dnrai,rnh4dnra,rnh4dnrai,rnm1, & + & bkphyanh4,bkphyano3,bkphosph,bkiron,ro2utammo + use mo_biomod, only: nitr_NH4,nitr_NO2,nitr_N2O_prod,nitr_NH4_OM,nitr_NO2_OM,denit_NO3, & + & denit_NO2,denit_N2O,DNRA_NO2,anmx_N2_prod,anmx_OM_prod + implicit none + + private + + ! public functions + public :: nitrification,denit_NO3_to_NO2,anammox,denit_dnra,extN_inv_check + + real :: eps = 1.e-25 + real :: minlim = 1.e-9 + +contains + + subroutine nitrification(kpie,kpje,kpke,kbnd,pddpo,omask,ptho) + ! Nitrification processes (NH4 -> NO2, NO2 -> NO3) accompanied + ! by dark carbon fixation and O2-dependent N2O production + + integer, intent(in) :: kpie,kpje,kpke,kbnd + real, intent(in) :: omask(kpie,kpje) + real, intent(in) :: pddpo(kpie,kpje,kpke) + real, intent(in) :: ptho(1-kbnd:kpie+kbnd,1-kbnd:kpje+kbnd,kpke) + + !local variables + integer :: i,j,k + real :: Tdepanh4,O2limanh4,nut1lim,anh4new,potdnh4amox,fdetamox,fno2,fn2o,ftotnh4 + real :: Tdepano2,O2limano2,nut2lim,ano2new,potdno2nitr,fdetnitr,ftotno2,no2fn2o,no2fno2, & + no2fdetamox + real :: amoxfrac,nitrfrac,totd,amox,nitr,temp + + ! Set output-related fields to zero + nitr_NH4 = 0. + nitr_NO2 = 0. + nitr_N2O_prod = 0. + nitr_NH4_OM = 0. + nitr_NO2_OM = 0. + + !$OMP PARALLEL DO PRIVATE(i,k,Tdepanh4,O2limanh4,nut1lim,anh4new,potdnh4amox,fdetamox,fno2, & + !$OMP fn2o,ftotnh4,Tdepano2,O2limano2,nut2lim,ano2new,potdno2nitr,fdetnitr,& + !$OMP ftotno2,amoxfrac,nitrfrac,totd,amox,nitr,temp,no2fn2o,no2fno2, & + !$OMP no2fdetamox) + do j = 1,kpje do i = 1,kpie - do k = 1,kpke - if(pddpo(i,j,k) > dp_min .and. omask(i,j) > 0.5) then - potdnh4amox = 0. - fn2o = 0. - fno2 = 0. - fdetamox = 0. - potdno2nitr = 0. - fdetnitr = 0. - -! if(ocetra(i,j,k,ioxygen)>minlim_oxnh4 .and. ocetra(i,j,k,ianh4)>minlim_nh4)then - temp = merge(ptho(i,j,k),10.,ptho(i,j,k)<40.) - ! Ammonium oxidation step of nitrification - Tdepanh4 = q10anh4nitr**((temp-Trefanh4nitr)/10.) - O2limanh4 = ocetra(i,j,k,ioxygen)/(ocetra(i,j,k,ioxygen) + bkoxamox) - nut1lim = ocetra(i,j,k,ianh4)/(ocetra(i,j,k,ianh4) + bkanh4nitr) - anh4new = ocetra(i,j,k,ianh4)/(1. + ranh4nitr*Tdepanh4*O2limanh4*nut1lim) - potdnh4amox = max(0.,ocetra(i,j,k,ianh4) - anh4new) - - ! pathway splitting functions according to Goreau 1980 - !===== - ! OLD version according to Goreau - !fn2o = 1. - ocetra(i,j,k,ioxygen)/(ocetra(i,j,k,ioxygen) + bkamoxn2o) - ! NEW version similar to Santoros et al. 2021, Ji et al. 2018 - fn2o = mufn2o * (bn2o + (1.-bn2o)*bkoxamox/(ocetra(i,j,k,ioxygen)+bkoxamox)) & - & * ocetra(i,j,k,ianh4)/(ocetra(i,j,k,ianh4)+bkamoxn2o) - !===== - fno2 = ocetra(i,j,k,ioxygen)/(ocetra(i,j,k,ioxygen) + bkoxamox) - fdetamox = n2omaxy*2.*(1. + n2oybeta)*ocetra(i,j,k,ioxygen)*bkyamox & + do k = 1,kpke + if(pddpo(i,j,k) > dp_min .and. omask(i,j) > 0.5) then + potdnh4amox = 0. + fn2o = 0. + fno2 = 0. + fdetamox = 0. + potdno2nitr = 0. + fdetnitr = 0. + + temp = merge(ptho(i,j,k),10.,ptho(i,j,k) < 40.) + ! Ammonium oxidation step of nitrification + Tdepanh4 = q10anh4nitr**((temp-Trefanh4nitr)/10.) + O2limanh4 = ocetra(i,j,k,ioxygen)/(ocetra(i,j,k,ioxygen) + bkoxamox) + nut1lim = ocetra(i,j,k,ianh4)/(ocetra(i,j,k,ianh4) + bkanh4nitr) + anh4new = ocetra(i,j,k,ianh4)/(1. + ranh4nitr*Tdepanh4*O2limanh4*nut1lim) + potdnh4amox = max(0.,ocetra(i,j,k,ianh4) - anh4new) + + ! pathway splitting function similar to Santoros et al. 2021, Ji et al. 2018 + fn2o = mufn2o * (bn2o + (1.-bn2o)*bkoxamox/(ocetra(i,j,k,ioxygen)+bkoxamox)) & + & * ocetra(i,j,k,ianh4)/(ocetra(i,j,k,ianh4)+bkamoxn2o) + + fno2 = ocetra(i,j,k,ioxygen)/(ocetra(i,j,k,ioxygen) + bkoxamox) + fdetamox = n2omaxy*2.*(1. + n2oybeta)*ocetra(i,j,k,ioxygen)*bkyamox & & /(ocetra(i,j,k,ioxygen)**2 + 2.*ocetra(i,j,k,ioxygen)*bkyamox + bkyamox**2) - ! normalization of pathway splitting functions to sum=1 - ftotnh4 = fn2o + fno2 + fdetamox + eps - fn2o = fn2o/ftotnh4 - fno2 = fno2/ftotnh4 - fdetamox = 1. - (fn2o + fno2) -! endif - -! if(ocetra(i,j,k,ioxygen)>minlim_oxno2 .and. ocetra(i,j,k,iano2)>minlim_no2)then - temp = merge(ptho(i,j,k),10.,ptho(i,j,k)<40.) - ! NO2 oxidizing step of nitrification - Tdepano2 = q10ano2nitr**((temp-Trefano2nitr)/10.) - O2limano2 = ocetra(i,j,k,ioxygen)/(ocetra(i,j,k,ioxygen) + bkoxnitr) - nut2lim = ocetra(i,j,k,iano2)/(ocetra(i,j,k,iano2) + bkano2nitr) - ano2new = ocetra(i,j,k,iano2)/(1. + rano2nitr*Tdepano2*O2limano2*nut2lim) - potdno2nitr = max(0.,ocetra(i,j,k,iano2) - ano2new) + ! normalization of pathway splitting functions to sum=1 + ftotnh4 = fn2o + fno2 + fdetamox + eps + fn2o = fn2o/ftotnh4 + fno2 = fno2/ftotnh4 + fdetamox = 1. - (fn2o + fno2) + + ! NO2 oxidizing step of nitrification + Tdepano2 = q10ano2nitr**((temp-Trefano2nitr)/10.) + O2limano2 = ocetra(i,j,k,ioxygen)/(ocetra(i,j,k,ioxygen) + bkoxnitr) + nut2lim = ocetra(i,j,k,iano2)/(ocetra(i,j,k,iano2) + bkano2nitr) + ano2new = ocetra(i,j,k,iano2)/(1. + rano2nitr*Tdepano2*O2limano2*nut2lim) + potdno2nitr = max(0.,ocetra(i,j,k,iano2) - ano2new) ! pathway splitting functions for NO2 nitrification - assuming to be the same as for NH4 ! but with reduced OM gain per used NO2 as energy source (in amox: NH4) - !===== - ! OLD version according to Goreau - ! no2fn2o = 1. - ocetra(i,j,k,ioxygen)/(ocetra(i,j,k,ioxygen) + bkamoxn2o) - ! NEW version - no2fn2o = mufn2o * (bn2o + (1.-bn2o)*bkoxamox/(ocetra(i,j,k,ioxygen)+bkoxamox)) & - & * ocetra(i,j,k,ianh4)/(ocetra(i,j,k,ianh4)+bkamoxn2o) - !===== - no2fno2 = ocetra(i,j,k,ioxygen)/(ocetra(i,j,k,ioxygen) + bkoxamox) - no2fdetamox = NOB2AOAy*n2omaxy*2.*(1. + n2oybeta)*ocetra(i,j,k,ioxygen)*bkyamox & - & /(ocetra(i,j,k,ioxygen)**2 + 2.*ocetra(i,j,k,ioxygen)*bkyamox + bkyamox**2) + no2fn2o = mufn2o * (bn2o + (1.-bn2o)*bkoxamox/(ocetra(i,j,k,ioxygen)+bkoxamox)) & + & * ocetra(i,j,k,ianh4)/(ocetra(i,j,k,ianh4)+bkamoxn2o) - fdetnitr = no2fdetamox/(no2fno2 + no2fn2o) ! yield to energy usage ratio for NO2 -> ratio equals 16:x -! endif + no2fno2 = ocetra(i,j,k,ioxygen)/(ocetra(i,j,k,ioxygen) + bkoxamox) + no2fdetamox = NOB2AOAy*n2omaxy*2.*(1. + n2oybeta)*ocetra(i,j,k,ioxygen)*bkyamox & + & /(ocetra(i,j,k,ioxygen)**2 + 2.*ocetra(i,j,k,ioxygen)*bkyamox + bkyamox**2) - ! limitation of the two processes through available nutrients, etc. - totd = potdnh4amox + potdno2nitr - amoxfrac = potdnh4amox/(totd + eps) - nitrfrac = 1. - amoxfrac - - totd = max(0., & - & min(totd, & - & ocetra(i,j,k,ianh4)/(amoxfrac + fdetnitr*nitrfrac + eps), & ! ammonium - & ocetra(i,j,k,isco212)/(rc2n*(fdetamox*amoxfrac + fdetnitr*nitrfrac) + eps), & ! CO2 - & ocetra(i,j,k,iphosph)/(rnoi*(fdetamox*amoxfrac + fdetnitr*nitrfrac) + eps), & ! PO4 - & ocetra(i,j,k,iiron)/(riron*rnoi*(fdetamox*amoxfrac + fdetnitr*nitrfrac) + eps), & ! Fe - & ocetra(i,j,k,ioxygen) & - & /((1.5*fno2 + fn2o - ro2nnit*fdetamox)*amoxfrac + (0.5 - ro2nnit*fdetnitr)*nitrfrac + eps), & ! O2 - & ocetra(i,j,k,ialkali) & - & /((2.*fno2 + fn2o + rnm1*rnoi*fdetamox)*amoxfrac + (rnm1*rnoi*fdetnitr)*nitrfrac + eps))) ! alkalinity - amox = amoxfrac*totd - nitr = nitrfrac*totd - - ocetra(i,j,k,ianh4) = ocetra(i,j,k,ianh4) - amox - fdetnitr*nitr - ocetra(i,j,k,ian2o) = ocetra(i,j,k,ian2o) + 0.5*fn2o*amox - ocetra(i,j,k,iano2) = ocetra(i,j,k,iano2) + fno2*amox - nitr - ocetra(i,j,k,iano3) = ocetra(i,j,k,iano3) + nitr - ocetra(i,j,k,idet) = ocetra(i,j,k,idet) + rnoi*(fdetamox*amox + fdetnitr*nitr) - ocetra(i,j,k,isco212) = ocetra(i,j,k,isco212) - rc2n*(fdetamox*amox + fdetnitr*nitr) - ocetra(i,j,k,iphosph) = ocetra(i,j,k,iphosph) - rnoi*(fdetamox*amox + fdetnitr*nitr) - ocetra(i,j,k,iiron) = ocetra(i,j,k,iiron) - riron*rnoi*(fdetamox*amox + fdetnitr*nitr) - ocetra(i,j,k,ioxygen) = ocetra(i,j,k,ioxygen) - (1.5*fno2 + fn2o - ro2nnit*fdetamox)*amox & - & - (0.5 - ro2nnit*fdetnitr)*nitr - ocetra(i,j,k,ialkali) = ocetra(i,j,k,ialkali) - (2.*fno2 + fn2o + rnm1*rnoi*fdetamox)*amox - rnm1*rnoi*fdetnitr*nitr - - ! Output - nitr_NH4(i,j,k) = amox ! kmol N/m3/dtb - NH4 consumption for nitrification on NH4-incl. usage for biomass - nitr_NO2(i,j,k) = nitr ! kmol N/m3/dtb - NO2 consumption for nitrification on NO2 - nitr_N2O_prod(i,j,k) = 0.5*fn2o*amox ! kmol N2O/m3/dtb - N2O production during aerob ammonium oxidation - nitr_NH4_OM(i,j,k) = rnoi*fdetamox*amox ! kmol P/m3/dtb - organic matter production during aerob NH4 oxidation - nitr_NO2_OM(i,j,k) = rnoi*fdetnitr*nitr ! kmol P/m3/dtb - organic matter production during aerob NO2 oxidation - - endif - enddo - enddo - enddo - !$OMP END PARALLEL DO + fdetnitr = no2fdetamox/(no2fno2 + no2fn2o) ! yield to energy usage ratio for NO2 -> ratio equals 16:x - end subroutine nitrification -!================================================================================================================================== - subroutine denit_NO3_to_NO2(kpie,kpje,kpke,kbnd,pddpo,omask,ptho) - ! Denitrification / dissimilatory nitrate reduction (NO3 -> NO2) + ! limitation of the two processes through available nutrients, etc. + totd = potdnh4amox + potdno2nitr + amoxfrac = potdnh4amox/(totd + eps) + nitrfrac = 1. - amoxfrac + + totd = max(0., & + & min(totd, & + & ocetra(i,j,k,ianh4)/(amoxfrac + fdetnitr*nitrfrac + eps), & ! ammonium + & ocetra(i,j,k,isco212)/(rc2n*(fdetamox*amoxfrac + fdetnitr*nitrfrac) +eps),& ! CO2 + & ocetra(i,j,k,iphosph)/(rnoi*(fdetamox*amoxfrac + fdetnitr*nitrfrac) +eps),& ! PO4 + & ocetra(i,j,k,iiron)/(riron*rnoi*(fdetamox*amoxfrac + fdetnitr*nitrfrac) & + & + eps), & ! Fe + & ocetra(i,j,k,ioxygen) & + & /((1.5*fno2 + fn2o - ro2nnit*fdetamox)*amoxfrac & + + (0.5 - ro2nnit*fdetnitr)*nitrfrac + eps), & ! O2 + & ocetra(i,j,k,ialkali) & + & /((2.*fno2 + fn2o + rnm1*rnoi*fdetamox)*amoxfrac & + & + (rnm1*rnoi*fdetnitr)*nitrfrac + eps))) ! alkalinity + amox = amoxfrac*totd + nitr = nitrfrac*totd + + ocetra(i,j,k,ianh4) = ocetra(i,j,k,ianh4) - amox - fdetnitr*nitr + ocetra(i,j,k,ian2o) = ocetra(i,j,k,ian2o) + 0.5*fn2o*amox + ocetra(i,j,k,iano2) = ocetra(i,j,k,iano2) + fno2*amox - nitr + ocetra(i,j,k,iano3) = ocetra(i,j,k,iano3) + nitr + ocetra(i,j,k,idet) = ocetra(i,j,k,idet) + rnoi*(fdetamox*amox + fdetnitr*nitr) + ocetra(i,j,k,isco212) = ocetra(i,j,k,isco212) - rc2n*(fdetamox*amox + fdetnitr*nitr) + ocetra(i,j,k,iphosph) = ocetra(i,j,k,iphosph) - rnoi*(fdetamox*amox + fdetnitr*nitr) + ocetra(i,j,k,iiron) = ocetra(i,j,k,iiron) - riron*rnoi*(fdetamox*amox + fdetnitr*nitr) + ocetra(i,j,k,ioxygen) = ocetra(i,j,k,ioxygen) - (1.5*fno2 + fn2o - ro2nnit*fdetamox)*amox & + & - (0.5 - ro2nnit*fdetnitr)*nitr + ocetra(i,j,k,ialkali) = ocetra(i,j,k,ialkali) - (2.*fno2 + fn2o + rnm1*rnoi*fdetamox)*amox& + & - rnm1*rnoi*fdetnitr*nitr - integer, intent(in) :: kpie,kpje,kpke,kbnd - real, intent(in) :: omask(kpie,kpje) - real, intent(in) :: pddpo(kpie,kpje,kpke) - real, intent(in) :: ptho(1-kbnd:kpie+kbnd,1-kbnd:kpje+kbnd,kpke) + ! Output + nitr_NH4(i,j,k) = amox ! kmol N/m3/dtb - NH4 consumption for nitrification on NH4-incl. usage for biomass + nitr_NO2(i,j,k) = nitr ! kmol N/m3/dtb - NO2 consumption for nitrification on NO2 + nitr_N2O_prod(i,j,k) = 0.5*fn2o*amox ! kmol N2O/m3/dtb - N2O production during aerob ammonium oxidation + nitr_NH4_OM(i,j,k) = rnoi*fdetamox*amox ! kmol P/m3/dtb - organic matter production during aerob NH4 oxidation + nitr_NO2_OM(i,j,k) = rnoi*fdetnitr*nitr ! kmol P/m3/dtb - organic matter production during aerob NO2 oxidation + endif + enddo + enddo + enddo + !$OMP END PARALLEL DO + end subroutine nitrification - !local variables - integer :: i,j,k - real :: Tdep,O2inhib,nutlim,ano3new,ano3denit,temp +!=================================================================================================================================== + subroutine denit_NO3_to_NO2(kpie,kpje,kpke,kbnd,pddpo,omask,ptho) + ! Denitrification / dissimilatory nitrate reduction (NO3 -> NO2) - real :: minlim_ox,minlim_no3 ! minimum conc for limitation functions + integer, intent(in) :: kpie,kpje,kpke,kbnd + real, intent(in) :: omask(kpie,kpje) + real, intent(in) :: pddpo(kpie,kpje,kpke) + real, intent(in) :: ptho(1-kbnd:kpie+kbnd,1-kbnd:kpje+kbnd,kpke) - minlim_ox = log(2./minlim-1.)/(2.*sc_ano3denit) - minlim_no3 = bkano3denit*minlim/(1.-minlim) + !local variables + integer :: i,j,k + real :: Tdep,O2inhib,nutlim,ano3new,ano3denit,temp - ! Sett output-related field to zero - denit_NO3 = 0. + ! Sett output-related field to zero + denit_NO3 = 0. - !$OMP PARALLEL DO PRIVATE(i,k,Tdep,O2inhib,nutlim,ano3new,ano3denit,temp) - do j = 1,kpje + !$OMP PARALLEL DO PRIVATE(i,k,Tdep,O2inhib,nutlim,ano3new,ano3denit,temp) + do j = 1,kpje do i = 1,kpie - do k = 1,kpke - if(pddpo(i,j,k) > dp_min .and. omask(i,j) > 0.5) then -! if(ocetra(i,j,k,ioxygen) < minlim_ox .and. ocetra(i,j,k,iano3)>minlim_no3)then - temp = merge(ptho(i,j,k),10.,ptho(i,j,k)<40.) - Tdep = q10ano3denit**((temp-Trefano3denit)/10.) - O2inhib = 1. - tanh(sc_ano3denit*ocetra(i,j,k,ioxygen)) + do k = 1,kpke + if(pddpo(i,j,k) > dp_min .and. omask(i,j) > 0.5) then + temp = merge(ptho(i,j,k),10.,ptho(i,j,k) < 40.) + Tdep = q10ano3denit**((temp-Trefano3denit)/10.) + O2inhib = 1. - tanh(sc_ano3denit*ocetra(i,j,k,ioxygen)) nutlim = ocetra(i,j,k,iano3)/(ocetra(i,j,k,iano3) + bkano3denit) - ano3new = ocetra(i,j,k,iano3)/(1. + rano3denit*Tdep*O2inhib*nutlim) + ano3new = ocetra(i,j,k,iano3)/(1. + rano3denit*Tdep*O2inhib*nutlim) ano3denit = max(0.,min(ocetra(i,j,k,iano3) - ano3new, ocetra(i,j,k,idet)*rnoxp)) @@ -268,219 +244,202 @@ subroutine denit_NO3_to_NO2(kpie,kpje,kpke,kbnd,pddpo,omask,ptho) ocetra(i,j,k,ialkali) = ocetra(i,j,k,ialkali) + ano3denit*rnm1*rnoxpi ! Output - denit_NO3(i,j,k) = ano3denit ! kmol NO3/m3/dtb - NO3 usage for denit on NO3 -! endif - endif - enddo - enddo + denit_NO3(i,j,k) = ano3denit ! kmol NO3/m3/dtb - NO3 usage for denit on NO3 + endif + enddo enddo - !$OMP END PARALLEL DO + enddo + !$OMP END PARALLEL DO + end subroutine denit_NO3_to_NO2 - end subroutine denit_NO3_to_NO2 +!================================================================================================================================== + subroutine anammox(kpie,kpje,kpke,kbnd,pddpo,omask,ptho) + ! Aanammox -!================================================================================================================================== - subroutine anammox(kpie,kpje,kpke,kbnd,pddpo,omask,ptho) - ! Aanammox + integer, intent(in) :: kpie,kpje,kpke,kbnd + real, intent(in) :: omask(kpie,kpje) + real, intent(in) :: pddpo(kpie,kpje,kpke) + real, intent(in) :: ptho(1-kbnd:kpie+kbnd,1-kbnd:kpje+kbnd,kpke) - integer, intent(in) :: kpie,kpje,kpke,kbnd - real, intent(in) :: omask(kpie,kpje) - real, intent(in) :: pddpo(kpie,kpje,kpke) - real, intent(in) :: ptho(1-kbnd:kpie+kbnd,1-kbnd:kpje+kbnd,kpke) + !local variables + integer :: i,j,k + real :: Tdep,O2inhib,nut1lim,nut2lim,ano2new,ano2anmx,temp - !local variables - integer :: i,j,k - real :: Tdep,O2inhib,nut1lim,nut2lim,ano2new,ano2anmx,temp + ! Set output-related field to zero + anmx_N2_prod = 0. + anmx_OM_prod = 0. - real :: minlim_ox,minlim_nh4,minlim_no2 ! minimum conc for limitation functions - - minlim_ox = log((1.-minlim)/minlim)/alphaanmx + bkoxanmx - minlim_nh4 = bkanh4anmx*minlim/(1.-minlim) - minlim_no2 = bkano2anmx*minlim/(1.-minlim) - - ! Set output-related field to zero - anmx_N2_prod = 0. - anmx_OM_prod = 0. - - !$OMP PARALLEL DO PRIVATE(i,k,Tdep,O2inhib,nut1lim,nut2lim,ano2new,ano2anmx,temp) - do j = 1,kpje + !$OMP PARALLEL DO PRIVATE(i,k,Tdep,O2inhib,nut1lim,nut2lim,ano2new,ano2anmx,temp) + do j = 1,kpje do i = 1,kpie - do k = 1,kpke - if(pddpo(i,j,k) > dp_min .and. omask(i,j) > 0.5) then -! if(ocetra(i,j,k,iano2)>minlim_no2 .and. ocetra(i,j,k,ianh4)>minlim_nh4 .and. ocetra(i,j,k,ioxygen) N2O -> N2) and dissmilatory nitrite reduction (NO2 -> NH4) - - integer, intent(in) :: kpie,kpje,kpke,kbnd - real, intent(in) :: omask(kpie,kpje) - real, intent(in) :: pddpo(kpie,kpje,kpke) - real, intent(in) :: ptho(1-kbnd:kpie+kbnd,1-kbnd:kpje+kbnd,kpke) - - !local variables - integer :: i,j,k - real :: Tdepano2,O2inhibano2,nutlimano2,detlimano2,rpotano2denit,ano2denit - real :: Tdepdnra,O2inhibdnra,nutlimdnra,detlimdnra,rpotano2dnra,ano2dnra - real :: fdenit,fdnra,potano2new,potdano2,potddet,fdetano2denit,fdetan2odenit,fdetdnra - real :: Tdepan2o,O2inhiban2o,nutliman2o,detliman2o,an2onew,an2odenit - - real :: temp - + do k = 1,kpke + if(pddpo(i,j,k) > dp_min .and. omask(i,j) > 0.5) then + temp = merge(ptho(i,j,k),10.,ptho(i,j,k) < 40.) + Tdep = q10anmx**((temp-Trefanmx)/10.) + O2inhib = 1. - exp(alphaanmx*(ocetra(i,j,k,ioxygen)-bkoxanmx)) & + & /(1.+ exp(alphaanmx*(ocetra(i,j,k,ioxygen)-bkoxanmx))) + nut1lim = ocetra(i,j,k,iano2)/(ocetra(i,j,k,iano2)+bkano2anmx) + nut2lim = ocetra(i,j,k,ianh4)/(ocetra(i,j,k,ianh4)+bkanh4anmx) + + ano2new = ocetra(i,j,k,iano2)/(1. + rano2anmx*Tdep*O2inhib*nut1lim*nut2lim) + + ano2anmx = max(0.,min(ocetra(i,j,k,iano2) - ano2new, & + ocetra(i,j,k,ianh4)*rno2anmx*rnh4anmxi, & + ocetra(i,j,k,isco212)*rno2anmx/rcar, & + ocetra(i,j,k,iphosph)*rno2anmx, & + ocetra(i,j,k,iiron)*rno2anmx/riron, & + ocetra(i,j,k,ialkali)*rno2anmx/rnm1)) + + ocetra(i,j,k,iano2) = ocetra(i,j,k,iano2) - ano2anmx + ocetra(i,j,k,ianh4) = ocetra(i,j,k,ianh4) - ano2anmx*rnh4anmx*rno2anmxi + ocetra(i,j,k,igasnit) = ocetra(i,j,k,igasnit) + ano2anmx*(rnh4anmx-rnit)*rno2anmxi + ocetra(i,j,k,iano3) = ocetra(i,j,k,iano3) + ano2anmx*rnoxp*rno2anmxi + ocetra(i,j,k,idet) = ocetra(i,j,k,idet) + ano2anmx*rno2anmxi + ocetra(i,j,k,isco212) = ocetra(i,j,k,isco212) - ano2anmx*rcar*rno2anmxi + ocetra(i,j,k,iphosph) = ocetra(i,j,k,iphosph) - ano2anmx*rno2anmxi + ocetra(i,j,k,iiron) = ocetra(i,j,k,iiron) - ano2anmx*riron*rno2anmxi + ocetra(i,j,k,ialkali) = ocetra(i,j,k,ialkali) - ano2anmx*rnm1*rno2anmxi - real :: minlim_ox,minlim_oxn2o,minlim_no2,minlim_n2o - - minlim_ox = min(bkoxano2denit,bkoxdnra)/sqrt(minlim) - minlim_oxn2o = bkoxan2odenit/sqrt(minlim) - minlim_no2 = min(bkdnra,bkano2denit)*minlim/(1. - minlim) - minlim_n2o = bkan2odenit*minlim/(1. - minlim) - - ! Set output-related field to zero - denit_NO2 = 0. - denit_N2O = 0. - DNRA_NO2 = 0. - - !$OMP PARALLEL DO PRIVATE(i,k,Tdepano2,O2inhibano2,nutlimano2,detlimano2,ano2denit, & - !$OMP Tdepan2o,O2inhiban2o,nutliman2o,detliman2o,an2onew,an2odenit, & - !$OMP rpotano2denit,rpotano2dnra, & - !$OMP fdenit,fdnra,potano2new,potdano2,potddet,fdetano2denit, & - !$OMP fdetan2odenit,fdetdnra, & - !$OMP Tdepdnra,O2inhibdnra,nutlimdnra,detlimdnra,ano2dnra,temp) - - do j = 1,kpje - do i = 1,kpie - do k = 1,kpke - if(pddpo(i,j,k) > dp_min .and. omask(i,j) > 0.5) then - potddet = 0. - an2odenit = 0. - ano2denit = 0. - ano2dnra = 0. - -! if(0.<=ocetra(i,j,k,ioxygen) .and. ocetra(i,j,k,ioxygen)minlim_n2o)then - temp = merge(ptho(i,j,k),10.,ptho(i,j,k)<40.) - ! === denitrification on N2O - Tdepan2o = q10an2odenit**((temp-Trefan2odenit)/10.) - O2inhiban2o = bkoxan2odenit**2/(ocetra(i,j,k,ioxygen)**2 + bkoxan2odenit**2) - nutliman2o = ocetra(i,j,k,ian2o)/(ocetra(i,j,k,ian2o) + bkan2odenit) - an2onew = ocetra(i,j,k,ian2o)/(1. + ran2odenit*Tdepan2o*O2inhiban2o*nutliman2o) - an2odenit = max(0.,min(ocetra(i,j,k,ian2o),ocetra(i,j,k,ian2o) - an2onew)) -! endif - -! if(0.<=ocetra(i,j,k,ioxygen) .and. ocetra(i,j,k,ioxygen)minlim_no2)then - temp = merge(ptho(i,j,k),10.,ptho(i,j,k)<40.) - ! denitrification on NO2 - Tdepano2 = q10ano2denit**((temp-Trefano2denit)/10.) - O2inhibano2 = bkoxano2denit**2/(ocetra(i,j,k,ioxygen)**2 + bkoxano2denit**2) - nutlimano2 = ocetra(i,j,k,iano2)/(ocetra(i,j,k,iano2) + bkano2denit) - rpotano2denit = max(0.,rano2denit*Tdepano2*O2inhibano2*nutlimano2) ! potential rate of denit - - ! DNRA on NO2 - Tdepdnra = q10dnra**((temp-Trefdnra)/10.) - O2inhibdnra = bkoxdnra**2/(ocetra(i,j,k,ioxygen)**2 + bkoxdnra**2) - nutlimdnra = ocetra(i,j,k,iano2)/(ocetra(i,j,k,iano2) + bkdnra) - rpotano2dnra = max(0.,rdnra*Tdepdnra*O2inhibdnra*nutlimdnra) ! pot. rate of dnra - - ! potential new conc of NO2 due to denitrification and DNRA - potano2new = ocetra(i,j,k,iano2)/(1. + rpotano2denit + rpotano2dnra) - potdano2 = max(0.,min(ocetra(i,j,k,iano2), ocetra(i,j,k,iano2) - potano2new)) - - ! === limitation due to NO2: - ! fraction on potential change of NO2: - fdenit = rpotano2denit/(rpotano2denit + rpotano2dnra + eps) - fdnra = 1. - fdenit - - ! potential fractional change - ano2denit = fdenit * potdano2 - ano2dnra = fdnra * potdano2 -! endif - - ! limitation of processes due to detritus - potddet = rnoxpi*(ano2denit + an2odenit) + rno2dnrai*ano2dnra ! P units - fdetano2denit = rnoxpi*ano2denit/(potddet + eps) - fdetan2odenit = rnoxpi*an2odenit/(potddet + eps) - fdetdnra = 1. - fdetano2denit - fdetan2odenit - potddet = max(0.,min(potddet,ocetra(i,j,k,idet))) - -! if(potddet>0.)then - ! change of NO2 and N2O in N units - ano2denit = fdetano2denit*rnoxp*potddet - an2odenit = fdetan2odenit*rnoxp*potddet - ano2dnra = fdetdnra*rno2dnra*potddet - - ! change in tracer concentrations due to denit (NO2->N2O->N2) and DNRA (NO2->NH4) - ocetra(i,j,k,iano2) = ocetra(i,j,k,iano2) - ano2denit - ano2dnra - ocetra(i,j,k,ian2o) = ocetra(i,j,k,ian2o) - an2odenit + 0.5*ano2denit - ocetra(i,j,k,igasnit) = ocetra(i,j,k,igasnit) + an2odenit - ocetra(i,j,k,ianh4) = ocetra(i,j,k,ianh4) + rnit*rnoxpi*(ano2denit+an2odenit) + rnh4dnra*rno2dnrai*ano2dnra - ocetra(i,j,k,idet) = ocetra(i,j,k,idet) - (ano2denit + an2odenit)*rnoxpi - ano2dnra*rno2dnrai - ocetra(i,j,k,isco212) = ocetra(i,j,k,isco212) + rcar*rnoxpi*(ano2denit + an2odenit) + rcar*rno2dnrai*ano2dnra - ocetra(i,j,k,iphosph) = ocetra(i,j,k,iphosph) + (ano2denit + an2odenit)*rnoxpi + ano2dnra*rno2dnrai - ocetra(i,j,k,iiron) = ocetra(i,j,k,iiron) + riron*rnoxpi*(ano2denit + an2odenit) + riron*rno2dnrai*ano2dnra - ocetra(i,j,k,ialkali) = ocetra(i,j,k,ialkali) + (295.*ano2denit + rnm1*an2odenit)*rnoxpi & - & + (rno2dnra + rnh4dnra - 1.)*rno2dnrai * ano2dnra - ! Output - denit_NO2(i,j,k) = ano2denit ! kmol NO2/m3/dtb - denitrification on NO2 - denit_N2O(i,j,k) = an2odenit ! kmol N2O/m3/dtb - denitrification on N2O - DNRA_NO2(i,j,k) = ano2dnra ! kmol NO2/m3/dtb - DNRA on NO2 -! endif - endif - enddo + ! Output + anmx_N2_prod(i,j,k) = ano2anmx*(rnh4anmx-rnit)*rno2anmxi ! kmol N2/m3/dtb - N2 prod through anammox + anmx_OM_prod(i,j,k) = ano2anmx*rno2anmxi ! kmol P/m3/dtb - OM production by anammox + endif + enddo enddo + enddo + !$OMP END PARALLEL DO + end subroutine anammox + +!================================================================================================================================== + subroutine denit_dnra(kpie,kpje,kpke,kbnd,pddpo,omask,ptho) + ! Denitrification processes (NO2 -> N2O -> N2) and dissmilatory nitrite reduction (NO2 -> NH4) + + integer, intent(in) :: kpie,kpje,kpke,kbnd + real, intent(in) :: omask(kpie,kpje) + real, intent(in) :: pddpo(kpie,kpje,kpke) + real, intent(in) :: ptho(1-kbnd:kpie+kbnd,1-kbnd:kpje+kbnd,kpke) + + !local variables + integer :: i,j,k + real :: Tdepano2,O2inhibano2,nutlimano2,detlimano2,rpotano2denit,ano2denit + real :: Tdepdnra,O2inhibdnra,nutlimdnra,detlimdnra,rpotano2dnra,ano2dnra + real :: fdenit,fdnra,potano2new,potdano2,potddet,fdetano2denit,fdetan2odenit,fdetdnra + real :: Tdepan2o,O2inhiban2o,nutliman2o,detliman2o,an2onew,an2odenit + + real :: temp + + ! Set output-related field to zero + denit_NO2 = 0. + denit_N2O = 0. + DNRA_NO2 = 0. + + !$OMP PARALLEL DO PRIVATE(i,k,Tdepano2,O2inhibano2,nutlimano2,detlimano2,ano2denit, & + !$OMP Tdepan2o,O2inhiban2o,nutliman2o,detliman2o,an2onew,an2odenit, & + !$OMP rpotano2denit,rpotano2dnra, & + !$OMP fdenit,fdnra,potano2new,potdano2,potddet,fdetano2denit, & + !$OMP fdetan2odenit,fdetdnra, & + !$OMP Tdepdnra,O2inhibdnra,nutlimdnra,detlimdnra,ano2dnra,temp) + + do j = 1,kpje + do i = 1,kpie + do k = 1,kpke + if(pddpo(i,j,k) > dp_min .and. omask(i,j) > 0.5) then + potddet = 0. + an2odenit = 0. + ano2denit = 0. + ano2dnra = 0. + + temp = merge(ptho(i,j,k),10.,ptho(i,j,k) < 40.) + ! === denitrification on N2O + Tdepan2o = q10an2odenit**((temp-Trefan2odenit)/10.) + O2inhiban2o = bkoxan2odenit**2/(ocetra(i,j,k,ioxygen)**2 + bkoxan2odenit**2) + nutliman2o = ocetra(i,j,k,ian2o)/(ocetra(i,j,k,ian2o) + bkan2odenit) + an2onew = ocetra(i,j,k,ian2o)/(1. + ran2odenit*Tdepan2o*O2inhiban2o*nutliman2o) + an2odenit = max(0.,min(ocetra(i,j,k,ian2o),ocetra(i,j,k,ian2o) - an2onew)) + + ! denitrification on NO2 + Tdepano2 = q10ano2denit**((temp-Trefano2denit)/10.) + O2inhibano2 = bkoxano2denit**2/(ocetra(i,j,k,ioxygen)**2 + bkoxano2denit**2) + nutlimano2 = ocetra(i,j,k,iano2)/(ocetra(i,j,k,iano2) + bkano2denit) + rpotano2denit = max(0.,rano2denit*Tdepano2*O2inhibano2*nutlimano2) ! potential rate of denit + + ! DNRA on NO2 + Tdepdnra = q10dnra**((temp-Trefdnra)/10.) + O2inhibdnra = bkoxdnra**2/(ocetra(i,j,k,ioxygen)**2 + bkoxdnra**2) + nutlimdnra = ocetra(i,j,k,iano2)/(ocetra(i,j,k,iano2) + bkdnra) + rpotano2dnra = max(0.,rdnra*Tdepdnra*O2inhibdnra*nutlimdnra) ! pot. rate of dnra + + ! potential new conc of NO2 due to denitrification and DNRA + potano2new = ocetra(i,j,k,iano2)/(1. + rpotano2denit + rpotano2dnra) + potdano2 = max(0.,min(ocetra(i,j,k,iano2), ocetra(i,j,k,iano2) - potano2new)) + + ! === limitation due to NO2: + ! fraction on potential change of NO2: + fdenit = rpotano2denit/(rpotano2denit + rpotano2dnra + eps) + fdnra = 1. - fdenit + + ! potential fractional change + ano2denit = fdenit * potdano2 + ano2dnra = fdnra * potdano2 + + ! limitation of processes due to detritus + potddet = rnoxpi*(ano2denit + an2odenit) + rno2dnrai*ano2dnra ! P units + fdetano2denit = rnoxpi*ano2denit/(potddet + eps) + fdetan2odenit = rnoxpi*an2odenit/(potddet + eps) + fdetdnra = 1. - fdetano2denit - fdetan2odenit + potddet = max(0.,min(potddet,ocetra(i,j,k,idet))) + + ! change of NO2 and N2O in N units + ano2denit = fdetano2denit*rnoxp*potddet + an2odenit = fdetan2odenit*rnoxp*potddet + ano2dnra = fdetdnra*rno2dnra*potddet + + ! change in tracer concentrations due to denit (NO2->N2O->N2) and DNRA (NO2->NH4) + ocetra(i,j,k,iano2) = ocetra(i,j,k,iano2) - ano2denit - ano2dnra + ocetra(i,j,k,ian2o) = ocetra(i,j,k,ian2o) - an2odenit + 0.5*ano2denit + ocetra(i,j,k,igasnit) = ocetra(i,j,k,igasnit) + an2odenit + ocetra(i,j,k,ianh4) = ocetra(i,j,k,ianh4) + rnit*rnoxpi*(ano2denit+an2odenit) & + & + rnh4dnra*rno2dnrai*ano2dnra + ocetra(i,j,k,idet) = ocetra(i,j,k,idet) - (ano2denit + an2odenit)*rnoxpi & + & - ano2dnra*rno2dnrai + ocetra(i,j,k,isco212) = ocetra(i,j,k,isco212) + rcar*rnoxpi*(ano2denit + an2odenit) & + & + rcar*rno2dnrai*ano2dnra + ocetra(i,j,k,iphosph) = ocetra(i,j,k,iphosph) + (ano2denit + an2odenit)*rnoxpi & + & + ano2dnra*rno2dnrai + ocetra(i,j,k,iiron) = ocetra(i,j,k,iiron) + riron*rnoxpi*(ano2denit + an2odenit) & + & + riron*rno2dnrai*ano2dnra + ocetra(i,j,k,ialkali) = ocetra(i,j,k,ialkali) + (295.*ano2denit + rnm1*an2odenit)*rnoxpi & + & + (rno2dnra + rnh4dnra - 1.)*rno2dnrai*ano2dnra + ! Output + denit_NO2(i,j,k) = ano2denit ! kmol NO2/m3/dtb - denitrification on NO2 + denit_N2O(i,j,k) = an2odenit ! kmol N2O/m3/dtb - denitrification on N2O + DNRA_NO2(i,j,k) = ano2dnra ! kmol NO2/m3/dtb - DNRA on NO2 + endif + enddo enddo - !$OMP END PARALLEL DO - end subroutine denit_dnra + enddo + !$OMP END PARALLEL DO + end subroutine denit_dnra -!================================================================================================================================== - subroutine extN_inv_check(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask,inv_message) - ! provide inventory calculation for extended nitrogen cycle +!================================================================================================================================== + subroutine extN_inv_check(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask,inv_message) + ! provide inventory calculation for extended nitrogen cycle - integer, intent(in) :: kpie,kpje,kpke - real, intent(in) :: omask(kpie,kpje) - real, intent(in) :: pdlxp(kpie,kpje),pdlyp(kpie,kpje),pddpo(kpie,kpje,kpke) - character (len=*),intent(in) :: inv_message + integer, intent(in) :: kpie,kpje,kpke + real, intent(in) :: omask(kpie,kpje) + real, intent(in) :: pdlxp(kpie,kpje),pdlyp(kpie,kpje),pddpo(kpie,kpje,kpke) + character (len=*),intent(in) :: inv_message #ifdef PBGC_OCNP_TIMESTEP - if (mnproc == 1) then - write(io_stdo_bgc,*)' ' - write(io_stdo_bgc,*)inv_message - endif - CALL INVENTORY_BGC(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask,0) + if (mnproc == 1) then + write(io_stdo_bgc,*)' ' + write(io_stdo_bgc,*)inv_message + endif + call INVENTORY_BGC(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask,0) #endif - end subroutine extN_inv_check + end subroutine extN_inv_check -!================================================================================================================================== - END MODULE +!================================================================================================================================== +end module mo_extNwatercol From c5f38b5bea30890cd838fbddac84d697ce51613d Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Wed, 24 Jan 2024 13:55:03 +0100 Subject: [PATCH 334/366] cleaning, indenting, small letters - trying to comply to new coding style --- hamocc/mo_m4ago.F90 | 1479 ++++++++++++++++++++++--------------------- 1 file changed, 741 insertions(+), 738 deletions(-) diff --git a/hamocc/mo_m4ago.F90 b/hamocc/mo_m4ago.F90 index 27b55240..87a0ba43 100644 --- a/hamocc/mo_m4ago.F90 +++ b/hamocc/mo_m4ago.F90 @@ -5,34 +5,34 @@ !! The 3-Clause BSD License !! SPDX short identifier: BSD-3-Clause !! See https://opensource.org/licenses/BSD-3-Clause -!! -!! (c) Copyright 2016-2021 MPI-M, Joeran Maerz, Irene Stemmler; +!! +!! (c) Copyright 2016-2021 MPI-M, Joeran Maerz, Irene Stemmler; !! first published 2020 !! -!! Redistribution and use in source and binary forms, with or without +!! Redistribution and use in source and binary forms, with or without !! modification, are permitted provided that the following conditions are met: !! -!! 1. Redistributions of source code must retain the above copyright notice, +!! 1. Redistributions of source code must retain the above copyright notice, !! this list of conditions and the following disclaimer. -!! 2. Redistributions in binary form must reproduce the above copyright notice, -!! this list of conditions and the following disclaimer in the documentation +!! 2. Redistributions in binary form must reproduce the above copyright notice, +!! this list of conditions and the following disclaimer in the documentation !! and/or other materials provided with the distribution. !! 3. Neither the name of the copyright holder nor the names of its contributors -!! may be used to endorse or promote products derived from this software +!! may be used to endorse or promote products derived from this software !! without specific prior written permission. !! -!! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" -!! AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +!! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +!! AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE !! IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE -!! ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE -!! LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +!! ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE +!! LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR !! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF !! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -!! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +!! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN !! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) !! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE !! POSSIBILITY OF SUCH DAMAGE.[7] -!! +!! !! !! ----------------------------------------------------------------------------- !! ----------------------------------------------------------------------------- @@ -46,342 +46,341 @@ !! - mean sinking velocity of aggregates !! !! See: -!! Maerz et al. 2020: Microstructure and composition of marine aggregates -!! as co-determinants for vertical particulate organic -!! carbon transfer in the global ocean. -!! Biogeosciences, 17, 1765-1803, +!! Maerz et al. 2020: Microstructure and composition of marine aggregates +!! as co-determinants for vertical particulate organic +!! carbon transfer in the global ocean. +!! Biogeosciences, 17, 1765-1803, !! https://doi.org/10.5194/bg-17-1765-2020 !! -!! This module is written within the project: +!! This module is written within the project: !! Multiscale Approach on the Role of Marine Aggregates (MARMA) !! funded by the Max Planck Society (MPG) !! !! @author: joeran maerz (joeran.maerz@mpimet.mpg.de), MPI-M, HH !! 2019, June, revised by Irene Stemmler (refactoring, cleaning), MPI-M, HH !! -!! 2023 adopted to iHAMOCC by joeran maerz, UiB, Bergen +!! 2023 adopted to iHAMOCC by joeran maerz, UiB, Bergen !! !! ----------------------------------------------------------------------------- !! ----------------------------------------------------------------------------- -!! +!! !! -MODULE mo_m4ago - USE mo_vgrid, ONLY: dp_min - USE mo_control_bgc, ONLY: dtb, dtbgc,io_stdo_bgc - USE mo_param_bgc, ONLY: calcdens, claydens, opaldens, calcwei, opalwei, ropal - USE mo_carbch, ONLY: ocetra - USE mo_param1_bgc, ONLY: iopal, ifdust, icalc, idet - - IMPLICIT NONE - - PRIVATE - - ! Public subroutines - PUBLIC :: mean_aggregate_sinking_speed, init_m4ago_nml_params, init_m4ago_params, alloc_mem_m4ago - - ! Public fields and parameters - PUBLIC :: ws_agg,& - & aggregate_diagnostics,kav_dp,kav_rho_p,kav_d_C,kws_agg,kdf_agg,kstickiness_agg,kb_agg,kstickiness_frustule, & - & kLmax_agg,kdynvis,kav_rhof_V,kav_por_V - - INTEGER :: i,j,k - - - ! model parameters - ! primary particle diameter for POM & PIM species involved in parametrized aggregation (m) - REAL :: dp_dust ! primary particle diameter dust - REAL :: dp_det ! primary particle diameter detritus - REAL :: dp_calc ! primary particle diameter calc - REAL :: dp_opal ! primary particle diameter opal - REAL :: stickiness_TEP ! stickiness of TEP (related to opal frustules) - REAL :: stickiness_det ! normal detritus stickiness - REAL :: stickiness_opal ! stickiness of opal (without TEP - just normal coating) - REAL :: stickiness_calc ! stickiness of calc particles (coated with organics) - REAL :: stickiness_dust ! stickiness of dust particles (coated with organics) - REAL :: agg_df_max ! maximum fractal dimension of aggregates (~2.5) - REAL :: agg_df_min ! minimum fractal dimension of aggregates (~1.2 - 1.6) - REAL :: rho_TEP ! density of TEP particles - REAL :: agg_org_dens ! organic detritus density (alternative to orgdens to avoid negative ws) - - REAL :: agg_Re_crit ! critical particle Reynolds number for nr-distribution limiting - REAL :: POM_remin_q10 ! Q10 factor for organic remineralization (POC) - REAL :: POM_remin_Tref - REAL :: opal_remin_q10 ! Q10 factor for silicate remineralization (OPAL) - REAL :: opal_remin_Tref - - REAL,ALLOCATABLE :: av_dp(:,:,:), & ! mean primary particle diameter - & av_rho_p(:,:,:), & ! mean primary particle density - & df_agg(:,:,:), & ! fractal dimension of aggregates - & b_agg(:,:,:), & ! aggregate number distribution slope - & Lmax_agg(:,:,:), & ! maximum diameter of aggregates - & ws_agg(:,:,:), & ! aggregate mean sinking velocity - & stickiness_agg(:,:,:), & ! mean aggregate stickiness - & stickiness_frustule(:,:,:),& ! frustule stickiness - & N_agg(:,:,:), & ! Number of aggregates - & av_d_C(:,:,:), & ! concentration-weighted mean diameter of aggs - & dyn_vis(:,:,:), & ! molecular dynamic viscosity - & m4ago_ppo(:,:,:) ! pressure - - INTEGER, PARAMETER :: & - kav_dp = 1, & - kav_rho_p = 2, & - kav_d_C = 3, & - kws_agg = 4, & - kdf_agg = 5, & - kstickiness_agg = 6, & - kb_agg = 7, & - kstickiness_frustule = 8, & - kLmax_agg = 9, & - kdynvis = 10, & - kav_rhof_V = 11, & - kav_por_V = 12, & - naggdiag = 12 - - REAL, DIMENSION (:,:,:,:), ALLOCATABLE, TARGET :: aggregate_diagnostics ! 3d concentration EU - - - - ! Internally used parameters and values - REAL, PARAMETER :: ONE_SIXTH = 1./6. - REAL, PARAMETER :: PI = 3.141592654 - REAL, PARAMETER :: NUM_FAC = 1.e9 ! factor to avoid numerical precision problems - REAL, PARAMETER :: EPS_ONE = EPSILON(1.) - - REAL :: det_mol2mass ! mol detritus P/m^3 to kg POM /m^3 (according to stoichiometry) - REAL :: AJ1, AJ2, AJ3, BJ1, BJ2, BJ3 ! constants for CD - REAL :: grav_acc_const ! gravitational acceleration constant - REAL :: rho_aq ! water reference density (1025 kg/m^3) - REAL :: n_det,n_opal,n_calc,n_dust ! total primary particle number (#) - REAL :: mf ! mass factor for aggregates - REAL :: V_dp_dust,V_dp_det,V_dp_calc,V_dp_opal ! volumes of primary particles (L^3) - REAL :: A_dp_dust,A_dp_det,A_dp_calc,A_dp_opal ! surface areas of primary particles (L^2) - REAL :: A_dust,A_det,A_calc,A_opal,A_total ! total surface area of primary particles per unit volume (L^2/L^3) - REAL :: stickiness_min, stickiness_max ! minimum and maximum stickiness of primary particles - REAL :: stickiness_mapped ! mapped mean stickiness of particles on range (0,1) - REAL :: df_slope ! slope for stickiness to fractal dimension mapping - REAL :: rho_V_dp_dust,rho_V_dp_det,rho_V_dp_calc ! rho_V_dp_opal ! mass of primary particles (M) - REAL :: V_det,V_opal,V_calc,V_dust,V_solid ! total volume of primary particles in a unit volume (L^3/L^3) - REAL :: Rm_SiP ! molar mass ratio opal (SiO_2) to POM - REAL :: thick_shell ! diatom frustule shell thickness (L) - REAL :: d_frustule_inner ! diameter of hollow part in diatom frustule (L) - REAL :: V_frustule_inner ! volume of hollow part in diatom frustule (L^3) - REAL :: V_frustule_opal ! volume of opal shell material (L^3) - REAL :: rho_V_frustule_opal ! mass of frustule material (M) - REAL :: cell_det_mass ! mass of detritus material in diatoms - REAL :: cell_pot_det_mass ! potential (max) mass detritus material in diatoms - REAL :: free_detritus ! freely available detritus mass outside the frustule - REAL :: V_POM_cell ! volume of POM in frustule - REAL :: V_aq ! volume of water space in frustule - REAL :: rho_frustule ! density of diatom frustule incl. opal, detritus and water - REAL :: rho_diatom ! density of either hollow frustule - - CONTAINS +module mo_m4ago + use mo_vgrid, only: dp_min + use mo_control_bgc, only: dtb, dtbgc,io_stdo_bgc + use mo_param_bgc, only: calcdens, claydens, opaldens, calcwei, opalwei, ropal + use mo_carbch, only: ocetra + use mo_param1_bgc, only: iopal, ifdust, icalc, idet + + implicit none + + private + + ! Public subroutines + public :: mean_aggregate_sinking_speed, init_m4ago_nml_params, init_m4ago_params, alloc_mem_m4ago + + ! Public fields and parameters + public :: ws_agg,& + & aggregate_diagnostics,kav_dp,kav_rho_p,kav_d_C,kws_agg,kdf_agg,kstickiness_agg,kb_agg, & + & kstickiness_frustule,kLmax_agg,kdynvis,kav_rhof_V,kav_por_V + + integer :: i,j,k + + + ! model parameters + ! primary particle diameter for POM & PIM species involved in parametrized aggregation (m) + real :: dp_dust ! primary particle diameter dust + real :: dp_det ! primary particle diameter detritus + real :: dp_calc ! primary particle diameter calc + real :: dp_opal ! primary particle diameter opal + real :: stickiness_TEP ! stickiness of TEP (related to opal frustules) + real :: stickiness_det ! normal detritus stickiness + real :: stickiness_opal ! stickiness of opal (without TEP - just normal coating) + real :: stickiness_calc ! stickiness of calc particles (coated with organics) + real :: stickiness_dust ! stickiness of dust particles (coated with organics) + real :: agg_df_max ! maximum fractal dimension of aggregates (~2.5) + real :: agg_df_min ! minimum fractal dimension of aggregates (~1.2 - 1.6) + real :: rho_TEP ! density of TEP particles + real :: agg_org_dens ! organic detritus density (alternative to orgdens to avoid negative ws) + + real :: agg_Re_crit ! critical particle Reynolds number for nr-distribution limiting + real :: POM_remin_q10 ! Q10 factor for organic remineralization (POC) + real :: POM_remin_Tref + real :: opal_remin_q10 ! Q10 factor for silicate remineralization (OPAL) + real :: opal_remin_Tref + + real,allocatable :: av_dp(:,:,:), & ! mean primary particle diameter + & av_rho_p(:,:,:), & ! mean primary particle density + & df_agg(:,:,:), & ! fractal dimension of aggregates + & b_agg(:,:,:), & ! aggregate number distribution slope + & Lmax_agg(:,:,:), & ! maximum diameter of aggregates + & ws_agg(:,:,:), & ! aggregate mean sinking velocity + & stickiness_agg(:,:,:), & ! mean aggregate stickiness + & stickiness_frustule(:,:,:),& ! frustule stickiness + & N_agg(:,:,:), & ! Number of aggregates + & av_d_C(:,:,:), & ! concentration-weighted mean diameter of aggs + & dyn_vis(:,:,:), & ! molecular dynamic viscosity + & m4ago_ppo(:,:,:) ! pressure + + integer, parameter :: & + kav_dp = 1, & + kav_rho_p = 2, & + kav_d_C = 3, & + kws_agg = 4, & + kdf_agg = 5, & + kstickiness_agg = 6, & + kb_agg = 7, & + kstickiness_frustule = 8, & + kLmax_agg = 9, & + kdynvis = 10, & + kav_rhof_V = 11, & + kav_por_V = 12, & + naggdiag = 12 + + real, dimension (:,:,:,:), allocatable, target :: aggregate_diagnostics ! 3d concentration EU + + + + ! Internally used parameters and values + real, parameter :: ONE_SIXTH = 1./6. + real, parameter :: PI = 3.141592654 + real, parameter :: NUM_FAC = 1.e9 ! factor to avoid numerical precision problems + real, parameter :: EPS_ONE = EPSILON(1.) + + real :: det_mol2mass ! mol detritus P/m^3 to kg POM /m^3 (according to stoichiometry) + real :: AJ1, AJ2, AJ3, BJ1, BJ2, BJ3 ! constants for CD + real :: grav_acc_const ! gravitational acceleration constant + real :: rho_aq ! water reference density (1025 kg/m^3) + real :: n_det,n_opal,n_calc,n_dust ! total primary particle number (#) + real :: mf ! mass factor for aggregates + real :: V_dp_dust,V_dp_det,V_dp_calc,V_dp_opal ! volumes of primary particles (L^3) + real :: A_dp_dust,A_dp_det,A_dp_calc,A_dp_opal ! surface areas of primary particles (L^2) + real :: A_dust,A_det,A_calc,A_opal,A_total ! total surface area of primary particles per unit volume (L^2/L^3) + real :: stickiness_min, stickiness_max ! minimum and maximum stickiness of primary particles + real :: stickiness_mapped ! mapped mean stickiness of particles on range (0,1) + real :: df_slope ! slope for stickiness to fractal dimension mapping + real :: rho_V_dp_dust,rho_V_dp_det,rho_V_dp_calc ! rho_V_dp_opal ! mass of primary particles (M) + real :: V_det,V_opal,V_calc,V_dust,V_solid ! total volume of primary particles in a unit volume (L^3/L^3) + real :: Rm_SiP ! molar mass ratio opal (SiO_2) to POM + real :: thick_shell ! diatom frustule shell thickness (L) + real :: d_frustule_inner ! diameter of hollow part in diatom frustule (L) + real :: V_frustule_inner ! volume of hollow part in diatom frustule (L^3) + real :: V_frustule_opal ! volume of opal shell material (L^3) + real :: rho_V_frustule_opal ! mass of frustule material (M) + real :: cell_det_mass ! mass of detritus material in diatoms + real :: cell_pot_det_mass ! potential (max) mass detritus material in diatoms + real :: free_detritus ! freely available detritus mass outside the frustule + real :: V_POM_cell ! volume of POM in frustule + real :: V_aq ! volume of water space in frustule + real :: rho_frustule ! density of diatom frustule incl. opal, detritus and water + real :: rho_diatom ! density of either hollow frustule + +contains !===================================================================================== m4ago_init_params - SUBROUTINE init_m4ago_nml_params - !> - !! Initialization of namelist parameters - !! - IMPLICIT NONE - ! Primary particle sizes - dp_dust = 2.e-6 ! following the classical HAMOCC parametrization - dp_det = 4.e-6 ! not well defined - dp_calc = 3.e-6 ! following Henderiks 2008, Henderiks & Pagani 2008 - dp_opal = 20.e-6 ! rough guestimate - literature search required - - ! Stickiness values - stickiness_TEP = 0.19 - stickiness_det = 0.1 - stickiness_opal = 0.08 - stickiness_calc = 0.09 - stickiness_dust = 0.07 - - ! minimum and maximum aggregate fractal dimension - agg_df_min = 1.6 - agg_df_max = 2.4 - - ! Density of primary particles - rho_TEP = 800. ! 700.-840. kg/m^3 Azetsu-Scott & Passow 2004 - agg_org_dens = 1100. ! detritus density - don't use orgdens to avoid negative ws - - agg_Re_crit = 20. ! critical particle Reynolds number for limiting nr-distribution - - END SUBROUTINE init_m4ago_nml_params - - SUBROUTINE init_m4ago_params - !> - !! Initilization of parameters - !! - - IMPLICIT NONE - det_mol2mass = 3166. ! mol detritus P/m^3 to kg POM /m^3 (according to stoichiometry) - grav_acc_const = 9.81 ! gravitational acceleration constant - rho_aq = 1025. ! water reference density (1025 kg/m^3) - - ! CD parameters (formula 16) - AJ1 = 24.00 - AJ2 = 29.03 - AJ3 = 14.15 - BJ1 = 1.0 - BJ2 = 0.871 - BJ3 = 0.547 - - V_dp_dust = ONE_SIXTH*PI*dp_dust**3.*NUM_FAC - V_dp_det = ONE_SIXTH*PI*dp_det**3.*NUM_FAC - V_dp_calc = ONE_SIXTH*PI*dp_calc**3.*NUM_FAC - V_dp_opal = ONE_SIXTH*PI*dp_opal**3.*NUM_FAC - A_dp_dust = PI*dp_dust**2.*NUM_FAC - A_dp_det = PI*dp_det**2.*NUM_FAC - A_dp_calc = PI*dp_calc**2.*NUM_FAC - A_dp_opal = PI*dp_opal**2.*NUM_FAC - - rho_V_dp_dust = V_dp_dust*claydens - rho_V_dp_det = V_dp_det*agg_org_dens - rho_V_dp_calc = V_dp_calc*calcdens - - Rm_SiP = ropal*opalwei/det_mol2mass - ! shell thickness - thick_shell = 0.5*dp_opal*(1. - (opaldens/(Rm_SiP*agg_org_dens+opaldens))**(1./3.)) - d_frustule_inner = dp_opal - 2.*thick_shell - ! volume of hollow part of frustule - V_frustule_inner = ONE_SIXTH* PI*d_frustule_inner**3.*NUM_FAC - ! volume of opal part of frustule - V_frustule_opal = ONE_SIXTH*PI*(dp_opal**3. - d_frustule_inner**3.)*NUM_FAC - rho_V_frustule_opal = V_frustule_opal*opaldens - - stickiness_min = MIN(stickiness_TEP, stickiness_det, stickiness_opal, stickiness_calc, stickiness_dust) - stickiness_max = MAX(stickiness_TEP, stickiness_det, stickiness_opal, stickiness_calc, stickiness_dust) - df_slope = LOG( agg_df_min / agg_df_max) - END SUBROUTINE init_m4ago_params - - - SUBROUTINE alloc_mem_m4ago(kpie, kpje, kpke) - !----------------------------------------------------------------------- - !> - !! Initialization/allocation fields - !! Called in ini_bgc after read_namelist - !! - - IMPLICIT NONE - - INTEGER, INTENT(in) :: kpie !< 1st REAL of model grid. - INTEGER, INTENT(in) :: kpje !< 2nd REAL of model grid. - INTEGER, INTENT(in) :: kpke !< 3rd (vertical) REAL of model grid. - - ! allocate memory space for aggregate properties - ALLOCATE(av_dp(kpie,kpje,kpke)) - ALLOCATE(av_rho_p(kpie,kpje,kpke)) - ALLOCATE(df_agg(kpie,kpje,kpke)) - ALLOCATE(b_agg(kpie,kpje,kpke)) - ALLOCATE(Lmax_agg(kpie,kpje,kpke)) - ALLOCATE(av_d_C(kpie,kpje,kpke)) - ALLOCATE(stickiness_agg(kpie,kpje,kpke)) - ALLOCATE(stickiness_frustule(kpie,kpje,kpke)) - ALLOCATE(aggregate_diagnostics(kpie, kpje, kpke, naggdiag)) - - ! mean sinking velocity - ALLOCATE(ws_agg(kpie,kpje,kpke)) - - ! molecular dynamic viscosity - ALLOCATE(dyn_vis(kpie, kpje, kpke)) - ALLOCATE(m4ago_ppo(kpie,kpje,kpke)) - - av_dp = 0. - av_rho_p = 0. - df_agg = 0. - b_agg = 0. - Lmax_agg = 0. - av_d_C = 0. - stickiness_agg = 0. - stickiness_frustule = 0. - aggregate_diagnostics = 0. - m4ago_ppo = 0. - - END SUBROUTINE alloc_mem_m4ago - - SUBROUTINE cleanup_mem_m4ago - - DEALLOCATE(av_dp) - DEALLOCATE(av_rho_p) - DEALLOCATE(df_agg) - DEALLOCATE(b_agg) - DEALLOCATE(Lmax_agg) - DEALLOCATE(av_d_C) - DEALLOCATE(stickiness_agg) - DEALLOCATE(stickiness_frustule) - DEALLOCATE(aggregate_diagnostics) - DEALLOCATE(ws_agg) - DEALLOCATE(dyn_vis) - DEALLOCATE(m4ago_ppo) - END SUBROUTINE cleanup_mem_m4ago + subroutine init_m4ago_nml_params + !> + !! Initialization of namelist parameters + !! + implicit none + ! Primary particle sizes + dp_dust = 2.e-6 ! following the classical HAMOCC parametrization + dp_det = 4.e-6 ! not well defined + dp_calc = 3.e-6 ! following Henderiks 2008, Henderiks & Pagani 2008 + dp_opal = 20.e-6 ! rough guestimate - literature search required + + ! Stickiness values + stickiness_TEP = 0.19 + stickiness_det = 0.1 + stickiness_opal = 0.08 + stickiness_calc = 0.09 + stickiness_dust = 0.07 + + ! minimum and maximum aggregate fractal dimension + agg_df_min = 1.6 + agg_df_max = 2.4 + + ! Density of primary particles + rho_TEP = 800. ! 700.-840. kg/m^3 Azetsu-Scott & Passow 2004 + agg_org_dens = 1100. ! detritus density - don't use orgdens to avoid negative ws + + agg_Re_crit = 20. ! critical particle Reynolds number for limiting nr-distribution + + end subroutine init_m4ago_nml_params + + subroutine init_m4ago_params + !> + !! Initilization of parameters + !! + + implicit none + det_mol2mass = 3166. ! mol detritus P/m^3 to kg POM /m^3 (according to stoichiometry) + grav_acc_const = 9.81 ! gravitational acceleration constant + rho_aq = 1025. ! water reference density (1025 kg/m^3) + + ! CD parameters (formula 16) + AJ1 = 24.00 + AJ2 = 29.03 + AJ3 = 14.15 + BJ1 = 1.0 + BJ2 = 0.871 + BJ3 = 0.547 + + V_dp_dust = ONE_SIXTH*PI*dp_dust**3.*NUM_FAC + V_dp_det = ONE_SIXTH*PI*dp_det**3.*NUM_FAC + V_dp_calc = ONE_SIXTH*PI*dp_calc**3.*NUM_FAC + V_dp_opal = ONE_SIXTH*PI*dp_opal**3.*NUM_FAC + A_dp_dust = PI*dp_dust**2.*NUM_FAC + A_dp_det = PI*dp_det**2.*NUM_FAC + A_dp_calc = PI*dp_calc**2.*NUM_FAC + A_dp_opal = PI*dp_opal**2.*NUM_FAC + + rho_V_dp_dust = V_dp_dust*claydens + rho_V_dp_det = V_dp_det*agg_org_dens + rho_V_dp_calc = V_dp_calc*calcdens + + Rm_SiP = ropal*opalwei/det_mol2mass + ! shell thickness + thick_shell = 0.5*dp_opal*(1. - (opaldens/(Rm_SiP*agg_org_dens+opaldens))**(1./3.)) + d_frustule_inner = dp_opal - 2.*thick_shell + ! volume of hollow part of frustule + V_frustule_inner = ONE_SIXTH* PI*d_frustule_inner**3.*NUM_FAC + ! volume of opal part of frustule + V_frustule_opal = ONE_SIXTH*PI*(dp_opal**3. - d_frustule_inner**3.)*NUM_FAC + rho_V_frustule_opal = V_frustule_opal*opaldens + + stickiness_min = min(stickiness_TEP, stickiness_det, stickiness_opal, stickiness_calc, stickiness_dust) + stickiness_max = max(stickiness_TEP, stickiness_det, stickiness_opal, stickiness_calc, stickiness_dust) + df_slope = log(agg_df_min / agg_df_max) + end subroutine init_m4ago_params + + + subroutine alloc_mem_m4ago(kpie, kpje, kpke) + !----------------------------------------------------------------------- + !> + !! Initialization/allocation fields + !! Called in ini_bgc after read_namelist + !! + + implicit none + + integer, intent(in) :: kpie !< 1st real of model grid. + integer, intent(in) :: kpje !< 2nd real of model grid. + integer, intent(in) :: kpke !< 3rd (vertical) real of model grid. + + ! allocate memory space for aggregate properties + allocate(av_dp(kpie,kpje,kpke)) + allocate(av_rho_p(kpie,kpje,kpke)) + allocate(df_agg(kpie,kpje,kpke)) + allocate(b_agg(kpie,kpje,kpke)) + allocate(Lmax_agg(kpie,kpje,kpke)) + allocate(av_d_C(kpie,kpje,kpke)) + allocate(stickiness_agg(kpie,kpje,kpke)) + allocate(stickiness_frustule(kpie,kpje,kpke)) + allocate(aggregate_diagnostics(kpie, kpje, kpke, naggdiag)) + + ! mean sinking velocity + allocate(ws_agg(kpie,kpje,kpke)) + + ! molecular dynamic viscosity + allocate(dyn_vis(kpie, kpje, kpke)) + allocate(m4ago_ppo(kpie,kpje,kpke)) + + av_dp = 0. + av_rho_p = 0. + df_agg = 0. + b_agg = 0. + Lmax_agg = 0. + av_d_C = 0. + stickiness_agg = 0. + stickiness_frustule = 0. + aggregate_diagnostics = 0. + m4ago_ppo = 0. + + end subroutine alloc_mem_m4ago + + subroutine cleanup_mem_m4ago + deallocate(av_dp) + deallocate(av_rho_p) + deallocate(df_agg) + deallocate(b_agg) + deallocate(Lmax_agg) + deallocate(av_d_C) + deallocate(stickiness_agg) + deallocate(stickiness_frustule) + deallocate(aggregate_diagnostics) + deallocate(ws_agg) + deallocate(dyn_vis) + deallocate(m4ago_ppo) + end subroutine cleanup_mem_m4ago !===================================================================================== pressure - SUBROUTINE calc_pressure(kpie, kpje, kpke,kbnd, pddpo,omask) + subroutine calc_pressure(kpie, kpje, kpke,kbnd, pddpo,omask) - use mo_vgrid, only: ptiestu + use mo_vgrid, only: ptiestu - IMPLICIT NONE + implicit none - INTEGER, INTENT(in) :: kpie !< 1st REAL of model grid. - INTEGER, INTENT(in) :: kpje !< 2nd REAL of model grid. - INTEGER, INTENT(in) :: kpke !< 3rd (vertical) REAL of model grid. - INTEGER, INTENT(in) :: kbnd - REAL, INTENT(in) :: pddpo(kpie,kpje,kpke) !< size of scalar grid cell (3rd dimension) [m] - REAL, INTENT(in) :: omask(kpie,kpje) !< mask + integer, intent(in) :: kpie !< 1st real of model grid. + integer, intent(in) :: kpje !< 2nd real of model grid. + integer, intent(in) :: kpke !< 3rd (vertical) real of model grid. + integer, intent(in) :: kbnd + real, intent(in) :: pddpo(kpie,kpje,kpke) !< size of scalar grid cell (3rd dimension) [m] + real, intent(in) :: omask(kpie,kpje) !< mask - !$OMP PARALLEL DO PRIVATE(i,j,k) - do k = 1,kpke - do j = 1,kpje - do i = 1,kpie - if(omask(i,j) > 0.5 .and. pddpo(i,j,k).gt.dp_min) then + !$OMP PARALLEL DO PRIVATE(i,j,k) + do k = 1,kpke + do j = 1,kpje + do i = 1,kpie + if(omask(i,j) > 0.5 .and. pddpo(i,j,k).gt.dp_min) then m4ago_ppo(i,j,k) = 1e5 * ptiestu(i,j,k)*98060.*1.027e-6 ! pressure in unit Pa, 98060 = onem - endif + endif + enddo enddo - enddo - enddo - !$OMP END PARALLEL DO - END SUBROUTINE calc_pressure + enddo + !$OMP END PARALLEL DO + end subroutine calc_pressure !===================================================================================== mean_agg_ws - SUBROUTINE mean_aggregate_sinking_speed(kpie, kpje, kpke, kbnd, pddpo, omask, ptho, psao, ppao, prho) - !----------------------------------------------------------------------- - !> - !! calculates the mass concentration-weighted mean sinking velocity of marine - !! aggregates - !! - - IMPLICIT NONE - - INTEGER, INTENT(in) :: kpie !< 1st REAL of model grid. - INTEGER, INTENT(in) :: kpje !< 2nd REAL of model grid. - INTEGER, INTENT(in) :: kpke !< 3rd (vertical) REAL of model grid. - INTEGER, INTENT(in) :: kbnd - REAL, INTENT(in) :: pddpo(kpie,kpje,kpke) !< size of scalar grid cell (3rd dimension) [m] - REAL, INTENT(in) :: omask(kpie,kpje) - REAL, INTENT(in) :: ptho (1-kbnd:kpie+kbnd,1-kbnd:kpje+kbnd,kpke) !< potential temperature [deg C] - REAL, INTENT(in) :: psao (1-kbnd:kpie+kbnd,1-kbnd:kpje+kbnd,kpke) !< salinity [psu.]. - REAL, INTENT(in) :: ppao (1-kbnd:kpie+kbnd,1-kbnd:kpje+kbnd) !< pressure at sea level [Pa]. - REAL, INTENT(in) :: prho (kpie,kpje,kpke) !< density [g/cm3] - - CALL calc_pressure(kpie, kpje, kpke,kbnd, pddpo, omask) - - ! molecular dynamic viscosity - CALL dynvis(kpie, kpje, kpke, kbnd, pddpo, omask, ptho, psao, m4ago_ppo) - - ! ======== calculate the mean sinking velocity of aggregates ======= - CALL aggregate_properties(kpie, kpje, kpke, kbnd, pddpo, omask, ptho) - CALL ws_Re_approx(kpie, kpje, kpke, pddpo, omask) - - !$OMP PARALLEL DO PRIVATE(i,j,k) - DO j = 1,kpje - DO i = 1,kpie - DO k = 1,kpke - IF(pddpo(i,j,k) > dp_min .and. omask(i,j) > 0.5) THEN + subroutine mean_aggregate_sinking_speed(kpie, kpje, kpke, kbnd, pddpo, omask, ptho, psao, ppao, prho) + !----------------------------------------------------------------------- + !> + !! calculates the mass concentration-weighted mean sinking velocity of marine + !! aggregates + !! + + implicit none + + integer, intent(in) :: kpie !< 1st real of model grid. + integer, intent(in) :: kpje !< 2nd real of model grid. + integer, intent(in) :: kpke !< 3rd (vertical) real of model grid. + integer, intent(in) :: kbnd + real, intent(in) :: pddpo(kpie,kpje,kpke) !< size of scalar grid cell (3rd dimension) [m] + real, intent(in) :: omask(kpie,kpje) + real, intent(in) :: ptho (1-kbnd:kpie+kbnd,1-kbnd:kpje+kbnd,kpke) !< potential temperature [deg C] + real, intent(in) :: psao (1-kbnd:kpie+kbnd,1-kbnd:kpje+kbnd,kpke) !< salinity [psu.]. + real, intent(in) :: ppao (1-kbnd:kpie+kbnd,1-kbnd:kpje+kbnd) !< pressure at sea level [Pa]. + real, intent(in) :: prho (kpie,kpje,kpke) !< density [g/cm3] + + call calc_pressure(kpie, kpje, kpke,kbnd, pddpo, omask) + + ! molecular dynamic viscosity + call dynvis(kpie, kpje, kpke, kbnd, pddpo, omask, ptho, psao, m4ago_ppo) + + ! ======== calculate the mean sinking velocity of aggregates ======= + call aggregate_properties(kpie, kpje, kpke, kbnd, pddpo, omask, ptho) + call ws_Re_approx(kpie, kpje, kpke, pddpo, omask) + + !$OMP PARALLEL DO PRIVATE(i,j,k) + do j = 1,kpje + do i = 1,kpie + do k = 1,kpke + if(pddpo(i,j,k) > dp_min .and. omask(i,j) > 0.5) then ! Limit settling velocity wrt CFL: - ws_agg(i,j,k) = MIN(ws_agg(i,j,k), 0.99*pddpo(i,j,k)) + ws_agg(i,j,k) = min(ws_agg(i,j,k), 0.99*pddpo(i,j,k)) ! ============================== Write general diagnostics ============ ! ----- settling velocity-related ----- @@ -402,10 +401,10 @@ SUBROUTINE mean_aggregate_sinking_speed(kpie, kpje, kpke, kbnd, pddpo, omask, pt aggregate_diagnostics(i,j,k,kstickiness_frustule) = stickiness_frustule(i,j,k) ! frustule stickiness aggregate_diagnostics(i,j,k,kLmax_agg) = Lmax_agg(i,j,k) ! applied max. diameter - aggregate_diagnostics(i,j,k,kav_dp) = av_dp(i,j,k) ! mean primary particle diameter - aggregate_diagnostics(i,j,k,kav_rho_p) = av_rho_p(i,j,k) ! mean primary particle density + aggregate_diagnostics(i,j,k,kav_dp) = av_dp(i,j,k) ! mean primary particle diameter + aggregate_diagnostics(i,j,k,kav_rho_p) = av_rho_p(i,j,k) ! mean primary particle density aggregate_diagnostics(i,j,k,kav_d_C) = av_d_C(i,j,k) ! conc-weighted mean agg. diameter - aggregate_diagnostics(i,j,k,kdf_agg) = df_agg(i,j,k) ! aggregate fractal dim + aggregate_diagnostics(i,j,k,kdf_agg) = df_agg(i,j,k) ! aggregate fractal dim aggregate_diagnostics(i,j,k,kb_agg) = b_agg(i,j,k) ! aggre number distr. slope ! volume-weighted aggregate density @@ -422,312 +421,316 @@ SUBROUTINE mean_aggregate_sinking_speed(kpie, kpje, kpke, kbnd, pddpo, omask, pt & - av_dp(i,j,k)**(1.+df_agg(i,j,k)-b_agg(i,j,k)))) & & / ((1.+df_agg(i,j,k)-b_agg(i,j,k)) & & *(Lmax_agg(i,j,k)**(4.-b_agg(i,j,k)) - av_dp(i,j,k)**(4.-b_agg(i,j,k)))) - END IF - END DO - END DO - END DO - - END SUBROUTINE mean_aggregate_sinking_speed + endif + enddo + enddo + enddo + end subroutine mean_aggregate_sinking_speed !===================================================================================== aggregate_properties - SUBROUTINE aggregate_properties(kpie, kpje, kpke, kbnd, pddpo, omask, ptho) - !----------------------------------------------------------------------- - !> - !! aggregate_properties calculates - !! - mean stickiness/aggrega - !! - fractal dimension - !! - slope of aggregate spectrum - !! - mean primary particle diameter - !! - mean primary particle density - !! - maximum aggregate diameter - !! - - IMPLICIT NONE - - INTEGER, INTENT(in) :: kpie !< 1st REAL of model grid. - INTEGER, INTENT(in) :: kpje !< 2nd REAL of model grid. - INTEGER, INTENT(in) :: kpke !< 3rd (vertical) REAL of model grid. - INTEGER, INTENT(in) :: kbnd - REAL, INTENT(in) :: pddpo(kpie,kpje,kpke) !< size of scalar grid cell (3rd dimension) [m] - REAL, INTENT(in) :: omask(kpie,kpje) - REAL, INTENT(in) :: ptho (1-kbnd:kpie+kbnd,1-kbnd:kpje+kbnd,kpke) !< potential temperature [deg C] - - REAL :: C_det,C_opal,C_calc,C_dust - !$OMP PARALLEL DO PRIVATE(i,j,k,C_det,C_opal,C_calc,C_dust,n_det,n_opal,n_dust,n_calc,mf,V_det,V_opal,V_calc,V_dust,V_solid, & - !$OMP free_detritus,rho_diatom,cell_det_mass,cell_pot_det_mass,V_POM_cell,V_aq,rho_frustule,A_det,A_opal, & - !$OMP A_calc,A_dust,A_total,stickiness_mapped) - DO j = 1,kpje - DO i = 1,kpie - DO k = 1,kpke - IF(pddpo(i,j,k) > dp_min .and. omask(i,j) > 0.5) THEN - C_det = 0. - C_opal = 0. - C_calc = 0. - C_dust = 0. - - C_det = ABS(ocetra(i,j,k,idet)) - C_opal = ABS(ocetra(i,j,k,iopal)) - C_calc = ABS(ocetra(i,j,k,icalc)) - C_dust = ABS(ocetra(i,j,k,ifdust)) - - n_det = 0. ! number of primary particles - n_opal = 0. - n_dust = 0. - n_calc = 0. - mf = 0. - - V_det = 0. ! total volume of primary particles in a unit volume - V_opal = 0. - V_calc = 0. - V_dust = 0. - V_solid = 0. - - free_detritus = 0. - rho_diatom = 0. - ! n_det are detritus primary particle that are - ! NOT linked to any diatom frustule - ! n_opal are number of frustule-like primary particles possessing - ! a density i) different from pure opal ii) due to a mixture of - ! opal frustule, detritus inside the frustule and potentially water - ! inside the frustule - - ! describing diatom frustule as hollow sphere - ! that is completely or partially filled with detritus - ! and water - cell_det_mass = 0. - cell_pot_det_mass = 0. - V_POM_cell = 0. - V_aq = 0. - rho_frustule = 0. - - ! number of opal frustules (/NUM_FAC) - n_opal = C_opal*opalwei/rho_V_frustule_opal - ! maximum mass of detritus inside a frustule - cell_pot_det_mass = n_opal*V_frustule_inner*agg_org_dens - - ! detritus mass inside frustules - cell_det_mass = MIN(cell_pot_det_mass, C_det*det_mol2mass - EPS_ONE) - - ! volume of detritus component in cell - V_POM_cell = (cell_det_mass/n_opal)/agg_org_dens - - ! if not detritus is available, water is added - V_aq = V_frustule_inner - V_POM_cell - - ! density of the diatom frsutules incl. opal, detritus and water - rho_frustule = (rho_V_frustule_opal + cell_det_mass/n_opal + V_aq*rho_aq)/V_dp_opal - - ! mass of extra cellular detritus particles - free_detritus = C_det*det_mol2mass - cell_det_mass - rho_diatom = (rho_frustule + cell_det_mass/cell_pot_det_mass*rho_TEP) & + subroutine aggregate_properties(kpie, kpje, kpke, kbnd, pddpo, omask, ptho) + !----------------------------------------------------------------------- + !> + !! aggregate_properties calculates + !! - mean stickiness/aggrega + !! - fractal dimension + !! - slope of aggregate spectrum + !! - mean primary particle diameter + !! - mean primary particle density + !! - maximum aggregate diameter + !! + + implicit none + + integer, intent(in) :: kpie !< 1st real of model grid. + integer, intent(in) :: kpje !< 2nd real of model grid. + integer, intent(in) :: kpke !< 3rd (vertical) real of model grid. + integer, intent(in) :: kbnd + real, intent(in) :: pddpo(kpie,kpje,kpke) !< size of scalar grid cell (3rd dimension) [m] + real, intent(in) :: omask(kpie,kpje) + real, intent(in) :: ptho (1-kbnd:kpie+kbnd,1-kbnd:kpje+kbnd,kpke) !< potential temperature [deg C] + + real :: C_det,C_opal,C_calc,C_dust + !$OMP PARALLEL DO PRIVATE(i,j,k,C_det,C_opal,C_calc,C_dust,n_det,n_opal,n_dust,n_calc,mf,V_det,& + !$OMP V_opal,V_calc,V_dust,V_solid,free_detritus,rho_diatom,cell_det_mass, & + !$OMP cell_pot_det_mass,V_POM_cell,V_aq,rho_frustule,A_det,A_opal, & + !$OMP A_calc,A_dust,A_total,stickiness_mapped) + do j = 1,kpje + do i = 1,kpie + do k = 1,kpke + if(pddpo(i,j,k) > dp_min .and. omask(i,j) > 0.5) then + C_det = 0. + C_opal = 0. + C_calc = 0. + C_dust = 0. + + C_det = abs(ocetra(i,j,k,idet)) + C_opal = abs(ocetra(i,j,k,iopal)) + C_calc = abs(ocetra(i,j,k,icalc)) + C_dust = abs(ocetra(i,j,k,ifdust)) + + n_det = 0. ! number of primary particles + n_opal = 0. + n_dust = 0. + n_calc = 0. + mf = 0. + + V_det = 0. ! total volume of primary particles in a unit volume + V_opal = 0. + V_calc = 0. + V_dust = 0. + V_solid = 0. + + free_detritus = 0. + rho_diatom = 0. + ! n_det are detritus primary particle that are + ! NOT linked to any diatom frustule + ! n_opal are number of frustule-like primary particles possessing + ! a density i) different from pure opal ii) due to a mixture of + ! opal frustule, detritus inside the frustule and potentially water + ! inside the frustule + + ! describing diatom frustule as hollow sphere + ! that is completely or partially filled with detritus + ! and water + cell_det_mass = 0. + cell_pot_det_mass = 0. + V_POM_cell = 0. + V_aq = 0. + rho_frustule = 0. + + ! number of opal frustules (/NUM_FAC) + n_opal = C_opal*opalwei/rho_V_frustule_opal + ! maximum mass of detritus inside a frustule + cell_pot_det_mass = n_opal*V_frustule_inner*agg_org_dens + + ! detritus mass inside frustules + cell_det_mass = min(cell_pot_det_mass, C_det*det_mol2mass - EPS_ONE) + + ! volume of detritus component in cell + V_POM_cell = (cell_det_mass/n_opal)/agg_org_dens + + ! if not detritus is available, water is added + V_aq = V_frustule_inner - V_POM_cell + + ! density of the diatom frsutules incl. opal, detritus and water + rho_frustule = (rho_V_frustule_opal + cell_det_mass/n_opal + V_aq*rho_aq)/V_dp_opal + + ! mass of extra cellular detritus particles + free_detritus = C_det*det_mol2mass - cell_det_mass + rho_diatom = (rho_frustule + cell_det_mass/cell_pot_det_mass*rho_TEP) & /(1. + cell_det_mass/cell_pot_det_mass) - ! number of primary particles - n_det = free_detritus/rho_V_dp_det ! includes NUM_FAC - n_calc = C_calc*calcwei/rho_V_dp_calc - n_dust = C_dust/rho_V_dp_dust ! dust is in kg/m3 - - ! primary particles surface weighted stickiness is mapped - ! on range between 0 and 1 - ! fractal dimension of aggregates is based on that mapped df - ! number distribution slope b is based on df - - ! calc total areas - A_det = n_det*A_dp_det - A_opal = n_opal*A_dp_opal - A_calc = n_calc*A_dp_calc - A_dust = n_dust*A_dp_dust - A_total = A_det + A_opal + A_calc + A_dust - - ! calc frustule stickiness - stickiness_frustule(i,j,k) = cell_det_mass/(cell_pot_det_mass + EPS_ONE)*stickiness_TEP & - & + (1. - cell_det_mass/(cell_pot_det_mass + EPS_ONE))*stickiness_opal - - ! calc mean stickiness - stickiness_agg(i,j,k) = stickiness_frustule(i,j,k)*A_opal & - & + stickiness_det*A_det & - & + stickiness_calc*A_calc & - & + stickiness_dust*A_dust - - stickiness_agg(i,j,k) = stickiness_agg(i,j,k)/(A_total+EPS_ONE) - - stickiness_mapped = (stickiness_agg(i,j,k) - stickiness_min) & + ! number of primary particles + n_det = free_detritus/rho_V_dp_det ! includes NUM_FAC + n_calc = C_calc*calcwei/rho_V_dp_calc + n_dust = C_dust/rho_V_dp_dust ! dust is in kg/m3 + + ! primary particles surface weighted stickiness is mapped + ! on range between 0 and 1 + ! fractal dimension of aggregates is based on that mapped df + ! number distribution slope b is based on df + + ! calc total areas + A_det = n_det*A_dp_det + A_opal = n_opal*A_dp_opal + A_calc = n_calc*A_dp_calc + A_dust = n_dust*A_dp_dust + A_total = A_det + A_opal + A_calc + A_dust + + ! calc frustule stickiness + stickiness_frustule(i,j,k) = cell_det_mass/(cell_pot_det_mass +EPS_ONE)*stickiness_TEP & + & + (1. - cell_det_mass/(cell_pot_det_mass + EPS_ONE)) & + & *stickiness_opal + + ! calc mean stickiness + stickiness_agg(i,j,k) = stickiness_frustule(i,j,k)*A_opal & + & + stickiness_det*A_det & + & + stickiness_calc*A_calc & + & + stickiness_dust*A_dust + + stickiness_agg(i,j,k) = stickiness_agg(i,j,k)/(A_total+EPS_ONE) + + stickiness_mapped = (stickiness_agg(i,j,k) - stickiness_min) & & /(stickiness_max - stickiness_min) - df_agg(i,j,k) = agg_df_max*EXP(df_slope*stickiness_mapped) - - ! Slope is here positive defined (as n(d)~d^-b), so *-1 of - ! Jiang & Logan 1991: Fractal dimensions of aggregates - ! determined from steady-state size distributions. - ! Environ. Sci. Technol. 25, 2031-2038. - ! - ! See also: - ! Hunt 1980: Prediction of oceanic particle size distributions - ! from coagulation and sedimentation mechanisms. - ! - ! Additional assumptions made here: - ! b in Jiang & Logan (used for Re < 0.1: b=1 - ! for 0.1 < Re < 10 : b=0.871 - ! for 10 < Re < 100 : b=0.547) - ! is set to 0.871 as an 'average for our range of 0 Formulation in Jiang & Logan 1991: - ! slope = -0.5*(3+df+(2+df-D2)/(2-b)) reduces to: - - b_agg(i,j,k) = 0.5*(3. + df_agg(i,j,k) & - & + (2. + df_agg(i,j,k) - MIN(2., df_agg(i,j,k)))/(2. - BJ2)) - - ! careful: for df=1.5904: b_agg=2*df where w_s is undefined. - - ! total volume of primary particles - V_det = n_det*V_dp_det*NUM_FAC - V_opal = n_opal*V_dp_opal*NUM_FAC - V_calc = n_calc*V_dp_calc*NUM_FAC - V_dust = n_dust*V_dp_dust*NUM_FAC - V_solid = V_det + V_opal + V_calc + V_dust + df_agg(i,j,k) = agg_df_max*exp(df_slope*stickiness_mapped) + + ! Slope is here positive defined (as n(d)~d^-b), so *-1 of + ! Jiang & Logan 1991: Fractal dimensions of aggregates + ! determined from steady-state size distributions. + ! Environ. Sci. Technol. 25, 2031-2038. + ! + ! See also: + ! Hunt 1980: Prediction of oceanic particle size distributions + ! from coagulation and sedimentation mechanisms. + ! + ! Additional assumptions made here: + ! b in Jiang & Logan (used for Re < 0.1: b=1 + ! for 0.1 < Re < 10 : b=0.871 + ! for 10 < Re < 100 : b=0.547) + ! is set to 0.871 as an 'average for our range of 0 Formulation in Jiang & Logan 1991: + ! slope = -0.5*(3+df+(2+df-D2)/(2-b)) reduces to: + + b_agg(i,j,k) = 0.5*(3. + df_agg(i,j,k) & + & + (2. + df_agg(i,j,k) - min(2., df_agg(i,j,k)))/(2. - BJ2)) - ! primary particle mean diameter according to Bushell & Amal 1998, 2000 - ! sum(n_i) not changing - can be pulled out and thus cancels out - av_dp(i,j,k) = (n_calc*dp_calc**3. + n_dust*dp_dust**3. + n_opal*dp_opal**3. + n_det*dp_det**3.) - av_dp(i,j,k) = av_dp(i,j,k)/(n_calc*dp_calc**df_agg(i,j,k) + n_dust*dp_dust**df_agg(i,j,k) & - & + n_opal*dp_opal**df_agg(i,j,k) + n_det*dp_det**df_agg(i,j,k)) - av_dp(i,j,k) = av_dp(i,j,k)**(1./(3. - df_agg(i,j,k))) - - ! density of mean primary particles - av_rho_p(i,j,k) = (V_det*agg_org_dens + V_opal*rho_diatom + V_calc*calcdens + V_dust*claydens)/V_solid - END IF - END DO - END DO - END DO - !$OMP END PARALLEL DO + ! careful: for df=1.5904: b_agg=2*df where w_s is undefined. + + ! total volume of primary particles + V_det = n_det*V_dp_det*NUM_FAC + V_opal = n_opal*V_dp_opal*NUM_FAC + V_calc = n_calc*V_dp_calc*NUM_FAC + V_dust = n_dust*V_dp_dust*NUM_FAC + V_solid = V_det + V_opal + V_calc + V_dust - ! calculate the maximum diameter of aggregates based on agg props - CALL max_agg_diam(kpie, kpje, kpke, pddpo, omask) + ! primary particle mean diameter according to Bushell & Amal 1998, 2000 + ! sum(n_i) not changing - can be pulled out and thus cancels out + av_dp(i,j,k) = (n_calc*dp_calc**3. + n_dust*dp_dust**3. + n_opal*dp_opal**3. & + & + n_det*dp_det**3.) + av_dp(i,j,k) = av_dp(i,j,k)/(n_calc*dp_calc**df_agg(i,j,k) & + & + n_dust*dp_dust**df_agg(i,j,k) & + & + n_opal*dp_opal**df_agg(i,j,k) + n_det*dp_det**df_agg(i,j,k)) + av_dp(i,j,k) = av_dp(i,j,k)**(1./(3. - df_agg(i,j,k))) + + ! density of mean primary particles + av_rho_p(i,j,k) = (V_det*agg_org_dens + V_opal*rho_diatom + V_calc*calcdens & + & + V_dust*claydens)/V_solid + endif + enddo + enddo + enddo + !$OMP END PARALLEL DO + + ! calculate the maximum diameter of aggregates based on agg props + call max_agg_diam(kpie, kpje, kpke, pddpo, omask) + + end subroutine aggregate_properties - END SUBROUTINE aggregate_properties - !================================== Reynolds number based on diameter - REAL FUNCTION Re_fun(ws,d,mu,rho) - !----------------------------------------------------------------------- - !> - !! Reynolds number for settling particles - !! - - IMPLICIT NONE - - REAL,INTENT(in) :: ws,d,mu,rho + real function Re_fun(ws,d,mu,rho) + !----------------------------------------------------------------------- + !> + !! Reynolds number for settling particles + !! - Re_fun = ABS(ws*d*rho/mu) - - END FUNCTION Re_fun + implicit none + + real,intent(in) :: ws,d,mu,rho + + Re_fun = abs(ws*d*rho/mu) + + end function Re_fun !================================================================================================== !===================================================================================== ws_Re_approx - SUBROUTINE ws_Re_approx(kpie, kpje, kpke, pddpo, omask) - !----------------------------------------------------------------------- - !> - !! ws_Re_approx: distribution integrated to Lmax (Re crit dependent maximum agg size) - !! Renolds number-dependent sinking velocity. - !! Approximation for c_D-value taken from Jiang & Logan 1991: - !! c_D=a*Re^-b - !! - - IMPLICIT NONE - - INTEGER, INTENT(in) :: kpie !< 1st REAL of model grid. - INTEGER, INTENT(in) :: kpje !< 2nd REAL of model grid. - INTEGER, INTENT(in) :: kpke !< 3rd (vertical) REAL of model grid. - REAL, INTENT(in) :: pddpo(kpie,kpje,kpke) !< size of scalar grid cell (3rd dimension) [m] - REAL, INTENT(in) :: omask(kpie,kpje) - - !$OMP PARALLEL DO PRIVATE(i,j,k) - DO j = 1,kpje - DO i = 1,kpie - DO k = 1,kpke - IF(pddpo(i,j,k) > dp_min .and. omask(i,j) > 0.5) THEN + subroutine ws_Re_approx(kpie, kpje, kpke, pddpo, omask) + !----------------------------------------------------------------------- + !> + !! ws_Re_approx: distribution integrated to Lmax (Re crit dependent maximum agg size) + !! Renolds number-dependent sinking velocity. + !! Approximation for c_D-value taken from Jiang & Logan 1991: + !! c_D=a*Re^-b + !! + + implicit none + + integer, intent(in) :: kpie !< 1st real of model grid. + integer, intent(in) :: kpje !< 2nd real of model grid. + integer, intent(in) :: kpke !< 3rd (vertical) real of model grid. + real, intent(in) :: pddpo(kpie,kpje,kpke) !< size of scalar grid cell (3rd dimension) [m] + real, intent(in) :: omask(kpie,kpje) + + !$OMP PARALLEL DO PRIVATE(i,j,k) + do j = 1,kpje + do i = 1,kpie + do k = 1,kpke + if(pddpo(i,j,k) > dp_min .and. omask(i,j) > 0.5) then ws_agg(i,j,k) = ws_Re(i,j,k,Lmax_agg(i,j,k)) - END IF - END DO - END DO - END DO - !$OMP END PARALLEL DO - - END SUBROUTINE ws_Re_approx - - REAL FUNCTION get_dRe(i, j, k, AJ, BJ, Re) - IMPLICIT NONE - ! Arguments - INTEGER, INTENT(in) :: i !< 1st REAL of model grid. - INTEGER, INTENT(in) :: j !< 2nd REAL of model grid. - INTEGER, INTENT(in) :: k !< 3rd (vertical) REAL of model grid. - REAL, INTENT(in) :: AJ - REAL, INTENT(in) :: BJ - REAL, INTENT(in) :: Re - + endif + enddo + enddo + enddo + !$OMP END PARALLEL DO + + end subroutine ws_Re_approx + + real function get_dRe(i, j, k, AJ, BJ, Re) + implicit none + ! Arguments + integer, intent(in) :: i !< 1st real of model grid. + integer, intent(in) :: j !< 2nd real of model grid. + integer, intent(in) :: k !< 3rd (vertical) real of model grid. + real, intent(in) :: AJ + real, intent(in) :: BJ + real, intent(in) :: Re + ! Local variables - REAL :: nu_vis - - nu_vis = dyn_vis(i,j,k)/rho_aq + real :: nu_vis + + nu_vis = dyn_vis(i,j,k)/rho_aq get_dRe = (Re*nu_vis)**((2. - BJ)/df_agg(i,j,k))/(4./3.*(av_rho_p(i,j,k) - rho_aq)/rho_aq & *av_dp(i,j,k)**(3. - df_agg(i,j,k))*grav_acc_const/(AJ*nu_vis**(BJ)))**(1./df_agg(i,j,k)) - END FUNCTION get_dRe - - REAL FUNCTION get_ws_agg_integral(i, j, k, AJ, BJ, lower_bound, upper_bound) - IMPLICIT NONE - - INTEGER, INTENT(in) :: i !< 1st REAL of model grid. - INTEGER, INTENT(in) :: j !< 2nd REAL of model grid. - INTEGER, INTENT(in) :: k !< 3rd (vertical) REAL of model grid. - - REAL, INTENT(in) :: AJ - REAL, INTENT(in) :: BJ - REAL, INTENT(in) :: upper_bound - REAL, INTENT(in) :: lower_bound - + end function get_dRe + + real function get_ws_agg_integral(i, j, k, AJ, BJ, lower_bound, upper_bound) + implicit none + + integer, intent(in) :: i !< 1st real of model grid. + integer, intent(in) :: j !< 2nd real of model grid. + integer, intent(in) :: k !< 3rd (vertical) real of model grid. + + real, intent(in) :: AJ + real, intent(in) :: BJ + real, intent(in) :: upper_bound + real, intent(in) :: lower_bound + ! Local variables - REAL :: nu_vis - - nu_vis = dyn_vis(i,j,k)/rho_aq - get_ws_agg_integral = (4./3.*(av_rho_p(i,j,k) - rho_aq)/rho_aq & - & *av_dp(i,j,k)**(3. - df_agg(i,j,k))*grav_acc_const & - & /(AJ*nu_vis**BJ))**(1./(2. - BJ)) & - & *(upper_bound**(1. - b_agg(i,j,k) + df_agg(i,j,k) & - & + (BJ + df_agg(i,j,k) - 2.)/(2. - BJ)) & - & /(1. - b_agg(i,j,k) + df_agg(i,j,k) + (BJ + df_agg(i,j,k) - 2.)/(2. - BJ)) & - & - lower_bound**(1. - b_agg(i,j,k) + df_agg(i,j,k) + (BJ + df_agg(i,j,k) - 2.) & - & /(2. - BJ)) & + real :: nu_vis + + nu_vis = dyn_vis(i,j,k)/rho_aq + get_ws_agg_integral = (4./3.*(av_rho_p(i,j,k) - rho_aq)/rho_aq & + & *av_dp(i,j,k)**(3. - df_agg(i,j,k))*grav_acc_const & + & /(AJ*nu_vis**BJ))**(1./(2. - BJ)) & + & *(upper_bound**(1. - b_agg(i,j,k) + df_agg(i,j,k) & + & + (BJ + df_agg(i,j,k) - 2.)/(2. - BJ)) & + & /(1. - b_agg(i,j,k) + df_agg(i,j,k) + (BJ + df_agg(i,j,k) - 2.)/(2. - BJ)) & + & - lower_bound**(1. - b_agg(i,j,k) + df_agg(i,j,k) + (BJ + df_agg(i,j,k) -2.)& + & /(2. - BJ)) & & /(1. - b_agg(i,j,k) + df_agg(i,j,k) + (BJ + df_agg(i,j,k) - 2.)/(2. - BJ))) - - END FUNCTION get_ws_agg_integral - + + end function get_ws_agg_integral + !===================================================================================== ws_Re - REAL FUNCTION ws_Re(i,j,k,dmax_agg) + real function ws_Re(i,j,k,dmax_agg) !----------------------------------------------------------------------- !> !! ws_Re: distribution integrated to Lmax (Re crit dependent maximum agg size) - !! Reynolds number-dependent sinking velocity. + !! Reynolds number-dependent sinking velocity. !! Approximation for c_D-value taken from Jiang & Logan 1991: !! c_D=a*Re^-b !! written in such a way that we check the critical Reynolds !! number (in case that we extend the maximum size by shear- - !! driven break-up). - !! + !! driven break-up). + !! - IMPLICIT NONE + implicit none - INTEGER, INTENT(in) :: i !< 1st REAL of model grid. - INTEGER, INTENT(in) :: j !< 2nd REAL of model grid. - INTEGER, INTENT(in) :: k !< 3rd (vertical) REAL of model grid. - REAL, INTENT(in) :: dmax_agg + integer, intent(in) :: i !< 1st real of model grid. + integer, intent(in) :: j !< 2nd real of model grid. + integer, intent(in) :: k !< 3rd (vertical) real of model grid. + real, intent(in) :: dmax_agg ! Local - REAL :: d_Re01, d_Re10, d_low, ws_agg_ints + real :: d_Re01, d_Re10, d_low, ws_agg_ints ! for Re-dependent, it should always be agg_Re_crit>10 ! for shear-driven break-up, check against integration bounds @@ -736,32 +739,32 @@ REAL FUNCTION ws_Re(i,j,k,dmax_agg) d_Re01 = get_dRe(i,j,k, AJ1, BJ1, 0.1) ! Re=10 d_Re10 = get_dRe(i,j,k, AJ2, BJ2, 10.) - d_low = av_dp(i,j,k) + d_low = av_dp(i,j,k) ws_agg_ints = 0. - IF(dmax_agg >= d_Re01)THEN ! Re > 0.1 + if(dmax_agg >= d_Re01)then ! Re > 0.1 ! - collect full range up to ! 0.1, (dp->d_Re1) and set lower bound to ! Re=0.1 val ! aj=AJ1, bj=1 ws_agg_ints = get_ws_agg_integral(i, j, k, AJ1, BJ1, av_dp(i,j,k), d_Re01) d_low = d_Re01 - ENDIF + endif - IF(dmax_agg >= d_Re10)THEN ! Re > 10 + if(dmax_agg >= d_Re10)then ! Re > 10 ! - collect full range Re=0.1-10 (d_Re1-> d_Re2) ! and set lower bound to ! Re=10 val ! aj=AJ2, bj=0.871 ws_agg_ints = ws_agg_ints + get_ws_agg_integral(i, j, k, AJ2, BJ2, d_Re01, d_Re10) d_low = d_Re10 - ENDIF + endif - IF(d_low < d_Re01)THEN ! Re<0.1 and Lmax < d_Re1 + if(d_low < d_Re01)then ! Re<0.1 and Lmax < d_Re1 ws_agg_ints = get_ws_agg_integral(i, j, k, AJ1, BJ1, av_dp(i,j,k), dmax_agg) - ELSE ! Re > 10, aj=AJ3, bj=BJ3 - ws_agg_ints = ws_agg_ints + get_ws_agg_integral(i, j, k, AJ3, BJ3, d_low, dmax_agg) - ENDIF + else ! Re > 10, aj=AJ3, bj=BJ3 + ws_agg_ints = ws_agg_ints + get_ws_agg_integral(i, j, k, AJ3, BJ3, d_low, dmax_agg) + endif ! concentration-weighted mean sinking velocity ws_Re = (ws_agg_ints & @@ -769,157 +772,157 @@ REAL FUNCTION ws_Re(i,j,k,dmax_agg) & - av_dp(i,j,k)**(1. + df_agg(i,j,k) - b_agg(i,j,k))) & & / (1. + df_agg(i,j,k) - b_agg(i,j,k))))*dtbgc ! (m/s -> m/d) *dtb - END FUNCTION ws_Re - - - SUBROUTINE max_agg_diam(kpie, kpje, kpke, pddpo, omask) - !----------------------------------------------------------------------- - !> - !! max_agg_diam calculates the maximum aggregate diameter of the aggregate - !! number distribution, assumes Re_crit > 10 - !! - INTEGER, INTENT(in) :: kpie !< 1st REAL of model grid. - INTEGER, INTENT(in) :: kpje !< 2nd REAL of model grid. - INTEGER, INTENT(in) :: kpke !< 3rd (vertical) REAL of model grid. - REAL, INTENT(in) :: pddpo(kpie,kpje,kpke) !< size of scalar grid cell (3rd dimension) [m] - REAL, INTENT(in) :: omask(kpie,kpje) - - !$OMP PARALLEL DO PRIVATE(i,j,k) - ! base on analytical Jiang approximation - DO j = 1,kpje - DO i = 1,kpie - DO k = 1,kpke - IF(pddpo(i,j,k) > dp_min .and. omask(i,j) > 0.5) THEN - Lmax_agg(i,j,k) = max_agg_diam_white(i,j,k) - END IF - END DO - END DO - END DO - !$OMP END PARALLEL DO - END SUBROUTINE max_agg_diam - + end function ws_Re + + + subroutine max_agg_diam(kpie, kpje, kpke, pddpo, omask) + !----------------------------------------------------------------------- + !> + !! max_agg_diam calculates the maximum aggregate diameter of the aggregate + !! number distribution, assumes Re_crit > 10 + !! + integer, intent(in) :: kpie !< 1st real of model grid. + integer, intent(in) :: kpje !< 2nd real of model grid. + integer, intent(in) :: kpke !< 3rd (vertical) real of model grid. + real, intent(in) :: pddpo(kpie,kpje,kpke) !< size of scalar grid cell (3rd dimension) [m] + real, intent(in) :: omask(kpie,kpje) + + !$OMP PARALLEL DO PRIVATE(i,j,k) + ! base on analytical Jiang approximation + do j = 1,kpje + do i = 1,kpie + do k = 1,kpke + if(pddpo(i,j,k) > dp_min .and. omask(i,j) > 0.5) then + Lmax_agg(i,j,k) = max_agg_diam_white(i,j,k) + endif + enddo + enddo + enddo + !$OMP END PARALLEL DO + end subroutine max_agg_diam + !================================================ maximum diameter of agg in non-stratified fluid - REAL FUNCTION max_agg_diam_white(i,j,k) - !------------------------------------------------------------------------- - !> - !! maximum aggregate diameter in a non-stratified fluid - following the - !! White drag approaximation by Jiang & Logan 1991, assuming agg_re_crit > 10 - !! (otherwise AJX,BJX needs to be adjusted) - !! + real function max_agg_diam_white(i,j,k) + !------------------------------------------------------------------------- + !> + !! maximum aggregate diameter in a non-stratified fluid - following the + !! White drag approaximation by Jiang & Logan 1991, assuming agg_re_crit > 10 + !! (otherwise AJX,BJX needs to be adjusted) + !! - IMPLICIT NONE + implicit none - INTEGER,INTENT(in) :: i,j,k - REAL :: nu_vis + integer,intent(in) :: i,j,k + real :: nu_vis - nu_vis = dyn_vis(i,j,k)/rho_aq - max_agg_diam_white = (agg_Re_crit*nu_vis)**((2. - BJ3)/df_agg(i,j,k)) & - & /((4./3.)*(av_rho_p(i,j,k) - rho_aq)/rho_aq & - & *av_dp(i,j,k)**(3. - df_agg(i,j,k))*grav_acc_const & - & /(AJ3*nu_vis**BJ3))**(1./df_agg(i,j,k)) + nu_vis = dyn_vis(i,j,k)/rho_aq + max_agg_diam_white = (agg_Re_crit*nu_vis)**((2. - BJ3)/df_agg(i,j,k)) & + & /((4./3.)*(av_rho_p(i,j,k) - rho_aq)/rho_aq & + & *av_dp(i,j,k)**(3. - df_agg(i,j,k))*grav_acc_const & + & /(AJ3*nu_vis**BJ3))**(1./df_agg(i,j,k)) - END FUNCTION max_agg_diam_white + end function max_agg_diam_white !===================================================================================== mass factor - REAL FUNCTION mass_factor(dp,df,rhop) - !----------------------------------------------------------------------- - !> - !! mass_factor calculates the mass factor for the mass of a single - !! aggregate - !! - IMPLICIT NONE - - REAL, INTENT(in) :: dp - REAL, INTENT(in) :: df - REAL, INTENT(in) :: rhop - - ! mass factor + real function mass_factor(dp,df,rhop) + !----------------------------------------------------------------------- + !> + !! mass_factor calculates the mass factor for the mass of a single + !! aggregate + !! + implicit none + + real, intent(in) :: dp + real, intent(in) :: df + real, intent(in) :: rhop + + ! mass factor mass_factor = ONE_SIXTH * PI * dp**(3. - df) * rhop - END FUNCTION mass_factor + end function mass_factor !===================================================================================== rho_agg - REAL FUNCTION rho_agg(d,rhop,dp,df,rho) - !----------------------------------------------------------------------- - !> - !! rho_agg provides the aggregate density - !! - - IMPLICIT NONE + real function rho_agg(d,rhop,dp,df,rho) + !----------------------------------------------------------------------- + !> + !! rho_agg provides the aggregate density + !! + + implicit none - REAL, INTENT(in) :: d - REAL, INTENT(in) :: rhop - REAL, INTENT(in) :: dp - REAL, INTENT(in) :: df - REAL, INTENT(in) :: rho + real, intent(in) :: d + real, intent(in) :: rhop + real, intent(in) :: dp + real, intent(in) :: df + real, intent(in) :: rho - rho_agg = (rhop - rho)*(dp/d)**(3. - df) + rho + rho_agg = (rhop - rho)*(dp/d)**(3. - df) + rho - END FUNCTION rho_agg + end function rho_agg !===================================================================================== dynvis - SUBROUTINE dynvis(kpie, kpje, kpke, kbnd, pddpo, omask, ptho, psao, ppo) - !----------------------------------------------------------------------- - !> - !! dynvis calculates the molecular dynamic viscosity according to - !! Richards 1998: The effect of temperature, pressure, and salinity - !! on sound attenuation in turbid seawater. J. Acoust. Soc. Am. 103 (1), - !! originally published by Matthaeus, W. (1972): Die Viskositaet des - !! Meerwassers. Beitraege zur Meereskunde, Heft 29 (in German). - !! - - IMPLICIT NONE - - INTEGER, INTENT(in) :: kpie !< 1st REAL of model grid. - INTEGER, INTENT(in) :: kpje !< 2nd REAL of model grid. - INTEGER, INTENT(in) :: kpke !< 3rd (vertical) REAL of model grid. - INTEGER, INTENT(in) :: kbnd - - REAL, INTENT(in) :: pddpo(kpie,kpje,kpke) !< size of scalar grid cell (3rd dimension) [m] - REAL, INTENT(in) :: omask(kpie,kpje) - REAL, INTENT(in) :: ptho(1-kbnd:kpie+kbnd,1-kbnd:kpje+kbnd,kpke) !< potential temperature [deg C] - REAL, INTENT(in) :: psao(1-kbnd:kpie+kbnd,1-kbnd:kpje+kbnd,kpke) !< salinity [psu.]. - REAL, INTENT(in) :: ppo(kpie,kpje,kpke) !< pressure [Pa]. - - ! Local variables - REAL:: press_val ! Pascal/rho -> dbar - REAL:: ptho_val,psao_val - INTEGER :: kch - kch = 0 - !$OMP PARALLEL DO PRIVATE(i,j,k,press_val,ptho_val,psao_val,kch) - DO j = 1,kpje - DO i = 1,kpie - DO k = 1,kpke - IF(pddpo(i,j,k) > dp_min .and. omask(i,j) > 0.5) THEN - kch = MERGE(k+1,k,k 0.5) THEN - press_val = 0.5*(ppo(i,j,k) + ppo(i,j,kch))*1.e-5 ! Pascal -> dbar - ptho_val = 0.5*(ptho(i,j,k) + ptho(i,j,kch)) - psao_val = 0.5*(psao(i,j,k) + ptho(i,j,kch)) - ELSE - press_val = ppo(i,j,k)*1.e-5 ! Pascal -> dbar - ptho_val = ptho(i,j,k) - psao_val = psao(i,j,k) - END IF - - - ! molecular dynamic viscosity - dyn_vis(i,j,k) = 0.1 & ! Unit: g / (cm*s) -> kg / (m*s) - & *(1.79e-2 & - & - 6.1299e-4*ptho_val + 1.4467e-5*ptho_val**2. & - & - 1.6826e-7*ptho_val**3. & - & - 1.8266e-7*press_val + 9.8972e-12*press_val**2. & - & + 2.4727e-5*psao_val & - & + psao_val*(4.8429e-7*ptho_val - 4.7172e-8*ptho_val**2. & - & + 7.5986e-10*ptho_val**3.) & - & + press_val*(1.3817e-8*ptho_val - 2.6363e-10*ptho_val**2.) & - & - press_val**2.*(6.3255e-13*ptho_val - 1.2116e-14*ptho_val**2.)) - END IF - END DO - END DO - END DO - !$OMP END PARALLEL DO - END SUBROUTINE dynvis - END MODULE mo_m4ago + subroutine dynvis(kpie, kpje, kpke, kbnd, pddpo, omask, ptho, psao, ppo) + !----------------------------------------------------------------------- + !> + !! dynvis calculates the molecular dynamic viscosity according to + !! Richards 1998: The effect of temperature, pressure, and salinity + !! on sound attenuation in turbid seawater. J. Acoust. Soc. Am. 103 (1), + !! originally published by Matthaeus, W. (1972): Die Viskositaet des + !! Meerwassers. Beitraege zur Meereskunde, Heft 29 (in German). + !! + + implicit none + + integer, intent(in) :: kpie !< 1st real of model grid. + integer, intent(in) :: kpje !< 2nd real of model grid. + integer, intent(in) :: kpke !< 3rd (vertical) real of model grid. + integer, intent(in) :: kbnd + + real, intent(in) :: pddpo(kpie,kpje,kpke) !< size of scalar grid cell (3rd dimension) [m] + real, intent(in) :: omask(kpie,kpje) + real, intent(in) :: ptho(1-kbnd:kpie+kbnd,1-kbnd:kpje+kbnd,kpke) !< potential temperature [deg C] + real, intent(in) :: psao(1-kbnd:kpie+kbnd,1-kbnd:kpje+kbnd,kpke) !< salinity [psu.]. + real, intent(in) :: ppo(kpie,kpje,kpke) !< pressure [Pa]. + + ! Local variables + real:: press_val ! Pascal/rho -> dbar + real:: ptho_val,psao_val + integer :: kch + kch = 0 + !$OMP PARALLEL DO PRIVATE(i,j,k,press_val,ptho_val,psao_val,kch) + do j = 1,kpje + do i = 1,kpie + do k = 1,kpke + if(pddpo(i,j,k) > dp_min .and. omask(i,j) > 0.5) then + kch = merge(k+1,k,k 0.5) then + press_val = 0.5*(ppo(i,j,k) + ppo(i,j,kch))*1.e-5 ! Pascal -> dbar + ptho_val = 0.5*(ptho(i,j,k) + ptho(i,j,kch)) + psao_val = 0.5*(psao(i,j,k) + ptho(i,j,kch)) + else + press_val = ppo(i,j,k)*1.e-5 ! Pascal -> dbar + ptho_val = ptho(i,j,k) + psao_val = psao(i,j,k) + endif + + ! molecular dynamic viscosity + dyn_vis(i,j,k) = 0.1 & ! Unit: g / (cm*s) -> kg / (m*s) + & *(1.79e-2 & + & - 6.1299e-4*ptho_val + 1.4467e-5*ptho_val**2. & + & - 1.6826e-7*ptho_val**3. & + & - 1.8266e-7*press_val + 9.8972e-12*press_val**2. & + & + 2.4727e-5*psao_val & + & + psao_val*(4.8429e-7*ptho_val - 4.7172e-8*ptho_val**2. & + & + 7.5986e-10*ptho_val**3.) & + & + press_val*(1.3817e-8*ptho_val - 2.6363e-10*ptho_val**2.) & + & - press_val**2.*(6.3255e-13*ptho_val - 1.2116e-14*ptho_val**2.)) + endif + enddo + enddo + enddo + !$OMP END PARALLEL DO + end subroutine dynvis + +end module mo_m4ago From 24b7ad6912a4da1549407447cbb670f3822674f6 Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Thu, 25 Jan 2024 16:41:26 +0100 Subject: [PATCH 335/366] minor changes - fix inventory write for extNcycle --- hamocc/mo_extNwatercol.F90 | 18 +++++++++++------- hamocc/mo_ocprod.F90 | 2 +- 2 files changed, 12 insertions(+), 8 deletions(-) diff --git a/hamocc/mo_extNwatercol.F90 b/hamocc/mo_extNwatercol.F90 index 113b0255..3995c98d 100644 --- a/hamocc/mo_extNwatercol.F90 +++ b/hamocc/mo_extNwatercol.F90 @@ -48,7 +48,7 @@ module mo_extNwatercol !**************************************************************** use mo_vgrid, only: dp_min use mod_xc, only: mnproc - use mo_control_bgc, only: io_stdo_bgc,dtb + use mo_control_bgc, only: dtb use mo_param1_bgc, only: ialkali,ianh4,iano2,ian2o,iano3,idet,igasnit,iiron,ioxygen,iphosph, & & isco212 use mo_carbch, only: ocetra @@ -425,6 +425,10 @@ end subroutine denit_dnra !================================================================================================================================== subroutine extN_inv_check(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask,inv_message) + use mo_inventory_bgc, only: inventory_bgc + use mo_control_bgc, only: io_stdo_bgc,dtb,use_PBGC_OCNP_TIMESTEP + + implicit none ! provide inventory calculation for extended nitrogen cycle integer, intent(in) :: kpie,kpje,kpke @@ -432,13 +436,13 @@ subroutine extN_inv_check(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask,inv_message) real, intent(in) :: pdlxp(kpie,kpje),pdlyp(kpie,kpje),pddpo(kpie,kpje,kpke) character (len=*),intent(in) :: inv_message -#ifdef PBGC_OCNP_TIMESTEP - if (mnproc == 1) then - write(io_stdo_bgc,*)' ' - write(io_stdo_bgc,*)inv_message + if (use_PBGC_OCNP_TIMESTEP) then + if (mnproc == 1) then + write(io_stdo_bgc,*)' ' + write(io_stdo_bgc,*)inv_message + endif + call INVENTORY_BGC(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask,0) endif - call INVENTORY_BGC(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask,0) -#endif end subroutine extN_inv_check !================================================================================================================================== diff --git a/hamocc/mo_ocprod.F90 b/hamocc/mo_ocprod.F90 index 24d3f271..a8fe9500 100644 --- a/hamocc/mo_ocprod.F90 +++ b/hamocc/mo_ocprod.F90 @@ -778,7 +778,7 @@ subroutine ocprod(kpie,kpje,kpke,kbnd,pdlxp,pdlyp,pddpo,omask,ptho,pi_ph,psao,pp endif if (.not. use_extNcycle) then - ! =====>>>> Regular CMIP6 iHAMOCC version for denitrification wo extended nitrogen cycle =====>>>> + ! =====>>>> Regular CMIP6 iHAMOCC version for denitrification wo extended nitrogen cycle =====>>>> !$OMP PARALLEL DO PRIVATE(remin,remin2o,dz,avmass,avnos,rem13,rem14,i,k) loop3: do j = 1,kpje do i = 1,kpie From d4672fab4ebef38ba9fba96d0dfe39b588e4d368 Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Thu, 25 Jan 2024 17:32:56 +0100 Subject: [PATCH 336/366] fix issues with DMS (partially introduced by merging, partially not correct before) --- hamocc/mo_ocprod.F90 | 2 +- hamocc/mo_param_bgc.F90 | 4 ++-- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/hamocc/mo_ocprod.F90 b/hamocc/mo_ocprod.F90 index a8fe9500..a0730f12 100644 --- a/hamocc/mo_ocprod.F90 +++ b/hamocc/mo_ocprod.F90 @@ -737,7 +737,7 @@ subroutine ocprod(kpie,kpje,kpke,kbnd,pdlxp,pdlyp,pddpo,omask,ptho,pi_ph,psao,pp ocetra(i,j,k,ioxygen) = ocetra(i,j,k,ioxygen)-remin*1.e-4*ro2ut*refra*0.5 endif - dms_bac = dmsp3 * dtb * abs(temp+3.) * ocetra(i,j,k,idms) & + dms_bac = dmsp3 * abs(temp+3.) * ocetra(i,j,k,idms) & & * (ocetra(i,j,k,idms) / (dmsp6+ocetra(i,j,k,idms))) ocetra(i,j,k,idms) = ocetra(i,j,k,idms)-dms_bac diff --git a/hamocc/mo_param_bgc.F90 b/hamocc/mo_param_bgc.F90 index e138487e..488e00d0 100644 --- a/hamocc/mo_param_bgc.F90 +++ b/hamocc/mo_param_bgc.F90 @@ -885,8 +885,8 @@ subroutine write_parambgc() write(io_stdo_bgc,*) '* fesoly = ',fesoly write(io_stdo_bgc,*) '* relaxfe = ',relaxfe*dtbinv write(io_stdo_bgc,*) '* dmsp1 = ',dmsp1 - write(io_stdo_bgc,*) '* dmsp2 = ',dmsp2 - write(io_stdo_bgc,*) '* dmsp3 = ',dmsp3 + write(io_stdo_bgc,*) '* dmsp2 = ',dmsp2*dtbinv + write(io_stdo_bgc,*) '* dmsp3 = ',dmsp3*dtbinv write(io_stdo_bgc,*) '* dmsp4 = ',dmsp4 write(io_stdo_bgc,*) '* dmsp5 = ',dmsp5 write(io_stdo_bgc,*) '* dmsp6 = ',dmsp6 From 834551be50ac4c83f1ef080c26c91f76d18062a7 Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Fri, 26 Jan 2024 16:02:19 +0100 Subject: [PATCH 337/366] remove double entry --- cime_config/namelist_definition_blom.xml | 12 ------------ 1 file changed, 12 deletions(-) diff --git a/cime_config/namelist_definition_blom.xml b/cime_config/namelist_definition_blom.xml index 87dfe7e1..d670a71b 100644 --- a/cime_config/namelist_definition_blom.xml +++ b/cime_config/namelist_definition_blom.xml @@ -5422,18 +5422,6 @@ Nitrite concentration [mol NO2 m-3] - extended N cycle only - - integer(3) - diabgc - diabgc - - 0,0,2 - 4,2,2 - 0,0,0 - - denitrification rate on N20 [mol N20 m-3 s-1] - ext. N cycle only - - integer(3) diabgc From 9bd1e478feb61b87410913c56683ed1840c1faa1 Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Fri, 26 Jan 2024 18:15:44 +0100 Subject: [PATCH 338/366] Add xml-switches to buildnml --- cime_config/buildnml | 6 ++++++ cime_config/namelist_definition_blom.xml | 15 +++++++++++++-- 2 files changed, 19 insertions(+), 2 deletions(-) diff --git a/cime_config/buildnml b/cime_config/buildnml index b69dddab..83439dd6 100755 --- a/cime_config/buildnml +++ b/cime_config/buildnml @@ -80,6 +80,9 @@ def buildnml(case, caseroot, compname): blom_tracer_modules = case.get_value("BLOM_TRACER_MODULES") hamocc_ciso = case.get_value("HAMOCC_CISO") hamocc_extncycle = case.get_value("HAMOCC_EXTNCYCLE") + hamocc_n2oc = case.get_value("HAMOCC_N2OC") + hamocc_atmndepc = case.get_value("HAMOCC_ATMNDEPC") + hamocc_m4ago = case.get_value("HAMOCC_M4AGO") hamocc_sedbypass = case.get_value("HAMOCC_SEDBYPASS") hamocc_sedspinup = case.get_value("HAMOCC_SEDSPINUP") hamocc_sedspinup_yr_start = case.get_value("HAMOCC_SEDSPINUP_YR_START") @@ -184,6 +187,9 @@ def buildnml(case, caseroot, compname): config["blom_tracer_modules"] = blom_tracer_modules config["hamocc_ciso"] = "yes" if hamocc_ciso else "no" config["hamocc_extncycle"] = "yes" if hamocc_extncycle else "no" + config["hamocc_n2oc"] = "yes" if hamocc_n2oc else "no" + config["hamocc_atmndepc"] = "yes" if hamocc_atmndepc else "no" + config["hamocc_m4ago"] = "yes" if hamocc_m4ago else "no" config["hamocc_sedbypass"] = "yes" if hamocc_sedbypass else "no" config["hamocc_sedspinup"] = "yes" if hamocc_sedspinup else "no" config["hamocc_sedspinup_yr_start"] = hamocc_sedspinup_yr_start diff --git a/cime_config/namelist_definition_blom.xml b/cime_config/namelist_definition_blom.xml index d670a71b..5f0fc734 100644 --- a/cime_config/namelist_definition_blom.xml +++ b/cime_config/namelist_definition_blom.xml @@ -3586,7 +3586,7 @@ bgcnml .false. - .true. + .true. Switch to couple nitrogen deposition. Requires do_ndep. @@ -3597,7 +3597,7 @@ bgcnml .false. - .true. + .true. Switch to couple N2O and NH3 fluxes @@ -3876,6 +3876,17 @@ (no swa-climatology has been created for other grid configurations) + + logical + config_bgc + config_bgc + + .false. + .true. + + activate the HAMOCC extended nitrogen cycle code + + logical config_bgc From d0d99a5dd61e8e3f225ba81d6e0a6096b325bab3 Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Fri, 26 Jan 2024 19:12:32 +0100 Subject: [PATCH 339/366] fix namelist def --- cime_config/namelist_definition_blom.xml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/cime_config/namelist_definition_blom.xml b/cime_config/namelist_definition_blom.xml index 5f0fc734..c0399be6 100644 --- a/cime_config/namelist_definition_blom.xml +++ b/cime_config/namelist_definition_blom.xml @@ -3597,7 +3597,7 @@ bgcnml .false. - .true. + .true. Switch to couple N2O and NH3 fluxes From 3d6184ae19ea2297ffad042ca9ada686dc0d4a2e Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Mon, 29 Jan 2024 16:54:01 +0100 Subject: [PATCH 340/366] fix configuration for coupled simulations --- cime_config/config_component.xml | 13 +++++++++---- 1 file changed, 9 insertions(+), 4 deletions(-) diff --git a/cime_config/config_component.xml b/cime_config/config_component.xml index d3312b8b..1e788d34 100644 --- a/cime_config/config_component.xml +++ b/cime_config/config_component.xml @@ -135,6 +135,11 @@ logical TRUE,FALSE FALSE + + TRUE + TRUE + TRUE + run_component_blom env_run.xml Set preprocessor option to activate the extended nitrogen cycle code. Requires module ecosys @@ -145,11 +150,11 @@ TRUE,FALSE FALSE - TRUE + TRUE run_component_blom env_run.xml - Nitrogen deposition coupled from atmopshere. Requires module ecosys and extncycle + Nitrogen deposition coupled from atmosphere. Requires module ecosys and extncycle @@ -157,11 +162,11 @@ TRUE,FALSE FALSE - TRUE + TRUE run_component_blom env_run.xml - N2O and NH3 fluxes coupled from atmopshere. Requires module ecosys and extncycle + N2O and NH3 fluxes coupled from atmosphere. Requires module ecosys and extncycle From 3da9dd656da4c8527aa953ab78db639ea78efbce Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Mon, 29 Jan 2024 17:31:55 +0100 Subject: [PATCH 341/366] minor changes --- cime_config/namelist_definition_blom.xml | 8 ++++---- cime_config/ocn_in.readme | 1 + 2 files changed, 5 insertions(+), 4 deletions(-) diff --git a/cime_config/namelist_definition_blom.xml b/cime_config/namelist_definition_blom.xml index c0399be6..8f46e4d4 100644 --- a/cime_config/namelist_definition_blom.xml +++ b/cime_config/namelist_definition_blom.xml @@ -5080,7 +5080,7 @@ 0,0,0 0,2,2 - 4,2,2 + 4,2,2 NOy nitrogen deposition flux [mol N m-2 s-1] @@ -5090,9 +5090,9 @@ diabgc diabgc - 0,2,2 - 4,2,2 - 0,0,0 + 0,0,0 + 0,2,2 + 4,2,2 NHx nitrogen deposition flux [mol N m-2 s-1] - extended N cycle only diff --git a/cime_config/ocn_in.readme b/cime_config/ocn_in.readme index cb4cca5d..526ea23b 100644 --- a/cime_config/ocn_in.readme +++ b/cime_config/ocn_in.readme @@ -365,6 +365,7 @@ ! DO_NDEP : Logical switch to activate N-deposition ! DO_NDEP_COUPLED: Logical to apply N-deposition fluxes received from the atmosphere (true=atm, false=clim) ! NDEPFILE : File name (incl. full path) for atmopheric N-deposition data +! DO_N2ONH3_COUPLED: Logical switch for interactive coupling of N2O and NH3 fluxes (true=atm, false=fix atmospheric value) ! DO_SEDSPINUP: Logical switch to activate sediment spin-up ! SEDSPIN_YR_S: Start year for sediment spinup ! SEDSPIN_YR_E: End year for sediment spinup From c51008b1d0fd390cb31bde9ddaec55c6521f684a Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Wed, 31 Jan 2024 16:56:31 +0100 Subject: [PATCH 342/366] add extended nitrogen cycle tuning parameters to xml --- cime_config/namelist_definition_blom.xml | 181 +++++++++++++++++++++++ hamocc/mo_param_bgc.F90 | 4 +- 2 files changed, 184 insertions(+), 1 deletion(-) diff --git a/cime_config/namelist_definition_blom.xml b/cime_config/namelist_definition_blom.xml index 16b4c733..d2d8978d 100644 --- a/cime_config/namelist_definition_blom.xml +++ b/cime_config/namelist_definition_blom.xml @@ -4299,6 +4299,187 @@ Sinking parameter: m/d maximum sinking speed + + real + bgcparams + bgcparams + + None + + Half-saturation constant for NH4 uptake by bulk phytoplankton (kmol/m3) + + + + real + bgcparams + bgcparams + + None + + Half-saturation constant for NO3 uptake by bulk phytoplankton (kmol/m3) + + + + real + bgcparams + bgcparams + + None + + Maximum growth rate denitrification on NO3 at reference T (1/d) + + + + real + bgcparams + bgcparams + + None + + Maximum growth rate for anammox at reference T (1/d) + + + + real + bgcparams + bgcparams + + None + + Maximum growth rate denitrification on NO2 at reference T (1/d) + + + + real + bgcparams + bgcparams + + None + + Maximum growth rate denitrification on N2O at reference T (1/d) + + + + real + bgcparams + bgcparams + + None + + Maximum growth rate DNRA on NO2 at reference T (1/d) + + + + real + bgcparams + bgcparams + + None + + Maximum growth rate nitrification on NH4 at reference T (1/d) + + + + real + bgcparams + bgcparams + + None + + Maximum growth rate nitrification on NO2 at reference T (1/d) + + + + real + bgcparams + bgcparams + + None + + SEDIMENT: Maximum growth rate denitrification on NO3 at reference T (1/d) + + + + real + bgcparams + bgcparams + + None + + SEDIMENT: Maximum growth rate for anammox at reference T (1/d) + + + + real + bgcparams + bgcparams + + None + + SEDIMENT: Maximum growth rate denitrification on NO2 at reference T (1/d) + + + + real + bgcparams + bgcparams + + None + + SEDIMENT: Maximum growth rate denitrification on N2O at reference T (1/d) + + + + real + bgcparams + bgcparams + + None + + SEDIMENT: Maximum growth rate DNRA on NO2 at reference T (1/d) + + + + real + bgcparams + bgcparams + + None + + SEDIMENT: Maximum growth rate nitrification on NH4 at reference T (1/d) + + + + real + bgcparams + bgcparams + + None + + SEDIMENT: Maximum growth rate nitrification on NO2 at reference T (1/d) + + + + real + bgcparams + bgcparams + + None + + atmosphere ammonia mixing ratio (ppt) + + + + real + bgcparams + bgcparams + + None + + atmosphere laughing gas mixing ratio (ppt) + + + diff --git a/hamocc/mo_param_bgc.F90 b/hamocc/mo_param_bgc.F90 index 488e00d0..52b0ec78 100644 --- a/hamocc/mo_param_bgc.F90 +++ b/hamocc/mo_param_bgc.F90 @@ -273,6 +273,7 @@ module mo_param_bgc !******************************************************************** ! Extended nitrogen cycle !******************************************************************** + ! WATER COLUMN ! Phytoplankton growth real, protected :: bkphyanh4 = 0.12e-6 ! Half-saturation constant for NH4 uptake by bulk phytoplankton (kmol/m3) real, protected :: bkphyano3 = 0.16e-6 ! Half-saturation constant for NO3 uptake by bulk phytoplankton (kmol/m3) @@ -337,6 +338,7 @@ module mo_param_bgc real, protected :: bkano2nitr = 0.287e-6 ! Half-saturation constant for NO2 for nitrification on NO2 (kmol/m3) real, protected :: NOB2AOAy = 0.44 ! Ratio of NOB versus AOA yield per energy source ~0.043/0.098 according to Zakem et al. 2022 + !SEDIMENT ! === Ammonification in the sediment real, protected :: POM_remin_q10_sed = 2.1 ! ammonification Q10 in sediment real, protected :: POM_remin_Tref_sed = 10. ! ammonification Tref in sediment @@ -585,7 +587,7 @@ subroutine read_bgcnamelist() rano3denit,rano2anmx,rano2denit,ran2odenit,rdnra, & ranh4nitr,rano2nitr,rano3denit_sed,rano2anmx_sed, & rano2denit_sed,ran2odenit_sed,rdnra_sed,ranh4nitr_sed, & - rano2nitr_sed,atm_nh3,atm_n2o + rano2nitr_sed,atm_nh3,atm_n2o,bkphyanh4,bkphyano3 open (newunit=iounit, file=bgc_namelist, status='old',action='read') read (unit=iounit, nml=BGCPARAMS) From 552be9f4bd721b3871f52ab59a0ba3aea520fed9 Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Wed, 31 Jan 2024 18:12:48 +0100 Subject: [PATCH 343/366] add barely used tuning parameter for extended nitrogen cycle to xml --- cime_config/namelist_definition_blom.xml | 230 +++++++++++++++++++++++ hamocc/mo_param_bgc.F90 | 2 +- 2 files changed, 231 insertions(+), 1 deletion(-) diff --git a/cime_config/namelist_definition_blom.xml b/cime_config/namelist_definition_blom.xml index d2d8978d..f93ba508 100644 --- a/cime_config/namelist_definition_blom.xml +++ b/cime_config/namelist_definition_blom.xml @@ -4479,6 +4479,236 @@ atmosphere laughing gas mixing ratio (ppt) + + real + bgcparams + bgcparams + + None + + Half-saturation constant for PO4 uptake by bulk phytoplankton (kmol/m3) + + + + real + bgcparams + bgcparams + + None + + Q10 factor for denitrification on NO3 (-) + + + + real + bgcparams + bgcparams + + None + + Shape factor for NO3 denitrification oxygen inhibition function (m3/kmol) + + + + real + bgcparams + bgcparams + + None + + Half-saturation constant for NO3 denitrification (kmol/m3) + + + + real + bgcparams + bgcparams + + None + + Q10 factor for anammox (-) + + + + real + bgcparams + bgcparams + + None + + Shape factor for anammox oxygen inhibition function (m3/kmol) + + + + real + bgcparams + bgcparams + + None + + Half-saturation constant for oxygen inhibition function (kmol/m3) + + + + real + bgcparams + bgcparams + + None + + Half-saturation constant for NO2 limitation (kmol/m3) + + + + real + bgcparams + bgcparams + + None + + Q10 factor for denitrification on NO2 (-) + + + + real + bgcparams + bgcparams + + None + + Half-saturation constant for (quadratic) oxygen inhibition function of denitrification on NO2 (kmol/m3) + + + + real + bgcparams + bgcparams + + None + + Half-saturation constant for denitrification on NO2 (kmol/m3) + + + + real + bgcparams + bgcparams + + None + + Q10 factor for denitrificationj on N2O (-) + + + + real + bgcparams + bgcparams + + None + + Half-saturation constant for (quadratic) oxygen inhibition function of denitrification on N2O (kmol/m3) + + + + real + bgcparams + bgcparams + + None + + Half-saturation constant for denitrification on N2O (kmol/m3) + + + + real + bgcparams + bgcparams + + None + + Q10 factor for DNRA on NO2 (-) + + + + real + bgcparams + bgcparams + + None + + Half saturation constant for (quadratic) oxygen inhibition function of DNRA on NO2 (kmol/m3) + + + + real + bgcparams + bgcparams + + None + + Half-saturation constant for DNRA on NO2 (kmol/m3) + + + + real + bgcparams + bgcparams + + None + + Q10 factor for nitrification on NH4 (-) + + + + real + bgcparams + bgcparams + + None + + Half-saturation constant for oxygen limitation of nitrification on NH4 (kmol/m3) + + + + real + bgcparams + bgcparams + + None + + Half-saturation constant for nitrification on NH4 (kmol/m3) + + + + real + bgcparams + bgcparams + + None + + Q10 factor for nitrification on NO2 (-) + + + + real + bgcparams + bgcparams + + None + + Half-saturation constant for oxygen limitation of nitrification on NO2 (kmol/m3) + + + + real + bgcparams + bgcparams + + None + + Half-saturation constant for NO2 for nitrification on NO2 (kmol/m3) + + diff --git a/hamocc/mo_param_bgc.F90 b/hamocc/mo_param_bgc.F90 index 52b0ec78..faf7a533 100644 --- a/hamocc/mo_param_bgc.F90 +++ b/hamocc/mo_param_bgc.F90 @@ -305,7 +305,7 @@ module mo_param_bgc ! === Denitrification step N2O -> N2 real, protected :: ran2odenit = 0.16 ! Maximum growth rate denitrification on N2O at reference T (1/d -> 1/dt) - real, protected :: q10an2odenit = 3. ! Q1- factor for denitrificationj on N2O (-) + real, protected :: q10an2odenit = 3. ! Q10 factor for denitrificationj on N2O (-) real, protected :: Trefan2odenit = 10. ! Reference temperature for denitrification on N2O (degr C) real, protected :: bkoxan2odenit = 5.e-6 ! Half-saturation constant for (quadratic) oxygen inhibition function of denitrification on N2O (kmol/m3) real, protected :: bkan2odenit = 1.e-6 ! Half-saturation constant for denitrification on N2O (kmol/m3) From 247722b7a8900ce6120ef7ef1230294664ea2523 Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Mon, 12 Feb 2024 20:00:37 +0100 Subject: [PATCH 344/366] add bgc-namelist parameters --- hamocc/mo_param_bgc.F90 | 17 +++++++++++++---- 1 file changed, 13 insertions(+), 4 deletions(-) diff --git a/hamocc/mo_param_bgc.F90 b/hamocc/mo_param_bgc.F90 index 5a902928..f84c8468 100644 --- a/hamocc/mo_param_bgc.F90 +++ b/hamocc/mo_param_bgc.F90 @@ -604,16 +604,25 @@ subroutine read_bgcnamelist() rano3denit,rano2anmx,rano2denit,ran2odenit,rdnra, & ranh4nitr,rano2nitr,rano3denit_sed,rano2anmx_sed, & rano2denit_sed,ran2odenit_sed,rdnra_sed,ranh4nitr_sed, & - rano2nitr_sed,atm_nh3,atm_n2o,bkphyanh4,bkphyano3 + rano2nitr_sed,atm_nh3,atm_n2o,bkphyanh4,bkphyano3, & + bkphosph, & + q10ano3denit,sc_ano3denit,bkano3denit,q10anmx,alphaanmx,& + bkoxanmx,bkano2anmx,q10ano2denit, & + bkoxano2denit,bkano2denit,q10an2odenit,bkoxan2odenit, & + bkan2odenit,q10dnra,bkoxdnra,bkdnra,q10anh4nitr, & + bkoxamox,bkanh4nitr,q10ano2nitr,bkoxnitr,bkano2nitr + + if (mnproc.eq.1) then + write(io_stdo_bgc,*) + write(io_stdo_bgc,*)'********************************************' + write(io_stdo_bgc,*) 'iHAMOCC: read namelist bgcparams' + endif open (newunit=iounit, file=bgc_namelist, status='old',action='read') read (unit=iounit, nml=BGCPARAMS) close(unit=iounit) if (mnproc.eq.1) then - write(io_stdo_bgc,*) - write(io_stdo_bgc,*)'********************************************' - write(io_stdo_bgc,*) 'iHAMOCC: read namelist bgcparams' write(io_stdo_bgc,nml=BGCPARAMS) endif From fb6ba42dee7bdf09b5d4277a5594e0c6550c8e90 Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Tue, 13 Feb 2024 11:58:26 +0100 Subject: [PATCH 345/366] add preformed silicate tracer to nc-inventory --- hamocc/mo_inventory_bgc.F90 | 21 ++++++++++++++++++++- 1 file changed, 20 insertions(+), 1 deletion(-) diff --git a/hamocc/mo_inventory_bgc.F90 b/hamocc/mo_inventory_bgc.F90 index 263e7a15..263f0d8e 100644 --- a/hamocc/mo_inventory_bgc.F90 +++ b/hamocc/mo_inventory_bgc.F90 @@ -680,7 +680,7 @@ subroutine write_netcdf(iogrp) use mo_param1_bgc, only: idicsat,idms,ifdust,iiron,iprefalk,iprefdic,iprefo2,iprefpo4, & iadust,inos,ibromo,icfc11,icfc12,isf6,icalc13,icalc14,idet13, & idet14,idoc13,idoc14,iphy13,iphy14,isco213,isco214,izoo13,izoo14, & - inatalkali,inatcalc,inatsco212,ianh4,iano2 + inatalkali,inatcalc,inatsco212,ianh4,iano2,iprefsilica use mo_control_bgc,only: use_PBGC_CK_TIMESTEP,use_BOXATM,use_sedbypass,use_cisonew,use_AGG, & use_CFC,use_natDIC,use_BROMO @@ -749,6 +749,7 @@ subroutine write_netcdf(iogrp) integer :: zt_iron_varid, zc_iron_varid ! Dissolved iron integer :: zt_prefo2_varid, zc_prefo2_varid ! Preformed oxygen integer :: zt_prefpo4_varid, zc_prefpo4_varid ! Preformed phosphate + integer :: zt_prefsilica_varid,zc_prefsilica_varid ! Preformed silicate integer :: zt_prefalk_varid, zc_prefalk_varid ! Preformed alkalinity integer :: zt_prefdic_varid, zc_prefdic_varid ! Preformed DIC integer :: zt_dicsat_varid, zc_dicsat_varid ! Saturated DIC @@ -1121,6 +1122,18 @@ subroutine write_netcdf(iogrp) & 'Mean preformed phosphate concentration') ) call nccheck( NF90_PUT_ATT(ncid, zc_prefpo4_varid, 'units', 'kmol/m^3') ) + call nccheck( NF90_DEF_VAR(ncid, 'zt_prefsilica', NF90_DOUBLE, & + & time_dimid, zt_prefsilica_varid) ) + call nccheck( NF90_PUT_ATT(ncid, zt_prefsilica_varid, 'long_name', & + & 'Total preformed silica tracer') ) + call nccheck( NF90_PUT_ATT(ncid, zt_prefsilica_varid, 'units', 'kmol') ) + + call nccheck( NF90_DEF_VAR(ncid, 'zc_prefsilica', NF90_DOUBLE, & + & time_dimid, zc_prefsilica_varid) ) + call nccheck( NF90_PUT_ATT(ncid, zc_prefsilica_varid, 'long_name', & + & 'Mean preformed silica concentration') ) + call nccheck( NF90_PUT_ATT(ncid, zc_prefsilica_varid, 'units', 'kmol/m^3') ) + call nccheck( NF90_DEF_VAR(ncid, 'zt_prefalk', NF90_DOUBLE, & & time_dimid, zt_prefalk_varid) ) call nccheck( NF90_PUT_ATT(ncid, zt_prefalk_varid, 'long_name', & @@ -1584,6 +1597,8 @@ subroutine write_netcdf(iogrp) call nccheck( NF90_INQ_VARID(ncid, "zc_prefo2", zc_prefo2_varid) ) call nccheck( NF90_INQ_VARID(ncid, "zt_prefpo4", zt_prefpo4_varid) ) call nccheck( NF90_INQ_VARID(ncid, "zc_prefpo4", zc_prefpo4_varid) ) + call nccheck( NF90_INQ_VARID(ncid, "zt_prefsilica", zt_prefsilica_varid) ) + call nccheck( NF90_INQ_VARID(ncid, "zc_prefsilica", zc_prefsilica_varid) ) call nccheck( NF90_INQ_VARID(ncid, "zt_prefalk", zt_prefalk_varid) ) call nccheck( NF90_INQ_VARID(ncid, "zc_prefalk", zc_prefalk_varid) ) call nccheck( NF90_INQ_VARID(ncid, "zt_prefdic", zt_prefdic_varid) ) @@ -1771,6 +1786,10 @@ subroutine write_netcdf(iogrp) & zocetratot(iprefpo4), start = wrstart) ) call nccheck( NF90_PUT_VAR(ncid, zc_prefpo4_varid, & & zocetratoc(iprefpo4), start = wrstart) ) + call nccheck( NF90_PUT_VAR(ncid, zt_prefsilica_varid, & + & zocetratot(iprefsilica), start = wrstart) ) + call nccheck( NF90_PUT_VAR(ncid, zc_prefsilica_varid, & + & zocetratoc(iprefsilica), start = wrstart) ) call nccheck( NF90_PUT_VAR(ncid, zt_prefalk_varid, & & zocetratot(iprefalk), start = wrstart) ) call nccheck( NF90_PUT_VAR(ncid, zc_prefalk_varid, & From a9c39ec35db3be06b322b7a3815551c290a13fb9 Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Fri, 23 Feb 2024 14:53:58 +0100 Subject: [PATCH 346/366] Reorder writing of burial fluxes --- hamocc/mo_sedshi.F90 | 17 ++++++++--------- 1 file changed, 8 insertions(+), 9 deletions(-) diff --git a/hamocc/mo_sedshi.F90 b/hamocc/mo_sedshi.F90 index 102e10c5..a3191429 100644 --- a/hamocc/mo_sedshi.F90 +++ b/hamocc/mo_sedshi.F90 @@ -135,7 +135,7 @@ subroutine sedshi(kpie,kpje,omask) uebers=wsed(i,j)*sedlay(i,j,ks,iv) sedlay(i,j,ks ,iv)=sedlay(i,j,ks ,iv)-uebers burial(i,j,iv)=burial(i,j,iv)+uebers*seddw(ks)*porsol(i,j,ks) - sedfluxb(i,j,iv) = uebers*seddw(ks)*porsol(i,j,ks) + sedfluxb(i,j,iv) = uebers*seddw(ks)*porsol(i,j,ks) endif enddo !end i-loop enddo !end j-loop @@ -183,8 +183,7 @@ subroutine sedshi(kpie,kpje,omask) ! shift the sediment deficiency from the deepest (burial) ! layer into layer ks - !$OMP PARALLEL DO & - !$OMP&PRIVATE(i,seddef,spresent,buried,refill,frac) + !$OMP PARALLEL DO PRIVATE(i,seddef,spresent,buried,refill,frac) do j=1,kpje do i=1,kpie if(omask(i,j).gt.0.5) then @@ -228,6 +227,12 @@ subroutine sedshi(kpie,kpje,omask) sedlay(i,j,ks,isssc14)=sedlay(i,j,ks,isssc14)+refill*burial(i,j,isssc14)/frac endif + ! account for refluxes to get net-burial fluxes for output: + sedfluxb(i,j,issso12) = sedfluxb(i,j,issso12) - refill*burial(i,j,issso12) + sedfluxb(i,j,isssc12) = sedfluxb(i,j,isssc12) - refill*burial(i,j,isssc12) + sedfluxb(i,j,issssil) = sedfluxb(i,j,issssil) - refill*burial(i,j,issssil) + sedfluxb(i,j,issster) = sedfluxb(i,j,issster) - refill*burial(i,j,issster) + ! account for losses in buried sediment burial(i,j,issso12) = burial(i,j,issso12)-refill*burial(i,j,issso12) burial(i,j,isssc12) = burial(i,j,isssc12)-refill*burial(i,j,isssc12) @@ -239,12 +244,6 @@ subroutine sedshi(kpie,kpje,omask) burial(i,j,issso14) = burial(i,j,issso14)-refill*burial(i,j,issso14) burial(i,j,isssc14) = burial(i,j,isssc14)-refill*burial(i,j,isssc14) endif - ! account for refluxes to get net-burial fluxes: - ! note that this (and before) assumes no reflux of isotopes! - up to change? - sedfluxb(i,j,issso12) = sedfluxb(i,j,issso12) - refill*burial(i,j,issso12) - sedfluxb(i,j,isssc12) = sedfluxb(i,j,isssc12) - refill*burial(i,j,isssc12) - sedfluxb(i,j,issssil) = sedfluxb(i,j,issssil) - refill*burial(i,j,issssil) - sedfluxb(i,j,issster) = sedfluxb(i,j,issster) - refill*burial(i,j,issster) endif enddo !end i-loop enddo !end j-loop From 7e1f3adca000437892158a51890643ccf3c0da6a Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Fri, 23 Feb 2024 14:55:11 +0100 Subject: [PATCH 347/366] update default water column parameters for the N-cycle --- hamocc/mo_param_bgc.F90 | 18 +++++++++--------- 1 file changed, 9 insertions(+), 9 deletions(-) diff --git a/hamocc/mo_param_bgc.F90 b/hamocc/mo_param_bgc.F90 index f84c8468..7d7b87d2 100644 --- a/hamocc/mo_param_bgc.F90 +++ b/hamocc/mo_param_bgc.F90 @@ -291,20 +291,20 @@ module mo_param_bgc !******************************************************************** ! WATER COLUMN ! Phytoplankton growth - real, protected :: bkphyanh4 = 0.12e-6 ! Half-saturation constant for NH4 uptake by bulk phytoplankton (kmol/m3) + real, protected :: bkphyanh4 = 0.25e-6 ! Half-saturation constant for NH4 uptake by bulk phytoplankton (kmol/m3) real, protected :: bkphyano3 = 0.16e-6 ! Half-saturation constant for NO3 uptake by bulk phytoplankton (kmol/m3) real, protected :: bkphosph = 0.01e-6 ! Half-saturation constant for PO4 uptake by bulk phytoplankton (kmol/m3) real, protected :: bkiron ! = bkphosph*riron - Half-saturation constant for Fe uptake by bulk phytoplankton (kmol/m3) ! === Denitrification step NO3 -> NO2: - real, protected :: rano3denit = 0.05 ! Maximum growth rate denitrification on NO3 at reference T (1/d -> 1/dt) + real, protected :: rano3denit = 0.00005 ! Maximum growth rate denitrification on NO3 at reference T (1/d -> 1/dt) real, protected :: q10ano3denit = 2. ! Q10 factor for denitrification on NO3 (-) real, protected :: Trefano3denit = 10. ! Reference temperature for denitrification on NO3 (degr C) real, protected :: sc_ano3denit = 0.12e6 ! Shape factor for NO3 denitrification oxygen inhibition function (m3/kmol) real, protected :: bkano3denit = 5.e-6 ! Half-saturation constant for NO3 denitrification (kmol/m3) ! === Anammox - real, protected :: rano2anmx = 0.05 ! Maximum growth rate for anammox at reference T (1/d -> 1/dt) + real, protected :: rano2anmx = 0.001 ! Maximum growth rate for anammox at reference T (1/d -> 1/dt) real, protected :: q10anmx = 1.6 ! Q10 factor for anammox (-) real, protected :: Trefanmx = 10. ! Reference temperature for anammox (degr C) real, protected :: alphaanmx = 0.45e6 ! Shape factor for anammox oxygen inhibition function (m3/kmol) @@ -313,21 +313,21 @@ module mo_param_bgc real, protected :: bkanh4anmx ! = bkano2anmx * rnh4anmx/rno2anmx !Half-saturation constant for NH4 limitation of anammox (kmol/m3) ! === Denitrification step NO2 -> N2O - real, protected :: rano2denit = 0.12 ! Maximum growth rate denitrification on NO2 at reference T (1/d -> 1/dt) + real, protected :: rano2denit = 0.002 ! Maximum growth rate denitrification on NO2 at reference T (1/d -> 1/dt) real, protected :: q10ano2denit = 2.0 ! Q10 factor for denitrification on NO2 (-) real, protected :: Trefano2denit = 10. ! Reference temperature for denitrification on NO2 (degr C) real, protected :: bkoxano2denit = 2.e-6 ! Half-saturation constant for (quadratic) oxygen inhibition function of denitrification on NO2 (kmol/m3) real, protected :: bkano2denit = 5.6e-6 ! Half-saturation constant for denitrification on NO2 (kmol/m3) ! === Denitrification step N2O -> N2 - real, protected :: ran2odenit = 0.16 ! Maximum growth rate denitrification on N2O at reference T (1/d -> 1/dt) + real, protected :: ran2odenit = 0.0005 ! Maximum growth rate denitrification on N2O at reference T (1/d -> 1/dt) real, protected :: q10an2odenit = 3. ! Q10 factor for denitrificationj on N2O (-) real, protected :: Trefan2odenit = 10. ! Reference temperature for denitrification on N2O (degr C) - real, protected :: bkoxan2odenit = 5.e-6 ! Half-saturation constant for (quadratic) oxygen inhibition function of denitrification on N2O (kmol/m3) - real, protected :: bkan2odenit = 1.e-6 ! Half-saturation constant for denitrification on N2O (kmol/m3) + real, protected :: bkoxan2odenit = 10e-6 ! Half-saturation constant for (quadratic) oxygen inhibition function of denitrification on N2O (kmol/m3) + real, protected :: bkan2odenit = 0.1e-6 ! Half-saturation constant for denitrification on N2O (kmol/m3) ! === DNRA NO2 -> NH4 - real, protected :: rdnra = 0.1 ! Maximum growth rate DNRA on NO2 at reference T (1/d -> 1/dt) + real, protected :: rdnra = 0.0003 ! Maximum growth rate DNRA on NO2 at reference T (1/d -> 1/dt) real, protected :: q10dnra = 2. ! Q10 factor for DNRA on NO2 (-) real, protected :: Trefdnra = 10. ! Reference temperature for DNRA (degr C) real, protected :: bkoxdnra = 2.5e-6 ! Half saturation constant for (quadratic) oxygen inhibition function of DNRA on NO2 (kmol/m3) @@ -347,7 +347,7 @@ module mo_param_bgc real, protected :: bkyamox = 0.333e-6 ! Half saturation constant for pathway splitting function OM-yield for nitrification on NH4 (kmol/m3) ! === Nitrification on NO2 - real, protected :: rano2nitr = 1.54 ! Maximum growth rate nitrification on NO2 at reference T (1/d -> 1/dt) + real, protected :: rano2nitr = 0.75 ! Maximum growth rate nitrification on NO2 at reference T (1/d -> 1/dt) real, protected :: q10ano2nitr = 2.7 ! Q10 factor for nitrification on NO2 (-) real, protected :: Trefano2nitr = 20. ! Reference temperature for nitrification on NO2 (degr C) real, protected :: bkoxnitr = 0.788e-6 ! Half-saturation constant for oxygen limitation of nitrification on NO2 (kmol/m3) From 83ae05db50aa4500fd2ce40d02cea82d2a555d9a Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Mon, 26 Feb 2024 18:38:27 +0100 Subject: [PATCH 348/366] Keep sign of sedlo division in mo_sedshi - eases working with sediment issues in 1D setup Tested on betzy and results in bit-identical results --- hamocc/mo_sedshi.F90 | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/hamocc/mo_sedshi.F90 b/hamocc/mo_sedshi.F90 index a3191429..1c32f8d5 100644 --- a/hamocc/mo_sedshi.F90 +++ b/hamocc/mo_sedshi.F90 @@ -79,7 +79,7 @@ subroutine sedshi(kpie,kpje,omask) & + oplfa*sedlay(i,j,k,issssil) & & + clafa*sedlay(i,j,k,issster) ! "full sediment has sedlo=1 - wsed(i,j)=max(0.,(sedlo-1.)/(sedlo+1.e-10)) + wsed(i,j)=max(0.,(sedlo-1.)/(abs(sedlo)+1.e-10)) endif enddo !end i-loop enddo !end j-loop @@ -120,7 +120,7 @@ subroutine sedshi(kpie,kpje,omask) & + calfa*sedlay(i,j,ks,isssc12) & & + oplfa*sedlay(i,j,ks,issssil) & & + clafa*sedlay(i,j,ks,issster) - wsed(i,j)=max(0.,(sedlo-1.)/(sedlo+1.e-10)) + wsed(i,j)=max(0.,(sedlo-1.)/(abs(sedlo)+1.e-10)) endif enddo !end i-loop enddo !end j-loop @@ -260,7 +260,7 @@ subroutine sedshi(kpie,kpje,omask) & + calfa*sedlay(i,j,k,isssc12) & & + oplfa*sedlay(i,j,k,issssil) & & + clafa*sedlay(i,j,k,issster) - wsed(i,j)=max(0.,(sedlo-1.)/(sedlo+1.e-10)) + wsed(i,j)=max(0.,(sedlo-1.)/(abs(sedlo)+1.e-10)) endif enddo !end i-loop enddo !end j-loop From 0b14dacafc610be300a7970b962dfbe8196cbd1c Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Tue, 27 Feb 2024 15:52:23 +0100 Subject: [PATCH 349/366] add sediment model parameters to namelist --- cime_config/namelist_definition_blom.xml | 260 +++++++++++++++++++++++ hamocc/mo_param_bgc.F90 | 13 +- 2 files changed, 271 insertions(+), 2 deletions(-) diff --git a/cime_config/namelist_definition_blom.xml b/cime_config/namelist_definition_blom.xml index f93ba508..09546c44 100644 --- a/cime_config/namelist_definition_blom.xml +++ b/cime_config/namelist_definition_blom.xml @@ -4389,6 +4389,36 @@ Maximum growth rate nitrification on NO2 at reference T (1/d) + + real + bgcparams + bgcparams + + None + + Sediment: remineralization rate (at reference temperature) (1/(kmol O2/m3 s)) + + + + real + bgcparams + bgcparams + + None + + Sediment: opal dissolution rate (1/(kmol Si(OH)4/m3 s)) + + + + real + bgcparams + bgcparams + + None + + Sediment: CaCO3 dissolution rate (1/(kmol CO3--/m3 s)) + + real bgcparams @@ -4459,6 +4489,236 @@ SEDIMENT: Maximum growth rate nitrification on NO2 at reference T (1/d) + + real + bgcparams + bgcparams + + None + + Sediment: Q10 factor for denitrification on NO3 (-) + + + + real + bgcparams + bgcparams + + None + + Sediment: Shape factor for NO3 denitrification oxygen inhibition function (m3/kmol) + + + + real + bgcparams + bgcparams + + None + + Sediment: Half-saturation constant for NO3 denitrification (kmol/m3) + + + + real + bgcparams + bgcparams + + None + + Sediment: Q10 factor for anammox (-) + + + + real + bgcparams + bgcparams + + None + + Sediment: Shape factor for anammox oxygen inhibition function (m3/kmol) + + + + real + bgcparams + bgcparams + + None + + Sediment: half saturation constant for O2 limitatio of ammonification in sediment (kmol/m3) + + + + real + bgcparams + bgcparams + + None + + Sediment: Anammox half-saturation constant for oxygen inhibition function (kmol/m3) + + + + real + bgcparams + bgcparams + + None + + Sediment: Anammox half-saturation constant for NO2 limitation (kmol/m3) + + + + real + bgcparams + bgcparams + + None + + Sediment: Q10 factor for denitrification on NO2 (-) + + + + real + bgcparams + bgcparams + + None + + Sediment: Half-saturation constant for (quadratic) oxygen inhibition function of denitrification on NO2 (kmol/m3) + + + + real + bgcparams + bgcparams + + None + + Sediment: Half-saturation constant for denitrification on NO2 (kmol/m3) + + + + real + bgcparams + bgcparams + + None + + Sediment: Q10 factor for denitrificationj on N2O (-) + + + + real + bgcparams + bgcparams + + None + + Sediment: Half-saturation constant for (quadratic) oxygen inhibition function of denitrification on N2O (kmol/m3) + + + + real + bgcparams + bgcparams + + None + + Sediment: Half-saturation constant for denitrification on N2O (kmol/m3) + + + + real + bgcparams + bgcparams + + None + + Sediment: Q10 factor for DNRA on NO2 (-) + + + + real + bgcparams + bgcparams + + None + + Sediment: Half saturation constant for (quadratic) oxygen inhibition function of DNRA on NO2 (kmol/m3) + + + + real + bgcparams + bgcparams + + None + + Sediment: Half-saturation constant for DNRA on NO2 (kmol/m3) + + + + real + bgcparams + bgcparams + + None + + Sediment: Q10 factor for nitrification on NH4 (-) + + + + real + bgcparams + bgcparams + + None + + Sediment: Half-saturation constant for oxygen limitation of nitrification on NH4 (kmol/m3) + + + + real + bgcparams + bgcparams + + None + + Sediment: Half-saturation constant for nitrification on NH4 (kmol/m3) + + + + real + bgcparams + bgcparams + + None + + Sediment: Q10 factor for nitrification on NO2 (-) + + + + real + bgcparams + bgcparams + + None + + Sediment: Half-saturation constant for oxygen limitation of nitrification on NO2 (kmol/m3) + + + + real + bgcparams + bgcparams + + None + + Sediment: Half-saturation constant for NO2 for nitrification on NO2 (kmol/m3) + + real bgcparams diff --git a/hamocc/mo_param_bgc.F90 b/hamocc/mo_param_bgc.F90 index 7d7b87d2..5ac5f96c 100644 --- a/hamocc/mo_param_bgc.F90 +++ b/hamocc/mo_param_bgc.F90 @@ -358,7 +358,7 @@ module mo_param_bgc ! === Ammonification in the sediment real, protected :: POM_remin_q10_sed = 2.1 ! ammonification Q10 in sediment real, protected :: POM_remin_Tref_sed = 10. ! ammonification Tref in sediment - real, protected :: bkox_drempoc_sed = 1e-7 ! half saturation constant for O2 limitatio of ammonification in sediment + real, protected :: bkox_drempoc_sed = 1e-7 ! half saturation constant for O2 limitatio of ammonification in sediment (kmol/m3) ! === Denitrification step NO3 -> NO2: real, protected :: rano3denit_sed = 0.05 ! Maximum growth rate denitrification on NO3 at reference T (1/d -> 1/dt) @@ -601,6 +601,7 @@ subroutine read_bgcnamelist() ecan,zinges,epsher,bkopal,rcalc,ropal, & remido,drempoc,dremopal,dremn2o,dremsul,fetune,relaxfe, & wmin,wmax,wlin,wpoc_const,wcal_const,wopal_const, & + disso_poc,disso_sil,disso_caco3, & rano3denit,rano2anmx,rano2denit,ran2odenit,rdnra, & ranh4nitr,rano2nitr,rano3denit_sed,rano2anmx_sed, & rano2denit_sed,ran2odenit_sed,rdnra_sed,ranh4nitr_sed, & @@ -610,7 +611,15 @@ subroutine read_bgcnamelist() bkoxanmx,bkano2anmx,q10ano2denit, & bkoxano2denit,bkano2denit,q10an2odenit,bkoxan2odenit, & bkan2odenit,q10dnra,bkoxdnra,bkdnra,q10anh4nitr, & - bkoxamox,bkanh4nitr,q10ano2nitr,bkoxnitr,bkano2nitr + bkoxamox,bkanh4nitr,q10ano2nitr,bkoxnitr,bkano2nitr, & + q10ano3denit_sed,sc_ano3denit_sed,bkano3denit_sed, & + q10anmx_sed,alphaanmx_sed,bkox_drempoc_sed, & + bkoxanmx_sed,bkano2anmx_sed,q10ano2denit_sed, & + bkoxano2denit_sed,bkano2denit_sed,q10an2odenit_sed, & + bkoxan2odenit_sed,bkan2odenit_sed,q10dnra_sed, & + bkoxdnra_sed,bkdnra_sed,q10anh4nitr_sed, & + bkoxamox_sed,bkanh4nitr_sed,q10ano2nitr_sed, & + bkoxnitr_sed,bkano2nitr_sed if (mnproc.eq.1) then write(io_stdo_bgc,*) From d6f1ec513c5b498a9cea475b3f17561380433ed2 Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Tue, 12 Mar 2024 17:40:28 +0100 Subject: [PATCH 350/366] fix spaces --- hamocc/mo_extNsediment.F90 | 4 ++-- hamocc/mo_ncout_hamocc.F90 | 2 +- hamocc/mo_sedshi.F90 | 2 +- 3 files changed, 4 insertions(+), 4 deletions(-) diff --git a/hamocc/mo_extNsediment.F90 b/hamocc/mo_extNsediment.F90 index 4ea85cea..546ae10e 100644 --- a/hamocc/mo_extNsediment.F90 +++ b/hamocc/mo_extNsediment.F90 @@ -17,12 +17,12 @@ module mo_extNsediment !********************************************************************** - ! + ! ! MODULE mo_extNsediment - extended nitrogen cycle processes ! in the sediment ! ! j.maerz 13.09.2022 - ! + ! ! Pupose: ! ------- ! - representation of microbial processes diff --git a/hamocc/mo_ncout_hamocc.F90 b/hamocc/mo_ncout_hamocc.F90 index 88bb4c7b..a8f2fe46 100644 --- a/hamocc/mo_ncout_hamocc.F90 +++ b/hamocc/mo_ncout_hamocc.F90 @@ -885,7 +885,7 @@ subroutine ncwrt_bgc(iogrp) call inisrf(joxflux(iogrp),0.) call inisrf(jniflux(iogrp),0.) call inisrf(jn2ofx(iogrp),0.) - call inisrf(jsrfpn2om(iogrp),0.) + call inisrf(jsrfpn2om(iogrp),0.) call inisrf(jdms(iogrp),0.) call inisrf(jdmsprod(iogrp),0.) call inisrf(jdms_bac(iogrp),0.) diff --git a/hamocc/mo_sedshi.F90 b/hamocc/mo_sedshi.F90 index 1c32f8d5..82034f50 100644 --- a/hamocc/mo_sedshi.F90 +++ b/hamocc/mo_sedshi.F90 @@ -44,7 +44,7 @@ subroutine sedshi(kpie,kpje,omask) use mo_param_bgc, only: rcar use mo_param1_bgc, only: isssc12,issssil,issso12,issster,ks,nsedtra,isssc13,isssc14, & issso13,issso14 - use mo_carbch, only: sedfluxb + use mo_carbch, only: sedfluxb use mo_control_bgc, only: use_cisonew ! Arguments From d54b65da00aee4a1836ac7500602f31f680f8200 Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Tue, 28 May 2024 13:37:06 +0200 Subject: [PATCH 351/366] Modularized M4AGO - now becoming a submodule --- .gitmodules | 3 + Externals_BLOM.cfg | 7 + hamocc/meson.build | 3 +- hamocc/mo_accfields.F90 | 2 +- hamocc/mo_hamocc_init.F90 | 3 +- hamocc/mo_m4ago.F90 | 928 -------------------------------------- hamocc/mo_ocprod.F90 | 4 +- pkgs/M4AGO-sinking-scheme | 1 + pkgs/meson.build | 4 + 9 files changed, 21 insertions(+), 934 deletions(-) delete mode 100644 hamocc/mo_m4ago.F90 create mode 160000 pkgs/M4AGO-sinking-scheme diff --git a/.gitmodules b/.gitmodules index 18c11683..f3288b67 100644 --- a/.gitmodules +++ b/.gitmodules @@ -1,3 +1,6 @@ [submodule "CVMix-src"] path = pkgs/CVMix-src url = git@github.com:CVMix/CVMix-src.git +[submodule "pkgs/M4AGO-sinking-scheme"] + path = pkgs/M4AGO-sinking-scheme + url = git@github.com:jmaerz/M4AGO-sinking-scheme diff --git a/Externals_BLOM.cfg b/Externals_BLOM.cfg index 7952afd5..c8da301e 100644 --- a/Externals_BLOM.cfg +++ b/Externals_BLOM.cfg @@ -5,5 +5,12 @@ repo_url = https://github.com/CVMix/CVMix-src local_path = pkgs/CVMix-src required = True +[M4AGO] +tag = dev-1.0.0 +protocol = git +repo_url = https://github.com/jmaerz/M4AGO-sinking-scheme +local_path = pkgs/M4AGO-sinking-scheme +required = True + [externals_description] schema_version = 1.0.0 diff --git a/hamocc/meson.build b/hamocc/meson.build index 8876e53e..a9c240e5 100644 --- a/hamocc/meson.build +++ b/hamocc/meson.build @@ -45,5 +45,4 @@ sources += files( 'mo_sedshi.F90', 'mo_trc_limitc.F90', 'mo_extNwatercol.F90', - 'mo_extNsediment.F90', - 'mo_m4ago.F90') + 'mo_extNsediment.F90') diff --git a/hamocc/mo_accfields.F90 b/hamocc/mo_accfields.F90 index 5469193d..ed5ec071 100644 --- a/hamocc/mo_accfields.F90 +++ b/hamocc/mo_accfields.F90 @@ -146,7 +146,7 @@ subroutine accfields(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask) use mo_vgrid, only: dp_min use mo_inventory_bgc, only: inventory_bgc use mo_ncwrt_bgc , only: ncwrt_bgc - use mo_m4ago, only: aggregate_diagnostics,kav_dp,kav_rho_p,kav_d_C,kws_agg,kdf_agg, & + use mo_ihamocc4m4ago, only: aggregate_diagnostics,kav_dp,kav_rho_p,kav_d_C,kws_agg,kdf_agg, & kstickiness_agg,kb_agg,kstickiness_frustule,kLmax_agg,kdynvis, & kav_rhof_V,kav_por_V use mo_extNsediment, only: extNsed_diagnostics,ised_nitr_NH4,ised_nitr_NO2,ised_nitr_N2O_prod,& diff --git a/hamocc/mo_hamocc_init.F90 b/hamocc/mo_hamocc_init.F90 index fe8a6faf..45caa09b 100644 --- a/hamocc/mo_hamocc_init.F90 +++ b/hamocc/mo_hamocc_init.F90 @@ -64,8 +64,9 @@ subroutine hamocc_init(read_rest,rstfnm_hamocc) sedlay2,powtra2,burial2,blom2hamocc,atm2 use mo_ini_fields, only: ini_fields_ocean,ini_fields_atm use mo_aufr_bgc, only: aufr_bgc - use mo_m4ago, only: alloc_mem_m4ago,init_m4ago_nml_params, init_m4ago_params use mo_extNsediment,only: alloc_mem_extNsediment_diag +! use mo_m4ago, only: init_m4ago_nml_params, init_m4ago_params + use mo_ihamocc4m4ago, only: alloc_mem_m4ago,init_m4ago_nml_params, init_m4ago_params ! Arguments diff --git a/hamocc/mo_m4ago.F90 b/hamocc/mo_m4ago.F90 deleted file mode 100644 index 87a0ba43..00000000 --- a/hamocc/mo_m4ago.F90 +++ /dev/null @@ -1,928 +0,0 @@ -!> -!! @par (c) Copyright -!! This software is provided under: -!! -!! The 3-Clause BSD License -!! SPDX short identifier: BSD-3-Clause -!! See https://opensource.org/licenses/BSD-3-Clause -!! -!! (c) Copyright 2016-2021 MPI-M, Joeran Maerz, Irene Stemmler; -!! first published 2020 -!! -!! Redistribution and use in source and binary forms, with or without -!! modification, are permitted provided that the following conditions are met: -!! -!! 1. Redistributions of source code must retain the above copyright notice, -!! this list of conditions and the following disclaimer. -!! 2. Redistributions in binary form must reproduce the above copyright notice, -!! this list of conditions and the following disclaimer in the documentation -!! and/or other materials provided with the distribution. -!! 3. Neither the name of the copyright holder nor the names of its contributors -!! may be used to endorse or promote products derived from this software -!! without specific prior written permission. -!! -!! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" -!! AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE -!! IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE -!! ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE -!! LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -!! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -!! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -!! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -!! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -!! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -!! POSSIBILITY OF SUCH DAMAGE.[7] -!! -!! -!! ----------------------------------------------------------------------------- -!! ----------------------------------------------------------------------------- -!! @file mo_m4ago.F90 -!! @brief Module for Marine Aggregates: -!! The Microstructure, Multiscale, Mechanistic, Marine Aggregates -!! in the Global Ocean (M4AGO) sinking scheme -!! -!! The mo_aggregates module contains routines to calculate: -!! - aggregate properties -!! - mean sinking velocity of aggregates -!! -!! See: -!! Maerz et al. 2020: Microstructure and composition of marine aggregates -!! as co-determinants for vertical particulate organic -!! carbon transfer in the global ocean. -!! Biogeosciences, 17, 1765-1803, -!! https://doi.org/10.5194/bg-17-1765-2020 -!! -!! This module is written within the project: -!! Multiscale Approach on the Role of Marine Aggregates (MARMA) -!! funded by the Max Planck Society (MPG) -!! -!! @author: joeran maerz (joeran.maerz@mpimet.mpg.de), MPI-M, HH -!! 2019, June, revised by Irene Stemmler (refactoring, cleaning), MPI-M, HH -!! -!! 2023 adopted to iHAMOCC by joeran maerz, UiB, Bergen -!! -!! ----------------------------------------------------------------------------- -!! ----------------------------------------------------------------------------- -!! -!! - - - -module mo_m4ago - use mo_vgrid, only: dp_min - use mo_control_bgc, only: dtb, dtbgc,io_stdo_bgc - use mo_param_bgc, only: calcdens, claydens, opaldens, calcwei, opalwei, ropal - use mo_carbch, only: ocetra - use mo_param1_bgc, only: iopal, ifdust, icalc, idet - - implicit none - - private - - ! Public subroutines - public :: mean_aggregate_sinking_speed, init_m4ago_nml_params, init_m4ago_params, alloc_mem_m4ago - - ! Public fields and parameters - public :: ws_agg,& - & aggregate_diagnostics,kav_dp,kav_rho_p,kav_d_C,kws_agg,kdf_agg,kstickiness_agg,kb_agg, & - & kstickiness_frustule,kLmax_agg,kdynvis,kav_rhof_V,kav_por_V - - integer :: i,j,k - - - ! model parameters - ! primary particle diameter for POM & PIM species involved in parametrized aggregation (m) - real :: dp_dust ! primary particle diameter dust - real :: dp_det ! primary particle diameter detritus - real :: dp_calc ! primary particle diameter calc - real :: dp_opal ! primary particle diameter opal - real :: stickiness_TEP ! stickiness of TEP (related to opal frustules) - real :: stickiness_det ! normal detritus stickiness - real :: stickiness_opal ! stickiness of opal (without TEP - just normal coating) - real :: stickiness_calc ! stickiness of calc particles (coated with organics) - real :: stickiness_dust ! stickiness of dust particles (coated with organics) - real :: agg_df_max ! maximum fractal dimension of aggregates (~2.5) - real :: agg_df_min ! minimum fractal dimension of aggregates (~1.2 - 1.6) - real :: rho_TEP ! density of TEP particles - real :: agg_org_dens ! organic detritus density (alternative to orgdens to avoid negative ws) - - real :: agg_Re_crit ! critical particle Reynolds number for nr-distribution limiting - real :: POM_remin_q10 ! Q10 factor for organic remineralization (POC) - real :: POM_remin_Tref - real :: opal_remin_q10 ! Q10 factor for silicate remineralization (OPAL) - real :: opal_remin_Tref - - real,allocatable :: av_dp(:,:,:), & ! mean primary particle diameter - & av_rho_p(:,:,:), & ! mean primary particle density - & df_agg(:,:,:), & ! fractal dimension of aggregates - & b_agg(:,:,:), & ! aggregate number distribution slope - & Lmax_agg(:,:,:), & ! maximum diameter of aggregates - & ws_agg(:,:,:), & ! aggregate mean sinking velocity - & stickiness_agg(:,:,:), & ! mean aggregate stickiness - & stickiness_frustule(:,:,:),& ! frustule stickiness - & N_agg(:,:,:), & ! Number of aggregates - & av_d_C(:,:,:), & ! concentration-weighted mean diameter of aggs - & dyn_vis(:,:,:), & ! molecular dynamic viscosity - & m4ago_ppo(:,:,:) ! pressure - - integer, parameter :: & - kav_dp = 1, & - kav_rho_p = 2, & - kav_d_C = 3, & - kws_agg = 4, & - kdf_agg = 5, & - kstickiness_agg = 6, & - kb_agg = 7, & - kstickiness_frustule = 8, & - kLmax_agg = 9, & - kdynvis = 10, & - kav_rhof_V = 11, & - kav_por_V = 12, & - naggdiag = 12 - - real, dimension (:,:,:,:), allocatable, target :: aggregate_diagnostics ! 3d concentration EU - - - - ! Internally used parameters and values - real, parameter :: ONE_SIXTH = 1./6. - real, parameter :: PI = 3.141592654 - real, parameter :: NUM_FAC = 1.e9 ! factor to avoid numerical precision problems - real, parameter :: EPS_ONE = EPSILON(1.) - - real :: det_mol2mass ! mol detritus P/m^3 to kg POM /m^3 (according to stoichiometry) - real :: AJ1, AJ2, AJ3, BJ1, BJ2, BJ3 ! constants for CD - real :: grav_acc_const ! gravitational acceleration constant - real :: rho_aq ! water reference density (1025 kg/m^3) - real :: n_det,n_opal,n_calc,n_dust ! total primary particle number (#) - real :: mf ! mass factor for aggregates - real :: V_dp_dust,V_dp_det,V_dp_calc,V_dp_opal ! volumes of primary particles (L^3) - real :: A_dp_dust,A_dp_det,A_dp_calc,A_dp_opal ! surface areas of primary particles (L^2) - real :: A_dust,A_det,A_calc,A_opal,A_total ! total surface area of primary particles per unit volume (L^2/L^3) - real :: stickiness_min, stickiness_max ! minimum and maximum stickiness of primary particles - real :: stickiness_mapped ! mapped mean stickiness of particles on range (0,1) - real :: df_slope ! slope for stickiness to fractal dimension mapping - real :: rho_V_dp_dust,rho_V_dp_det,rho_V_dp_calc ! rho_V_dp_opal ! mass of primary particles (M) - real :: V_det,V_opal,V_calc,V_dust,V_solid ! total volume of primary particles in a unit volume (L^3/L^3) - real :: Rm_SiP ! molar mass ratio opal (SiO_2) to POM - real :: thick_shell ! diatom frustule shell thickness (L) - real :: d_frustule_inner ! diameter of hollow part in diatom frustule (L) - real :: V_frustule_inner ! volume of hollow part in diatom frustule (L^3) - real :: V_frustule_opal ! volume of opal shell material (L^3) - real :: rho_V_frustule_opal ! mass of frustule material (M) - real :: cell_det_mass ! mass of detritus material in diatoms - real :: cell_pot_det_mass ! potential (max) mass detritus material in diatoms - real :: free_detritus ! freely available detritus mass outside the frustule - real :: V_POM_cell ! volume of POM in frustule - real :: V_aq ! volume of water space in frustule - real :: rho_frustule ! density of diatom frustule incl. opal, detritus and water - real :: rho_diatom ! density of either hollow frustule - -contains - - !===================================================================================== m4ago_init_params - subroutine init_m4ago_nml_params - !> - !! Initialization of namelist parameters - !! - implicit none - ! Primary particle sizes - dp_dust = 2.e-6 ! following the classical HAMOCC parametrization - dp_det = 4.e-6 ! not well defined - dp_calc = 3.e-6 ! following Henderiks 2008, Henderiks & Pagani 2008 - dp_opal = 20.e-6 ! rough guestimate - literature search required - - ! Stickiness values - stickiness_TEP = 0.19 - stickiness_det = 0.1 - stickiness_opal = 0.08 - stickiness_calc = 0.09 - stickiness_dust = 0.07 - - ! minimum and maximum aggregate fractal dimension - agg_df_min = 1.6 - agg_df_max = 2.4 - - ! Density of primary particles - rho_TEP = 800. ! 700.-840. kg/m^3 Azetsu-Scott & Passow 2004 - agg_org_dens = 1100. ! detritus density - don't use orgdens to avoid negative ws - - agg_Re_crit = 20. ! critical particle Reynolds number for limiting nr-distribution - - end subroutine init_m4ago_nml_params - - subroutine init_m4ago_params - !> - !! Initilization of parameters - !! - - implicit none - det_mol2mass = 3166. ! mol detritus P/m^3 to kg POM /m^3 (according to stoichiometry) - grav_acc_const = 9.81 ! gravitational acceleration constant - rho_aq = 1025. ! water reference density (1025 kg/m^3) - - ! CD parameters (formula 16) - AJ1 = 24.00 - AJ2 = 29.03 - AJ3 = 14.15 - BJ1 = 1.0 - BJ2 = 0.871 - BJ3 = 0.547 - - V_dp_dust = ONE_SIXTH*PI*dp_dust**3.*NUM_FAC - V_dp_det = ONE_SIXTH*PI*dp_det**3.*NUM_FAC - V_dp_calc = ONE_SIXTH*PI*dp_calc**3.*NUM_FAC - V_dp_opal = ONE_SIXTH*PI*dp_opal**3.*NUM_FAC - A_dp_dust = PI*dp_dust**2.*NUM_FAC - A_dp_det = PI*dp_det**2.*NUM_FAC - A_dp_calc = PI*dp_calc**2.*NUM_FAC - A_dp_opal = PI*dp_opal**2.*NUM_FAC - - rho_V_dp_dust = V_dp_dust*claydens - rho_V_dp_det = V_dp_det*agg_org_dens - rho_V_dp_calc = V_dp_calc*calcdens - - Rm_SiP = ropal*opalwei/det_mol2mass - ! shell thickness - thick_shell = 0.5*dp_opal*(1. - (opaldens/(Rm_SiP*agg_org_dens+opaldens))**(1./3.)) - d_frustule_inner = dp_opal - 2.*thick_shell - ! volume of hollow part of frustule - V_frustule_inner = ONE_SIXTH* PI*d_frustule_inner**3.*NUM_FAC - ! volume of opal part of frustule - V_frustule_opal = ONE_SIXTH*PI*(dp_opal**3. - d_frustule_inner**3.)*NUM_FAC - rho_V_frustule_opal = V_frustule_opal*opaldens - - stickiness_min = min(stickiness_TEP, stickiness_det, stickiness_opal, stickiness_calc, stickiness_dust) - stickiness_max = max(stickiness_TEP, stickiness_det, stickiness_opal, stickiness_calc, stickiness_dust) - df_slope = log(agg_df_min / agg_df_max) - end subroutine init_m4ago_params - - - subroutine alloc_mem_m4ago(kpie, kpje, kpke) - !----------------------------------------------------------------------- - !> - !! Initialization/allocation fields - !! Called in ini_bgc after read_namelist - !! - - implicit none - - integer, intent(in) :: kpie !< 1st real of model grid. - integer, intent(in) :: kpje !< 2nd real of model grid. - integer, intent(in) :: kpke !< 3rd (vertical) real of model grid. - - ! allocate memory space for aggregate properties - allocate(av_dp(kpie,kpje,kpke)) - allocate(av_rho_p(kpie,kpje,kpke)) - allocate(df_agg(kpie,kpje,kpke)) - allocate(b_agg(kpie,kpje,kpke)) - allocate(Lmax_agg(kpie,kpje,kpke)) - allocate(av_d_C(kpie,kpje,kpke)) - allocate(stickiness_agg(kpie,kpje,kpke)) - allocate(stickiness_frustule(kpie,kpje,kpke)) - allocate(aggregate_diagnostics(kpie, kpje, kpke, naggdiag)) - - ! mean sinking velocity - allocate(ws_agg(kpie,kpje,kpke)) - - ! molecular dynamic viscosity - allocate(dyn_vis(kpie, kpje, kpke)) - allocate(m4ago_ppo(kpie,kpje,kpke)) - - av_dp = 0. - av_rho_p = 0. - df_agg = 0. - b_agg = 0. - Lmax_agg = 0. - av_d_C = 0. - stickiness_agg = 0. - stickiness_frustule = 0. - aggregate_diagnostics = 0. - m4ago_ppo = 0. - - end subroutine alloc_mem_m4ago - - subroutine cleanup_mem_m4ago - deallocate(av_dp) - deallocate(av_rho_p) - deallocate(df_agg) - deallocate(b_agg) - deallocate(Lmax_agg) - deallocate(av_d_C) - deallocate(stickiness_agg) - deallocate(stickiness_frustule) - deallocate(aggregate_diagnostics) - deallocate(ws_agg) - deallocate(dyn_vis) - deallocate(m4ago_ppo) - end subroutine cleanup_mem_m4ago - - !===================================================================================== pressure - subroutine calc_pressure(kpie, kpje, kpke,kbnd, pddpo,omask) - - use mo_vgrid, only: ptiestu - - implicit none - - integer, intent(in) :: kpie !< 1st real of model grid. - integer, intent(in) :: kpje !< 2nd real of model grid. - integer, intent(in) :: kpke !< 3rd (vertical) real of model grid. - integer, intent(in) :: kbnd - real, intent(in) :: pddpo(kpie,kpje,kpke) !< size of scalar grid cell (3rd dimension) [m] - real, intent(in) :: omask(kpie,kpje) !< mask - - !$OMP PARALLEL DO PRIVATE(i,j,k) - do k = 1,kpke - do j = 1,kpje - do i = 1,kpie - if(omask(i,j) > 0.5 .and. pddpo(i,j,k).gt.dp_min) then - m4ago_ppo(i,j,k) = 1e5 * ptiestu(i,j,k)*98060.*1.027e-6 ! pressure in unit Pa, 98060 = onem - endif - enddo - enddo - enddo - !$OMP END PARALLEL DO - end subroutine calc_pressure - - !===================================================================================== mean_agg_ws - subroutine mean_aggregate_sinking_speed(kpie, kpje, kpke, kbnd, pddpo, omask, ptho, psao, ppao, prho) - !----------------------------------------------------------------------- - !> - !! calculates the mass concentration-weighted mean sinking velocity of marine - !! aggregates - !! - - implicit none - - integer, intent(in) :: kpie !< 1st real of model grid. - integer, intent(in) :: kpje !< 2nd real of model grid. - integer, intent(in) :: kpke !< 3rd (vertical) real of model grid. - integer, intent(in) :: kbnd - real, intent(in) :: pddpo(kpie,kpje,kpke) !< size of scalar grid cell (3rd dimension) [m] - real, intent(in) :: omask(kpie,kpje) - real, intent(in) :: ptho (1-kbnd:kpie+kbnd,1-kbnd:kpje+kbnd,kpke) !< potential temperature [deg C] - real, intent(in) :: psao (1-kbnd:kpie+kbnd,1-kbnd:kpje+kbnd,kpke) !< salinity [psu.]. - real, intent(in) :: ppao (1-kbnd:kpie+kbnd,1-kbnd:kpje+kbnd) !< pressure at sea level [Pa]. - real, intent(in) :: prho (kpie,kpje,kpke) !< density [g/cm3] - - call calc_pressure(kpie, kpje, kpke,kbnd, pddpo, omask) - - ! molecular dynamic viscosity - call dynvis(kpie, kpje, kpke, kbnd, pddpo, omask, ptho, psao, m4ago_ppo) - - ! ======== calculate the mean sinking velocity of aggregates ======= - call aggregate_properties(kpie, kpje, kpke, kbnd, pddpo, omask, ptho) - call ws_Re_approx(kpie, kpje, kpke, pddpo, omask) - - !$OMP PARALLEL DO PRIVATE(i,j,k) - do j = 1,kpje - do i = 1,kpie - do k = 1,kpke - if(pddpo(i,j,k) > dp_min .and. omask(i,j) > 0.5) then - ! Limit settling velocity wrt CFL: - ws_agg(i,j,k) = min(ws_agg(i,j,k), 0.99*pddpo(i,j,k)) - - ! ============================== Write general diagnostics ============ - ! ----- settling velocity-related ----- - aggregate_diagnostics(i,j,k,kws_agg) = ws_agg(i,j,k)/dtb ! applied ws conversion m/time_step to m/d for output - - ! ----- settling environment ----- - aggregate_diagnostics(i,j,k,kdynvis) = dyn_vis(i,j,k) ! dynamic viscosity - - ! ----- aggregate properties ----- - av_d_C(i,j,k) = (1. + df_agg(i,j,k) - b_agg(i,j,k)) & - & /(2. + df_agg(i,j,k) - b_agg(i,j,k)) & - & *(Lmax_agg(i,j,k)**(2. + df_agg(i,j,k) - b_agg(i,j,k)) & - & - av_dp(i,j,k)**(2. + df_agg(i,j,k) - b_agg(i,j,k))) & - & / (Lmax_agg(i,j,k)**(1.+df_agg(i,j,k)-b_agg(i,j,k)) & - & - av_dp(i,j,k)**(1. + df_agg(i,j,k)-b_agg(i,j,k))) - - aggregate_diagnostics(i,j,k,kstickiness_agg) = stickiness_agg(i,j,k) ! aggre. stickiness - aggregate_diagnostics(i,j,k,kstickiness_frustule) = stickiness_frustule(i,j,k) ! frustule stickiness - - aggregate_diagnostics(i,j,k,kLmax_agg) = Lmax_agg(i,j,k) ! applied max. diameter - aggregate_diagnostics(i,j,k,kav_dp) = av_dp(i,j,k) ! mean primary particle diameter - aggregate_diagnostics(i,j,k,kav_rho_p) = av_rho_p(i,j,k) ! mean primary particle density - aggregate_diagnostics(i,j,k,kav_d_C) = av_d_C(i,j,k) ! conc-weighted mean agg. diameter - aggregate_diagnostics(i,j,k,kdf_agg) = df_agg(i,j,k) ! aggregate fractal dim - aggregate_diagnostics(i,j,k,kb_agg) = b_agg(i,j,k) ! aggre number distr. slope - - ! volume-weighted aggregate density - aggregate_diagnostics(i,j,k,kav_rhof_V) = (av_rho_p(i,j,k)-rho_aq)*av_dp(i,j,k)**(3.-df_agg(i,j,k)) & - & *(4.-b_agg(i,j,k))*(Lmax_agg(i,j,k)**(1.+df_agg(i,j,k)-b_agg(i,j,k)) & - & - av_dp(i,j,k)**(1.+df_agg(i,j,k)-b_agg(i,j,k))) & - & / ((1.+df_agg(i,j,k)-b_agg(i,j,k)) & - & *(Lmax_agg(i,j,k)**(4.-b_agg(i,j,k)) - av_dp(i,j,k)**(4.-b_agg(i,j,k)))) + rho_aq - - ! volume-weighted aggregate porosity - aggregate_diagnostics(i,j,k,kav_por_V) = 1. - ((4.-b_agg(i,j,k)) & - & *av_dp(i,j,k)**(3.-df_agg(i,j,k)) & - & *(Lmax_agg(i,j,k)**(1.+df_agg(i,j,k)-b_agg(i,j,k)) & - & - av_dp(i,j,k)**(1.+df_agg(i,j,k)-b_agg(i,j,k)))) & - & / ((1.+df_agg(i,j,k)-b_agg(i,j,k)) & - & *(Lmax_agg(i,j,k)**(4.-b_agg(i,j,k)) - av_dp(i,j,k)**(4.-b_agg(i,j,k)))) - endif - enddo - enddo - enddo - end subroutine mean_aggregate_sinking_speed - - !===================================================================================== aggregate_properties - subroutine aggregate_properties(kpie, kpje, kpke, kbnd, pddpo, omask, ptho) - !----------------------------------------------------------------------- - !> - !! aggregate_properties calculates - !! - mean stickiness/aggrega - !! - fractal dimension - !! - slope of aggregate spectrum - !! - mean primary particle diameter - !! - mean primary particle density - !! - maximum aggregate diameter - !! - - implicit none - - integer, intent(in) :: kpie !< 1st real of model grid. - integer, intent(in) :: kpje !< 2nd real of model grid. - integer, intent(in) :: kpke !< 3rd (vertical) real of model grid. - integer, intent(in) :: kbnd - real, intent(in) :: pddpo(kpie,kpje,kpke) !< size of scalar grid cell (3rd dimension) [m] - real, intent(in) :: omask(kpie,kpje) - real, intent(in) :: ptho (1-kbnd:kpie+kbnd,1-kbnd:kpje+kbnd,kpke) !< potential temperature [deg C] - - real :: C_det,C_opal,C_calc,C_dust - !$OMP PARALLEL DO PRIVATE(i,j,k,C_det,C_opal,C_calc,C_dust,n_det,n_opal,n_dust,n_calc,mf,V_det,& - !$OMP V_opal,V_calc,V_dust,V_solid,free_detritus,rho_diatom,cell_det_mass, & - !$OMP cell_pot_det_mass,V_POM_cell,V_aq,rho_frustule,A_det,A_opal, & - !$OMP A_calc,A_dust,A_total,stickiness_mapped) - do j = 1,kpje - do i = 1,kpie - do k = 1,kpke - if(pddpo(i,j,k) > dp_min .and. omask(i,j) > 0.5) then - C_det = 0. - C_opal = 0. - C_calc = 0. - C_dust = 0. - - C_det = abs(ocetra(i,j,k,idet)) - C_opal = abs(ocetra(i,j,k,iopal)) - C_calc = abs(ocetra(i,j,k,icalc)) - C_dust = abs(ocetra(i,j,k,ifdust)) - - n_det = 0. ! number of primary particles - n_opal = 0. - n_dust = 0. - n_calc = 0. - mf = 0. - - V_det = 0. ! total volume of primary particles in a unit volume - V_opal = 0. - V_calc = 0. - V_dust = 0. - V_solid = 0. - - free_detritus = 0. - rho_diatom = 0. - ! n_det are detritus primary particle that are - ! NOT linked to any diatom frustule - ! n_opal are number of frustule-like primary particles possessing - ! a density i) different from pure opal ii) due to a mixture of - ! opal frustule, detritus inside the frustule and potentially water - ! inside the frustule - - ! describing diatom frustule as hollow sphere - ! that is completely or partially filled with detritus - ! and water - cell_det_mass = 0. - cell_pot_det_mass = 0. - V_POM_cell = 0. - V_aq = 0. - rho_frustule = 0. - - ! number of opal frustules (/NUM_FAC) - n_opal = C_opal*opalwei/rho_V_frustule_opal - ! maximum mass of detritus inside a frustule - cell_pot_det_mass = n_opal*V_frustule_inner*agg_org_dens - - ! detritus mass inside frustules - cell_det_mass = min(cell_pot_det_mass, C_det*det_mol2mass - EPS_ONE) - - ! volume of detritus component in cell - V_POM_cell = (cell_det_mass/n_opal)/agg_org_dens - - ! if not detritus is available, water is added - V_aq = V_frustule_inner - V_POM_cell - - ! density of the diatom frsutules incl. opal, detritus and water - rho_frustule = (rho_V_frustule_opal + cell_det_mass/n_opal + V_aq*rho_aq)/V_dp_opal - - ! mass of extra cellular detritus particles - free_detritus = C_det*det_mol2mass - cell_det_mass - rho_diatom = (rho_frustule + cell_det_mass/cell_pot_det_mass*rho_TEP) & - /(1. + cell_det_mass/cell_pot_det_mass) - - ! number of primary particles - n_det = free_detritus/rho_V_dp_det ! includes NUM_FAC - n_calc = C_calc*calcwei/rho_V_dp_calc - n_dust = C_dust/rho_V_dp_dust ! dust is in kg/m3 - - ! primary particles surface weighted stickiness is mapped - ! on range between 0 and 1 - ! fractal dimension of aggregates is based on that mapped df - ! number distribution slope b is based on df - - ! calc total areas - A_det = n_det*A_dp_det - A_opal = n_opal*A_dp_opal - A_calc = n_calc*A_dp_calc - A_dust = n_dust*A_dp_dust - A_total = A_det + A_opal + A_calc + A_dust - - ! calc frustule stickiness - stickiness_frustule(i,j,k) = cell_det_mass/(cell_pot_det_mass +EPS_ONE)*stickiness_TEP & - & + (1. - cell_det_mass/(cell_pot_det_mass + EPS_ONE)) & - & *stickiness_opal - - ! calc mean stickiness - stickiness_agg(i,j,k) = stickiness_frustule(i,j,k)*A_opal & - & + stickiness_det*A_det & - & + stickiness_calc*A_calc & - & + stickiness_dust*A_dust - - stickiness_agg(i,j,k) = stickiness_agg(i,j,k)/(A_total+EPS_ONE) - - stickiness_mapped = (stickiness_agg(i,j,k) - stickiness_min) & - & /(stickiness_max - stickiness_min) - - df_agg(i,j,k) = agg_df_max*exp(df_slope*stickiness_mapped) - - ! Slope is here positive defined (as n(d)~d^-b), so *-1 of - ! Jiang & Logan 1991: Fractal dimensions of aggregates - ! determined from steady-state size distributions. - ! Environ. Sci. Technol. 25, 2031-2038. - ! - ! See also: - ! Hunt 1980: Prediction of oceanic particle size distributions - ! from coagulation and sedimentation mechanisms. - ! - ! Additional assumptions made here: - ! b in Jiang & Logan (used for Re < 0.1: b=1 - ! for 0.1 < Re < 10 : b=0.871 - ! for 10 < Re < 100 : b=0.547) - ! is set to 0.871 as an 'average for our range of 0 Formulation in Jiang & Logan 1991: - ! slope = -0.5*(3+df+(2+df-D2)/(2-b)) reduces to: - - b_agg(i,j,k) = 0.5*(3. + df_agg(i,j,k) & - & + (2. + df_agg(i,j,k) - min(2., df_agg(i,j,k)))/(2. - BJ2)) - - ! careful: for df=1.5904: b_agg=2*df where w_s is undefined. - - ! total volume of primary particles - V_det = n_det*V_dp_det*NUM_FAC - V_opal = n_opal*V_dp_opal*NUM_FAC - V_calc = n_calc*V_dp_calc*NUM_FAC - V_dust = n_dust*V_dp_dust*NUM_FAC - V_solid = V_det + V_opal + V_calc + V_dust - - ! primary particle mean diameter according to Bushell & Amal 1998, 2000 - ! sum(n_i) not changing - can be pulled out and thus cancels out - av_dp(i,j,k) = (n_calc*dp_calc**3. + n_dust*dp_dust**3. + n_opal*dp_opal**3. & - & + n_det*dp_det**3.) - av_dp(i,j,k) = av_dp(i,j,k)/(n_calc*dp_calc**df_agg(i,j,k) & - & + n_dust*dp_dust**df_agg(i,j,k) & - & + n_opal*dp_opal**df_agg(i,j,k) + n_det*dp_det**df_agg(i,j,k)) - av_dp(i,j,k) = av_dp(i,j,k)**(1./(3. - df_agg(i,j,k))) - - ! density of mean primary particles - av_rho_p(i,j,k) = (V_det*agg_org_dens + V_opal*rho_diatom + V_calc*calcdens & - & + V_dust*claydens)/V_solid - endif - enddo - enddo - enddo - !$OMP END PARALLEL DO - - ! calculate the maximum diameter of aggregates based on agg props - call max_agg_diam(kpie, kpje, kpke, pddpo, omask) - - end subroutine aggregate_properties - - - !================================== Reynolds number based on diameter - real function Re_fun(ws,d,mu,rho) - !----------------------------------------------------------------------- - !> - !! Reynolds number for settling particles - !! - - implicit none - - real,intent(in) :: ws,d,mu,rho - - Re_fun = abs(ws*d*rho/mu) - - end function Re_fun - - - !================================================================================================== - !===================================================================================== ws_Re_approx - subroutine ws_Re_approx(kpie, kpje, kpke, pddpo, omask) - !----------------------------------------------------------------------- - !> - !! ws_Re_approx: distribution integrated to Lmax (Re crit dependent maximum agg size) - !! Renolds number-dependent sinking velocity. - !! Approximation for c_D-value taken from Jiang & Logan 1991: - !! c_D=a*Re^-b - !! - - implicit none - - integer, intent(in) :: kpie !< 1st real of model grid. - integer, intent(in) :: kpje !< 2nd real of model grid. - integer, intent(in) :: kpke !< 3rd (vertical) real of model grid. - real, intent(in) :: pddpo(kpie,kpje,kpke) !< size of scalar grid cell (3rd dimension) [m] - real, intent(in) :: omask(kpie,kpje) - - !$OMP PARALLEL DO PRIVATE(i,j,k) - do j = 1,kpje - do i = 1,kpie - do k = 1,kpke - if(pddpo(i,j,k) > dp_min .and. omask(i,j) > 0.5) then - ws_agg(i,j,k) = ws_Re(i,j,k,Lmax_agg(i,j,k)) - endif - enddo - enddo - enddo - !$OMP END PARALLEL DO - - end subroutine ws_Re_approx - - real function get_dRe(i, j, k, AJ, BJ, Re) - implicit none - ! Arguments - integer, intent(in) :: i !< 1st real of model grid. - integer, intent(in) :: j !< 2nd real of model grid. - integer, intent(in) :: k !< 3rd (vertical) real of model grid. - real, intent(in) :: AJ - real, intent(in) :: BJ - real, intent(in) :: Re - - ! Local variables - - real :: nu_vis - - nu_vis = dyn_vis(i,j,k)/rho_aq - - get_dRe = (Re*nu_vis)**((2. - BJ)/df_agg(i,j,k))/(4./3.*(av_rho_p(i,j,k) - rho_aq)/rho_aq & - *av_dp(i,j,k)**(3. - df_agg(i,j,k))*grav_acc_const/(AJ*nu_vis**(BJ)))**(1./df_agg(i,j,k)) - - end function get_dRe - - real function get_ws_agg_integral(i, j, k, AJ, BJ, lower_bound, upper_bound) - implicit none - - integer, intent(in) :: i !< 1st real of model grid. - integer, intent(in) :: j !< 2nd real of model grid. - integer, intent(in) :: k !< 3rd (vertical) real of model grid. - - real, intent(in) :: AJ - real, intent(in) :: BJ - real, intent(in) :: upper_bound - real, intent(in) :: lower_bound - - ! Local variables - real :: nu_vis - - nu_vis = dyn_vis(i,j,k)/rho_aq - get_ws_agg_integral = (4./3.*(av_rho_p(i,j,k) - rho_aq)/rho_aq & - & *av_dp(i,j,k)**(3. - df_agg(i,j,k))*grav_acc_const & - & /(AJ*nu_vis**BJ))**(1./(2. - BJ)) & - & *(upper_bound**(1. - b_agg(i,j,k) + df_agg(i,j,k) & - & + (BJ + df_agg(i,j,k) - 2.)/(2. - BJ)) & - & /(1. - b_agg(i,j,k) + df_agg(i,j,k) + (BJ + df_agg(i,j,k) - 2.)/(2. - BJ)) & - & - lower_bound**(1. - b_agg(i,j,k) + df_agg(i,j,k) + (BJ + df_agg(i,j,k) -2.)& - & /(2. - BJ)) & - & /(1. - b_agg(i,j,k) + df_agg(i,j,k) + (BJ + df_agg(i,j,k) - 2.)/(2. - BJ))) - - end function get_ws_agg_integral - - !===================================================================================== ws_Re - real function ws_Re(i,j,k,dmax_agg) - !----------------------------------------------------------------------- - !> - !! ws_Re: distribution integrated to Lmax (Re crit dependent maximum agg size) - !! Reynolds number-dependent sinking velocity. - !! Approximation for c_D-value taken from Jiang & Logan 1991: - !! c_D=a*Re^-b - !! written in such a way that we check the critical Reynolds - !! number (in case that we extend the maximum size by shear- - !! driven break-up). - !! - - implicit none - - integer, intent(in) :: i !< 1st real of model grid. - integer, intent(in) :: j !< 2nd real of model grid. - integer, intent(in) :: k !< 3rd (vertical) real of model grid. - real, intent(in) :: dmax_agg - - ! Local - real :: d_Re01, d_Re10, d_low, ws_agg_ints - - ! for Re-dependent, it should always be agg_Re_crit>10 - ! for shear-driven break-up, check against integration bounds - ! calc integration limits for Re-dependent sinking: - ! Re=0.1 - d_Re01 = get_dRe(i,j,k, AJ1, BJ1, 0.1) - ! Re=10 - d_Re10 = get_dRe(i,j,k, AJ2, BJ2, 10.) - d_low = av_dp(i,j,k) - - ws_agg_ints = 0. - if(dmax_agg >= d_Re01)then ! Re > 0.1 - ! - collect full range up to - ! 0.1, (dp->d_Re1) and set lower bound to - ! Re=0.1 val - ! aj=AJ1, bj=1 - ws_agg_ints = get_ws_agg_integral(i, j, k, AJ1, BJ1, av_dp(i,j,k), d_Re01) - d_low = d_Re01 - endif - - if(dmax_agg >= d_Re10)then ! Re > 10 - ! - collect full range Re=0.1-10 (d_Re1-> d_Re2) - ! and set lower bound to - ! Re=10 val - ! aj=AJ2, bj=0.871 - ws_agg_ints = ws_agg_ints + get_ws_agg_integral(i, j, k, AJ2, BJ2, d_Re01, d_Re10) - d_low = d_Re10 - endif - - if(d_low < d_Re01)then ! Re<0.1 and Lmax < d_Re1 - ws_agg_ints = get_ws_agg_integral(i, j, k, AJ1, BJ1, av_dp(i,j,k), dmax_agg) - else ! Re > 10, aj=AJ3, bj=BJ3 - ws_agg_ints = ws_agg_ints + get_ws_agg_integral(i, j, k, AJ3, BJ3, d_low, dmax_agg) - endif - - ! concentration-weighted mean sinking velocity - ws_Re = (ws_agg_ints & - & /((dmax_agg**(1. + df_agg(i,j,k) - b_agg(i,j,k)) & - & - av_dp(i,j,k)**(1. + df_agg(i,j,k) - b_agg(i,j,k))) & - & / (1. + df_agg(i,j,k) - b_agg(i,j,k))))*dtbgc ! (m/s -> m/d) *dtb - - end function ws_Re - - - subroutine max_agg_diam(kpie, kpje, kpke, pddpo, omask) - !----------------------------------------------------------------------- - !> - !! max_agg_diam calculates the maximum aggregate diameter of the aggregate - !! number distribution, assumes Re_crit > 10 - !! - integer, intent(in) :: kpie !< 1st real of model grid. - integer, intent(in) :: kpje !< 2nd real of model grid. - integer, intent(in) :: kpke !< 3rd (vertical) real of model grid. - real, intent(in) :: pddpo(kpie,kpje,kpke) !< size of scalar grid cell (3rd dimension) [m] - real, intent(in) :: omask(kpie,kpje) - - !$OMP PARALLEL DO PRIVATE(i,j,k) - ! base on analytical Jiang approximation - do j = 1,kpje - do i = 1,kpie - do k = 1,kpke - if(pddpo(i,j,k) > dp_min .and. omask(i,j) > 0.5) then - Lmax_agg(i,j,k) = max_agg_diam_white(i,j,k) - endif - enddo - enddo - enddo - !$OMP END PARALLEL DO - end subroutine max_agg_diam - - !================================================ maximum diameter of agg in non-stratified fluid - real function max_agg_diam_white(i,j,k) - !------------------------------------------------------------------------- - !> - !! maximum aggregate diameter in a non-stratified fluid - following the - !! White drag approaximation by Jiang & Logan 1991, assuming agg_re_crit > 10 - !! (otherwise AJX,BJX needs to be adjusted) - !! - - implicit none - - integer,intent(in) :: i,j,k - real :: nu_vis - - nu_vis = dyn_vis(i,j,k)/rho_aq - max_agg_diam_white = (agg_Re_crit*nu_vis)**((2. - BJ3)/df_agg(i,j,k)) & - & /((4./3.)*(av_rho_p(i,j,k) - rho_aq)/rho_aq & - & *av_dp(i,j,k)**(3. - df_agg(i,j,k))*grav_acc_const & - & /(AJ3*nu_vis**BJ3))**(1./df_agg(i,j,k)) - - end function max_agg_diam_white - - !===================================================================================== mass factor - real function mass_factor(dp,df,rhop) - !----------------------------------------------------------------------- - !> - !! mass_factor calculates the mass factor for the mass of a single - !! aggregate - !! - implicit none - - real, intent(in) :: dp - real, intent(in) :: df - real, intent(in) :: rhop - - ! mass factor - mass_factor = ONE_SIXTH * PI * dp**(3. - df) * rhop - - end function mass_factor - - - !===================================================================================== rho_agg - real function rho_agg(d,rhop,dp,df,rho) - !----------------------------------------------------------------------- - !> - !! rho_agg provides the aggregate density - !! - - implicit none - - real, intent(in) :: d - real, intent(in) :: rhop - real, intent(in) :: dp - real, intent(in) :: df - real, intent(in) :: rho - - rho_agg = (rhop - rho)*(dp/d)**(3. - df) + rho - - end function rho_agg - - !===================================================================================== dynvis - subroutine dynvis(kpie, kpje, kpke, kbnd, pddpo, omask, ptho, psao, ppo) - !----------------------------------------------------------------------- - !> - !! dynvis calculates the molecular dynamic viscosity according to - !! Richards 1998: The effect of temperature, pressure, and salinity - !! on sound attenuation in turbid seawater. J. Acoust. Soc. Am. 103 (1), - !! originally published by Matthaeus, W. (1972): Die Viskositaet des - !! Meerwassers. Beitraege zur Meereskunde, Heft 29 (in German). - !! - - implicit none - - integer, intent(in) :: kpie !< 1st real of model grid. - integer, intent(in) :: kpje !< 2nd real of model grid. - integer, intent(in) :: kpke !< 3rd (vertical) real of model grid. - integer, intent(in) :: kbnd - - real, intent(in) :: pddpo(kpie,kpje,kpke) !< size of scalar grid cell (3rd dimension) [m] - real, intent(in) :: omask(kpie,kpje) - real, intent(in) :: ptho(1-kbnd:kpie+kbnd,1-kbnd:kpje+kbnd,kpke) !< potential temperature [deg C] - real, intent(in) :: psao(1-kbnd:kpie+kbnd,1-kbnd:kpje+kbnd,kpke) !< salinity [psu.]. - real, intent(in) :: ppo(kpie,kpje,kpke) !< pressure [Pa]. - - ! Local variables - real:: press_val ! Pascal/rho -> dbar - real:: ptho_val,psao_val - integer :: kch - kch = 0 - !$OMP PARALLEL DO PRIVATE(i,j,k,press_val,ptho_val,psao_val,kch) - do j = 1,kpje - do i = 1,kpie - do k = 1,kpke - if(pddpo(i,j,k) > dp_min .and. omask(i,j) > 0.5) then - kch = merge(k+1,k,k 0.5) then - press_val = 0.5*(ppo(i,j,k) + ppo(i,j,kch))*1.e-5 ! Pascal -> dbar - ptho_val = 0.5*(ptho(i,j,k) + ptho(i,j,kch)) - psao_val = 0.5*(psao(i,j,k) + ptho(i,j,kch)) - else - press_val = ppo(i,j,k)*1.e-5 ! Pascal -> dbar - ptho_val = ptho(i,j,k) - psao_val = psao(i,j,k) - endif - - ! molecular dynamic viscosity - dyn_vis(i,j,k) = 0.1 & ! Unit: g / (cm*s) -> kg / (m*s) - & *(1.79e-2 & - & - 6.1299e-4*ptho_val + 1.4467e-5*ptho_val**2. & - & - 1.6826e-7*ptho_val**3. & - & - 1.8266e-7*press_val + 9.8972e-12*press_val**2. & - & + 2.4727e-5*psao_val & - & + psao_val*(4.8429e-7*ptho_val - 4.7172e-8*ptho_val**2. & - & + 7.5986e-10*ptho_val**3.) & - & + press_val*(1.3817e-8*ptho_val - 2.6363e-10*ptho_val**2.) & - & - press_val**2.*(6.3255e-13*ptho_val - 1.2116e-14*ptho_val**2.)) - endif - enddo - enddo - enddo - !$OMP END PARALLEL DO - end subroutine dynvis - -end module mo_m4ago - diff --git a/hamocc/mo_ocprod.F90 b/hamocc/mo_ocprod.F90 index a0730f12..363c59ac 100644 --- a/hamocc/mo_ocprod.F90 +++ b/hamocc/mo_ocprod.F90 @@ -99,7 +99,7 @@ subroutine ocprod(kpie,kpje,kpke,kbnd,pdlxp,pdlyp,pddpo,omask,ptho,pi_ph,psao,pp use mo_vgrid, only: kmle use mo_clim_swa, only: swa_clim use mo_inventory_bgc, only: inventory_bgc - use mo_m4ago, only: mean_aggregate_sinking_speed,ws_agg + use mo_ihamocc4m4ago, only: ihamocc_mean_aggregate_sinking_speed,ws_agg use mo_extNwatercol, only: nitrification,denit_NO3_to_NO2,anammox,denit_dnra,extN_inv_check @@ -285,7 +285,7 @@ subroutine ocprod(kpie,kpje,kpke,kbnd,pdlxp,pdlyp,pddpo,omask,ptho,pi_ph,psao,pp if (lm4ago) then ! even though we loose detritus, etc. we call the calculation for settling velocity by M4AGO here ! to enable further future development... - assuming that the operator splitting decently functions - call mean_aggregate_sinking_speed(kpie, kpje, kpke, kbnd, pddpo, omask, ptho, psao, ppao, prho) + call ihamocc_mean_aggregate_sinking_speed(kpie, kpje, kpke, kbnd, pddpo, omask, ptho, psao, ppao, prho) endif !$OMP PARALLEL DO PRIVATE(avphy,avgra,avsil,avanut,avanfe,pho,xa,xn & diff --git a/pkgs/M4AGO-sinking-scheme b/pkgs/M4AGO-sinking-scheme new file mode 160000 index 00000000..82568dbe --- /dev/null +++ b/pkgs/M4AGO-sinking-scheme @@ -0,0 +1 @@ +Subproject commit 82568dbe4ee402804894020ccf602cff0d0a251e diff --git a/pkgs/meson.build b/pkgs/meson.build index 3b8fd0fa..050d0d5e 100644 --- a/pkgs/meson.build +++ b/pkgs/meson.build @@ -8,3 +8,7 @@ sources += files('CVMix-src/src/shared/cvmix_background.F90', 'CVMix-src/src/shared/cvmix_shear.F90', 'CVMix-src/src/shared/cvmix_tidal.F90', 'CVMix-src/src/shared/cvmix_utils.F90') + +sources += files('M4AGO-sinking-scheme/src/mo_m4ago_core.f90', + 'M4AGO-sinking-scheme/src/mo_m4ago_physics.f90', + 'M4AGO-sinking-scheme/src/mo_ihamocc4m4ago.f90') From c6260937362306b294fd2c0fd1f465a575e8bba4 Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Tue, 28 May 2024 14:45:08 +0200 Subject: [PATCH 352/366] add M4AGO submodule to cime path --- cime_config/buildlib_2.1 | 1 + cime_config/buildlib_2.2 | 1 + 2 files changed, 2 insertions(+) diff --git a/cime_config/buildlib_2.1 b/cime_config/buildlib_2.1 index a46abbdd..b36dc37d 100755 --- a/cime_config/buildlib_2.1 +++ b/cime_config/buildlib_2.1 @@ -65,6 +65,7 @@ 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: diff --git a/cime_config/buildlib_2.2 b/cime_config/buildlib_2.2 index d069e2eb..ec30963c 100755 --- a/cime_config/buildlib_2.2 +++ b/cime_config/buildlib_2.2 @@ -66,6 +66,7 @@ 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: From 99e04e2f11326728225f59aa03e600fde453ee9c Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Tue, 28 May 2024 16:55:14 +0200 Subject: [PATCH 353/366] minor changes in M4AGO submodule --- pkgs/M4AGO-sinking-scheme | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/pkgs/M4AGO-sinking-scheme b/pkgs/M4AGO-sinking-scheme index 82568dbe..99db47ff 160000 --- a/pkgs/M4AGO-sinking-scheme +++ b/pkgs/M4AGO-sinking-scheme @@ -1 +1 @@ -Subproject commit 82568dbe4ee402804894020ccf602cff0d0a251e +Subproject commit 99db47ff6328eb7e006257ae0bc9ed5cc588f711 From c4273acd17e4c80737f5b00b88955c82f3f2ce4b Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Tue, 28 May 2024 17:58:38 +0200 Subject: [PATCH 354/366] re-introduce phy/restart_wt.F part --- phy/mod_restart.F90 | 18 +++++++++++++++--- 1 file changed, 15 insertions(+), 3 deletions(-) diff --git a/phy/mod_restart.F90 b/phy/mod_restart.F90 index c520d225..f59f011c 100644 --- a/phy/mod_restart.F90 +++ b/phy/mod_restart.F90 @@ -40,6 +40,7 @@ module mod_restart use mod_dia use mod_forcing, only: ditflx, disflx, sprfac, tflxdi, sflxdi, nflxdi, & prfac, eiacc, pracc, flxco2, flxdms, flxbrf, & + flxn2o,flxnh3, & ustarb, buoyfl use mod_niw, only: uml, vml, umlres, vmlres use mod_difest, only: OBLdepth @@ -48,7 +49,8 @@ module mod_restart 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, ustarw_da, slp_da, abswnd_da, & - atmco2_da, atmbrf_da, ficem_da, l1ci, l2ci + atmco2_da, atmbrf_da, atmn2o_da, atmnh3_da, & + ficem_da, l1ci, l2ci use mod_ben02, only: cd_d, ch_d, ce_d, wg2_d, cd_m, ch_m, ce_m, wg2_m, & rhoa, tsi_tda, tml_tda, sml_tda, alb_tda, fice_tda, & ntda, rnfres @@ -61,7 +63,7 @@ module mod_restart # endif #endif #ifdef HAMOCC - use mo_control_bgc, only : use_BROMO + use mo_control_bgc, only : use_BROMO,use_extNcycle #endif implicit none @@ -418,7 +420,11 @@ subroutine defwrtflds(defmode) call defwrtfld('atmco2_da', trim(c5p)//' k2 time', & atmco2_da, ip, defmode) call defwrtfld('atmbrf_da', trim(c5p)//' k2 time', & - atmbrf_da, ip, defmode) ! not read in restart_read, necesarry? + atmbrf_da, ip, defmode) ! not read in restart_read, necessary? + call defwrtfld('atmn2o_da', trim(c5p)//' k2 time', & + atmn2o_da, ip, defmode) ! not read in restart_read, necessary? + call defwrtfld('atmnh3_da', trim(c5p)//' k2 time', & + atmnh3_da, ip, defmode) ! not read in restart_read, necessary? call defwrtfld('frzpot', trim(c5p)//' time', & frzpot, ip, defmode) call defwrtfld('mltpot', trim(c5p)//' time', & @@ -432,6 +438,12 @@ subroutine defwrtflds(defmode) call defwrtfld('flxbrf', trim(c5p)//' time', & flxbrf, ip, defmode) endif + if (use_extNcycle) then + call defwrtfld('flxn2o', trim(c5p)//' time', & + flxn2o, ip, defmode) + call defwrtfld('flxnh3', trim(c5p)//' time', & + flxnh3, ip, defmode) + endif #endif endif From e540d579d8d27f39159449a621e112e95aaab70b Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Tue, 28 May 2024 17:59:57 +0200 Subject: [PATCH 355/366] re-introduce phy/restart_rd.F part --- phy/mod_restart.F90 | 10 ++++++++++ 1 file changed, 10 insertions(+) diff --git a/phy/mod_restart.F90 b/phy/mod_restart.F90 index f59f011c..2d484426 100644 --- a/phy/mod_restart.F90 +++ b/phy/mod_restart.F90 @@ -1607,6 +1607,16 @@ subroutine restart_read if (.not.fld_read .and. mnproc == 1) & write(lp,*) 'restart_read: warning: bromoform flux is not read '// & 'from restart file and will be initialized to zero.' + call readfld('flxn2o', no_unitconv, flxn2o, ip, & + required = .false., fld_read = fld_read) + if (.not.fld_read .and. mnproc == 1) & + write(lp,*) 'restart_read: warning: N2O flux is not read '// & + 'from restart file and will be initialized to zero.' + call readfld('flxnh3', no_unitconv, flxnh3, ip, & + required = .false., fld_read = fld_read) + if (.not.fld_read .and. mnproc == 1) & + write(lp,*) 'restart_read: warning: NH3 flux is not read '// & + 'from restart file and will be initialized to zero.' endif #ifdef TRC From aea602dbbd3830e9b35732e38be937c4b9a4bb75 Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Tue, 28 May 2024 18:27:25 +0200 Subject: [PATCH 356/366] Fix meson test system --- pkgs/meson.build | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/pkgs/meson.build b/pkgs/meson.build index 050d0d5e..ba95bea5 100644 --- a/pkgs/meson.build +++ b/pkgs/meson.build @@ -9,6 +9,8 @@ sources += files('CVMix-src/src/shared/cvmix_background.F90', 'CVMix-src/src/shared/cvmix_tidal.F90', 'CVMix-src/src/shared/cvmix_utils.F90') -sources += files('M4AGO-sinking-scheme/src/mo_m4ago_core.f90', - 'M4AGO-sinking-scheme/src/mo_m4ago_physics.f90', - 'M4AGO-sinking-scheme/src/mo_ihamocc4m4ago.f90') +if get_option('ecosys') + sources += files('M4AGO-sinking-scheme/src/mo_m4ago_core.f90', + 'M4AGO-sinking-scheme/src/mo_m4ago_physics.f90', + 'M4AGO-sinking-scheme/src/mo_ihamocc4m4ago.f90') +endif From d653aad8bab75c5bd1321cc2fa1103c0808d43d7 Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Wed, 29 May 2024 13:52:56 +0200 Subject: [PATCH 357/366] Clean up comments and whitespaces --- cime_config/namelist_definition_blom.xml | 66 ++++++++++++------------ hamocc/mo_hamocc_init.F90 | 1 - 2 files changed, 33 insertions(+), 34 deletions(-) diff --git a/cime_config/namelist_definition_blom.xml b/cime_config/namelist_definition_blom.xml index 39d9a1c7..a392d6f8 100644 --- a/cime_config/namelist_definition_blom.xml +++ b/cime_config/namelist_definition_blom.xml @@ -3619,8 +3619,8 @@ .true. Switch to couple nitrogen deposition. Requires do_ndep. - - + + logical bgcnml @@ -3630,8 +3630,8 @@ .true. Switch to couple N2O and NH3 fluxes - - + + logical bgcnml @@ -3642,7 +3642,7 @@ Switch for M4AGO settling scheme - + logical bgcnml @@ -3652,7 +3652,7 @@ Switch for cyano-bluefix in euphotic zone only - + logical bgcnml @@ -5148,8 +5148,8 @@ 0,0,0 Surface ammonium concentration [mol NH4 m-3] - extended N cycle only - - + + integer(3) diabgc @@ -5340,8 +5340,8 @@ 0,0,0 Upward CO2 flux (co2fxu) [kg C m-2 s-1] - - + + integer(3) diabgc @@ -5412,8 +5412,8 @@ 0,0,0 Ammonia flux [mol NH3 m-2 s-1] - - + + integer(3) diabgc @@ -5532,8 +5532,8 @@ 0,0,0 Atmospheric N2O [ppt] - - + + integer(3) diabgc @@ -5688,8 +5688,8 @@ 0,0,0 Atmospheric bromoform [ppt] - - + + integer(3) diabgc @@ -5773,8 +5773,8 @@ Vertically integrated denitrification - - + + integer(3) diabgc diabgc @@ -5796,7 +5796,7 @@ 4,2,2 NHx nitrogen deposition flux [mol N m-2 s-1] - extended N cycle only - + integer(3) @@ -6144,8 +6144,8 @@ 0,0,0 Ammonium concentration [mol NH4 m-3] - extended N cycle only - - + + integer(3) diabgc @@ -6324,7 +6324,7 @@ 0,0,0 sulfate-based remin rate on det [mol P m-3 s-1] - ext. N cycle only - + integer(3) @@ -6468,8 +6468,8 @@ 0,0,0 Volume-weighted mean aggregate porosity [-] - - + + integer(3) diabgc @@ -6649,7 +6649,7 @@ Pre-formed silica [mol m-3] - + integer(3) diabgc @@ -7450,8 +7450,8 @@ 0,0,0 Volume-weighted mean aggregate porosity [-] - - + + integer(3) diabgc @@ -7629,7 +7629,7 @@ Pre-formed silica [mol m-3] - + integer(3) diabgc @@ -8025,7 +8025,7 @@ sediment - water-column diffusive flux of nitrate [mol NO3 m-2 s-1] - + integer(3) diabgc @@ -8060,7 +8060,7 @@ 0,0,0 Sediment - water-column diffusive flux of nitrite [mol NO2 m-2 s-1] - + integer(3) @@ -8121,7 +8121,7 @@ burial fluxes of clay [g m-2 s-1] - + integer(3) diabgc @@ -8384,8 +8384,8 @@ 0,0,0 sulfate-based remin rate on det [mol P m-3 s-1] - ext. N cycle only - - + + integer(3) diabgc diff --git a/hamocc/mo_hamocc_init.F90 b/hamocc/mo_hamocc_init.F90 index 45caa09b..aaf38efb 100644 --- a/hamocc/mo_hamocc_init.F90 +++ b/hamocc/mo_hamocc_init.F90 @@ -65,7 +65,6 @@ subroutine hamocc_init(read_rest,rstfnm_hamocc) use mo_ini_fields, only: ini_fields_ocean,ini_fields_atm use mo_aufr_bgc, only: aufr_bgc use mo_extNsediment,only: alloc_mem_extNsediment_diag -! use mo_m4ago, only: init_m4ago_nml_params, init_m4ago_params use mo_ihamocc4m4ago, only: alloc_mem_m4ago,init_m4ago_nml_params, init_m4ago_params From 0936b17b64bb6dc4b53b8f21e3ed364c8cf0db0d Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Thu, 30 May 2024 13:28:54 +0200 Subject: [PATCH 358/366] Change M4AGO switch: lm4ago -> use_M4AGO --- cime_config/namelist_definition_blom.xml | 2 +- cime_config/ocn_in.readme | 2 +- hamocc/mo_accfields.F90 | 6 +++--- hamocc/mo_bgcmean.F90 | 6 +++--- hamocc/mo_control_bgc.F90 | 2 +- hamocc/mo_hamocc_init.F90 | 8 ++++---- hamocc/mo_ncout_hamocc.F90 | 20 ++++++++++---------- hamocc/mo_ocprod.F90 | 24 ++++++++++++------------ hamocc/mo_param_bgc.F90 | 8 ++++---- 9 files changed, 39 insertions(+), 39 deletions(-) diff --git a/cime_config/namelist_definition_blom.xml b/cime_config/namelist_definition_blom.xml index a392d6f8..395f9d3b 100644 --- a/cime_config/namelist_definition_blom.xml +++ b/cime_config/namelist_definition_blom.xml @@ -3632,7 +3632,7 @@ Switch to couple N2O and NH3 fluxes - + logical bgcnml bgcnml diff --git a/cime_config/ocn_in.readme b/cime_config/ocn_in.readme index 526ea23b..30807855 100644 --- a/cime_config/ocn_in.readme +++ b/cime_config/ocn_in.readme @@ -374,7 +374,7 @@ ! OXY, NO3, SIL, D13C, and D14C ! WITH_DMSPH : Logical switch to activate DMS calculation as function of pH ! PI_PH_FILE : File name (incl. full path) for surface PI pH input data. -! LM4AGO : Switch for M4AGO settling scheme +! use_M4AGO : Switch for M4AGO settling scheme ! LEUPHOTIC_CYA : Switch to perform bluefix (cyanobacteria) only in the euphotic zone ! L_3DVARSEDPOR : Logical switch to enable lon-lat-depth variable sediment porosity (as opposed to default: only depth) ! SEDPORFILE : File name (incl. full path) for sediment porosity diff --git a/hamocc/mo_accfields.F90 b/hamocc/mo_accfields.F90 index ed5ec071..d214ea92 100644 --- a/hamocc/mo_accfields.F90 +++ b/hamocc/mo_accfields.F90 @@ -128,7 +128,7 @@ subroutine accfields(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask) jsdm_remin_sulf,jsediffnh4,jsediffn2o,jsediffno2,jatmn2o,jatmnh3, & jndepnhxfx use mo_control_bgc, only: io_stdo_bgc,dtb,use_BROMO,use_AGG,use_WLIN,use_natDIC, & - use_CFC,use_sedbypass,use_cisonew,use_BOXATM,lm4ago,use_extNcycle + use_CFC,use_sedbypass,use_cisonew,use_BOXATM,use_M4AGO,use_extNcycle use mo_param1_bgc, only: ialkali,ian2o,iano3,iatmco2,iatmdms,iatmn2,iatmn2o,iatmo2, & icalc,idet,idms,idicsat,idoc,iiron,iopal, & ioxygen,iphosph,iphy,iprefalk,iprefdic, & @@ -454,7 +454,7 @@ subroutine accfields(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask) call acclyr(jremin_aerob,remin_aerob,pddpo,1) call acclyr(jremin_sulf,remin_sulf,pddpo,1) endif - if (lm4ago) then + if (use_M4AGO) then ! M4AGO call acclyr(jagg_ws,aggregate_diagnostics(1,1,1,kws_agg),pddpo,1) call acclyr(jdynvis,aggregate_diagnostics(1,1,1,kdynvis),pddpo,1) @@ -571,7 +571,7 @@ subroutine accfields(kpie,kpje,kpke,pdlxp,pdlyp,pddpo,omask) call acclvl(jlvl_remin_aerob,remin_aerob,k,ind1,ind2,wghts) call acclvl(jlvl_remin_sulf,remin_sulf,k,ind1,ind2,wghts) endif - if (lm4ago) then + if (use_M4AGO) then !M4AGO call acclvl(jlvl_agg_ws,aggregate_diagnostics(1,1,1,kws_agg),k,ind1,ind2,wghts) call acclvl(jlvl_dynvis,aggregate_diagnostics(1,1,1,kdynvis),k,ind1,ind2,wghts) diff --git a/hamocc/mo_bgcmean.F90 b/hamocc/mo_bgcmean.F90 index 42778e96..d4b0b74e 100644 --- a/hamocc/mo_bgcmean.F90 +++ b/hamocc/mo_bgcmean.F90 @@ -49,7 +49,7 @@ module mo_bgcmean use netcdf, only: nf90_fill_double use mo_param1_bgc, only: ks use mo_control_bgc, only: use_sedbypass,use_cisonew,use_CFC,use_natDIC,use_BROMO,use_BOXATM, & - use_AGG,lm4ago,use_extNcycle + use_AGG,use_M4AGO,use_extNcycle implicit none @@ -1145,7 +1145,7 @@ subroutine alloc_mem_bgcmean(kpie,kpje,kpke) if (LYR_remin_sulf(n) > 0) i_bsc_m3d=i_bsc_m3d+1 jremin_sulf(n)=i_bsc_m3d*min(1,LYR_remin_sulf(n)) endif - if (lm4ago) then + if (use_M4AGO) then ! M4AGO if (LYR_agg_ws(n) > 0) i_bsc_m3d=i_bsc_m3d+1 jagg_ws(n)=i_bsc_m3d*min(1,LYR_agg_ws(n)) @@ -1322,7 +1322,7 @@ subroutine alloc_mem_bgcmean(kpie,kpje,kpke) if (LVL_remin_sulf(n) > 0) ilvl_bsc_m3d=ilvl_bsc_m3d+1 jlvl_remin_sulf(n)=ilvl_bsc_m3d*min(1,LVL_remin_sulf(n)) endif - if (lm4ago) then + if (use_M4AGO) then ! M4AGO if (LVL_agg_ws(n) > 0) ilvl_bsc_m3d=ilvl_bsc_m3d+1 jlvl_agg_ws(n)=ilvl_bsc_m3d*min(1,LVL_agg_ws(n)) diff --git a/hamocc/mo_control_bgc.F90 b/hamocc/mo_control_bgc.F90 index 9ea44479..71908c4e 100644 --- a/hamocc/mo_control_bgc.F90 +++ b/hamocc/mo_control_bgc.F90 @@ -60,7 +60,7 @@ module mo_control_bgc logical :: do_sedspinup = .false. ! apply sediment spin-up logical :: do_oalk = .false. ! apply ocean alkalinization logical :: with_dmsph = .false. ! apply DMS with pH dependence - logical :: lm4ago = .false. ! run with M4AGO settling scheme + logical :: use_M4AGO = .false. ! run with M4AGO settling scheme logical :: leuphotic_cya = .false. ! allow cyanobacteria to grow only in euphotic zone integer :: sedspin_yr_s = -1 ! start year for sediment spin-up integer :: sedspin_yr_e = -1 ! end year for sediment spin-up diff --git a/hamocc/mo_hamocc_init.F90 b/hamocc/mo_hamocc_init.F90 index aaf38efb..3df63a31 100644 --- a/hamocc/mo_hamocc_init.F90 +++ b/hamocc/mo_hamocc_init.F90 @@ -42,7 +42,7 @@ subroutine hamocc_init(read_rest,rstfnm_hamocc) use mo_control_bgc, only: bgc_namelist,get_bgc_namelist,do_ndep,do_rivinpt,do_oalk, & do_sedspinup,sedspin_yr_s,sedspin_yr_e,sedspin_ncyc, & dtb,dtbgc,io_stdo_bgc,ldtbgc, & - ldtrunbgc,ndtdaybgc,with_dmsph,l_3Dvarsedpor,lm4ago, & + ldtrunbgc,ndtdaybgc,with_dmsph,l_3Dvarsedpor,use_M4AGO, & do_ndep_coupled,leuphotic_cya,do_n2onh3_coupled, & ocn_co2_type, use_sedbypass, use_BOXATM, use_BROMO,use_extNcycle use mo_param1_bgc, only: ks,init_por2octra_mapping @@ -80,7 +80,7 @@ subroutine hamocc_init(read_rest,rstfnm_hamocc) namelist /bgcnml/ atm_co2,fedepfile,do_rivinpt,rivinfile,do_ndep,ndepfile,do_oalk, & & do_sedspinup,sedspin_yr_s,sedspin_yr_e,sedspin_ncyc, & & inidic,inialk,inipo4,inioxy,inino3,inisil,inid13c,inid14c,swaclimfile, & - & with_dmsph,pi_ph_file,l_3Dvarsedpor,sedporfile,ocn_co2_type,lm4ago, & + & with_dmsph,pi_ph_file,l_3Dvarsedpor,sedporfile,ocn_co2_type,use_M4AGO, & & leuphotic_cya, do_ndep_coupled,do_n2onh3_coupled ! ! --- Set io units and some control parameters @@ -139,7 +139,7 @@ subroutine hamocc_init(read_rest,rstfnm_hamocc) call alloc_mem_biomod(idm,jdm,kdm) call alloc_mem_sedmnt(idm,jdm) call alloc_mem_carbch(idm,jdm,kdm) - if (lm4ago) then + if (use_M4AGO) then call alloc_mem_M4AGO(idm,jdm,kdm) endif if (use_extNcycle .and. .not. use_sedbypass) then @@ -179,7 +179,7 @@ subroutine hamocc_init(read_rest,rstfnm_hamocc) ! --- Initialize parameters ! call ini_parambgc(idm,jdm) - if (lm4ago) then + if (use_M4AGO) then call init_m4ago_nml_params call init_m4ago_params endif diff --git a/hamocc/mo_ncout_hamocc.F90 b/hamocc/mo_ncout_hamocc.F90 index a8f2fe46..98073b3c 100644 --- a/hamocc/mo_ncout_hamocc.F90 +++ b/hamocc/mo_ncout_hamocc.F90 @@ -35,7 +35,7 @@ subroutine ncwrt_bgc(iogrp) use mod_grid, only: depths use mod_dia, only: diafnm,sigmar1,iotype,ddm,depthslev,depthslev_bnds use mo_control_bgc, only: dtbgc,use_cisonew,use_AGG,use_CFC,use_natDIC,use_BROMO, & - use_sedbypass,use_BOXATM,lm4ago,use_extNcycle + use_sedbypass,use_BOXATM,use_M4AGO,use_extNcycle use mo_vgrid, only: k0100,k0500,k1000,k2000,k4000 use mo_param1_bgc, only: ks use mod_nctools, only: ncwrt1,ncdims,nctime,ncfcls,ncfopn,ncdimc,ncputr,ncputi @@ -377,7 +377,7 @@ subroutine ncwrt_bgc(iogrp) call finlyr(jremin_aerob(iogrp),jdp(iogrp)) call finlyr(jremin_sulf(iogrp),jdp(iogrp)) endif - if(lm4ago)then + if (use_M4AGO) then ! M4AGO call finlyr(jagg_ws(iogrp),jdp(iogrp)) call finlyr(jdynvis(iogrp),jdp(iogrp)) @@ -492,7 +492,7 @@ subroutine ncwrt_bgc(iogrp) call msklvl(jlvl_remin_aerob(iogrp),depths) call msklvl(jlvl_remin_sulf(iogrp),depths) endif - if(lm4ago)then + if (use_M4AGO) then ! M4AGO call msklvl(jlvl_agg_ws(iogrp),depths) call msklvl(jlvl_dynvis(iogrp),depths) @@ -716,7 +716,7 @@ subroutine ncwrt_bgc(iogrp) call wrtlyr(jremin_aerob(iogrp), LYR_remin_aerob(iogrp),1e3/dtbgc, 0.,cmpflg,'remina') call wrtlyr(jremin_sulf(iogrp), LYR_remin_sulf(iogrp),1e3/dtbgc, 0.,cmpflg,'remins') endif - if(lm4ago)then + if (use_M4AGO) then ! M4AGO call wrtlyr(jagg_ws(iogrp), LYR_agg_ws(iogrp), 1., 0.,cmpflg,'agg_ws') call wrtlyr(jdynvis(iogrp), LYR_dynvis(iogrp), 1., 0.,cmpflg,'dynvis') @@ -814,7 +814,7 @@ subroutine ncwrt_bgc(iogrp) call wrtlvl(jlvl_remin_aerob(iogrp), LVL_remin_aerob(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'reminalvl') call wrtlvl(jlvl_remin_sulf(iogrp), LVL_remin_sulf(iogrp), rnacc*1e3/dtbgc,0.,cmpflg,'reminslvl') endif - if(lm4ago)then + if (use_M4AGO) then ! M4AGO call wrtlvl(jlvl_agg_ws(iogrp), LVL_agg_ws(iogrp), rnacc, 0.,cmpflg,'agg_wslvl') call wrtlvl(jlvl_dynvis(iogrp), LVL_dynvis(iogrp), rnacc, 0.,cmpflg,'dynvislvl') @@ -1070,7 +1070,7 @@ subroutine ncwrt_bgc(iogrp) call inilyr(jremin_aerob(iogrp),0.) call inilyr(jremin_sulf(iogrp),0.) endif - if(lm4ago)then + if (use_M4AGO) then ! M4AGO call inilyr(jagg_ws(iogrp),0.) call inilyr(jdynvis(iogrp),0.) @@ -1166,7 +1166,7 @@ subroutine ncwrt_bgc(iogrp) call inilvl(jlvl_remin_aerob(iogrp),0.) call inilvl(jlvl_remin_sulf(iogrp),0.) endif - if(lm4ago)then + if (use_M4AGO) then ! M4AGO call inilvl(jlvl_agg_ws(iogrp),0.) call inilvl(jlvl_dynvis(iogrp),0.) @@ -1230,7 +1230,7 @@ subroutine hamoccvardef(iogrp,timeunits,calendar,cmpflg) use mod_nctools, only: ncdefvar,ncattr,ncfopn,ncdimc,ncdims, & nctime,ncfcls,ncedef,ncdefvar3d,ndouble - use mo_control_bgc, only: lm4ago + use mo_control_bgc, only: use_M4AGO use mo_bgcmean, only: srf_kwco2,srf_pco2,srf_dmsflux,srf_co2fxd, & srf_kwco2khm,srf_co2kh,srf_co2khm,srf_pco2m, & srf_co2fxu,srf_oxflux,srf_niflux,srf_pn2om,srf_dms,srf_dmsprod, & @@ -1729,7 +1729,7 @@ subroutine hamoccvardef(iogrp,timeunits,calendar,cmpflg) call ncdefvar3d(LYR_remin_sulf(iogrp),cmpflg,'p', & & 'remins','Sulfate remineralization rate',' ','mol P m-3 s-1',1) endif - if(lm4ago)then + if (use_M4AGO) then ! M4AGO call ncdefvar3d(LYR_agg_ws(iogrp),cmpflg,'p', & & 'agg_ws','aggregate mean settling velocity',' ','m d-1',1) @@ -1916,7 +1916,7 @@ subroutine hamoccvardef(iogrp,timeunits,calendar,cmpflg) & 'reminslvl','Sulfate remineralization rate',' ', & & 'mol P m-3 s-1',2) endif - if(lm4ago)then + if (use_M4AGO) then ! M4AGO call ncdefvar3d(LVL_agg_ws(iogrp),cmpflg,'p', & & 'agg_wslvl','aggregate mean settling velocity',' ','m d-1',2) diff --git a/hamocc/mo_ocprod.F90 b/hamocc/mo_ocprod.F90 index 363c59ac..657f75a4 100644 --- a/hamocc/mo_ocprod.F90 +++ b/hamocc/mo_ocprod.F90 @@ -93,7 +93,7 @@ subroutine ocprod(kpie,kpje,kpke,kbnd,pdlxp,pdlyp,pddpo,omask,ptho,pi_ph,psao,pp inatalkali,inatcalc,inatsco212,ianh4 use mo_control_bgc, only: dtb,io_stdo_bgc,with_dmsph, & use_BROMO,use_AGG,use_PBGC_OCNP_TIMESTEP,use_FB_BGC_OCE, & - use_AGG,use_cisonew,use_natDIC, use_WLIN,use_sedbypass,lm4ago, & + use_AGG,use_cisonew,use_natDIC, use_WLIN,use_sedbypass,use_M4AGO, & use_extNcycle use mo_vgrid, only: dp_min,dp_min_sink,k0100,k0500,k1000,k2000,k4000,kwrbioz,ptiestu use mo_vgrid, only: kmle @@ -282,7 +282,7 @@ subroutine ocprod(kpie,kpje,kpke,kbnd,pdlxp,pdlyp,pddpo,omask,ptho,pi_ph,psao,pp enddo !$OMP END PARALLEL DO - if (lm4ago) then + if (use_M4AGO) then ! even though we loose detritus, etc. we call the calculation for settling velocity by M4AGO here ! to enable further future development... - assuming that the operator splitting decently functions call ihamocc_mean_aggregate_sinking_speed(kpie, kpje, kpke, kbnd, pddpo, omask, ptho, psao, ppao, prho) @@ -494,7 +494,7 @@ subroutine ocprod(kpie,kpje,kpke,kbnd,pdlxp,pdlyp,pddpo,omask,ptho,pi_ph,psao,pp ocetra(i,j,k,inatalkali) = ocetra(i,j,k,inatalkali)-2.*delcar-(rnit+1)*dtr ocetra(i,j,k,inatcalc) = ocetra(i,j,k,inatcalc)+delcar endif - if(lm4ago)then + if (use_M4AGO) then opalrem = dremopal*opal_remin_q10**((ptho(i,j,k)-opal_remin_Tref)/10.)*ocetra(i,j,k,iopal) else opalrem = dremopal*ocetra(i,j,k,iopal) @@ -631,7 +631,7 @@ subroutine ocprod(kpie,kpje,kpke,kbnd,pdlxp,pdlyp,pddpo,omask,ptho,pi_ph,psao,pp endif if(ocetra(i,j,k,ioxygen) > 5.e-8) then - if(lm4ago) then + if (use_M4AGO) then if (.not. use_extNcycle) then ! M4AGO comes with O2-lim o2lim = ocetra(i,j,k,ioxygen)/(ocetra(i,j,k,ioxygen) + bkox_drempoc) @@ -717,7 +717,7 @@ subroutine ocprod(kpie,kpje,kpke,kbnd,pdlxp,pdlyp,pddpo,omask,ptho,pi_ph,psao,pp ! so the expression dremopal*(Si(OH)4sat-Si(OH)4) would change the ! rate only from 0 to 100% !*********************************************************************** - if (lm4ago) then + if (use_M4AGO) then opalrem = dremopal*opal_remin_q10**((ptho(i,j,k)-opal_remin_Tref)/10.)*ocetra(i,j,k,iopal) else opalrem = dremopal*0.1*(temp+3.)*ocetra(i,j,k,iopal) @@ -1170,7 +1170,7 @@ subroutine ocprod(kpie,kpje,kpke,kbnd,pdlxp,pdlyp,pddpo,omask,ptho,pi_ph,psao,pp wdustd = wdust_const dagg = 0.0 endif - if(lm4ago)then ! superseding every other method + if (use_M4AGO) then ! superseding every other method wpoc = ws_agg(i,j,k) wpocd = ws_agg(i,j,kdonor) wcal = ws_agg(i,j,k) @@ -1190,7 +1190,7 @@ subroutine ocprod(kpie,kpje,kpke,kbnd,pdlxp,pdlyp,pddpo,omask,ptho,pi_ph,psao,pp if (use_AGG) then wnosd = 0.0 else if (use_WLIN) then - if (lm4ago)then + if (use_M4AGO) then wpoc = ws_agg(i,j,k) else wpoc = wmin @@ -1384,7 +1384,7 @@ subroutine ocprod(kpie,kpje,kpke,kbnd,pdlxp,pdlyp,pddpo,omask,ptho,pi_ph,psao,pp else if (use_WLIN) then wpoc = min(wmin+wlin*ptiestu(i,j,k), wmax) endif - if(lm4ago)then + if (use_M4AGO) then wpoc = ws_agg(i,j,k) wcal = ws_agg(i,j,k) wopal = ws_agg(i,j,k) @@ -1409,7 +1409,7 @@ subroutine ocprod(kpie,kpje,kpke,kbnd,pdlxp,pdlyp,pddpo,omask,ptho,pi_ph,psao,pp else if (use_WLIN) then wpoc = min(wmin+wlin*ptiestu(i,j,k), wmax) endif - if(lm4ago)then + if (use_M4AGO) then wpoc = ws_agg(i,j,k) wcal = ws_agg(i,j,k) wopal = ws_agg(i,j,k) @@ -1434,7 +1434,7 @@ subroutine ocprod(kpie,kpje,kpke,kbnd,pdlxp,pdlyp,pddpo,omask,ptho,pi_ph,psao,pp else if (use_WLIN) then wpoc = min(wmin+wlin*ptiestu(i,j,k), wmax) endif - if(lm4ago)then + if (use_M4AGO) then wpoc = ws_agg(i,j,k) wcal = ws_agg(i,j,k) wopal = ws_agg(i,j,k) @@ -1459,7 +1459,7 @@ subroutine ocprod(kpie,kpje,kpke,kbnd,pdlxp,pdlyp,pddpo,omask,ptho,pi_ph,psao,pp else if (use_WLIN) then wpoc = min(wmin+wlin*ptiestu(i,j,k), wmax) endif - if(lm4ago)then + if (use_M4AGO) then wpoc = ws_agg(i,j,k) wcal = ws_agg(i,j,k) wopal = ws_agg(i,j,k) @@ -1484,7 +1484,7 @@ subroutine ocprod(kpie,kpje,kpke,kbnd,pdlxp,pdlyp,pddpo,omask,ptho,pi_ph,psao,pp else if (use_WLIN) then wpoc = min(wmin+wlin*ptiestu(i,j,k), wmax) endif - if(lm4ago)then + if (use_M4AGO) then wpoc = ws_agg(i,j,k) wcal = ws_agg(i,j,k) wopal = ws_agg(i,j,k) diff --git a/hamocc/mo_param_bgc.F90 b/hamocc/mo_param_bgc.F90 index a54da7af..7c6b05a6 100644 --- a/hamocc/mo_param_bgc.F90 +++ b/hamocc/mo_param_bgc.F90 @@ -36,7 +36,7 @@ module mo_param_bgc use_BROMO,use_cisonew,use_WLIN,use_FB_BGC_OCE, & do_ndep,do_oalk,do_rivinpt,do_sedspinup,l_3Dvarsedpor, & use_BOXATM,use_CFC,use_PBGC_CK_TIMESTEP, & - use_sedbypass,with_dmsph,use_PBGC_OCNP_TIMESTEP,ocn_co2_type,lm4ago, & + use_sedbypass,with_dmsph,use_PBGC_OCNP_TIMESTEP,ocn_co2_type,use_M4AGO,& leuphotic_cya,do_ndep_coupled,do_n2onh3_coupled,use_extNcycle use mod_xc, only: mnproc @@ -276,7 +276,7 @@ module mo_param_bgc real, protected :: remido = 0.004 ! 1/d - remineralization rate (of DOM) ! deep sea remineralisation constants real, protected :: drempoc = 0.025 ! 1/d Aerob remineralization rate detritus - real, protected :: drempoc_anaerob = 1.25e-3 ! =0.05*drempoc - remin in sub-/anoxic environm. - not be overwritten by lm4ago + real, protected :: drempoc_anaerob = 1.25e-3 ! =0.05*drempoc - remin in sub-/anoxic environm. - not be overwritten by M4AGO real, protected :: bkox_drempoc = 1e-7 ! half-saturation constant for oxygen for ammonification (aerobic remin via drempoc) real, protected :: dremopal = 0.003 ! 1/d Dissolution rate for opal real, protected :: dremn2o = 0.01 ! 1/d Remineralization rate of detritus on N2O @@ -577,7 +577,7 @@ subroutine ini_param_biol() ropal = 30. ! iris 25 !opal to organic phosphorous production ratio endif - if (lm4ago) then + if (use_M4AGO) then ! reset drempoc and dremopal for Q10 T-dep remin/dissolution drempoc = 0.12 dremopal = 0.023 @@ -837,7 +837,7 @@ subroutine write_parambgc() call cinfo_add_entry('do_sedspinup', do_sedspinup) call cinfo_add_entry('l_3Dvarsedpor', l_3Dvarsedpor) call cinfo_add_entry('leuphotic_cya', leuphotic_cya) - call cinfo_add_entry('lm4ago', lm4ago) + call cinfo_add_entry('use_M4AGO', use_M4AGO) if (use_extNcycle) then call cinfo_add_entry('do_ndep_coupled', do_ndep_coupled) call cinfo_add_entry('do_n2onh3_coupled', do_n2onh3_coupled) From 535f8192437de9afe18a0fab5b225dd2856e7976 Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Thu, 30 May 2024 13:35:23 +0200 Subject: [PATCH 359/366] Indentation --- cesm/mod_cesm.F90 | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/cesm/mod_cesm.F90 b/cesm/mod_cesm.F90 index 32be4546..a46a0267 100644 --- a/cesm/mod_cesm.F90 +++ b/cesm/mod_cesm.F90 @@ -129,13 +129,13 @@ subroutine inifrc_cesm if (.not. use_stream_relaxation) then ! If SST restoring is requested prepare interpolation and ! read climatological sea-ice concentration and surface temperature. - if (trxday > 0._r8) then - call initai - call rdcsic - call rdctsf - endif + if (trxday > 0._r8) then + call initai + call rdcsic + call rdctsf + endif - ! If SSS restoring is requested, read climatological sea surface salinity. + ! If SSS restoring is requested, read climatological sea surface salinity. if (srxday > 0._r8) then call rdcsss end if From 56f483f01b0b5d4131b40a13aaba88cbc6f0818a Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Thu, 30 May 2024 13:49:21 +0200 Subject: [PATCH 360/366] adjust description for burial fluxes --- cime_config/ocn_in.readme | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/cime_config/ocn_in.readme b/cime_config/ocn_in.readme index 30807855..101d8c93 100644 --- a/cime_config/ocn_in.readme +++ b/cime_config/ocn_in.readme @@ -582,10 +582,10 @@ ! SEDIFFN2O - sediment - water-column diffusive flux of N2O [mol N2O m-2 s-1] - extended N cycle only ! SEDIFFNH4 - sediment - water-column diffusive flux of ammonium [mol NH4 m-2 s-1] - extended N cycle only ! SEDIFFSI - sediment - water-column diffusive flux of silica [mol Si m-2 s-1] -! FLX_BURSSO12 - burial fluxes organic carbon [mol P m-2 s-1] -! FLX_BURSSSC12 - burial fluxes of calcium carbonate [mol Ca m-2 s-1] -! FLX_BURSSSSIL - burial fluxes of silicate [mol Si m-2 s-1] -! FLX_BURSSSTER - burial fluxes of clay [g m-2 s-1] +! BURSSO12 - burial fluxes organic carbon [mol P m-2 s-1] +! BURSSSC12 - burial fluxes of calcium carbonate [mol Ca m-2 s-1] +! BURSSSSIL - burial fluxes of silicate [mol Si m-2 s-1] +! BURSSSTER - burial fluxes of clay [g m-2 s-1] ! ! Sediment fields (SDM) ! POWAIC - (powdic) [mol C m-3] From 93d74735208d171f9aa9df97ce4616af2ab32046 Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Thu, 30 May 2024 15:50:47 +0200 Subject: [PATCH 361/366] Write amt_n2o always to 2D field --- hamocc/mo_carchm.F90 | 10 ++++------ hamocc/mo_ini_fields.F90 | 2 +- 2 files changed, 5 insertions(+), 7 deletions(-) diff --git a/hamocc/mo_carchm.F90 b/hamocc/mo_carchm.F90 index 75350a70..200979a5 100644 --- a/hamocc/mo_carchm.F90 +++ b/hamocc/mo_carchm.F90 @@ -119,7 +119,7 @@ subroutine carchm(kpie,kpje,kpke,kbnd,pdlxp,pdlyp,pddpo,prho,pglat,omask,psicomo real :: scco2,sco2,scn2,scdms,scn2o real :: xconvxa real :: oxflux,niflux,dmsflux,n2oflux - real :: ato2,atn2,atco2,pco2,atn2ov + real :: ato2,atn2,atco2,pco2,atn2o real :: oxy,ani,anisa real :: rrho,t,t2,t3,t4,tk,tk100,prb,s,rs real :: Kh,Khd,K1,K2,Kb,K1p,K2p,K3p,Ksi,Kw,Ks1,Kf,Kspc,Kspa @@ -177,7 +177,7 @@ subroutine carchm(kpie,kpje,kpke,kbnd,pdlxp,pdlyp,pddpo,prho,pglat,omask,psicomo !$OMP PARALLEL DO PRIVATE(t,t2,t3,t4,tk,tk100,s,rs,prb,Kh,Khd,K1,K2 & !$OMP ,Kb,K1p,K2p,K3p,Ksi,Kw,Ks1,Kf,Kspc,Kspa,tc,ta,sit,pt,ah1,ac & !$OMP ,cu,cb,cc,pco2,rpp0,scco2,scdms,sco2,oxy,ani,anisa,Xconvxa & - !$OMP ,kwco2,kwdms,kwo2,atco2,ato2,atn2,atn2ov,fluxd,fluxu,oxflux & + !$OMP ,kwco2,kwdms,kwo2,atco2,ato2,atn2,atn2o,fluxd,fluxu,oxflux & !$OMP ,tc_sat,niflux,n2oflux,dmsflux,omega,supsat,undsa,dissol & !$OMP ,sch_11,sch_12,sch_sf,kw_11,kw_12,kw_sf,a_11,a_12,a_sf,flx11 & !$OMP ,flx12,flxsf,atm_cfc11,atm_cfc12,atm_sf6,fact & @@ -387,6 +387,7 @@ subroutine carchm(kpie,kpje,kpke,kbnd,pdlxp,pdlyp,pddpo,prho,pglat,omask,psicomo atco2 = atm(i,j,iatmco2) ato2 = atm(i,j,iatmo2) atn2 = atm(i,j,iatmn2) + atn2o = atm(i,j,iatmn2o) if (use_cisonew) then atco213 = atm(i,j,iatmc13) atco214 = atm(i,j,iatmc14) @@ -396,9 +397,6 @@ subroutine carchm(kpie,kpje,kpke,kbnd,pdlxp,pdlyp,pddpo,prho,pglat,omask,psicomo endif if (use_extNcycle) then atnh3 = atm(i,j,iatmnh3) - atn2ov = atm(i,j,iatmn2o) - else - atn2ov = atm_n2o endif ! Ratio P/P_0, where P is the local SLP and P_0 is standard pressure (1 atm). This is @@ -457,7 +455,7 @@ subroutine carchm(kpie,kpje,kpke,kbnd,pdlxp,pdlyp,pddpo,prho,pglat,omask,psicomo niflux=kwn2*dtbgc*(ocetra(i,j,1,igasnit)-anisa*(atn2/802000)*rpp0) ocetra(i,j,1,igasnit)=ocetra(i,j,1,igasnit)-niflux/pddpo(i,j,1) ! Surface flux of laughing gas (same piston velocity as for O2 and N2) - n2oflux=kwn2o*dtbgc*(ocetra(i,j,1,ian2o)-satn2o(i,j)*atn2ov*1e-12*rpp0) + n2oflux=kwn2o*dtbgc*(ocetra(i,j,1,ian2o)-satn2o(i,j)*atn2o*1e-12*rpp0) ! pN2O under moist air assumption at normal pressure pn2om(i,j) = 1e9 * ocetra(i,j,1,ian2o)/satn2o(i,j) ocetra(i,j,1,ian2o)=ocetra(i,j,1,ian2o)-n2oflux/pddpo(i,j,1) diff --git a/hamocc/mo_ini_fields.F90 b/hamocc/mo_ini_fields.F90 index 6c73e808..26f4e131 100644 --- a/hamocc/mo_ini_fields.F90 +++ b/hamocc/mo_ini_fields.F90 @@ -59,6 +59,7 @@ subroutine ini_fields_atm(kpie,kpje) atm(i,j,iatmco2) = atm_co2 atm(i,j,iatmo2) = atm_o2 atm(i,j,iatmn2) = atm_n2 + atm(i,j,iatmn2o) = atm_n2o if (use_natDIC) then atm(i,j,iatmnco2) = atm_co2_nat endif @@ -71,7 +72,6 @@ subroutine ini_fields_atm(kpie,kpje) endif if (use_extNcycle) then atm(i,j,iatmnh3) = atm_nh3 - atm(i,j,iatmn2o) = atm_n2o endif enddo enddo From 2b20826af49b0c8626c9af1c8843777b7904e1be Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Thu, 30 May 2024 16:26:12 +0200 Subject: [PATCH 362/366] adjust description of output nml --- cime_config/ocn_in.readme | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/cime_config/ocn_in.readme b/cime_config/ocn_in.readme index 101d8c93..b12f07b3 100644 --- a/cime_config/ocn_in.readme +++ b/cime_config/ocn_in.readme @@ -564,7 +564,7 @@ ! DNIT - Vertically integrated denitrification ! ! -! Particle fluxes (FLX, e.g CARFLX****, where ****=0100,0500,1000,2000,4000, or _BOT), +! Particle fluxes (FLX_, e.g FLX_CAR****, where ****=0100,0500,1000,2000,4000, or _BOT), ! diffusive fluxes at the sediment - water-column interface (SEDIFF*), and other fluxes ! NDEPNOY - Nitrogen deposition flux in form of nitrate [mol N m-2 s-1] ! NDEPNHX - Nitrogen deposition flux in form of ammonium [mol N m-2 s-1] From 30b97a2accf0395c77481ea763c2b9b23e98d1ac Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Thu, 30 May 2024 17:25:23 +0200 Subject: [PATCH 363/366] Clarify dependency of do_ndep_coupled on do_ndep --- cime_config/ocn_in.readme | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/cime_config/ocn_in.readme b/cime_config/ocn_in.readme index b12f07b3..891e8785 100644 --- a/cime_config/ocn_in.readme +++ b/cime_config/ocn_in.readme @@ -363,7 +363,7 @@ ! DO_RIVINPT : Logical switch to activate riverine input ! RIVINFILE : File name (incl. full path) for riverine input data ! DO_NDEP : Logical switch to activate N-deposition -! DO_NDEP_COUPLED: Logical to apply N-deposition fluxes received from the atmosphere (true=atm, false=clim) +! DO_NDEP_COUPLED: Logical to apply N-deposition fluxes received from the atmosphere (true=atm, false=clim), requires DO_NDEP=TRUE ! NDEPFILE : File name (incl. full path) for atmopheric N-deposition data ! DO_N2ONH3_COUPLED: Logical switch for interactive coupling of N2O and NH3 fluxes (true=atm, false=fix atmospheric value) ! DO_SEDSPINUP: Logical switch to activate sediment spin-up From 50aab8cc1f56628680e48c98d7ffafd143757c4b Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Thu, 30 May 2024 17:31:34 +0200 Subject: [PATCH 364/366] Make dependency of do_ndep_coupled on do_ndep more explicit --- hamocc/mo_hamocc4bcm.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/hamocc/mo_hamocc4bcm.F90 b/hamocc/mo_hamocc4bcm.F90 index 5e2a720f..97d40723 100644 --- a/hamocc/mo_hamocc4bcm.F90 +++ b/hamocc/mo_hamocc4bcm.F90 @@ -192,7 +192,7 @@ subroutine hamocc4bcm(kpie,kpje,kpke,kbnd,kplyear,kplmon,kplday,kldtday,pdlxp,pd if (mnproc.eq.1) write (io_stdo_bgc,*) 'iHAMOCC: getting N2O and NH3 conc. from atm' endif - if (do_ndep_coupled) then + if (do_ndep .and. do_ndep_coupled) then fatmndep = 365.*86400./mw_nitrogen ndep(:,:,:) = 0. !$OMP PARALLEL DO PRIVATE(i) From 2386ea3085c196d68c732c47e658605d0ec99c85 Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Thu, 30 May 2024 18:38:02 +0200 Subject: [PATCH 365/366] Restructure online atmosphere nitrogen deposition --- hamocc/mo_apply_ndep.F90 | 2 +- hamocc/mo_hamocc4bcm.F90 | 33 +++------------ hamocc/mo_hamocc_step.F90 | 8 ++-- hamocc/mo_read_ndep.F90 | 87 ++++++++++++++++++++++++++------------- 4 files changed, 69 insertions(+), 61 deletions(-) diff --git a/hamocc/mo_apply_ndep.F90 b/hamocc/mo_apply_ndep.F90 index b20cc5f5..856d0729 100644 --- a/hamocc/mo_apply_ndep.F90 +++ b/hamocc/mo_apply_ndep.F90 @@ -97,6 +97,6 @@ subroutine apply_ndep(kpie,kpje,kpke,pddpo,omask,ndep) enddo end subroutine apply_ndep - + !************************************************************************************************* end module mo_apply_ndep diff --git a/hamocc/mo_hamocc4bcm.F90 b/hamocc/mo_hamocc4bcm.F90 index 97d40723..ec5f6c3a 100644 --- a/hamocc/mo_hamocc4bcm.F90 +++ b/hamocc/mo_hamocc4bcm.F90 @@ -28,7 +28,7 @@ module mo_hamocc4bcm subroutine hamocc4bcm(kpie,kpje,kpke,kbnd,kplyear,kplmon,kplday,kldtday,pdlxp,pdlyp,pddpo,prho, & pglat,omask, dust,rivin,ndep,oafx,pi_ph,pfswr,psicomo,ppao,pfu10,ptho,psao,& patmco2,pflxco2,pflxdms,patmbromo,pflxbromo, & - patmn2o,pflxn2o,patmnh3,pflxnh3,patmnhxdep,patmnoydep) + patmn2o,pflxn2o,patmnh3,pflxnh3) !*********************************************************************************************** ! Main routine of iHAMOCC. @@ -55,9 +55,8 @@ subroutine hamocc4bcm(kpie,kpje,kpke,kbnd,kplyear,kplmon,kplday,kldtday,pdlxp,pd do_sedspinup,sedspin_yr_s,sedspin_yr_e,sedspin_ncyc, & use_BROMO, use_CFC, use_PBGC_CK_TIMESTEP, & use_BOXATM, use_sedbypass,ocn_co2_type, & - do_ndep_coupled,do_n2onh3_coupled,use_extNcycle - use mo_param1_bgc, only: iatmco2,iatmdms,nocetra,nriv,iatmbromo,nndep,idepnoy,iatmn2o, & - iatmnh3,idepnhx + do_n2onh3_coupled,use_extNcycle + use mo_param1_bgc, only: iatmco2,iatmdms,nocetra,nriv,iatmbromo,nndep,iatmn2o,iatmnh3 use mo_vgrid, only: set_vgrid use mo_apply_fedep, only: apply_fedep use mo_apply_rivin, only: apply_rivin @@ -72,7 +71,7 @@ subroutine hamocc4bcm(kpie,kpje,kpke,kbnd,kplyear,kplmon,kplday,kldtday,pdlxp,pd use mo_cyano, only: cyano use mo_ocprod, only: ocprod use mo_carchm, only: carchm - use mo_chemcon, only: mw_nitrogen,mw_nh3,mw_n2o + use mo_chemcon, only: mw_nh3,mw_n2o ! Arguments integer, intent(in) :: kpie ! 1st dimension of model grid. @@ -91,7 +90,7 @@ subroutine hamocc4bcm(kpie,kpje,kpke,kbnd,kplyear,kplmon,kplday,kldtday,pdlxp,pd real, intent(in) :: omask (kpie,kpje) ! land/ocean mask. real, intent(in) :: dust (kpie,kpje) ! dust deposition flux [kg/m2/month]. real, intent(in) :: rivin (kpie,kpje,nriv) ! riverine input [kmol m-2 yr-1]. - real, intent(inout):: ndep (kpie,kpje,nndep) ! nitrogen deposition [kmol m-2 yr-1]. + real, intent(in) :: ndep (kpie,kpje,nndep) ! nitrogen deposition [kmol m-2 yr-1]. real, intent(in) :: oafx (kpie,kpje) ! alkalinity flux from alkalinization [kmol m-2 yr-1] real, intent(in) :: pi_ph (kpie,kpje) ! pre-ind. pH climatology used for pH-dependent DMS fluxes [log10([H+])] real, intent(in) :: pfswr (1-kbnd:kpie+kbnd,1-kbnd:kpje+kbnd) ! solar radiation [W/m**2]. @@ -109,14 +108,11 @@ subroutine hamocc4bcm(kpie,kpje,kpke,kbnd,kplyear,kplmon,kplday,kldtday,pdlxp,pd real, intent(out) :: pflxn2o(1-kbnd:kpie+kbnd,1-kbnd:kpje+kbnd) ! Nitrous oxide flux [kg N2O m-2 s-1]. real, intent(in) :: patmnh3(1-kbnd:kpie+kbnd,1-kbnd:kpje+kbnd) ! atmospheric ammonia concentration [ppt] used in fully coupled mode real, intent(out) :: pflxnh3(1-kbnd:kpie+kbnd,1-kbnd:kpje+kbnd) ! Ammonia flux [kg NH3 m-2 s-1]. - real, intent(in) :: patmnhxdep(1-kbnd:kpie+kbnd,1-kbnd:kpje+kbnd) ! Atmospheric NHx deposition [kgN m-2 s-1] - real, intent(in) :: patmnoydep(1-kbnd:kpie+kbnd,1-kbnd:kpje+kbnd) ! Atmospheric NOy deposition [kgN m-2 s-1] ! Local variables integer :: i,j,k,l integer :: nspin,it logical :: lspin - real :: fatmndep if (mnproc.eq.1) then write(io_stdo_bgc,*) 'iHAMOCC',KLDTDAY,LDTRUNBGC,NDTDAYBGC @@ -191,25 +187,6 @@ subroutine hamocc4bcm(kpie,kpje,kpke,kbnd,kplyear,kplmon,kplday,kldtday,pdlxp,pd !$OMP END PARALLEL DO if (mnproc.eq.1) write (io_stdo_bgc,*) 'iHAMOCC: getting N2O and NH3 conc. from atm' endif - - if (do_ndep .and. do_ndep_coupled) then - fatmndep = 365.*86400./mw_nitrogen - ndep(:,:,:) = 0. - !$OMP PARALLEL DO PRIVATE(i) - do j=1,kpje - do i=1,kpie - ! convert from kgN/m2/s to climatological input file units: kmolN/m2/yr - if (patmnoydep(i,j).gt.0.) then - ndep(i,j,idepnoy) = patmnoydep(i,j)*fatmndep - endif - if (patmnhxdep(i,j).gt.0.) then - ndep(i,j,idepnhx) = patmnhxdep(i,j)*fatmndep - endif - enddo - enddo - !$OMP END PARALLEL DO - if (mnproc.eq.1) write (io_stdo_bgc,*) 'iHAMOCC: getting NOy and NHx deposition from atm' - endif endif !-------------------------------------------------------------------- diff --git a/hamocc/mo_hamocc_step.F90 b/hamocc/mo_hamocc_step.F90 index 67c8fe8c..39515374 100644 --- a/hamocc/mo_hamocc_step.F90 +++ b/hamocc/mo_hamocc_step.F90 @@ -28,7 +28,7 @@ subroutine hamocc_step(m,n,mm,nn,k1m,k1n) ! ********************************************************************************************** ! Perform one HAMOCC step ! ********************************************************************************************** - + use mod_xc, only: idm,jdm,kdm,nbdy use mod_time, only: date,nday_of_year,nstep,nstep_in_day use mod_grid, only: plat @@ -43,7 +43,7 @@ subroutine hamocc_step(m,n,mm,nn,k1m,k1n) use mo_read_ndep, only: get_ndep use mo_read_oafx, only: get_oafx use mo_read_pi_ph, only: get_pi_ph,pi_ph - use mo_control_bgc, only: with_dmsph,do_ndep_coupled + use mo_control_bgc, only: with_dmsph use mo_accfields, only: accfields use mo_hamocc4bcm, only: hamocc4bcm use mo_trc_limitc, only: trc_limitc @@ -75,7 +75,7 @@ subroutine hamocc_step(m,n,mm,nn,k1m,k1n) enddo call get_fedep(idm,jdm,date%month,dust) - if (.not. do_ndep_coupled) call get_ndep(idm,jdm,date%year,date%month,omask,ndep) + call get_ndep(idm,jdm,nbdy,date%year,date%month,omask,ndep,atmnhxdep,atmnoydep) call get_oafx(idm,jdm,date%year,date%month,omask,oafx) if(with_dmsph) call get_pi_ph(idm,jdm,date%month) @@ -83,7 +83,7 @@ subroutine hamocc_step(m,n,mm,nn,k1m,k1n) & bgc_rho,plat,omask,dust,rivflx,ndep,oafx,pi_ph,swa,ficem,slp,abswnd, & & temp(1-nbdy,1-nbdy,1+nn),saln(1-nbdy,1-nbdy,1+nn), & & atmco2,flxco2,flxdms,atmbrf,flxbrf, & - & atmn2o,flxn2o,atmnh3,flxnh3,atmnhxdep,atmnoydep) + & atmn2o,flxn2o,atmnh3,flxnh3) ! ! --- accumulate fields and write output diff --git a/hamocc/mo_read_ndep.F90 b/hamocc/mo_read_ndep.F90 index dda0e245..723e2c24 100644 --- a/hamocc/mo_read_ndep.F90 +++ b/hamocc/mo_read_ndep.F90 @@ -172,30 +172,36 @@ subroutine ini_read_ndep(kpie,kpje) end subroutine ini_read_ndep - subroutine get_ndep(kpie,kpje,kplyear,kplmon,omask,ndep) + subroutine get_ndep(kpie,kpje,kbnd,kplyear,kplmon,omask,ndep,patmnhxdep,patmnoydep) !*********************************************************************************************** - ! Read and return CMIP6 n-deposition data for a given month. + ! Read and return CMIP6 n-deposition data for a given month or use atmosphere input ! ! S. Gao *Gfi, Bergen* 19.08.2017 !*********************************************************************************************** use mod_xc, only: mnproc use netcdf, only: nf90_open,nf90_close,nf90_nowrite - use mo_control_bgc, only: io_stdo_bgc,do_ndep,use_extNcycle + use mo_control_bgc, only: io_stdo_bgc,do_ndep,use_extNcycle, do_ndep_coupled use mo_netcdf_bgcrw, only: read_netcdf_var use mo_param1_bgc, only: nndep,idepnoy,idepnhx + use mo_chemcon, only: mw_nitrogen ! Arguments integer, intent(in) :: kpie ! 1st dimension of model grid. integer, intent(in) :: kpje ! 2nd dimension of model grid. + integer, intent(in) :: kbnd ! integer, intent(in) :: kplyear ! current year. integer, intent(in) :: kplmon ! current month. real, intent(in) :: omask(kpie,kpje) ! land/ocean mask (1=ocean) real, intent(out) :: ndep(kpie,kpje,nndep) ! N-deposition field for current year and month + real, intent(in) :: patmnhxdep(1-kbnd:kpie+kbnd,1-kbnd:kpje+kbnd) ! Atmospheric NHx deposition [kgN m-2 s-1] + real, intent(in) :: patmnoydep(1-kbnd:kpie+kbnd,1-kbnd:kpje+kbnd) ! Atmospheric NOy deposition [kgN m-2 s-1] + ! local variables integer :: month_in_file, ncstat, ncid, i, j + real :: fatmndep ! if N-deposition is switched off set ndep to zero and return if (.not. do_ndep) then @@ -203,37 +209,62 @@ subroutine get_ndep(kpie,kpje,kplyear,kplmon,omask,ndep) return endif - ! read ndep data from file - if (kplmon.ne.oldmonth) then - month_in_file=(max(startyear,min(endyear,kplyear))-startyear)*12+kplmon - if (mnproc.eq.1) then - write(io_stdo_bgc,*) 'Read N deposition month ',month_in_file,' from file ',trim(ndepfile) - endif - ncstat=nf90_open(trim(ndepfile),nf90_nowrite,ncid) - if (use_extNcycle) then - call read_netcdf_var(ncid,'nhxdep',nhxdepread,1,month_in_file,0) - call read_netcdf_var(ncid,'noydep',noydepread,1,month_in_file,0) - else - call read_netcdf_var(ncid,'ndep',ndepread,1,month_in_file,0) - endif - ncstat=nf90_close(ncid) - oldmonth=kplmon - endif + if (use_extNcycle .and. do_ndep_coupled) then + + ! get N-deposition from atmosphere + fatmndep = 365.*86400./mw_nitrogen + ndep(:,:,:) = 0. + !$OMP PARALLEL DO PRIVATE(i) + do j=1,kpje + do i=1,kpie + ! convert from kgN/m2/s to climatological input file units: kmolN/m2/yr + if (patmnoydep(i,j) > 0.) then + ndep(i,j,idepnoy) = patmnoydep(i,j)*fatmndep + endif + if (patmnhxdep(i,j) > 0.) then + ndep(i,j,idepnhx) = patmnhxdep(i,j)*fatmndep + endif + enddo + enddo + !$OMP END PARALLEL DO + if (mnproc .eq. 1) then + write (io_stdo_bgc,*) 'iHAMOCC: getting NOy and NHx deposition from atm' + endif + + else - !$OMP PARALLEL DO PRIVATE(i) - ! 1 = NO3; 2 = NH4 - do j=1,kpje - do i=1,kpie + ! read ndep data from file + if (kplmon.ne.oldmonth) then + month_in_file=(max(startyear,min(endyear,kplyear))-startyear)*12+kplmon + if (mnproc.eq.1) then + write(io_stdo_bgc,*) 'Read N deposition month ',month_in_file,' from file ',trim(ndepfile) + endif + ncstat=nf90_open(trim(ndepfile),nf90_nowrite,ncid) if (use_extNcycle) then - ndep(i,j,idepnoy) = noydepread(i,j) - ndep(i,j,idepnhx) = nhxdepread(i,j) + call read_netcdf_var(ncid,'nhxdep',nhxdepread,1,month_in_file,0) + call read_netcdf_var(ncid,'noydep',noydepread,1,month_in_file,0) else - ndep(i,j,idepnoy) = ndepread(i,j) + call read_netcdf_var(ncid,'ndep',ndepread,1,month_in_file,0) endif + ncstat=nf90_close(ncid) + oldmonth=kplmon + endif + + !$OMP PARALLEL DO PRIVATE(i) + ! 1 = NO3; 2 = NH4 + do j=1,kpje + do i=1,kpie + if (use_extNcycle) then + ndep(i,j,idepnoy) = noydepread(i,j) + ndep(i,j,idepnhx) = nhxdepread(i,j) + else + ndep(i,j,idepnoy) = ndepread(i,j) + endif + enddo enddo - enddo - !$OMP END PARALLEL DO + !$OMP END PARALLEL DO + endif end subroutine get_ndep end module mo_read_ndep From 066da575132289bb9b0aaf3efca4f5aa31c95bbc Mon Sep 17 00:00:00 2001 From: joeran maerz Date: Fri, 31 May 2024 18:03:16 +0200 Subject: [PATCH 366/366] Switching cyanobacteria on only in the euphotic zone - breaks bfb with recent master Before this last commit leuphotic_cya=true, it was bfb with default settings with master --- hamocc/mo_control_bgc.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/hamocc/mo_control_bgc.F90 b/hamocc/mo_control_bgc.F90 index 71908c4e..0da1dcf0 100644 --- a/hamocc/mo_control_bgc.F90 +++ b/hamocc/mo_control_bgc.F90 @@ -61,7 +61,7 @@ module mo_control_bgc logical :: do_oalk = .false. ! apply ocean alkalinization logical :: with_dmsph = .false. ! apply DMS with pH dependence logical :: use_M4AGO = .false. ! run with M4AGO settling scheme - logical :: leuphotic_cya = .false. ! allow cyanobacteria to grow only in euphotic zone + logical :: leuphotic_cya = .true. ! allow cyanobacteria to grow only in euphotic zone integer :: sedspin_yr_s = -1 ! start year for sediment spin-up integer :: sedspin_yr_e = -1 ! end year for sediment spin-up integer :: sedspin_ncyc = -1 ! sediment spin-up sub-cycles