From 2c32568b76ff1646e6626630b95bdaee11a055ef Mon Sep 17 00:00:00 2001 From: Jess <20195932+wrongkindofdoctor@users.noreply.github.com> Date: Thu, 28 Nov 2019 15:12:18 -0500 Subject: [PATCH 1/9] merge in latest dev/gfdl updates (#36) * TC4 integration into test suite This patch renames the tc4 test to activate it in the test suite. It also modifies the Makefile to build the input field test scripts. It also modifies the Python build scripts to be PEP8-conformant. We temporarily disable tc4 in the restart tests, since they currently fail. This needs to be addressed before we can merge this into the main branch. The patch does not enable the necessary Python modules for running on Travis, that will also be addressed later. * Travis python support; tc4 Makefile The custom TC4 Makefile has been added (oops), and the presumed Python Ubuntu packages have been added for Travis. * Verify ENABLE_THERMODYNAMICS is True before posting C_p diagnostic * Make tc4 faster * remove trailing whitespace * add unit scaling * fix restart fail for tc4 and some cleanup * remove trailiny ws * Enable tc4.restart test * +Pass timeesteps to tracer diagnostics in [T] Pass timeesteps to the tracer diagnistics routines post_tracer_diagnostics and postALE_tracer_diagnostics and to adiabatic in units of [T}. All answers are bitwise identical. * +Rescaled tracer advective flux diagnostics Rescaled the internal units of the tracer advective flux diagnostics to units of [conc H L2 T-1] for code simplicity and dimensional consistency testing. Also corrected the units of some tracer fluxes as documented in comments and commented out unused elements of the tracer_type. All answers are bitwise identical. * +Pass timesteps to ALE_main in [T] Pass the timesteps to ALE_main, ALE_main_offline, and ALE_main_accelerated in units of [T] for code simplicity and dimensional consistency testing. This also includes the rescaling of remapping-driven tracer tendencies. All answers and diagnostics are bitwise identical. * +Pass timesteps to tracer column_physics in [T] Pass timesteps to the various tracer column_physics routines in [T] for dimensional consistency testing. Also added a new unit_scale_type argument to these routines. All answers are bitwise identical, but there are minor interface changes to 13 subroutines. * +Pass timesteps to applyTracerBoundaryFluxesInOut in [T] Pass timesteps to applyTracerBoundaryFluxesInOut in [T], and use units of [T-1] for internal source and decay rates for the oil tracer and in fluxes of CFCs. Also modified extract_offline_main to return timesteps as real values with units of [T]. Also there is a new unit_scale_type argument to register_oil_tracer. All answers in the MOM6_examples test cases and regression tests are bitwise identical. * Simplified expressions in MOM_PointAccel Simplified expressions inside of MOM_PointAccel, taking into account that all velocities use the same units of [L T-1]. All answers are bitwise identical. * Corrected dimensional epsilons in downscaling Added distinct negligible volumes, face areas, horizonal areas and lengths with proper dimensional rescaling in the downsample field routines. With these changes, downscaled diagnostics should now pass the dimensional rescaling tests, whereas previously there would have been a problem when the numbers used to represent lengths are smaller than about 1e-8 times their MKS values. All answers are bitwise identical without dimensional rescaling. * Simplified expressions in MOM_offline_aux Simplified expressions in distribute_residual_uh_barotropic. All answers are bitwise identical. * Revised wave_speed to return speed in [L T-1] Revised wave_speed to return the internal wave speed in units of [L T-1] and to use mono_N2_depth in units of [Z] for code simplification and expanded dimensional consistency testing. Also revised the internal units of some related diagnostics in calculate_diagnostic_fields. All answers and diagnostics are bitwise identical. * Rescaled internal variables in wave_speed Rescale internal calculations in wave_speed and wave_speeds for greater robustness and dimensional consistency testing. All answers are bitwise identical and pass dimensional scaling tests. * +Changed the units of minimum_forcing_depth to [H] Changed the units of minimum_forcing_depth passed to applyBoundaryFluxesInOut and applyTracerBoundaryFluxesInOut to [H]. All answers are bitwise identical. * Correction of documented units in comments Corrected some units in comments and eliminated some unused variables. All answers are bitwise identical. * Adiabatic clock ID bugfix This patch fixes an initialization bug of the diabatic timer, which was being used to measure adiabatic time but was never initialized if the experiment was configured as adiabatic. We fix this by introducing a separate timer for the adiabatic solver. Although we could have reused the diabatic timer, the addition of a new variable should not add any overhead on modern compilers. * Corrected an OMP declaration Added a variable to an OMP declaration. All answers are bitwise identical, and a recently added compile-time error with openMP was fixed. * Update MOM.F90 Fixed Alistair's embarrassing error. * Dimensional rescaling in MOM_open_boundary.F90 Added rescaling for dimensional consistency testing in MOM_open_boundary.F90, including splitting variables with different units that had previously shared the same variable and adding more extensive documentation of variables. Also changed the dimensions of the timesteps passed to radiation_open_bdry_conds and update_segment_tracer_reservoirs to [T] and added vertical_grid_type and unit_scale_type arguments to open_boundary_init and open_boundary_test_extern_h. All answers are bitwise identical, although some probably bugs have been noted in comments and there are new or altered arguments to several routines. * (*)Fixed invariance bugs in MOM_open_boundary.F90 Corrected dimensional consistency bugs in update_segment_tracer_reservoirs and horizontal indexing and related bugs in gradient_at_q_points with oblique_grad OBCs. These will both change answers in test cases that use some open boundary condition options, but not in any of the MOM6-examples test cases. --- .testing/Makefile | 17 +- .testing/_tc4/build_data.py | 68 -- .testing/_tc4/build_grid.py | 75 -- .testing/_tc4/input.nml | 27 - .testing/{_tc4 => tc4}/MOM_input | 17 +- .testing/{_tc4 => tc4}/MOM_override | 0 .testing/tc4/Makefile | 3 + .testing/tc4/build_data.py | 80 ++ .testing/tc4/build_grid.py | 76 ++ .testing/{_tc4 => tc4}/diag_table | 0 .testing/tc4/input.nml | 18 + src/ALE/MOM_ALE.F90 | 23 +- src/core/MOM.F90 | 45 +- src/core/MOM_dynamics_split_RK2.F90 | 8 +- src/core/MOM_open_boundary.F90 | 855 ++++++++++-------- src/core/MOM_variables.F90 | 6 +- src/diagnostics/MOM_PointAccel.F90 | 70 +- src/diagnostics/MOM_diagnostics.F90 | 88 +- src/diagnostics/MOM_wave_speed.F90 | 195 ++-- src/framework/MOM_diag_mediator.F90 | 99 +- .../MOM_state_initialization.F90 | 12 +- src/parameterizations/lateral/MOM_MEKE.F90 | 12 +- .../lateral/MOM_hor_visc.F90 | 20 +- .../lateral/MOM_internal_tides.F90 | 14 +- .../lateral/MOM_lateral_mixing_coeffs.F90 | 36 +- .../lateral/MOM_thickness_diffuse.F90 | 12 +- .../vertical/MOM_ALE_sponge.F90 | 222 ++--- .../vertical/MOM_diabatic_aux.F90 | 6 +- .../vertical/MOM_diabatic_driver.F90 | 53 +- .../vertical/MOM_energetic_PBL.F90 | 2 +- src/tracer/DOME_tracer.F90 | 16 +- src/tracer/ISOMIP_tracer.F90 | 19 +- src/tracer/MOM_OCMIP2_CFC.F90 | 21 +- src/tracer/MOM_generic_tracer.F90 | 8 +- src/tracer/MOM_offline_aux.F90 | 8 +- src/tracer/MOM_offline_main.F90 | 50 +- src/tracer/MOM_tracer_advect.F90 | 10 +- src/tracer/MOM_tracer_diabatic.F90 | 11 +- src/tracer/MOM_tracer_flow_control.F90 | 84 +- src/tracer/MOM_tracer_hor_diff.F90 | 2 +- src/tracer/MOM_tracer_registry.F90 | 98 +- src/tracer/RGC_tracer.F90 | 19 +- src/tracer/advection_test_tracer.F90 | 17 +- src/tracer/boundary_impulse_tracer.F90 | 16 +- src/tracer/dye_example.F90 | 11 +- src/tracer/dyed_obc_tracer.F90 | 12 +- src/tracer/ideal_age_example.F90 | 17 +- src/tracer/oil_tracer.F90 | 44 +- src/tracer/pseudo_salt_tracer.F90 | 10 +- src/tracer/tracer_example.F90 | 6 +- 50 files changed, 1345 insertions(+), 1293 deletions(-) delete mode 100644 .testing/_tc4/build_data.py delete mode 100644 .testing/_tc4/build_grid.py delete mode 100644 .testing/_tc4/input.nml rename .testing/{_tc4 => tc4}/MOM_input (96%) rename .testing/{_tc4 => tc4}/MOM_override (100%) create mode 100644 .testing/tc4/Makefile create mode 100644 .testing/tc4/build_data.py create mode 100644 .testing/tc4/build_grid.py rename .testing/{_tc4 => tc4}/diag_table (100%) create mode 100644 .testing/tc4/input.nml diff --git a/.testing/Makefile b/.testing/Makefile index 66247a252a..645b9dc8f8 100644 --- a/.testing/Makefile +++ b/.testing/Makefile @@ -251,6 +251,7 @@ results/%/ocean.stats.$(1): ../build/$(2)/MOM6 if [ $(3) ]; then find ../build/$(2) -name *.gcda -exec rm -f '{}' \; ; fi mkdir -p work/$$*/$(1) cp -rL $$*/* work/$$*/$(1) + cd work/$$*/$(1) && if [ -f Makefile ]; then make; fi mkdir -p work/$$*/$(1)/RESTART echo $(4) > work/$$*/$(1)/MOM_override cd work/$$*/$(1) && $$(call MPIRUN_CMD,$(5)) -n $(6) ../../../$$< 2> debug.out > std.out \ @@ -285,6 +286,7 @@ results/%/ocean.stats.restart: ../build/symmetric/MOM6 rm -rf work/$*/restart mkdir -p work/$*/restart cp -rL $*/* work/$*/restart + cd work/$*/restart && if [ -f Makefile ]; then make; fi mkdir -p work/$*/restart/RESTART # Generate the half-period input namelist # TODO: Assumes runtime set by DAYMAX, will fail if set by input.nml @@ -294,20 +296,19 @@ results/%/ocean.stats.restart: ../build/symmetric/MOM6 && if [ -z "$${timeunit}" ]; then timeunit="8.64e4"; fi \ && printf -v timeunit_int "%.f" "$${timeunit}" \ && halfperiod=$$(printf "%.f" $$(bc <<< "scale=10; 0.5 * $${daymax} * $${timeunit_int}")) \ - && printf "\n&ocean_solo_nml\n seconds = $${halfperiod}\n/\n" >> input.nml \ - && echo $${daymax} $${timeunit} + && printf "\n&ocean_solo_nml\n seconds = $${halfperiod}\n/\n" >> input.nml # Run the first half-period - cd work/$*/restart && $(MPIRUN) -n 1 ../../../$< 2> debug.out > std.out \ - || ! sed 's/^/$*.restart1: /' std.out debug.out \ - && sed 's/^/$*.restart1: /' std.out + cd work/$*/restart && $(MPIRUN) -n 1 ../../../$< 2> debug1.out > std1.out \ + || ! sed 's/^/$*.restart1: /' std1.out debug1.out \ + && sed 's/^/$*.restart1: /' std1.out # Setup the next inputs cd work/$*/restart && rm -rf INPUT && mv RESTART INPUT mkdir work/$*/restart/RESTART cd work/$*/restart && sed -i -e "s/input_filename *= *'n'/input_filename = 'r'/g" input.nml # Run the second half-period - cd work/$*/restart && $(MPIRUN) -n 1 ../../../$< 2> debug.out > std.out \ - || ! sed 's/^/$*.restart2: /' std.out debug.out \ - && sed 's/^/$*.restart2: /' std.out + cd work/$*/restart && $(MPIRUN) -n 1 ../../../$< 2> debug2.out > std2.out \ + || ! sed 's/^/$*.restart2: /' std2.out debug2.out \ + && sed 's/^/$*.restart2: /' std2.out # Archive the results and cleanup mkdir -p $(@D) cp work/$*/restart/ocean.stats $@ diff --git a/.testing/_tc4/build_data.py b/.testing/_tc4/build_data.py deleted file mode 100644 index 904db77c7a..0000000000 --- a/.testing/_tc4/build_data.py +++ /dev/null @@ -1,68 +0,0 @@ -import netCDF4 as nc -import numpy as np - -x=nc.Dataset('ocean_hgrid.nc').variables['x'][1::2,1::2] -y=nc.Dataset('ocean_hgrid.nc').variables['y'][1::2,1::2] -zbot=nc.Dataset('topog.nc').variables['depth'][:] -zbot0=zbot.max() - -def t_fc(x,y,z,radius=5.0,tmag=1.0): # a radially symmetric anomaly in the center of the domain. units are meters and degC - ny,nx=x.shape;nz=z.shape[0] - x0=x[int(ny/2),int(nx/2)];y0=y[int(ny/2),int(nx/2)] - tl=np.zeros((nz,ny,nx)) - zb=z[-1] - if len(z)>1: - zd=z/zb - else: - zd=[0.] - for k in np.arange(len(zd)): - r=np.sqrt((x-x0)**2.+(y-y0)**2.) - tl[k,:]=tl[k,:]+(1.0-np.minimum(r/radius,1.0))*tmag*(1.0-zd[k]) - return tl - -ny,nx = x.shape -nz=10;z=(np.arange(nz)*zbot0)/nz - -temp=t_fc(x,y,z) -salt=np.zeros(temp.shape)+35.0 -fl=nc.Dataset('temp_salt_ic.nc','w',format='NETCDF3_CLASSIC') -fl.createDimension('lon',nx) -fl.createDimension('lat',ny) -fl.createDimension('depth',nz) -fl.createDimension('Time',None) -zv=fl.createVariable('depth','f8',('depth')) -lonv=fl.createVariable('lon','f8',('lon')) -latv=fl.createVariable('lat','f8',('lat')) -timev=fl.createVariable('Time','f8',('Time')) -timev.calendar='noleap' -timev.units='days since 0001-01-01 00:00:00.0' -timev.modulo=' ' -tv=fl.createVariable('ptemp','f8',('Time','depth','lat','lon'),fill_value=-1.e20) -sv=fl.createVariable('salt','f8',('Time','depth','lat','lon'),fill_value=-1.e20) -tv[:]=temp[np.newaxis,:] -sv[:]=salt[np.newaxis,:] -zv[:]=z -lonv[:]=x[0,:] -latv[:]=y[:,0] -timev[0]=0. -fl.sync() -fl.close() - - -# Make Sponge forcing file -dampTime=20.0 # days -secDays=8.64e4 -fl=nc.Dataset('sponge.nc','w',format='NETCDF3_CLASSIC') -fl.createDimension('lon',nx) -fl.createDimension('lat',ny) -lonv=fl.createVariable('lon','f8',('lon')) -latv=fl.createVariable('lat','f8',('lat')) -spv=fl.createVariable('Idamp','f8',('lat','lon'),fill_value=-1.e20) -Idamp=np.zeros((ny,nx)) -if dampTime>0.: - Idamp=0.0+1.0/(dampTime*secDays) -spv[:]=Idamp -lonv[:]=x[0,:] -latv[:]=y[:,0] -fl.sync() -fl.close() diff --git a/.testing/_tc4/build_grid.py b/.testing/_tc4/build_grid.py deleted file mode 100644 index 8187e98144..0000000000 --- a/.testing/_tc4/build_grid.py +++ /dev/null @@ -1,75 +0,0 @@ -import netCDF4 as nc -from netCDF4 import stringtochar -import numpy as np - - -nx=14;ny=10 # grid size -depth0=100. #uniform depth -ds=0.01 # grid resolution at the equator in degrees -Re=6.378e6 # Radius of earth - -topo_=np.zeros((ny,nx))+depth0 -f_topo=nc.Dataset('topog.nc','w',format='NETCDF3_CLASSIC') -ny,nx=topo_.shape -f_topo.createDimension('ny',ny) -f_topo.createDimension('nx',nx) -f_topo.createDimension('ntiles',1) -f_topo.createVariable('depth','f8',('ny','nx')) -f_topo.createVariable('h2','f8',('ny','nx')) -f_topo.variables['depth'][:]=topo_ -f_topo.sync() -f_topo.close() - -x_=np.arange(0,2*nx+1)*ds # units are degrees E -y_=np.arange(0,2*ny+1)*ds # units are degrees N -x,y=np.meshgrid(x_,y_) - -dx=np.zeros((2*ny+1,2*nx)) -dy=np.zeros((2*ny,2*nx+1)) -rad_deg=np.pi/180. -dx[:]=rad_deg*Re*(x[:,1:]-x[:,0:-1])*np.cos(0.5*rad_deg*(y[:,0:-1]+y[:,1:])) -dy[:]=rad_deg*Re*(y[1:,:]-y[0:-1,:]) - -f_sg=nc.Dataset('ocean_hgrid.nc','w',format='NETCDF3_CLASSIC') -f_sg.createDimension('ny',ny*2) -f_sg.createDimension('nx',nx*2) -f_sg.createDimension('nyp',ny*2+1) -f_sg.createDimension('nxp',nx*2+1) -f_sg.createDimension('string',5) -f_sg.createVariable('y','f8',('nyp','nxp')) -f_sg.createVariable('x','f8',('nyp','nxp')) -dyv=f_sg.createVariable('dy','f8',('ny','nxp')) -dxv=f_sg.createVariable('dx','f8',('nyp','nx')) -areav=f_sg.createVariable('area','f8',('ny','nx')) -dxv.units='m' -dyv.units='m' -areav.units='m2' -f_sg.createVariable('angle_dx','f8',('nyp','nxp')) -f_sg.createVariable('tile','S1',('string')) -f_sg.variables['y'].units='degrees' -f_sg.variables['x'].units='degrees' -f_sg.variables['dy'].units='meters' -f_sg.variables['dx'].units='meters' -f_sg.variables['area'].units='m2' -f_sg.variables['angle_dx'].units='degrees' -f_sg.variables['y'][:]=y -f_sg.variables['x'][:]=x -f_sg.variables['dx'][:]=dx -f_sg.variables['dy'][:]=dy -#Compute the area bounded by lines of constant -#latitude-longitud on a sphere in m2. -dlon=x_[1:]-x_[:-1] -dlon=np.tile(dlon[np.newaxis,:],(2*ny,1)) -y1_=y_[:-1] -y1_=y1_[:,np.newaxis]*rad_deg -y2_=y_[1:] -y2_=y2_[:,np.newaxis]*rad_deg -y1_=np.tile(y1_,(1,2*nx)) -y2_=np.tile(y2_,(1,2*nx)) -area=(rad_deg*Re*Re)*(np.sin(y2_)-np.sin(y1_)) * dlon -f_sg.variables['area'][:]=area -f_sg.variables['angle_dx'][:]=0. -str_=stringtochar(np.array(['tile1'],dtype='S5')) -f_sg.variables['tile'][:] = str_ -f_sg.sync() -f_sg.close() diff --git a/.testing/_tc4/input.nml b/.testing/_tc4/input.nml deleted file mode 100644 index 29918fbdee..0000000000 --- a/.testing/_tc4/input.nml +++ /dev/null @@ -1,27 +0,0 @@ - &MOM_input_nml - output_directory = './', - input_filename = 'n' - restart_input_dir = 'INPUT/', - restart_output_dir = 'RESTART/', - parameter_filename = 'MOM_input', - 'MOM_override' / - - &diag_manager_nml - flush_nc_files = .true. - / - - &fms_nml - domains_stack_size = 710000, - stack_size = 0 / - - &ocean_domains_nml - / - - &ocean_solo_nml - months = 0 - date_init = 1,1,1,0,0,0 - hours = 0 - minutes = 0 - seconds = 0 - calendar = 'julian' / - diff --git a/.testing/_tc4/MOM_input b/.testing/tc4/MOM_input similarity index 96% rename from .testing/_tc4/MOM_input rename to .testing/tc4/MOM_input index da0e887a6a..2b08e9bccb 100644 --- a/.testing/_tc4/MOM_input +++ b/.testing/tc4/MOM_input @@ -7,10 +7,15 @@ USE_REGRIDDING = True ! [Boolean] default = False ! If True, use the ALE algorithm (regridding/remapping). If False, use the ! layered isopycnal algorithm. -DT = 300.0 ! [s] +DT = 1200.0 ! [s] ! The (baroclinic) dynamics time step. The time-step that is actually used will ! be an integer fraction of the forcing time-step (DT_FORCING in ocean-only mode ! or the coupling timestep in coupled mode.) +DT_THERM = 3600.0 ! [s] default = 300.0 + ! The thermodynamic and tracer advection time step. Ideally DT_THERM should be + ! an integer multiple of DT and less than the forcing or coupling time-step, + ! unless THERMO_SPANS_COUPLING is true, in which case DT_THERM can be an integer + ! multiple of the coupling timestep. By default DT_THERM is set to DT. C_P = 3925.0 ! [J kg-1 K-1] default = 3991.86795711963 ! The heat capacity of sea water, approximated as a constant. This is only used ! if ENABLE_THERMODYNAMICS is true. The default value is from the TEOS-10 @@ -377,10 +382,15 @@ WIND_CONFIG = "zero" ! ! === module MOM_restart === ! === module MOM_main (MOM_driver) === -DAYMAX = 1.0 ! [days] +DAYMAX = 0.25 ! [days] ! The final time of the whole simulation, in units of TIMEUNIT seconds. This ! also sets the potential end time of the present run segment if the end time is ! not set via ocean_solo_nml in input.nml. + +ENERGYSAVEDAYS = 0.125 ! [days] default = 1.44E+04 + ! The interval in units of TIMEUNIT between saves of the + ! energies of the run and other globally summed diagnostics. + RESTART_CONTROL = 3 ! default = 1 ! An integer whose bits encode which restart files are written. Add 2 (bit 1) ! for a time-stamped file, and odd (bit 0) for a non-time-stamped file. A @@ -397,3 +407,6 @@ MAXCPU = 2.88E+04 ! [wall-clock seconds] default = -1.0 ! processors used. ! === module MOM_file_parser === + +DIAG_AS_CHKSUM = True +DEBUG = True diff --git a/.testing/_tc4/MOM_override b/.testing/tc4/MOM_override similarity index 100% rename from .testing/_tc4/MOM_override rename to .testing/tc4/MOM_override diff --git a/.testing/tc4/Makefile b/.testing/tc4/Makefile new file mode 100644 index 0000000000..cea78bf3bd --- /dev/null +++ b/.testing/tc4/Makefile @@ -0,0 +1,3 @@ +all: + python build_grid.py + python build_data.py diff --git a/.testing/tc4/build_data.py b/.testing/tc4/build_data.py new file mode 100644 index 0000000000..e060d05cb1 --- /dev/null +++ b/.testing/tc4/build_data.py @@ -0,0 +1,80 @@ +import netCDF4 as nc +import numpy as np + +x = nc.Dataset('ocean_hgrid.nc').variables['x'][1::2, 1::2] +y = nc.Dataset('ocean_hgrid.nc').variables['y'][1::2, 1::2] +zbot = nc.Dataset('topog.nc').variables['depth'][:] +zbot0 = zbot.max() + + +def t_fc(x, y, z, radius=5.0, tmag=1.0): + """a radially symmetric anomaly in the center of the domain. + units are meters and degC. + """ + ny, nx = x.shape + nz = z.shape[0] + + x0 = x[int(ny/2), int(nx/2)] + y0 = y[int(ny/2), int(nx/2)] + + tl = np.zeros((nz, ny, nx)) + zb = z[-1] + if len(z) > 1: + zd = z / zb + else: + zd = [0.] + for k in np.arange(len(zd)): + r = np.sqrt((x - x0)**2 + (y - y0)**2) + tl[k, :] += (1.0 - np.minimum(r / radius, 1.0)) * tmag * (1.0 - zd[k]) + return tl + + +ny, nx = x.shape +nz = 3 +z = (np.arange(nz) * zbot0) / nz + +temp = t_fc(x, y, z) +salt = np.zeros(temp.shape)+35.0 +fl = nc.Dataset('temp_salt_ic.nc', 'w', format='NETCDF3_CLASSIC') +fl.createDimension('lon', nx) +fl.createDimension('lat', ny) +fl.createDimension('depth', nz) +fl.createDimension('Time', None) +zv = fl.createVariable('depth', 'f8', ('depth')) +lonv = fl.createVariable('lon', 'f8', ('lon')) +latv = fl.createVariable('lat', 'f8', ('lat')) +timev = fl.createVariable('Time', 'f8', ('Time')) +timev.calendar = 'noleap' +timev.units = 'days since 0001-01-01 00:00:00.0' +timev.modulo = ' ' +tv = fl.createVariable('ptemp', 'f8', ('Time', 'depth', 'lat', 'lon'), + fill_value=-1.e20) +sv = fl.createVariable('salt', 'f8', ('Time', 'depth', 'lat', 'lon'), + fill_value=-1.e20) +tv[:] = temp[np.newaxis, :] +sv[:] = salt[np.newaxis, :] +zv[:] = z +lonv[:] = x[0, :] +latv[:] = y[:, 0] +timev[0] = 0. +fl.sync() +fl.close() + + +# Make Sponge forcing file +dampTime = 20.0 # days +secDays = 8.64e4 +fl = nc.Dataset('sponge.nc', 'w', format='NETCDF3_CLASSIC') +fl.createDimension('lon', nx) +fl.createDimension('lat', ny) +lonv = fl.createVariable('lon', 'f8', ('lon')) +latv = fl.createVariable('lat', 'f8', ('lat')) +spv = fl.createVariable('Idamp', 'f8', ('lat', 'lon'), fill_value=-1.e20) +Idamp = np.zeros((ny, nx)) +if dampTime > 0.: + Idamp = 0.0 + 1.0 / (dampTime * secDays) +spv[:] = Idamp +lonv[:] = x[0, :] +latv[:] = y[:, 0] +fl.sync() +fl.close() diff --git a/.testing/tc4/build_grid.py b/.testing/tc4/build_grid.py new file mode 100644 index 0000000000..7f1be74efd --- /dev/null +++ b/.testing/tc4/build_grid.py @@ -0,0 +1,76 @@ +import netCDF4 as nc +from netCDF4 import stringtochar +import numpy as np + +nx, ny = 14, 10 # Grid size +depth0 = 100. # Uniform depth +ds = 0.01 # grid resolution at the equator in degrees +Re = 6.378e6 # Radius of earth + +topo_ = np.zeros((ny, nx)) + depth0 +f_topo = nc.Dataset('topog.nc', 'w', format='NETCDF3_CLASSIC') +ny, nx = topo_.shape +f_topo.createDimension('ny', ny) +f_topo.createDimension('nx', nx) +f_topo.createDimension('ntiles', 1) +f_topo.createVariable('depth', 'f8', ('ny', 'nx')) +f_topo.createVariable('h2', 'f8', ('ny', 'nx')) +f_topo.variables['depth'][:] = topo_ +f_topo.sync() +f_topo.close() + +x_ = np.arange(0, 2*nx + 1) * ds # units are degrees E +y_ = np.arange(0, 2*ny + 1) * ds # units are degrees N +x, y = np.meshgrid(x_, y_) + +dx = np.zeros((2*ny + 1, 2*nx)) +dy = np.zeros((2*ny, 2*nx + 1)) +rad_deg = np.pi / 180. +dx[:] = (rad_deg * Re * (x[:, 1:] - x[:, 0:-1]) + * np.cos(0.5*rad_deg*(y[:, 0:-1] + y[:, 1:]))) +dy[:] = rad_deg * Re * (y[1:, :] - y[0:-1, :]) + +f_sg = nc.Dataset('ocean_hgrid.nc', 'w', format='NETCDF3_CLASSIC') +f_sg.createDimension('ny', 2*ny) +f_sg.createDimension('nx', 2*nx) +f_sg.createDimension('nyp', 2*ny + 1) +f_sg.createDimension('nxp', 2*nx + 1) +f_sg.createDimension('string', 5) +f_sg.createVariable('y', 'f8', ('nyp', 'nxp')) +f_sg.createVariable('x', 'f8', ('nyp', 'nxp')) +dyv = f_sg.createVariable('dy', 'f8', ('ny', 'nxp')) +dxv = f_sg.createVariable('dx', 'f8', ('nyp', 'nx')) +areav = f_sg.createVariable('area', 'f8', ('ny', 'nx')) +dxv.units = 'm' +dyv.units = 'm' +areav.units = 'm2' +f_sg.createVariable('angle_dx', 'f8', ('nyp', 'nxp')) +f_sg.createVariable('tile', 'S1', ('string')) +f_sg.variables['y'].units = 'degrees' +f_sg.variables['x'].units = 'degrees' +f_sg.variables['dy'].units = 'meters' +f_sg.variables['dx'].units = 'meters' +f_sg.variables['area'].units = 'm2' +f_sg.variables['angle_dx'].units = 'degrees' +f_sg.variables['y'][:] = y +f_sg.variables['x'][:] = x +f_sg.variables['dx'][:] = dx +f_sg.variables['dy'][:] = dy + +# Compute the area bounded by lines of constant +# latitude-longitud on a sphere in m2. +dlon = x_[1:] - x_[:-1] +dlon = np.tile(dlon[np.newaxis, :], (2*ny, 1)) +y1_ = y_[:-1] +y1_ = y1_[:, np.newaxis]*rad_deg +y2_ = y_[1:] +y2_ = y2_[:, np.newaxis]*rad_deg +y1_ = np.tile(y1_, (1, 2*nx)) +y2_ = np.tile(y2_, (1, 2*nx)) +area = rad_deg * Re * Re * (np.sin(y2_) - np.sin(y1_)) * dlon +f_sg.variables['area'][:] = area +f_sg.variables['angle_dx'][:] = 0. +str_ = stringtochar(np.array(['tile1'], dtype='S5')) +f_sg.variables['tile'][:] = str_ +f_sg.sync() +f_sg.close() diff --git a/.testing/_tc4/diag_table b/.testing/tc4/diag_table similarity index 100% rename from .testing/_tc4/diag_table rename to .testing/tc4/diag_table diff --git a/.testing/tc4/input.nml b/.testing/tc4/input.nml new file mode 100644 index 0000000000..0b30a7a5a6 --- /dev/null +++ b/.testing/tc4/input.nml @@ -0,0 +1,18 @@ +&mom_input_nml + output_directory = './' + input_filename = 'n' + restart_input_dir = 'INPUT/' + restart_output_dir = 'RESTART/' + parameter_filename = + 'MOM_input', + 'MOM_override', +/ + +&diag_manager_nml + flush_nc_files = .true. +/ + +&fms_nml + domains_stack_size = 710000 + stack_size = 0 +/ diff --git a/src/ALE/MOM_ALE.F90 b/src/ALE/MOM_ALE.F90 index 7a090bb400..d7917f8cad 100644 --- a/src/ALE/MOM_ALE.F90 +++ b/src/ALE/MOM_ALE.F90 @@ -68,7 +68,7 @@ module MOM_ALE !! remaps between grids described by h. real :: regrid_time_scale !< The time-scale used in blending between the current (old) grid - !! and the target (new) grid. (s) + !! and the target (new) grid [T ~> s] type(regridding_CS) :: regridCS !< Regridding parameters and work arrays type(remapping_CS) :: remapCS !< Remapping parameters and work arrays @@ -209,7 +209,7 @@ subroutine ALE_init( param_file, GV, US, max_depth, CS) "and the target (new) grid. A short time-scale favors the target "//& "grid (0. or anything less than DT_THERM) has no memory of the old "//& "grid. A very long time-scale makes the model more Lagrangian.", & - units="s", default=0.) + units="s", default=0., scale=US%s_to_T) call get_param(param_file, mdl, "REGRID_FILTER_SHALLOW_DEPTH", filter_shallow_depth, & "The depth above which no time-filtering is applied. Above this depth "//& "final grid exactly matches the target (new) grid.", & @@ -269,7 +269,7 @@ subroutine ALE_register_diags(Time, G, GV, US, diag, CS) conversion=GV%H_to_m, v_extensive=.true.) cs%id_vert_remap_h_tendency = register_diag_field('ocean_model','vert_remap_h_tendency',diag%axestl,time, & 'Layer thicknesses tendency due to ALE regridding and remapping', 'm', & - conversion=GV%H_to_m, v_extensive = .true.) + conversion=GV%H_to_m*US%s_to_T, v_extensive = .true.) end subroutine ALE_register_diags @@ -319,7 +319,7 @@ subroutine ALE_main( G, GV, US, h, u, v, tv, Reg, CS, OBC, dt, frac_shelf_h) type(tracer_registry_type), pointer :: Reg !< Tracer registry structure type(ALE_CS), pointer :: CS !< Regridding parameters and options type(ocean_OBC_type), pointer :: OBC !< Open boundary structure - real, optional, intent(in) :: dt !< Time step between calls to ALE_main() + real, optional, intent(in) :: dt !< Time step between calls to ALE_main [T ~> s] real, dimension(:,:), optional, pointer :: frac_shelf_h !< Fractional ice shelf coverage ! Local variables real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1) :: dzRegrid ! The change in grid interface positions @@ -403,7 +403,7 @@ subroutine ALE_main_offline( G, GV, h, tv, Reg, CS, OBC, dt) type(tracer_registry_type), pointer :: Reg !< Tracer registry structure type(ALE_CS), pointer :: CS !< Regridding parameters and options type(ocean_OBC_type), pointer :: OBC !< Open boundary structure - real, optional, intent(in) :: dt !< Time step between calls to ALE_main() + real, optional, intent(in) :: dt !< Time step between calls to ALE_main [T ~> s] ! Local variables real, dimension(SZI_(G), SZJ_(G), SZK_(GV)+1) :: dzRegrid ! The change in grid interface positions real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: h_new ! New 3D grid obtained after last time step [H ~> m or kg-2] @@ -660,7 +660,7 @@ subroutine ALE_regrid_accelerated(CS, G, GV, h, tv, n, u, v, OBC, Reg, dt, dzReg type(ocean_OBC_type), pointer :: OBC !< Open boundary structure type(tracer_registry_type), & optional, pointer :: Reg !< Tracer registry to remap onto new grid - real, optional, intent(in) :: dt !< Model timestep to provide a timescale for regridding [s] + real, optional, intent(in) :: dt !< Model timestep to provide a timescale for regridding [T ~> s] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), & optional, intent(inout) :: dzRegrid !< Final change in interface positions logical, optional, intent(in) :: initial !< Whether we're being called from an initialization @@ -698,7 +698,7 @@ subroutine ALE_regrid_accelerated(CS, G, GV, h, tv, n, u, v, OBC, Reg, dt, dzReg ! Apply timescale to regridding (for e.g. filtered_grid_motion) if (present(dt)) & - call ALE_update_regrid_weights(dt, CS) + call ALE_update_regrid_weights(dt, CS) do k = 1, n call do_group_pass(pass_T_S_h, G%domain) @@ -718,7 +718,7 @@ subroutine ALE_regrid_accelerated(CS, G, GV, h, tv, n, u, v, OBC, Reg, dt, dzReg enddo ! remap all state variables (including those that weren't needed for regridding) - call remap_all_state_vars(CS%remapCS, CS, G, GV, h_orig, h, Reg, OBC, dzIntTotal, u, v, dt=dt) + call remap_all_state_vars(CS%remapCS, CS, G, GV, h_orig, h, Reg, OBC, dzIntTotal, u, v) ! save total dzregrid for diags if needed? if (present(dzRegrid)) dzRegrid(:,:,:) = dzIntTotal(:,:,:) @@ -750,7 +750,7 @@ subroutine remap_all_state_vars(CS_remapping, CS_ALE, G, GV, h_old, h_new, Reg, real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & optional, intent(inout) :: v !< Meridional velocity [L T-1 ~> m s-1] logical, optional, intent(in) :: debug !< If true, show the call tree - real, optional, intent(in) :: dt !< time step for diagnostics + real, optional, intent(in) :: dt !< time step for diagnostics [T ~> s] ! Local variables integer :: i, j, k, m integer :: nz, ntr @@ -759,7 +759,8 @@ subroutine remap_all_state_vars(CS_remapping, CS_ALE, G, GV, h_old, h_new, Reg, real, dimension(SZI_(G), SZJ_(G), SZK_(GV)) :: work_conc real, dimension(SZI_(G), SZJ_(G), SZK_(GV)) :: work_cont real, dimension(SZI_(G), SZJ_(G)) :: work_2d - real :: Idt, ppt2mks + real :: Idt ! The inverse of the timestep [T-1 ~> s-1] + real :: ppt2mks real, dimension(GV%ke) :: h2 real :: h_neglect, h_neglect_edge logical :: show_call_tree @@ -1197,7 +1198,7 @@ end function ALE_remap_init_conds !> Updates the weights for time filtering the new grid generated in regridding subroutine ALE_update_regrid_weights( dt, CS ) - real, intent(in) :: dt !< Time-step used between ALE calls + real, intent(in) :: dt !< Time-step used between ALE calls [T ~> s] type(ALE_CS), pointer :: CS !< ALE control structure ! Local variables real :: w ! An implicit weighting estimate. diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index a29a555f55..ad9e235b27 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -370,6 +370,7 @@ module MOM integer :: id_clock_thermo integer :: id_clock_tracer integer :: id_clock_diabatic +integer :: id_clock_adiabatic integer :: id_clock_continuity ! also in dynamics s/r integer :: id_clock_thick_diff integer :: id_clock_BBL_visc @@ -784,7 +785,7 @@ subroutine step_MOM(forces, fluxes, sfc_state, Time_start, time_int_in, CS, & call calculate_diagnostic_fields(u, v, h, CS%uh, CS%vh, CS%tv, CS%ADp, & CS%CDp, p_surf, CS%t_dyn_rel_diag, CS%diag_pre_sync,& G, GV, US, CS%diagnostics_CSp) - call post_tracer_diagnostics(CS%Tracer_reg, h, CS%diag_pre_sync, CS%diag, G, GV, US%T_to_s*CS%t_dyn_rel_diag) + call post_tracer_diagnostics(CS%Tracer_reg, h, CS%diag_pre_sync, CS%diag, G, GV, CS%t_dyn_rel_diag) call diag_copy_diag_to_storage(CS%diag_pre_sync, h, CS%diag) if (showCallTree) call callTree_waypoint("finished calculate_diagnostic_fields (step_MOM)") call disable_averaging(CS%diag) @@ -1091,7 +1092,7 @@ subroutine step_MOM_tracer_dyn(CS, G, GV, US, h, Time_local) CS%tracer_diff_CSp, CS%tracer_Reg, CS%tv) if (showCallTree) call callTree_waypoint("finished tracer advection/diffusion (step_MOM)") call update_segment_tracer_reservoirs(G, GV, CS%uhtr, CS%vhtr, h, CS%OBC, & - US%T_to_s*CS%t_dyn_rel_adv, CS%tracer_Reg) + CS%t_dyn_rel_adv, CS%tracer_Reg) call cpu_clock_end(id_clock_tracer) ; call cpu_clock_end(id_clock_thermo) call cpu_clock_begin(id_clock_other) ; call cpu_clock_begin(id_clock_diagnostics) @@ -1221,9 +1222,9 @@ subroutine step_MOM_thermo(CS, G, GV, US, u, v, h, tv, fluxes, dtdia, & call cpu_clock_begin(id_clock_ALE) if (use_ice_shelf) then call ALE_main(G, GV, US, h, u, v, tv, CS%tracer_Reg, CS%ALE_CSp, CS%OBC, & - US%T_to_s*dtdia, fluxes%frac_shelf_h) + dtdia, fluxes%frac_shelf_h) else - call ALE_main(G, GV, US, h, u, v, tv, CS%tracer_Reg, CS%ALE_CSp, CS%OBC, US%T_to_s*dtdia) + call ALE_main(G, GV, US, h, u, v, tv, CS%tracer_Reg, CS%ALE_CSp, CS%OBC, dtdia) endif if (showCallTree) call callTree_waypoint("finished ALE_main (step_MOM_thermo)") @@ -1252,7 +1253,7 @@ subroutine step_MOM_thermo(CS, G, GV, US, u, v, h, tv, fluxes, dtdia, & call diag_update_remap_grids(CS%diag) !### Consider moving this up into the if ALE block. - call postALE_tracer_diagnostics(CS%tracer_Reg, G, GV, CS%diag, US%T_to_s*dtdia) + call postALE_tracer_diagnostics(CS%tracer_Reg, G, GV, CS%diag, dtdia) if (CS%debug) then call uvchksum("Post-diabatic u", u, v, G%HI, haloshift=2, scale=US%L_T_to_m_s) @@ -1275,10 +1276,10 @@ subroutine step_MOM_thermo(CS, G, GV, US, u, v, h, tv, fluxes, dtdia, & call cpu_clock_end(id_clock_diabatic) else ! complement of "if (.not.CS%adiabatic)" - call cpu_clock_begin(id_clock_diabatic) - call adiabatic(h, tv, fluxes, US%T_to_s*dtdia, G, GV, CS%diabatic_CSp) + call cpu_clock_begin(id_clock_adiabatic) + call adiabatic(h, tv, fluxes, dtdia, G, GV, US, CS%diabatic_CSp) fluxes%fluxes_used = .true. - call cpu_clock_end(id_clock_diabatic) + call cpu_clock_end(id_clock_adiabatic) if (associated(tv%T)) then call create_group_pass(pass_T_S, tv%T, G%Domain, To_All+Omit_Corners, halo=1) @@ -1325,8 +1326,8 @@ subroutine step_offline(forces, fluxes, sfc_state, Time_start, time_interval, CS logical :: do_vertical !< If enough time has elapsed, do the diabatic tracer sources/sinks logical :: adv_converged !< True if all the horizontal fluxes have been used - real :: dt_off ! The offline timestep [T ~> s] - integer :: dt_offline, dt_offline_vertical + real :: dt_offline ! The offline timestep for advection [T ~> s] + real :: dt_offline_vertical ! The offline timestep for vertical fluxes and remapping [T ~> s] logical :: skip_diffusion integer :: id_eta_diff_end @@ -1354,7 +1355,6 @@ subroutine step_offline(forces, fluxes, sfc_state, Time_start, time_interval, CS call extract_offline_main(CS%offline_CSp, uhtr, vhtr, eatr, ebtr, h_end, accumulated_time, & dt_offline, dt_offline_vertical, skip_diffusion) Time_end = increment_date(Time_start, seconds=floor(time_interval+0.001)) - dt_off = US%s_to_T*REAL(dt_offline) call enable_averaging(time_interval, Time_end, CS%diag) @@ -1366,14 +1366,14 @@ subroutine step_offline(forces, fluxes, sfc_state, Time_start, time_interval, CS endif ! Check to see if vertical tracer functions should be done - if ( mod(accumulated_time, dt_offline_vertical) == 0 ) then + if ( mod(accumulated_time, floor(US%T_to_s*dt_offline_vertical + 1e-6)) == 0 ) then do_vertical = .true. else do_vertical = .false. endif ! Increment the amount of time elapsed since last read and check if it's time to roll around - accumulated_time = mod(accumulated_time + int(time_interval), dt_offline) + accumulated_time = mod(accumulated_time + int(time_interval), floor(US%T_to_s*dt_offline+1e-6)) if (accumulated_time==0) then last_iter = .true. else @@ -1406,9 +1406,9 @@ subroutine step_offline(forces, fluxes, sfc_state, Time_start, time_interval, CS if (associated(CS%VarMix)) then call pass_var(CS%h, G%Domain) call calc_resoln_function(CS%h, CS%tv, G, GV, US, CS%VarMix) - call calc_slope_functions(CS%h, CS%tv, dt_off, G, GV, US, CS%VarMix) + call calc_slope_functions(CS%h, CS%tv, dt_offline, G, GV, US, CS%VarMix) endif - call tracer_hordiff(CS%h, dt_off, CS%MEKE, CS%VarMix, G, GV, US, & + call tracer_hordiff(CS%h, dt_offline, CS%MEKE, CS%VarMix, G, GV, US, & CS%tracer_diff_CSp, CS%tracer_Reg, CS%tv) endif endif @@ -1431,9 +1431,9 @@ subroutine step_offline(forces, fluxes, sfc_state, Time_start, time_interval, CS if (associated(CS%VarMix)) then call pass_var(CS%h, G%Domain) call calc_resoln_function(CS%h, CS%tv, G, GV, US, CS%VarMix) - call calc_slope_functions(CS%h, CS%tv, dt_off, G, GV, US, CS%VarMix) + call calc_slope_functions(CS%h, CS%tv, dt_offline, G, GV, US, CS%VarMix) endif - call tracer_hordiff(CS%h, dt_off, CS%MEKE, CS%VarMix, G, GV, US, & + call tracer_hordiff(CS%h, dt_offline, CS%MEKE, CS%VarMix, G, GV, US, & CS%tracer_diff_CSp, CS%tracer_Reg, CS%tv) endif endif @@ -1459,7 +1459,7 @@ subroutine step_offline(forces, fluxes, sfc_state, Time_start, time_interval, CS ! Note that for the layer mode case, the calls to tracer sources and sinks is embedded in ! main_offline_advection_layer. Warning: this may not be appropriate for tracers that ! exchange with the atmosphere - if (time_interval /= dt_offline) then + if (abs(time_interval - US%T_to_s*dt_offline) > 1.0e-6) then call MOM_error(FATAL, & "For offline tracer mode in a non-ALE configuration, dt_offline must equal time_interval") endif @@ -1468,7 +1468,7 @@ subroutine step_offline(forces, fluxes, sfc_state, Time_start, time_interval, CS CS%h, eatr, ebtr, uhtr, vhtr) ! Perform offline diffusion if requested if (.not. skip_diffusion) then - call tracer_hordiff(h_end, dt_off, CS%MEKE, CS%VarMix, G, GV, US, & + call tracer_hordiff(h_end, dt_offline, CS%MEKE, CS%VarMix, G, GV, US, & CS%tracer_diff_CSp, CS%tracer_Reg, CS%tv) endif @@ -2232,7 +2232,7 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & ! pass to the pointer shelf_area => frac_shelf_h call ALE_main(G, GV, US, CS%h, CS%u, CS%v, CS%tv, CS%tracer_Reg, CS%ALE_CSp, & - CS%OBC, frac_shelf_h = shelf_area) + CS%OBC, frac_shelf_h=shelf_area) else call ALE_main( G, GV, US, CS%h, CS%u, CS%v, CS%tv, CS%tracer_Reg, CS%ALE_CSp, CS%OBC) endif @@ -2566,8 +2566,11 @@ subroutine MOM_timing_init(CS) id_clock_thermo = cpu_clock_id('Ocean thermodynamics and tracers', grain=CLOCK_SUBCOMPONENT) id_clock_other = cpu_clock_id('Ocean Other', grain=CLOCK_SUBCOMPONENT) id_clock_tracer = cpu_clock_id('(Ocean tracer advection)', grain=CLOCK_MODULE_DRIVER) - if (.not.CS%adiabatic) & + if (.not.CS%adiabatic) then id_clock_diabatic = cpu_clock_id('(Ocean diabatic driver)', grain=CLOCK_MODULE_DRIVER) + else + id_clock_adiabatic = cpu_clock_id('(Ocean adiabatic driver)', grain=CLOCK_MODULE_DRIVER) + endif id_clock_continuity = cpu_clock_id('(Ocean continuity equation *)', grain=CLOCK_MODULE) id_clock_BBL_visc = cpu_clock_id('(Ocean set BBL viscosity)', grain=CLOCK_MODULE) diff --git a/src/core/MOM_dynamics_split_RK2.F90 b/src/core/MOM_dynamics_split_RK2.F90 index 957a3338ca..c479550847 100644 --- a/src/core/MOM_dynamics_split_RK2.F90 +++ b/src/core/MOM_dynamics_split_RK2.F90 @@ -363,7 +363,7 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, & endif if (associated(CS%OBC)) then - if (CS%debug_OBC) call open_boundary_test_extern_h(G, CS%OBC, h) + if (CS%debug_OBC) call open_boundary_test_extern_h(G, GV, CS%OBC, h) do k=1,nz ; do j=G%jsd,G%jed ; do I=G%IsdB,G%IedB u_old_rad_OBC(I,j,k) = u_av(I,j,k) @@ -611,7 +611,7 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, & if (CS%debug) & call uvchksum("Pre OBC avg [uv]", u_av, v_av, G%HI, haloshift=1, symmetric=sym, scale=US%L_T_to_m_s) - call radiation_open_bdry_conds(CS%OBC, u_av, u_old_rad_OBC, v_av, v_old_rad_OBC, G, US, US%T_to_s*dt_pred) + call radiation_open_bdry_conds(CS%OBC, u_av, u_old_rad_OBC, v_av, v_old_rad_OBC, G, US, dt_pred) if (CS%debug) & call uvchksum("Post OBC avg [uv]", u_av, v_av, G%HI, haloshift=1, symmetric=sym, scale=US%L_T_to_m_s) @@ -819,7 +819,7 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, & endif if (associated(CS%OBC)) then - call radiation_open_bdry_conds(CS%OBC, u, u_old_rad_OBC, v, v_old_rad_OBC, G, US, US%T_to_s*dt) + call radiation_open_bdry_conds(CS%OBC, u, u_old_rad_OBC, v, v_old_rad_OBC, G, US, dt) endif ! h_av = (h_in + h_out)/2 . Going in to this line, h_av = h_in. @@ -1170,7 +1170,7 @@ subroutine initialize_dyn_split_RK2(u, v, h, uh, vh, eta, Time, G, GV, US, param elseif ( (US%s_to_T_restart * US%m_to_L_restart /= 0.0) .and. & ((US%m_to_L * US%s_to_T_restart) /= (US%m_to_L_restart * US%s_to_T)) ) then vel_rescale = (US%m_to_L * US%s_to_T_restart) / (US%m_to_L_restart * US%s_to_T) - do k=1,nz ; do j=jsd,jed ; do I=IsdB,IeDB ; CS%u_av(I,j,k) = vel_rescale * CS%u_av(I,j,k) ; enddo ; enddo ; enddo + do k=1,nz ; do j=jsd,jed ; do I=IsdB,IedB ; CS%u_av(I,j,k) = vel_rescale * CS%u_av(I,j,k) ; enddo ; enddo ; enddo do k=1,nz ; do J=JsdB,JedB ; do i=isd,ied ; CS%v_av(i,J,k) = vel_rescale * CS%v_av(i,J,k) ; enddo ; enddo ; enddo endif diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index 4a2b734e99..f35748dd4a 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -15,7 +15,7 @@ module MOM_open_boundary use MOM_io, only : EAST_FACE, NORTH_FACE use MOM_io, only : slasher, read_data, field_size, SINGLE_FILE use MOM_io, only : vardesc, query_vardesc, var_desc -use MOM_restart, only : register_restart_field, MOM_restart_CS +use MOM_restart, only : register_restart_field, query_initialized, MOM_restart_CS use MOM_obsolete_params, only : obsolete_logical, obsolete_int, obsolete_real, obsolete_char use MOM_string_functions, only : extract_word, remove_spaces use MOM_tracer_registry, only : tracer_type, tracer_registry_type, tracer_name_lookup @@ -57,7 +57,7 @@ module MOM_open_boundary integer, parameter, public :: OBC_NONE = 0 !< Indicates the use of no open boundary integer, parameter, public :: OBC_SIMPLE = 1 !< Indicates the use of a simple inflow open boundary -integer, parameter, public :: OBC_WALL = 2 !< Indicates the use of a closed sall +integer, parameter, public :: OBC_WALL = 2 !< Indicates the use of a closed wall integer, parameter, public :: OBC_FLATHER = 3 !< Indicates the use of a Flather open boundary integer, parameter, public :: OBC_RADIATION = 4 !< Indicates the use of a radiation open boundary integer, parameter, public :: OBC_DIRECTION_N = 100 !< Indicates the boundary is an effective northern boundary @@ -76,7 +76,7 @@ module MOM_open_boundary integer :: nk_src !< Number of vertical levels in the source data real, dimension(:,:,:), pointer :: dz_src=>NULL() !< vertical grid cell spacing of the incoming segment data [m] real, dimension(:,:,:), pointer :: buffer_dst=>NULL() !< buffer src data remapped to the target vertical grid - real, dimension(:,:), pointer :: bt_vel=>NULL() !< barotropic velocity [m s-1] + real, dimension(:,:), pointer :: bt_vel=>NULL() !< barotropic velocity [L T-1 ~> m s-1] real :: value !< constant value if fid is equal to -1 end type OBC_segment_data_type @@ -138,12 +138,12 @@ module MOM_open_boundary integer :: Ie_obc !< i-indices of boundary segment. integer :: Js_obc !< j-indices of boundary segment. integer :: Je_obc !< j-indices of boundary segment. - real :: Velocity_nudging_timescale_in !< Nudging timescale on inflow [s]. - real :: Velocity_nudging_timescale_out !< Nudging timescale on outflow [s]. + real :: Velocity_nudging_timescale_in !< Nudging timescale on inflow [T ~> s]. + real :: Velocity_nudging_timescale_out !< Nudging timescale on outflow [T ~> s]. logical :: on_pe !< true if segment is located in the computational domain logical :: temp_segment_data_exists !< true if temperature data arrays are present logical :: salt_segment_data_exists !< true if salinity data arrays are present - real, pointer, dimension(:,:) :: Cg=>NULL() !< The external gravity wave speed [m s-1] + real, pointer, dimension(:,:) :: Cg=>NULL() !< The external gravity wave speed [L T-1 ~> m s-1] !! at OBC-points. real, pointer, dimension(:,:) :: Htot=>NULL() !< The total column thickness [H ~> m or kg m-2] at OBC-points. real, pointer, dimension(:,:,:) :: h=>NULL() !< The cell thickness [H ~> m or kg m-2] at OBC-points. @@ -159,17 +159,21 @@ module MOM_open_boundary !! the OB segment [L T-1 ~> m s-1]. real, pointer, dimension(:,:) :: eta=>NULL() !< The sea-surface elevation along the segment [m]. real, pointer, dimension(:,:,:) :: grad_normal=>NULL() !< The gradient of the normal flow along the - !! segment [T-1 ~> s-1] + !! segment times the grid spacing [L T-1 ~> m s-1] real, pointer, dimension(:,:,:) :: grad_tan=>NULL() !< The gradient of the tangential flow along the - !! segment [T-1 ~> s-1] - real, pointer, dimension(:,:,:) :: grad_gradient=>NULL() !< The gradient of the gradient of tangential flow along the - !! segment times a grid spacing [T-1 ~> s-1] - real, pointer, dimension(:,:,:) :: rx_normal=>NULL() !< The rx_old_u value for radiation coeff - !! for normal velocity - real, pointer, dimension(:,:,:) :: ry_normal=>NULL() !< The tangential value for radiation coeff - !! for normal velocity + !! segment times the grid spacing [L T-1 ~> m s-1] + real, pointer, dimension(:,:,:) :: grad_gradient=>NULL() !< The gradient of the gradient of tangential flow along + !! the segment times the grid spacing [T-1 ~> s-1] + real, pointer, dimension(:,:,:) :: rx_norm_rad=>NULL() !< The previous normal phase speed use for EW radiation + !! OBC, in grid points per timestep [nondim] + real, pointer, dimension(:,:,:) :: ry_norm_rad=>NULL() !< The previous normal phase speed use for NS radiation + !! OBC, in grid points per timestep [nondim] + real, pointer, dimension(:,:,:) :: rx_norm_obl=>NULL() !< The previous normal radiation coefficient for EW + !! oblique OBCs [L2 T-2 ~> m2 s-2] + real, pointer, dimension(:,:,:) :: ry_norm_obl=>NULL() !< The previous normal radiation coefficient for NS + !! oblique OBCs [L2 T-2 ~> m2 s-2] real, pointer, dimension(:,:,:) :: cff_normal=>NULL() !< The denominator for oblique radiation - !! for normal velocity + !! for normal velocity [L2 T-2 ~> m2 s-2] real, pointer, dimension(:,:,:) :: nudged_normal_vel=>NULL() !< The layer velocity normal to the OB segment !! that values should be nudged towards [L T-1 ~> m s-1]. real, pointer, dimension(:,:,:) :: nudged_tangential_vel=>NULL() !< The layer velocity tangential to the OB segment @@ -178,11 +182,13 @@ module MOM_open_boundary !! can occur [T-1 ~> s-1]. type(segment_tracer_registry_type), pointer :: tr_Reg=> NULL()!< A pointer to the tracer registry for the segment. type(hor_index_type) :: HI !< Horizontal index ranges - real :: Tr_InvLscale_out !< An effective inverse length scale [m-1] - real :: Tr_InvLscale_in !< for restoring the tracer concentration in a - !! ficticious reservior towards interior values - !! when flow is exiting the domain, or towards - !! an externally imposed value when flow is entering + real :: Tr_InvLscale_out !< An effective inverse length scale for restoring + !! the tracer concentration in a ficticious + !! reservior towards interior values when flow + !! is exiting the domain [L-1 ~> m-1] + real :: Tr_InvLscale_in !< An effective inverse length scale for restoring + !! the tracer concentration towards an externally + !! imposed value when flow is entering [L-1 ~> m-1] end type OBC_segment_type !> Open-boundary data @@ -256,17 +262,21 @@ module MOM_open_boundary logical :: OBC_pe !< Is there an open boundary on this tile? type(remapping_CS), pointer :: remap_CS !< ALE remapping control structure for segments only type(OBC_registry_type), pointer :: OBC_Reg => NULL() !< Registry type for boundaries - real, pointer, dimension(:,:,:) :: rx_normal => NULL() !< Array storage for restarts - real, pointer, dimension(:,:,:) :: ry_normal => NULL() !< Array storage for restarts - real, pointer, dimension(:,:,:) :: cff_normal => NULL() !< Array storage for restarts - real, pointer, dimension(:,:,:,:) :: tres_x => NULL() !< Array storage for restarts - real, pointer, dimension(:,:,:,:) :: tres_y => NULL() !< Array storage for restarts - real :: silly_h !< A silly value of thickness outside of the domain that - !! can be used to test the independence of the OBCs to - !! this external data [H ~> m or kg m-2]. - real :: silly_u !< A silly value of velocity outside of the domain that - !! can be used to test the independence of the OBCs to - !! this external data [m s-1]. + real, pointer, dimension(:,:,:) :: & + rx_normal => NULL(), & !< Array storage for normal phase speed for EW radiation OBCs in units of + !! grid points per timestep [nondim] + ry_normal => NULL(), & !< Array storage for normal phase speed for NS radiation OBCs in units of + !! grid points per timestep [nondim] + rx_oblique => NULL(), & !< Array storage for oblique boundary condition restarts [L2 T-2 ~> m2 s-2] + ry_oblique => NULL(), & !< Array storage for oblique boundary condition restarts [L2 T-2 ~> m2 s-2] + cff_normal => NULL() !< Array storage for oblique boundary condition restarts [L2 T-2 ~> m2 s-2] + real, pointer, dimension(:,:,:,:) :: & + tres_x => NULL(), & !< Array storage of tracer reservoirs for restarts [conc L ~> conc m] + tres_y => NULL() !< Array storage of tracer reservoirs for restarts [conc L ~> conc m] + real :: silly_h !< A silly value of thickness outside of the domain that can be used to test + !! the independence of the OBCs to this external data [H ~> m or kg m-2]. + real :: silly_u !< A silly value of velocity outside of the domain that can be used to test + !! the independence of the OBCs to this external data [L T-1 ~> m s-1]. end type ocean_OBC_type !> Control structure for open boundaries that read from files. @@ -304,8 +314,8 @@ module MOM_open_boundary !> later call to update_open_boundary_data subroutine open_boundary_config(G, US, param_file, OBC) - type(dyn_horgrid_type), intent(inout) :: G !< Ocean grid structure - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(dyn_horgrid_type), intent(inout) :: G !< Ocean grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(param_file_type), intent(in) :: param_file !< Parameter file handle type(ocean_OBC_type), pointer :: OBC !< Open boundary control structure ! Local variables @@ -314,7 +324,7 @@ subroutine open_boundary_config(G, US, param_file, OBC) character(len=15) :: segment_param_str ! The run-time parameter name for each segment character(len=100) :: segment_str ! The contents (rhs) for parameter "segment_param_str" character(len=200) :: config1 ! String for OBC_USER_CONFIG - real :: Lscale_in, Lscale_out ! parameters controlling tracer values at the boundaries + real :: Lscale_in, Lscale_out ! parameters controlling tracer values at the boundaries [L ~> m] allocate(OBC) call log_version(param_file, mdl, version, & @@ -399,11 +409,11 @@ subroutine open_boundary_config(G, US, param_file, OBC) call get_param(param_file, mdl, "OBC_SILLY_THICK", OBC%silly_h, & "A silly value of thicknesses used outside of open boundary "//& - "conditions for debugging.", units="m", default=0.0, & + "conditions for debugging.", units="m", default=0.0, scale=US%m_to_Z, & do_not_log=.not.debug_OBC, debuggingParam=.true.) call get_param(param_file, mdl, "OBC_SILLY_VEL", OBC%silly_u, & "A silly value of velocities used outside of open boundary "//& - "conditions for debugging.", units="m/s", default=0.0, & + "conditions for debugging.", units="m/s", default=0.0, scale=US%m_s_to_L_T, & do_not_log=.not.debug_OBC, debuggingParam=.true.) reentrant_x = .false. call get_param(param_file, mdl, "REENTRANT_X", reentrant_x, default=.true.) @@ -453,9 +463,9 @@ subroutine open_boundary_config(G, US, param_file, OBC) fail_if_missing=.true.) segment_str = remove_spaces(segment_str) if (segment_str(1:2) == 'I=') then - call setup_u_point_obc(OBC, G, segment_str, l, param_file, reentrant_y) + call setup_u_point_obc(OBC, G, US, segment_str, l, param_file, reentrant_y) elseif (segment_str(1:2) == 'J=') then - call setup_v_point_obc(OBC, G, segment_str, l, param_file, reentrant_x) + call setup_v_point_obc(OBC, G, US, segment_str, l, param_file, reentrant_x) else call MOM_error(FATAL, "MOM_open_boundary.F90, open_boundary_config: "//& "Unable to interpret "//segment_param_str//" = "//trim(segment_str)) @@ -477,7 +487,7 @@ subroutine open_boundary_config(G, US, param_file, OBC) "time level (1) or the running mean (0) for velocities. "//& "Valid values range from 0 to 1. This is only used if "//& "one of the open boundary segments is using Orlanski.", & - units="nondim", default=0.3) + units="nondim", default=0.3) endif Lscale_in = 0. @@ -486,12 +496,12 @@ subroutine open_boundary_config(G, US, param_file, OBC) call get_param(param_file, mdl, "OBC_TRACER_RESERVOIR_LENGTH_SCALE_OUT ", Lscale_out, & "An effective length scale for restoring the tracer concentration "//& "at the boundaries to externally imposed values when the flow "//& - "is exiting the domain.", units="m", default=0.0) + "is exiting the domain.", units="m", default=0.0, scale=US%m_to_L) call get_param(param_file, mdl, "OBC_TRACER_RESERVOIR_LENGTH_SCALE_IN ", Lscale_in, & "An effective length scale for restoring the tracer concentration "//& "at the boundaries to values from the interior when the flow "//& - "is entering the domain.", units="m", default=0.0) + "is entering the domain.", units="m", default=0.0, scale=US%m_to_L) endif if (mask_outside) call mask_outside_OBCs(G, US, param_file, OBC) @@ -500,9 +510,9 @@ subroutine open_boundary_config(G, US, param_file, OBC) ! tracer-specific in the future for example, in cases where certain tracers are poorly constrained ! by data while others are well constrained - MJH. do l = 1, OBC%number_of_segments - OBC%segment(l)%Tr_InvLscale_in=0.0 + OBC%segment(l)%Tr_InvLscale_in = 0.0 if (Lscale_in>0.) OBC%segment(l)%Tr_InvLscale_in = 1.0/Lscale_in - OBC%segment(l)%Tr_InvLscale_out=0.0 + OBC%segment(l)%Tr_InvLscale_out = 0.0 if (Lscale_out>0.) OBC%segment(l)%Tr_InvLscale_out = 1.0/Lscale_out enddo @@ -844,9 +854,10 @@ subroutine setup_segment_indices(G, seg, Is_obc, Ie_obc, Js_obc, Je_obc) end subroutine setup_segment_indices !> Parse an OBC_SEGMENT_%%% string starting with "I=" and configure placement and type of OBC accordingly -subroutine setup_u_point_obc(OBC, G, segment_str, l_seg, PF, reentrant_y) +subroutine setup_u_point_obc(OBC, G, US, segment_str, l_seg, PF, reentrant_y) type(ocean_OBC_type), pointer :: OBC !< Open boundary control structure - type(dyn_horgrid_type), intent(in) :: G !< Ocean grid structure + type(dyn_horgrid_type), intent(in) :: G !< Ocean grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type character(len=*), intent(in) :: segment_str !< A string in form of "I=%,J=%:%,string" integer, intent(in) :: l_seg !< which segment is this? type(param_file_type), intent(in) :: PF !< Parameter file handle @@ -938,12 +949,12 @@ subroutine setup_u_point_obc(OBC, G, segment_str, l_seg, PF, reentrant_y) write(segment_param_str(1:43),"('OBC_SEGMENT_',i3.3,'_VELOCITY_NUDGING_TIMESCALES')") l_seg allocate(tnudge(2)) call get_param(PF, mdl, segment_param_str(1:43), tnudge, & - "Timescales in days for nudging along a segment, "//& - "for inflow, then outflow. Setting both to zero should "//& - "behave like SIMPLE obcs for the baroclinic velocities.", & - fail_if_missing=.true.,default=0.,units="days") - OBC%segment(l_seg)%Velocity_nudging_timescale_in = tnudge(1)*86400. - OBC%segment(l_seg)%Velocity_nudging_timescale_out = tnudge(2)*86400. + "Timescales in days for nudging along a segment, "//& + "for inflow, then outflow. Setting both to zero should "//& + "behave like SIMPLE obcs for the baroclinic velocities.", & + fail_if_missing=.true., default=0., units="days", scale=86400.0*US%s_to_T) + OBC%segment(l_seg)%Velocity_nudging_timescale_in = tnudge(1) + OBC%segment(l_seg)%Velocity_nudging_timescale_out = tnudge(2) deallocate(tnudge) endif @@ -979,9 +990,10 @@ subroutine setup_u_point_obc(OBC, G, segment_str, l_seg, PF, reentrant_y) end subroutine setup_u_point_obc !> Parse an OBC_SEGMENT_%%% string starting with "J=" and configure placement and type of OBC accordingly -subroutine setup_v_point_obc(OBC, G, segment_str, l_seg, PF, reentrant_x) +subroutine setup_v_point_obc(OBC, G, US, segment_str, l_seg, PF, reentrant_x) type(ocean_OBC_type), pointer :: OBC !< Open boundary control structure - type(dyn_horgrid_type), intent(in) :: G !< Ocean grid structure + type(dyn_horgrid_type), intent(in) :: G !< Ocean grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type character(len=*), intent(in) :: segment_str !< A string in form of "J=%,I=%:%,string" integer, intent(in) :: l_seg !< which segment is this? type(param_file_type), intent(in) :: PF !< Parameter file handle @@ -1074,12 +1086,12 @@ subroutine setup_v_point_obc(OBC, G, segment_str, l_seg, PF, reentrant_x) write(segment_param_str(1:43),"('OBC_SEGMENT_',i3.3,'_VELOCITY_NUDGING_TIMESCALES')") l_seg allocate(tnudge(2)) call get_param(PF, mdl, segment_param_str(1:43), tnudge, & - "Timescales in days for nudging along a segment, "//& - "for inflow, then outflow. Setting both to zero should "//& - "behave like SIMPLE obcs for the baroclinic velocities.", & - fail_if_missing=.true.,default=0.,units="days") - OBC%segment(l_seg)%Velocity_nudging_timescale_in = tnudge(1)*86400. - OBC%segment(l_seg)%Velocity_nudging_timescale_out = tnudge(2)*86400. + "Timescales in days for nudging along a segment, "//& + "for inflow, then outflow. Setting both to zero should "//& + "behave like SIMPLE obcs for the baroclinic velocities.", & + fail_if_missing=.true., default=0., units="days", scale=86400.0*US%s_to_T) + OBC%segment(l_seg)%Velocity_nudging_timescale_in = tnudge(1) + OBC%segment(l_seg)%Velocity_nudging_timescale_out = tnudge(2) deallocate(tnudge) endif @@ -1461,17 +1473,67 @@ subroutine parse_segment_param_real(segment_str, var, param_value, debug ) end subroutine parse_segment_param_real -!> Initialize open boundary control structure -subroutine open_boundary_init(G, param_file, OBC) - type(ocean_grid_type), intent(in) :: G !< Ocean grid structure - type(param_file_type), intent(in) :: param_file !< Parameter file handle - type(ocean_OBC_type), pointer :: OBC !< Open boundary control structure +!> Initialize open boundary control structure and do any necessary rescaling of OBC +!! fields that have been read from a restart file. +subroutine open_boundary_init(G, GV, US, param_file, OBC, restart_CSp) + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< Container for vertical grid information + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(param_file_type), intent(in) :: param_file !< Parameter file handle + type(ocean_OBC_type), pointer :: OBC !< Open boundary control structure + type(MOM_restart_CS), pointer :: restart_CSp !< Restart structure, data intent(inout) + ! Local variables + real :: vel2_rescale ! A rescaling factor for squared velocities from the representation in + ! a restart file to the internal representation in this run. + integer :: i, j, k, isd, ied, jsd, jed, nz + integer :: IsdB, IedB, JsdB, JedB + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed ; nz = GV%ke + IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB if (.not.associated(OBC)) return id_clock_pass = cpu_clock_id('(Ocean OBC halo updates)', grain=CLOCK_ROUTINE) + ! The rx_normal and ry_normal arrays used with radiation OBCs are currently in units of grid + ! points per timestep, but if this were to be corrected to [L T-1 ~> m s-1] or [T-1 ~> s-1] to + ! permit timesteps to change between calls to the OBC code, the following would be needed: +! if ( OBC%radiation_BCs_exist_globally .and. (US%s_to_T_restart * US%m_to_L_restart /= 0.0) .and. & +! ((US%m_to_L * US%s_to_T_restart) /= (US%m_to_L_restart * US%s_to_T)) ) then +! vel_rescale = (US%m_to_L * US%s_to_T_restart) / (US%m_to_L_restart * US%s_to_T) +! if (query_initialized(OBC%rx_normal, "rx_normal", restart_CSp)) then +! do k=1,nz ; do j=jsd,jed ; do I=IsdB,IedB +! OBC%rx_normal(I,j,k) = vel_rescale * OBC%rx_normal(I,j,k) +! enddo ; enddo ; enddo +! endif +! if (query_initialized(OBC%ry_normal, "ry_normal", restart_CSp)) then +! do k=1,nz ; do J=JsdB,JedB ; do i=isd,ied +! OBC%ry_normal(i,J,k) = vel_rescale * OBC%ry_normal(i,J,k) +! enddo ; enddo ; enddo +! endif +! endif + + ! The oblique boundary condition terms have units of [L2 T-2 ~> m2 s-2] and may need to be rescaled. + if ( OBC%oblique_BCs_exist_globally .and. (US%s_to_T_restart * US%m_to_L_restart /= 0.0) .and. & + ((US%m_to_L * US%s_to_T_restart) /= (US%m_to_L_restart * US%s_to_T)) ) then + vel2_rescale = (US%m_to_L * US%s_to_T_restart)**2 / (US%m_to_L_restart * US%s_to_T)**2 + if (query_initialized(OBC%rx_oblique, "rx_oblique", restart_CSp)) then + do k=1,nz ; do j=jsd,jed ; do I=IsdB,IedB + OBC%rx_oblique(I,j,k) = vel2_rescale * OBC%rx_oblique(I,j,k) + enddo ; enddo ; enddo + endif + if (query_initialized(OBC%ry_oblique, "ry_oblique", restart_CSp)) then + do k=1,nz ; do J=JsdB,JedB ; do i=isd,ied + OBC%ry_oblique(i,J,k) = vel2_rescale * OBC%ry_oblique(i,J,k) + enddo ; enddo ; enddo + endif + if (query_initialized(OBC%cff_normal, "cff_normal", restart_CSp)) then + do k=1,nz ; do J=JsdB,JedB ; do I=IsdB,IedB + OBC%cff_normal(I,J,k) = vel2_rescale * OBC%cff_normal(I,J,k) + enddo ; enddo ; enddo + endif + endif + end subroutine open_boundary_init logical function open_boundary_query(OBC, apply_open_OBC, apply_specified_OBC, apply_Flather_OBC, & @@ -1513,6 +1575,8 @@ subroutine open_boundary_dealloc(OBC) if (associated(OBC%segnum_v)) deallocate(OBC%segnum_v) if (associated(OBC%rx_normal)) deallocate(OBC%rx_normal) if (associated(OBC%ry_normal)) deallocate(OBC%ry_normal) + if (associated(OBC%rx_oblique)) deallocate(OBC%rx_oblique) + if (associated(OBC%ry_oblique)) deallocate(OBC%ry_oblique) if (associated(OBC%cff_normal)) deallocate(OBC%cff_normal) if (associated(OBC%tres_x)) deallocate(OBC%tres_x) if (associated(OBC%tres_y)) deallocate(OBC%tres_y) @@ -1732,19 +1796,24 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) !! barotropic accelerations [L T-1 ~> m s-1]. real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(in) :: v_old !< Original unadjusted v [L T-1 ~> m s-1] type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - real, intent(in) :: dt !< Appropriate timestep [s] + real, intent(in) :: dt !< Appropriate timestep [T ~> s] ! Local variables real :: dhdt, dhdx, dhdy ! One-point differences in time or space [L T-1 ~> m s-1] - real :: gamma_u, gamma_v, gamma_2 - real :: cff, Cx, Cy, tau - real :: rx_max, ry_max ! coefficients for radiation - real :: rx_new, rx_avg ! coefficients for radiation - real :: ry_new, ry_avg ! coefficients for radiation - real :: cff_new, cff_avg ! denominator in oblique - real, pointer, dimension(:,:,:) :: rx_tangential=>NULL() - real, pointer, dimension(:,:,:) :: ry_tangential=>NULL() - real, pointer, dimension(:,:,:) :: cff_tangential=>NULL() - real :: eps ! A small velocity squared [L2 T-2 ~> m2 s-2]? + real :: gamma_u, gamma_2 ! Fractional weightings of new values [nondim] + real :: tau ! A local nudging timescale [T ~> s] + real :: rx_max, ry_max ! coefficients for radiation [nondim] or [L2 T-2 ~> m2 s-2] + real :: rx_new, rx_avg ! coefficients for radiation [nondim] or [L2 T-2 ~> m2 s-2] + real :: ry_new, ry_avg ! coefficients for radiation [nondim] or [L2 T-2 ~> m2 s-2] + real :: cff_new, cff_avg ! denominator in oblique [L2 T-2 ~> m2 s-2] + real, allocatable, dimension(:,:,:) :: & + rx_tang_rad, & ! The phase speed at u-points for tangential oblique OBCs + ! in units of grid points per timestep [nondim] + ry_tang_rad, & ! The phase speed at v-points for tangential oblique OBCs + ! in units of grid points per timestep [nondim] + rx_tang_obl, & ! The x-coefficient for tangential oblique OBCs [L2 T-2 ~> m2 s-2] + ry_tang_obl, & ! The y-coefficient for tangential oblique OBCs [L2 T-2 ~> m2 s-2] + cff_tangential ! The denominator for tangential oblique OBCs [L2 T-2 ~> m2 s-2] + real :: eps ! A small velocity squared [L2 T-2 ~> m2 s-2] type(OBC_segment_type), pointer :: segment => NULL() integer :: i, j, k, is, ie, js, je, m, nz, n integer :: is_obc, ie_obc, js_obc, je_obc @@ -1769,14 +1838,14 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) do k=1,G%ke I=segment%HI%IsdB do j=segment%HI%jsd,segment%HI%jed - segment%rx_normal(I,j,k) = OBC%rx_normal(I,j,k) + segment%rx_norm_rad(I,j,k) = OBC%rx_normal(I,j,k) enddo enddo elseif (segment%is_N_or_S .and. segment%radiation) then do k=1,G%ke J=segment%HI%JsdB do i=segment%HI%isd,segment%HI%ied - segment%ry_normal(i,J,k) = OBC%ry_normal(i,J,k) + segment%ry_norm_rad(i,J,k) = OBC%ry_normal(i,J,k) enddo enddo endif @@ -1784,8 +1853,8 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) do k=1,G%ke I=segment%HI%IsdB do j=segment%HI%jsd,segment%HI%jed - segment%rx_normal(I,j,k) = OBC%rx_normal(I,j,k) - segment%ry_normal(I,j,k) = OBC%ry_normal(I,j,k) + segment%rx_norm_obl(I,j,k) = OBC%rx_oblique(I,j,k) + segment%ry_norm_obl(I,j,k) = OBC%ry_oblique(I,j,k) segment%cff_normal(I,j,k) = OBC%cff_normal(I,j,k) enddo enddo @@ -1793,8 +1862,8 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) do k=1,G%ke J=segment%HI%JsdB do i=segment%HI%isd,segment%HI%ied - segment%rx_normal(i,J,k) = OBC%rx_normal(i,J,k) - segment%ry_normal(i,J,k) = OBC%ry_normal(i,J,k) + segment%rx_norm_obl(i,J,k) = OBC%rx_oblique(i,J,k) + segment%ry_norm_obl(i,J,k) = OBC%ry_oblique(i,J,k) segment%cff_normal(i,J,k) = OBC%cff_normal(i,J,k) enddo enddo @@ -1832,7 +1901,7 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) endif enddo - gamma_u = OBC%gamma_uv ; gamma_v = OBC%gamma_uv + gamma_u = OBC%gamma_uv rx_max = OBC%rx_max ; ry_max = OBC%rx_max do n=1,OBC%number_of_segments segment=>OBC%segment(n) @@ -1848,11 +1917,11 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) rx_new = 0.0 if (dhdt*dhdx > 0.0) rx_new = min( (dhdt/dhdx), rx_max) ! outward phase speed if (gamma_u < 1.0) then - rx_avg = (1.0-gamma_u)*segment%rx_normal(I,j,k) + gamma_u*rx_new + rx_avg = (1.0-gamma_u)*segment%rx_norm_rad(I,j,k) + gamma_u*rx_new else rx_avg = rx_new endif - segment%rx_normal(I,j,k) = rx_avg + segment%rx_norm_rad(I,j,k) = rx_avg ! The new boundary value is interpolated between future interior ! value, u_new(I-1) and past boundary value but with barotropic ! accelerations, u_new(I). @@ -1860,7 +1929,7 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) ! Copy restart fields into 3-d arrays. This is an inefficient and temporary issues ! implemented as a work-around to limitations in restart capability if (gamma_u < 1.0) then - OBC%rx_normal(I,j,k) = segment%rx_normal(I,j,k) + OBC%rx_normal(I,j,k) = segment%rx_norm_rad(I,j,k) endif elseif (segment%oblique) then dhdt = (u_old(I-1,j,k) - u_new(I-1,j,k)) !old-new @@ -1873,20 +1942,20 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) dhdy = segment%grad_normal(J,1,k) endif if (dhdt*dhdx < 0.0) dhdt = 0.0 - rx_new = US%L_T_to_m_s**2*dhdt*dhdx - cff_new = US%L_T_to_m_s**2*max(dhdx*dhdx + dhdy*dhdy, eps) - ry_new = min(cff_new,max(US%L_T_to_m_s**2*dhdt*dhdy,-cff_new)) + rx_new = dhdt*dhdx + cff_new = max(dhdx*dhdx + dhdy*dhdy, eps) + ry_new = min(cff_new,max(dhdt*dhdy,-cff_new)) if (gamma_u < 1.0) then - rx_avg = (1.0-gamma_u)*segment%rx_normal(I,j,k) + gamma_u*rx_new - ry_avg = (1.0-gamma_u)*segment%ry_normal(i,J,k) + gamma_u*ry_new + rx_avg = (1.0-gamma_u)*segment%rx_norm_obl(I,j,k) + gamma_u*rx_new + ry_avg = (1.0-gamma_u)*segment%ry_norm_obl(i,J,k) + gamma_u*ry_new cff_avg = (1.0-gamma_u)*segment%cff_normal(i,J,k) + gamma_u*cff_new else rx_avg = rx_new ry_avg = ry_new cff_avg = cff_new endif - segment%rx_normal(I,j,k) = rx_avg - segment%ry_normal(i,J,k) = ry_avg + segment%rx_norm_obl(I,j,k) = rx_avg + segment%ry_norm_obl(i,J,k) = ry_avg segment%cff_normal(i,J,k) = cff_avg segment%normal_vel(I,j,k) = ((cff_avg*u_new(I,j,k) + rx_avg*u_new(I-1,j,k)) - & (max(ry_avg,0.0)*segment%grad_normal(J-1,2,k) + & @@ -1895,8 +1964,8 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) if (gamma_u < 1.0) then ! Copy restart fields into 3-d arrays. This is an inefficient and temporary ! implementation as a work-around to limitations in restart capability - OBC%rx_normal(I,j,k) = segment%rx_normal(I,j,k) - OBC%ry_normal(i,J,k) = segment%ry_normal(i,J,k) + OBC%rx_oblique(I,j,k) = segment%rx_norm_obl(I,j,k) + OBC%ry_oblique(i,J,k) = segment%ry_norm_obl(i,J,k) OBC%cff_normal(I,j,k) = segment%cff_normal(I,j,k) endif elseif (segment%gradient) then @@ -1910,45 +1979,45 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) tau = segment%Velocity_nudging_timescale_out endif gamma_2 = dt / (tau + dt) - segment%normal_vel(I,j,k) = (1 - gamma_2) * segment%normal_vel(I,j,k) + & + segment%normal_vel(I,j,k) = (1.0 - gamma_2) * segment%normal_vel(I,j,k) + & gamma_2 * segment%nudged_normal_vel(I,j,k) endif enddo ; enddo if (segment%radiation_tan .or. segment%radiation_grad) then I=segment%HI%IsdB - allocate(rx_tangential(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz)) + allocate(rx_tang_rad(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz)) do k=1,nz if (gamma_u < 1.0) then - rx_tangential(I,segment%HI%JsdB,k) = segment%rx_normal(I,segment%HI%jsd,k) - rx_tangential(I,segment%HI%JedB,k) = segment%rx_normal(I,segment%HI%jed,k) + rx_tang_rad(I,segment%HI%JsdB,k) = segment%rx_norm_rad(I,segment%HI%jsd,k) + rx_tang_rad(I,segment%HI%JedB,k) = segment%rx_norm_rad(I,segment%HI%jed,k) do J=segment%HI%JsdB+1,segment%HI%JedB-1 - rx_tangential(I,J,k) = 0.5*(segment%rx_normal(I,j,k) + segment%rx_normal(I,j+1,k)) + rx_tang_rad(I,J,k) = 0.5*(segment%rx_norm_rad(I,j,k) + segment%rx_norm_rad(I,j+1,k)) enddo else do J=segment%HI%JsdB,segment%HI%JedB dhdt = v_old(i,J,k)-v_new(i,J,k) !old-new dhdx = v_new(i,J,k)-v_new(i-1,J,k) !in new time backward sasha for I-1 - rx_tangential(I,J,k) = 0.0 - if (dhdt*dhdx > 0.0) rx_tangential(I,J,k) = min( (dhdt/dhdx), rx_max) ! outward phase speed + rx_tang_rad(I,J,k) = 0.0 + if (dhdt*dhdx > 0.0) rx_tang_rad(I,J,k) = min( (dhdt/dhdx), rx_max) ! outward phase speed enddo endif enddo if (segment%radiation_tan) then do k=1,nz ; do J=segment%HI%JsdB,segment%HI%JedB - rx_avg = rx_tangential(I,J,k) + rx_avg = rx_tang_rad(I,J,k) segment%tangential_vel(I,J,k) = (v_new(i,J,k) + rx_avg*v_new(i-1,J,k)) / (1.0+rx_avg) enddo ; enddo endif if (segment%nudged_tan) then do k=1,nz ; do J=segment%HI%JsdB,segment%HI%JedB ! dhdt gets set to 0 on inflow in oblique case - if (rx_tangential(I,J,k) <= 0.0) then + if (rx_tang_rad(I,J,k) <= 0.0) then tau = segment%Velocity_nudging_timescale_in else tau = segment%Velocity_nudging_timescale_out endif gamma_2 = dt / (tau + dt) - segment%tangential_vel(I,J,k) = (1 - gamma_2) * segment%tangential_vel(I,J,k) + & + segment%tangential_vel(I,J,k) = (1.0 - gamma_2) * segment%tangential_vel(I,J,k) + & gamma_2 * segment%nudged_tangential_vel(I,J,k) enddo ; enddo endif @@ -1956,13 +2025,13 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) Js_obc = max(segment%HI%JsdB,G%jsd+1) Je_obc = min(segment%HI%JedB,G%jed-1) do k=1,nz ; do J=Js_obc,Je_obc - rx_avg = rx_tangential(I,J,k) + rx_avg = rx_tang_rad(I,J,k) ! if (G%mask2dCu(I-1,j) > 0.0 .and. G%mask2dCu(I-1,j+1) > 0.0) then -! rx_avg = 0.5*(u_new(I-1,j,k) + u_new(I-1,j+1,k)) * US%s_to_T*dt * G%IdxBu(I-1,J) +! rx_avg = 0.5*(u_new(I-1,j,k) + u_new(I-1,j+1,k)) * dt * G%IdxBu(I-1,J) ! elseif (G%mask2dCu(I-1,j) > 0.0) then -! rx_avg = u_new(I-1,j,k) * US%s_to_T*dt * G%IdxBu(I-1,J) +! rx_avg = u_new(I-1,j,k) * dt * G%IdxBu(I-1,J) ! elseif (G%mask2dCu(I-1,j+1) > 0.0) then -! rx_avg = u_new(I-1,j+1,k) * US%s_to_T*dt * G%IdxBu(I-1,J) +! rx_avg = u_new(I-1,j+1,k) * dt * G%IdxBu(I-1,J) ! else ! rx_avg = 0.0 ! endif @@ -1973,34 +2042,34 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) if (segment%nudged_grad) then do k=1,nz ; do J=segment%HI%JsdB,segment%HI%JedB ! dhdt gets set to 0 on inflow in oblique case - if (rx_tangential(I,J,k) <= 0.0) then + if (rx_tang_rad(I,J,k) <= 0.0) then tau = segment%Velocity_nudging_timescale_in else tau = segment%Velocity_nudging_timescale_out endif gamma_2 = dt / (tau + dt) - segment%tangential_grad(I,J,k) = (1 - gamma_2) * segment%tangential_grad(I,J,k) + & + segment%tangential_grad(I,J,k) = (1.0 - gamma_2) * segment%tangential_grad(I,J,k) + & gamma_2 * segment%nudged_tangential_grad(I,J,k) enddo ; enddo endif - deallocate(rx_tangential) + deallocate(rx_tang_rad) endif if (segment%oblique_tan .or. segment%oblique_grad) then I=segment%HI%IsdB - allocate(rx_tangential(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz)) - allocate(ry_tangential(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz)) + allocate(rx_tang_obl(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz)) + allocate(ry_tang_obl(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz)) allocate(cff_tangential(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz)) do k=1,nz if (gamma_u < 1.0) then - rx_tangential(I,segment%HI%JsdB,k) = segment%rx_normal(I,segment%HI%jsd,k) - rx_tangential(I,segment%HI%JedB,k) = segment%rx_normal(I,segment%HI%jed,k) - ry_tangential(I,segment%HI%JsdB,k) = segment%ry_normal(I,segment%HI%jsd,k) - ry_tangential(I,segment%HI%JedB,k) = segment%ry_normal(I,segment%HI%jed,k) + rx_tang_obl(I,segment%HI%JsdB,k) = segment%rx_norm_obl(I,segment%HI%jsd,k) + rx_tang_obl(I,segment%HI%JedB,k) = segment%rx_norm_obl(I,segment%HI%jed,k) + ry_tang_obl(I,segment%HI%JsdB,k) = segment%ry_norm_obl(I,segment%HI%jsd,k) + ry_tang_obl(I,segment%HI%JedB,k) = segment%ry_norm_obl(I,segment%HI%jed,k) cff_tangential(I,segment%HI%JsdB,k) = segment%cff_normal(I,segment%HI%jsd,k) cff_tangential(I,segment%HI%JedB,k) = segment%cff_normal(I,segment%HI%jed,k) do J=segment%HI%JsdB+1,segment%HI%JedB-1 - rx_tangential(I,J,k) = 0.5*(segment%rx_normal(I,j,k) + segment%rx_normal(I,j+1,k)) - ry_tangential(I,J,k) = 0.5*(segment%ry_normal(I,j,k) + segment%ry_normal(I,j+1,k)) + rx_tang_obl(I,J,k) = 0.5*(segment%rx_norm_obl(I,j,k) + segment%rx_norm_obl(I,j+1,k)) + ry_tang_obl(I,J,k) = 0.5*(segment%ry_norm_obl(I,j,k) + segment%ry_norm_obl(I,j+1,k)) cff_tangential(I,J,k) = 0.5*(segment%cff_normal(I,j,k) + segment%cff_normal(I,j+1,k)) enddo else @@ -2015,19 +2084,19 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) dhdy = segment%grad_tan(j+1,1,k) endif if (dhdt*dhdx < 0.0) dhdt = 0.0 - rx_new = US%L_T_to_m_s**2*dhdt*dhdx - cff_new = US%L_T_to_m_s**2*max(dhdx*dhdx + dhdy*dhdy, eps) - ry_new = min(cff_new,max(US%L_T_to_m_s**2*dhdt*dhdy,-cff_new)) - rx_tangential(I,j,k) = rx_new - ry_tangential(i,J,k) = ry_new + rx_new = dhdt*dhdx + cff_new = max(dhdx*dhdx + dhdy*dhdy, eps) + ry_new = min(cff_new,max(dhdt*dhdy,-cff_new)) + rx_tang_obl(I,j,k) = rx_new + ry_tang_obl(i,J,k) = ry_new cff_tangential(i,J,k) = cff_new enddo endif enddo if (segment%oblique_tan) then do k=1,nz ; do J=segment%HI%JsdB,segment%HI%JedB - rx_avg = rx_tangential(I,J,k) - ry_avg = ry_tangential(I,J,k) + rx_avg = rx_tang_obl(I,J,k) + ry_avg = ry_tang_obl(I,J,k) cff_avg = cff_tangential(I,J,k) segment%tangential_vel(I,J,k) = ((cff_avg*v_new(i,J,k) + rx_avg*v_new(i-1,J,k)) - & (max(ry_avg,0.0)*segment%grad_tan(j,2,k) + & @@ -2038,13 +2107,13 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) if (segment%nudged_tan) then do k=1,nz ; do J=segment%HI%JsdB,segment%HI%JedB ! dhdt gets set to 0 on inflow in oblique case - if (rx_tangential(I,J,k) <= 0.0) then + if (rx_tang_obl(I,J,k) <= 0.0) then tau = segment%Velocity_nudging_timescale_in else tau = segment%Velocity_nudging_timescale_out endif gamma_2 = dt / (tau + dt) - segment%tangential_vel(I,J,k) = (1 - gamma_2) * segment%tangential_vel(I,J,k) + & + segment%tangential_vel(I,J,k) = (1.0 - gamma_2) * segment%tangential_vel(I,J,k) + & gamma_2 * segment%nudged_tangential_vel(I,J,k) enddo ; enddo endif @@ -2052,8 +2121,8 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) Js_obc = max(segment%HI%JsdB,G%jsd+1) Je_obc = min(segment%HI%JedB,G%jed-1) do k=1,nz ; do J=segment%HI%JsdB+1,segment%HI%JedB-1 - rx_avg = rx_tangential(I,J,k) - ry_avg = ry_tangential(I,J,k) + rx_avg = rx_tang_obl(I,J,k) + ry_avg = ry_tang_obl(I,J,k) cff_avg = cff_tangential(I,J,k) segment%tangential_grad(I,J,k) = & ((cff_avg*(v_new(i,J,k) - v_new(i-1,J,k))*G%IdxBu(I-1,J) + & @@ -2066,18 +2135,18 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) if (segment%nudged_grad) then do k=1,nz ; do J=segment%HI%JsdB,segment%HI%JedB ! dhdt gets set to 0 on inflow in oblique case - if (rx_tangential(I,J,k) <= 0.0) then + if (rx_tang_obl(I,J,k) <= 0.0) then tau = segment%Velocity_nudging_timescale_in else tau = segment%Velocity_nudging_timescale_out endif gamma_2 = dt / (tau + dt) - segment%tangential_grad(I,J,k) = (1 - gamma_2) * segment%tangential_grad(I,J,k) + & + segment%tangential_grad(I,J,k) = (1.0 - gamma_2) * segment%tangential_grad(I,J,k) + & gamma_2 * segment%nudged_tangential_grad(I,J,k) enddo ; enddo endif - deallocate(rx_tangential) - deallocate(ry_tangential) + deallocate(rx_tang_obl) + deallocate(ry_tang_obl) deallocate(cff_tangential) endif endif @@ -2092,11 +2161,11 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) rx_new = 0.0 if (dhdt*dhdx > 0.0) rx_new = min( (dhdt/dhdx), rx_max) if (gamma_u < 1.0) then - rx_avg = (1.0-gamma_u)*segment%rx_normal(I,j,k) + gamma_u*rx_new + rx_avg = (1.0-gamma_u)*segment%rx_norm_rad(I,j,k) + gamma_u*rx_new else rx_avg = rx_new endif - segment%rx_normal(I,j,k) = rx_avg + segment%rx_norm_rad(I,j,k) = rx_avg ! The new boundary value is interpolated between future interior ! value, u_new(I+1) and past boundary value but with barotropic ! accelerations, u_new(I). @@ -2104,7 +2173,7 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) if (gamma_u < 1.0) then ! Copy restart fields into 3-d arrays. This is an inefficient and temporary issues ! implemented as a work-around to limitations in restart capability - OBC%rx_normal(I,j,k) = segment%rx_normal(I,j,k) + OBC%rx_normal(I,j,k) = segment%rx_norm_rad(I,j,k) endif elseif (segment%oblique) then dhdt = (u_old(I+1,j,k) - u_new(I+1,j,k)) !old-new @@ -2118,20 +2187,20 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) endif if (dhdt*dhdx < 0.0) dhdt = 0.0 - rx_new = US%L_T_to_m_s**2*dhdt*dhdx - cff_new = US%L_T_to_m_s**2*max(dhdx*dhdx + dhdy*dhdy, eps) - ry_new = min(cff_new,max(US%L_T_to_m_s**2*dhdt*dhdy,-cff_new)) + rx_new = dhdt*dhdx + cff_new = max(dhdx*dhdx + dhdy*dhdy, eps) + ry_new = min(cff_new,max(dhdt*dhdy,-cff_new)) if (gamma_u < 1.0) then - rx_avg = (1.0-gamma_u)*segment%rx_normal(I,j,k) + gamma_u*rx_new - ry_avg = (1.0-gamma_u)*segment%ry_normal(i,J,k) + gamma_u*ry_new + rx_avg = (1.0-gamma_u)*segment%rx_norm_obl(I,j,k) + gamma_u*rx_new + ry_avg = (1.0-gamma_u)*segment%ry_norm_obl(i,J,k) + gamma_u*ry_new cff_avg = (1.0-gamma_u)*segment%cff_normal(I,j,k) + gamma_u*cff_new else rx_avg = rx_new ry_avg = ry_new cff_avg = cff_new endif - segment%rx_normal(I,j,k) = rx_avg - segment%ry_normal(i,J,k) = ry_avg + segment%rx_norm_obl(I,j,k) = rx_avg + segment%ry_norm_obl(i,J,k) = ry_avg segment%cff_normal(i,J,k) = cff_avg segment%normal_vel(I,j,k) = ((cff_avg*u_new(I,j,k) + rx_avg*u_new(I+1,j,k)) - & (max(ry_avg,0.0)*segment%grad_normal(J-1,2,k) + & @@ -2140,8 +2209,8 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) if (gamma_u < 1.0) then ! Copy restart fields into 3-d arrays. This is an inefficient and temporary issues ! implemented as a work-around to limitations in restart capability - OBC%rx_normal(I,j,k) = segment%rx_normal(I,j,k) - OBC%ry_normal(i,J,k) = segment%ry_normal(i,J,k) + OBC%rx_oblique(I,j,k) = segment%rx_norm_obl(I,j,k) + OBC%ry_oblique(i,J,k) = segment%ry_norm_obl(i,J,k) OBC%cff_normal(I,j,k) = segment%cff_normal(I,j,k) endif elseif (segment%gradient) then @@ -2155,45 +2224,45 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) tau = segment%Velocity_nudging_timescale_out endif gamma_2 = dt / (tau + dt) - segment%normal_vel(I,j,k) = (1 - gamma_2) * segment%normal_vel(I,j,k) + & + segment%normal_vel(I,j,k) = (1.0 - gamma_2) * segment%normal_vel(I,j,k) + & gamma_2 * segment%nudged_normal_vel(I,j,k) endif enddo ; enddo if (segment%radiation_tan .or. segment%radiation_grad) then I=segment%HI%IsdB - allocate(rx_tangential(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz)) + allocate(rx_tang_rad(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz)) do k=1,nz if (gamma_u < 1.0) then - rx_tangential(I,segment%HI%JsdB,k) = segment%rx_normal(I,segment%HI%jsd,k) - rx_tangential(I,segment%HI%JedB,k) = segment%rx_normal(I,segment%HI%jed,k) + rx_tang_rad(I,segment%HI%JsdB,k) = segment%rx_norm_rad(I,segment%HI%jsd,k) + rx_tang_rad(I,segment%HI%JedB,k) = segment%rx_norm_rad(I,segment%HI%jed,k) do J=segment%HI%JsdB+1,segment%HI%JedB-1 - rx_tangential(I,J,k) = 0.5*(segment%rx_normal(I,j,k) + segment%rx_normal(I,j+1,k)) + rx_tang_rad(I,J,k) = 0.5*(segment%rx_norm_rad(I,j,k) + segment%rx_norm_rad(I,j+1,k)) enddo else do J=segment%HI%JsdB,segment%HI%JedB dhdt = v_old(i+1,J,k)-v_new(i+1,J,k) !old-new dhdx = v_new(i+1,J,k)-v_new(i+2,J,k) !in new time backward sasha for I-1 - rx_tangential(I,J,k) = 0.0 - if (dhdt*dhdx > 0.0) rx_tangential(I,J,k) = min( (dhdt/dhdx), rx_max) ! outward phase speed + rx_tang_rad(I,J,k) = 0.0 + if (dhdt*dhdx > 0.0) rx_tang_rad(I,J,k) = min( (dhdt/dhdx), rx_max) ! outward phase speed enddo endif enddo if (segment%radiation_tan) then do k=1,nz ; do J=segment%HI%JsdB,segment%HI%JedB - rx_avg = rx_tangential(I,J,k) + rx_avg = rx_tang_rad(I,J,k) segment%tangential_vel(I,J,k) = (v_new(i+1,J,k) + rx_avg*v_new(i+2,J,k)) / (1.0+rx_avg) enddo ; enddo endif if (segment%nudged_tan) then do k=1,nz ; do J=segment%HI%JsdB,segment%HI%JedB ! dhdt gets set to 0 on inflow in oblique case - if (rx_tangential(I,J,k) <= 0.0) then + if (rx_tang_rad(I,J,k) <= 0.0) then tau = segment%Velocity_nudging_timescale_in else tau = segment%Velocity_nudging_timescale_out endif gamma_2 = dt / (tau + dt) - segment%tangential_vel(I,J,k) = (1 - gamma_2) * segment%tangential_vel(I,J,k) + & + segment%tangential_vel(I,J,k) = (1.0 - gamma_2) * segment%tangential_vel(I,J,k) + & gamma_2 * segment%nudged_tangential_vel(I,J,k) enddo ; enddo endif @@ -2201,13 +2270,13 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) Js_obc = max(segment%HI%JsdB,G%jsd+1) Je_obc = min(segment%HI%JedB,G%jed-1) do k=1,nz ; do J=Js_obc,Je_obc - rx_avg = rx_tangential(I,J,k) + rx_avg = rx_tang_rad(I,J,k) ! if (G%mask2dCu(I+1,j) > 0.0 .and. G%mask2dCu(I+1,j+1) > 0.0) then -! rx_avg = 0.5*(u_new(I+1,j,k) + u_new(I+1,j+1,k)) * US%s_to_T*dt * G%IdxBu(I+1,J) +! rx_avg = 0.5*(u_new(I+1,j,k) + u_new(I+1,j+1,k)) * dt * G%IdxBu(I+1,J) ! elseif (G%mask2dCu(I+1,j) > 0.0) then -! rx_avg = u_new(I+1,j,k) * US%s_to_T*dt * G%IdxBu(I+1,J) +! rx_avg = u_new(I+1,j,k) * dt * G%IdxBu(I+1,J) ! elseif (G%mask2dCu(I+1,j+1) > 0.0) then -! rx_avg = u_new(I+1,j+1,k) * US%s_to_T*dt * G%IdxBu(I+1,J) +! rx_avg = u_new(I+1,j+1,k) * dt * G%IdxBu(I+1,J) ! else ! rx_avg = 0.0 ! endif @@ -2218,34 +2287,34 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) if (segment%nudged_grad) then do k=1,nz ; do J=segment%HI%JsdB,segment%HI%JedB ! dhdt gets set to 0 on inflow in oblique case - if (rx_tangential(I,J,k) <= 0.0) then + if (rx_tang_rad(I,J,k) <= 0.0) then tau = segment%Velocity_nudging_timescale_in else tau = segment%Velocity_nudging_timescale_out endif gamma_2 = dt / (tau + dt) - segment%tangential_grad(I,J,k) = (1 - gamma_2) * segment%tangential_grad(I,J,k) + & + segment%tangential_grad(I,J,k) = (1.0 - gamma_2) * segment%tangential_grad(I,J,k) + & gamma_2 * segment%nudged_tangential_grad(I,J,k) enddo ; enddo endif - deallocate(rx_tangential) + deallocate(rx_tang_rad) endif if (segment%oblique_tan .or. segment%oblique_grad) then I=segment%HI%IsdB - allocate(rx_tangential(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz)) - allocate(ry_tangential(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz)) + allocate(rx_tang_obl(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz)) + allocate(ry_tang_obl(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz)) allocate(cff_tangential(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz)) do k=1,nz if (gamma_u < 1.0) then - rx_tangential(I,segment%HI%JsdB,k) = segment%rx_normal(I,segment%HI%jsd,k) - rx_tangential(I,segment%HI%JedB,k) = segment%rx_normal(I,segment%HI%jed,k) - ry_tangential(I,segment%HI%JsdB,k) = segment%ry_normal(I,segment%HI%jsd,k) - ry_tangential(I,segment%HI%JedB,k) = segment%ry_normal(I,segment%HI%jed,k) + rx_tang_obl(I,segment%HI%JsdB,k) = segment%rx_norm_obl(I,segment%HI%jsd,k) + rx_tang_obl(I,segment%HI%JedB,k) = segment%rx_norm_obl(I,segment%HI%jed,k) + ry_tang_obl(I,segment%HI%JsdB,k) = segment%ry_norm_obl(I,segment%HI%jsd,k) + ry_tang_obl(I,segment%HI%JedB,k) = segment%ry_norm_obl(I,segment%HI%jed,k) cff_tangential(I,segment%HI%JsdB,k) = segment%cff_normal(I,segment%HI%jsd,k) cff_tangential(I,segment%HI%JedB,k) = segment%cff_normal(I,segment%HI%jed,k) do J=segment%HI%JsdB+1,segment%HI%JedB-1 - rx_tangential(I,J,k) = 0.5*(segment%rx_normal(I,j,k) + segment%rx_normal(I,j+1,k)) - ry_tangential(I,J,k) = 0.5*(segment%ry_normal(I,j,k) + segment%ry_normal(I,j+1,k)) + rx_tang_obl(I,J,k) = 0.5*(segment%rx_norm_obl(I,j,k) + segment%rx_norm_obl(I,j+1,k)) + ry_tang_obl(I,J,k) = 0.5*(segment%ry_norm_obl(I,j,k) + segment%ry_norm_obl(I,j+1,k)) cff_tangential(I,J,k) = 0.5*(segment%cff_normal(I,j,k) + segment%cff_normal(I,j+1,k)) enddo else @@ -2260,19 +2329,19 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) dhdy = segment%grad_tan(j+1,1,k) endif if (dhdt*dhdx < 0.0) dhdt = 0.0 - rx_new = US%L_T_to_m_s**2*dhdt*dhdx - cff_new = US%L_T_to_m_s**2*max(dhdx*dhdx + dhdy*dhdy, eps) - ry_new = min(cff_new,max(US%L_T_to_m_s**2*dhdt*dhdy,-cff_new)) - rx_tangential(I,j,k) = rx_new - ry_tangential(i,J,k) = ry_new + rx_new = dhdt*dhdx + cff_new = max(dhdx*dhdx + dhdy*dhdy, eps) + ry_new = min(cff_new,max(dhdt*dhdy,-cff_new)) + rx_tang_obl(I,j,k) = rx_new + ry_tang_obl(i,J,k) = ry_new cff_tangential(i,J,k) = cff_new enddo endif enddo if (segment%oblique_tan) then do k=1,nz ; do J=segment%HI%JsdB,segment%HI%JedB - rx_avg = rx_tangential(I,J,k) - ry_avg = ry_tangential(I,J,k) + rx_avg = rx_tang_obl(I,J,k) + ry_avg = ry_tang_obl(I,J,k) cff_avg = cff_tangential(I,J,k) segment%tangential_vel(I,J,k) = ((cff_avg*v_new(i+1,J,k) + rx_avg*v_new(i+2,J,k)) - & (max(ry_avg,0.0)*segment%grad_tan(j,2,k) + & @@ -2283,13 +2352,13 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) if (segment%nudged_tan) then do k=1,nz ; do J=segment%HI%JsdB,segment%HI%JedB ! dhdt gets set to 0 on inflow in oblique case - if (rx_tangential(I,J,k) <= 0.0) then + if (rx_tang_obl(I,J,k) <= 0.0) then tau = segment%Velocity_nudging_timescale_in else tau = segment%Velocity_nudging_timescale_out endif gamma_2 = dt / (tau + dt) - segment%tangential_vel(I,J,k) = (1 - gamma_2) * segment%tangential_vel(I,J,k) + & + segment%tangential_vel(I,J,k) = (1.0 - gamma_2) * segment%tangential_vel(I,J,k) + & gamma_2 * segment%nudged_tangential_vel(I,J,k) enddo ; enddo endif @@ -2297,8 +2366,8 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) Js_obc = max(segment%HI%JsdB,G%jsd+1) Je_obc = min(segment%HI%JedB,G%jed-1) do k=1,nz ; do J=segment%HI%JsdB+1,segment%HI%JedB-1 - rx_avg = rx_tangential(I,J,k) - ry_avg = ry_tangential(I,J,k) + rx_avg = rx_tang_obl(I,J,k) + ry_avg = ry_tang_obl(I,J,k) cff_avg = cff_tangential(I,J,k) segment%tangential_grad(I,J,k) = & ((cff_avg*(v_new(i+2,J,k) - v_new(i+1,J,k))*G%IdxBu(I+1,J) + & @@ -2311,18 +2380,18 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) if (segment%nudged_grad) then do k=1,nz ; do J=segment%HI%JsdB,segment%HI%JedB ! dhdt gets set to 0 on inflow in oblique case - if (rx_tangential(I,J,k) <= 0.0) then + if (rx_tang_obl(I,J,k) <= 0.0) then tau = segment%Velocity_nudging_timescale_in else tau = segment%Velocity_nudging_timescale_out endif gamma_2 = dt / (tau + dt) - segment%tangential_grad(I,J,k) = (1 - gamma_2) * segment%tangential_grad(I,J,k) + & + segment%tangential_grad(I,J,k) = (1.0 - gamma_2) * segment%tangential_grad(I,J,k) + & gamma_2 * segment%nudged_tangential_grad(I,J,k) enddo ; enddo endif - deallocate(rx_tangential) - deallocate(ry_tangential) + deallocate(rx_tang_obl) + deallocate(ry_tang_obl) deallocate(cff_tangential) endif endif @@ -2337,11 +2406,11 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) ry_new = 0.0 if (dhdt*dhdy > 0.0) ry_new = min( (dhdt/dhdy), ry_max) if (gamma_u < 1.0) then - ry_avg = (1.0-gamma_v)*segment%ry_normal(I,j,k) + gamma_v*ry_new + ry_avg = (1.0-gamma_u)*segment%ry_norm_rad(I,j,k) + gamma_u*ry_new else ry_avg = ry_new endif - segment%ry_normal(i,J,k) = ry_avg + segment%ry_norm_rad(i,J,k) = ry_avg ! The new boundary value is interpolated between future interior ! value, v_new(J-1) and past boundary value but with barotropic ! accelerations, v_new(J). @@ -2349,7 +2418,7 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) if (gamma_u < 1.0) then ! Copy restart fields into 3-d arrays. This is an inefficient and temporary issues ! implemented as a work-around to limitations in restart capability - OBC%ry_normal(i,J,k) = segment%ry_normal(i,J,k) + OBC%ry_normal(i,J,k) = segment%ry_norm_rad(i,J,k) endif elseif (segment%oblique) then dhdt = (v_old(i,J-1,k) - v_new(i,J-1,k)) !old-new @@ -2362,20 +2431,20 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) dhdx = segment%grad_normal(I,1,k) endif if (dhdt*dhdy < 0.0) dhdt = 0.0 - ry_new = US%L_T_to_m_s**2*dhdt*dhdy - cff_new = US%L_T_to_m_s**2*max(dhdx*dhdx + dhdy*dhdy, eps) - rx_new = min(cff_new,max(US%L_T_to_m_s**2*dhdt*dhdx,-cff_new)) + ry_new = dhdt*dhdy + cff_new = max(dhdx*dhdx + dhdy*dhdy, eps) + rx_new = min(cff_new,max(dhdt*dhdx,-cff_new)) if (gamma_u < 1.0) then - rx_avg = (1.0-gamma_u)*segment%rx_normal(I,j,k) + gamma_u*rx_new - ry_avg = (1.0-gamma_u)*segment%ry_normal(i,J,k) + gamma_u*ry_new + rx_avg = (1.0-gamma_u)*segment%rx_norm_obl(I,j,k) + gamma_u*rx_new + ry_avg = (1.0-gamma_u)*segment%ry_norm_obl(i,J,k) + gamma_u*ry_new cff_avg = (1.0-gamma_u)*segment%cff_normal(i,J,k) + gamma_u*cff_new else rx_avg = rx_new ry_avg = ry_new cff_avg = cff_new endif - segment%rx_normal(I,j,k) = rx_avg - segment%ry_normal(i,J,k) = ry_avg + segment%rx_norm_obl(I,j,k) = rx_avg + segment%ry_norm_obl(i,J,k) = ry_avg segment%cff_normal(i,J,k) = cff_avg segment%normal_vel(i,J,k) = ((cff_avg*v_new(i,J,k) + ry_avg*v_new(i,J-1,k)) - & (max(rx_avg,0.0)*segment%grad_normal(I-1,2,k) +& @@ -2384,8 +2453,8 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) if (gamma_u < 1.0) then ! Copy restart fields into 3-d arrays. This is an inefficient and temporary issues ! implemented as a work-around to limitations in restart capability - OBC%rx_normal(I,j,k) = segment%rx_normal(I,j,k) - OBC%ry_normal(i,J,k) = segment%ry_normal(i,J,k) + OBC%rx_oblique(I,j,k) = segment%rx_norm_obl(I,j,k) + OBC%ry_oblique(i,J,k) = segment%ry_norm_obl(i,J,k) OBC%cff_normal(i,J,k) = segment%cff_normal(i,J,k) endif elseif (segment%gradient) then @@ -2399,45 +2468,45 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) tau = segment%Velocity_nudging_timescale_out endif gamma_2 = dt / (tau + dt) - segment%normal_vel(i,J,k) = (1 - gamma_2) * segment%normal_vel(i,J,k) + & + segment%normal_vel(i,J,k) = (1.0 - gamma_2) * segment%normal_vel(i,J,k) + & gamma_2 * segment%nudged_normal_vel(i,J,k) endif enddo ; enddo if (segment%radiation_tan .or. segment%radiation_grad) then J=segment%HI%JsdB - allocate(ry_tangential(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz)) + allocate(ry_tang_rad(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz)) do k=1,nz if (gamma_u < 1.0) then - ry_tangential(segment%HI%IsdB,J,k) = segment%ry_normal(segment%HI%isd,J,k) - ry_tangential(segment%HI%IedB,J,k) = segment%ry_normal(segment%HI%ied,J,k) + ry_tang_rad(segment%HI%IsdB,J,k) = segment%ry_norm_rad(segment%HI%isd,J,k) + ry_tang_rad(segment%HI%IedB,J,k) = segment%ry_norm_rad(segment%HI%ied,J,k) do I=segment%HI%IsdB+1,segment%HI%IedB-1 - ry_tangential(I,J,k) = 0.5*(segment%ry_normal(i,J,k) + segment%ry_normal(i+1,J,k)) + ry_tang_rad(I,J,k) = 0.5*(segment%ry_norm_rad(i,J,k) + segment%ry_norm_rad(i+1,J,k)) enddo else do I=segment%HI%IsdB,segment%HI%IedB dhdt = u_old(I,j-1,k)-u_new(I,j-1,k) !old-new dhdy = u_new(I,j-1,k)-u_new(I,j-2,k) !in new time backward sasha for I-1 - ry_tangential(I,J,k) = 0.0 - if (dhdt*dhdy > 0.0) ry_tangential(I,J,k) = min( (dhdt/dhdy), rx_max) ! outward phase speed + ry_tang_rad(I,J,k) = 0.0 + if (dhdt*dhdy > 0.0) ry_tang_rad(I,J,k) = min( (dhdt/dhdy), rx_max) ! outward phase speed enddo endif enddo if (segment%radiation_tan) then do k=1,nz ; do I=segment%HI%IsdB,segment%HI%IedB - ry_avg = ry_tangential(I,J,k) + ry_avg = ry_tang_rad(I,J,k) segment%tangential_vel(I,J,k) = (u_new(I,j,k) + ry_avg*u_new(I,j-1,k)) / (1.0+ry_avg) enddo ; enddo endif if (segment%nudged_tan) then do k=1,nz ; do I=segment%HI%IsdB,segment%HI%IedB ! dhdt gets set to 0 on inflow in oblique case - if (ry_tangential(I,J,k) <= 0.0) then + if (ry_tang_rad(I,J,k) <= 0.0) then tau = segment%Velocity_nudging_timescale_in else tau = segment%Velocity_nudging_timescale_out endif gamma_2 = dt / (tau + dt) - segment%tangential_vel(I,J,k) = (1 - gamma_2) * segment%tangential_vel(I,J,k) + & + segment%tangential_vel(I,J,k) = (1.0 - gamma_2) * segment%tangential_vel(I,J,k) + & gamma_2 * segment%nudged_tangential_vel(I,J,k) enddo ; enddo endif @@ -2445,13 +2514,13 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) Is_obc = max(segment%HI%IsdB,G%isd+1) Ie_obc = min(segment%HI%IedB,G%ied-1) do k=1,nz ; do I=Is_obc,Ie_obc - ry_avg = ry_tangential(I,J,k) + ry_avg = ry_tang_rad(I,J,k) ! if (G%mask2dCv(i,J-1) > 0.0 .and. G%mask2dCv(i+1,J-1) > 0.0) then -! ry_avg = 0.5*(v_new(i,J-1,k) + v_new(i+1,J-1,k) * US%s_to_T*dt * G%IdyBu(I,J-1)) +! ry_avg = 0.5*(v_new(i,J-1,k) + v_new(i+1,J-1,k) * dt * G%IdyBu(I,J-1)) ! elseif (G%mask2dCv(i,J-1) > 0.0) then -! ry_avg = v_new(i,J-1,k) * US%s_to_T*dt *G%IdyBu(I,J-1) +! ry_avg = v_new(i,J-1,k) * dt *G%IdyBu(I,J-1) ! elseif (G%mask2dCv(i+1,J-1) > 0.0) then -! ry_avg = v_new(i+1,J-1,k) * US%s_to_T*dt *G%IdyBu(I,J-1) +! ry_avg = v_new(i+1,J-1,k) * dt *G%IdyBu(I,J-1) ! else ! ry_avg = 0.0 ! endif @@ -2462,34 +2531,34 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) if (segment%nudged_grad) then do k=1,nz ; do I=segment%HI%IsdB,segment%HI%IedB ! dhdt gets set to 0 on inflow in oblique case - if (ry_tangential(I,J,k) <= 0.0) then + if (ry_tang_rad(I,J,k) <= 0.0) then tau = segment%Velocity_nudging_timescale_in else tau = segment%Velocity_nudging_timescale_out endif gamma_2 = dt / (tau + dt) - segment%tangential_grad(I,J,k) = (1 - gamma_2) * segment%tangential_grad(I,J,k) + & + segment%tangential_grad(I,J,k) = (1.0 - gamma_2) * segment%tangential_grad(I,J,k) + & gamma_2 * segment%nudged_tangential_grad(I,J,k) enddo ; enddo endif - deallocate(ry_tangential) + deallocate(ry_tang_rad) endif if (segment%oblique_tan .or. segment%oblique_grad) then J=segment%HI%JsdB - allocate(rx_tangential(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz)) - allocate(ry_tangential(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz)) + allocate(rx_tang_obl(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz)) + allocate(ry_tang_obl(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz)) allocate(cff_tangential(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz)) do k=1,nz if (gamma_u < 1.0) then - rx_tangential(segment%HI%IsdB,J,k) = segment%rx_normal(segment%HI%isd,J,k) - rx_tangential(segment%HI%IedB,J,k) = segment%rx_normal(segment%HI%ied,J,k) - ry_tangential(segment%HI%IsdB,J,k) = segment%ry_normal(segment%HI%isd,J,k) - ry_tangential(segment%HI%IedB,J,k) = segment%ry_normal(segment%HI%ied,J,k) + rx_tang_obl(segment%HI%IsdB,J,k) = segment%rx_norm_obl(segment%HI%isd,J,k) + rx_tang_obl(segment%HI%IedB,J,k) = segment%rx_norm_obl(segment%HI%ied,J,k) + ry_tang_obl(segment%HI%IsdB,J,k) = segment%ry_norm_obl(segment%HI%isd,J,k) + ry_tang_obl(segment%HI%IedB,J,k) = segment%ry_norm_obl(segment%HI%ied,J,k) cff_tangential(segment%HI%IsdB,J,k) = segment%cff_normal(segment%HI%isd,J,k) cff_tangential(segment%HI%IedB,J,k) = segment%cff_normal(segment%HI%ied,J,k) do I=segment%HI%IsdB+1,segment%HI%IedB-1 - rx_tangential(I,J,k) = 0.5*(segment%rx_normal(i,J,k) + segment%rx_normal(i+1,J,k)) - ry_tangential(I,J,k) = 0.5*(segment%ry_normal(i,J,k) + segment%ry_normal(i+1,J,k)) + rx_tang_obl(I,J,k) = 0.5*(segment%rx_norm_obl(i,J,k) + segment%rx_norm_obl(i+1,J,k)) + ry_tang_obl(I,J,k) = 0.5*(segment%ry_norm_obl(i,J,k) + segment%ry_norm_obl(i+1,J,k)) cff_tangential(I,J,k) = 0.5*(segment%cff_normal(i,J,k) + segment%cff_normal(i+1,J,k)) enddo else @@ -2504,19 +2573,19 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) dhdx = segment%grad_tan(i+1,1,k) endif if (dhdt*dhdy < 0.0) dhdt = 0.0 - ry_new = US%L_T_to_m_s**2*dhdt*dhdy - cff_new = US%L_T_to_m_s**2*max(dhdx*dhdx + dhdy*dhdy, eps) - rx_new = min(cff_new,max(US%L_T_to_m_s**2*dhdt*dhdx,-cff_new)) - rx_tangential(I,j,k) = rx_new - ry_tangential(i,J,k) = ry_new + ry_new = dhdt*dhdy + cff_new = max(dhdx*dhdx + dhdy*dhdy, eps) + rx_new = min(cff_new,max(dhdt*dhdx,-cff_new)) + rx_tang_obl(I,j,k) = rx_new + ry_tang_obl(i,J,k) = ry_new cff_tangential(i,J,k) = cff_new enddo endif enddo if (segment%oblique_tan) then do k=1,nz ; do I=segment%HI%IsdB,segment%HI%IedB - rx_avg = rx_tangential(I,J,k) - ry_avg = ry_tangential(I,J,k) + rx_avg = rx_tang_obl(I,J,k) + ry_avg = ry_tang_obl(I,J,k) cff_avg = cff_tangential(I,J,k) segment%tangential_vel(I,J,k) = ((cff_avg*u_new(I,j,k) + ry_avg*u_new(I,j-1,k)) - & (max(rx_avg,0.0)*segment%grad_tan(i,2,k) + & @@ -2527,13 +2596,13 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) if (segment%nudged_tan) then do k=1,nz ; do I=segment%HI%IsdB,segment%HI%IedB ! dhdt gets set to 0 on inflow in oblique case - if (ry_tangential(I,J,k) <= 0.0) then + if (ry_tang_obl(I,J,k) <= 0.0) then tau = segment%Velocity_nudging_timescale_in else tau = segment%Velocity_nudging_timescale_out endif gamma_2 = dt / (tau + dt) - segment%tangential_vel(I,J,k) = (1 - gamma_2) * segment%tangential_vel(I,J,k) + & + segment%tangential_vel(I,J,k) = (1.0 - gamma_2) * segment%tangential_vel(I,J,k) + & gamma_2 * segment%nudged_tangential_vel(I,J,k) enddo ; enddo endif @@ -2541,8 +2610,8 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) Is_obc = max(segment%HI%IsdB,G%isd+1) Ie_obc = min(segment%HI%IedB,G%ied-1) do k=1,nz ; do I=segment%HI%IsdB+1,segment%HI%IedB-1 - rx_avg = rx_tangential(I,J,k) - ry_avg = ry_tangential(I,J,k) + rx_avg = rx_tang_obl(I,J,k) + ry_avg = ry_tang_obl(I,J,k) cff_avg = cff_tangential(I,J,k) segment%tangential_grad(I,J,k) = & ((cff_avg*(u_new(I,j,k) - u_new(I,j-1,k))*G%IdyBu(I,J-1) + & @@ -2555,18 +2624,18 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) if (segment%nudged_grad) then do k=1,nz ; do I=segment%HI%IsdB,segment%HI%IedB ! dhdt gets set to 0 on inflow in oblique case - if (ry_tangential(I,J,k) <= 0.0) then + if (ry_tang_obl(I,J,k) <= 0.0) then tau = segment%Velocity_nudging_timescale_in else tau = segment%Velocity_nudging_timescale_out endif gamma_2 = dt / (tau + dt) - segment%tangential_grad(I,J,k) = (1 - gamma_2) * segment%tangential_grad(I,J,k) + & + segment%tangential_grad(I,J,k) = (1.0 - gamma_2) * segment%tangential_grad(I,J,k) + & gamma_2 * segment%nudged_tangential_grad(I,J,k) enddo ; enddo endif - deallocate(rx_tangential) - deallocate(ry_tangential) + deallocate(rx_tang_obl) + deallocate(ry_tang_obl) deallocate(cff_tangential) endif endif @@ -2581,11 +2650,11 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) ry_new = 0.0 if (dhdt*dhdy > 0.0) ry_new = min( (dhdt/dhdy), ry_max) if (gamma_u < 1.0) then - ry_avg = (1.0-gamma_v)*segment%ry_normal(I,j,k) + gamma_v*ry_new + ry_avg = (1.0-gamma_u)*segment%ry_norm_rad(I,j,k) + gamma_u*ry_new else ry_avg = ry_new endif - segment%ry_normal(i,J,k) = ry_avg + segment%ry_norm_rad(i,J,k) = ry_avg ! The new boundary value is interpolated between future interior ! value, v_new(J+1) and past boundary value but with barotropic ! accelerations, v_new(J). @@ -2593,7 +2662,7 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) if (gamma_u < 1.0) then ! Copy restart fields into 3-d arrays. This is an inefficient and temporary issues ! implemented as a work-around to limitations in restart capability - OBC%ry_normal(i,J,k) = segment%ry_normal(i,J,k) + OBC%ry_normal(i,J,k) = segment%ry_norm_rad(i,J,k) endif elseif (segment%oblique) then dhdt = (v_old(i,J+1,k) - v_new(i,J+1,k)) !old-new @@ -2607,20 +2676,20 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) endif if (dhdt*dhdy < 0.0) dhdt = 0.0 - ry_new = US%L_T_to_m_s**2*dhdt*dhdy - cff_new = US%L_T_to_m_s**2*max(dhdx*dhdx + dhdy*dhdy, eps) - rx_new = min(cff_new,max(US%L_T_to_m_s**2*dhdt*dhdx,-cff_new)) + ry_new = dhdt*dhdy + cff_new = max(dhdx*dhdx + dhdy*dhdy, eps) + rx_new = min(cff_new,max(dhdt*dhdx,-cff_new)) if (gamma_u < 1.0) then - rx_avg = (1.0-gamma_u)*segment%rx_normal(I,j,k) + gamma_u*rx_new - ry_avg = (1.0-gamma_u)*segment%ry_normal(i,J,k) + gamma_u*ry_new + rx_avg = (1.0-gamma_u)*segment%rx_norm_obl(I,j,k) + gamma_u*rx_new + ry_avg = (1.0-gamma_u)*segment%ry_norm_obl(i,J,k) + gamma_u*ry_new cff_avg = (1.0-gamma_u)*segment%cff_normal(i,J,k) + gamma_u*cff_new else rx_avg = rx_new ry_avg = ry_new cff_avg = cff_new endif - segment%rx_normal(I,j,k) = rx_avg - segment%ry_normal(i,J,k) = ry_avg + segment%rx_norm_obl(I,j,k) = rx_avg + segment%ry_norm_obl(i,J,k) = ry_avg segment%cff_normal(i,J,k) = cff_avg segment%normal_vel(i,J,k) = ((cff_avg*v_new(i,J,k) + ry_avg*v_new(i,J+1,k)) - & (max(rx_avg,0.0)*segment%grad_normal(I-1,2,k) + & @@ -2629,8 +2698,8 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) if (gamma_u < 1.0) then ! Copy restart fields into 3-d arrays. This is an inefficient and temporary issues ! implemented as a work-around to limitations in restart capability - OBC%rx_normal(I,j,k) = segment%rx_normal(I,j,k) - OBC%ry_normal(i,J,k) = segment%ry_normal(i,J,k) + OBC%rx_oblique(I,j,k) = segment%rx_norm_obl(I,j,k) + OBC%ry_oblique(i,J,k) = segment%ry_norm_obl(i,J,k) OBC%cff_normal(i,J,k) = segment%cff_normal(i,J,k) endif elseif (segment%gradient) then @@ -2644,45 +2713,45 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) tau = segment%Velocity_nudging_timescale_out endif gamma_2 = dt / (tau + dt) - segment%normal_vel(i,J,k) = (1 - gamma_2) * segment%normal_vel(i,J,k) + & + segment%normal_vel(i,J,k) = (1.0 - gamma_2) * segment%normal_vel(i,J,k) + & gamma_2 * segment%nudged_normal_vel(i,J,k) endif enddo ; enddo if (segment%radiation_tan .or. segment%radiation_grad) then J=segment%HI%JsdB - allocate(ry_tangential(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz)) + allocate(ry_tang_rad(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz)) do k=1,nz if (gamma_u < 1.0) then - ry_tangential(segment%HI%IsdB,J,k) = segment%ry_normal(segment%HI%isd,J,k) - ry_tangential(segment%HI%IedB,J,k) = segment%ry_normal(segment%HI%ied,J,k) + ry_tang_rad(segment%HI%IsdB,J,k) = segment%ry_norm_rad(segment%HI%isd,J,k) + ry_tang_rad(segment%HI%IedB,J,k) = segment%ry_norm_rad(segment%HI%ied,J,k) do I=segment%HI%IsdB+1,segment%HI%IedB-1 - ry_tangential(I,J,k) = 0.5*(segment%ry_normal(i,J,k) + segment%ry_normal(i+1,J,k)) + ry_tang_rad(I,J,k) = 0.5*(segment%ry_norm_rad(i,J,k) + segment%ry_norm_rad(i+1,J,k)) enddo else do I=segment%HI%IsdB,segment%HI%IedB dhdt = u_old(I,j+1,k)-u_new(I,j+1,k) !old-new dhdy = u_new(I,j+1,k)-u_new(I,j+2,k) !in new time backward sasha for I-1 - ry_tangential(I,J,k) = 0.0 - if (dhdt*dhdy > 0.0) ry_tangential(I,J,k) = min( (dhdt/dhdy), rx_max) ! outward phase speed + ry_tang_rad(I,J,k) = 0.0 + if (dhdt*dhdy > 0.0) ry_tang_rad(I,J,k) = min( (dhdt/dhdy), rx_max) ! outward phase speed enddo endif enddo if (segment%radiation_tan) then do k=1,nz ; do I=segment%HI%IsdB,segment%HI%IedB - ry_avg = ry_tangential(I,J,k) + ry_avg = ry_tang_rad(I,J,k) segment%tangential_vel(I,J,k) = (u_new(I,j+1,k) + ry_avg*u_new(I,j+2,k)) / (1.0+ry_avg) enddo ; enddo endif if (segment%nudged_tan) then do k=1,nz ; do I=segment%HI%IsdB,segment%HI%IedB ! dhdt gets set to 0 on inflow in oblique case - if (ry_tangential(I,J,k) <= 0.0) then + if (ry_tang_rad(I,J,k) <= 0.0) then tau = segment%Velocity_nudging_timescale_in else tau = segment%Velocity_nudging_timescale_out endif gamma_2 = dt / (tau + dt) - segment%tangential_vel(I,J,k) = (1 - gamma_2) * segment%tangential_vel(I,J,k) + & + segment%tangential_vel(I,J,k) = (1.0 - gamma_2) * segment%tangential_vel(I,J,k) + & gamma_2 * segment%nudged_tangential_vel(I,J,k) enddo ; enddo endif @@ -2690,13 +2759,13 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) Is_obc = max(segment%HI%IsdB,G%isd+1) Ie_obc = min(segment%HI%IedB,G%ied-1) do k=1,nz ; do I=Is_obc,Ie_obc - ry_avg = ry_tangential(I,J,k) + ry_avg = ry_tang_rad(I,J,k) ! if (G%mask2dCv(i,J+1) > 0.0 .and. G%mask2dCv(i+1,J+1) > 0.0) then -! ry_avg = 0.5*(v_new(i,J+1,k) + v_new(i+1,J+1,k)) * US%s_to_T*dt * G%IdyBu(I,J+1) +! ry_avg = 0.5*(v_new(i,J+1,k) + v_new(i+1,J+1,k)) * dt * G%IdyBu(I,J+1) ! elseif (G%mask2dCv(i,J+1) > 0.0) then -! ry_avg = v_new(i,J+1,k) * US%s_to_T*dt * G%IdyBu(I,J+1) +! ry_avg = v_new(i,J+1,k) * dt * G%IdyBu(I,J+1) ! elseif (G%mask2dCv(i+1,J+1) > 0.0) then -! ry_avg = v_new(i+1,J+1,k) * US%s_to_T*dt * G%IdyBu(I,J+1) +! ry_avg = v_new(i+1,J+1,k) * dt * G%IdyBu(I,J+1) ! else ! ry_avg = 0.0 ! endif @@ -2707,34 +2776,34 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) if (segment%nudged_grad) then do k=1,nz ; do J=segment%HI%JsdB,segment%HI%JedB ! dhdt gets set to 0 on inflow in oblique case - if (ry_tangential(I,J,k) <= 0.0) then + if (ry_tang_rad(I,J,k) <= 0.0) then tau = segment%Velocity_nudging_timescale_in else tau = segment%Velocity_nudging_timescale_out endif gamma_2 = dt / (tau + dt) - segment%tangential_grad(I,J,k) = (1 - gamma_2) * segment%tangential_grad(I,J,k) + & + segment%tangential_grad(I,J,k) = (1.0 - gamma_2) * segment%tangential_grad(I,J,k) + & gamma_2 * segment%nudged_tangential_grad(I,J,k) enddo ; enddo endif - deallocate(ry_tangential) + deallocate(ry_tang_rad) endif if (segment%oblique_tan .or. segment%oblique_grad) then J=segment%HI%JsdB - allocate(rx_tangential(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz)) - allocate(ry_tangential(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz)) + allocate(rx_tang_obl(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz)) + allocate(ry_tang_obl(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz)) allocate(cff_tangential(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz)) do k=1,nz if (gamma_u < 1.0) then - rx_tangential(segment%HI%IsdB,J,k) = segment%rx_normal(segment%HI%isd,J,k) - rx_tangential(segment%HI%IedB,J,k) = segment%rx_normal(segment%HI%ied,J,k) - ry_tangential(segment%HI%IsdB,J,k) = segment%ry_normal(segment%HI%isd,J,k) - ry_tangential(segment%HI%IedB,J,k) = segment%ry_normal(segment%HI%ied,J,k) + rx_tang_obl(segment%HI%IsdB,J,k) = segment%rx_norm_obl(segment%HI%isd,J,k) + rx_tang_obl(segment%HI%IedB,J,k) = segment%rx_norm_obl(segment%HI%ied,J,k) + ry_tang_obl(segment%HI%IsdB,J,k) = segment%ry_norm_obl(segment%HI%isd,J,k) + ry_tang_obl(segment%HI%IedB,J,k) = segment%ry_norm_obl(segment%HI%ied,J,k) cff_tangential(segment%HI%IsdB,J,k) = segment%cff_normal(segment%HI%isd,J,k) cff_tangential(segment%HI%IedB,J,k) = segment%cff_normal(segment%HI%ied,J,k) do I=segment%HI%IsdB+1,segment%HI%IedB-1 - rx_tangential(I,J,k) = 0.5*(segment%rx_normal(i,J,k) + segment%rx_normal(i+1,J,k)) - ry_tangential(I,J,k) = 0.5*(segment%ry_normal(i,J,k) + segment%ry_normal(i+1,J,k)) + rx_tang_obl(I,J,k) = 0.5*(segment%rx_norm_obl(i,J,k) + segment%rx_norm_obl(i+1,J,k)) + ry_tang_obl(I,J,k) = 0.5*(segment%ry_norm_obl(i,J,k) + segment%ry_norm_obl(i+1,J,k)) cff_tangential(I,J,k) = 0.5*(segment%cff_normal(i,J,k) + segment%cff_normal(i+1,J,k)) enddo else @@ -2749,19 +2818,19 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) dhdx = segment%grad_tan(i+1,1,k) endif if (dhdt*dhdy < 0.0) dhdt = 0.0 - ry_new = US%L_T_to_m_s**2*dhdt*dhdy - cff_new = US%L_T_to_m_s**2*max(dhdx*dhdx + dhdy*dhdy, eps) - rx_new = min(cff_new,max(US%L_T_to_m_s**2*dhdt*dhdx,-cff_new)) - rx_tangential(I,j,k) = rx_new - ry_tangential(i,J,k) = ry_new + ry_new = dhdt*dhdy + cff_new = max(dhdx*dhdx + dhdy*dhdy, eps) + rx_new = min(cff_new,max(dhdt*dhdx,-cff_new)) + rx_tang_obl(I,j,k) = rx_new + ry_tang_obl(i,J,k) = ry_new cff_tangential(i,J,k) = cff_new enddo endif enddo if (segment%oblique_tan) then do k=1,nz ; do I=segment%HI%IsdB,segment%HI%IedB - rx_avg = rx_tangential(I,J,k) - ry_avg = ry_tangential(I,J,k) + rx_avg = rx_tang_obl(I,J,k) + ry_avg = ry_tang_obl(I,J,k) cff_avg = cff_tangential(I,J,k) segment%tangential_vel(I,J,k) = ((cff_avg*u_new(I,j+1,k) + ry_avg*u_new(I,j+2,k)) - & (max(rx_avg,0.0)*segment%grad_tan(i,2,k) + & @@ -2772,13 +2841,13 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) if (segment%nudged_tan) then do k=1,nz ; do I=segment%HI%IsdB,segment%HI%IedB ! dhdt gets set to 0 on inflow in oblique case - if (ry_tangential(I,J,k) <= 0.0) then + if (ry_tang_obl(I,J,k) <= 0.0) then tau = segment%Velocity_nudging_timescale_in else tau = segment%Velocity_nudging_timescale_out endif gamma_2 = dt / (tau + dt) - segment%tangential_vel(I,J,k) = (1 - gamma_2) * segment%tangential_vel(I,J,k) + & + segment%tangential_vel(I,J,k) = (1.0 - gamma_2) * segment%tangential_vel(I,J,k) + & gamma_2 * segment%nudged_tangential_vel(I,J,k) enddo ; enddo endif @@ -2786,8 +2855,8 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) Is_obc = max(segment%HI%IsdB,G%isd+1) Ie_obc = min(segment%HI%IedB,G%ied-1) do k=1,nz ; do I=segment%HI%IsdB+1,segment%HI%IedB-1 - rx_avg = rx_tangential(I,J,k) - ry_avg = ry_tangential(I,J,k) + rx_avg = rx_tang_obl(I,J,k) + ry_avg = ry_tang_obl(I,J,k) cff_avg = cff_tangential(I,J,k) segment%tangential_grad(I,J,k) = & ((cff_avg*(u_new(I,j+2,k) - u_new(I,j+1,k))*G%IdyBu(I,J+1) + & @@ -2800,18 +2869,18 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) if (segment%nudged_grad) then do k=1,nz ; do J=segment%HI%JsdB,segment%HI%JedB ! dhdt gets set to 0 on inflow in oblique case - if (ry_tangential(I,J,k) <= 0.0) then + if (ry_tang_obl(I,J,k) <= 0.0) then tau = segment%Velocity_nudging_timescale_in else tau = segment%Velocity_nudging_timescale_out endif gamma_2 = dt / (tau + dt) - segment%tangential_grad(I,J,k) = (1 - gamma_2) * segment%tangential_grad(I,J,k) + & + segment%tangential_grad(I,J,k) = (1.0 - gamma_2) * segment%tangential_grad(I,J,k) + & gamma_2 * segment%nudged_tangential_grad(I,J,k) enddo ; enddo endif - deallocate(rx_tangential) - deallocate(ry_tangential) + deallocate(rx_tang_obl) + deallocate(ry_tang_obl) deallocate(cff_tangential) endif endif @@ -2923,9 +2992,9 @@ subroutine gradient_at_q_points(G, segment, uvel, vvel) do k=1,G%ke do J=max(segment%HI%jsd, G%HI%jsd+1),min(segment%HI%jed, G%HI%jed-1) segment%grad_gradient(j,1,k) = (((vvel(i-1,J,k) - vvel(i-2,J,k))*G%IdxBu(I-2,J)) - & - (vvel(i-1,J-1,k) - vvel(i-2,J-1,k))*G%IdxBu(I-2,J-1)) * G%mask2dCu(I-1,j) + (vvel(i-1,J-1,k) - vvel(i-2,J-1,k))*G%IdxBu(I-2,J-1)) * G%mask2dCu(I-2,j) segment%grad_gradient(j,2,k) = (((vvel(i,J,k) - vvel(i-1,J,k))*G%IdxBu(I-1,J)) - & - (vvel(i,J-1,k) - vvel(i-1,J-1,k))*G%IdxBu(I-1,J-1)) * G%mask2dCu(I,j) + (vvel(i,J-1,k) - vvel(i-1,J-1,k))*G%IdxBu(I-1,J-1)) * G%mask2dCu(I-1,j) enddo enddo endif @@ -2976,11 +3045,10 @@ subroutine gradient_at_q_points(G, segment, uvel, vvel) if (segment%oblique_grad) then do k=1,G%ke do I=max(segment%HI%isd, G%HI%isd+1),min(segment%HI%ied, G%HI%ied-1) - !### The combination of differences in j and Idx here do not make sense to me. All should be Idy? - segment%grad_gradient(i,1,k) = (((uvel(I,j-1,k) - uvel(I,j-2,k))*G%IdxBu(I,J-2)) - & - (uvel(I-1,j-1,k) - uvel(I-1,j-2,k))*G%IdxBu(I-1,J-2)) * G%mask2dCv(I,j-1) + segment%grad_gradient(i,1,k) = (((uvel(I,j-1,k) - uvel(I,j-2,k))*G%IdyBu(I,J-2)) - & + (uvel(I-1,j-1,k) - uvel(I-1,j-2,k))*G%IdyBu(I-1,J-2)) * G%mask2dCv(i,J-2) segment%grad_gradient(i,2,k) = (((uvel(I,j,k) - uvel(I,j-1,k))*G%IdyBu(I,J-1)) - & - (uvel(I-1,j,k) - uvel(I-1,j-1,k))*G%IdyBu(I-1,J-1)) * G%mask2dCv(i,J) + (uvel(I-1,j,k) - uvel(I-1,j-1,k))*G%IdyBu(I-1,J-1)) * G%mask2dCv(i,J-1) enddo enddo endif @@ -3003,10 +3071,9 @@ subroutine gradient_at_q_points(G, segment, uvel, vvel) if (segment%oblique_grad) then do k=1,G%ke do I=max(segment%HI%isd, G%HI%isd+1),min(segment%HI%ied, G%HI%ied-1) - !### The combination of differences in j and Idx here do not make sense to me. All should be Idy? - segment%grad_gradient(i,1,k) = (((uvel(I,j+3,k) - uvel(I,j+2,k))*G%IdxBu(I,J+2)) - & + segment%grad_gradient(i,1,k) = (((uvel(I,j+3,k) - uvel(I,j+2,k))*G%IdyBu(I,J+2)) - & (uvel(I-1,j+3,k) - uvel(I-1,j+2,k))*G%IdyBu(I-1,J+2)) * G%mask2dCv(i,J+2) - segment%grad_gradient(i,2,k) = (((uvel(I,j+2,k) - uvel(I,j+1,k))*G%IdxBu(I,J+1)) - & + segment%grad_gradient(i,2,k) = (((uvel(I,j+2,k) - uvel(I,j+1,k))*G%IdyBu(I,J+1)) - & (uvel(I-1,j+2,k) - uvel(I-1,j+1,k))*G%IdyBu(I-1,J+1)) * G%mask2dCv(i,J+1) enddo enddo @@ -3125,7 +3192,7 @@ subroutine allocate_OBC_segment_data(OBC, segment) allocate(segment%h(IsdB:IedB,jsd:jed,OBC%ke)); segment%h(:,:,:)=0.0 allocate(segment%eta(IsdB:IedB,jsd:jed)); segment%eta(:,:)=0.0 if (segment%radiation) then - allocate(segment%rx_normal(IsdB:IedB,jsd:jed,OBC%ke)); segment%rx_normal(:,:,:)=0.0 + allocate(segment%rx_norm_rad(IsdB:IedB,jsd:jed,OBC%ke)); segment%rx_norm_rad(:,:,:)=0.0 endif allocate(segment%normal_vel(IsdB:IedB,jsd:jed,OBC%ke)); segment%normal_vel(:,:,:)=0.0 allocate(segment%normal_vel_bt(IsdB:IedB,jsd:jed)); segment%normal_vel_bt(:,:)=0.0 @@ -3149,8 +3216,8 @@ subroutine allocate_OBC_segment_data(OBC, segment) endif if (segment%oblique) then allocate(segment%grad_normal(JsdB:JedB,2,OBC%ke)); segment%grad_normal(:,:,:) = 0.0 - allocate(segment%rx_normal(IsdB:IedB,jsd:jed,OBC%ke)); segment%rx_normal(:,:,:)=0.0 - allocate(segment%ry_normal(IsdB:IedB,jsd:jed,OBC%ke)); segment%ry_normal(:,:,:)=0.0 + allocate(segment%rx_norm_obl(IsdB:IedB,jsd:jed,OBC%ke)); segment%rx_norm_obl(:,:,:)=0.0 + allocate(segment%ry_norm_obl(IsdB:IedB,jsd:jed,OBC%ke)); segment%ry_norm_obl(:,:,:)=0.0 allocate(segment%cff_normal(IsdB:IedB,jsd:jed,OBC%ke)); segment%cff_normal(:,:,:)=0.0 endif if (segment%oblique_tan) then @@ -3168,7 +3235,7 @@ subroutine allocate_OBC_segment_data(OBC, segment) allocate(segment%h(isd:ied,JsdB:JedB,OBC%ke)); segment%h(:,:,:)=0.0 allocate(segment%eta(isd:ied,JsdB:JedB)); segment%eta(:,:)=0.0 if (segment%radiation) then - allocate(segment%ry_normal(isd:ied,JsdB:JedB,OBC%ke)); segment%ry_normal(:,:,:)=0.0 + allocate(segment%ry_norm_rad(isd:ied,JsdB:JedB,OBC%ke)); segment%ry_norm_rad(:,:,:)=0.0 endif allocate(segment%normal_vel(isd:ied,JsdB:JedB,OBC%ke)); segment%normal_vel(:,:,:)=0.0 allocate(segment%normal_vel_bt(isd:ied,JsdB:JedB)); segment%normal_vel_bt(:,:)=0.0 @@ -3192,8 +3259,8 @@ subroutine allocate_OBC_segment_data(OBC, segment) endif if (segment%oblique) then allocate(segment%grad_normal(IsdB:IedB,2,OBC%ke)); segment%grad_normal(:,:,:) = 0.0 - allocate(segment%rx_normal(isd:ied,JsdB:JedB,OBC%ke)); segment%rx_normal(:,:,:)=0.0 - allocate(segment%ry_normal(isd:ied,JsdB:JedB,OBC%ke)); segment%ry_normal(:,:,:)=0.0 + allocate(segment%rx_norm_obl(isd:ied,JsdB:JedB,OBC%ke)); segment%rx_norm_obl(:,:,:)=0.0 + allocate(segment%ry_norm_obl(isd:ied,JsdB:JedB,OBC%ke)); segment%ry_norm_obl(:,:,:)=0.0 allocate(segment%cff_normal(isd:ied,JsdB:JedB,OBC%ke)); segment%cff_normal(:,:,:)=0.0 endif if (segment%oblique_tan) then @@ -3219,8 +3286,10 @@ subroutine deallocate_OBC_segment_data(OBC, segment) if (associated (segment%Htot)) deallocate(segment%Htot) if (associated (segment%h)) deallocate(segment%h) if (associated (segment%eta)) deallocate(segment%eta) - if (associated (segment%rx_normal)) deallocate(segment%rx_normal) - if (associated (segment%ry_normal)) deallocate(segment%ry_normal) + if (associated (segment%rx_norm_rad)) deallocate(segment%rx_norm_rad) + if (associated (segment%ry_norm_rad)) deallocate(segment%ry_norm_rad) + if (associated (segment%rx_norm_obl)) deallocate(segment%rx_norm_obl) + if (associated (segment%ry_norm_obl)) deallocate(segment%ry_norm_obl) if (associated (segment%cff_normal)) deallocate(segment%cff_normal) if (associated (segment%grad_normal)) deallocate(segment%grad_normal) if (associated (segment%grad_tan)) deallocate(segment%grad_tan) @@ -3244,8 +3313,8 @@ end subroutine deallocate_OBC_segment_data subroutine open_boundary_test_extern_uv(G, OBC, u, v) type(ocean_grid_type), intent(in) :: G !< Ocean grid structure type(ocean_OBC_type), pointer :: OBC !< Open boundary structure - real, dimension(SZIB_(G),SZJ_(G), SZK_(G)),intent(inout) :: u !< Zonal velocity [m s-1] - real, dimension(SZI_(G),SZJB_(G), SZK_(G)),intent(inout) :: v !< Meridional velocity [m s-1] + real, dimension(SZIB_(G),SZJ_(G), SZK_(G)),intent(inout) :: u !< Zonal velocity [L T-1 ~> m s-1] + real, dimension(SZI_(G),SZJB_(G), SZK_(G)),intent(inout) :: v !< Meridional velocity [L T-1 ~> m s-1] ! Local variables integer :: i, j, k, n @@ -3284,37 +3353,41 @@ end subroutine open_boundary_test_extern_uv !> Set thicknesses outside of open boundaries to silly values !! (used for checking the interior state is independent of values outside !! of the domain). -subroutine open_boundary_test_extern_h(G, OBC, h) - type(ocean_grid_type), intent(in) :: G !< Ocean grid structure - type(ocean_OBC_type), pointer :: OBC !< Open boundary structure - real, dimension(SZI_(G),SZJ_(G), SZK_(G)),intent(inout) :: h !< Layer thickness [H ~> m or kg m-2] +subroutine open_boundary_test_extern_h(G, GV, OBC, h) + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure + type(ocean_OBC_type), pointer :: OBC !< Open boundary structure + real, dimension(SZI_(G),SZJ_(G), SZK_(GV)),intent(inout) :: h !< Layer thickness [H ~> m or kg m-2] ! Local variables + real :: silly_h ! A silly thickness for testing [H ~> m or kg m-2] integer :: i, j, k, n if (.not. associated(OBC)) return + silly_h = GV%Z_to_H*OBC%silly_h + do n = 1, OBC%number_of_segments - do k = 1, G%ke + do k = 1, GV%ke if (OBC%segment(n)%is_N_or_S) then J = OBC%segment(n)%HI%JsdB if (OBC%segment(n)%direction == OBC_DIRECTION_N) then do i = OBC%segment(n)%HI%isd, OBC%segment(n)%HI%ied - h(i,j+1,k) = OBC%silly_h + h(i,j+1,k) = silly_h enddo else do i = OBC%segment(n)%HI%isd, OBC%segment(n)%HI%ied - h(i,j,k) = OBC%silly_h + h(i,j,k) = silly_h enddo endif elseif (OBC%segment(n)%is_E_or_W) then I = OBC%segment(n)%HI%IsdB if (OBC%segment(n)%direction == OBC_DIRECTION_E) then do j = OBC%segment(n)%HI%jsd, OBC%segment(n)%HI%jed - h(i+1,j,k) = OBC%silly_h + h(i+1,j,k) = silly_h enddo else do j = OBC%segment(n)%HI%jsd, OBC%segment(n)%HI%jed - h(i,j,k) = OBC%silly_h + h(i,j,k) = silly_h enddo endif endif @@ -3388,7 +3461,7 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) if (segment%direction == OBC_DIRECTION_W) ishift=1 I=segment%HI%IsdB do j=segment%HI%jsd,segment%HI%jed - segment%Cg(I,j) = US%L_T_to_m_s*sqrt(GV%g_prime(1)*G%bathyT(i+ishift,j)) + segment%Cg(I,j) = sqrt(GV%g_prime(1)*G%bathyT(i+ishift,j)) segment%Htot(I,j)=0.0 do k=1,G%ke segment%h(I,j,k) = h(i+ishift,j,k) @@ -3401,7 +3474,7 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) if (segment%direction == OBC_DIRECTION_S) jshift=1 J=segment%HI%JsdB do i=segment%HI%isd,segment%HI%ied - segment%Cg(i,J) = US%L_T_to_m_s*sqrt(GV%g_prime(1)*G%bathyT(i,j+jshift)) + segment%Cg(i,J) = sqrt(GV%g_prime(1)*G%bathyT(i,j+jshift)) segment%Htot(i,J)=0.0 do k=1,G%ke segment%h(i,J,k) = h(i,j+jshift,k) @@ -3647,7 +3720,7 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) endif endif else ! 2d data - segment%field(m)%buffer_dst(:,:,1)=segment%field(m)%buffer_src(:,:,1) ! initialize remap destination buffer + segment%field(m)%buffer_dst(:,:,1) = segment%field(m)%buffer_src(:,:,1) ! initialize remap destination buffer endif deallocate(tmp_buffer) else ! fid <= 0 (Uniform value) @@ -3681,9 +3754,9 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) allocate(segment%field(m)%buffer_dst(is_obc+1:ie_obc,js_obc:je_obc,G%ke)) endif endif - segment%field(m)%buffer_dst(:,:,:)=segment%field(m)%value + segment%field(m)%buffer_dst(:,:,:) = segment%field(m)%value if (trim(segment%field(m)%name) == 'U' .or. trim(segment%field(m)%name) == 'V') then - segment%field(m)%bt_vel(:,:)=segment%field(m)%value + segment%field(m)%bt_vel(:,:) = segment%field(m)%value endif endif endif @@ -4355,7 +4428,7 @@ subroutine open_boundary_register_restarts(HI, GV, OBC, Reg, param_file, restart "uninitialized OBC control structure") if (associated(OBC%rx_normal) .or. associated(OBC%ry_normal) .or. & - associated(OBC%cff_normal)) & + associated(OBC%rx_oblique) .or. associated(OBC%ry_oblique) .or. associated(OBC%cff_normal)) & call MOM_error(FATAL, "open_boundary_register_restarts: Restart "//& "arrays were previously allocated") @@ -4367,20 +4440,28 @@ subroutine open_boundary_register_restarts(HI, GV, OBC, Reg, param_file, restart ! This implementation uses 3D arrays solely for restarts. We need ! to be able to add 2D ( x,z or y,z ) data to restarts to avoid using ! so much memory and disk space. *** - if (OBC%radiation_BCs_exist_globally .or. OBC%oblique_BCs_exist_globally) then + if (OBC%radiation_BCs_exist_globally) then allocate(OBC%rx_normal(HI%isdB:HI%iedB,HI%jsd:HI%jed,GV%ke)) OBC%rx_normal(:,:,:) = 0.0 - vd = var_desc("rx_normal","m s-1", "Normal Phase Speed for EW OBCs",'u','L') + vd = var_desc("rx_normal", "m s-1", "Normal Phase Speed for EW radiation OBCs", 'u', 'L') call register_restart_field(OBC%rx_normal, vd, .false., restart_CSp) allocate(OBC%ry_normal(HI%isd:HI%ied,HI%jsdB:HI%jedB,GV%ke)) OBC%ry_normal(:,:,:) = 0.0 - vd = var_desc("ry_normal","m s-1", "Normal Phase Speed for NS OBCs",'v','L') + vd = var_desc("ry_normal", "m s-1", "Normal Phase Speed for NS radiation OBCs", 'v', 'L') call register_restart_field(OBC%ry_normal, vd, .false., restart_CSp) endif if (OBC%oblique_BCs_exist_globally) then + allocate(OBC%rx_oblique(HI%isdB:HI%iedB,HI%jsd:HI%jed,GV%ke)) + OBC%rx_oblique(:,:,:) = 0.0 + vd = var_desc("rx_oblique", "m2 s-2", "Radiation Speed Squared for EW oblique OBCs", 'u', 'L') + call register_restart_field(OBC%rx_oblique, vd, .false., restart_CSp) + allocate(OBC%ry_oblique(HI%isd:HI%ied,HI%jsdB:HI%jedB,GV%ke)) + OBC%ry_oblique(:,:,:) = 0.0 + vd = var_desc("ry_oblique", "m2 s-2", "Radiation Speed Squared for NS oblique OBCs", 'v', 'L') + call register_restart_field(OBC%ry_oblique, vd, .false., restart_CSp) allocate(OBC%cff_normal(HI%IsdB:HI%IedB,HI%jsdB:HI%jedB,GV%ke)) OBC%cff_normal(:,:,:) = 0.0 - vd = var_desc("cff_normal","m s-1", "denominator for oblique OBCs",'q','L') + vd = var_desc("cff_normal", "m2 s-2", "denominator for oblique OBCs", 'q', 'L') call register_restart_field(OBC%cff_normal, vd, .false., restart_CSp) endif @@ -4396,8 +4477,7 @@ subroutine open_boundary_register_restarts(HI, GV, OBC, Reg, param_file, restart ! This would be coming from user code such as DOME. if (OBC%ntr /= Reg%ntr) then ! call MOM_error(FATAL, "open_boundary_regiser_restarts: Inconsistent value for ntr") - write(mesg,'("Inconsisten values for ntr ",'// & - 'I8," and ",I8,".")') OBC%ntr, Reg%ntr + write(mesg,'("Inconsistent values for ntr ", I8," and ",I8,".")') OBC%ntr, Reg%ntr call MOM_error(WARNING, 'open_boundary_register_restarts: '//mesg) endif endif @@ -4439,75 +4519,66 @@ subroutine update_segment_tracer_reservoirs(G, GV, uhr, vhr, h, OBC, dt, Reg) real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< layer thickness after advection !! [H ~> m or kg m-2] type(ocean_OBC_type), pointer :: OBC !< Open boundary structure - real, intent(in) :: dt !< time increment [s] + real, intent(in) :: dt !< time increment [T ~> s] type(tracer_registry_type), pointer :: Reg !< pointer to tracer registry ! Local variables + type(OBC_segment_type), pointer :: segment=>NULL() + real :: u_L_in, u_L_out ! The zonal distance moved in or out of a cell [L ~> m] + real :: v_L_in, v_L_out ! The meridional distance moved in or out of a cell [L ~> m] + real :: fac1 ! The denominator of the expression for tracer updates [nondim] integer :: i, j, k, m, n, ntr, nz integer :: ishift, idir, jshift, jdir - type(OBC_segment_type), pointer :: segment=>NULL() - real :: u_L_in, u_L_out - real :: v_L_in, v_L_out - real :: fac1 nz = GV%ke ntr = Reg%ntr - if (associated(OBC)) then ; if (OBC%OBC_pe) then - do n=1,OBC%number_of_segments - segment=>OBC%segment(n) - if (.not. associated(segment%tr_Reg)) cycle - if (segment%is_E_or_W) then - do j=segment%HI%jsd,segment%HI%jed - I = segment%HI%IsdB - ishift=0 ! ishift+I corresponds to the nearest interior tracer cell index - idir=1 ! idir switches the sign of the flow so that positive is into the reservoir - if (segment%direction == OBC_DIRECTION_W) then - ishift=1 - idir=-1 - endif - ! update the reservoir tracer concentration implicitly - ! using Backward-Euler timestep - do m=1,ntr - if (associated(segment%tr_Reg%Tr(m)%tres)) then - do k=1,nz - u_L_out=max((idir*uhr(I,j,k))*segment%Tr_InvLscale_out/(h(i+ishift,j,k)*G%dyCu(I,j)),0.) - u_L_in=min((idir*uhr(I,j,k))*segment%Tr_InvLscale_in/(h(i+ishift,j,k)*G%dyCu(I,j)),0.) - fac1=1.0+dt*(u_L_out-u_L_in) - segment%tr_Reg%Tr(m)%tres(I,j,k)= (1.0/fac1)*(segment%tr_Reg%Tr(m)%tres(I,j,k) + & - dt*(u_L_out*Reg%Tr(m)%t(I+ishift,j,k) - & - u_L_in*segment%tr_Reg%Tr(m)%t(I,j,k))) - if (associated(OBC%tres_x)) OBC%tres_x(I,j,k,m) = segment%tr_Reg%Tr(m)%tres(I,j,k) - enddo - endif - enddo - enddo - else - do i=segment%HI%isd,segment%HI%ied - J = segment%HI%JsdB - jshift=0 ! jshift+J corresponds to the nearest interior tracer cell index - jdir=1 ! jdir switches the sign of the flow so that positive is into the reservoir - if (segment%direction == OBC_DIRECTION_S) then - jshift=1 - jdir=-1 - endif - ! update the reservoir tracer concentration implicitly - ! using Backward-Euler timestep - do m=1,ntr - if (associated(segment%tr_Reg%Tr(m)%tres)) then - do k=1,nz - v_L_out=max((jdir*vhr(i,J,k))*segment%Tr_InvLscale_out/(h(i,j+jshift,k)*G%dxCv(i,J)),0.) - v_L_in=min((jdir*vhr(i,J,k))*segment%Tr_InvLscale_in/(h(i,j+jshift,k)*G%dxCv(i,J)),0.) - fac1=1.0+dt*(v_L_out-v_L_in) - segment%tr_Reg%Tr(m)%tres(i,J,k)= (1.0/fac1)*(segment%tr_Reg%Tr(m)%tres(i,J,k) + & - dt*(v_L_out*Reg%Tr(m)%t(i,J+jshift,k) - & - v_L_in*segment%tr_Reg%Tr(m)%t(i,J,k))) - if (associated(OBC%tres_y)) OBC%tres_y(i,J,k,m) = segment%tr_Reg%Tr(m)%tres(i,J,k) - enddo - endif - enddo - enddo - endif - enddo - endif; endif + if (associated(OBC)) then ; if (OBC%OBC_pe) then ; do n=1,OBC%number_of_segments + segment=>OBC%segment(n) + if (.not. associated(segment%tr_Reg)) cycle + if (segment%is_E_or_W) then + do j=segment%HI%jsd,segment%HI%jed + I = segment%HI%IsdB + ! ishift+I corresponds to the nearest interior tracer cell index + ! idir switches the sign of the flow so that positive is into the reservoir + if (segment%direction == OBC_DIRECTION_W) then + ishift = 1 ; idir = -1 + else + ishift = 0 ; idir = 1 + endif + ! Update the reservoir tracer concentration implicitly using a Backward-Euler timestep + do m=1,ntr ; if (associated(segment%tr_Reg%Tr(m)%tres)) then ; do k=1,nz + u_L_out = max(0.0, (idir*uhr(I,j,k))*segment%Tr_InvLscale_out / (h(i+ishift,j,k)*G%dyCu(I,j))) + u_L_in = min(0.0, (idir*uhr(I,j,k))*segment%Tr_InvLscale_in / (h(i+ishift,j,k)*G%dyCu(I,j))) + fac1 = 1.0 + (u_L_out-u_L_in) + segment%tr_Reg%Tr(m)%tres(I,j,k) = (1.0/fac1)*(segment%tr_Reg%Tr(m)%tres(I,j,k) + & + (u_L_out*Reg%Tr(m)%t(I+ishift,j,k) - & + u_L_in*segment%tr_Reg%Tr(m)%t(I,j,k))) + if (associated(OBC%tres_x)) OBC%tres_x(I,j,k,m) = segment%tr_Reg%Tr(m)%tres(I,j,k) + enddo ; endif ; enddo + enddo + else + do i=segment%HI%isd,segment%HI%ied + J = segment%HI%JsdB + ! jshift+J corresponds to the nearest interior tracer cell index + ! jdir switches the sign of the flow so that positive is into the reservoir + if (segment%direction == OBC_DIRECTION_S) then + jshift = 1 ; jdir = -1 + else + jshift = 0 ; jdir = 1 + endif + ! Update the reservoir tracer concentration implicitly using a Backward-Euler timestep + do m=1,ntr ; if (associated(segment%tr_Reg%Tr(m)%tres)) then ; do k=1,nz + v_L_out = max(0.0, (jdir*vhr(i,J,k))*segment%Tr_InvLscale_out / (h(i,j+jshift,k)*G%dxCv(i,J))) + v_L_in = min(0.0, (jdir*vhr(i,J,k))*segment%Tr_InvLscale_in / (h(i,j+jshift,k)*G%dxCv(i,J))) + fac1 = 1.0 + (v_L_out-v_L_in) + segment%tr_Reg%Tr(m)%tres(i,J,k) = (1.0/fac1)*(segment%tr_Reg%Tr(m)%tres(i,J,k) + & + (v_L_out*Reg%Tr(m)%t(i,J+jshift,k) - & + v_L_in*segment%tr_Reg%Tr(m)%t(i,J,k))) + if (associated(OBC%tres_y)) OBC%tres_y(i,J,k,m) = segment%tr_Reg%Tr(m)%tres(i,J,k) + enddo ; endif ; enddo + enddo + endif + enddo ; endif ; endif + end subroutine update_segment_tracer_reservoirs !> Adjust interface heights to fit the bathymetry and diagnose layer thickness. diff --git a/src/core/MOM_variables.F90 b/src/core/MOM_variables.F90 index 586419f19e..5dfa91fee2 100644 --- a/src/core/MOM_variables.F90 +++ b/src/core/MOM_variables.F90 @@ -164,10 +164,10 @@ module MOM_variables dv_dt_dia => NULL() !< Meridional acceleration due to diapycnal mixing [L T-2 ~> m s-2] real, pointer, dimension(:,:,:) :: du_other => NULL() !< Zonal velocity changes due to any other processes that are - !! not due to any explicit accelerations [m s-1]. + !! not due to any explicit accelerations [L T-1 ~> m s-1]. real, pointer, dimension(:,:,:) :: dv_other => NULL() - !< Meridional velocity changes due to any other processes that are - !! not due to any explicit accelerations [m s-1]. + !< Meridional velocity changes due to any other processes that are + !! not due to any explicit accelerations [L T-1 ~> m s-1]. ! These accelerations are sub-terms included in the accelerations above. real, pointer :: gradKEu(:,:,:) => NULL() !< gradKEu = - d/dx(u2) [L T-2 ~> m s-2] diff --git a/src/diagnostics/MOM_PointAccel.F90 b/src/diagnostics/MOM_PointAccel.F90 index dd72378671..4ad1b67314 100644 --- a/src/diagnostics/MOM_PointAccel.F90 +++ b/src/diagnostics/MOM_PointAccel.F90 @@ -58,7 +58,6 @@ module MOM_PointAccel real, pointer, dimension(:,:,:) :: pbce => NULL() !< pbce times eta gives the baroclinic !! pressure anomaly in each layer due to free surface height anomalies !! [m2 s-2 H-1 ~> m s-2 or m4 kg-1 s-2]. - real :: u_av_scale !< A scaling factor to convert u_av to m s-1. end type PointAccel_CS contains @@ -108,7 +107,7 @@ subroutine write_u_accel(I, j, um, hin, ADp, CDp, dt_in_T, G, GV, US, CS, vel_rp Angstrom = GV%Angstrom_H + GV%H_subroundoff dt = US%T_to_s*dt_in_T - h_scale = GV%H_to_m ; uh_scale = GV%H_to_m + h_scale = GV%H_to_m ; uh_scale = GV%H_to_m*US%L_T_to_m_s ! if (.not.associated(CS)) return nz = G%ke @@ -134,14 +133,14 @@ subroutine write_u_accel(I, j, um, hin, ADp, CDp, dt_in_T, G, GV, US, CS, vel_rp ! Determine which layers to write out accelerations for. do k=1,nz - if (((max(US%m_s_to_L_T*CS%u_av_scale*CS%u_av(I,j,k),um(I,j,k)) >= vel_rpt) .or. & - (min(US%m_s_to_L_T*CS%u_av_scale*CS%u_av(I,j,k),um(I,j,k)) <= -vel_rpt)) .and. & + if (((max(CS%u_av(I,j,k),um(I,j,k)) >= vel_rpt) .or. & + (min(CS%u_av(I,j,k),um(I,j,k)) <= -vel_rpt)) .and. & ((hin(i,j,k) + hin(i+1,j,k)) > 3.0*Angstrom)) exit enddo ks = k do k=nz,1,-1 - if (((max(US%m_s_to_L_T*CS%u_av_scale*CS%u_av(I,j,k), um(I,j,k)) >= vel_rpt) .or. & - (min(US%m_s_to_L_T*CS%u_av_scale*CS%u_av(I,j,k), um(I,j,k)) <= -vel_rpt)) .and. & + if (((max(CS%u_av(I,j,k), um(I,j,k)) >= vel_rpt) .or. & + (min(CS%u_av(I,j,k), um(I,j,k)) <= -vel_rpt)) .and. & ((hin(i,j,k) + hin(i+1,j,k)) > 3.0*Angstrom)) exit enddo ke = k @@ -171,7 +170,7 @@ subroutine write_u_accel(I, j, um, hin, ADp, CDp, dt_in_T, G, GV, US, CS, vel_rp do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') (US%L_T_to_m_s*CS%u_prev(I,j,k)); enddo endif write(file,'(/,"u(3): ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') (CS%u_av_scale*CS%u_av(I,j,k)); enddo + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') (US%L_T_to_m_s*CS%u_av(I,j,k)); enddo write(file,'(/,"CFL u: ",$)') do k=ks,ke ; if (do_k(k)) then @@ -217,7 +216,7 @@ subroutine write_u_accel(I, j, um, hin, ADp, CDp, dt_in_T, G, GV, US, CS, vel_rp if (associated(ADp%du_other)) then write(file,'(/,"du_other: ",$)') do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & - (ADp%du_other(I,j,k)); enddo + (US%L_T_to_m_s*ADp%du_other(I,j,k)); enddo endif if (present(a)) then write(file,'(/,"a: ",$)') @@ -287,10 +286,10 @@ subroutine write_u_accel(I, j, um, hin, ADp, CDp, dt_in_T, G, GV, US, CS, vel_rp write(file,'(/,"vh--: ",$)') do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & - (uh_scale*US%m_to_L*CDp%vh(i,J-1,k)*G%IdxCv(i,J-1)); enddo + (uh_scale*CDp%vh(i,J-1,k)*G%IdxCv(i,J-1)); enddo write(file,'(/," vhC--:",$)') do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & - (0.5*CS%u_av_scale*CS%v_av(i,j-1,k)*h_scale*(hin(i,j-1,k) + hin(i,j,k))); enddo + (0.5*US%L_T_to_m_s*CS%v_av(i,j-1,k)*h_scale*(hin(i,j-1,k) + hin(i,j,k))); enddo if (prev_avail) then write(file,'(/," vhCp--:",$)') do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & @@ -299,10 +298,10 @@ subroutine write_u_accel(I, j, um, hin, ADp, CDp, dt_in_T, G, GV, US, CS, vel_rp write(file,'(/,"vh-+: ",$)') do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & - (uh_scale*US%m_to_L*CDp%vh(i,J,k)*G%IdxCv(i,J)); enddo + (uh_scale*CDp%vh(i,J,k)*G%IdxCv(i,J)); enddo write(file,'(/," vhC-+:",$)') do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & - (0.5*CS%u_av_scale*CS%v_av(i,J,k)*h_scale*(hin(i,j,k) + hin(i,j+1,k))); enddo + (0.5*US%L_T_to_m_s*CS%v_av(i,J,k)*h_scale*(hin(i,j,k) + hin(i,j+1,k))); enddo if (prev_avail) then write(file,'(/," vhCp-+:",$)') do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & @@ -311,10 +310,10 @@ subroutine write_u_accel(I, j, um, hin, ADp, CDp, dt_in_T, G, GV, US, CS, vel_rp write(file,'(/,"vh+-: ",$)') do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & - (uh_scale*US%m_to_L*CDp%vh(i+1,J-1,k)*G%IdxCv(i+1,J-1)); enddo + (uh_scale*CDp%vh(i+1,J-1,k)*G%IdxCv(i+1,J-1)); enddo write(file,'(/," vhC+-:",$)') do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & - (0.5*CS%u_av_scale*CS%v_av(i+1,J-1,k)*h_scale*(hin(i+1,j-1,k) + hin(i+1,j,k))); enddo + (0.5*US%L_T_to_m_s*CS%v_av(i+1,J-1,k)*h_scale*(hin(i+1,j-1,k) + hin(i+1,j,k))); enddo if (prev_avail) then write(file,'(/," vhCp+-:",$)') do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & @@ -323,14 +322,14 @@ subroutine write_u_accel(I, j, um, hin, ADp, CDp, dt_in_T, G, GV, US, CS, vel_rp write(file,'(/,"vh++: ",$)') do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & - (uh_scale*US%m_to_L*CDp%vh(i+1,J,k)*G%IdxCv(i+1,J)); enddo + (uh_scale*CDp%vh(i+1,J,k)*G%IdxCv(i+1,J)); enddo write(file,'(/," vhC++:",$)') do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & - (0.5*CS%u_av_scale*CS%v_av(i+1,J,k)*h_scale*(hin(i+1,j,k) + hin(i+1,j+1,k))); enddo + (0.5*US%L_T_to_m_s*CS%v_av(i+1,J,k)*h_scale*(hin(i+1,j,k) + hin(i+1,j+1,k))); enddo if (prev_avail) then write(file,'(/," vhCp++:",$)') do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & - (0.5*CS%u_av_scale*CS%v_av(i+1,J,k)*h_scale*(hin(i+1,j,k) + hin(i+1,j+1,k))); enddo + (0.5*US%L_T_to_m_s*CS%v_av(i+1,J,k)*h_scale*(hin(i+1,j,k) + hin(i+1,j+1,k))); enddo endif write(file,'(/,"D: ",2(ES10.3))') US%Z_to_m*G%bathyT(i,j),US%Z_to_m*G%bathyT(i+1,j) @@ -380,7 +379,7 @@ subroutine write_u_accel(I, j, um, hin, ADp, CDp, dt_in_T, G, GV, US, CS, vel_rp if (associated(ADp%du_other)) then write(file,'(/,"du_other: ",$)') do k=ks,ke ; if (do_k(k)) write(file,'(F10.6," ",$)') & - (ADp%du_other(I,j,k))*Inorm(k); enddo + (US%L_T_to_m_s*ADp%du_other(I,j,k))*Inorm(k); enddo endif if (associated(CS%u_accel_bt)) then write(file,'(/,"dubt: ",$)') @@ -441,7 +440,7 @@ subroutine write_v_accel(i, J, vm, hin, ADp, CDp, dt_in_T, G, GV, US, CS, vel_rp Angstrom = GV%Angstrom_H + GV%H_subroundoff dt = US%T_to_s*dt_in_T - h_scale = GV%H_to_m ; uh_scale = GV%H_to_m + h_scale = GV%H_to_m ; uh_scale = GV%H_to_m*US%L_T_to_m_s ! if (.not.associated(CS)) return nz = G%ke @@ -466,14 +465,14 @@ subroutine write_v_accel(i, J, vm, hin, ADp, CDp, dt_in_T, G, GV, US, CS, vel_rp prev_avail = (associated(CS%u_prev) .and. associated(CS%v_prev)) do k=1,nz - if (((max(US%m_s_to_L_T*CS%u_av_scale*CS%v_av(i,J,k), US%L_T_to_m_s*vm(i,J,k)) >= vel_rpt) .or. & - (min(US%m_s_to_L_T*CS%u_av_scale*CS%v_av(i,J,k), US%L_T_to_m_s*vm(i,J,k)) <= -vel_rpt)) .and. & + if (((max(CS%v_av(i,J,k), vm(i,J,k)) >= vel_rpt) .or. & + (min(CS%v_av(i,J,k), vm(i,J,k)) <= -vel_rpt)) .and. & ((hin(i,j,k) + hin(i,j+1,k)) > 3.0*Angstrom)) exit enddo ks = k do k=nz,1,-1 - if (((max(US%m_s_to_L_T*CS%u_av_scale*CS%v_av(i,J,k), US%L_T_to_m_s*vm(i,J,k)) >= vel_rpt) .or. & - (min(US%m_s_to_L_T*CS%u_av_scale*CS%v_av(i,J,k), US%L_T_to_m_s*vm(i,J,k)) <= -vel_rpt)) .and. & + if (((max(CS%v_av(i,J,k), vm(i,J,k)) >= vel_rpt) .or. & + (min(CS%v_av(i,J,k), vm(i,J,k)) <= -vel_rpt)) .and. & ((hin(i,j,k) + hin(i,j+1,k)) > 3.0*Angstrom)) exit enddo ke = k @@ -505,7 +504,7 @@ subroutine write_v_accel(i, J, vm, hin, ADp, CDp, dt_in_T, G, GV, US, CS, vel_rp endif write(file,'(/,"v(3): ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') (CS%u_av_scale*CS%v_av(i,J,k)); enddo + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') (US%L_T_to_m_s*CS%v_av(i,J,k)); enddo write(file,'(/,"CFL v: ",$)') do k=ks,ke ; if (do_k(k)) then CFL = abs(vm(i,J,k)) * US%s_to_T*dt * G%dx_Cv(i,J) @@ -554,7 +553,7 @@ subroutine write_v_accel(i, J, vm, hin, ADp, CDp, dt_in_T, G, GV, US, CS, vel_rp if (associated(ADp%dv_other)) then write(file,'(/,"dv_other: ",$)') do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & - (ADp%dv_other(i,J,k)); enddo + (US%L_T_to_m_s*ADp%dv_other(i,J,k)); enddo endif if (present(a)) then write(file,'(/,"a: ",$)') @@ -623,10 +622,10 @@ subroutine write_v_accel(i, J, vm, hin, ADp, CDp, dt_in_T, G, GV, US, CS, vel_rp write(file,'(/,"uh--: ",$)') do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & - (uh_scale*US%m_to_L*CDp%uh(I-1,j,k)*G%IdyCu(I-1,j)); enddo + (uh_scale*CDp%uh(I-1,j,k)*G%IdyCu(I-1,j)); enddo write(file,'(/," uhC--: ",$)') do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & - (CS%u_av_scale*CS%u_av(I-1,j,k) * h_scale*0.5*(hin(i-1,j,k) + hin(i,j,k))); enddo + (US%L_T_to_m_s*CS%u_av(I-1,j,k) * h_scale*0.5*(hin(i-1,j,k) + hin(i,j,k))); enddo if (prev_avail) then write(file,'(/," uhCp--:",$)') do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & @@ -635,10 +634,10 @@ subroutine write_v_accel(i, J, vm, hin, ADp, CDp, dt_in_T, G, GV, US, CS, vel_rp write(file,'(/,"uh-+: ",$)') do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & - (uh_scale*US%m_to_L*CDp%uh(I-1,j+1,k)*G%IdyCu(I-1,j+1)); enddo + (uh_scale*CDp%uh(I-1,j+1,k)*G%IdyCu(I-1,j+1)); enddo write(file,'(/," uhC-+: ",$)') do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & - (CS%u_av_scale*CS%u_av(I-1,j+1,k) * h_scale*0.5*(hin(i-1,j+1,k) + hin(i,j+1,k))); enddo + (US%L_T_to_m_s*CS%u_av(I-1,j+1,k) * h_scale*0.5*(hin(i-1,j+1,k) + hin(i,j+1,k))); enddo if (prev_avail) then write(file,'(/," uhCp-+:",$)') do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & @@ -647,10 +646,10 @@ subroutine write_v_accel(i, J, vm, hin, ADp, CDp, dt_in_T, G, GV, US, CS, vel_rp write(file,'(/,"uh+-: ",$)') do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & - (uh_scale*US%m_to_L*CDp%uh(I,j,k)*G%IdyCu(I,j)); enddo + (uh_scale*CDp%uh(I,j,k)*G%IdyCu(I,j)); enddo write(file,'(/," uhC+-: ",$)') do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & - (CS%u_av_scale*CS%u_av(I,j,k) * h_scale*0.5*(hin(i,j,k) + hin(i+1,j,k))); enddo + (US%L_T_to_m_s*CS%u_av(I,j,k) * h_scale*0.5*(hin(i,j,k) + hin(i+1,j,k))); enddo if (prev_avail) then write(file,'(/," uhCp+-:",$)') do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & @@ -659,10 +658,10 @@ subroutine write_v_accel(i, J, vm, hin, ADp, CDp, dt_in_T, G, GV, US, CS, vel_rp write(file,'(/,"uh++: ",$)') do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & - (uh_scale*US%m_to_L*CDp%uh(I,j+1,k)*G%IdyCu(I,j+1)); enddo + (uh_scale*CDp%uh(I,j+1,k)*G%IdyCu(I,j+1)); enddo write(file,'(/," uhC++: ",$)') do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & - (CS%u_av_scale*CS%u_av(I,j+1,k) * 0.5*h_scale*(hin(i,j+1,k) + hin(i+1,j+1,k))); enddo + (US%L_T_to_m_s*CS%u_av(I,j+1,k) * 0.5*h_scale*(hin(i,j+1,k) + hin(i+1,j+1,k))); enddo if (prev_avail) then write(file,'(/," uhCp++:",$)') do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & @@ -712,7 +711,7 @@ subroutine write_v_accel(i, J, vm, hin, ADp, CDp, dt_in_T, G, GV, US, CS, vel_rp if (associated(ADp%dv_other)) then write(file,'(/,"dv_other: ",$)') do k=ks,ke ; if (do_k(k)) write(file,'(F10.6," ",$)') & - (ADp%dv_other(i,J,k)*Inorm(k)); enddo + (US%L_T_to_m_s*ADp%dv_other(i,J,k)*Inorm(k)); enddo endif if (associated(CS%v_accel_bt)) then write(file,'(/,"dvbt: ",$)') @@ -759,9 +758,6 @@ subroutine PointAccel_init(MIS, Time, G, param_file, diag, dirs, CS) CS%u_av => MIS%u_av; if (.not.associated(MIS%u_av)) CS%u_av => MIS%u(:,:,:) CS%v_av => MIS%v_av; if (.not.associated(MIS%v_av)) CS%v_av => MIS%v(:,:,:) -! CS%u_av_scale = G%US%L_T_to_m_s ; if (.not.associated(MIS%u_av)) CS%u_av_scale = 1.0 - CS%u_av_scale = 1.0 - ! Read all relevant parameters and write them to the model log. call log_version(param_file, mdl, version, "") call get_param(param_file, mdl, "U_TRUNC_FILE", CS%u_trunc_file, & diff --git a/src/diagnostics/MOM_diagnostics.F90 b/src/diagnostics/MOM_diagnostics.F90 index d4fa0a59c8..95c3ad6916 100644 --- a/src/diagnostics/MOM_diagnostics.F90 +++ b/src/diagnostics/MOM_diagnostics.F90 @@ -52,7 +52,7 @@ module MOM_diagnostics !! monotonic for the purposes of calculating the equivalent !! barotropic wave speed. real :: mono_N2_depth = -1. !< The depth below which N2 is limited as monotonic for the purposes of - !! calculating the equivalent barotropic wave speed [m]. + !! calculating the equivalent barotropic wave speed [Z ~> m]. type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to !! regulate the timing of diagnostic output. @@ -84,11 +84,11 @@ module MOM_diagnostics ! following fields are 2-D. real, pointer, dimension(:,:) :: & - cg1 => NULL(), & !< First baroclinic gravity wave speed [m s-1] - Rd1 => NULL(), & !< First baroclinic deformation radius [m] - cfl_cg1 => NULL(), & !< CFL for first baroclinic gravity wave speed, nondim - cfl_cg1_x => NULL(), & !< i-component of CFL for first baroclinic gravity wave speed, nondim - cfl_cg1_y => NULL() !< j-component of CFL for first baroclinic gravity wave speed, nondim + cg1 => NULL(), & !< First baroclinic gravity wave speed [L T-1 ~> m s-1] + Rd1 => NULL(), & !< First baroclinic deformation radius [L ~> m] + cfl_cg1 => NULL(), & !< CFL for first baroclinic gravity wave speed [nondim] + cfl_cg1_x => NULL(), & !< i-component of CFL for first baroclinic gravity wave speed [nondim] + cfl_cg1_y => NULL() !< j-component of CFL for first baroclinic gravity wave speed [nondim] ! The following arrays hold diagnostics in the layer-integrated energy budget. real, pointer, dimension(:,:,:) :: & @@ -219,29 +219,22 @@ subroutine calculate_diagnostic_fields(u, v, h, uh, vh, tv, ADp, CDp, p_surf, & !! variable that gives the "correct" free surface height (Boussinesq) or total water column !! mass per unit area (non-Boussinesq). This is used to dilate the layer thicknesses when !! calculating interface heights [H ~> m or kg m-2]. + ! Local variables integer i, j, k, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz, nkmb - ! coordinate variable potential density [R ~> kg m-3]. - real :: Rcv(SZI_(G),SZJ_(G),SZK_(G)) - ! Two temporary work arrays - real :: work_3d(SZI_(G),SZJ_(G),SZK_(G)) - real :: work_2d(SZI_(G),SZJ_(G)) + real :: Rcv(SZI_(G),SZJ_(G),SZK_(G)) ! Coordinate variable potential density [R ~> kg m-3]. + real :: work_3d(SZI_(G),SZJ_(G),SZK_(G)) ! A 3-d temporary work array. + real :: work_2d(SZI_(G),SZJ_(G)) ! A 2-d temporary work array. ! tmp array for surface properties real :: surface_field(SZI_(G),SZJ_(G)) real :: pressure_1d(SZI_(G)) ! Temporary array for pressure when calling EOS real :: wt, wt_p - ! squared Coriolis parameter at to h-points [s-2] - real :: f2_h - - ! magnitude of the gradient of f [s-1 m-1] - real :: mag_beta - - ! frequency squared used to avoid division by 0 [s-2] - ! value is roughly (pi / (the age of the universe) )^2. - real, parameter :: absurdly_small_freq2 = 1e-34 + real :: f2_h ! Squared Coriolis parameter at to h-points [T-2 ~> s-2] + real :: mag_beta ! Magnitude of the gradient of f [T-1 L-1 ~> s-1 m-1] + real :: absurdly_small_freq2 ! Srequency squared used to avoid division by 0 [T-2 ~> s-2] integer :: k_list @@ -252,6 +245,9 @@ subroutine calculate_diagnostic_fields(u, v, h, uh, vh, tv, ADp, CDp, p_surf, & Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB nz = G%ke ; nkmb = GV%nk_rho_varies + ! This value is roughly (pi / (the age of the universe) )^2. + absurdly_small_freq2 = 1e-34*US%T_to_s**2 + if (loc(CS)==0) call MOM_error(FATAL, & "calculate_diagnostic_fields: Module must be initialized before used.") @@ -317,7 +313,7 @@ subroutine calculate_diagnostic_fields(u, v, h, uh, vh, tv, ADp, CDp, p_surf, & call post_data(CS%id_masscello, work_3d, CS%diag) endif - ! mass of liquid ocean (for Bouss, use Rho0) + ! mass of liquid ocean (for Bouss, use Rho0). The reproducing sum requires the use of MKS units. if (CS%id_masso > 0) then work_2d(:,:) = 0.0 do k=1,nz ; do j=js,je ; do i=is,ie @@ -623,14 +619,13 @@ subroutine calculate_diagnostic_fields(u, v, h, uh, vh, tv, ADp, CDp, p_surf, & call wave_speed(h, tv, G, GV, US, CS%cg1, CS%wave_speed_CSp) if (CS%id_cg1>0) call post_data(CS%id_cg1, CS%cg1, CS%diag) if (CS%id_Rd1>0) then -!$OMP parallel do default(none) shared(is,ie,js,je,G,CS,US) & -!$OMP private(f2_h,mag_beta) + !$OMP parallel do default(shared) private(f2_h,mag_beta) do j=js,je ; do i=is,ie ! Blend the equatorial deformation radius with the standard one. - f2_h = absurdly_small_freq2 + 0.25 * US%s_to_T**2 * & + f2_h = absurdly_small_freq2 + 0.25 * & ((G%CoriolisBu(I,J)**2 + G%CoriolisBu(I-1,J-1)**2) + & (G%CoriolisBu(I-1,J)**2 + G%CoriolisBu(I,J-1)**2)) - mag_beta = US%s_to_T*US%m_to_L * sqrt(0.5 * ( & + mag_beta = sqrt(0.5 * ( & (((G%CoriolisBu(I,J)-G%CoriolisBu(I-1,J)) * G%IdxCv(i,J))**2 + & ((G%CoriolisBu(I,J-1)-G%CoriolisBu(I-1,J-1)) * G%IdxCv(i,J-1))**2) + & (((G%CoriolisBu(I,J)-G%CoriolisBu(I,J-1)) * G%IdyCu(I,j))**2 + & @@ -642,19 +637,19 @@ subroutine calculate_diagnostic_fields(u, v, h, uh, vh, tv, ADp, CDp, p_surf, & endif if (CS%id_cfl_cg1>0) then do j=js,je ; do i=is,ie - CS%cfl_cg1(i,j) = (dt*US%m_s_to_L_T*CS%cg1(i,j)) * (G%IdxT(i,j) + G%IdyT(i,j)) + CS%cfl_cg1(i,j) = (dt*CS%cg1(i,j)) * (G%IdxT(i,j) + G%IdyT(i,j)) enddo ; enddo call post_data(CS%id_cfl_cg1, CS%cfl_cg1, CS%diag) endif if (CS%id_cfl_cg1_x>0) then do j=js,je ; do i=is,ie - CS%cfl_cg1_x(i,j) = (dt*US%m_s_to_L_T*CS%cg1(i,j)) * G%IdxT(i,j) + CS%cfl_cg1_x(i,j) = (dt*CS%cg1(i,j)) * G%IdxT(i,j) enddo ; enddo call post_data(CS%id_cfl_cg1_x, CS%cfl_cg1_x, CS%diag) endif if (CS%id_cfl_cg1_y>0) then do j=js,je ; do i=is,ie - CS%cfl_cg1_y(i,j) = (dt*US%m_s_to_L_T*CS%cg1(i,j)) * G%IdyT(i,j) + CS%cfl_cg1_y(i,j) = (dt*CS%cg1(i,j)) * G%IdyT(i,j) enddo ; enddo call post_data(CS%id_cfl_cg1_y, CS%cfl_cg1_y, CS%diag) endif @@ -672,14 +667,13 @@ subroutine calculate_diagnostic_fields(u, v, h, uh, vh, tv, ADp, CDp, p_surf, & endif if (CS%id_cg_ebt>0) call post_data(CS%id_cg_ebt, CS%cg1, CS%diag) if (CS%id_Rd_ebt>0) then -!$OMP parallel do default(none) shared(is,ie,js,je,G,CS,US) & -!$OMP private(f2_h,mag_beta) + !$OMP parallel do default(shared) private(f2_h,mag_beta) do j=js,je ; do i=is,ie ! Blend the equatorial deformation radius with the standard one. - f2_h = absurdly_small_freq2 + 0.25 * US%s_to_T**2 * & + f2_h = absurdly_small_freq2 + 0.25 * & ((G%CoriolisBu(I,J)**2 + G%CoriolisBu(I-1,J-1)**2) + & (G%CoriolisBu(I-1,J)**2 + G%CoriolisBu(I,J-1)**2)) - mag_beta = US%s_to_T*US%m_to_L * sqrt(0.5 * ( & + mag_beta = sqrt(0.5 * ( & (((G%CoriolisBu(I,J)-G%CoriolisBu(I-1,J)) * G%IdxCv(i,J))**2 + & ((G%CoriolisBu(I,J-1)-G%CoriolisBu(I-1,J-1)) * G%IdxCv(i,J-1))**2) + & (((G%CoriolisBu(I,J)-G%CoriolisBu(I,J-1)) * G%IdyCu(I,j))**2 + & @@ -699,8 +693,8 @@ end subroutine calculate_diagnostic_fields !! weights that should be assigned to elements k and k+1. subroutine find_weights(Rlist, R_in, k, nz, wt, wt_p) real, dimension(:), & - intent(in) :: Rlist !< The list of target densities [kg m-3] - real, intent(in) :: R_in !< The density being inserted into Rlist [kg m-3] + intent(in) :: Rlist !< The list of target densities [R ~> kg m-3] + real, intent(in) :: R_in !< The density being inserted into Rlist [R ~> kg m-3] integer, intent(inout) :: k !< The value of k such that Rlist(k) <= R_in < Rlist(k+1) !! The input value is a first guess integer, intent(in) :: nz !< The number of layers in Rlist @@ -1365,7 +1359,7 @@ subroutine post_transport_diagnostics(G, GV, US, uhtr, vhtr, h, IDs, diag_pre_dy ! [H s-1 ~> m s-1 or kg m-2 s-1]. real :: Idt ! The inverse of the time interval [T-1 ~> s-1] real :: H_to_kg_m2_dt ! A conversion factor from accumulated transports to fluxes - ! [kg L-2 H-1 s-1 ~> kg m-3 s-1 or s-1]. + ! [kg L-2 H-1 T-1 ~> kg m-3 s-1 or s-1]. integer :: i, j, k, is, ie, js, je, nz is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke @@ -1481,7 +1475,7 @@ subroutine MOM_diagnostics_init(MIS, ADp, CDp, Time, G, GV, US, param_file, diag call get_param(param_file, mdl, "DIAG_EBT_MONO_N2_DEPTH", CS%mono_N2_depth, & "The depth below which N2 is limited as monotonic for the "// & "purposes of calculating the equivalent barotropic wave speed.", & - units='m', default=-1.) + units='m', scale=US%m_to_Z, default=-1.) if (GV%Boussinesq) then thickness_units = "m" ; flux_units = "m3 s-1" ; convert_H = GV%H_to_m @@ -1673,9 +1667,9 @@ subroutine MOM_diagnostics_init(MIS, ADp, CDp, Time, G, GV, US, param_file, diag ! gravity wave CFLs CS%id_cg1 = register_diag_field('ocean_model', 'cg1', diag%axesT1, Time, & - 'First baroclinic gravity wave speed', 'm s-1') + 'First baroclinic gravity wave speed', 'm s-1', conversion=US%L_T_to_m_s) CS%id_Rd1 = register_diag_field('ocean_model', 'Rd1', diag%axesT1, Time, & - 'First baroclinic deformation radius', 'm') + 'First baroclinic deformation radius', 'm', conversion=US%L_to_m) CS%id_cfl_cg1 = register_diag_field('ocean_model', 'CFL_cg1', diag%axesT1, Time, & 'CFL of first baroclinic gravity wave = dt*cg1*(1/dx+1/dy)', 'nondim') CS%id_cfl_cg1_x = register_diag_field('ocean_model', 'CFL_cg1_x', diag%axesT1, Time, & @@ -1683,9 +1677,9 @@ subroutine MOM_diagnostics_init(MIS, ADp, CDp, Time, G, GV, US, param_file, diag CS%id_cfl_cg1_y = register_diag_field('ocean_model', 'CFL_cg1_y', diag%axesT1, Time, & 'j-component of CFL of first baroclinic gravity wave = dt*cg1*/dy', 'nondim') CS%id_cg_ebt = register_diag_field('ocean_model', 'cg_ebt', diag%axesT1, Time, & - 'Equivalent barotropic gravity wave speed', 'm s-1') + 'Equivalent barotropic gravity wave speed', 'm s-1', conversion=US%L_T_to_m_s) CS%id_Rd_ebt = register_diag_field('ocean_model', 'Rd_ebt', diag%axesT1, Time, & - 'Equivalent barotropic deformation radius', 'm') + 'Equivalent barotropic deformation radius', 'm', conversion=US%L_to_m) CS%id_p_ebt = register_diag_field('ocean_model', 'p_ebt', diag%axesTL, Time, & 'Equivalent barotropic modal strcuture', 'nondim') @@ -1865,6 +1859,7 @@ subroutine write_static_fields(G, GV, US, tv, diag) ! Local variables integer :: id + logical :: use_temperature id = register_static_field('ocean_model', 'geolat', diag%axesT1, & 'Latitude of tracer (T) points', 'degrees_north') @@ -2017,11 +2012,14 @@ subroutine write_static_fields(G, GV, US, tv, diag) cmor_long_name='reference sea water density for boussinesq approximation') if (id > 0) call post_data(id, GV%Rho0, diag, .true.) - id = register_static_field('ocean_model','C_p', diag%axesNull, & - 'heat capacity of sea water', 'J kg-1 K-1', cmor_field_name='cpocean', & - cmor_standard_name='specific_heat_capacity_of_sea_water', & - cmor_long_name='specific_heat_capacity_of_sea_water') - if (id > 0) call post_data(id, tv%C_p, diag, .true.) + use_temperature = associated(tv%T) + if (use_temperature) then + id = register_static_field('ocean_model','C_p', diag%axesNull, & + 'heat capacity of sea water', 'J kg-1 K-1', cmor_field_name='cpocean', & + cmor_standard_name='specific_heat_capacity_of_sea_water', & + cmor_long_name='specific_heat_capacity_of_sea_water') + if (id > 0) call post_data(id, tv%C_p, diag, .true.) + endif end subroutine write_static_fields diff --git a/src/diagnostics/MOM_wave_speed.F90 b/src/diagnostics/MOM_wave_speed.F90 index c5915dae67..eb11a2b5e9 100644 --- a/src/diagnostics/MOM_wave_speed.F90 +++ b/src/diagnostics/MOM_wave_speed.F90 @@ -54,7 +54,7 @@ subroutine wave_speed(h, tv, G, GV, US, cg1, CS, full_halos, use_ebt_mode, & real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & intent(in) :: h !< Layer thickness [H ~> m or kg m-2] type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamic variables - real, dimension(SZI_(G),SZJ_(G)), intent(out) :: cg1 !< First mode internal wave speed [m s-1] + real, dimension(SZI_(G),SZJ_(G)), intent(out) :: cg1 !< First mode internal wave speed [L T-1 ~> m s-1] type(wave_speed_CS), pointer :: CS !< Control structure for MOM_wave_speed logical, optional, intent(in) :: full_halos !< If true, do the calculation !! over the entire computational domain. @@ -65,7 +65,7 @@ subroutine wave_speed(h, tv, G, GV, US, cg1, CS, full_halos, use_ebt_mode, & !! for the purposes of calculating vertical modal structure. real, optional, intent(in) :: mono_N2_depth !< A depth below which N2 is limited as !! monotonic for the purposes of calculating vertical - !! modal structure [m]. + !! modal structure [Z ~> m]. real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & optional, intent(out) :: modal_structure !< Normalized model structure [nondim] @@ -76,11 +76,11 @@ subroutine wave_speed(h, tv, G, GV, US, cg1, CS, full_halos, use_ebt_mode, & pres, & ! Interface pressure [Pa] T_int, & ! Temperature interpolated to interfaces [degC] S_int, & ! Salinity interpolated to interfaces [ppt] - gprime ! The reduced gravity across each interface [m2 Z-1 s-2 ~> m s-2]. + gprime ! The reduced gravity across each interface [L2 Z-1 T-2 ~> m s-2]. real, dimension(SZK_(G)) :: & Igl, Igu, Igd ! The inverse of the reduced gravity across an interface times ! the thickness of the layer below (Igl) or above (Igu) it. - ! Their sum, Igd, is provided for the tridiagonal solver. [s2 m-2] + ! Their sum, Igd, is provided for the tridiagonal solver. [T2 L-2 ~> s2 m-2] real, dimension(SZK_(G),SZI_(G)) :: & Hf, & ! Layer thicknesses after very thin layers are combined [Z ~> m] Tf, & ! Layer temperatures after very thin layers are combined [degC] @@ -92,9 +92,11 @@ subroutine wave_speed(h, tv, G, GV, US, cg1, CS, full_halos, use_ebt_mode, & Sc, & ! A column of layer salinites after convective istabilities are removed [ppt] Rc, & ! A column of layer densities after convective istabilities are removed [R ~> kg m-3] Hc_H ! Hc(:) rescaled from Z to thickness units [H ~> m or kg m-2] - real det, ddet, detKm1, detKm2, ddetKm1, ddetKm2 - real :: lam, dlam, lam0 - real :: min_h_frac + real :: det, ddet, detKm1, detKm2, ddetKm1, ddetKm2 + real :: lam ! The eigenvalue [T2 L-2 ~> s m-1] + real :: dlam ! The change in estimates of the eigenvalue [T2 L-2 ~> s m-1] + real :: lam0 ! The first guess of the eigenvalue [T2 L-2 ~> s m-1] + real :: min_h_frac ! [nondim] real :: Z_to_Pa ! A conversion factor from thicknesses (in Z) to pressure (in Pa) real, dimension(SZI_(G)) :: & htot, hmin, & ! Thicknesses [Z ~> m] @@ -102,13 +104,16 @@ subroutine wave_speed(h, tv, G, GV, US, cg1, CS, full_halos, use_ebt_mode, & HxT_here, & ! A layer integrated temperature [degC Z ~> degC m] HxS_here, & ! A layer integrated salinity [ppt Z ~> ppt m] HxR_here ! A layer integrated density [R Z ~> kg m-2] - real :: speed2_tot ! overestimate of the mode-1 speed squared [m2 s-2] + real :: speed2_tot ! overestimate of the mode-1 speed squared [L2 T-2 ~> m2 s-2] real :: I_Hnew ! The inverse of a new layer thickness [Z-1 ~> m-1] real :: drxh_sum ! The sum of density diffrences across interfaces times thicknesses [R Z ~> kg m-2] - real :: L2_to_Z2 ! A scaling factor squared from units of lateral distances to depths [Z2 m-2 ~> 1]. + real :: L2_to_Z2 ! A scaling factor squared from units of lateral distances to depths [Z2 L-2 ~> 1]. real, parameter :: tol1 = 0.0001, tol2 = 0.001 real, pointer, dimension(:,:,:) :: T => NULL(), S => NULL() - real :: g_Rho0 ! G_Earth/Rho0 [m2 s-2 Z-1 R-1 ~> m4 s-2 kg-1]. + real :: g_Rho0 ! G_Earth/Rho0 [L2 T-2 Z-1 R-1 ~> m4 s-2 kg-1]. + real :: c2_scale ! A scaling factor for wave speeds to help control the growth of the determinant + ! and its derivative with lam between rows of the Thomas algorithm solver. The + ! exact value should not matter for the final result if it is an even power of 2. real :: rescale, I_rescale integer :: kf(SZI_(G)) integer, parameter :: max_itt = 10 @@ -117,7 +122,9 @@ subroutine wave_speed(h, tv, G, GV, US, cg1, CS, full_halos, use_ebt_mode, & ! equation of state. integer :: kc integer :: i, j, k, k2, itt, is, ie, js, je, nz - real :: hw, gp, sum_hc, N2min + real :: hw, sum_hc + real :: gp ! A limited local copy of gprime [L2 Z-1 T-2 ~> m s-2] + real :: N2min ! A minimum buoyancy frequency [T-2 ~> s-2] logical :: l_use_ebt_mode, calc_modal_structure real :: l_mono_N2_column_fraction, l_mono_N2_depth real :: mode_struct(SZK_(G)), ms_min, ms_max, ms_sq @@ -130,14 +137,14 @@ subroutine wave_speed(h, tv, G, GV, US, cg1, CS, full_halos, use_ebt_mode, & is = G%isd ; ie = G%ied ; js = G%jsd ; je = G%jed endif ; endif - L2_to_Z2 = US%m_to_Z**2 + L2_to_Z2 = US%L_to_Z**2 l_use_ebt_mode = CS%use_ebt_mode if (present(use_ebt_mode)) l_use_ebt_mode = use_ebt_mode l_mono_N2_column_fraction = CS%mono_N2_column_fraction if (present(mono_N2_column_fraction)) l_mono_N2_column_fraction = mono_N2_column_fraction - l_mono_N2_depth = US%m_to_Z*CS%mono_N2_depth - if (present(mono_N2_depth)) l_mono_N2_depth = US%m_to_Z*mono_N2_depth + l_mono_N2_depth = CS%mono_N2_depth + if (present(mono_N2_depth)) l_mono_N2_depth = mono_N2_depth calc_modal_structure = l_use_ebt_mode if (present(modal_structure)) calc_modal_structure = .true. if (calc_modal_structure) then @@ -147,17 +154,20 @@ subroutine wave_speed(h, tv, G, GV, US, cg1, CS, full_halos, use_ebt_mode, & endif S => tv%S ; T => tv%T - g_Rho0 = US%L_T_to_m_s**2 * GV%g_Earth / GV%Rho0 + g_Rho0 = GV%g_Earth / GV%Rho0 Z_to_Pa = GV%Z_to_H * GV%H_to_Pa use_EOS = associated(tv%eqn_of_state) rescale = 1024.0**4 ; I_rescale = 1.0/rescale + ! The following two lines give identical results: + ! c2_scale = 16.0 * US%m_s_to_L_T**2 + c2_scale = US%m_s_to_L_T**2 min_h_frac = tol1 / real(nz) !$OMP parallel do default(none) shared(is,ie,js,je,nz,h,G,GV,US,min_h_frac,use_EOS,T,S,tv,& !$OMP calc_modal_structure,l_use_ebt_mode,modal_structure, & !$OMP l_mono_N2_column_fraction,l_mono_N2_depth,CS, & -!$OMP Z_to_Pa,cg1,g_Rho0,rescale,I_rescale,L2_to_Z2) & +!$OMP Z_to_Pa,cg1,g_Rho0,rescale,I_rescale,L2_to_Z2,c2_scale) & !$OMP private(htot,hmin,kf,H_here,HxT_here,HxS_here,HxR_here, & !$OMP Hf,Tf,Sf,Rf,pres,T_int,S_int,drho_dT, & !$OMP drho_dS,drxh_sum,kc,Hc,Hc_H,Tc,Sc,I_Hnew,gprime,& @@ -345,7 +355,7 @@ subroutine wave_speed(h, tv, G, GV, US, cg1, CS, full_halos, use_ebt_mode, & (L2_to_Z2*gp > N2min*hw) ) then ! Filters out regions where N2 increases with depth but only in a lower fraction ! of the water column or below a certain depth. - gp = US%Z_to_m**2 * (N2min*hw) + gp = US%Z_to_L**2 * (N2min*hw) else N2min = L2_to_Z2 * gp/hw endif @@ -384,13 +394,14 @@ subroutine wave_speed(h, tv, G, GV, US, cg1, CS, full_halos, use_ebt_mode, & ! | igu(2) b(2)-lam igl(2) 0 0 ... | ! | 0 igu(3) b(3)-lam igl(3) 0 ... | ! which is consistent if the eigenvalue problem is for horizontal velocity or pressure modes. - !detKm1 = ( Igl(1)-lam) ; ddetKm1 = -1.0 + !detKm1 = c2_scale*(Igl(1)-lam) ; ddetKm1 = -1.0*c2_scale !det = (Igu(2)+Igl(2)-lam)*detKm1 - (Igu(2)*Igl(1)) ; ddet = (Igu(2)+Igl(2)-lam)*ddetKm1 - detKm1 detKm1 = 1.0 ; ddetKm1 = 0.0 - det = ( Igl(1)-lam) ; ddet = -1.0 + det = (Igl(1)-lam) ; ddet = -1.0 if (kc>1) then - detKm2 = detKm1; ddetKm2 = ddetKm1 - detKm1 = det; ddetKm1 = ddet + ! Shift variables and rescale rows to avoid over- or underflow. + detKm2 = c2_scale*detKm1 ; ddetKm2 = c2_scale*ddetKm1 + detKm1 = c2_scale*det ; ddetKm1 = c2_scale*ddet det = (Igu(2)+Igl(2)-lam)*detKm1 - (Igu(2)*Igl(1))*detKm2 ddet = (Igu(2)+Igl(2)-lam)*ddetKm1 - (Igu(2)*Igl(1))*ddetKm2 - detKm1 endif @@ -405,23 +416,27 @@ subroutine wave_speed(h, tv, G, GV, US, cg1, CS, full_halos, use_ebt_mode, & ! | 0 igu43) b(4)-lam igl(4) 0 ... | ! which is consistent if the eigenvalue problem is for vertical velocity modes. detKm1 = 1.0 ; ddetKm1 = 0.0 - det = (Igu(2)+Igl(2)-lam) ; ddet = -1.0 + det = (Igu(2) + Igl(2) - lam) ; ddet = -1.0 ! The last three rows of the w equation matrix are ! | ... 0 igu(kc-1) b(kc-1)-lam igl(kc-1) 0 | ! | ... 0 0 igu(kc-1) b(kc-1)-lam igl(kc-1) | ! \ ... 0 0 0 igu(kc) b(kc)-lam / endif do k=3,kc - detKm2 = detKm1; ddetKm2 = ddetKm1 - detKm1 = det; ddetKm1 = ddet + ! Shift variables and rescale rows to avoid over- or underflow. + detKm2 = c2_scale*detKm1 ; ddetKm2 = c2_scale*ddetKm1 + detKm1 = c2_scale*det ; ddetKm1 = c2_scale*ddet det = (Igu(k)+Igl(k)-lam)*detKm1 - (Igu(k)*Igl(k-1))*detKm2 ddet = (Igu(k)+Igl(k)-lam)*ddetKm1 - (Igu(k)*Igl(k-1))*ddetKm2 - detKm1 - ! Rescale det & ddet if det is getting too large. + ! Rescale det & ddet if det is getting too large or too small. if (abs(det) > rescale) then det = I_rescale*det ; detKm1 = I_rescale*detKm1 ddet = I_rescale*ddet ; ddetKm1 = I_rescale*ddetKm1 + elseif (abs(det) < I_rescale) then + det = rescale*det ; detKm1 = rescale*detKm1 + ddet = rescale*ddet ; ddetKm1 = rescale*ddetKm1 endif enddo ! Use Newton's method iteration to find a new estimate of lam. @@ -498,14 +513,17 @@ end subroutine wave_speed !! This uses the Thomas algorithm rather than the Hallberg algorithm since the matrix is not symmetric. subroutine tdma6(n, a, b, c, lam, y) integer, intent(in) :: n !< Number of rows of matrix - real, dimension(n), intent(in) :: a !< Lower diagonal - real, dimension(n), intent(in) :: b !< Leading diagonal - real, dimension(n), intent(in) :: c !< Upper diagonal - real, intent(in) :: lam !< Scalar subtracted from leading diagonal + real, dimension(n), intent(in) :: a !< Lower diagonal [T2 L-2 ~> s2 m-2] + real, dimension(n), intent(in) :: b !< Leading diagonal [T2 L-2 ~> s2 m-2] + real, dimension(n), intent(in) :: c !< Upper diagonal [T2 L-2 ~> s2 m-2] + real, intent(in) :: lam !< Scalar subtracted from leading diagonal [T2 L-2 ~> s2 m-2] real, dimension(n), intent(inout) :: y !< RHS on entry, result on exit ! Local variables integer :: k, l - real :: beta(n), yy(n), lambda + real :: beta(n), lambda ! Temporary variables in [T2 L-2 ~> s2 m-2] + real :: I_beta(n) ! Temporary variables in [L2 T-2 ~> m2 s-2] + real :: yy(n) ! A temporary variable with the same units as y on entry. + lambda = lam beta(1) = b(1) - lambda if (beta(1)==0.) then ! lam was chosen too perfectly @@ -513,26 +531,28 @@ subroutine tdma6(n, a, b, c, lam, y) lambda = (1. + 1.e-5) * lambda beta(1) = b(1) - lambda endif - beta(1) = 1. / beta(1) + I_beta(1) = 1. / beta(1) yy(1) = y(1) do k = 2, n - beta(k) = ( b(k) - lambda ) - a(k) * c(k-1) * beta(k-1) + beta(k) = ( b(k) - lambda ) - a(k) * c(k-1) * I_beta(k-1) + ! Perhaps the following 0 needs to become a tolerance to handle underflow? if (beta(k)==0.) then ! lam was chosen too perfectly ! Change lambda and redo everything up to row k lambda = (1. + 1.e-5) * lambda - beta(1) = 1. / ( b(1) - lambda ) + I_beta(1) = 1. / ( b(1) - lambda ) do l = 2, k - beta(l) = 1. / ( ( b(l) - lambda ) - a(l) * c(l-1) * beta(l-1) ) - yy(l) = y(l) - a(l) * yy(l-1) * beta(l-1) + I_beta(l) = 1. / ( ( b(l) - lambda ) - a(l) * c(l-1) * I_beta(l-1) ) + yy(l) = y(l) - a(l) * yy(l-1) * I_beta(l-1) enddo else - beta(k) = 1. / beta(k) + I_beta(k) = 1. / beta(k) endif - yy(k) = y(k) - a(k) * yy(k-1) * beta(k-1) + yy(k) = y(k) - a(k) * yy(k-1) * I_beta(k-1) enddo - y(n) = yy(n) * beta(n) + ! The units of y change by a factor of [L2 T-2] in the following lines. + y(n) = yy(n) * I_beta(n) do k = n-1, 1, -1 - y(k) = ( yy(k) - c(k) * y(k+1) ) * beta(k) + y(k) = ( yy(k) - c(k) * y(k+1) ) * I_beta(k) enddo end subroutine tdma6 @@ -555,14 +575,14 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, full_halos) pres, & ! Interface pressure [Pa] T_int, & ! Temperature interpolated to interfaces [degC] S_int, & ! Salinity interpolated to interfaces [ppt] - gprime ! The reduced gravity across each interface [m2 Z-1 s-2 ~> m s-2]. + gprime ! The reduced gravity across each interface [L2 Z-1 T-2 ~> m s-2]. real, dimension(SZK_(G)) :: & Igl, Igu ! The inverse of the reduced gravity across an interface times - ! the thickness of the layer below (Igl) or above (Igu) it [s2 m-2]. + ! the thickness of the layer below (Igl) or above (Igu) it, in [T2 L-2 ~> s2 m-2]. real, dimension(SZK_(G)-1) :: & a_diag, b_diag, c_diag ! diagonals of tridiagonal matrix; one value for each - ! interface (excluding surface and bottom) + ! interface (excluding surface and bottom) [T2 L-2 ~> s2 m-2] real, dimension(SZK_(G),SZI_(G)) :: & Hf, & ! Layer thicknesses after very thin layers are combined [Z ~> m] Tf, & ! Layer temperatures after very thin layers are combined [degC] @@ -573,23 +593,22 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, full_halos) Tc, & ! A column of layer temperatures after convective istabilities are removed [degC] Sc, & ! A column of layer salinites after convective istabilities are removed [ppt] Rc ! A column of layer densities after convective istabilities are removed [R ~> kg m-3] - real, parameter :: c1_thresh = 0.01 - ! if c1 is below this value, don't bother calculating - ! cn values for higher modes + real :: c1_thresh ! if c1 is below this value, don't bother calculating + ! cn values for higher modes [L T-1 ~> m s-1] real :: det, ddet ! determinant & its derivative of eigen system - real :: lam_1 ! approximate mode-1 eigen value - real :: lam_n ! approximate mode-n eigen value - real :: dlam ! increment in lam for Newton's method - real :: lamMin ! minimum lam value for root searching range - real :: lamMax ! maximum lam value for root searching range - real :: lamInc ! width of moving window for root searching + real :: lam_1 ! approximate mode-1 eigenvalue [T2 L-2 ~> s2 m-2] + real :: lam_n ! approximate mode-n eigenvalue [T2 L-2 ~> s2 m-2] + real :: dlam ! increment in lam for Newton's method [T2 L-2 ~> s2 m-2] + real :: lamMin ! minimum lam value for root searching range [T2 L-2 ~> s2 m-2] + real :: lamMax ! maximum lam value for root searching range [T2 L-2 ~> s2 m-2] + real :: lamInc ! width of moving window for root searching [T2 L-2 ~> s2 m-2] real :: det_l,det_r ! determinant value at left and right of window real :: ddet_l,ddet_r ! derivative of determinant at left and right of window real :: det_sub,ddet_sub! derivative of determinant at subinterval endpoint - real :: xl,xr ! lam guesses at left and right of window - real :: xl_sub ! lam guess at left of subinterval window + real :: xl,xr ! lam guesses at left and right of window [T2 L-2 ~> s2 m-2] + real :: xl_sub ! lam guess at left of subinterval window [T2 L-2 ~> s2 m-2] real,dimension(nmodes) :: & - xbl,xbr ! lam guesses bracketing a zero-crossing (root) + xbl,xbr ! lam guesses bracketing a zero-crossing (root) [T2 L-2 ~> s2 m-2] integer :: numint ! number of widows (intervals) in root searching range integer :: nrootsfound ! number of extra roots found (not including 1st root) real :: min_h_frac @@ -600,20 +619,20 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, full_halos) HxT_here, & ! A layer integrated temperature [degC Z ~> degC m] HxS_here, & ! A layer integrated salinity [ppt Z ~> ppt m] HxR_here ! A layer integrated density [R Z ~> kg m-2] - real :: speed2_tot ! overestimate of the mode-1 speed squared [m2 s-2] - real :: speed2_min ! minimum mode speed (squared) to consider in root searching + real :: speed2_tot ! overestimate of the mode-1 speed squared [L2 T-2 ~> m2 s-2] + real :: speed2_min ! minimum mode speed (squared) to consider in root searching [L2 T-2 ~> m2 s-2] real, parameter :: reduct_factor = 0.5 - ! factor used in setting speed2_min + ! factor used in setting speed2_min [nondim] real :: I_Hnew ! The inverse of a new layer thickness [Z-1 ~> m-1] real :: drxh_sum ! The sum of density diffrences across interfaces times thicknesses [R Z ~> kg m-2] real, parameter :: tol1 = 0.0001, tol2 = 0.001 real, pointer, dimension(:,:,:) :: T => NULL(), S => NULL() - real :: g_Rho0 ! G_Earth/Rho0 [m2 s-2 Z-1 R-1 ~> m4 s-2 kg-1]. + real :: g_Rho0 ! G_Earth/Rho0 [L2 T-2 Z-1 R-1 ~> m4 s-2 kg-1]. integer :: kf(SZI_(G)) integer, parameter :: max_itt = 10 logical :: use_EOS ! If true, density is calculated from T & S using the equation of state. real, dimension(SZK_(G)+1) :: z_int - ! real, dimension(SZK_(G)+1) :: N2 + ! real, dimension(SZK_(G)+1) :: N2 ! The local squared buoyancy frequency [T-2 ~> s-2] integer :: nsub ! number of subintervals used for root finding integer, parameter :: sub_it_max = 4 ! maximum number of times to subdivide interval @@ -635,9 +654,10 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, full_halos) endif ; endif S => tv%S ; T => tv%T - g_Rho0 = US%L_T_to_m_s**2 * GV%g_Earth / GV%Rho0 + g_Rho0 = GV%g_Earth / GV%Rho0 use_EOS = associated(tv%eqn_of_state) Z_to_Pa = GV%Z_to_H * GV%H_to_Pa + c1_thresh = 0.01*US%m_s_to_L_T min_h_frac = tol1 / real(nz) !$OMP parallel do default(private) shared(is,ie,js,je,nz,h,G,GV,US,min_h_frac,use_EOS,T,S, & @@ -814,7 +834,7 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, full_halos) do K=2,kc Igl(K) = 1.0/(gprime(K)*Hc(k)) ; Igu(K) = 1.0/(gprime(K)*Hc(k-1)) z_int(K) = z_int(K-1) + Hc(k-1) - ! N2(K) = US%m_to_Z**2*gprime(K)/(0.5*(Hc(k)+Hc(k-1))) + ! N2(K) = US%L_to_Z**2*gprime(K)/(0.5*(Hc(k)+Hc(k-1))) speed2_tot = speed2_tot + gprime(K)*(Hc(k-1)+Hc(k)) enddo ! Set stratification for surface and bottom (setting equal to nearest interface for now) @@ -830,31 +850,31 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, full_halos) ! First, populate interior rows do K=3,kc-1 row = K-1 ! indexing for TD matrix rows - a_diag(row) = (-Igu(K)) - b_diag(row) = (Igu(K)+Igl(K)) - c_diag(row) = (-Igl(K)) + a_diag(row) = -Igu(K) + b_diag(row) = Igu(K)+Igl(K) + c_diag(row) = -Igl(K) enddo ! Populate top row of tridiagonal matrix K=2 ; row = K-1 a_diag(row) = 0.0 - b_diag(row) = (Igu(K)+Igl(K)) - c_diag(row) = (-Igl(K)) + b_diag(row) = Igu(K)+Igl(K) + c_diag(row) = -Igl(K) ! Populate bottom row of tridiagonal matrix K=kc ; row = K-1 - a_diag(row) = (-Igu(K)) - b_diag(row) = (Igu(K)+Igl(K)) + a_diag(row) = -Igu(K) + b_diag(row) = Igu(K)+Igl(K) c_diag(row) = 0.0 ! Total number of rows in the matrix = number of interior interfaces nrows = kc-1 - ! Under estimate the first eigen value to start with. + ! Under estimate the first eigenvalue to start with. lam_1 = 1.0 / speed2_tot ! Find the first eigen value do itt=1,max_itt ! calculate the determinant of (A-lam_1*I) call tridiag_det(a_diag(1:nrows),b_diag(1:nrows),c_diag(1:nrows), & - nrows,lam_1,det,ddet) + nrows,lam_1,det,ddet, row_scale=US%m_s_to_L_T**2) ! Use Newton's method iteration to find a new estimate of lam_1 !det = det_it(itt) ; ddet = ddet_it(itt) if ((ddet >= 0.0) .or. (-det > -0.5*lam_1*ddet)) then @@ -892,13 +912,13 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, full_halos) ! find det_l of first interval (det at left endpoint) call tridiag_det(a_diag(1:nrows),b_diag(1:nrows),c_diag(1:nrows), & - nrows,lamMin,det_l,ddet_l) + nrows,lamMin,det_l,ddet_l, row_scale=US%m_s_to_L_T**2) ! move interval window looking for zero-crossings************************ do iint=1,numint xr = lamMin + lamInc * iint xl = xr - lamInc call tridiag_det(a_diag(1:nrows),b_diag(1:nrows),c_diag(1:nrows), & - nrows,xr,det_r,ddet_r) + nrows,xr,det_r,ddet_r, row_scale=US%m_s_to_L_T**2) if (det_l*det_r < 0.0) then ! if function changes sign if (det_l*ddet_l < 0.0) then ! if function at left is headed to zero nrootsfound = nrootsfound + 1 @@ -919,7 +939,7 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, full_halos) do sub=1,nsub-1,2 ! only check odds; sub = 1; 1,3; 1,3,5,7;... xl_sub = xl + lamInc/(nsub)*sub call tridiag_det(a_diag(1:nrows),b_diag(1:nrows),c_diag(1:nrows), & - nrows,xl_sub,det_sub,ddet_sub) + nrows,xl_sub,det_sub,ddet_sub, row_scale=US%m_s_to_L_T**2) if (det_sub*det_r < 0.0) then ! if function changes sign if (det_sub*ddet_sub < 0.0) then ! if function at left is headed to zero sub_rootfound = .true. @@ -962,7 +982,7 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, full_halos) do itt=1,max_itt ! calculate the determinant of (A-lam_n*I) call tridiag_det(a_diag(1:nrows),b_diag(1:nrows),c_diag(1:nrows), & - nrows,lam_n,det,ddet) + nrows,lam_n,det,ddet, row_scale=US%m_s_to_L_T**2) ! Use Newton's method to find a new estimate of lam_n dlam = - det / ddet lam_n = lam_n + dlam @@ -976,7 +996,6 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, full_halos) else cn(i,j,2:nmodes) = 0.0 ! else too small to worry about endif ! if nmodes>1 .and. kc>nmodes .and. c1>c1_thresh - do m=1,nmodes ; cn(i,j,m) = US%m_s_to_L_T*cn(i,j,m) ; enddo else cn(i,j,:) = 0.0 endif ! if more than 2 layers @@ -989,8 +1008,11 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, full_halos) end subroutine wave_speeds -!> Calculate the determinant of a tridiagonal matrix with diagonals a,b-lam,c where lam is constant across rows. -subroutine tridiag_det(a,b,c,nrows,lam,det_out,ddet_out) +!> Calculate the determinant of a tridiagonal matrix with diagonals a,b-lam,c and its derivative +!! with lam, where lam is constant across rows. Only the ratio of det to its derivative and their +!! signs are typically used, so internal rescaling by consistent factors are used to avoid +!! over- or underflow. +subroutine tridiag_det(a, b, c, nrows, lam, det_out, ddet_out, row_scale) real, dimension(:), intent(in) :: a !< Lower diagonal of matrix (first entry = 0) real, dimension(:), intent(in) :: b !< Leading diagonal of matrix (excluding lam) real, dimension(:), intent(in) :: c !< Upper diagonal of matrix (last entry = 0) @@ -998,10 +1020,13 @@ subroutine tridiag_det(a,b,c,nrows,lam,det_out,ddet_out) real, intent(in) :: lam !< Value subtracted from b real, intent(out):: det_out !< Determinant real, intent(out):: ddet_out !< Derivative of determinant w.r.t. lam + real, optional, intent(in) :: row_scale !< A scaling factor of the rows of the + !! matrix to limit the growth of the determinant ! Local variables real, dimension(nrows) :: det ! value of recursion function real, dimension(nrows) :: ddet ! value of recursion function for derivative real, parameter:: rescale = 1024.0**4 ! max value of determinant allowed before rescaling + real :: rscl real :: I_rescale ! inverse of rescale integer :: n ! row (layer interface) index @@ -1010,20 +1035,24 @@ subroutine tridiag_det(a,b,c,nrows,lam,det_out,ddet_out) if (size(c) /= nrows) call MOM_error(WARNING, "Diagonal c must be same length as nrows.") I_rescale = 1.0/rescale + rscl = 1.0 ; if (present(row_scale)) rscl = row_scale det(1) = 1.0 ; ddet(1) = 0.0 det(2) = b(2)-lam ; ddet(2) = -1.0 do n=3,nrows - det(n) = (b(n)-lam)*det(n-1) - (a(n)*c(n-1))*det(n-2) - ddet(n) = (b(n)-lam)*ddet(n-1) - (a(n)*c(n-1))*ddet(n-2) - det(n-1) - ! Rescale det & ddet if det is getting too large. + det(n) = rscl*(b(n)-lam)*det(n-1) - rscl*(a(n)*c(n-1))*det(n-2) + ddet(n) = rscl*(b(n)-lam)*ddet(n-1) - rscl*(a(n)*c(n-1))*ddet(n-2) - det(n-1) + ! Rescale det & ddet if det is getting too large or too small to avoid overflow or underflow. if (abs(det(n)) > rescale) then det(n) = I_rescale*det(n) ; det(n-1) = I_rescale*det(n-1) ddet(n) = I_rescale*ddet(n) ; ddet(n-1) = I_rescale*ddet(n-1) + elseif (abs(det(n)) < I_rescale) then + det(n) = rescale*det(n) ; det(n-1) = rescale*det(n-1) + ddet(n) = rescale*ddet(n) ; ddet(n-1) = rescale*ddet(n-1) endif enddo det_out = det(nrows) - ddet_out = ddet(nrows) + ddet_out = ddet(nrows) / rscl end subroutine tridiag_det @@ -1037,7 +1066,7 @@ subroutine wave_speed_init(CS, use_ebt_mode, mono_N2_column_fraction, mono_N2_de !! calculating the vertical modal structure. real, optional, intent(in) :: mono_N2_depth !< The depth below which N2 is limited !! as monotonic for the purposes of calculating the - !! vertical modal structure. + !! vertical modal structure [Z ~> m]. ! This include declares and sets the variable "version". #include "version_variable.h" character(len=40) :: mdl = "MOM_wave_speed" ! This module's name. @@ -1067,7 +1096,7 @@ subroutine wave_speed_set_param(CS, use_ebt_mode, mono_N2_column_fraction, mono_ !! calculating the vertical modal structure. real, optional, intent(in) :: mono_N2_depth !< The depth below which N2 is limited !! as monotonic for the purposes of calculating the - !! vertical modal structure. + !! vertical modal structure [Z ~> m]. if (.not.associated(CS)) call MOM_error(FATAL, & "wave_speed_set_param called with an associated control structure.") diff --git a/src/framework/MOM_diag_mediator.F90 b/src/framework/MOM_diag_mediator.F90 index c82f3258b6..5fd21bd490 100644 --- a/src/framework/MOM_diag_mediator.F90 +++ b/src/framework/MOM_diag_mediator.F90 @@ -2982,13 +2982,15 @@ subroutine diag_mediator_init(G, GV, US, nz, param_file, diag_cs, doc_file_dir) ! This subroutine initializes the diag_mediator and the diag_manager. ! The grid type should have its dimensions set by this point, but it ! is not necessary that the metrics and axis labels be set up yet. + + ! Local variables integer :: ios, i, new_unit logical :: opened, new_file character(len=8) :: this_pe character(len=240) :: doc_file, doc_file_dflt, doc_path character(len=240), allocatable :: diag_coords(:) -! This include declares and sets the variable "version". -#include "version_variable.h" + ! This include declares and sets the variable "version". +# include "version_variable.h" character(len=40) :: mdl = "MOM_diag_mediator" ! This module's name. character(len=32) :: filename_appendix = '' !fms appendix to filename for ensemble runs @@ -3164,7 +3166,7 @@ end subroutine diag_mediator_init !> Set pointers to the default state fields used to remap diagnostics. subroutine diag_set_state_ptrs(h, T, S, eqn_of_state, diag_cs) - real, dimension(:,:,:), target, intent(in ) :: h !< the model thickness array + real, dimension(:,:,:), target, intent(in ) :: h !< the model thickness array [H ~> m or kg m-2] real, dimension(:,:,:), target, intent(in ) :: T !< the model temperature array real, dimension(:,:,:), target, intent(in ) :: S !< the model salinity array type(EOS_type), target, intent(in ) :: eqn_of_state !< Equation of state structure @@ -3184,7 +3186,7 @@ subroutine diag_set_state_ptrs(h, T, S, eqn_of_state, diag_cs) subroutine diag_update_remap_grids(diag_cs, alt_h, alt_T, alt_S) type(diag_ctrl), intent(inout) :: diag_cs !< Diagnostics control structure real, target, optional, intent(in ) :: alt_h(:,:,:) !< Used if remapped grids should be something other than - !! the current thicknesses + !! the current thicknesses [H ~> m or kg m-2] real, target, optional, intent(in ) :: alt_T(:,:,:) !< Used if remapped grids should be something other than !! the current temperatures real, target, optional, intent(in ) :: alt_S(:,:,:) !< Used if remapped grids should be something other than @@ -3862,9 +3864,15 @@ subroutine downsample_field_3d(field_in, field_out, dl, method, mask, diag_cs, d integer :: i,j,ii,jj,i0,j0,f1,f2,f_in1,f_in2 integer :: k,ks,ke real :: ave,total_weight,weight - real :: epsilon = 1.0e-20 + real :: eps_vol ! A negligibly small volume or mass [H L2 ~> m3 or kg] + real :: eps_area ! A negligibly small area [L2 ~> m2] + real :: eps_face ! A negligibly small face area [H L ~> m2 or kg m-1] + + ks = 1 ; ke = size(field_in,3) + eps_face = 1.0e-20 * diag_cs%G%US%m_to_L * diag_cs%GV%m_to_H + eps_area = 1.0e-20 * diag_cs%G%US%m_to_L**2 + eps_vol = 1.0e-20 * diag_cs%G%US%m_to_L**2 * diag_cs%GV%m_to_H - ks=1 ; ke =size(field_in,3) ! Allocate the down sampled field on the down sampled data domain ! allocate(field_out(diag_cs%dsamp(dl)%isd:diag_cs%dsamp(dl)%ied,diag_cs%dsamp(dl)%jsd:diag_cs%dsamp(dl)%jed,ks:ke)) ! allocate(field_out(1:size(field_in,1)/dl,1:size(field_in,2)/dl,ks:ke)) @@ -3880,7 +3888,7 @@ subroutine downsample_field_3d(field_in, field_out, dl, method, mask, diag_cs, d allocate(field_out(1:f1,1:f2,ks:ke)) ! Fill the down sampled field on the down sampled diagnostics (almost always compuate) domain - if(method .eq. MMM) then + if (method == MMM) then do k= ks,ke ; do j=jsv_d,jev_d ; do i=isv_d,iev_d i0 = isv_o+dl*(i-isv_d) j0 = jsv_o+dl*(j-jsv_d) @@ -3888,24 +3896,24 @@ subroutine downsample_field_3d(field_in, field_out, dl, method, mask, diag_cs, d total_weight = 0.0 do jj=j0,j0+dl-1 ; do ii=i0,i0+dl-1 ! do ii=i0,i0+dl-1 ; do jj=j0,j0+dl-1 !This seems to be faster!!!! - weight = mask(ii,jj,k)*diag_cs%G%US%L_to_m**2*diag_cs%G%areaT(ii,jj)*diag_cs%h(ii,jj,k) + weight = mask(ii,jj,k) * diag_cs%G%areaT(ii,jj) * diag_cs%h(ii,jj,k) total_weight = total_weight + weight - ave=ave+field_in(ii,jj,k)*weight + ave = ave+field_in(ii,jj,k) * weight enddo; enddo - field_out(i,j,k) = ave/(total_weight+epsilon) !Avoid zero mask at all aggregating cells where ave=0.0 + field_out(i,j,k) = ave/(total_weight + eps_vol) !Avoid zero mask at all aggregating cells where ave=0.0 enddo; enddo; enddo - elseif(method .eq. SSS) then !e.g., volcello + elseif (method == SSS) then !e.g., volcello do k= ks,ke ; do j=jsv_d,jev_d ; do i=isv_d,iev_d i0 = isv_o+dl*(i-isv_d) j0 = jsv_o+dl*(j-jsv_d) ave = 0.0 do jj=j0,j0+dl-1 ; do ii=i0,i0+dl-1 weight = mask(ii,jj,k) - ave=ave+field_in(ii,jj,k)*weight + ave = ave+field_in(ii,jj,k)*weight enddo; enddo field_out(i,j,k) = ave !Masked Sum (total_weight=1) enddo; enddo; enddo - elseif(method .eq. MMP .or. method .eq. MMS) then !e.g., T_advection_xy + elseif(method == MMP .or. method == MMS) then !e.g., T_advection_xy do k= ks,ke ; do j=jsv_d,jev_d ; do i=isv_d,iev_d i0 = isv_o+dl*(i-isv_d) j0 = jsv_o+dl*(j-jsv_d) @@ -3913,13 +3921,13 @@ subroutine downsample_field_3d(field_in, field_out, dl, method, mask, diag_cs, d total_weight = 0.0 do jj=j0,j0+dl-1 ; do ii=i0,i0+dl-1 ! do ii=i0,i0+dl-1 ; do jj=j0,j0+dl-1 - weight = mask(ii,jj,k)*diag_cs%G%US%L_to_m**2*diag_cs%G%areaT(ii,jj) + weight = mask(ii,jj,k) * diag_cs%G%areaT(ii,jj) total_weight = total_weight + weight - ave=ave+field_in(ii,jj,k)*weight + ave = ave+field_in(ii,jj,k)*weight enddo; enddo - field_out(i,j,k) = ave/(total_weight+epsilon) !Avoid zero mask at all aggregating cells where ave=0.0 + field_out(i,j,k) = ave / (total_weight+eps_area) !Avoid zero mask at all aggregating cells where ave=0.0 enddo; enddo; enddo - elseif(method .eq. PMM) then + elseif(method == PMM) then do k= ks,ke ; do j=jsv_d,jev_d ; do i=isv_d,iev_d i0 = isv_o+dl*(i-isv_d) j0 = jsv_o+dl*(j-jsv_d) @@ -3927,13 +3935,13 @@ subroutine downsample_field_3d(field_in, field_out, dl, method, mask, diag_cs, d total_weight = 0.0 ii=i0 do jj=j0,j0+dl-1 - weight =mask(ii,jj,k)*diag_cs%G%US%L_to_m*diag_cs%G%dyCu(ii,jj) * diag_cs%h(ii,jj,k) + weight =mask(ii,jj,k) * diag_cs%G%dyCu(ii,jj) * diag_cs%h(ii,jj,k) total_weight = total_weight +weight ave=ave+field_in(ii,jj,k)*weight enddo - field_out(i,j,k) = ave/(total_weight+epsilon) !Avoid zero mask at all aggregating cells where ave=0.0 + field_out(i,j,k) = ave/(total_weight+eps_face) !Avoid zero mask at all aggregating cells where ave=0.0 enddo; enddo; enddo - elseif(method .eq. PSS) then !e.g. umo + elseif(method == PSS) then !e.g. umo do k= ks,ke ; do j=jsv_d,jev_d ; do i=isv_d,iev_d i0 = isv_o+dl*(i-isv_d) j0 = jsv_o+dl*(j-jsv_d) @@ -3945,7 +3953,7 @@ subroutine downsample_field_3d(field_in, field_out, dl, method, mask, diag_cs, d enddo field_out(i,j,k) = ave !Masked Sum (total_weight=1) enddo; enddo; enddo - elseif(method .eq. SPS) then !e.g. vmo + elseif(method == SPS) then !e.g. vmo do k= ks,ke ; do j=jsv_d,jev_d ; do i=isv_d,iev_d i0 = isv_o+dl*(i-isv_d) j0 = jsv_o+dl*(j-jsv_d) @@ -3957,7 +3965,7 @@ subroutine downsample_field_3d(field_in, field_out, dl, method, mask, diag_cs, d enddo field_out(i,j,k) = ave !Masked Sum (total_weight=1) enddo; enddo; enddo - elseif(method .eq. MPM) then + elseif(method == MPM) then do k= ks,ke ; do j=jsv_d,jev_d ; do i=isv_d,iev_d i0 = isv_o+dl*(i-isv_d) j0 = jsv_o+dl*(j-jsv_d) @@ -3965,13 +3973,13 @@ subroutine downsample_field_3d(field_in, field_out, dl, method, mask, diag_cs, d total_weight = 0.0 jj=j0 do ii=i0,i0+dl-1 - weight = mask(ii,jj,k)*diag_cs%G%US%L_to_m*diag_cs%G%dxCv(ii,jj)*diag_cs%h(ii,jj,k) + weight = mask(ii,jj,k) * diag_cs%G%dxCv(ii,jj) * diag_cs%h(ii,jj,k) total_weight = total_weight + weight ave=ave+field_in(ii,jj,k)*weight enddo - field_out(i,j,k) = ave/(total_weight+epsilon) !Avoid zero mask at all aggregating cells where ave=0.0 + field_out(i,j,k) = ave/(total_weight+eps_face) !Avoid zero mask at all aggregating cells where ave=0.0 enddo; enddo; enddo - elseif(method .eq. MSK) then !The input field is a mask, subsample + elseif(method == MSK) then !The input field is a mask, subsample field_out(:,:,:) = 0.0 do k= ks,ke ; do j=jsv_d,jev_d ; do i=isv_d,iev_d i0 = isv_o+dl*(i-isv_d) @@ -4010,8 +4018,13 @@ subroutine downsample_field_2d(field_in, field_out, dl, method, mask, diag_cs, d ! Locals character(len=240) :: mesg integer :: i,j,ii,jj,i0,j0,f1,f2,f_in1,f_in2 - real :: ave,total_weight,weight - real :: epsilon = 1.0e-20 + real :: ave, total_weight, weight + real :: epsilon = 1.0e-20 ! A negligibly small count of weights [nondim] + real :: eps_area ! A negligibly small area [L2 ~> m2] + real :: eps_len ! A negligibly small horizontal length [L ~> m] + + eps_len = 1.0e-20 * diag_cs%G%US%m_to_L + eps_area = 1.0e-20 * diag_cs%G%US%m_to_L**2 ! Allocate the down sampled field on the down sampled data domain ! allocate(field_out(diag_cs%dsamp(dl)%isd:diag_cs%dsamp(dl)%ied,diag_cs%dsamp(dl)%jsd:diag_cs%dsamp(dl)%jed)) @@ -4028,7 +4041,7 @@ subroutine downsample_field_2d(field_in, field_out, dl, method, mask, diag_cs, d endif allocate(field_out(1:f1,1:f2)) - if(method .eq. MMP) then + if (method == MMP) then do j=jsv_d,jev_d ; do i=isv_d,iev_d i0 = isv_o+dl*(i-isv_d) j0 = jsv_o+dl*(j-jsv_d) @@ -4036,13 +4049,13 @@ subroutine downsample_field_2d(field_in, field_out, dl, method, mask, diag_cs, d total_weight = 0.0 do jj=j0,j0+dl-1 ; do ii=i0,i0+dl-1 ! do ii=i0,i0+dl-1 ; do jj=j0,j0+dl-1 - weight = mask(ii,jj)*diag_cs%G%US%L_to_m**2*diag_cs%G%areaT(ii,jj) + weight = mask(ii,jj)*diag_cs%G%areaT(ii,jj) total_weight = total_weight + weight - ave=ave+field_in(ii,jj)*weight + ave = ave+field_in(ii,jj)*weight enddo; enddo - field_out(i,j) = ave/(total_weight+epsilon) !Avoid zero mask at all aggregating cells where ave=0.0 + field_out(i,j) = ave/(total_weight + eps_area) !Avoid zero mask at all aggregating cells where ave=0.0 enddo; enddo - elseif(method .eq. SSP) then ! e.g., T_dfxy_cont_tendency_2d + elseif(method == SSP) then ! e.g., T_dfxy_cont_tendency_2d do j=jsv_d,jev_d ; do i=isv_d,iev_d i0 = isv_o+dl*(i-isv_d) j0 = jsv_o+dl*(j-jsv_d) @@ -4056,7 +4069,7 @@ subroutine downsample_field_2d(field_in, field_out, dl, method, mask, diag_cs, d enddo; enddo field_out(i,j) = ave/(total_weight+epsilon) !Avoid zero mask at all aggregating cells where ave=0.0 enddo; enddo - elseif(method .eq. PSP) then ! e.g., umo_2d + elseif(method == PSP) then ! e.g., umo_2d do j=jsv_d,jev_d ; do i=isv_d,iev_d i0 = isv_o+dl*(i-isv_d) j0 = jsv_o+dl*(j-jsv_d) @@ -4064,13 +4077,13 @@ subroutine downsample_field_2d(field_in, field_out, dl, method, mask, diag_cs, d total_weight = 0.0 ii=i0 do jj=j0,j0+dl-1 - weight =mask(ii,jj) + weight = mask(ii,jj) total_weight = total_weight +weight ave=ave+field_in(ii,jj)*weight enddo field_out(i,j) = ave/(total_weight+epsilon) !Avoid zero mask at all aggregating cells where ave=0.0 enddo; enddo - elseif(method .eq. SPP) then ! e.g., vmo_2d + elseif(method == SPP) then ! e.g., vmo_2d do j=jsv_d,jev_d ; do i=isv_d,iev_d i0 = isv_o+dl*(i-isv_d) j0 = jsv_o+dl*(j-jsv_d) @@ -4078,13 +4091,13 @@ subroutine downsample_field_2d(field_in, field_out, dl, method, mask, diag_cs, d total_weight = 0.0 jj=j0 do ii=i0,i0+dl-1 - weight =mask(ii,jj) + weight = mask(ii,jj) total_weight = total_weight +weight ave=ave+field_in(ii,jj)*weight enddo field_out(i,j) = ave/(total_weight+epsilon) !Avoid zero mask at all aggregating cells where ave=0.0 enddo; enddo - elseif(method .eq. PMP) then + elseif(method == PMP) then do j=jsv_d,jev_d ; do i=isv_d,iev_d i0 = isv_o+dl*(i-isv_d) j0 = jsv_o+dl*(j-jsv_d) @@ -4092,13 +4105,13 @@ subroutine downsample_field_2d(field_in, field_out, dl, method, mask, diag_cs, d total_weight = 0.0 ii=i0 do jj=j0,j0+dl-1 - weight = mask(ii,jj)*diag_cs%G%US%L_to_m*diag_cs%G%dyCu(ii,jj)!*diag_cs%h(ii,jj,1) !Niki? + weight = mask(ii,jj) * diag_cs%G%dyCu(ii,jj)!*diag_cs%h(ii,jj,1) !Niki? total_weight = total_weight +weight ave=ave+field_in(ii,jj)*weight enddo - field_out(i,j) = ave/(total_weight+epsilon) !Avoid zero mask at all aggregating cells where ave=0.0 + field_out(i,j) = ave/(total_weight+eps_len) !Avoid zero mask at all aggregating cells where ave=0.0 enddo; enddo - elseif(method .eq. MPP) then + elseif(method == MPP) then do j=jsv_d,jev_d ; do i=isv_d,iev_d i0 = isv_o+dl*(i-isv_d) j0 = jsv_o+dl*(j-jsv_d) @@ -4106,13 +4119,13 @@ subroutine downsample_field_2d(field_in, field_out, dl, method, mask, diag_cs, d total_weight = 0.0 jj=j0 do ii=i0,i0+dl-1 - weight = mask(ii,jj)*diag_cs%G%US%L_to_m*diag_cs%G%dxCv(ii,jj)!*diag_cs%h(ii,jj,1) !Niki? + weight = mask(ii,jj)* diag_cs%G%dxCv(ii,jj)!*diag_cs%h(ii,jj,1) !Niki? total_weight = total_weight +weight ave=ave+field_in(ii,jj)*weight enddo - field_out(i,j) = ave/(total_weight+epsilon) !Avoid zero mask at all aggregating cells where ave=0.0 + field_out(i,j) = ave/(total_weight+eps_len) !Avoid zero mask at all aggregating cells where ave=0.0 enddo; enddo - elseif(method .eq. MSK) then !The input field is a mask, subsample + elseif(method == MSK) then !The input field is a mask, subsample field_out(:,:) = 0.0 do j=jsv_d,jev_d ; do i=isv_d,iev_d i0 = isv_o+dl*(i-isv_d) diff --git a/src/initialization/MOM_state_initialization.F90 b/src/initialization/MOM_state_initialization.F90 index da0b986303..03310d70f3 100644 --- a/src/initialization/MOM_state_initialization.F90 +++ b/src/initialization/MOM_state_initialization.F90 @@ -158,7 +158,7 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, US, PF, dirs, & ! a restart file to the internal representation in this run. real :: vel_rescale ! A rescaling factor for velocities from the representation in ! a restart file to the internal representation in this run. - real :: dt ! The baroclinic dynamics timestep for this run [s]. + real :: dt ! The baroclinic dynamics timestep for this run [T ~> s]. logical :: from_Z_file, useALE logical :: new_sim integer :: write_geom @@ -475,7 +475,7 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, US, PF, dirs, & "an initial grid that is consistent with the initial conditions.", & default=1, do_not_log=just_read) - call get_param(PF, mdl, "DT", dt, "Timestep", fail_if_missing=.true.) + call get_param(PF, mdl, "DT", dt, "Timestep", fail_if_missing=.true., scale=US%s_to_T) if (new_sim .and. debug) & call hchksum(h, "Pre-ALE_regrid: h ", G%HI, haloshift=1, scale=GV%H_to_m) @@ -562,7 +562,7 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, US, PF, dirs, & endif ! Reads OBC parameters not pertaining to the location of the boundaries - call open_boundary_init(G, PF, OBC) + call open_boundary_init(G, GV, US, PF, OBC, restart_CS) ! This controls user code for setting open boundary data if (associated(OBC)) then @@ -616,7 +616,7 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, US, PF, dirs, & call qchksum(G%mask2dBu, 'MOM_initialize_state: mask2dBu ', G%HI) endif - if (debug_OBC) call open_boundary_test_extern_h(G, OBC, h) + if (debug_OBC) call open_boundary_test_extern_h(G, GV, OBC, h) call callTree_leave('MOM_initialize_state()') end subroutine MOM_initialize_state @@ -1864,8 +1864,8 @@ subroutine initialize_sponges_file(G, GV, US, use_temperature, tv, param_file, C call MOM_read_data(filename, salin_var, tmp(:,:,:), G%Domain) call set_up_sponge_field(tmp, tv%S, G, nz, CSp) elseif (use_temperature) then - call set_up_ALE_sponge_field(filename, potemp_var, Time, G, GV, tv%T, ALE_CSp) - call set_up_ALE_sponge_field(filename, salin_var, Time, G, GV, tv%S, ALE_CSp) + call set_up_ALE_sponge_field(filename, potemp_var, Time, G, GV, US, tv%T, ALE_CSp) + call set_up_ALE_sponge_field(filename, salin_var, Time, G, GV, US, tv%S, ALE_CSp) endif end subroutine initialize_sponges_file diff --git a/src/parameterizations/lateral/MOM_MEKE.F90 b/src/parameterizations/lateral/MOM_MEKE.F90 index 55a9a71304..9513937c9d 100644 --- a/src/parameterizations/lateral/MOM_MEKE.F90 +++ b/src/parameterizations/lateral/MOM_MEKE.F90 @@ -358,20 +358,20 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, US, CS, hu, h ! Calculate Laplacian of MEKE !$OMP parallel do default(shared) do j=js-1,je+1 ; do I=is-2,ie+1 - ! Here the units of MEKE_uflux are [L2 T-2]. + ! Here the units of MEKE_uflux are [L2 T-2 ~> m2 s-2]. MEKE_uflux(I,j) = ((G%dy_Cu(I,j)*G%IdxCu(I,j)) * G%mask2dCu(I,j)) * & (MEKE%MEKE(i+1,j) - MEKE%MEKE(i,j)) - ! This would have units of [R Z L2 T-2] + ! This would have units of [R Z L2 T-2 ~> kg s-2] ! MEKE_uflux(I,j) = ((G%dy_Cu(I,j)*G%IdxCu(I,j)) * & ! ((2.0*mass(i,j)*mass(i+1,j)) / ((mass(i,j)+mass(i+1,j)) + mass_neglect)) ) * & ! (MEKE%MEKE(i+1,j) - MEKE%MEKE(i,j)) enddo ; enddo !$OMP parallel do default(shared) do J=js-2,je+1 ; do i=is-1,ie+1 - ! Here the units of MEKE_vflux are [L2 T-2]. + ! Here the units of MEKE_vflux are [L2 T-2 ~> m2 s-2]. MEKE_vflux(i,J) = ((G%dx_Cv(i,J)*G%IdyCv(i,J)) * G%mask2dCv(i,J)) * & (MEKE%MEKE(i,j+1) - MEKE%MEKE(i,j)) - ! This would have units of [R Z L2 T-2] + ! This would have units of [R Z L2 T-2 ~> kg s-2] ! MEKE_vflux(i,J) = ((G%dx_Cv(i,J)*G%IdyCv(i,J)) * & ! ((2.0*mass(i,j)*mass(i,j+1)) / ((mass(i,j)+mass(i,j+1)) + mass_neglect)) ) * & ! (MEKE%MEKE(i,j+1) - MEKE%MEKE(i,j)) @@ -436,7 +436,7 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, US, CS, hu, h if (Kh_here*Inv_Kh_max > 0.25) Kh_here = 0.25 / Inv_Kh_max Kh_u(I,j) = Kh_here - ! Here the units of MEKE_uflux and MEKE_vflux are [R Z L4 T-3]. + ! Here the units of MEKE_uflux and MEKE_vflux are [R Z L4 T-3 ~> kg m2 s-3]. MEKE_uflux(I,j) = ((Kh_here * (G%dy_Cu(I,j)*G%IdxCu(I,j))) * & ((2.0*mass(i,j)*mass(i+1,j)) / ((mass(i,j)+mass(i+1,j)) + mass_neglect)) ) * & (MEKE%MEKE(i,j) - MEKE%MEKE(i+1,j)) @@ -451,7 +451,7 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, US, CS, hu, h if (Kh_here*Inv_Kh_max > 0.25) Kh_here = 0.25 / Inv_Kh_max Kh_v(i,J) = Kh_here - ! Here the units of MEKE_uflux and MEKE_vflux are [R Z L4 T-3]. + ! Here the units of MEKE_uflux and MEKE_vflux are [R Z L4 T-3 ~> kg m2 s-3]. MEKE_vflux(i,J) = ((Kh_here * (G%dx_Cv(i,J)*G%IdyCv(i,J))) * & ((2.0*mass(i,j)*mass(i,j+1)) / ((mass(i,j)+mass(i,j+1)) + mass_neglect)) ) * & (MEKE%MEKE(i,j) - MEKE%MEKE(i,j+1)) diff --git a/src/parameterizations/lateral/MOM_hor_visc.F90 b/src/parameterizations/lateral/MOM_hor_visc.F90 index 3c5b25d12d..63811e14d7 100644 --- a/src/parameterizations/lateral/MOM_hor_visc.F90 +++ b/src/parameterizations/lateral/MOM_hor_visc.F90 @@ -85,9 +85,9 @@ module MOM_hor_visc !! answers from the end of 2018. Otherwise, use updated and more robust !! forms of the same expressions. real :: GME_h0 !< The strength of GME tapers quadratically to zero when the bathymetric - !! depth is shallower than GME_H0 [m] + !! depth is shallower than GME_H0 [Z ~> m] real :: GME_efficiency !< The nondimensional prefactor multiplying the GME coefficient [nondim] - real :: GME_limiter !< The absolute maximum value the GME coefficient is allowed to take [m2 s-1]. + real :: GME_limiter !< The absolute maximum value the GME coefficient is allowed to take [L2 T-1 ~> m2 s-1]. real ALLOCABLE_, dimension(NIMEM_,NJMEM_) :: Kh_bg_xx !< The background Laplacian viscosity at h points [L2 T-1 ~> m2 s-1]. @@ -101,9 +101,9 @@ module MOM_hor_visc !< The background biharmonic viscosity at h points [L4 T-1 ~> m4 s-1]. !! The actual viscosity may be the larger of this !! viscosity and the Smagorinsky and Leith viscosities. - real ALLOCABLE_, dimension(NIMEM_,NJMEM_) :: Biharm5_const2_xx +! real ALLOCABLE_, dimension(NIMEM_,NJMEM_) :: Biharm5_const2_xx !< A constant relating the biharmonic viscosity to the - !! square of the velocity shear [m4 s]. This value is + !! square of the velocity shear [L4 T ~> m4 s]. This value is !! set to be the magnitude of the Coriolis terms once the !! velocity differences reach a value of order 1/2 MAXVEL. real ALLOCABLE_, dimension(NIMEM_,NJMEM_) :: reduction_xx @@ -123,9 +123,9 @@ module MOM_hor_visc !< The background biharmonic viscosity at q points [L4 T-1 ~> m4 s-1]. !! The actual viscosity may be the larger of this !! viscosity and the Smagorinsky and Leith viscosities. - real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEMB_PTR_) :: Biharm5_const2_xy +! real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEMB_PTR_) :: Biharm5_const2_xy !< A constant relating the biharmonic viscosity to the - !! square of the velocity shear [m4 s]. This value is + !! square of the velocity shear [L4 T ~> m4 s]. This value is !! set to be the magnitude of the Coriolis terms once the !! velocity differences reach a value of order 1/2 MAXVEL. real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEMB_PTR_) :: reduction_xy @@ -1234,7 +1234,7 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, ! Make a similar calculation as for FrictWork above but accumulating into ! the vertically integrated MEKE source term, and adjusting for any - ! energy loss seen as a reduction in the [biharmonic] frictional source term. + ! energy loss seen as a reduction in the (biharmonic) frictional source term. if (find_FrictWork .and. associated(MEKE)) then ; if (associated(MEKE%mom_src)) then if (k==1) then do j=js,je ; do i=is,ie @@ -2239,9 +2239,9 @@ subroutine hor_visc_end(CS) endif if (CS%Smagorinsky_Ah) then DEALLOC_(CS%Biharm5_const_xx) ; DEALLOC_(CS%Biharm5_const_xy) - if (CS%bound_Coriolis) then - DEALLOC_(CS%Biharm5_const2_xx) ; DEALLOC_(CS%Biharm5_const2_xy) - endif + ! if (CS%bound_Coriolis) then + ! DEALLOC_(CS%Biharm5_const2_xx) ; DEALLOC_(CS%Biharm5_const2_xy) + ! endif endif if (CS%Leith_Ah) then DEALLOC_(CS%Biharm_const_xx) ; DEALLOC_(CS%Biharm_const_xy) diff --git a/src/parameterizations/lateral/MOM_internal_tides.F90 b/src/parameterizations/lateral/MOM_internal_tides.F90 index d6616a5ee0..d9e77f2180 100644 --- a/src/parameterizations/lateral/MOM_internal_tides.F90 +++ b/src/parameterizations/lateral/MOM_internal_tides.F90 @@ -175,7 +175,7 @@ subroutine propagate_int_tide(h, tv, cn, TKE_itidal_input, vel_btTide, Nb, dt, & test real, dimension(SZI_(G),SZJ_(G),CS%nFreq,CS%nMode) :: & tot_En_mode, & ! energy summed over angles only [R Z3 T-2 ~> J m-2] - Ub, & ! near-bottom horizontal velocity of wave (modal) [m s-1] + Ub, & ! near-bottom horizontal velocity of wave (modal) [L T-1 ~> m s-1] Umax ! Maximum horizontal velocity of wave (modal) [L T-1 ~> m s-1] real, dimension(SZI_(G),SZJB_(G)) :: & flux_heat_y, & @@ -191,7 +191,7 @@ subroutine propagate_int_tide(h, tv, cn, TKE_itidal_input, vel_btTide, Nb, dt, & real :: I_D_here ! The inverse of the local depth [Z-1 ~> m-1] real :: I_rho0 ! The inverse fo the Boussinesq density [R-1 ~> m3 kg-1] real :: freq2 ! The frequency squared [T-2 ~> s-2] - real :: c_phase ! The phase speed [m s-1] + real :: c_phase ! The phase speed [L T-1 ~> m s-1] real :: loss_rate ! An energy loss rate [T-1 ~> s-1] real :: Fr2_max real :: cn_subRO ! A tiny wave speed to prevent division by zero [L T-1 ~> m s-1] @@ -772,8 +772,8 @@ subroutine refract(En, cn, freq, dt, G, US, NAngle, use_PPMang) real :: f2 ! The squared Coriolis parameter [T-2 ~> s-2]. real :: favg ! The average Coriolis parameter at a point [T-1 ~> s-1]. real :: df_dy, df_dx ! The x- and y- gradients of the Coriolis parameter [T-1 L-1 ~> s-1 m-1]. - real :: dlnCn_dx ! The x-gradient of the wave speed divided by itself [m-1]. - real :: dlnCn_dy ! The y-gradient of the wave speed divided by itself [m-1]. + real :: dlnCn_dx ! The x-gradient of the wave speed divided by itself [L-1 ~> m-1]. + real :: dlnCn_dy ! The y-gradient of the wave speed divided by itself [L-1 ~> m-1]. real :: Angle_size, dt_Angle_size, angle real :: Ifreq, Kmag2, I_Kmag real :: cn_subRO ! A tiny wave speed to prevent division by zero [L T-1 ~> m s-1] @@ -980,7 +980,7 @@ subroutine propagate(En, cn, freq, dt, G, US, CS, NAngle) cos_angle, sin_angle real, dimension(NAngle) :: & Cgx_av, Cgy_av, dCgx, dCgy - real :: f2 ! The squared Coriolis parameter [s-2]. + real :: f2 ! The squared Coriolis parameter [T-2 ~> s-2]. real :: Angle_size, I_Angle_size, angle real :: Ifreq ! The inverse of the frequency [T ~> s] real :: freq2 ! The frequency squared [T-2 ~> s-2] @@ -1367,7 +1367,7 @@ subroutine propagate_x(En, speed_x, Cgx_av, dCgx, dt, G, US, Nangle, CS, LB) real, dimension(SZI_(G),SZJ_(G)) :: & EnL, EnR ! Left and right face energy densities [R Z3 T-2 ~> J m-2]. real, dimension(SZIB_(G),SZJ_(G)) :: & - flux_x ! The internal wave energy flux [J s-1]. + flux_x ! The internal wave energy flux [J T-1 ~> J s-1]. real, dimension(SZIB_(G)) :: & cg_p, cg_m, flux1, flux2 !real, dimension(SZI_(G),SZJB_(G),Nangle) :: En_m, En_p @@ -1442,7 +1442,7 @@ subroutine propagate_y(En, speed_y, Cgy_av, dCgy, dt, G, US, Nangle, CS, LB) real, dimension(SZI_(G),SZJ_(G)) :: & EnL, EnR ! South and north face energy densities [R Z3 T-2 ~> J m-2]. real, dimension(SZI_(G),SZJB_(G)) :: & - flux_y ! The internal wave energy flux [J s-1]. + flux_y ! The internal wave energy flux [J T-1 ~> J s-1]. real, dimension(SZI_(G)) :: & cg_p, cg_m, flux1, flux2 !real, dimension(SZI_(G),SZJB_(G),Nangle) :: En_m, En_p diff --git a/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 b/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 index 2fc6934de4..710012c837 100644 --- a/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 +++ b/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 @@ -188,10 +188,6 @@ subroutine calc_resoln_function(h, tv, G, GV, US, CS) call wave_speed(h, tv, G, GV, US, CS%cg1, CS%wave_speed_CSp) endif - do j=js,je ; do i=is,ie - CS%cg1(i,j) = US%m_s_to_L_T*CS%cg1(i,j) - enddo ; enddo - call create_group_pass(CS%pass_cg1, CS%cg1, G%Domain) call do_group_pass(CS%pass_cg1, G%Domain) endif @@ -712,8 +708,8 @@ subroutine calc_QG_Leith_viscosity(CS, G, GV, US, h, k, div_xx_dx, div_xx_dy, vo type(ocean_grid_type), intent(in) :: G !< Ocean grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type -! real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(in) :: u !< Zonal flow [m s-1] -! real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(in) :: v !< Meridional flow [m s-1] +! real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(in) :: u !< Zonal flow [L T-1 ~> m s-1] +! real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(in) :: v !< Meridional flow [L T-1 ~> m s-1] real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(inout) :: h !< Layer thickness [H ~> m or kg m-2] integer, intent(in) :: k !< Layer for which to calculate vorticity magnitude real, dimension(SZIB_(G),SZJ_(G)), intent(in) :: div_xx_dx !< x-derivative of horizontal divergence @@ -725,21 +721,16 @@ subroutine calc_QG_Leith_viscosity(CS, G, GV, US, h, k, div_xx_dx, div_xx_dy, vo real, dimension(SZIB_(G),SZJ_(G)), intent(inout) :: vort_xy_dy !< y-derivative of vertical vorticity !! (d/dy(dv/dx - du/dy)) [L-1 T-1 ~> m-1 s-1] ! real, dimension(SZI_(G),SZJ_(G)), intent(out) :: Leith_Kh_h !< Leith Laplacian viscosity - !! at h-points [m2 s-1] + !! at h-points [L2 T-1 ~> m2 s-1] ! real, dimension(SZIB_(G),SZJB_(G)), intent(out) :: Leith_Kh_q !< Leith Laplacian viscosity - !! at q-points [m2 s-1] + !! at q-points [L2 T-1 ~> m2 s-1] ! real, dimension(SZI_(G),SZJ_(G)), intent(out) :: Leith_Ah_h !< Leith bi-harmonic viscosity - !! at h-points [m4 s-1] + !! at h-points [L4 T-1 ~> m4 s-1] ! real, dimension(SZIB_(G),SZJB_(G)), intent(out) :: Leith_Ah_q !< Leith bi-harmonic viscosity - !! at q-points [m4 s-1] + !! at q-points [L4 T-1 ~> m4 s-1] ! Local variables -! real, dimension(SZIB_(G),SZJB_(G)) :: vort_xy, & ! Vertical vorticity (dv/dx - du/dy) [s-1] -! dudy, & ! Meridional shear of zonal velocity [s-1] -! dvdx ! Zonal shear of meridional velocity [s-1] real, dimension(SZI_(G),SZJB_(G)) :: & -! vort_xy_dx, & ! x-derivative of vertical vorticity (d/dx(dv/dx - du/dy)) [L-1 T-1 ~> m-1 s-1] -! div_xx_dy, & ! y-derivative of horizontal divergence (d/dy(du/dx + dv/dy)) [L-1 T-1 ~> m-1 s-1] dslopey_dz, & ! z-derivative of y-slope at v-points [Z-1 ~> m-1] h_at_v, & ! Thickness at v-points [H ~> m or kg m-2] beta_v, & ! Beta at v-points [T-1 L-1 ~> s-1 m-1] @@ -747,16 +738,14 @@ subroutine calc_QG_Leith_viscosity(CS, G, GV, US, h, k, div_xx_dx, div_xx_dy, vo grad_div_mag_v ! Magnitude of divergence gradient at v-points [T-1 L-1 ~> s-1 m-1] real, dimension(SZIB_(G),SZJ_(G)) :: & -! vort_xy_dy, & ! y-derivative of vertical vorticity (d/dy(dv/dx - du/dy)) [L-1 T-1 ~> m-1 s-1] -! div_xx_dx, & ! x-derivative of horizontal divergence (d/dx(du/dx + dv/dy)) [L-1 T-1 ~> m-1 s-1] dslopex_dz, & ! z-derivative of x-slope at u-points [Z-1 ~> m-1] h_at_u, & ! Thickness at u-points [H ~> m or kg m-2] beta_u, & ! Beta at u-points [T-1 L-1 ~> s-1 m-1] grad_vort_mag_u, & ! Magnitude of vorticity gradient at u-points [T-1 L-1 ~> s-1 m-1] grad_div_mag_u ! Magnitude of divergence gradient at u-points [T-1 L-1 ~> s-1 m-1] -! real, dimension(SZI_(G),SZJ_(G)) :: div_xx ! Estimate of horizontal divergence at h-points [s-1] -! real :: mod_Leith, DY_dxBu, DX_dyBu, vert_vort_mag - real :: h_at_slope_above, h_at_slope_below, Ih + real :: h_at_slope_above ! The thickness above [H ~> m or kg m-2] + real :: h_at_slope_below ! The thickness below [H ~> m or kg m-2] + real :: Ih ! The inverse of a combination of thicknesses [H-1 ~> m-1 or m2 kg-1] real :: f ! A copy of the Coriolis parameter [T-1 ~> s-1] integer :: i, j, is, ie, js, je, Isq, Ieq, Jsq, Jeq,nz real :: inv_PI3 @@ -881,7 +870,9 @@ subroutine VarMix_init(Time, G, GV, US, param_file, diag, CS) type(diag_ctrl), target, intent(inout) :: diag !< Diagnostics control structure type(VarMix_CS), pointer :: CS !< Variable mixing coefficients ! Local variables - real :: KhTr_Slope_Cff, KhTh_Slope_Cff, oneOrTwo, N2_filter_depth + real :: KhTr_Slope_Cff, KhTh_Slope_Cff, oneOrTwo + real :: N2_filter_depth ! A depth below which stratification is treated as monotonic when + ! calculating the first-mode wave speed [Z ~> m] real :: KhTr_passivity_coeff real :: absurdly_small_freq ! A miniscule frequency that is used to avoid division by 0 [T-1 ~> s-1]. The ! default value is roughly (pi / (the age of the universe)). @@ -983,7 +974,7 @@ subroutine VarMix_init(Time, G, GV, US, param_file, diag, CS) call get_param(param_file, mdl, "RESOLN_N2_FILTER_DEPTH", N2_filter_depth, & "The depth below which N2 is monotonized to avoid stratification "//& "artifacts from altering the equivalent barotropic mode structure.",& - units="m", default=2000.) + units="m", default=2000., scale=US%m_to_Z) allocate(CS%ebt_struct(isd:ied,jsd:jed,G%ke)) ; CS%ebt_struct(:,:,:) = 0.0 endif @@ -1054,6 +1045,7 @@ subroutine VarMix_init(Time, G, GV, US, param_file, diag, CS) 'Square of Brunt-Vaisala frequency, N^2, at u-points, as used in Visbeck et al.', 's-2') CS%id_N2_v = register_diag_field('ocean_model', 'N2_v', diag%axesCvi, Time, & 'Square of Brunt-Vaisala frequency, N^2, at v-points, as used in Visbeck et al.', 's-2') + !### The units of the next two diagnostics should be 'nondim'. CS%id_S2_u = register_diag_field('ocean_model', 'S2_u', diag%axesCu1, Time, & 'Depth average square of slope magnitude, S^2, at u-points, as used in Visbeck et al.', 's-2') CS%id_S2_v = register_diag_field('ocean_model', 'S2_v', diag%axesCv1, Time, & diff --git a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 index ddaf61e397..a567edb4be 100644 --- a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 +++ b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 @@ -50,7 +50,7 @@ module MOM_thickness_diffuse real :: FGNV_scale !< A coefficient scaling the vertical smoothing term in the !! Ferrari et al., 2010, streamfunction formulation [nondim]. real :: FGNV_c_min !< A minimum wave speed used in the Ferrari et al., 2010, - !! streamfunction formulation [m s-1]. + !! streamfunction formulation [L T-1 ~> m s-1]. real :: N2_floor !< A floor for Brunt-Vasaila frequency in the Ferrari et al., 2010, !! streamfunction formulation [T-2 ~> s-2]. logical :: detangle_interfaces !< If true, add 3-d structured interface height @@ -831,7 +831,7 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV hN2_x_PE(I,j,k) = hN2_u(I,K) if (CS%id_slope_x > 0) CS%diagSlopeX(I,j,k) = Slope - ! Estimate the streamfunction at each interface [m3 s-1]. + ! Estimate the streamfunction at each interface [Z L2 T-1 ~> m3 s-1]. Sfn_unlim_u(I,K) = -((KH_u(I,j,K)*G%dy_Cu(I,j))*US%L_to_Z*Slope) ! Avoid moving dense water upslope from below the level of @@ -1081,7 +1081,7 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV hN2_y_PE(i,J,k) = hN2_v(i,K) if (CS%id_slope_y > 0) CS%diagSlopeY(I,j,k) = Slope - ! Estimate the streamfunction at each interface [m3 s-1]. + ! Estimate the streamfunction at each interface [Z L2 T-1 ~> m3 s-1]. Sfn_unlim_v(i,K) = -((KH_v(i,J,K)*G%dx_Cv(i,J))*US%L_to_Z*Slope) ! Avoid moving dense water upslope from below the level of @@ -1299,8 +1299,8 @@ end subroutine thickness_diffuse_full !> Tridiagonal solver for streamfunction at interfaces subroutine streamfn_solver(nk, c2_h, hN2, sfn) integer, intent(in) :: nk !< Number of layers - real, dimension(nk), intent(in) :: c2_h !< Wave speed squared over thickness in layers [m s-2] - real, dimension(nk+1), intent(in) :: hN2 !< Thickness times N2 at interfaces [m s-2] + real, dimension(nk), intent(in) :: c2_h !< Wave speed squared over thickness in layers [L2 Z-1 T-2 ~> m s-2] + real, dimension(nk+1), intent(in) :: hN2 !< Thickness times N2 at interfaces [L2 Z-1 T-2 ~> m s-2] real, dimension(nk+1), intent(inout) :: sfn !< Streamfunction [Z L2 T-1 ~> m3 s-1] or arbitrary units !! On entry, equals diffusivity times slope. !! On exit, equals the streamfunction. @@ -1830,7 +1830,7 @@ subroutine thickness_diffuse_init(Time, G, GV, US, param_file, diag, CDp, CS) call get_param(param_file, mdl, "FGNV_C_MIN", CS%FGNV_c_min, & "A minium wave speed used in the Ferrari et al., 2010, "//& "streamfunction formulation.", & - default=0., units="m s-1", do_not_log=.not.CS%use_FGNV_streamfn) + default=0., units="m s-1", scale=US%m_s_to_L_T, do_not_log=.not.CS%use_FGNV_streamfn) call get_param(param_file, mdl, "FGNV_STRAT_FLOOR", strat_floor, & "A floor for Brunt-Vasaila frequency in the Ferrari et al., 2010, "//& "streamfunction formulation, expressed as a fraction of planetary "//& diff --git a/src/parameterizations/vertical/MOM_ALE_sponge.F90 b/src/parameterizations/vertical/MOM_ALE_sponge.F90 index dd58368bd3..bdf422bec8 100644 --- a/src/parameterizations/vertical/MOM_ALE_sponge.F90 +++ b/src/parameterizations/vertical/MOM_ALE_sponge.F90 @@ -10,8 +10,8 @@ module MOM_ALE_sponge -! This file is part of MOM6. See LICENSE.md for the license. +! This file is part of MOM6. See LICENSE.md for the license. use MOM_coms, only : sum_across_PEs use MOM_diag_mediator, only : post_data, query_averaging_enabled, register_diag_field use MOM_diag_mediator, only : diag_ctrl @@ -24,7 +24,6 @@ module MOM_ALE_sponge use MOM_remapping, only : remapping_cs, remapping_core_h, initialize_remapping use MOM_unit_scaling, only : unit_scale_type use MOM_verticalGrid, only : verticalGrid_type -! GMM - Planned extension: Support for time varying sponge targets. implicit none ; private @@ -129,7 +128,7 @@ module MOM_ALE_sponge type(remapping_cs) :: remap_cs !< Remapping parameters and work arrays - logical :: new_sponges !< True if using newer sponge code + logical :: time_varying_sponges !< True if using newer sponge code logical :: spongeDataOngrid !< True if the sponge data are on the model horizontal grid end type ALE_sponge_CS @@ -195,7 +194,7 @@ subroutine initialize_ALE_sponge_fixed(Iresttime, G, param_file, CS, data_h, nz_ "PPM reconstruction will also be used within boundary cells.", & default=.false., do_not_log=.true.) - CS%new_sponges = .false. + CS%time_varying_sponges = .false. CS%nz = G%ke CS%isc = G%isc ; CS%iec = G%iec ; CS%jsc = G%jsc ; CS%jec = G%jec CS%isd = G%isd ; CS%ied = G%ied ; CS%jsd = G%jsd ; CS%jed = G%jed @@ -370,7 +369,7 @@ subroutine get_ALE_sponge_thicknesses(G, data_h, sponge_mask, CS) end subroutine get_ALE_sponge_thicknesses -!> This subroutine determines the number of points which are within sponges in this computational +!> This subroutine determines the number of points which are to be restoref in the computational !! domain. Only points that have positive values of Iresttime and which mask2dT indicates are ocean !! points are included in the sponges. subroutine initialize_ALE_sponge_varying(Iresttime, G, param_file, CS) @@ -382,8 +381,6 @@ subroutine initialize_ALE_sponge_varying(Iresttime, G, param_file, CS) type(ALE_sponge_CS), pointer :: CS !< A pointer that is set to point to the control !! structure for this module (in/out). - - ! This include declares and sets the variable "version". #include "version_variable.h" character(len=40) :: mdl = "MOM_sponge" ! This module's name. @@ -394,45 +391,38 @@ subroutine initialize_ALE_sponge_varying(Iresttime, G, param_file, CS) logical :: spongeDataOngrid = .false. integer :: i, j, k, col, total_sponge_cols, total_sponge_cols_u, total_sponge_cols_v character(len=10) :: remapScheme + if (associated(CS)) then call MOM_error(WARNING, "initialize_sponge called with an associated "// & "control structure.") return endif - ! Set default, read and log parameters call log_version(param_file, mdl, version, "") call get_param(param_file, mdl, "SPONGE", use_sponge, & "If true, sponges may be applied anywhere in the domain. "//& "The exact location and properties of those sponges are "//& "specified from MOM_initialization.F90.", default=.false.) - if (.not.use_sponge) return - allocate(CS) - call get_param(param_file, mdl, "SPONGE_UV", CS%sponge_uv, & "Apply sponges in u and v, in addition to tracers.", & default=.false.) - call get_param(param_file, mdl, "REMAPPING_SCHEME", remapScheme, & "This sets the reconstruction scheme used "//& " for vertical remapping for all variables.", & default="PLM", do_not_log=.true.) - call get_param(param_file, mdl, "BOUNDARY_EXTRAPOLATION", bndExtrapolation, & "When defined, a proper high-order reconstruction "//& "scheme is used within boundary cells rather "//& "than PCM. E.g., if PPM is used for remapping, a "//& "PPM reconstruction will also be used within boundary cells.", & default=.false., do_not_log=.true.) - call get_param(param_file, mdl, "SPONGE_DATA_ONGRID", CS%spongeDataOngrid, & "When defined, the incoming sponge data are "//& "assumed to be on the model grid " , & default=.false.) - - CS%new_sponges = .true. + CS%time_varying_sponges = .true. CS%nz = G%ke CS%isc = G%isc ; CS%iec = G%iec ; CS%jsc = G%jsc ; CS%jec = G%jec CS%isd = G%isd ; CS%ied = G%ied ; CS%jsd = G%jsd ; CS%jed = G%jed @@ -444,8 +434,6 @@ subroutine initialize_ALE_sponge_varying(Iresttime, G, param_file, CS) if ((Iresttime(i,j)>0.0) .and. (G%mask2dT(i,j)>0)) & CS%num_col = CS%num_col + 1 enddo ; enddo - - if (CS%num_col > 0) then allocate(CS%Iresttime_col(CS%num_col)) ; CS%Iresttime_col = 0.0 allocate(CS%col_i(CS%num_col)) ; CS%col_i = 0 @@ -460,21 +448,16 @@ subroutine initialize_ALE_sponge_varying(Iresttime, G, param_file, CS) endif enddo ; enddo endif - total_sponge_cols = CS%num_col call sum_across_PEs(total_sponge_cols) ! Call the constructor for remapping control structure call initialize_remapping(CS%remap_cs, remapScheme, boundary_extrapolation=bndExtrapolation) - call log_param(param_file, mdl, "!Total sponge columns at h points", total_sponge_cols, & "The total number of columns where sponges are applied at h points.") - if (CS%sponge_uv) then - allocate(Iresttime_u(G%isdB:G%iedB,G%jsd:G%jed)); Iresttime_u(:,:)=0.0 allocate(Iresttime_v(G%isd:G%ied,G%jsdB:G%jedB)); Iresttime_v(:,:)=0.0 - ! u points CS%num_col_u = 0 ; !CS%fldno_u = 0 do j=CS%jsc,CS%jec; do I=CS%iscB,CS%iecB @@ -482,13 +465,10 @@ subroutine initialize_ALE_sponge_varying(Iresttime, G, param_file, CS) if ((Iresttime_u(I,j)>0.0) .and. (G%mask2dCu(I,j)>0)) & CS%num_col_u = CS%num_col_u + 1 enddo ; enddo - if (CS%num_col_u > 0) then - allocate(CS%Iresttime_col_u(CS%num_col_u)) ; CS%Iresttime_col_u = 0.0 allocate(CS%col_i_u(CS%num_col_u)) ; CS%col_i_u = 0 allocate(CS%col_j_u(CS%num_col_u)) ; CS%col_j_u = 0 - ! pass indices, restoring time to the CS structure col = 1 do j=CS%jsc,CS%jec ; do I=CS%iscB,CS%iecB @@ -498,15 +478,12 @@ subroutine initialize_ALE_sponge_varying(Iresttime, G, param_file, CS) col = col +1 endif enddo ; enddo - ! same for total number of arbritary layers and correspondent data - endif total_sponge_cols_u = CS%num_col_u call sum_across_PEs(total_sponge_cols_u) call log_param(param_file, mdl, "!Total sponge columns at u points", total_sponge_cols_u, & "The total number of columns where sponges are applied at u points.") - ! v points CS%num_col_v = 0 ; !CS%fldno_v = 0 do J=CS%jscB,CS%jecB; do i=CS%isc,CS%iec @@ -514,13 +491,10 @@ subroutine initialize_ALE_sponge_varying(Iresttime, G, param_file, CS) if ((Iresttime_v(i,J)>0.0) .and. (G%mask2dCv(i,J)>0)) & CS%num_col_v = CS%num_col_v + 1 enddo ; enddo - if (CS%num_col_v > 0) then - allocate(CS%Iresttime_col_v(CS%num_col_v)) ; CS%Iresttime_col_v = 0.0 allocate(CS%col_i_v(CS%num_col_v)) ; CS%col_i_v = 0 allocate(CS%col_j_v(CS%num_col_v)) ; CS%col_j_v = 0 - ! pass indices, restoring time to the CS structure col = 1 do J=CS%jscB,CS%jecB ; do i=CS%isc,CS%iec @@ -530,7 +504,6 @@ subroutine initialize_ALE_sponge_varying(Iresttime, G, param_file, CS) col = col +1 endif enddo ; enddo - endif total_sponge_cols_v = CS%num_col_v call sum_across_PEs(total_sponge_cols_v) @@ -594,7 +567,7 @@ end subroutine set_up_ALE_sponge_field_fixed !> This subroutine stores the reference profile at h points for the variable !! whose address is given by filename and fieldname. -subroutine set_up_ALE_sponge_field_varying(filename, fieldname, Time, G, GV, f_ptr, CS) +subroutine set_up_ALE_sponge_field_varying(filename, fieldname, Time, G, GV, US, f_ptr, CS) character(len=*), intent(in) :: filename !< The name of the file with the !! time varying field data character(len=*), intent(in) :: fieldname !< The name of the field in the file @@ -602,6 +575,7 @@ subroutine set_up_ALE_sponge_field_varying(filename, fieldname, Time, G, GV, f_p type(time_type), intent(in) :: Time !< The current model time type(ocean_grid_type), intent(in) :: G !< Grid structure (in). type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & target, intent(in) :: f_ptr !< Pointer to the field to be damped (in). type(ALE_sponge_CS), pointer :: CS !< Sponge control structure (in/out). @@ -617,101 +591,42 @@ subroutine set_up_ALE_sponge_field_varying(filename, fieldname, Time, G, GV, f_p integer, dimension(4) :: fld_sz integer :: nz_data !< the number of vertical levels in this input field character(len=256) :: mesg ! String for error messages - ! Local variables for ALE remapping - real, dimension(:), allocatable :: hsrc ! Source thicknesses [Z ~> m]. real, dimension(:), allocatable :: tmpT1d real :: zTopOfCell, zBottomOfCell ! Heights [Z ~> m]. type(remapping_CS) :: remapCS ! Remapping parameters and work arrays if (.not.associated(CS)) return - - ! Call this in case it was not previously done. + ! initialize time interpolator module call time_interp_external_init() - isd = G%isd; ied = G%ied; jsd = G%jsd; jed = G%jed CS%fldno = CS%fldno + 1 - if (CS%fldno > MAX_FIELDS_) then write(mesg,'("Increase MAX_FIELDS_ to at least ",I3," in MOM_memory.h or decrease & &the number of fields to be damped in the call to & &initialize_sponge." )') CS%fldno call MOM_error(FATAL,"set_up_ALE_sponge_field: "//mesg) endif - - ! get a unique id for this field which will allow us to return an array - ! containing time-interpolated values from an external file corresponding - ! to the current model date. - + ! get a unique time interp id for this field. If sponge data is ongrid, then setup + ! to only read on the computational domain if (CS%spongeDataOngrid) then CS%Ref_val(CS%fldno)%id = init_external_field(filename, fieldname,domain=G%Domain%mpp_domain) else CS%Ref_val(CS%fldno)%id = init_external_field(filename, fieldname) endif - fld_sz(1:4)=-1 fld_sz = get_external_field_size(CS%Ref_val(CS%fldno)%id) nz_data = fld_sz(3) - CS%Ref_val(CS%fldno)%nz_data = nz_data !< each individual sponge field is assumed to reside on a different grid + CS%Ref_val(CS%fldno)%nz_data = nz_data !< individual sponge fields may reside on a different vertical grid CS%Ref_val(CS%fldno)%num_tlevs = fld_sz(4) - - allocate( sp_val(isd:ied,jsd:jed, nz_data) ) - allocate( mask_z(isd:ied,jsd:jed, nz_data) ) - - ! initializes the current reference profile array + ! initializes the target profile array for this field + ! for all columns which will be masked allocate(CS%Ref_val(CS%fldno)%p(nz_data,CS%num_col)) CS%Ref_val(CS%fldno)%p(:,:) = 0.0 allocate( CS%Ref_val(CS%fldno)%h(nz_data,CS%num_col) ) CS%Ref_val(CS%fldno)%h(:,:) = 0.0 - - ! Interpolate external file data to the model grid - ! I am hard-wiring this call to assume that the input grid is zonally re-entrant - ! In the future, this should be generalized using an interface to return the - ! modulo attribute of the zonal axis (mjh). - -! call horiz_interp_and_extrap_tracer(CS%Ref_val(CS%fldno)%id,Time, 1.0,G,sp_val,mask_z,z_in,z_edges_in, & -! missing_value, .true., .false., .false., m_to_Z=US%m_to_Z) - - ! Do not think halo updates are needed (mjh) -! call pass_var(sp_val,G%Domain) -! call pass_var(mask_z,G%Domain) - - ! Done with horizontal interpolation. - ! Now remap to model coordinates - ! First we reserve a work space for reconstructions of the source data - allocate( hsrc(nz_data) ) - allocate( tmpT1d(nz_data) ) - - do col=1,CS%num_col - ! Build the source grid - zTopOfCell = 0. ; zBottomOfCell = 0. ; nPoints = 0; hsrc(:) = 0.0; tmpT1d(:) = -99.9 - do k=1,nz_data - if (mask_z(CS%col_i(col),CS%col_j(col),k) == 1.0) then - zBottomOfCell = -min( z_edges_in(k+1), G%bathyT(CS%col_i(col),CS%col_j(col)) ) -! tmpT1d(k) = sp_val(CS%col_i(col),CS%col_j(col),k) - elseif (k>1) then - zBottomOfCell = -G%bathyT(CS%col_i(col),CS%col_j(col)) -! tmpT1d(k) = tmpT1d(k-1) -! else ! This next block should only ever be reached over land -! tmpT1d(k) = -99.9 - endif - hsrc(k) = zTopOfCell - zBottomOfCell - if (hsrc(k)>0.) nPoints = nPoints + 1 - zTopOfCell = zBottomOfCell ! Bottom becomes top for next value of k - enddo - ! In case data is deeper than model - hsrc(nz_data) = hsrc(nz_data) + ( zTopOfCell + G%bathyT(CS%col_i(col),CS%col_j(col)) ) - CS%Ref_val(CS%fldno)%h(1:nz_data,col) = 0. - CS%Ref_val(CS%fldno)%p(1:nz_data,col) = -1.e24 - CS%Ref_val(CS%fldno)%h(1:nz_data,col) = GV%Z_to_H*hsrc(1:nz_data) -! CS%Ref_val(CS%fldno)%p(1:nz_data,col) = tmpT1d(1:nz_data) - enddo - CS%var(CS%fldno)%p => f_ptr - deallocate( hSrc ) - deallocate( tmpT1d ) - deallocate(sp_val, mask_z) end subroutine set_up_ALE_sponge_field_varying @@ -740,9 +655,7 @@ subroutine set_up_ALE_sponge_vel_field_fixed(u_val, v_val, G, u_ptr, v_ptr, CS) CS%Ref_val_u%p(k,col) = u_val(CS%col_i_u(col),CS%col_j_u(col),k) enddo enddo - CS%var_u%p => u_ptr - allocate(CS%Ref_val_v%p(CS%nz_data,CS%num_col_v)) CS%Ref_val_v%p(:,:) = 0.0 do col=1,CS%num_col_v @@ -750,7 +663,6 @@ subroutine set_up_ALE_sponge_vel_field_fixed(u_val, v_val, G, u_ptr, v_ptr, CS) CS%Ref_val_v%p(k,col) = v_val(CS%col_i_v(col),CS%col_j_v(col),k) enddo enddo - CS%var_v%p => v_ptr end subroutine set_up_ALE_sponge_vel_field_fixed @@ -788,46 +700,36 @@ subroutine set_up_ALE_sponge_vel_field_varying(filename_u, fieldname_u, filename isd = G%isd; ied = G%ied; jsd = G%jsd; jed = G%jed isdB = G%isdB; iedB = G%iedB; jsdB = G%jsdB; jedB = G%jedB - ! get a unique id for this field which will allow us to return an array ! containing time-interpolated values from an external file corresponding ! to the current model date. - CS%Ref_val_u%id = init_external_field(filename_u, fieldname_u) fld_sz(1:4)=-1 fld_sz = get_external_field_size(CS%Ref_val_u%id) CS%Ref_val_u%nz_data = fld_sz(3) CS%Ref_val_u%num_tlevs = fld_sz(4) - CS%Ref_val_v%id = init_external_field(filename_v, fieldname_v) fld_sz(1:4)=-1 fld_sz = get_external_field_size(CS%Ref_val_v%id) CS%Ref_val_v%nz_data = fld_sz(3) CS%Ref_val_v%num_tlevs = fld_sz(4) - allocate( u_val(isdB:iedB,jsd:jed, fld_sz(3)) ) allocate( mask_u(isdB:iedB,jsd:jed, fld_sz(3)) ) allocate( v_val(isd:ied,jsdB:jedB, fld_sz(3)) ) allocate( mask_v(isd:ied,jsdB:jedB, fld_sz(3)) ) - ! Interpolate external file data to the model grid ! I am hard-wiring this call to assume that the input grid is zonally re-entrant ! In the future, this should be generalized using an interface to return the ! modulo attribute of the zonal axis (mjh). - call horiz_interp_and_extrap_tracer(CS%Ref_val_u%id,Time, 1.0,G,u_val,mask_u,z_in,z_edges_in,& missing_value,.true.,.false.,.false., m_to_Z=US%m_to_Z) - !!! TODO: add a velocity interface! (mjh) - ! Interpolate external file data to the model grid ! I am hard-wiring this call to assume that the input grid is zonally re-entrant ! In the future, this should be generalized using an interface to return the ! modulo attribute of the zonal axis (mjh). - call horiz_interp_and_extrap_tracer(CS%Ref_val_v%id,Time, 1.0,G,v_val,mask_v,z_in,z_edges_in, & missing_value,.true.,.false.,.false., m_to_Z=US%m_to_Z) - ! stores the reference profile allocate(CS%Ref_val_u%p(fld_sz(3),CS%num_col_u)) CS%Ref_val_u%p(:,:) = 0.0 @@ -836,9 +738,7 @@ subroutine set_up_ALE_sponge_vel_field_varying(filename_u, fieldname_u, filename CS%Ref_val_u%p(k,col) = u_val(CS%col_i_u(col),CS%col_j_u(col),k) enddo enddo - CS%var_u%p => u_ptr - allocate(CS%Ref_val_v%p(fld_sz(3),CS%num_col_v)) CS%Ref_val_v%p(:,:) = 0.0 do col=1,CS%num_col_v @@ -846,7 +746,6 @@ subroutine set_up_ALE_sponge_vel_field_varying(filename_u, fieldname_u, filename CS%Ref_val_v%p(k,col) = v_val(CS%col_i_v(col),CS%col_j_v(col),k) enddo enddo - CS%var_v%p => v_ptr end subroutine set_up_ALE_sponge_vel_field_varying @@ -873,13 +772,18 @@ subroutine apply_ALE_sponge(h, dt, G, GV, US, CS, Time) real :: hv(SZI_(G), SZJB_(G), SZK_(G)) ! A temporary array for h at v pts real, allocatable, dimension(:,:,:) :: sp_val ! A temporary array for fields real, allocatable, dimension(:,:,:) :: mask_z ! A temporary array for field mask at h pts + real, dimension(:), allocatable :: hsrc ! Source thicknesses [Z ~> m]. + ! Local variables for ALE remapping + real, dimension(:), allocatable :: tmpT1d integer :: c, m, nkmb, i, j, k, is, ie, js, je, nz, nz_data + integer :: col, total_sponge_cols real, allocatable, dimension(:), target :: z_in, z_edges_in real :: missing_value real :: h_neglect, h_neglect_edge + real :: zTopOfCell, zBottomOfCell ! Heights [Z ~> m]. + integer :: nPoints is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke - if (.not.associated(CS)) return if (GV%Boussinesq) then @@ -888,46 +792,57 @@ subroutine apply_ALE_sponge(h, dt, G, GV, US, CS, Time) h_neglect = GV%kg_m2_to_H*1.0e-30 ; h_neglect_edge = GV%kg_m2_to_H*1.0e-10 endif - if (CS%new_sponges) then + if (CS%time_varying_sponges) then if (.not. present(Time)) & call MOM_error(FATAL,"apply_ALE_sponge: No time information provided") - -! Interpolate new grid in time-space do m=1,CS%fldno - - nz_data = CS%Ref_val(m)%nz_data - allocate(sp_val(G%isd:G%ied,G%jsd:G%jed,1:nz_data)) - allocate(mask_z(G%isd:G%ied,G%jsd:G%jed,1:nz_data)) - sp_val(:,:,:)=0.0 - mask_z(:,:,:)=0.0 - - call horiz_interp_and_extrap_tracer(CS%Ref_val(m)%id,Time, 1.0,G,sp_val,mask_z,z_in,z_edges_in, & - missing_value,.true., .false.,.false., m_to_Z=US%m_to_Z,spongeOnGrid=CS%SpongeDataOngrid) - -! call pass_var(sp_val,G%Domain) -! call pass_var(mask_z,G%Domain) - - - do c=1,CS%num_col - i = CS%col_i(c) ; j = CS%col_j(c) - CS%Ref_val(m)%p(1:nz_data,c) = sp_val(i,j,1:nz_data) - do k=2,nz_data -! if (mask_z(i,j,k)==0.) & - if (CS%Ref_val(m)%h(k,c) <= 0.001*GV%m_to_H) & - ! some confusion here about why the masks are not correct returning from horiz_interp - ! reverting to using a minimum thickness criteria - CS%Ref_val(m)%p(k,c) = CS%Ref_val(m)%p(k-1,c) - enddo + nz_data = CS%Ref_val(m)%nz_data + allocate(sp_val(G%isd:G%ied,G%jsd:G%jed,1:nz_data)) + allocate(mask_z(G%isd:G%ied,G%jsd:G%jed,1:nz_data)) + sp_val(:,:,:)=0.0 + mask_z(:,:,:)=0.0 + call horiz_interp_and_extrap_tracer(CS%Ref_val(m)%id,Time, 1.0,G,sp_val,mask_z,z_in,z_edges_in, & + missing_value,.true., .false.,.false.,spongeOnGrid=CS%SpongeDataOngrid, m_to_Z=US%m_to_Z) + allocate( hsrc(nz_data) ) + allocate( tmpT1d(nz_data) ) + do c=1,CS%num_col + i = CS%col_i(c) ; j = CS%col_j(c) + CS%Ref_val(m)%p(1:nz_data,c) = sp_val(i,j,1:nz_data) + ! Build the source grid + zTopOfCell = 0. ; zBottomOfCell = 0. ; nPoints = 0; hsrc(:) = 0.0; tmpT1d(:) = -99.9 + do k=1,nz_data + if (mask_z(CS%col_i(c),CS%col_j(c),k) == 1.0) then + zBottomOfCell = -min( z_edges_in(k+1), G%bathyT(CS%col_i(c),CS%col_j(c)) ) + tmpT1d(k) = sp_val(CS%col_i(c),CS%col_j(c),k) + elseif (k>1) then + zBottomOfCell = -G%bathyT(CS%col_i(c),CS%col_j(c)) + tmpT1d(k) = tmpT1d(k-1) + else ! This next block should only ever be reached over land + tmpT1d(k) = -99.9 + endif + hsrc(k) = zTopOfCell - zBottomOfCell + if (hsrc(k)>0.) nPoints = nPoints + 1 + zTopOfCell = zBottomOfCell ! Bottom becomes top for next value of k + enddo + ! In case data is deeper than model + hsrc(nz_data) = hsrc(nz_data) + ( zTopOfCell + G%bathyT(CS%col_i(c),CS%col_j(c)) ) + CS%Ref_val(CS%fldno)%h(1:nz_data,c) = GV%Z_to_H*hsrc(1:nz_data) + CS%Ref_val(CS%fldno)%p(1:nz_data,c) = tmpT1d(1:nz_data) + do k=2,nz_data + ! if (mask_z(i,j,k)==0.) & + if (CS%Ref_val(m)%h(k,c) <= 0.001*GV%m_to_H) & + ! some confusion here about why the masks are not correct returning from horiz_interp + ! reverting to using a minimum thickness criteria + CS%Ref_val(m)%p(k,c) = CS%Ref_val(m)%p(k-1,c) + enddo enddo - - deallocate(sp_val, mask_z) + deallocate(sp_val, mask_z, hsrc, tmpT1d) enddo else nz_data = CS%nz_data endif allocate(tmp_val2(nz_data)) - do m=1,CS%fldno do c=1,CS%num_col ! c is an index for the next 3 lines but a multiplier for the rest of the loop @@ -936,7 +851,7 @@ subroutine apply_ALE_sponge(h, dt, G, GV, US, CS, Time) damp = dt * CS%Iresttime_col(c) I1pdamp = 1.0 / (1.0 + damp) tmp_val2(1:nz_data) = CS%Ref_val(m)%p(1:nz_data,c) - if (CS%new_sponges) then + if (CS%time_varying_sponges) then call remapping_core_h(CS%remap_cs, nz_data, CS%Ref_val(m)%h(1:nz_data,c), tmp_val2, & CS%nz, h(i,j,:), tmp_val1, h_neglect, h_neglect_edge) else @@ -945,7 +860,6 @@ subroutine apply_ALE_sponge(h, dt, G, GV, US, CS, Time) endif !Backward Euler method CS%var(m)%p(i,j,1:CS%nz) = I1pdamp * (CS%var(m)%p(i,j,1:CS%nz) + tmp_val1 * damp) - enddo enddo @@ -957,13 +871,11 @@ subroutine apply_ALE_sponge(h, dt, G, GV, US, CS, Time) !enddo if (CS%sponge_uv) then - ! u points do j=CS%jsc,CS%jec; do I=CS%iscB,CS%iecB; do k=1,nz hu(I,j,k) = 0.5 * (h(i,j,k) + h(i+1,j,k)) enddo ; enddo ; enddo - - if (CS%new_sponges) then + if (CS%time_varying_sponges) then if (.not. present(Time)) & call MOM_error(FATAL,"apply_ALE_sponge: No time information provided") @@ -973,10 +885,8 @@ subroutine apply_ALE_sponge(h, dt, G, GV, US, CS, Time) ! Interpolate from the external horizontal grid and in time call horiz_interp_and_extrap_tracer(CS%Ref_val_u%id,Time, 1.0,G,sp_val,mask_z,z_in,z_edges_in, & missing_value, .true., .false., .false., m_to_Z=US%m_to_Z) - ! call pass_var(sp_val,G%Domain) ! call pass_var(mask_z,G%Domain) - do c=1,CS%num_col ! c is an index for the next 3 lines but a multiplier for the rest of the loop ! Therefore we use c as per C code and increment the index where necessary. @@ -1013,9 +923,9 @@ subroutine apply_ALE_sponge(h, dt, G, GV, US, CS, Time) i = CS%col_i_u(c) ; j = CS%col_j_u(c) damp = dt * CS%Iresttime_col_u(c) I1pdamp = 1.0 / (1.0 + damp) - if (CS%new_sponges) nz_data = CS%Ref_val(m)%nz_data + if (CS%time_varying_sponges) nz_data = CS%Ref_val(m)%nz_data tmp_val2(1:nz_data) = CS%Ref_val_u%p(1:nz_data,c) - if (CS%new_sponges) then + if (CS%time_varying_sponges) then call remapping_core_h(CS%remap_cs, nz_data, CS%Ref_val_u%h(:,c), tmp_val2, & CS%nz, hu(i,j,:), tmp_val1, h_neglect, h_neglect_edge) else @@ -1036,7 +946,7 @@ subroutine apply_ALE_sponge(h, dt, G, GV, US, CS, Time) damp = dt * CS%Iresttime_col_v(c) I1pdamp = 1.0 / (1.0 + damp) tmp_val2(1:nz_data) = CS%Ref_val_v%p(1:nz_data,c) - if (CS%new_sponges) then + if (CS%time_varying_sponges) then call remapping_core_h(CS%remap_cs, CS%nz_data, CS%Ref_val_v%h(:,c), tmp_val2, & CS%nz, hv(i,j,:), tmp_val1, h_neglect, h_neglect_edge) else diff --git a/src/parameterizations/vertical/MOM_diabatic_aux.F90 b/src/parameterizations/vertical/MOM_diabatic_aux.F90 index 3e2588db8c..fe1ae86ee6 100644 --- a/src/parameterizations/vertical/MOM_diabatic_aux.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_aux.F90 @@ -867,7 +867,7 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t real, intent(in) :: evap_CFL_limit !< The largest fraction of a layer that !! can be evaporated in one time-step [nondim]. real, intent(in) :: minimum_forcing_depth !< The smallest depth over which - !! heat and freshwater fluxes is applied [m]. + !! heat and freshwater fluxes is applied [H ~> m or kg m-2]. real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & optional, intent(out) :: cTKE !< Turbulent kinetic energy requirement to mix !! forcing through each layer [R Z3 T-2 ~> J m-2] @@ -915,7 +915,7 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t T2d, & ! A 2-d copy of the layer temperatures [degC] pen_TKE_2d, & ! The TKE required to homogenize the heating by shortwave radiation within ! a layer [R Z3 T-2 ~> J m-2] - dSV_dT_2d ! The partial derivative of specific volume with temperature [R-1 degC-1] + dSV_dT_2d ! The partial derivative of specific volume with temperature [R-1 degC-1 ~> m3 kg-1 degC-1] real, dimension(SZI_(G)) :: & netPen_rate ! The surface penetrative shortwave heating rate summed over all bands ! [degC H T-1 ~> degC m s-1 or degC kg m-2 s-1] @@ -1168,7 +1168,7 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t ! Place forcing into this layer if this layer has nontrivial thickness. ! For layers thin relative to 1/IforcingDepthScale, then distribute ! forcing into deeper layers. - IforcingDepthScale = 1. / max(GV%H_subroundoff, minimum_forcing_depth*GV%m_to_H - netMassOut(i) ) + IforcingDepthScale = 1. / max(GV%H_subroundoff, minimum_forcing_depth - netMassOut(i) ) ! fractionOfForcing = 1.0, unless h2d is less than IforcingDepthScale. fractionOfForcing = min(1.0, h2d(i,k)*IforcingDepthScale) diff --git a/src/parameterizations/vertical/MOM_diabatic_driver.F90 b/src/parameterizations/vertical/MOM_diabatic_driver.F90 index f7dcc5fd4f..f65a0e8eae 100644 --- a/src/parameterizations/vertical/MOM_diabatic_driver.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_driver.F90 @@ -148,8 +148,8 @@ module MOM_diabatic_driver real :: Kd_min_tr !< A minimal diffusivity that should always be !! applied to tracers, especially in massless layers !! near the bottom [Z2 T-1 ~> m2 s-1]. - real :: minimum_forcing_depth = 0.001 !< The smallest depth over which heat and freshwater - !! fluxes are applied [m]. + real :: minimum_forcing_depth !< The smallest depth over which heat and freshwater + !! fluxes are applied [H ~> m or kg m-2]. real :: evap_CFL_limit = 0.8 !< The largest fraction of a layer that can be !! evaporated in one time-step [nondim]. integer :: halo_TS_diff = 0 !< The temperature, salinity and thickness halo size that @@ -258,7 +258,6 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & G, GV, US, CS, WAVES) type(ocean_grid_type), intent(inout) :: G !< ocean grid structure type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(inout) :: u !< zonal velocity [L T-1 ~> m s-1] real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(inout) :: v !< meridional velocity [L T-1 ~> m s-1] real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(inout) :: h !< thickness [H ~> m or kg m-2] @@ -274,6 +273,7 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & type(cont_diag_ptrs), intent(inout) :: CDp !< points to terms in continuity equations real, intent(in) :: dt !< time increment [T ~> s] type(time_type), intent(in) :: Time_end !< Time at the end of the interval + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(diabatic_CS), pointer :: CS !< module control structure type(Wave_parameters_CS), optional, pointer :: Waves !< Surface gravity waves @@ -535,7 +535,7 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim real :: c1(SZIB_(G),SZK_(G)) ! tridiagonal solver. real :: Ent_int ! The diffusive entrainment rate at an interface [H ~> m or kg m-2] - real :: Idt ! The inverse time step [s-1] + real :: Idt ! The inverse time step [T-1 ~> s-1] integer :: dir_flag ! An integer encoding the directions in which to do halo updates. logical :: showCallTree ! If true, show the call tree @@ -1133,10 +1133,10 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim ! For passive tracers, the changes in thickness due to boundary fluxes has yet to be applied ! so hold should be h_orig - call call_tracer_column_fns(h_prebound, h, ea_s, eb_s, fluxes, Hml, US%T_to_s*dt, G, GV, tv, & + call call_tracer_column_fns(h_prebound, h, ea_s, eb_s, fluxes, Hml, dt, G, GV, US, tv, & CS%optics, CS%tracer_flow_CSp, CS%debug, & evap_CFL_limit = CS%evap_CFL_limit, & - minimum_forcing_depth = CS%minimum_forcing_depth) + minimum_forcing_depth=CS%minimum_forcing_depth) elseif (associated(visc%Kd_extra_S)) then ! extra diffusivity for passive tracers @@ -1162,16 +1162,16 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim enddo ; enddo ; enddo ! For passive tracers, the changes in thickness due to boundary fluxes has yet to be applied - call call_tracer_column_fns(h_prebound, h, eatr, ebtr, fluxes, Hml, US%T_to_s*dt, G, GV, tv, & + call call_tracer_column_fns(h_prebound, h, eatr, ebtr, fluxes, Hml, dt, G, GV, US, tv, & CS%optics, CS%tracer_flow_CSp, CS%debug,& evap_CFL_limit = CS%evap_CFL_limit, & - minimum_forcing_depth = CS%minimum_forcing_depth) + minimum_forcing_depth=CS%minimum_forcing_depth) else ! For passive tracers, the changes in thickness due to boundary fluxes has yet to be applied - call call_tracer_column_fns(h_prebound, h, eatr, ebtr, fluxes, Hml, US%T_to_s*dt, G, GV, tv, & + call call_tracer_column_fns(h_prebound, h, eatr, ebtr, fluxes, Hml, dt, G, GV, US, tv, & CS%optics, CS%tracer_flow_CSp, CS%debug, & evap_CFL_limit = CS%evap_CFL_limit, & - minimum_forcing_depth = CS%minimum_forcing_depth) + minimum_forcing_depth=CS%minimum_forcing_depth) endif ! (CS%mix_boundary_tracers) call cpu_clock_end(id_clock_tracers) @@ -1318,7 +1318,7 @@ subroutine diabatic_ALE(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, real :: c1(SZIB_(G),SZK_(G)) ! tridiagonal solver. real :: Ent_int ! The diffusive entrainment rate at an interface [H ~> m or kg m-2] - real :: Idt ! The inverse time step [s-1] + real :: Idt ! The inverse time step [T-1 ~> s-1] integer :: dir_flag ! An integer encoding the directions in which to do halo updates. logical :: showCallTree ! If true, show the call tree @@ -1807,10 +1807,10 @@ subroutine diabatic_ALE(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, ! For passive tracers, the changes in thickness due to boundary fluxes has yet to be applied ! so hold should be h_orig - call call_tracer_column_fns(h_prebound, h, ea_s, eb_s, fluxes, Hml, US%T_to_s*dt, G, GV, tv, & + call call_tracer_column_fns(h_prebound, h, ea_s, eb_s, fluxes, Hml, dt, G, GV, US, tv, & CS%optics, CS%tracer_flow_CSp, CS%debug, & evap_CFL_limit = CS%evap_CFL_limit, & - minimum_forcing_depth = CS%minimum_forcing_depth) + minimum_forcing_depth=CS%minimum_forcing_depth) elseif (associated(visc%Kd_extra_S)) then ! extra diffusivity for passive tracers @@ -1831,16 +1831,16 @@ subroutine diabatic_ALE(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, enddo ; enddo ; enddo ! For passive tracers, the changes in thickness due to boundary fluxes has yet to be applied - call call_tracer_column_fns(h_prebound, h, eatr, ebtr, fluxes, Hml, US%T_to_s*dt, G, GV, tv, & + call call_tracer_column_fns(h_prebound, h, eatr, ebtr, fluxes, Hml, dt, G, GV, US, tv, & CS%optics, CS%tracer_flow_CSp, CS%debug,& evap_CFL_limit = CS%evap_CFL_limit, & - minimum_forcing_depth = CS%minimum_forcing_depth) + minimum_forcing_depth=CS%minimum_forcing_depth) else ! For passive tracers, the changes in thickness due to boundary fluxes has yet to be applied - call call_tracer_column_fns(h_prebound, h, eatr, ebtr, fluxes, Hml, US%T_to_s*dt, G, GV, tv, & + call call_tracer_column_fns(h_prebound, h, eatr, ebtr, fluxes, Hml, dt, G, GV, US, tv, & CS%optics, CS%tracer_flow_CSp, CS%debug, & evap_CFL_limit = CS%evap_CFL_limit, & - minimum_forcing_depth = CS%minimum_forcing_depth) + minimum_forcing_depth=CS%minimum_forcing_depth) endif ! (CS%mix_boundary_tracers) call cpu_clock_end(id_clock_tracers) @@ -2007,7 +2007,7 @@ subroutine layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_e real :: Ent_int ! The diffusive entrainment rate at an interface [H ~> m or kg m-2] real :: dt_mix ! The amount of time over which to apply mixing [T ~> s] - real :: Idt ! The inverse time step [s-1] + real :: Idt ! The inverse time step [T-1 ~> s-1] real :: Idt_accel ! The inverse time step times rescaling factors [T-1 ~> s-1] integer :: dir_flag ! An integer encoding the directions in which to do halo updates. @@ -2642,7 +2642,7 @@ subroutine layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_e enddo - call call_tracer_column_fns(hold, h, eatr, ebtr, fluxes, Hml, US%T_to_s*dt, G, GV, tv, & + call call_tracer_column_fns(hold, h, eatr, ebtr, fluxes, Hml, dt, G, GV, US, tv, & CS%optics, CS%tracer_flow_CSp, CS%debug) elseif (associated(visc%Kd_extra_S)) then ! extra diffusivity for passive tracers @@ -2663,11 +2663,11 @@ subroutine layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_e eatr(i,j,k) = ea(i,j,k) + add_ent enddo ; enddo ; enddo - call call_tracer_column_fns(hold, h, eatr, ebtr, fluxes, Hml, US%T_to_s*dt, G, GV, tv, & + call call_tracer_column_fns(hold, h, eatr, ebtr, fluxes, Hml, dt, G, GV, US, tv, & CS%optics, CS%tracer_flow_CSp, CS%debug) else - call call_tracer_column_fns(hold, h, ea, eb, fluxes, Hml, US%T_to_s*dt, G, GV, tv, & + call call_tracer_column_fns(hold, h, ea, eb, fluxes, Hml, dt, G, GV, US, tv, & CS%optics, CS%tracer_flow_CSp, CS%debug) endif ! (CS%mix_boundary_tracers) @@ -2869,7 +2869,7 @@ subroutine extract_diabatic_member(CS, opacity_CSp, optics_CSp, & real, optional, intent( out) :: evap_CFL_limit ! m or kg m-2]. type(diabatic_aux_CS), optional, pointer :: diabatic_aux_CSp !< A pointer to be set to the diabatic_aux !! control structure @@ -2885,21 +2885,22 @@ subroutine extract_diabatic_member(CS, opacity_CSp, optics_CSp, & end subroutine extract_diabatic_member !> Routine called for adiabatic physics -subroutine adiabatic(h, tv, fluxes, dt, G, GV, CS) +subroutine adiabatic(h, tv, fluxes, dt, G, GV, US, CS) type(ocean_grid_type), intent(inout) :: G !< ocean grid structure real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & intent(inout) :: h !< thickness [H ~> m or kg m-2] type(thermo_var_ptrs), intent(inout) :: tv !< points to thermodynamic fields type(forcing), intent(inout) :: fluxes !< boundary fluxes - real, intent(in) :: dt !< time step [s] + real, intent(in) :: dt !< time step [T ~> s] type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(diabatic_CS), pointer :: CS !< module control structure real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: zeros ! An array of zeros. zeros(:,:,:) = 0.0 - call call_tracer_column_fns(h, h, zeros, zeros, fluxes, zeros(:,:,1), dt, G, GV, tv, & + call call_tracer_column_fns(h, h, zeros, zeros, fluxes, zeros(:,:,1), dt, G, GV, US, tv, & CS%optics, CS%tracer_flow_CSp, CS%debug) end subroutine adiabatic @@ -3348,7 +3349,7 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di "only takes effect when near-surface layers become thin "//& "relative to this scale, in which case the forcing tendencies "//& "scaled down by distributing the forcing over this depth scale.", & - units="m", default=0.001) + units="m", default=0.001, scale=GV%m_to_H) call get_param(param_file, mdl, "EVAP_CFL_LIMIT", CS%evap_CFL_limit, & "The largest fraction of a layer than can be lost to forcing "//& "(e.g. evaporation, sea-ice formation) in one time-step. The unused "//& diff --git a/src/parameterizations/vertical/MOM_energetic_PBL.F90 b/src/parameterizations/vertical/MOM_energetic_PBL.F90 index 8ae83ca615..f8c20682ee 100644 --- a/src/parameterizations/vertical/MOM_energetic_PBL.F90 +++ b/src/parameterizations/vertical/MOM_energetic_PBL.F90 @@ -554,7 +554,7 @@ subroutine ePBL_column(h, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, abs !! forcing that has been applied to each layer !! [R Z3 T-2 ~> J m-2]. real, intent(in) :: B_flux !< The surface buoyancy flux [Z2 T-3 ~> m2 s-3] - real, intent(in) :: absf !< The absolute value of the Coriolis parameter [T-1]. + real, intent(in) :: absf !< The absolute value of the Coriolis parameter [T-1 ~> s-1]. real, intent(in) :: u_star !< The surface friction velocity [Z T-1 ~> m s-1]. real, intent(in) :: u_star_mean !< The surface friction velocity without any !! contribution from unresolved gustiness [Z T-1 ~> m s-1]. diff --git a/src/tracer/DOME_tracer.F90 b/src/tracer/DOME_tracer.F90 index debfd6f4b1..f8bc58c8d8 100644 --- a/src/tracer/DOME_tracer.F90 +++ b/src/tracer/DOME_tracer.F90 @@ -17,7 +17,7 @@ module DOME_tracer use MOM_time_manager, only : time_type use MOM_tracer_registry, only : register_tracer, tracer_registry_type use MOM_tracer_diabatic, only : tracer_vertdiff, applyTracerBoundaryFluxesInOut -use MOM_unit_scaling, only : unit_scale_type +use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : surface use MOM_verticalGrid, only : verticalGrid_type @@ -143,7 +143,7 @@ subroutine initialize_DOME_tracer(restart, day, G, GV, US, h, diag, OBC, CS, & sponge_CSp, param_file) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type logical, intent(in) :: restart !< .true. if the fields have already !! been read from a restart file. type(time_type), target, intent(in) :: day !< Time of the start of the run. @@ -171,7 +171,6 @@ subroutine initialize_DOME_tracer(restart, day, G, GV, US, h, diag, OBC, CS, & real, pointer :: tr_ptr(:,:,:) => NULL() real :: PI ! 3.1415926... calculated as 4*atan(1) real :: tr_y ! Initial zonally uniform tracer concentrations. - real :: dist2 ! The distance squared from a line [m2]. real :: h_neglect ! A thickness that is so small it is usually lost ! in roundoff and can be neglected [H ~> m or kg m-2]. real :: e(SZK_(G)+1), e_top, e_bot ! Heights [Z ~> m]. @@ -283,7 +282,7 @@ end subroutine initialize_DOME_tracer !! !! The arguments to this subroutine are redundant in that !! h_new(k) = h_old(k) + ea(k) - eb(k-1) + eb(k) - ea(k+1) -subroutine DOME_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, CS, & +subroutine DOME_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, US, CS, & evap_CFL_limit, minimum_forcing_depth) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure @@ -301,13 +300,14 @@ subroutine DOME_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, !! added [H ~> m or kg m-2]. type(forcing), intent(in) :: fluxes !< A structure containing pointers to thermodynamic !! and tracer forcing fields. Unused fields have NULL ptrs. - real, intent(in) :: dt !< The amount of time covered by this call [s] + real, intent(in) :: dt !< The amount of time covered by this call [T ~> s] + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(DOME_tracer_CS), pointer :: CS !< The control structure returned by a previous !! call to DOME_register_tracer. real, optional, intent(in) :: evap_CFL_limit !< Limit on the fraction of the water that can !! be fluxed out of the top layer in a timestep [nondim] real, optional, intent(in) :: minimum_forcing_depth !< The smallest depth over which - !! fluxes can be applied [m] + !! fluxes can be applied [H ~> m or kg m-2] ! Local variables real :: b1(SZI_(G)) ! b1 and c1 are variables used by the @@ -323,8 +323,8 @@ subroutine DOME_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, do k=1,nz ;do j=js,je ; do i=is,ie h_work(i,j,k) = h_old(i,j,k) enddo ; enddo ; enddo - call applyTracerBoundaryFluxesInOut(G, GV, CS%tr(:,:,:,m) , dt, fluxes, h_work, & - evap_CFL_limit, minimum_forcing_depth) + call applyTracerBoundaryFluxesInOut(G, GV, CS%tr(:,:,:,m), dt, fluxes, h_work, & + evap_CFL_limit, minimum_forcing_depth) call tracer_vertdiff(h_work, ea, eb, dt, CS%tr(:,:,:,m), G, GV) enddo else diff --git a/src/tracer/ISOMIP_tracer.F90 b/src/tracer/ISOMIP_tracer.F90 index deb8669451..c2b189917c 100644 --- a/src/tracer/ISOMIP_tracer.F90 +++ b/src/tracer/ISOMIP_tracer.F90 @@ -10,6 +10,7 @@ module ISOMIP_tracer ! Original sample tracer package by Robert Hallberg, 2002 ! Adapted to the ISOMIP test case by Gustavo Marques, May 2016 +use MOM_coms, only : max_across_PEs use MOM_diag_mediator, only : diag_ctrl use MOM_error_handler, only : MOM_error, FATAL, WARNING use MOM_file_parser, only : get_param, log_param, log_version, param_file_type @@ -17,15 +18,15 @@ module ISOMIP_tracer use MOM_hor_index, only : hor_index_type use MOM_grid, only : ocean_grid_type use MOM_io, only : file_exists, MOM_read_data, slasher, vardesc, var_desc, query_vardesc +use MOM_open_boundary, only : ocean_OBC_type use MOM_restart, only : MOM_restart_CS use MOM_ALE_sponge, only : set_up_ALE_sponge_field, ALE_sponge_CS use MOM_time_manager, only : time_type use MOM_tracer_registry, only : register_tracer, tracer_registry_type use MOM_tracer_diabatic, only : tracer_vertdiff, applyTracerBoundaryFluxesInOut +use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : surface -use MOM_open_boundary, only : ocean_OBC_type use MOM_verticalGrid, only : verticalGrid_type -use MOM_coms, only : max_across_PEs use coupler_types_mod, only : coupler_type_set_data, ind_csurf use atmos_ocean_fluxes_mod, only : aof_set_coupler_flux @@ -176,9 +177,6 @@ subroutine initialize_ISOMIP_tracer(restart, day, G, GV, h, diag, OBC, CS, & character(len=48) :: flux_units ! The units for tracer fluxes, usually ! kg(tracer) kg(water)-1 m3 s-1 or kg(tracer) s-1. real, pointer :: tr_ptr(:,:,:) => NULL() - real :: PI ! 3.1415926... calculated as 4*atan(1) - real :: tr_y ! Initial zonally uniform tracer concentrations. - real :: dist2 ! The distance squared from a line [m2]. real :: h_neglect ! A thickness that is so small it is usually lost ! in roundoff and can be neglected [H ~> m or kg m-2]. real :: e(SZK_(G)+1), e_top, e_bot, d_tr @@ -247,7 +245,7 @@ end subroutine initialize_ISOMIP_tracer !> This subroutine applies diapycnal diffusion, including the surface boundary !! conditions and any other column tracer physics or chemistry to the tracers from this file. -subroutine ISOMIP_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, CS, & +subroutine ISOMIP_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, US, CS, & evap_CFL_limit, minimum_forcing_depth) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure @@ -265,13 +263,14 @@ subroutine ISOMIP_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, G !! added [H ~> m or kg m-2]. type(forcing), intent(in) :: fluxes !< A structure containing pointers to thermodynamic !! and tracer forcing fields. Unused fields have NULL ptrs. - real, intent(in) :: dt !< The amount of time covered by this call [s] + real, intent(in) :: dt !< The amount of time covered by this call [T ~> s] + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(ISOMIP_tracer_CS), pointer :: CS !< The control structure returned by a previous !! call to ISOMIP_register_tracer. real, optional, intent(in) :: evap_CFL_limit !< Limit on the fraction of the water that can !! be fluxed out of the top layer in a timestep [nondim] real, optional, intent(in) :: minimum_forcing_depth !< The smallest depth over which - !! fluxes can be applied [m] + !! fluxes can be applied [H ~> m or kg m-2] ! The arguments to this subroutine are redundant in that ! h_new(k) = h_old(k) + ea(k) - eb(k-1) + eb(k) - ea(k+1) @@ -312,8 +311,8 @@ subroutine ISOMIP_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, G do k=1,nz ;do j=js,je ; do i=is,ie h_work(i,j,k) = h_old(i,j,k) enddo ; enddo ; enddo - call applyTracerBoundaryFluxesInOut(G, GV, CS%tr(:,:,:,m) , dt, fluxes, h_work, & - evap_CFL_limit, minimum_forcing_depth) + call applyTracerBoundaryFluxesInOut(G, GV, CS%tr(:,:,:,m), dt, fluxes, h_work, & + evap_CFL_limit, minimum_forcing_depth) call tracer_vertdiff(h_work, ea, eb, dt, CS%tr(:,:,:,m), G, GV) enddo else diff --git a/src/tracer/MOM_OCMIP2_CFC.F90 b/src/tracer/MOM_OCMIP2_CFC.F90 index a5fc04fc06..3aa250b8bb 100644 --- a/src/tracer/MOM_OCMIP2_CFC.F90 +++ b/src/tracer/MOM_OCMIP2_CFC.F90 @@ -406,7 +406,7 @@ end subroutine init_tracer_CFC !> This subroutine applies diapycnal diffusion, souces and sinks and any other column !! tracer physics or chemistry to the OCMIP2 CFC tracers. !! CFCs are relatively simple, as they are passive tracers with only a surface flux as a source. -subroutine OCMIP2_CFC_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, CS, & +subroutine OCMIP2_CFC_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, US, CS, & evap_CFL_limit, minimum_forcing_depth) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure @@ -424,13 +424,14 @@ subroutine OCMIP2_CFC_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, CS !! added [H ~> m or kg m-2]. type(forcing), intent(in) :: fluxes !< A structure containing pointers to thermodynamic !! and tracer forcing fields. Unused fields have NULL ptrs. - real, intent(in) :: dt !< The amount of time covered by this call [s] + real, intent(in) :: dt !< The amount of time covered by this call [T ~> s] + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(OCMIP2_CFC_CS), pointer :: CS !< The control structure returned by a !! previous call to register_OCMIP2_CFC. real, optional, intent(in) :: evap_CFL_limit !< Limit on the fraction of the water that can !! be fluxed out of the top layer in a timestep [nondim] real, optional, intent(in) :: minimum_forcing_depth !< The smallest depth over which - !! fluxes can be applied [m] + !! fluxes can be applied [H ~> m or kg m-2] ! This subroutine applies diapycnal diffusion and any other column ! tracer physics or chemistry to the tracers from this file. ! CFCs are relatively simple, as they are passive tracers. with only a surface @@ -458,11 +459,11 @@ subroutine OCMIP2_CFC_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, CS ! These two calls unpack the fluxes from the input arrays. ! The -GV%Rho0 changes the sign convention of the flux and changes the units - ! of the flux from [Conc. m s-1] to [Conc. kg m-2 s-1]. - call coupler_type_extract_data(fluxes%tr_fluxes, CS%ind_cfc_11_flux, ind_flux, & - CFC11_flux, -G%US%R_to_kg_m3*GV%Rho0, idim=idim, jdim=jdim) - call coupler_type_extract_data(fluxes%tr_fluxes, CS%ind_cfc_12_flux, ind_flux, & - CFC12_flux, -G%US%R_to_kg_m3*GV%Rho0, idim=idim, jdim=jdim) + ! of the flux from [Conc. m s-1] to [Conc. kg m-2 T-1]. + call coupler_type_extract_data(fluxes%tr_fluxes, CS%ind_cfc_11_flux, ind_flux, CFC11_flux, & + scale_factor=-G%US%R_to_kg_m3*GV%Rho0*US%T_to_s, idim=idim, jdim=jdim) + call coupler_type_extract_data(fluxes%tr_fluxes, CS%ind_cfc_12_flux, ind_flux, CFC12_flux, & + scale_factor=-G%US%R_to_kg_m3*GV%Rho0*US%T_to_s, idim=idim, jdim=jdim) ! Use a tridiagonal solver to determine the concentrations after the ! surface source is applied and diapycnal advection and diffusion occurs. @@ -471,14 +472,14 @@ subroutine OCMIP2_CFC_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, CS h_work(i,j,k) = h_old(i,j,k) enddo ; enddo ; enddo call applyTracerBoundaryFluxesInOut(G, GV, CFC11, dt, fluxes, h_work, & - evap_CFL_limit, minimum_forcing_depth) + evap_CFL_limit, minimum_forcing_depth) call tracer_vertdiff(h_work, ea, eb, dt, CFC11, G, GV, sfc_flux=CFC11_flux) do k=1,nz ;do j=js,je ; do i=is,ie h_work(i,j,k) = h_old(i,j,k) enddo ; enddo ; enddo call applyTracerBoundaryFluxesInOut(G, GV, CFC12, dt, fluxes, h_work, & - evap_CFL_limit, minimum_forcing_depth) + evap_CFL_limit, minimum_forcing_depth) call tracer_vertdiff(h_work, ea, eb, dt, CFC12, G, GV, sfc_flux=CFC12_flux) else call tracer_vertdiff(h_old, ea, eb, dt, CFC11, G, GV, sfc_flux=CFC11_flux) diff --git a/src/tracer/MOM_generic_tracer.F90 b/src/tracer/MOM_generic_tracer.F90 index 28f31c6fa1..3cd81de052 100644 --- a/src/tracer/MOM_generic_tracer.F90 +++ b/src/tracer/MOM_generic_tracer.F90 @@ -410,7 +410,8 @@ subroutine MOM_generic_tracer_column_physics(h_old, h_new, ea, eb, fluxes, Hml, real, optional, intent(in) :: evap_CFL_limit !< Limits how much water can be fluxed out of !! the top layer Stored previously in diabatic CS. real, optional, intent(in) :: minimum_forcing_depth !< The smallest depth over which fluxes - !! can be applied Stored previously in diabatic CS. + !! can be applied [H ~> m or kg m-2] + ! Stored previously in diabatic CS. ! The arguments to this subroutine are redundant in that ! h_new(k) = h_old(k) + ea(k) - eb(k-1) + eb(k) - ea(k+1) @@ -507,8 +508,8 @@ subroutine MOM_generic_tracer_column_physics(h_old, h_new, ea, eb, fluxes, Hml, do k=1,nk ;do j=jsc,jec ; do i=isc,iec h_work(i,j,k) = h_old(i,j,k) enddo ; enddo ; enddo - call applyTracerBoundaryFluxesInOut(G, GV, g_tracer%field(:,:,:,1), dt, fluxes, h_work, & - evap_CFL_limit, minimum_forcing_depth) + call applyTracerBoundaryFluxesInOut(G, GV, g_tracer%field(:,:,:,1), G%US%s_to_T*dt, & + fluxes, h_work, evap_CFL_limit, minimum_forcing_depth) endif !traverse the linked list till hit NULL @@ -542,7 +543,6 @@ subroutine MOM_generic_tracer_column_physics(h_old, h_new, ea, eb, fluxes, Hml, call g_tracer_set_csdiag(CS%diag) #endif - end subroutine MOM_generic_tracer_column_physics !> This subroutine calculates mass-weighted integral on the PE either diff --git a/src/tracer/MOM_offline_aux.F90 b/src/tracer/MOM_offline_aux.F90 index d553af730d..0900598589 100644 --- a/src/tracer/MOM_offline_aux.F90 +++ b/src/tracer/MOM_offline_aux.F90 @@ -294,7 +294,7 @@ subroutine distribute_residual_uh_barotropic(G, GV, hvol, uh) endif ! Calculate and check that column integrated transports match the original to ! within the tolerance limit - uh_neglect = GV%Angstrom_H*min(G%US%L_to_m**2*G%areaT(i,j),G%US%L_to_m**2*G%areaT(i+1,j)) + uh_neglect = GV%Angstrom_H*G%US%L_to_m**2 * min(G%areaT(i,j), G%areaT(i+1,j)) if ( abs(sum(uh2d(I,:))-uh2d_sum(I)) > uh_neglect) & call MOM_error(WARNING,"Column integral of uh does not match after "//& "barotropic redistribution") @@ -364,7 +364,7 @@ subroutine distribute_residual_vh_barotropic(G, GV, hvol, vh) endif ! Calculate and check that column integrated transports match the original to ! within the tolerance limit - vh_neglect = GV%Angstrom_H*min(G%US%L_to_m**2*G%areaT(i,j),G%US%L_to_m**2*G%areaT(i,j+1)) + vh_neglect = GV%Angstrom_H*G%US%L_to_m**2 * min(G%areaT(i,j), G%areaT(i,j+1)) if ( abs(sum(vh2d(J,:))-vh2d_sum(J)) > vh_neglect) then call MOM_error(WARNING,"Column integral of vh does not match after "//& "barotropic redistribution") @@ -460,7 +460,7 @@ subroutine distribute_residual_uh_upwards(G, GV, hvol, uh) ! Calculate and check that column integrated transports match the original to ! within the tolerance limit - uh_neglect = GV%Angstrom_H*min(G%US%L_to_m**2*G%areaT(i,j),G%US%L_to_m**2*G%areaT(i+1,j)) + uh_neglect = GV%Angstrom_H*G%US%L_to_m**2 * min(G%areaT(i,j), G%areaT(i+1,j)) if (abs(uh_col - sum(uh2d(I,:)))>uh_neglect) then call MOM_error(WARNING,"Column integral of uh does not match after "//& "upwards redistribution") @@ -558,7 +558,7 @@ subroutine distribute_residual_vh_upwards(G, GV, hvol, vh) ! Calculate and check that column integrated transports match the original to ! within the tolerance limit - vh_neglect = GV%Angstrom_H*min(G%US%L_to_m**2*G%areaT(i,j),G%US%L_to_m**2*G%areaT(i,j+1)) + vh_neglect = GV%Angstrom_H*G%US%L_to_m**2 * min(G%areaT(i,j), G%areaT(i,j+1)) if ( ABS(vh_col-SUM(vh2d(J,:))) > vh_neglect) then call MOM_error(WARNING,"Column integral of vh does not match after "//& "upwards redistribution") diff --git a/src/tracer/MOM_offline_main.F90 b/src/tracer/MOM_offline_main.F90 index 52ad380273..7da25d6841 100644 --- a/src/tracer/MOM_offline_main.F90 +++ b/src/tracer/MOM_offline_main.F90 @@ -116,10 +116,14 @@ module MOM_offline_main integer :: num_off_iter !< Number of advection iterations per offline step integer :: num_vert_iter !< Number of vertical iterations per offline step integer :: off_ale_mod !< Sets how frequently the ALE step is done during the advection - real :: dt_offline !< Timestep used for offline tracers [s] - real :: dt_offline_vertical !< Timestep used for calls to tracer vertical physics [s] - real :: evap_CFL_limit !< Copied from diabatic_CS controlling how tracers follow freshwater fluxes - real :: minimum_forcing_depth !< Copied from diabatic_CS controlling how tracers follow freshwater fluxes + real :: dt_offline !< Timestep used for offline tracers [T ~> s] + real :: dt_offline_vertical !< Timestep used for calls to tracer vertical physics [T ~> s] + real :: evap_CFL_limit !< Limit on the fraction of the water that can be fluxed out of the top + !! layer in a timestep [nondim]. This is Copied from diabatic_CS controlling + !! how tracers follow freshwater fluxes + real :: minimum_forcing_depth !< The smallest depth over which fluxes can be applied [H ~> m or kg m-2]. + !! This is copied from diabatic_CS controlling how tracers follow freshwater fluxes + real :: Kd_max !< Runtime parameter specifying the maximum value of vertical diffusivity real :: min_residual !< The minimum amount of total mass flux before exiting the main advection routine !>@{ Diagnostic manager IDs for some fields that may be of interest when doing offline transport @@ -242,7 +246,10 @@ subroutine offline_advection_ale(fluxes, Time_start, time_interval, CS, id_clock integer :: isv, iev, jsv, jev ! The valid range of the indices. integer :: IsdB, IedB, JsdB, JedB logical :: z_first, x_before_y - real :: evap_CFL_limit, minimum_forcing_depth, dt_iter, dt_offline + real :: evap_CFL_limit ! Limit on the fraction of the water that can be fluxed out of the + ! top layer in a timestep [nondim] + real :: minimum_forcing_depth ! The smallest depth over which fluxes can be applied [H ~> m or kg m-2] + real :: dt_iter ! The timestep to use for each iteration [T ~> s] integer :: nstocks real :: stock_values(MAX_FIELDS_) @@ -260,13 +267,12 @@ subroutine offline_advection_ale(fluxes, Time_start, time_interval, CS, id_clock isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB - dt_offline = CS%dt_offline evap_CFL_limit = CS%evap_CFL_limit minimum_forcing_depth = CS%minimum_forcing_depth niter = CS%num_off_iter Inum_iter = 1./real(niter) - dt_iter = dt_offline*Inum_iter + dt_iter = CS%dt_offline*Inum_iter ! Initialize working arrays h_new(:,:,:) = 0.0 @@ -706,7 +712,7 @@ subroutine offline_diabatic_ale(fluxes, Time_start, Time_end, CS, h_pre, eatr, e enddo ; enddo do k=2,nz ; do j=js,je ; do i=is,ie hval=1.0/(CS%GV%H_subroundoff + 0.5*(h_pre(i,j,k-1) + h_pre(i,j,k))) - eatr(i,j,k) = (CS%GV%m_to_H**2) * CS%dt_offline_vertical * hval * CS%Kd(i,j,k) + eatr(i,j,k) = (CS%GV%m_to_H**2*CS%US%T_to_s) * CS%dt_offline_vertical * hval * CS%Kd(i,j,k) ebtr(i,j,k-1) = eatr(i,j,k) enddo ; enddo ; enddo do j=js,je ; do i=is,ie @@ -726,8 +732,8 @@ subroutine offline_diabatic_ale(fluxes, Time_start, Time_end, CS, h_pre, eatr, e ! Note that tracerBoundaryFluxesInOut within this subroutine should NOT be called ! as the freshwater fluxes have already been accounted for - call call_tracer_column_fns(h_pre, h_pre, eatr, ebtr, fluxes, CS%MLD, CS%dt_offline_vertical, CS%G, CS%GV, & - CS%tv, CS%optics, CS%tracer_flow_CSp, CS%debug) + call call_tracer_column_fns(h_pre, h_pre, eatr, ebtr, fluxes, CS%MLD, CS%dt_offline_vertical, & + CS%G, CS%GV, CS%US, CS%tv, CS%optics, CS%tracer_flow_CSp, CS%debug) if (CS%diurnal_SW .and. CS%read_sw) then fluxes%sw(:,:) = sw @@ -871,19 +877,23 @@ subroutine offline_advection_layer(fluxes, Time_start, time_interval, CS, h_pre, temp_old, salt_old, & temp_mean, salt_mean, & zero_3dh ! - integer :: niter, iter - real :: Inum_iter, dt_iter - logical :: converged + integer :: niter, iter + real :: Inum_iter + real :: dt_iter ! The timestep of each iteration [T ~> s] + logical :: converged character(len=160) :: mesg ! The text of an error message integer :: i, j, k, m, is, ie, js, je, isd, ied, jsd, jed, nz integer :: isv, iev, jsv, jev ! The valid range of the indices. integer :: IsdB, IedB, JsdB, JedB logical :: z_first, x_before_y + G => CS%G ; GV => CS%GV is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB + dt_iter = CS%US%s_to_T * time_interval / real(max(1, CS%num_off_iter)) + do iter=1,CS%num_off_iter do k = 1, nz ; do j=js-1,je+1 ; do i=is-1,ie+1 @@ -907,7 +917,7 @@ subroutine offline_advection_layer(fluxes, Time_start, time_interval, CS, h_pre, ! First do vertical advection call update_h_vertical_flux(G, GV, eatr_sub, ebtr_sub, h_pre, h_new) call call_tracer_column_fns(h_pre, h_new, eatr_sub, ebtr_sub, & - fluxes, CS%mld, dt_iter, G, GV, CS%tv, CS%optics, CS%tracer_flow_CSp, CS%debug) + fluxes, CS%mld, dt_iter, G, GV, CS%US, CS%tv, CS%optics, CS%tracer_flow_CSp, CS%debug) ! We are now done with the vertical mass transports, so now h_new is h_sub do k = 1, nz ; do j=js-1,je+1 ; do i=is-1,ie+1 h_pre(i,j,k) = h_new(i,j,k) @@ -947,7 +957,7 @@ subroutine offline_advection_layer(fluxes, Time_start, time_interval, CS, h_pre, ! Second vertical advection call update_h_vertical_flux(G, GV, eatr_sub, ebtr_sub, h_pre, h_new) call call_tracer_column_fns(h_pre, h_new, eatr_sub, ebtr_sub, & - fluxes, CS%mld, dt_iter, G, GV, CS%tv, CS%optics, CS%tracer_flow_CSp, CS%debug) + fluxes, CS%mld, dt_iter, G, GV, CS%US, CS%tv, CS%optics, CS%tracer_flow_CSp, CS%debug) ! We are now done with the vertical mass transports, so now h_new is h_sub do k = 1, nz ; do i=is-1,ie+1 ; do j=js-1,je+1 h_pre(i,j,k) = h_new(i,j,k) @@ -1203,9 +1213,9 @@ subroutine extract_offline_main(CS, uhtr, vhtr, eatr, ebtr, h_end, accumulated_t !### Why are the following variables integers? integer, optional, pointer :: accumulated_time !< Length of time accumulated in the !! current offline interval [s] - integer, optional, intent( out) :: dt_offline !< Timestep used for offline tracers [s] - integer, optional, intent( out) :: dt_offline_vertical !< Timestep used for calls to tracer - !! vertical physics [s] + real, optional, intent( out) :: dt_offline !< Timestep used for offline tracers [T ~> s] + real, optional, intent( out) :: dt_offline_vertical !< Timestep used for calls to tracer + !! vertical physics [T ~> s] logical, optional, intent( out) :: skip_diffusion !< Skips horizontal diffusion of tracers ! Pointers to 3d members @@ -1320,11 +1330,11 @@ subroutine offline_transport_init(param_file, CS, diabatic_CSp, G, GV, US) call get_param(param_file, mdl, "NK_INPUT", CS%nk_input, & "Number of vertical levels in offline input files", default = nz) call get_param(param_file, mdl, "DT_OFFLINE", CS%dt_offline, & - "Length of time between reading in of input fields", fail_if_missing = .true.) + "Length of time between reading in of input fields", units='s', scale=US%s_to_T, fail_if_missing = .true.) call get_param(param_file, mdl, "DT_OFFLINE_VERTICAL", CS%dt_offline_vertical, & "Length of the offline timestep for tracer column sources/sinks " //& "This should be set to the length of the coupling timestep for " //& - "tracers which need shortwave fluxes", fail_if_missing = .true.) + "tracers which need shortwave fluxes", units="s", scale=US%s_to_T, fail_if_missing = .true.) call get_param(param_file, mdl, "START_INDEX", CS%start_index, & "Which time index to start from", default=1) call get_param(param_file, mdl, "FIELDS_ARE_OFFSET", CS%fields_are_offset, & diff --git a/src/tracer/MOM_tracer_advect.F90 b/src/tracer/MOM_tracer_advect.F90 index 164ba483b6..e050933dc2 100644 --- a/src/tracer/MOM_tracer_advect.F90 +++ b/src/tracer/MOM_tracer_advect.F90 @@ -28,7 +28,7 @@ module MOM_tracer_advect !> Control structure for this module type, public :: tracer_advect_CS ; private - real :: dt !< The baroclinic dynamics time step [s]. + real :: dt !< The baroclinic dynamics time step [T ~> s]. type(diag_ctrl), pointer :: diag !< A structure that is used to regulate the !< timing of diagnostic output. logical :: debug !< If true, write verbose checksums for debugging purposes. @@ -661,10 +661,10 @@ subroutine advect_x(Tr, hprev, uhr, uh_neglect, OBC, domore_u, ntr, Idt, & ! diagnostics if (associated(Tr(m)%ad_x)) then ; do i=is,ie ; if (do_i(i)) then - Tr(m)%ad_x(I,j,k) = Tr(m)%ad_x(I,j,k) + US%L_to_m**2*flux_x(I,m)*Idt + Tr(m)%ad_x(I,j,k) = Tr(m)%ad_x(I,j,k) + flux_x(I,m)*Idt endif ; enddo ; endif if (associated(Tr(m)%ad2d_x)) then ; do i=is,ie ; if (do_i(i)) then - Tr(m)%ad2d_x(I,j) = Tr(m)%ad2d_x(I,j) + US%L_to_m**2*flux_x(I,m)*Idt + Tr(m)%ad2d_x(I,j) = Tr(m)%ad2d_x(I,j) + flux_x(I,m)*Idt endif ; enddo ; endif ! diagnose convergence of flux_x (do not use the Ihnew(i) part of the logic). @@ -1030,10 +1030,10 @@ subroutine advect_y(Tr, hprev, vhr, vh_neglect, OBC, domore_v, ntr, Idt, & ! diagnostics if (associated(Tr(m)%ad_y)) then ; do i=is,ie ; if (do_i(i)) then - Tr(m)%ad_y(i,J,k) = Tr(m)%ad_y(i,J,k) + US%L_to_m**2*flux_y(i,m,J)*Idt + Tr(m)%ad_y(i,J,k) = Tr(m)%ad_y(i,J,k) + flux_y(i,m,J)*Idt endif ; enddo ; endif if (associated(Tr(m)%ad2d_y)) then ; do i=is,ie ; if (do_i(i)) then - Tr(m)%ad2d_y(i,J) = Tr(m)%ad2d_y(i,J) + US%L_to_m**2*flux_y(i,m,J)*Idt + Tr(m)%ad2d_y(i,J) = Tr(m)%ad2d_y(i,J) + flux_y(i,m,J)*Idt endif ; enddo ; endif ! diagnose convergence of flux_y and add to convergence of flux_x. diff --git a/src/tracer/MOM_tracer_diabatic.F90 b/src/tracer/MOM_tracer_diabatic.F90 index 276742905c..ec7c025db0 100644 --- a/src/tracer/MOM_tracer_diabatic.F90 +++ b/src/tracer/MOM_tracer_diabatic.F90 @@ -231,14 +231,14 @@ subroutine applyTracerBoundaryFluxesInOut(G, GV, Tr, dt, fluxes, h, evap_CFL_lim type(ocean_grid_type), intent(in ) :: G !< Grid structure type(verticalGrid_type), intent(in ) :: GV !< ocean vertical grid structure real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(inout) :: Tr !< Tracer concentration on T-cell - real, intent(in ) :: dt !< Time-step over which forcing is applied [s] + real, intent(in ) :: dt !< Time-step over which forcing is applied [T ~> s] type(forcing), intent(in ) :: fluxes !< Surface fluxes container real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(inout) :: h !< Layer thickness [H ~> m or kg m-2] real, intent(in ) :: evap_CFL_limit !< Limit on the fraction of the !! water that can be fluxed out of the top !! layer in a timestep [nondim] real, intent(in ) :: minimum_forcing_depth !< The smallest depth over - !! which fluxes can be applied [m] + !! which fluxes can be applied [H ~> m or kg m-2] real, dimension(SZI_(G),SZJ_(G)), optional, intent(in ) :: in_flux_optional !< The total time-integrated !! amount of tracer that enters with freshwater real, dimension(SZI_(G),SZJ_(G)), optional, intent(in) :: out_flux_optional !< The total time-integrated @@ -248,7 +248,7 @@ subroutine applyTracerBoundaryFluxesInOut(G, GV, Tr, dt, fluxes, h, evap_CFL_lim integer, parameter :: maxGroundings = 5 integer :: numberOfGroundings, iGround(maxGroundings), jGround(maxGroundings) - real :: H_limit_fluxes, IforcingDepthScale, Idt + real :: H_limit_fluxes, IforcingDepthScale real :: dThickness, dTracer real :: fractionOfForcing, hOld, Ithickness real :: RivermixConst ! A constant used in implementing river mixing [Pa s]. @@ -292,13 +292,12 @@ subroutine applyTracerBoundaryFluxesInOut(G, GV, Tr, dt, fluxes, h, evap_CFL_lim update_h = .true. endif - Idt = 1.0/dt numberOfGroundings = 0 !$OMP parallel do default(none) shared(is,ie,js,je,nz,h,Tr,G,GV,fluxes,dt, & !$OMP IforcingDepthScale,minimum_forcing_depth, & !$OMP numberOfGroundings,iGround,jGround,update_h, & -!$OMP in_flux,out_flux,hGrounding,Idt,evap_CFL_limit) & +!$OMP in_flux,out_flux,hGrounding,evap_CFL_limit) & !$OMP private(h2d,Tr2d,netMassInOut,netMassOut, & !$OMP in_flux_1d,out_flux_1d,fractionOfForcing, & !$OMP dThickness,dTracer,hOld,Ithickness, & @@ -367,7 +366,7 @@ subroutine applyTracerBoundaryFluxesInOut(G, GV, Tr, dt, fluxes, h, evap_CFL_lim ! Place forcing into this layer if this layer has nontrivial thickness. ! For layers thin relative to 1/IforcingDepthScale, then distribute ! forcing into deeper layers. - IforcingDepthScale = 1. / max(GV%H_subroundoff, minimum_forcing_depth*GV%m_to_H - netMassOut(i) ) + IforcingDepthScale = 1. / max(GV%H_subroundoff, minimum_forcing_depth - netMassOut(i) ) ! fractionOfForcing = 1.0, unless h2d is less than IforcingDepthScale. fractionOfForcing = min(1.0, h2d(i,k)*IforcingDepthScale) diff --git a/src/tracer/MOM_tracer_flow_control.F90 b/src/tracer/MOM_tracer_flow_control.F90 index d937f27d92..5a176cd3f9 100644 --- a/src/tracer/MOM_tracer_flow_control.F90 +++ b/src/tracer/MOM_tracer_flow_control.F90 @@ -143,9 +143,11 @@ subroutine call_tracer_flux_init(verbosity) end subroutine call_tracer_flux_init -!> The following 5 subroutines and associated definitions provide the -!! machinery to register and call the subroutines that initialize -!! tracers and apply vertical column processes to tracers. +! The following 5 subroutines and associated definitions provide the machinery to register and call +! the subroutines that initialize tracers and apply vertical column processes to tracers. + +!> This subroutine determines which tracer packages are to be used and does the calls to +!! register their tracers to be advected, diffused, and read from restarts. subroutine call_tracer_register(HI, GV, US, param_file, CS, tr_Reg, restart_CS) type(hor_index_type), intent(in) :: HI !< A horizontal index type structure. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. @@ -159,18 +161,10 @@ subroutine call_tracer_register(HI, GV, US, param_file, CS, tr_Reg, restart_CS) !! advection and diffusion module. type(MOM_restart_CS), pointer :: restart_CS !< A pointer to the restart control !! structure. -! Arguments: HI - A horizontal index type structure. -! (in) GV - The ocean's vertical grid structure. -! (in) param_file - A structure indicating the open file to parse for -! model parameter values. -! (in/out) CS - A pointer that is set to point to the control structure -! for this module -! (in/out) tr_Reg - A pointer that is set to point to the control structure -! for the tracer advection and diffusion module. -! (in) restart_CS - A pointer to the restart control structure. - -! This include declares and sets the variable "version". -#include "version_variable.h" + + + ! This include declares and sets the variable "version". +# include "version_variable.h" character(len=40) :: mdl = "MOM_tracer_flow_control" ! This module's name. if (associated(CS)) then @@ -251,7 +245,7 @@ subroutine call_tracer_register(HI, GV, US, param_file, CS, tr_Reg, restart_CS) register_dye_tracer(HI, GV, US, param_file, CS%dye_tracer_CSp, & tr_Reg, restart_CS) if (CS%use_oil) CS%use_oil = & - register_oil_tracer(HI, GV, param_file, CS%oil_tracer_CSp, & + register_oil_tracer(HI, GV, US, param_file, CS%oil_tracer_CSp, & tr_Reg, restart_CS) if (CS%use_advection_test_tracer) CS%use_advection_test_tracer = & register_advection_test_tracer(HI, GV, param_file, CS%advection_test_tracer_CSp, & @@ -408,7 +402,7 @@ subroutine call_tracer_set_forcing(state, fluxes, day_start, day_interval, G, CS end subroutine call_tracer_set_forcing !> This subroutine calls all registered tracer column physics subroutines. -subroutine call_tracer_column_fns(h_old, h_new, ea, eb, fluxes, Hml, dt, G, GV, tv, optics, CS, & +subroutine call_tracer_column_fns(h_old, h_new, ea, eb, fluxes, Hml, dt, G, GV, US, tv, optics, CS, & debug, evap_CFL_limit, minimum_forcing_depth) real, dimension(NIMEM_,NJMEM_,NKMEM_), intent(in) :: h_old !< Layer thickness before entrainment !! [H ~> m or kg m-2]. @@ -425,10 +419,11 @@ subroutine call_tracer_column_fns(h_old, h_new, ea, eb, fluxes, Hml, dt, G, GV, !! Unused fields have NULL ptrs. real, dimension(NIMEM_,NJMEM_), intent(in) :: Hml !< Mixed layer depth [H ~> m or kg m-2] real, intent(in) :: dt !< The amount of time covered by this - !! call [s] + !! call [T ~> s] type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid !! structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various !! thermodynamic variables. type(optics_type), pointer :: optics !< The structure containing optical @@ -451,68 +446,68 @@ subroutine call_tracer_column_fns(h_old, h_new, ea, eb, fluxes, Hml, dt, G, GV, ! Add calls to tracer column functions here. if (CS%use_USER_tracer_example) & call tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, & - G, GV, CS%USER_tracer_example_CSp) + G, GV, US, CS%USER_tracer_example_CSp) if (CS%use_DOME_tracer) & call DOME_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, & - G, GV, CS%DOME_tracer_CSp, & + G, GV, US, CS%DOME_tracer_CSp, & evap_CFL_limit=evap_CFL_limit, & minimum_forcing_depth=minimum_forcing_depth) if (CS%use_ISOMIP_tracer) & call ISOMIP_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, & - G, GV, CS%ISOMIP_tracer_CSp, & + G, GV, US, CS%ISOMIP_tracer_CSp, & evap_CFL_limit=evap_CFL_limit, & minimum_forcing_depth=minimum_forcing_depth) if (CS%use_RGC_tracer) & call RGC_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, & - G, GV, CS%RGC_tracer_CSp, & + G, GV, US, CS%RGC_tracer_CSp, & evap_CFL_limit=evap_CFL_limit, & minimum_forcing_depth=minimum_forcing_depth) if (CS%use_ideal_age) & call ideal_age_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, & - G, GV, CS%ideal_age_tracer_CSp, & + G, GV, US, CS%ideal_age_tracer_CSp, & evap_CFL_limit=evap_CFL_limit, & minimum_forcing_depth=minimum_forcing_depth) if (CS%use_regional_dyes) & call dye_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, & - G, GV, CS%dye_tracer_CSp, & + G, GV, US, CS%dye_tracer_CSp, & evap_CFL_limit=evap_CFL_limit, & minimum_forcing_depth=minimum_forcing_depth) if (CS%use_oil) & call oil_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, & - G, GV, CS%oil_tracer_CSp, tv, & + G, GV, US, CS%oil_tracer_CSp, tv, & evap_CFL_limit=evap_CFL_limit, & minimum_forcing_depth=minimum_forcing_depth) if (CS%use_advection_test_tracer) & call advection_test_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, & - G, GV, CS%advection_test_tracer_CSp, & + G, GV, US, CS%advection_test_tracer_CSp, & evap_CFL_limit=evap_CFL_limit, & minimum_forcing_depth=minimum_forcing_depth) if (CS%use_OCMIP2_CFC) & call OCMIP2_CFC_column_physics(h_old, h_new, ea, eb, fluxes, dt, & - G, GV, CS%OCMIP2_CFC_CSp, & + G, GV, US, CS%OCMIP2_CFC_CSp, & evap_CFL_limit=evap_CFL_limit, & minimum_forcing_depth=minimum_forcing_depth) #ifdef _USE_GENERIC_TRACER if (CS%use_MOM_generic_tracer) & - call MOM_generic_tracer_column_physics(h_old, h_new, ea, eb, fluxes, Hml, dt, & + call MOM_generic_tracer_column_physics(h_old, h_new, ea, eb, fluxes, Hml, US%T_to_s*dt, & G, GV, CS%MOM_generic_tracer_CSp, tv, optics, & evap_CFL_limit=evap_CFL_limit, & minimum_forcing_depth=minimum_forcing_depth) #endif if (CS%use_pseudo_salt_tracer) & call pseudo_salt_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, & - G, GV, CS%pseudo_salt_tracer_CSp, tv, debug,& + G, GV, US, CS%pseudo_salt_tracer_CSp, tv, debug, & evap_CFL_limit=evap_CFL_limit, & minimum_forcing_depth=minimum_forcing_depth) if (CS%use_boundary_impulse_tracer) & call boundary_impulse_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, & - G, GV, CS%boundary_impulse_tracer_CSp, tv, debug,& + G, GV, US, CS%boundary_impulse_tracer_CSp, tv, debug, & evap_CFL_limit=evap_CFL_limit, & minimum_forcing_depth=minimum_forcing_depth) if (CS%use_dyed_obc_tracer) & call dyed_obc_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, & - G, GV, CS%dyed_obc_tracer_CSp, & + G, GV, US, CS%dyed_obc_tracer_CSp, & evap_CFL_limit=evap_CFL_limit, & minimum_forcing_depth=minimum_forcing_depth) @@ -520,46 +515,45 @@ subroutine call_tracer_column_fns(h_old, h_new, ea, eb, fluxes, Hml, dt, G, GV, else ! Apply tracer surface fluxes using ea on the first layer if (CS%use_USER_tracer_example) & call tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, & - G, GV, CS%USER_tracer_example_CSp) + G, GV, US, CS%USER_tracer_example_CSp) if (CS%use_DOME_tracer) & call DOME_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, & - G, GV, CS%DOME_tracer_CSp) + G, GV, US, CS%DOME_tracer_CSp) if (CS%use_ISOMIP_tracer) & call ISOMIP_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, & - G, GV, CS%ISOMIP_tracer_CSp) + G, GV, US, CS%ISOMIP_tracer_CSp) if (CS%use_RGC_tracer) & call RGC_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, & - G, GV, CS%RGC_tracer_CSp) + G, GV, US, CS%RGC_tracer_CSp) if (CS%use_ideal_age) & call ideal_age_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, & - G, GV, CS%ideal_age_tracer_CSp) + G, GV, US, CS%ideal_age_tracer_CSp) if (CS%use_regional_dyes) & call dye_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, & - G, GV, CS%dye_tracer_CSp) + G, GV, US, CS%dye_tracer_CSp) if (CS%use_oil) & call oil_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, & - G, GV, CS%oil_tracer_CSp, tv) + G, GV, US, CS%oil_tracer_CSp, tv) if (CS%use_advection_test_tracer) & call advection_test_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, & - G, GV, CS%advection_test_tracer_CSp) + G, GV, US, CS%advection_test_tracer_CSp) if (CS%use_OCMIP2_CFC) & call OCMIP2_CFC_column_physics(h_old, h_new, ea, eb, fluxes, dt, & - G, GV, CS%OCMIP2_CFC_CSp) + G, GV, US, CS%OCMIP2_CFC_CSp) #ifdef _USE_GENERIC_TRACER if (CS%use_MOM_generic_tracer) & - call MOM_generic_tracer_column_physics(h_old, h_new, ea, eb, fluxes, Hml, dt, & + call MOM_generic_tracer_column_physics(h_old, h_new, ea, eb, fluxes, Hml, US%T_to_s*dt, & G, GV, CS%MOM_generic_tracer_CSp, tv, optics) #endif if (CS%use_pseudo_salt_tracer) & call pseudo_salt_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, & - G, GV, CS%pseudo_salt_tracer_CSp, tv, debug) + G, GV, US, CS%pseudo_salt_tracer_CSp, tv, debug) if (CS%use_boundary_impulse_tracer) & call boundary_impulse_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, & - G, GV, CS%boundary_impulse_tracer_CSp, tv, debug) + G, GV, US, CS%boundary_impulse_tracer_CSp, tv, debug) if (CS%use_dyed_obc_tracer) & call dyed_obc_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, & - G, GV, CS%dyed_obc_tracer_CSp) - + G, GV, US, CS%dyed_obc_tracer_CSp) endif diff --git a/src/tracer/MOM_tracer_hor_diff.F90 b/src/tracer/MOM_tracer_hor_diff.F90 index 3dd89881b2..2d42483c49 100644 --- a/src/tracer/MOM_tracer_hor_diff.F90 +++ b/src/tracer/MOM_tracer_hor_diff.F90 @@ -139,7 +139,7 @@ subroutine tracer_hordiff(h, dt, MEKE, VarMix, G, GV, US, CS, Reg, tv, do_online Kh_u ! Tracer mixing coefficient at u-points [L2 T-1 ~> m2 s-1]. real, dimension(SZI_(G),SZJB_(G)) :: & khdt_y, & ! The value of Khtr*dt times the open face width divided by - ! the distance between adjacent tracer points [L2]. + ! the distance between adjacent tracer points [L2 ~> m2]. Coef_y, & ! The coefficients relating meridional tracer differences ! to time-integrated fluxes [H L2 ~> m3 or kg]. Kh_v ! Tracer mixing coefficient at u-points [L2 T-1 ~> m2 s-1]. diff --git a/src/tracer/MOM_tracer_registry.F90 b/src/tracer/MOM_tracer_registry.F90 index 5f32fb104e..01d15fb887 100644 --- a/src/tracer/MOM_tracer_registry.F90 +++ b/src/tracer/MOM_tracer_registry.F90 @@ -45,33 +45,33 @@ module MOM_tracer_registry ! !! specified in OBCs through v-face of cell real, dimension(:,:,:), pointer :: ad_x => NULL() !< diagnostic array for x-advective tracer flux - !! [conc H m2 s-1 ~> conc m3 s-1 or conc kg s-1] + !! [conc H L2 T-1 ~> conc m3 s-1 or conc kg s-1] real, dimension(:,:,:), pointer :: ad_y => NULL() !< diagnostic array for y-advective tracer flux - !! [conc H m2 s-1 ~> conc m3 s-1 or conc kg s-1] + !! [conc H L2 T-1 ~> conc m3 s-1 or conc kg s-1] real, dimension(:,:), pointer :: ad2d_x => NULL() !< diagnostic vertical sum x-advective tracer flux - !! [conc H m2 s-1 ~> conc m3 s-1 or conc kg s-1] + !! [conc H L2 T-1 ~> conc m3 s-1 or conc kg s-1] real, dimension(:,:), pointer :: ad2d_y => NULL() !< diagnostic vertical sum y-advective tracer flux - !! [conc H m2 s-1 ~> conc m3 s-1 or conc kg s-1] + !! [conc H L2 T-1 ~> conc m3 s-1 or conc kg s-1] real, dimension(:,:,:), pointer :: df_x => NULL() !< diagnostic array for x-diffusive tracer flux - !! [conc H L2 s-1 ~> conc m3 s-1 or conc kg s-1] + !! [conc H L2 T-1 ~> conc m3 s-1 or conc kg s-1] real, dimension(:,:,:), pointer :: df_y => NULL() !< diagnostic array for y-diffusive tracer flux - !! [conc H L2 s-1 ~> conc m3 s-1 or conc kg s-1] + !! [conc H L2 T-1 ~> conc m3 s-1 or conc kg s-1] real, dimension(:,:), pointer :: df2d_x => NULL() !< diagnostic vertical sum x-diffusive flux - !! [conc H L2 s-1 ~> conc m3 s-1 or conc kg s-1] + !! [conc H L2 T-1 ~> conc m3 s-1 or conc kg s-1] real, dimension(:,:), pointer :: df2d_y => NULL() !< diagnostic vertical sum y-diffusive flux - !! [conc H L2 s-1 ~> conc m3 s-1 or conc kg s-1] - real, dimension(:,:), pointer :: df2d_conc_x => NULL() !< diagnostic vertical sum x-diffusive content flux - !! [conc H m2 s-1 ~> conc m3 s-1 or conc kg s-1] - real, dimension(:,:), pointer :: df2d_conc_y => NULL() !< diagnostic vertical sum y-diffusive content flux - !! [conc H m2 s-1 ~> conc m3 s-1 or conc kg s-1] + !! [conc H L2 T-1 ~> conc m3 s-1 or conc kg s-1] +! real, dimension(:,:), pointer :: df2d_conc_x => NULL() !< diagnostic vertical sum x-diffusive content flux +! !! [conc H m2 s-1 ~> conc m3 s-1 or conc kg s-1] +! real, dimension(:,:), pointer :: df2d_conc_y => NULL() !< diagnostic vertical sum y-diffusive content flux +! !! [conc H m2 s-1 ~> conc m3 s-1 or conc kg s-1] real, dimension(:,:,:), pointer :: advection_xy => NULL() !< convergence of lateral advective tracer fluxes - !! [conc H s-1 ~> conc m s-1 or conc kg m-2 s-1] - real, dimension(:,:,:), pointer :: diff_cont_xy => NULL() !< convergence of lateral diffusive tracer fluxes - !! [conc H s-1 ~> conc m s-1 or conc kg m-2 s-1] - real, dimension(:,:,:), pointer :: diff_conc_xy => NULL() !< convergence of lateral diffusive tracer fluxes - !! expressed as a change in concentration [conc s-1] + !! [conc H T-1 ~> conc m s-1 or conc kg m-2 s-1] +! real, dimension(:,:,:), pointer :: diff_cont_xy => NULL() !< convergence of lateral diffusive tracer fluxes +! !! [conc H s-1 ~> conc m s-1 or conc kg m-2 s-1] +! real, dimension(:,:,:), pointer :: diff_conc_xy => NULL() !< convergence of lateral diffusive tracer fluxes +! !! expressed as a change in concentration [conc s-1] real, dimension(:,:,:), pointer :: t_prev => NULL() !< tracer concentration array at a previous !! timestep used for diagnostics [conc] real, dimension(:,:,:), pointer :: Trxh_prev => NULL() !< layer integrated tracer concentration array @@ -102,8 +102,8 @@ module MOM_tracer_registry integer :: ind_tr_squared = -1 !< The tracer registry index for the square of this tracer !### THESE CAPABILITIES HAVE NOT YET BEEN IMPLEMENTED. - logical :: advect_tr = .true. !< If true, this tracer should be advected - logical :: hordiff_tr = .true. !< If true, this tracer should experience epineutral diffusion + ! logical :: advect_tr = .true. !< If true, this tracer should be advected + ! logical :: hordiff_tr = .true. !< If true, this tracer should experience epineutral diffusion logical :: remap_tr = .true. !< If true, this tracer should be vertically remapped integer :: diag_form = 1 !< An integer indicating which template is to be used to label diagnostics. @@ -162,18 +162,22 @@ subroutine register_tracer(tr_ptr, Reg, param_file, HI, GV, name, longname, unit !! tracer cells (units of tracer CONC) ! The following are probably not necessary if registry_diags is present and true. - real, dimension(:,:,:), optional, pointer :: ad_x !< diagnostic x-advective flux (CONC m3/s or CONC*kg/s) - real, dimension(:,:,:), optional, pointer :: ad_y !< diagnostic y-advective flux (CONC m3/s or CONC*kg/s) - real, dimension(:,:,:), optional, pointer :: df_x !< diagnostic x-diffusive flux (CONC m3/s or CONC*kg/s) - real, dimension(:,:,:), optional, pointer :: df_y !< diagnostic y-diffusive flux (CONC m3/s or CONC*kg/s) + real, dimension(:,:,:), optional, pointer :: ad_x !< diagnostic x-advective flux + !! [conc H L2 T-1 ~> CONC m3 s-1 or CONC kg s-1] + real, dimension(:,:,:), optional, pointer :: ad_y !< diagnostic y-advective flux + !! [conc H L2 T-1 ~> CONC m3 s-1 or CONC kg s-1] + real, dimension(:,:,:), optional, pointer :: df_x !< diagnostic x-diffusive flux + !! [conc H L2 T-1 ~> CONC m3 s-1 or CONC kg s-1] + real, dimension(:,:,:), optional, pointer :: df_y !< diagnostic y-diffusive flux + !! [conc H L2 T-1 ~> CONC m3 s-1 or CONC kg s-1] real, dimension(:,:), optional, pointer :: ad_2d_x !< vert sum of diagnostic x-advect flux - !! (CONC m3/s or CONC*kg/s) + !! [conc H L2 T-1 ~> CONC m3 s-1 or CONC kg s-1] real, dimension(:,:), optional, pointer :: ad_2d_y !< vert sum of diagnostic y-advect flux - !! (CONC m3/s or CONC*kg/s) + !! [conc H L2 T-1 ~> CONC m3 s-1 or CONC kg s-1] real, dimension(:,:), optional, pointer :: df_2d_x !< vert sum of diagnostic x-diffuse flux - !! (CONC m3/s or CONC*kg/s) + !! [conc H L2 T-1 ~> CONC m3 s-1 or CONC kg s-1] real, dimension(:,:), optional, pointer :: df_2d_y !< vert sum of diagnostic y-diffuse flux - !! (CONC m3/s or CONC*kg/s) + !! [conc H L2 T-1 ~> CONC m3 s-1 or CONC kg s-1] real, dimension(:,:,:), optional, pointer :: advection_xy !< convergence of lateral advective tracer fluxes logical, optional, intent(in) :: registry_diags !< If present and true, use the registry for @@ -393,11 +397,11 @@ subroutine register_tracer_diagnostics(Reg, h, Time, diag, G, GV, US, use_ALE) Tr%id_adx = register_diag_field("ocean_model", trim(shortnm)//"_adx", & diag%axesCuL, Time, trim(flux_longname)//" advective zonal flux" , & trim(flux_units), v_extensive = .true., y_cell_method = 'sum', & - conversion=Tr%flux_scale*US%s_to_T) + conversion=Tr%flux_scale*(US%L_to_m**2)*US%s_to_T) Tr%id_ady = register_diag_field("ocean_model", trim(shortnm)//"_ady", & diag%axesCvL, Time, trim(flux_longname)//" advective meridional flux" , & trim(flux_units), v_extensive = .true., x_cell_method = 'sum', & - conversion=Tr%flux_scale*US%s_to_T) + conversion=Tr%flux_scale*(US%L_to_m**2)*US%s_to_T) Tr%id_dfx = register_diag_field("ocean_model", trim(shortnm)//"_dfx", & diag%axesCuL, Time, trim(flux_longname)//" diffusive zonal flux" , & trim(flux_units), v_extensive = .true., y_cell_method = 'sum', & @@ -409,10 +413,10 @@ subroutine register_tracer_diagnostics(Reg, h, Time, diag, G, GV, US, use_ALE) else Tr%id_adx = register_diag_field("ocean_model", trim(shortnm)//"_adx", & diag%axesCuL, Time, "Advective (by residual mean) Zonal Flux of "//trim(flux_longname), & - flux_units, v_extensive=.true., conversion=Tr%flux_scale*US%s_to_T, y_cell_method = 'sum') + flux_units, v_extensive=.true., conversion=Tr%flux_scale*(US%L_to_m**2)*US%s_to_T, y_cell_method = 'sum') Tr%id_ady = register_diag_field("ocean_model", trim(shortnm)//"_ady", & diag%axesCvL, Time, "Advective (by residual mean) Meridional Flux of "//trim(flux_longname), & - flux_units, v_extensive=.true., conversion=Tr%flux_scale*US%s_to_T, x_cell_method = 'sum') + flux_units, v_extensive=.true., conversion=Tr%flux_scale*(US%L_to_m**2)*US%s_to_T, x_cell_method = 'sum') Tr%id_dfx = register_diag_field("ocean_model", trim(shortnm)//"_diffx", & diag%axesCuL, Time, "Diffusive Zonal Flux of "//trim(flux_longname), & flux_units, v_extensive=.true., conversion=(US%L_to_m**2)*Tr%flux_scale*US%s_to_T, & @@ -430,11 +434,11 @@ subroutine register_tracer_diagnostics(Reg, h, Time, diag, G, GV, US, use_ALE) Tr%id_adx_2d = register_diag_field("ocean_model", trim(shortnm)//"_adx_2d", & diag%axesCu1, Time, & "Vertically Integrated Advective Zonal Flux of "//trim(flux_longname), & - flux_units, conversion=Tr%flux_scale*US%s_to_T, y_cell_method = 'sum') + flux_units, conversion=Tr%flux_scale*(US%L_to_m**2)*US%s_to_T, y_cell_method = 'sum') Tr%id_ady_2d = register_diag_field("ocean_model", trim(shortnm)//"_ady_2d", & diag%axesCv1, Time, & "Vertically Integrated Advective Meridional Flux of "//trim(flux_longname), & - flux_units, conversion=Tr%flux_scale*US%s_to_T, x_cell_method = 'sum') + flux_units, conversion=Tr%flux_scale*(US%L_to_m**2)*US%s_to_T, x_cell_method = 'sum') Tr%id_dfx_2d = register_diag_field("ocean_model", trim(shortnm)//"_diffx_2d", & diag%axesCu1, Time, & "Vertically Integrated Diffusive Zonal Flux of "//trim(flux_longname), & @@ -465,7 +469,7 @@ subroutine register_tracer_diagnostics(Reg, h, Time, diag, G, GV, US, use_ALE) Tr%id_tendency = register_diag_field('ocean_model', trim(shortnm)//'_tendency', & diag%axesTL, Time, & - 'Net time tendency for '//trim(lowercase(longname)), trim(units)//' s-1') + 'Net time tendency for '//trim(lowercase(longname)), trim(units)//' s-1', conversion=US%s_to_T) if (Tr%id_tendency > 0) then call safe_alloc_ptr(Tr%t_prev,isd,ied,jsd,jed,nz) @@ -511,10 +515,10 @@ subroutine register_tracer_diagnostics(Reg, h, Time, diag, G, GV, US, use_ALE) if (len_trim(Tr%cmor_tendprefix) == 0) then Tr%id_trxh_tendency = register_diag_field('ocean_model', trim(shortnm)//'h_tendency', & diag%axesTL, Time, var_lname, conv_units, v_extensive=.true., & - conversion=Tr%conv_scale) + conversion=Tr%conv_scale*US%s_to_T) Tr%id_trxh_tendency_2d = register_diag_field('ocean_model', trim(shortnm)//'h_tendency_2d', & diag%axesT1, Time, "Vertical sum of "//trim(lowercase(var_lname)), conv_units, & - conversion=Tr%conv_scale) + conversion=Tr%conv_scale*US%s_to_T) else cmor_var_lname = "Tendency of "//trim(cmor_longname)//" Expressed as "//& trim(flux_longname)//" Content" @@ -522,13 +526,13 @@ subroutine register_tracer_diagnostics(Reg, h, Time, diag, G, GV, US, use_ALE) diag%axesTL, Time, var_lname, conv_units, & cmor_field_name=trim(Tr%cmor_tendprefix)//"tend", & cmor_standard_name=cmor_long_std(cmor_var_lname), cmor_long_name=cmor_var_lname, & - v_extensive=.true., conversion=Tr%conv_scale) + v_extensive=.true., conversion=Tr%conv_scale*US%s_to_T) cmor_var_lname = trim(cmor_var_lname)//" Vertical Sum" Tr%id_trxh_tendency_2d = register_diag_field('ocean_model', trim(shortnm)//'h_tendency_2d', & diag%axesT1, Time, "Vertical sum of "//trim(lowercase(var_lname)), conv_units, & cmor_field_name=trim(Tr%cmor_tendprefix)//"tend_2d", & cmor_standard_name=cmor_long_std(cmor_var_lname), cmor_long_name=cmor_var_lname, & - conversion=Tr%conv_scale) + conversion=Tr%conv_scale*US%s_to_T) endif if ((Tr%id_trxh_tendency > 0) .or. (Tr%id_trxh_tendency_2d > 0)) then call safe_alloc_ptr(Tr%Trxh_prev,isd,ied,jsd,jed,nz) @@ -542,18 +546,18 @@ subroutine register_tracer_diagnostics(Reg, h, Time, diag, G, GV, US, use_ALE) var_lname = "Vertical remapping tracer concentration tendency for "//trim(Reg%Tr(m)%name) Tr%id_remap_conc= register_diag_field('ocean_model', & trim(Tr%flux_nameroot)//'_tendency_vert_remap', diag%axesTL, Time, var_lname, & - trim(units)//' s-1') + trim(units)//' s-1', conversion=US%s_to_T) var_lname = "Vertical remapping tracer content tendency for "//trim(Reg%Tr(m)%flux_longname) Tr%id_remap_cont = register_diag_field('ocean_model', & trim(Tr%flux_nameroot)//'h_tendency_vert_remap', & - diag%axesTL, Time, var_lname, flux_units, v_extensive=.true., conversion = Tr%conv_scale) + diag%axesTL, Time, var_lname, flux_units, v_extensive=.true., conversion=Tr%conv_scale*US%s_to_T) var_lname = "Vertical sum of vertical remapping tracer content tendency for "//& trim(Reg%Tr(m)%flux_longname) Tr%id_remap_cont_2d = register_diag_field('ocean_model', & trim(Tr%flux_nameroot)//'h_tendency_vert_remap_2d', & - diag%axesT1, Time, var_lname, flux_units, conversion = Tr%conv_scale) + diag%axesT1, Time, var_lname, flux_units, conversion=Tr%conv_scale*US%s_to_T) endif @@ -561,7 +565,7 @@ subroutine register_tracer_diagnostics(Reg, h, Time, diag, G, GV, US, use_ALE) unit2 = trim(units)//"2" if (index(units(1:len_trim(units))," ") > 0) unit2 = "("//trim(units)//")2" Tr%id_tr_vardec = register_diag_field('ocean_model', trim(shortnm)//"_vardec", diag%axesTL, & - Time, "ALE variance decay for "//lowercase(longname), trim(unit2)//" s-1") + Time, "ALE variance decay for "//lowercase(longname), trim(unit2)//" s-1", conversion=US%s_to_T) if (Tr%id_tr_vardec > 0) then ! Set up a new tracer for this tracer squared m2 = Reg%ntr+1 @@ -604,10 +608,10 @@ subroutine postALE_tracer_diagnostics(Reg, G, GV, diag, dt) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure type(diag_ctrl), intent(in) :: diag !< regulates diagnostic output - real, intent(in) :: dt !< total time interval for these diagnostics + real, intent(in) :: dt !< total time interval for these diagnostics [T ~> s] - real :: work(SZI_(G),SZJ_(G),SZK_(G)) - real :: Idt + real :: work(SZI_(G),SZJ_(G),SZK_(G)) + real :: Idt ! The inverse of the time step [T-1 ~> s-1] integer :: i, j, k, is, ie, js, je, nz, m, m2 is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke @@ -636,11 +640,11 @@ subroutine post_tracer_diagnostics(Reg, h, diag_prev, diag, G, GV, dt) intent(in) :: h !< Layer thicknesses type(diag_grid_storage), intent(in) :: diag_prev !< Contains diagnostic grids from previous timestep type(diag_ctrl), intent(inout) :: diag !< structure to regulate diagnostic output - real, intent(in) :: dt !< total time step for tracer updates + real, intent(in) :: dt !< total time step for tracer updates [T ~> s] real :: work3d(SZI_(G),SZJ_(G),SZK_(GV)) real :: work2d(SZI_(G),SZJ_(G)) - real :: Idt + real :: Idt ! The inverse of the time step [T-1 ~> s-1] type(tracer_type), pointer :: Tr=>NULL() integer :: i, j, k, is, ie, js, je, nz, m is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke diff --git a/src/tracer/RGC_tracer.F90 b/src/tracer/RGC_tracer.F90 index decb834a6a..028718f379 100644 --- a/src/tracer/RGC_tracer.F90 +++ b/src/tracer/RGC_tracer.F90 @@ -26,6 +26,7 @@ module RGC_tracer use MOM_time_manager, only : time_type use MOM_tracer_registry, only : register_tracer, tracer_registry_type use MOM_tracer_diabatic, only : tracer_vertdiff, applyTracerBoundaryFluxesInOut +use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : surface use MOM_open_boundary, only : ocean_OBC_type use MOM_verticalGrid, only : verticalGrid_type @@ -182,11 +183,8 @@ subroutine initialize_RGC_tracer(restart, day, G, GV, h, diag, OBC, CS, & character(len=48) :: flux_units ! The units for tracer fluxes, usually ! kg(tracer) kg(water)-1 m3 s-1 or kg(tracer) s-1. real, pointer :: tr_ptr(:,:,:) => NULL() - real :: PI ! 3.1415926... calculated as 4*atan(1) - real :: tr_y ! Initial zonally uniform tracer concentrations. - real :: dist2 ! The distance squared from a line, in m2. real :: h_neglect ! A thickness that is so small it is usually lost - ! in roundoff and can be neglected, in m. + ! in roundoff and can be neglected [H ~> m or kg-2]. real :: e(SZK_(G)+1), e_top, e_bot, d_tr ! Heights [Z ~> m]. integer :: i, j, k, is, ie, js, je, isd, ied, jsd, jed, nz, m integer :: IsdB, IedB, JsdB, JedB @@ -275,7 +273,7 @@ end subroutine initialize_RGC_tracer !> This subroutine applies diapycnal diffusion and any other column !! tracer physics or chemistry to the tracers from this file. !! This is a simple example of a set of advected passive tracers. -subroutine RGC_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, CS, & +subroutine RGC_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, US, CS, & evap_CFL_limit, minimum_forcing_depth) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. @@ -293,12 +291,13 @@ subroutine RGC_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, !! added [H ~> m or kg m-2]. type(forcing), intent(in) :: fluxes !< A structure containing pointers to any possible !! forcing fields. Unused fields have NULL ptrs. - real, intent(in) :: dt !< The amount of time covered by this call [s]. - type(RGC_tracer_CS), pointer :: CS !< The control structure returned by a previous call. + real, intent(in) :: dt !< The amount of time covered by this call [T ~> s]. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(RGC_tracer_CS), pointer :: CS !< The control structure returned by a previous call. real, optional, intent(in) :: evap_CFL_limit !< Limit on the fraction of the water that can be !! fluxed out of the top layer in a timestep [nondim]. real, optional, intent(in) :: minimum_forcing_depth !< The smallest depth over which fluxes - !! can be applied [m]. + !! can be applied [H ~> m or kg m-2]. ! The arguments to this subroutine are redundant in that ! h_new[k] = h_old[k] + ea[k] - eb[k-1] + eb[k] - ea[k+1] @@ -325,10 +324,10 @@ subroutine RGC_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, if (present(evap_CFL_limit) .and. present(minimum_forcing_depth)) then do m=1,NTR do k=1,nz ;do j=js,je ; do i=is,ie - h_work(i,j,k) = h_old(i,j,k) + h_work(i,j,k) = h_old(i,j,k) enddo ; enddo ; enddo; call applyTracerBoundaryFluxesInOut(G, GV, CS%tr(:,:,:,m) , dt, fluxes, h_work, & - evap_CFL_limit, minimum_forcing_depth, in_flux(:,:,m)) + evap_CFL_limit, minimum_forcing_depth, in_flux(:,:,m)) call tracer_vertdiff(h_work, ea, eb, dt, CS%tr(:,:,:,m), G, GV) enddo diff --git a/src/tracer/advection_test_tracer.F90 b/src/tracer/advection_test_tracer.F90 index 12fd1e08a1..e81003c0ff 100644 --- a/src/tracer/advection_test_tracer.F90 +++ b/src/tracer/advection_test_tracer.F90 @@ -16,6 +16,7 @@ module advection_test_tracer use MOM_time_manager, only : time_type use MOM_tracer_registry, only : register_tracer, tracer_registry_type use MOM_tracer_diabatic, only : tracer_vertdiff, applyTracerBoundaryFluxesInOut +use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : surface use MOM_verticalGrid, only : verticalGrid_type @@ -193,9 +194,6 @@ subroutine initialize_advection_test_tracer(restart, day, G, GV, h,diag, OBC, CS character(len=48) :: flux_units ! The units for tracer fluxes, usually ! kg(tracer) kg(water)-1 m3 s-1 or kg(tracer) s-1. real, pointer :: tr_ptr(:,:,:) => NULL() - real :: PI ! 3.1415926... calculated as 4*atan(1) - real :: tr_y ! Initial zonally uniform tracer concentrations. - real :: dist2 ! The distance squared from a line [m2]. real :: h_neglect ! A thickness that is so small it is usually lost ! in roundoff and can be neglected [H ~> m or kg m-2]. integer :: i, j, k, is, ie, js, je, isd, ied, jsd, jed, nz, m @@ -257,7 +255,7 @@ end subroutine initialize_advection_test_tracer !> Applies diapycnal diffusion and any other column tracer physics or chemistry to the tracers !! from this package. This is a simple example of a set of advected passive tracers. -subroutine advection_test_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, CS, & +subroutine advection_test_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, US, CS, & evap_CFL_limit, minimum_forcing_depth) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure @@ -275,13 +273,14 @@ subroutine advection_test_tracer_column_physics(h_old, h_new, ea, eb, fluxes, !! added [H ~> m or kg m-2]. type(forcing), intent(in) :: fluxes !< A structure containing pointers to thermodynamic !! and tracer forcing fields. Unused fields have NULL ptrs. - real, intent(in) :: dt !< The amount of time covered by this call [s] - type(advection_test_tracer_CS), pointer :: CS !< The control structure returned by a previous + real, intent(in) :: dt !< The amount of time covered by this call [T ~> s] + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(advection_test_tracer_CS), pointer :: CS !< The control structure returned by a previous !! call to register_advection_test_tracer. real, optional, intent(in) :: evap_CFL_limit !< Limit on the fraction of the water that can !! be fluxed out of the top layer in a timestep [nondim] real, optional, intent(in) :: minimum_forcing_depth !< The smallest depth over which - !! fluxes can be applied [m] + !! fluxes can be applied [H ~> m or kg m-2] ! This subroutine applies diapycnal diffusion and any other column ! tracer physics or chemistry to the tracers from this file. ! This is a simple example of a set of advected passive tracers. @@ -302,8 +301,8 @@ subroutine advection_test_tracer_column_physics(h_old, h_new, ea, eb, fluxes, do k=1,nz ;do j=js,je ; do i=is,ie h_work(i,j,k) = h_old(i,j,k) enddo ; enddo ; enddo - call applyTracerBoundaryFluxesInOut(G, GV, CS%tr(:,:,:,m) , dt, fluxes, h_work, & - evap_CFL_limit, minimum_forcing_depth) + call applyTracerBoundaryFluxesInOut(G, GV, CS%tr(:,:,:,m), dt, fluxes, h_work, & + evap_CFL_limit, minimum_forcing_depth) call tracer_vertdiff(h_work, ea, eb, dt, CS%tr(:,:,:,m), G, GV) enddo else diff --git a/src/tracer/boundary_impulse_tracer.F90 b/src/tracer/boundary_impulse_tracer.F90 index e712686521..e70320a5c7 100644 --- a/src/tracer/boundary_impulse_tracer.F90 +++ b/src/tracer/boundary_impulse_tracer.F90 @@ -17,6 +17,7 @@ module boundary_impulse_tracer use MOM_tracer_registry, only : register_tracer, tracer_registry_type use MOM_tracer_diabatic, only : tracer_vertdiff, applyTracerBoundaryFluxesInOut use MOM_tracer_Z_init, only : tracer_Z_init +use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : surface use MOM_variables, only : thermo_var_ptrs use MOM_verticalGrid, only : verticalGrid_type @@ -50,7 +51,7 @@ module boundary_impulse_tracer real, dimension(NTR_MAX) :: land_val = -1.0 !< A value to use to fill in tracers over land real :: kw_eff !< An effective piston velocity used to flux tracer out at the surface real :: remaining_source_time !< How much longer (same units as the timestep) to - !! inject the tracer at the surface + !! inject the tracer at the surface [s] type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to !! regulate the timing of diagnostic output. @@ -203,7 +204,7 @@ subroutine initialize_boundary_impulse_tracer(restart, day, G, GV, h, diag, OBC, end subroutine initialize_boundary_impulse_tracer !> Apply source or sink at boundary and do vertical diffusion -subroutine boundary_impulse_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, CS, & +subroutine boundary_impulse_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, US, CS, & tv, debug, evap_CFL_limit, minimum_forcing_depth) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure @@ -221,8 +222,9 @@ subroutine boundary_impulse_tracer_column_physics(h_old, h_new, ea, eb, fluxes, !! added [H ~> m or kg m-2]. type(forcing), intent(in) :: fluxes !< A structure containing pointers to thermodynamic !! and tracer forcing fields. Unused fields have NULL ptrs. - real, intent(in) :: dt !< The amount of time covered by this call [s] - type(boundary_impulse_tracer_CS), pointer :: CS !< The control structure returned by a previous + real, intent(in) :: dt !< The amount of time covered by this call [T ~> s] + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(boundary_impulse_tracer_CS), pointer :: CS !< The control structure returned by a previous !! call to register_boundary_impulse_tracer. type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various !! thermodynamic variables @@ -230,7 +232,7 @@ subroutine boundary_impulse_tracer_column_physics(h_old, h_new, ea, eb, fluxes, real, optional, intent(in) :: evap_CFL_limit !< Limit on the fraction of the water that can !! be fluxed out of the top layer in a timestep [nondim] real, optional, intent(in) :: minimum_forcing_depth !< The smallest depth over which - !! fluxes can be applied [m] + !! fluxes can be applied [H ~> m or kg m-2] ! This subroutine applies diapycnal diffusion and any other column ! tracer physics or chemistry to the tracers from this file. @@ -257,7 +259,7 @@ subroutine boundary_impulse_tracer_column_physics(h_old, h_new, ea, eb, fluxes, h_work(i,j,k) = h_old(i,j,k) enddo ; enddo ; enddo call applyTracerBoundaryFluxesInOut(G, GV, CS%tr(:,:,:,1), dt, fluxes, h_work, & - evap_CFL_limit, minimum_forcing_depth) + evap_CFL_limit, minimum_forcing_depth) call tracer_vertdiff(h_work, ea, eb, dt, CS%tr(:,:,:,1), G, GV) else call tracer_vertdiff(h_old, ea, eb, dt, CS%tr(:,:,:,1), G, GV) @@ -269,7 +271,7 @@ subroutine boundary_impulse_tracer_column_physics(h_old, h_new, ea, eb, fluxes, do k=1,CS%nkml ; do j=js,je ; do i=is,ie CS%tr(i,j,k,m) = 1.0 enddo ; enddo ; enddo - CS%remaining_source_time = CS%remaining_source_time-dt + CS%remaining_source_time = CS%remaining_source_time-US%T_to_s*dt else do k=1,CS%nkml ; do j=js,je ; do i=is,ie CS%tr(i,j,k,m) = 0.0 diff --git a/src/tracer/dye_example.F90 b/src/tracer/dye_example.F90 index 92f8491a49..86a4ac7aeb 100644 --- a/src/tracer/dye_example.F90 +++ b/src/tracer/dye_example.F90 @@ -243,7 +243,7 @@ end subroutine initialize_dye_tracer !! This is a simple example of a set of advected passive tracers. !! The arguments to this subroutine are redundant in that !! h_new(k) = h_old(k) + ea(k) - eb(k-1) + eb(k) - ea(k+1) -subroutine dye_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, CS, & +subroutine dye_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, US, CS, & evap_CFL_limit, minimum_forcing_depth) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure @@ -261,13 +261,14 @@ subroutine dye_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, CS !! added [H ~> m or kg m-2]. type(forcing), intent(in) :: fluxes !< A structure containing pointers to thermodynamic !! and tracer forcing fields. Unused fields have NULL ptrs. - real, intent(in) :: dt !< The amount of time covered by this call [s] + real, intent(in) :: dt !< The amount of time covered by this call [T ~> s] + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(dye_tracer_CS), pointer :: CS !< The control structure returned by a previous !! call to register_dye_tracer. real, optional, intent(in) :: evap_CFL_limit !< Limit on the fraction of the water that can !! be fluxed out of the top layer in a timestep [nondim] real, optional, intent(in) :: minimum_forcing_depth !< The smallest depth over which - !! fluxes can be applied [m] + !! fluxes can be applied [H ~> m or kg m-2] ! Local variables real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: h_work ! Used so that h can be modified @@ -288,8 +289,8 @@ subroutine dye_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, CS do k=1,nz ;do j=js,je ; do i=is,ie h_work(i,j,k) = h_old(i,j,k) enddo ; enddo ; enddo - call applyTracerBoundaryFluxesInOut(G, GV, CS%tr(:,:,:,m) , dt, fluxes, h_work, & - evap_CFL_limit, minimum_forcing_depth) + call applyTracerBoundaryFluxesInOut(G, GV, CS%tr(:,:,:,m), dt, fluxes, h_work, & + evap_CFL_limit, minimum_forcing_depth) call tracer_vertdiff(h_work, ea, eb, dt, CS%tr(:,:,:,m), G, GV) enddo else diff --git a/src/tracer/dyed_obc_tracer.F90 b/src/tracer/dyed_obc_tracer.F90 index 4ea3611a2a..198ee1bc4f 100644 --- a/src/tracer/dyed_obc_tracer.F90 +++ b/src/tracer/dyed_obc_tracer.F90 @@ -15,6 +15,7 @@ module dyed_obc_tracer use MOM_time_manager, only : time_type use MOM_tracer_registry, only : register_tracer, tracer_registry_type use MOM_tracer_diabatic, only : tracer_vertdiff, applyTracerBoundaryFluxesInOut +use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : surface use MOM_verticalGrid, only : verticalGrid_type @@ -199,7 +200,7 @@ end subroutine initialize_dyed_obc_tracer !! !! The arguments to this subroutine are redundant in that !! h_new(k) = h_old(k) + ea(k) - eb(k-1) + eb(k) - ea(k+1) -subroutine dyed_obc_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, CS, & +subroutine dyed_obc_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, US, CS, & evap_CFL_limit, minimum_forcing_depth) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure @@ -217,13 +218,14 @@ subroutine dyed_obc_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, !! added [H ~> m or kg m-2]. type(forcing), intent(in) :: fluxes !< A structure containing pointers to thermodynamic !! and tracer forcing fields. Unused fields have NULL ptrs. - real, intent(in) :: dt !< The amount of time covered by this call [s] + real, intent(in) :: dt !< The amount of time covered by this call [T ~> s] + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(dyed_obc_tracer_CS), pointer :: CS !< The control structure returned by a previous !! call to dyed_obc_register_tracer. real, optional, intent(in) :: evap_CFL_limit !< Limit on the fraction of the water that can !! be fluxed out of the top layer in a timestep [nondim] real, optional, intent(in) :: minimum_forcing_depth !< The smallest depth over which - !! fluxes can be applied [m] + !! fluxes can be applied [H ~> m or kg m-2] ! Local variables real :: b1(SZI_(G)) ! b1 and c1 are variables used by the @@ -240,8 +242,8 @@ subroutine dyed_obc_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, do k=1,nz ;do j=js,je ; do i=is,ie h_work(i,j,k) = h_old(i,j,k) enddo ; enddo ; enddo - call applyTracerBoundaryFluxesInOut(G, GV, CS%tr(:,:,:,m) , dt, fluxes, h_work, & - evap_CFL_limit, minimum_forcing_depth) + call applyTracerBoundaryFluxesInOut(G, GV, CS%tr(:,:,:,m), dt, fluxes, h_work, & + evap_CFL_limit, minimum_forcing_depth) if (nz > 1) call tracer_vertdiff(h_work, ea, eb, dt, CS%tr(:,:,:,m), G, GV) enddo else diff --git a/src/tracer/ideal_age_example.F90 b/src/tracer/ideal_age_example.F90 index a46e42f415..3ef61e1a57 100644 --- a/src/tracer/ideal_age_example.F90 +++ b/src/tracer/ideal_age_example.F90 @@ -281,7 +281,7 @@ subroutine initialize_ideal_age_tracer(restart, day, G, GV, US, h, diag, OBC, CS end subroutine initialize_ideal_age_tracer !> Applies diapycnal diffusion, aging and regeneration at the surface to the ideal age tracers -subroutine ideal_age_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, CS, & +subroutine ideal_age_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, US, CS, & evap_CFL_limit, minimum_forcing_depth) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure @@ -299,13 +299,14 @@ subroutine ideal_age_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, !! added [H ~> m or kg m-2]. type(forcing), intent(in) :: fluxes !< A structure containing pointers to thermodynamic !! and tracer forcing fields. Unused fields have NULL ptrs. - real, intent(in) :: dt !< The amount of time covered by this call [s] + real, intent(in) :: dt !< The amount of time covered by this call [T ~> s] + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(ideal_age_tracer_CS), pointer :: CS !< The control structure returned by a previous !! call to register_ideal_age_tracer. real, optional, intent(in) :: evap_CFL_limit !< Limit on the fraction of the water that can !! be fluxed out of the top layer in a timestep [nondim] real, optional, intent(in) :: minimum_forcing_depth !< The smallest depth over which - !! fluxes can be applied [m] + !! fluxes can be applied [H ~> m or kg m-2] ! This subroutine applies diapycnal diffusion and any other column ! tracer physics or chemistry to the tracers from this file. ! This is a simple example of a set of advected passive tracers. @@ -315,7 +316,7 @@ subroutine ideal_age_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, ! Local variables real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: h_work ! Used so that h can be modified real :: sfc_val ! The surface value for the tracers. - real :: Isecs_per_year ! The number of seconds in a year. + real :: Isecs_per_year ! The inverse of the amount of time in a year [T-1 ~> s-1] real :: year ! The time in years. integer :: i, j, k, is, ie, js, je, nz, m is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke @@ -328,8 +329,8 @@ subroutine ideal_age_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, do k=1,nz ;do j=js,je ; do i=is,ie h_work(i,j,k) = h_old(i,j,k) enddo ; enddo ; enddo - call applyTracerBoundaryFluxesInOut(G, GV, CS%tr(:,:,:,m) , dt, fluxes, h_work, & - evap_CFL_limit, minimum_forcing_depth) + call applyTracerBoundaryFluxesInOut(G, GV, CS%tr(:,:,:,m), dt, fluxes, h_work, & + evap_CFL_limit, minimum_forcing_depth) call tracer_vertdiff(h_work, ea, eb, dt, CS%tr(:,:,:,m), G, GV) enddo else @@ -338,10 +339,10 @@ subroutine ideal_age_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, enddo endif - Isecs_per_year = 1.0 / (365.0*86400.0) + Isecs_per_year = 1.0 / (365.0*86400.0*US%s_to_T) ! Set the surface value of tracer 1 to increase exponentially ! with a 30 year time scale. - year = time_type_to_real(CS%Time) * Isecs_per_year + year = US%s_to_T*time_type_to_real(CS%Time) * Isecs_per_year do m=1,CS%ntr if (CS%sfc_growth_rate(m) == 0.0) then diff --git a/src/tracer/oil_tracer.F90 b/src/tracer/oil_tracer.F90 index 09fab89b70..4d755497c6 100644 --- a/src/tracer/oil_tracer.F90 +++ b/src/tracer/oil_tracer.F90 @@ -45,7 +45,7 @@ module oil_tracer real :: oil_source_latitude !< Longitude of source location (geographic) integer :: oil_source_i=-999 !< Local i of source location (computational) integer :: oil_source_j=-999 !< Local j of source location (computational) - real :: oil_source_rate !< Rate of oil injection [kg s-1] + real :: oil_source_rate !< Rate of oil injection [kg T-1 ~> kg s-1] real :: oil_start_year !< The year in which tracers start aging, or at which the !! surface value equals young_val, in years. real :: oil_end_year !< The year in which tracers start aging, or at which the @@ -58,7 +58,7 @@ module oil_tracer real, dimension(NTR_MAX) :: land_val = -1.0 !< The value of tr used where land is masked out. real, dimension(NTR_MAX) :: sfc_growth_rate !< The exponential growth rate for the surface value [year-1]. real, dimension(NTR_MAX) :: oil_decay_days !< Decay time scale of oil [days] - real, dimension(NTR_MAX) :: oil_decay_rate !< Decay rate of oil [s-1] calculated from oil_decay_days + real, dimension(NTR_MAX) :: oil_decay_rate !< Decay rate of oil [T-1 ~> s-1] calculated from oil_decay_days integer, dimension(NTR_MAX) :: oil_source_k !< Layer of source logical :: oil_may_reinit !< If true, oil tracers may be reset by the initialization code !! if they are not found in the restart files. @@ -74,16 +74,17 @@ module oil_tracer contains !> Register oil tracer fields and subroutines to be used with MOM. -function register_oil_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) +function register_oil_tracer(HI, GV, US, param_file, CS, tr_Reg, restart_CS) type(hor_index_type), intent(in) :: HI !< A horizontal index type structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters - type(oil_tracer_CS), pointer :: CS !< A pointer that is set to point to the control - !! structure for this module - type(tracer_registry_type), pointer :: tr_Reg !< A pointer that is set to point to the control - !! structure for the tracer advection and - !! diffusion module - type(MOM_restart_CS), pointer :: restart_CS !< A pointer to the restart control structure + type(oil_tracer_CS), pointer :: CS !< A pointer that is set to point to the control + !! structure for this module + type(tracer_registry_type), pointer :: tr_Reg !< A pointer that is set to point to the control + !! structure for the tracer advection and + !! diffusion module + type(MOM_restart_CS), pointer :: restart_CS !< A pointer to the restart control structure ! Local variables character(len=40) :: mdl = "oil_tracer" ! This module's name. @@ -139,7 +140,7 @@ function register_oil_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) "negative number for a vertically uniform source, "//& "or 0 not to use this tracer.", units="Layer", default=0) call get_param(param_file, mdl, "OIL_SOURCE_RATE", CS%oil_source_rate, & - "The rate of oil injection.", units="kg s-1", default=1.0) + "The rate of oil injection.", units="kg s-1", scale=US%T_to_s, default=1.0) call get_param(param_file, mdl, "OIL_DECAY_DAYS", CS%oil_decay_days, & "The decay timescale in days (if positive), or no decay "//& "if 0, or use the temperature dependent decay rate of "//& @@ -161,13 +162,13 @@ function register_oil_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) CS%tr_desc(m) = var_desc("oil"//trim(name_tag), "kg m-3", "Oil Tracer", caller=mdl) CS%IC_val(m) = 0.0 if (CS%oil_decay_days(m)>0.) then - CS%oil_decay_rate(m)=1./(86400.0*CS%oil_decay_days(m)) + CS%oil_decay_rate(m) = 1. / (86400.0*US%s_to_T * CS%oil_decay_days(m)) elseif (CS%oil_decay_days(m)<0.) then - CS%oil_decay_rate(m)=-1. + CS%oil_decay_rate(m) = -1. endif endif enddo - call log_param(param_file, mdl, "OIL_DECAY_RATE", CS%oil_decay_rate(1:CS%ntr)) + call log_param(param_file, mdl, "OIL_DECAY_RATE", US%s_to_T*CS%oil_decay_rate(1:CS%ntr)) ! This needs to be changed if the units of tracer are changed above. if (GV%Boussinesq) then ; flux_units = "kg s-1" @@ -295,7 +296,7 @@ subroutine initialize_oil_tracer(restart, day, G, GV, US, h, diag, OBC, CS, & end subroutine initialize_oil_tracer !> Apply sources, sinks, diapycnal mixing and rising motions to the oil tracers -subroutine oil_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, CS, tv, & +subroutine oil_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, US, CS, tv, & evap_CFL_limit, minimum_forcing_depth) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure @@ -313,14 +314,15 @@ subroutine oil_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, CS !! added [H ~> m or kg m-2]. type(forcing), intent(in) :: fluxes !< A structure containing pointers to thermodynamic !! and tracer forcing fields. Unused fields have NULL ptrs. - real, intent(in) :: dt !< The amount of time covered by this call [s] + real, intent(in) :: dt !< The amount of time covered by this call [T ~> s] + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(oil_tracer_CS), pointer :: CS !< The control structure returned by a previous !! call to register_oil_tracer. type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various thermodynamic variables real, optional, intent(in) :: evap_CFL_limit !< Limit on the fraction of the water that can !! be fluxed out of the top layer in a timestep [nondim] real, optional, intent(in) :: minimum_forcing_depth !< The smallest depth over which - !! fluxes can be applied [m] + !! fluxes can be applied [H ~> m or kg m-2] ! This subroutine applies diapycnal diffusion and any other column ! tracer physics or chemistry to the tracers from this file. ! This is a simple example of a set of advected passive tracers. @@ -343,8 +345,8 @@ subroutine oil_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, CS do k=1,nz ;do j=js,je ; do i=is,ie h_work(i,j,k) = h_old(i,j,k) enddo ; enddo ; enddo - call applyTracerBoundaryFluxesInOut(G, GV, CS%tr(:,:,:,m) , dt, fluxes, h_work, & - evap_CFL_limit, minimum_forcing_depth) + call applyTracerBoundaryFluxesInOut(G, GV, CS%tr(:,:,:,m), dt, fluxes, h_work, & + evap_CFL_limit, minimum_forcing_depth) call tracer_vertdiff(h_work, ea, eb, dt, CS%tr(:,:,:,m), G, GV) enddo else @@ -361,11 +363,11 @@ subroutine oil_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, CS !CS%tr(i,j,k,m) = CS%tr(i,j,k,m) - dt*CS%oil_decay_rate(m)*CS%tr(i,j,k,m) ! Simple !CS%tr(i,j,k,m) = CS%tr(i,j,k,m) - min(dt*CS%oil_decay_rate(m),1.)*CS%tr(i,j,k,m) ! Safer if (CS%oil_decay_rate(m)>0.) then - CS%tr(i,j,k,m) = G%mask2dT(i,j)*max(1.-dt*CS%oil_decay_rate(m),0.)*CS%tr(i,j,k,m) ! Safest + CS%tr(i,j,k,m) = G%mask2dT(i,j)*max(1. - dt*CS%oil_decay_rate(m),0.)*CS%tr(i,j,k,m) ! Safest elseif (CS%oil_decay_rate(m)<0.) then ldecay = 12.*(3.0**(-(tv%T(i,j,k)-20.)/10.)) ! Timescale [days] - ldecay = 1./(86400.*ldecay) ! Rate [s-1] - CS%tr(i,j,k,m) = G%mask2dT(i,j)*max(1.-dt*ldecay,0.)*CS%tr(i,j,k,m) + ldecay = 1. / (86400.*US%s_to_T * ldecay) ! Rate [T-1 ~> s-1] + CS%tr(i,j,k,m) = G%mask2dT(i,j)*max(1. - dt*ldecay,0.)*CS%tr(i,j,k,m) endif enddo ; enddo ; enddo enddo diff --git a/src/tracer/pseudo_salt_tracer.F90 b/src/tracer/pseudo_salt_tracer.F90 index af4c1e9659..5c74487c0c 100644 --- a/src/tracer/pseudo_salt_tracer.F90 +++ b/src/tracer/pseudo_salt_tracer.F90 @@ -19,6 +19,7 @@ module pseudo_salt_tracer use MOM_tracer_registry, only : register_tracer, tracer_registry_type use MOM_tracer_diabatic, only : tracer_vertdiff, applyTracerBoundaryFluxesInOut use MOM_tracer_Z_init, only : tracer_Z_init +use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : surface use MOM_variables, only : thermo_var_ptrs use MOM_verticalGrid, only : verticalGrid_type @@ -170,7 +171,7 @@ subroutine initialize_pseudo_salt_tracer(restart, day, G, GV, h, diag, OBC, CS, end subroutine initialize_pseudo_salt_tracer !> Apply sources, sinks and diapycnal diffusion to the tracers in this package. -subroutine pseudo_salt_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, CS, tv, debug, & +subroutine pseudo_salt_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, US, CS, tv, debug, & evap_CFL_limit, minimum_forcing_depth) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure @@ -188,7 +189,8 @@ subroutine pseudo_salt_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G !! added [H ~> m or kg m-2]. type(forcing), intent(in) :: fluxes !< A structure containing pointers to thermodynamic !! and tracer forcing fields. Unused fields have NULL ptrs. - real, intent(in) :: dt !< The amount of time covered by this call [s] + real, intent(in) :: dt !< The amount of time covered by this call [T ~> s] + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(pseudo_salt_tracer_CS), pointer :: CS !< The control structure returned by a previous !! call to register_pseudo_salt_tracer. type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various thermodynamic variables @@ -196,7 +198,7 @@ subroutine pseudo_salt_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G real, optional, intent(in) :: evap_CFL_limit !< Limit on the fraction of the water that can !! be fluxed out of the top layer in a timestep [nondim] real, optional, intent(in) :: minimum_forcing_depth !< The smallest depth over which - !! fluxes can be applied [m] + !! fluxes can be applied [H ~> m or kg m-2] ! This subroutine applies diapycnal diffusion and any other column ! tracer physics or chemistry to the tracers from this file. @@ -226,7 +228,7 @@ subroutine pseudo_salt_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G h_work(i,j,k) = h_old(i,j,k) enddo ; enddo ; enddo call applyTracerBoundaryFluxesInOut(G, GV, CS%ps, dt, fluxes, h_work, & - evap_CFL_limit, minimum_forcing_depth, out_flux_optional=fluxes%netSalt) + evap_CFL_limit, minimum_forcing_depth, out_flux_optional=fluxes%netSalt) call tracer_vertdiff(h_work, ea, eb, dt, CS%ps, G, GV) else call tracer_vertdiff(h_old, ea, eb, dt, CS%ps, G, GV) diff --git a/src/tracer/tracer_example.F90 b/src/tracer/tracer_example.F90 index aa9d34c4e1..c5e8f669c6 100644 --- a/src/tracer/tracer_example.F90 +++ b/src/tracer/tracer_example.F90 @@ -15,6 +15,7 @@ module USER_tracer_example use MOM_sponge, only : set_up_sponge_field, sponge_CS use MOM_time_manager, only : time_type use MOM_tracer_registry, only : register_tracer, tracer_registry_type +use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : surface use MOM_verticalGrid, only : verticalGrid_type @@ -259,7 +260,7 @@ end subroutine USER_initialize_tracer !! This is a simple example of a set of advected passive tracers. !! The arguments to this subroutine are redundant in that !! h_new(k) = h_old(k) + ea(k) - eb(k-1) + eb(k) - ea(k+1) -subroutine tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, CS) +subroutine tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, US, CS) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & @@ -276,7 +277,8 @@ subroutine tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, CS) !! added [H ~> m or kg m-2]. type(forcing), intent(in) :: fluxes !< A structure containing pointers to thermodynamic !! and tracer forcing fields. Unused fields have NULL ptrs. - real, intent(in) :: dt !< The amount of time covered by this call [s] + real, intent(in) :: dt !< The amount of time covered by this call [T ~> s] + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(USER_tracer_example_CS), pointer :: CS !< The control structure returned by a previous !! call to USER_register_tracer_example. From 855d7069db41f28364793167f414e0e80a9e2f0a Mon Sep 17 00:00:00 2001 From: Jess <20195932+wrongkindofdoctor@users.noreply.github.com> Date: Mon, 2 Dec 2019 14:01:36 -0500 Subject: [PATCH 2/9] Merge in dev/gfdl updates (#37) * TC4 integration into test suite This patch renames the tc4 test to activate it in the test suite. It also modifies the Makefile to build the input field test scripts. It also modifies the Python build scripts to be PEP8-conformant. We temporarily disable tc4 in the restart tests, since they currently fail. This needs to be addressed before we can merge this into the main branch. The patch does not enable the necessary Python modules for running on Travis, that will also be addressed later. * Travis python support; tc4 Makefile The custom TC4 Makefile has been added (oops), and the presumed Python Ubuntu packages have been added for Travis. * Verify ENABLE_THERMODYNAMICS is True before posting C_p diagnostic * Make tc4 faster * remove trailing whitespace * add unit scaling * fix restart fail for tc4 and some cleanup * remove trailiny ws * Enable tc4.restart test * +Pass timeesteps to tracer diagnostics in [T] Pass timeesteps to the tracer diagnistics routines post_tracer_diagnostics and postALE_tracer_diagnostics and to adiabatic in units of [T}. All answers are bitwise identical. * +Rescaled tracer advective flux diagnostics Rescaled the internal units of the tracer advective flux diagnostics to units of [conc H L2 T-1] for code simplicity and dimensional consistency testing. Also corrected the units of some tracer fluxes as documented in comments and commented out unused elements of the tracer_type. All answers are bitwise identical. * +Pass timesteps to ALE_main in [T] Pass the timesteps to ALE_main, ALE_main_offline, and ALE_main_accelerated in units of [T] for code simplicity and dimensional consistency testing. This also includes the rescaling of remapping-driven tracer tendencies. All answers and diagnostics are bitwise identical. * +Pass timesteps to tracer column_physics in [T] Pass timesteps to the various tracer column_physics routines in [T] for dimensional consistency testing. Also added a new unit_scale_type argument to these routines. All answers are bitwise identical, but there are minor interface changes to 13 subroutines. * +Pass timesteps to applyTracerBoundaryFluxesInOut in [T] Pass timesteps to applyTracerBoundaryFluxesInOut in [T], and use units of [T-1] for internal source and decay rates for the oil tracer and in fluxes of CFCs. Also modified extract_offline_main to return timesteps as real values with units of [T]. Also there is a new unit_scale_type argument to register_oil_tracer. All answers in the MOM6_examples test cases and regression tests are bitwise identical. * Simplified expressions in MOM_PointAccel Simplified expressions inside of MOM_PointAccel, taking into account that all velocities use the same units of [L T-1]. All answers are bitwise identical. * Corrected dimensional epsilons in downscaling Added distinct negligible volumes, face areas, horizonal areas and lengths with proper dimensional rescaling in the downsample field routines. With these changes, downscaled diagnostics should now pass the dimensional rescaling tests, whereas previously there would have been a problem when the numbers used to represent lengths are smaller than about 1e-8 times their MKS values. All answers are bitwise identical without dimensional rescaling. * Simplified expressions in MOM_offline_aux Simplified expressions in distribute_residual_uh_barotropic. All answers are bitwise identical. * Revised wave_speed to return speed in [L T-1] Revised wave_speed to return the internal wave speed in units of [L T-1] and to use mono_N2_depth in units of [Z] for code simplification and expanded dimensional consistency testing. Also revised the internal units of some related diagnostics in calculate_diagnostic_fields. All answers and diagnostics are bitwise identical. * Rescaled internal variables in wave_speed Rescale internal calculations in wave_speed and wave_speeds for greater robustness and dimensional consistency testing. All answers are bitwise identical and pass dimensional scaling tests. * +Changed the units of minimum_forcing_depth to [H] Changed the units of minimum_forcing_depth passed to applyBoundaryFluxesInOut and applyTracerBoundaryFluxesInOut to [H]. All answers are bitwise identical. * Correction of documented units in comments Corrected some units in comments and eliminated some unused variables. All answers are bitwise identical. * Adiabatic clock ID bugfix This patch fixes an initialization bug of the diabatic timer, which was being used to measure adiabatic time but was never initialized if the experiment was configured as adiabatic. We fix this by introducing a separate timer for the adiabatic solver. Although we could have reused the diabatic timer, the addition of a new variable should not add any overhead on modern compilers. * Corrected an OMP declaration Added a variable to an OMP declaration. All answers are bitwise identical, and a recently added compile-time error with openMP was fixed. * Update MOM.F90 Fixed Alistair's embarrassing error. * Dimensional rescaling in MOM_open_boundary.F90 Added rescaling for dimensional consistency testing in MOM_open_boundary.F90, including splitting variables with different units that had previously shared the same variable and adding more extensive documentation of variables. Also changed the dimensions of the timesteps passed to radiation_open_bdry_conds and update_segment_tracer_reservoirs to [T] and added vertical_grid_type and unit_scale_type arguments to open_boundary_init and open_boundary_test_extern_h. All answers are bitwise identical, although some probably bugs have been noted in comments and there are new or altered arguments to several routines. * (*)Fixed invariance bugs in MOM_open_boundary.F90 Corrected dimensional consistency bugs in update_segment_tracer_reservoirs and horizontal indexing and related bugs in gradient_at_q_points with oblique_grad OBCs. These will both change answers in test cases that use some open boundary condition options, but not in any of the MOM6-examples test cases. From 3c15a0c111df1220821a8e799930a674ea113321 Mon Sep 17 00:00:00 2001 From: Jess <20195932+wrongkindofdoctor@users.noreply.github.com> Date: Mon, 2 Dec 2019 14:03:08 -0500 Subject: [PATCH 3/9] Revert "Merge in dev/gfdl updates (#37)" This reverts commit 855d7069db41f28364793167f414e0e80a9e2f0a. From e072bc7cce861b38df7ef1d2bde825d2d010f694 Mon Sep 17 00:00:00 2001 From: Jess <20195932+wrongkindofdoctor@users.noreply.github.com> Date: Fri, 6 Dec 2019 11:35:56 -0500 Subject: [PATCH 4/9] Merge in latest dev/gfdl updates (#40) * (*)Fixed dimensional inconsistency in P3M_functions Corrected dimensionally inconsistent expressions in P3M_functions.F90, notably in P3M_limiter and monotonize_cubic and a complete rewrite and simplification of is_cubic_monotonic. Also added comments documenting the units of all real variables in this module, and changed the code to use logical variables in place of integer "booleans", including in the return value from is_cubic_monotonic. These changes will change (fix) the answers when remapping variables with small numerical values, but no answers change in the MOM6-examples test cases. * +Added REMAPPING_2018 runtime option Added a new runtime option, REMAPPING_2018, which if set to false triggers the use of new, more accurate expressions in various parts of the ALE remapping code. By default, the older expressions are used, and all answers are bitwise identical, but there are new optional arguments to various routines related to remapping to trigger the use of new mathematically equivalent expressions. By default all answers are bitwise identical, but there are new and reordered entries in the MOM6_parameter_doc files. * Corrected the formatting of a doxygen comment * Added conversion factors to forcing diagnostics Added conversion factors to 4 mass-flux diagnostics and comments to 4 others on why no conversion factors are needed. All answers are bitwise identical. * Added correct scaling factors to chksum calls Added scale arguments to 5 chksum calls and grouped another two chksum calls while also adding the right scaling argument. All answers are bitwise identical. * +Unscales area before taking global sum Undoes the dimensional scaling of the cell areas before taking their global sum, so that the reproducing sum does not overflow when there is dimensional rescaling. All answers are bitwise identical when there is no rescaling, but this eliminates a source of inadvertent overflows or underflows in the global sums, and there is a new optional argument to compute_global_grid_integrals. * (*)Correct dimensionally inconsistent advective CFL Corrects the dimensionally inconsistent expressions for the CFL number in the tracer advection code, in which a negligible thickness had been added to the cell volume to avoid division by zero. This change does not alter the solutions in the MOM6-examples test cases, but now it permits dimensional rescaling of lengths over a much larger range, and it could change answers if the minimum layer thicknesses are small enough. * Unscale sea level before averaging Unscale interface heights before taking a global average via a reproducing sum in non-Boussinesq mode global diagnostics to permit dimensional consistency testing over a larger range. All answers are bitwise identical. * +Added an optional tmp_scale arg to global_i_mean Added an optional tmp_scale argument to global_i_mean and global_j_mean to specify an internal rescaling of variables being averaged before the reproducing sum. All answers are bitwise identical, but there are new optional arguments to two public interfaces. * Expand consistency testing with i-mean sponges Use tmp_scale when taking the i-mean interface heights for i-mean sponges, to give a greatly expanded range of dimensional consistency testing. All answers are bitwise identical. --- src/ALE/MOM_ALE.F90 | 43 ++- src/ALE/MOM_remapping.F90 | 37 ++- src/ALE/P3M_functions.F90 | 261 +++++++----------- src/ALE/regrid_edge_slopes.F90 | 142 ++++++---- src/ALE/regrid_edge_values.F90 | 229 +++++++++------ src/ALE/regrid_interp.F90 | 60 ++-- src/core/MOM.F90 | 2 +- src/core/MOM_dynamics_split_RK2.F90 | 6 +- src/core/MOM_forcing_type.F90 | 28 +- src/diagnostics/MOM_sum_output.F90 | 5 +- src/framework/MOM_spatial_means.F90 | 32 ++- .../MOM_fixed_initialization.F90 | 2 +- .../MOM_shared_initialization.F90 | 10 +- .../MOM_state_initialization.F90 | 7 +- src/parameterizations/lateral/MOM_MEKE.F90 | 2 +- .../vertical/MOM_set_diffusivity.F90 | 4 +- src/parameterizations/vertical/MOM_sponge.F90 | 2 +- src/tracer/MOM_tracer_advect.F90 | 18 +- 18 files changed, 494 insertions(+), 396 deletions(-) diff --git a/src/ALE/MOM_ALE.F90 b/src/ALE/MOM_ALE.F90 index d7917f8cad..97232b22ca 100644 --- a/src/ALE/MOM_ALE.F90 +++ b/src/ALE/MOM_ALE.F90 @@ -63,9 +63,9 @@ module MOM_ALE !> ALE control structure type, public :: ALE_CS ; private - logical :: remap_uv_using_old_alg !< If true, uses the old "remapping via a delta z" - !! method. If False, uses the new method that - !! remaps between grids described by h. + logical :: remap_uv_using_old_alg !< If true, uses the old "remapping via a delta z" + !! method. If False, uses the new method that + !! remaps between grids described by h. real :: regrid_time_scale !< The time-scale used in blending between the current (old) grid !! and the target (new) grid [T ~> s] @@ -73,9 +73,13 @@ module MOM_ALE type(regridding_CS) :: regridCS !< Regridding parameters and work arrays type(remapping_CS) :: remapCS !< Remapping parameters and work arrays - integer :: nk !< Used only for queries, not directly by this module + integer :: nk !< Used only for queries, not directly by this module - logical :: remap_after_initialization !< Indicates whether to regrid/remap after initializing the state. + logical :: remap_after_initialization !< Indicates whether to regrid/remap after initializing the state. + + logical :: answers_2018 !< If true, use the order of arithmetic and expressions for remapping + !! that recover the answers from the end of 2018. Otherwise, use more + !! robust and accurate forms of mathematically equivalent expressions. logical :: show_call_tree !< For debugging @@ -145,6 +149,7 @@ subroutine ALE_init( param_file, GV, US, max_depth, CS) character(len=40) :: mdl = "MOM_ALE" ! This module's name. character(len=80) :: string ! Temporary strings real :: filter_shallow_depth, filter_deep_depth + logical :: default_2018_answers logical :: check_reconstruction logical :: check_remapping logical :: force_bounds_in_subcell @@ -192,11 +197,19 @@ subroutine ALE_init( param_file, GV, US, max_depth, CS) call get_param(param_file, mdl, "REMAP_BOUNDARY_EXTRAP", remap_boundary_extrap, & "If true, values at the interfaces of boundary cells are "//& "extrapolated instead of piecewise constant", default=.false.) + call get_param(param_file, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & + "This sets the default value for the various _2018_ANSWERS parameters.", & + default=.true.) + call get_param(param_file, mdl, "REMAPPING_2018_ANSWERS", CS%answers_2018, & + "If true, use the order of arithmetic and expressions that recover the "//& + "answers from the end of 2018. Otherwise, use updated and more robust "//& + "forms of the same expressions.", default=default_2018_answers) call initialize_remapping( CS%remapCS, string, & boundary_extrapolation=remap_boundary_extrap, & check_reconstruction=check_reconstruction, & check_remapping=check_remapping, & - force_bounds_in_subcell=force_bounds_in_subcell) + force_bounds_in_subcell=force_bounds_in_subcell, & + answers_2018=CS%answers_2018) call get_param(param_file, mdl, "REMAP_AFTER_INITIALIZATION", CS%remap_after_initialization, & "If true, applies regridding and remapping immediately after "//& @@ -220,7 +233,7 @@ subroutine ALE_init( param_file, GV, US, max_depth, CS) "REGRID_FILTER_SHALLOW_DEPTH the filter weights adopt a cubic profile.", & units="m", default=0., scale=GV%m_to_H) call set_regrid_params(CS%regridCS, depth_of_time_filter_shallow=filter_shallow_depth, & - depth_of_time_filter_deep=filter_deep_depth) + depth_of_time_filter_deep=filter_deep_depth) call get_param(param_file, mdl, "REGRID_USE_OLD_DIRECTION", local_logical, & "If true, the regridding ntegrates upwards from the bottom for "//& "interface positions, much as the main model does. If false "//& @@ -1089,13 +1102,13 @@ subroutine pressure_gradient_ppm( CS, S_t, S_b, T_t, T_b, G, GV, tv, h, bdry_ext ! Local variables integer :: i, j, k - real :: hTmp(GV%ke) - real :: tmp(GV%ke) + real :: hTmp(GV%ke) ! A 1-d copy of h [H ~> m or kg m-2] + real :: tmp(GV%ke) ! A 1-d copy of a column of temperature [degC] or salinity [ppt] real, dimension(CS%nk,2) :: & - ppol_E !Edge value of polynomial + ppol_E ! Edge value of polynomial in [degC] or [ppt] real, dimension(CS%nk,3) :: & - ppol_coefs !Coefficients of polynomial - real :: h_neglect, h_neglect_edge + ppol_coefs ! Coefficients of polynomial, all in [degC] or [ppt] + real :: h_neglect, h_neglect_edge ! Tiny thicknesses [H ~> m or kg m-2] !### Try replacing both of these with GV%H_subroundoff if (GV%Boussinesq) then @@ -1116,7 +1129,8 @@ subroutine pressure_gradient_ppm( CS, S_t, S_b, T_t, T_b, G, GV, tv, h, bdry_ext ppol_E(:,:) = 0.0 ppol_coefs(:,:) = 0.0 !### Try to replace the following value of h_neglect with GV%H_subroundoff. - call edge_values_implicit_h4( GV%ke, hTmp, tmp, ppol_E, h_neglect=h_neglect_edge ) + call edge_values_implicit_h4( GV%ke, hTmp, tmp, ppol_E, h_neglect=h_neglect_edge, & + answers_2018=CS%answers_2018 ) call PPM_reconstruction( GV%ke, hTmp, tmp, ppol_E, ppol_coefs, h_neglect ) if (bdry_extrap) & call PPM_boundary_extrapolation( GV%ke, hTmp, tmp, ppol_E, ppol_coefs, h_neglect ) @@ -1131,7 +1145,8 @@ subroutine pressure_gradient_ppm( CS, S_t, S_b, T_t, T_b, G, GV, tv, h, bdry_ext ppol_coefs(:,:) = 0.0 tmp(:) = tv%T(i,j,:) !### Try to replace the following value of h_neglect with GV%H_subroundoff. - call edge_values_implicit_h4( GV%ke, hTmp, tmp, ppol_E, h_neglect=1.0e-10*GV%m_to_H ) + call edge_values_implicit_h4( GV%ke, hTmp, tmp, ppol_E, h_neglect=1.0e-10*GV%m_to_H, & + answers_2018=CS%answers_2018 ) call PPM_reconstruction( GV%ke, hTmp, tmp, ppol_E, ppol_coefs, h_neglect ) if (bdry_extrap) & call PPM_boundary_extrapolation(GV%ke, hTmp, tmp, ppol_E, ppol_coefs, h_neglect ) diff --git a/src/ALE/MOM_remapping.F90 b/src/ALE/MOM_remapping.F90 index f399aa2c0f..d7f8343993 100644 --- a/src/ALE/MOM_remapping.F90 +++ b/src/ALE/MOM_remapping.F90 @@ -33,6 +33,8 @@ module MOM_remapping logical :: check_remapping = .false. !> If true, the intermediate values used in remapping are forced to be bounded. logical :: force_bounds_in_subcell = .false. + !> If true use older, less acccurate expressions. + logical :: answers_2018 = .true. end type ! The following routines are visible to the outside world @@ -84,13 +86,14 @@ module MOM_remapping !> Set parameters within remapping object subroutine remapping_set_param(CS, remapping_scheme, boundary_extrapolation, & - check_reconstruction, check_remapping, force_bounds_in_subcell) + check_reconstruction, check_remapping, force_bounds_in_subcell, answers_2018) type(remapping_CS), intent(inout) :: CS !< Remapping control structure character(len=*), optional, intent(in) :: remapping_scheme !< Remapping scheme to use logical, optional, intent(in) :: boundary_extrapolation !< Indicate to extrapolate in boundary cells logical, optional, intent(in) :: check_reconstruction !< Indicate to check reconstructions logical, optional, intent(in) :: check_remapping !< Indicate to check results of remapping logical, optional, intent(in) :: force_bounds_in_subcell !< Force subcells values to be bounded + logical, optional, intent(in) :: answers_2018 !< If true use older, less acccurate expressions. if (present(remapping_scheme)) then call setReconstructionType( remapping_scheme, CS ) @@ -107,6 +110,9 @@ subroutine remapping_set_param(CS, remapping_scheme, boundary_extrapolation, & if (present(force_bounds_in_subcell)) then CS%force_bounds_in_subcell = force_bounds_in_subcell endif + if (present(answers_2018)) then + CS%answers_2018 = answers_2018 + endif end subroutine remapping_set_param subroutine extract_member_remapping_CS(CS, remapping_scheme, degree, boundary_extrapolation, check_reconstruction, & @@ -392,22 +398,22 @@ subroutine build_reconstructions_1d( CS, n0, h0, u0, ppoly_r_coefs, & endif iMethod = INTEGRATION_PLM case ( REMAPPING_PPM_H4 ) - call edge_values_explicit_h4( n0, h0, u0, ppoly_r_E, h_neglect_edge ) + call edge_values_explicit_h4( n0, h0, u0, ppoly_r_E, h_neglect_edge, answers_2018=CS%answers_2018 ) call PPM_reconstruction( n0, h0, u0, ppoly_r_E, ppoly_r_coefs, h_neglect ) if ( CS%boundary_extrapolation ) then call PPM_boundary_extrapolation( n0, h0, u0, ppoly_r_E, ppoly_r_coefs, h_neglect ) endif iMethod = INTEGRATION_PPM case ( REMAPPING_PPM_IH4 ) - call edge_values_implicit_h4( n0, h0, u0, ppoly_r_E, h_neglect_edge ) + call edge_values_implicit_h4( n0, h0, u0, ppoly_r_E, h_neglect_edge, answers_2018=CS%answers_2018 ) call PPM_reconstruction( n0, h0, u0, ppoly_r_E, ppoly_r_coefs, h_neglect ) if ( CS%boundary_extrapolation ) then call PPM_boundary_extrapolation( n0, h0, u0, ppoly_r_E, ppoly_r_coefs, h_neglect ) endif iMethod = INTEGRATION_PPM case ( REMAPPING_PQM_IH4IH3 ) - call edge_values_implicit_h4( n0, h0, u0, ppoly_r_E, h_neglect_edge ) - call edge_slopes_implicit_h3( n0, h0, u0, ppoly_r_S, h_neglect ) + call edge_values_implicit_h4( n0, h0, u0, ppoly_r_E, h_neglect_edge, answers_2018=CS%answers_2018 ) + call edge_slopes_implicit_h3( n0, h0, u0, ppoly_r_S, h_neglect, answers_2018=CS%answers_2018 ) call PQM_reconstruction( n0, h0, u0, ppoly_r_E, ppoly_r_S, ppoly_r_coefs, h_neglect ) if ( CS%boundary_extrapolation ) then call PQM_boundary_extrapolation_v1( n0, h0, u0, ppoly_r_E, ppoly_r_S, & @@ -415,8 +421,8 @@ subroutine build_reconstructions_1d( CS, n0, h0, u0, ppoly_r_coefs, & endif iMethod = INTEGRATION_PQM case ( REMAPPING_PQM_IH6IH5 ) - call edge_values_implicit_h6( n0, h0, u0, ppoly_r_E, h_neglect_edge ) - call edge_slopes_implicit_h5( n0, h0, u0, ppoly_r_S, h_neglect ) + call edge_values_implicit_h6( n0, h0, u0, ppoly_r_E, h_neglect_edge, answers_2018=CS%answers_2018 ) + call edge_slopes_implicit_h5( n0, h0, u0, ppoly_r_S, h_neglect, answers_2018=CS%answers_2018 ) call PQM_reconstruction( n0, h0, u0, ppoly_r_E, ppoly_r_S, ppoly_r_coefs, h_neglect ) if ( CS%boundary_extrapolation ) then call PQM_boundary_extrapolation_v1( n0, h0, u0, ppoly_r_E, ppoly_r_S, & @@ -1537,7 +1543,7 @@ end subroutine dzFromH1H2 !> Constructor for remapping control structure subroutine initialize_remapping( CS, remapping_scheme, boundary_extrapolation, & - check_reconstruction, check_remapping, force_bounds_in_subcell) + check_reconstruction, check_remapping, force_bounds_in_subcell, answers_2018) ! Arguments type(remapping_CS), intent(inout) :: CS !< Remapping control structure character(len=*), intent(in) :: remapping_scheme !< Remapping scheme to use @@ -1545,11 +1551,12 @@ subroutine initialize_remapping( CS, remapping_scheme, boundary_extrapolation, & logical, optional, intent(in) :: check_reconstruction !< Indicate to check reconstructions logical, optional, intent(in) :: check_remapping !< Indicate to check results of remapping logical, optional, intent(in) :: force_bounds_in_subcell !< Force subcells values to be bounded + logical, optional, intent(in) :: answers_2018 !< If true use older, less acccurate expressions. - ! Note that remapping_scheme is mandatory fir initialize_remapping() + ! Note that remapping_scheme is mandatory for initialize_remapping() call remapping_set_param(CS, remapping_scheme=remapping_scheme, boundary_extrapolation=boundary_extrapolation, & check_reconstruction=check_reconstruction, check_remapping=check_remapping, & - force_bounds_in_subcell=force_bounds_in_subcell) + force_bounds_in_subcell=force_bounds_in_subcell, answers_2018=answers_2018) end subroutine initialize_remapping @@ -1615,6 +1622,7 @@ logical function remapping_unit_tests(verbose) data h2 /6*0.5/ ! 6 uniform layers with total depth of 3 type(remapping_CS) :: CS !< Remapping control structure real, allocatable, dimension(:,:) :: ppoly0_E, ppoly0_S, ppoly0_coefs + logical :: answers_2018 ! If true use older, less acccurate expressions. integer :: i real :: err, h_neglect, h_neglect_edge logical :: thisTest, v @@ -1622,6 +1630,7 @@ logical function remapping_unit_tests(verbose) v = verbose h_neglect = hNeglect_dflt h_neglect_edge = 1.0e-10 + answers_2018 = .true. write(*,*) '==== MOM_remapping: remapping_unit_tests =================' remapping_unit_tests = .false. ! Normally return false @@ -1643,7 +1652,7 @@ logical function remapping_unit_tests(verbose) remapping_unit_tests = remapping_unit_tests .or. thisTest thisTest = .false. - call initialize_remapping(CS, 'PPM_H4') + call initialize_remapping(CS, 'PPM_H4', answers_2018=answers_2018) if (verbose) write(*,*) 'h0 (test data)' if (verbose) call dumpGrid(n0,h0,x0,u0) @@ -1667,7 +1676,7 @@ logical function remapping_unit_tests(verbose) ppoly0_S(:,:) = 0.0 ppoly0_coefs(:,:) = 0.0 - call edge_values_explicit_h4( n0, h0, u0, ppoly0_E, h_neglect=1e-10 ) + call edge_values_explicit_h4( n0, h0, u0, ppoly0_E, h_neglect=1e-10, answers_2018=answers_2018 ) call PPM_reconstruction( n0, h0, u0, ppoly0_E, ppoly0_coefs, h_neglect ) call PPM_boundary_extrapolation( n0, h0, u0, ppoly0_E, ppoly0_coefs, h_neglect ) u1(:) = 0. @@ -1798,7 +1807,7 @@ logical function remapping_unit_tests(verbose) test_answer(v, 3, ppoly0_coefs(:,2), (/0.,4.,0./), 'Non-uniform line PLM: P1') call edge_values_explicit_h4( 5, (/1.,1.,1.,1.,1./), (/1.,3.,5.,7.,9./), ppoly0_E, & - h_neglect=1e-10 ) + h_neglect=1e-10, answers_2018=answers_2018 ) ! The next two tests currently fail due to roundoff. thisTest = test_answer(v, 5, ppoly0_E(:,1), (/0.,2.,4.,6.,8./), 'Line H4: left edges') thisTest = test_answer(v, 5, ppoly0_E(:,2), (/2.,4.,6.,8.,10./), 'Line H4: right edges') @@ -1814,7 +1823,7 @@ logical function remapping_unit_tests(verbose) test_answer(v, 5, ppoly0_coefs(:,3), (/0.,0.,0.,0.,0./), 'Line PPM: P2') call edge_values_explicit_h4( 5, (/1.,1.,1.,1.,1./), (/1.,1.,7.,19.,37./), ppoly0_E, & - h_neglect=1e-10 ) + h_neglect=1e-10, answers_2018=answers_2018 ) ! The next two tests currently fail due to roundoff. thisTest = test_answer(v, 5, ppoly0_E(:,1), (/3.,0.,3.,12.,27./), 'Parabola H4: left edges') thisTest = test_answer(v, 5, ppoly0_E(:,2), (/0.,3.,12.,27.,48./), 'Parabola H4: right edges') diff --git a/src/ALE/P3M_functions.F90 b/src/ALE/P3M_functions.F90 index 1964cd25dd..da3fe5bb6b 100644 --- a/src/ALE/P3M_functions.F90 +++ b/src/ALE/P3M_functions.F90 @@ -25,20 +25,15 @@ module P3M_functions !! !! It is assumed that the size of the array 'u' is equal to the number of cells !! defining 'grid' and 'ppoly'. No consistency check is performed here. -subroutine P3M_interpolation( N, h, u, ppoly_E, ppoly_S, ppoly_coef, & - h_neglect ) +subroutine P3M_interpolation( N, h, u, ppoly_E, ppoly_S, ppoly_coef, h_neglect ) integer, intent(in) :: N !< Number of cells - real, dimension(:), intent(in) :: h !< cell widths (size N) - real, dimension(:), intent(in) :: u !< cell averages (size N) - real, dimension(:,:), intent(inout) :: ppoly_E !< Edge value of polynomial, - !! with the same units as u. - real, dimension(:,:), intent(inout) :: ppoly_S !< Edge slope of polynomial, - !! in the units of u over the units of h. - real, dimension(:,:), intent(inout) :: ppoly_coef !< Coefficients of polynomial, mainly - !! with the same units as u. + real, dimension(:), intent(in) :: h !< cell widths (size N) [H] + real, dimension(:), intent(in) :: u !< cell averages (size N) in arbitrary units [A] + real, dimension(:,:), intent(inout) :: ppoly_E !< Edge value of polynomial [A] + real, dimension(:,:), intent(inout) :: ppoly_S !< Edge slope of polynomial [A H-1]. + real, dimension(:,:), intent(inout) :: ppoly_coef !< Coefficients of polynomial [A] real, optional, intent(in) :: h_neglect !< A negligibly small width for the - !! purpose of cell reconstructions - !! in the same units as h. + !! purpose of cell reconstructions [H] ! Call the limiter for p3m, which takes care of everything from ! computing the coefficients of the cubic to monotonizing it. @@ -64,28 +59,24 @@ end subroutine P3M_interpolation !! Step 3 of the monotonization process leaves all edge values unchanged. subroutine P3M_limiter( N, h, u, ppoly_E, ppoly_S, ppoly_coef, h_neglect ) integer, intent(in) :: N !< Number of cells - real, dimension(:), intent(in) :: h !< cell widths (size N) - real, dimension(:), intent(in) :: u !< cell averages (size N) - real, dimension(:,:), intent(inout) :: ppoly_E !< Edge value of polynomial, - !! with the same units as u. - real, dimension(:,:), intent(inout) :: ppoly_S !< Edge slope of polynomial, - !! in the units of u over the units of h. - real, dimension(:,:), intent(inout) :: ppoly_coef !< Coefficients of polynomial + real, dimension(:), intent(in) :: h !< cell widths (size N) [H] + real, dimension(:), intent(in) :: u !< cell averages (size N) in arbitrary units [A] + real, dimension(:,:), intent(inout) :: ppoly_E !< Edge value of polynomial [A] + real, dimension(:,:), intent(inout) :: ppoly_S !< Edge slope of polynomial [A H-1] + real, dimension(:,:), intent(inout) :: ppoly_coef !< Coefficients of polynomial [A] real, optional, intent(in) :: h_neglect !< A negligibly small width for - !! the purpose of cell reconstructions - !! in the same units as h. + !! the purpose of cell reconstructions [H] ! Local variables integer :: k ! loop index - integer :: monotonic ! boolean indicating whether the cubic is monotonic - real :: u0_l, u0_r ! edge values - real :: u1_l, u1_r ! edge slopes - real :: u_l, u_c, u_r ! left, center and right cell averages - real :: h_l, h_c, h_r ! left, center and right cell widths - real :: sigma_l, sigma_c, sigma_r ! left, center and right - ! van Leer slopes - real :: slope ! retained PLM slope + logical :: monotonic ! boolean indicating whether the cubic is monotonic + real :: u0_l, u0_r ! edge values [A] + real :: u1_l, u1_r ! edge slopes [A H-1] + real :: u_l, u_c, u_r ! left, center and right cell averages [A] + real :: h_l, h_c, h_r ! left, center and right cell widths [H] + real :: sigma_l, sigma_c, sigma_r ! left, center and right van Leer slopes [A H-1] + real :: slope ! retained PLM slope [A H-1] real :: eps - real :: hNeglect + real :: hNeglect ! A negligibly small thickness [H] hNeglect = hNeglect_dflt ; if (present(h_neglect)) hNeglect = h_neglect @@ -142,16 +133,9 @@ subroutine P3M_limiter( N, h, u, ppoly_E, ppoly_S, ppoly_coef, h_neglect ) slope = 0.0 endif - ! If the slopes are close to zero in machine precision and in absolute - ! value, we set the slope to zero. This prevents asymmetric representation - ! near extrema. These expressions are both nondimensional. - if ( abs(u1_l*h_c) < eps ) then - u1_l = 0.0 - endif - - if ( abs(u1_r*h_c) < eps ) then - u1_r = 0.0 - endif + ! If the slopes are small, set them to zero to prevent asymmetric representation near extrema. + if ( abs(u1_l*h_c) < epsilon(u_c)*abs(u_c) ) u1_l = 0.0 + if ( abs(u1_r*h_c) < epsilon(u_c)*abs(u_c) ) u1_r = 0.0 ! The edge slopes are limited from above by the respective ! one-sided slopes @@ -172,7 +156,7 @@ subroutine P3M_limiter( N, h, u, ppoly_E, ppoly_S, ppoly_coef, h_neglect ) ! If cubic is not monotonic, monotonize it by modifiying the ! edge slopes, store the new edge slopes and recompute the ! cubic coefficients - if ( monotonic == 0 ) then + if ( .not.monotonic ) then call monotonize_cubic( h_c, u0_l, u0_r, sigma_l, sigma_r, slope, u1_l, u1_r ) endif @@ -204,30 +188,25 @@ end subroutine P3M_limiter subroutine P3M_boundary_extrapolation( N, h, u, ppoly_E, ppoly_S, ppoly_coef, & h_neglect, h_neglect_edge ) integer, intent(in) :: N !< Number of cells - real, dimension(:), intent(in) :: h !< cell widths (size N) - real, dimension(:), intent(in) :: u !< cell averages (size N) - real, dimension(:,:), intent(inout) :: ppoly_E !< Edge value of polynomial, - !! with the same units as u. - real, dimension(:,:), intent(inout) :: ppoly_S !< Edge slope of polynomial, - !! in the units of u over the units of h. - real, dimension(:,:), intent(inout) :: ppoly_coef !< Coefficients of polynomial, mainly - !! with the same units as u. + real, dimension(:), intent(in) :: h !< cell widths (size N) [H] + real, dimension(:), intent(in) :: u !< cell averages (size N) in arbitrary units [A] + real, dimension(:,:), intent(inout) :: ppoly_E !< Edge value of polynomial [A] + real, dimension(:,:), intent(inout) :: ppoly_S !< Edge slope of polynomial [A H-1] + real, dimension(:,:), intent(inout) :: ppoly_coef !< Coefficients of polynomial [A] real, optional, intent(in) :: h_neglect !< A negligibly small width for the - !! purpose of cell reconstructions - !! in the same units as h. + !! purpose of cell reconstructions [H] real, optional, intent(in) :: h_neglect_edge !< A negligibly small width - !! for the purpose of finding edge values - !! in the same units as h. + !! for the purpose of finding edge values [H] ! Local variables integer :: i0, i1 - integer :: monotonic - real :: u0, u1 - real :: h0, h1 - real :: b, c, d - real :: u0_l, u0_r - real :: u1_l, u1_r - real :: slope - real :: hNeglect, hNeglect_edge + logical :: monotonic ! boolean indicating whether the cubic is monotonic + real :: u0, u1 ! Values of u in two adjacent cells [A] + real :: h0, h1 ! Values of h in two adjacent cells, plus a smal increment [H] + real :: b, c, d ! Temporary variables [A] + real :: u0_l, u0_r ! Left and right edge values [A] + real :: u1_l, u1_r ! Left and right edge slopes [A H-1] + real :: slope ! The cell center slope [A H-1] + real :: hNeglect, hNeglect_edge ! Negligibly small thickness [H] hNeglect = hNeglect_dflt ; if (present(h_neglect)) hNeglect = h_neglect hNeglect_edge = hNeglect_edge_dflt @@ -281,7 +260,7 @@ subroutine P3M_boundary_extrapolation( N, h, u, ppoly_E, ppoly_S, ppoly_coef, & call build_cubic_interpolant( h, i0, ppoly_E, ppoly_S, ppoly_coef ) monotonic = is_cubic_monotonic( ppoly_coef, i0 ) - if ( monotonic == 0 ) then + if ( .not.monotonic ) then call monotonize_cubic( h0, u0_l, u0_r, 0.0, slope, slope, u1_l, u1_r ) ! Rebuild cubic after monotonization @@ -340,7 +319,7 @@ subroutine P3M_boundary_extrapolation( N, h, u, ppoly_E, ppoly_S, ppoly_coef, & call build_cubic_interpolant( h, i1, ppoly_E, ppoly_S, ppoly_coef ) monotonic = is_cubic_monotonic( ppoly_coef, i1 ) - if ( monotonic == 0 ) then + if ( .not.monotonic ) then call monotonize_cubic( h1, u0_l, u0_r, slope, 0.0, slope, u1_l, u1_r ) ! Rebuild cubic after monotonization @@ -360,19 +339,17 @@ end subroutine P3M_boundary_extrapolation !! NOTE: edge values and slopes MUST have been properly calculated prior to !! calling this routine. subroutine build_cubic_interpolant( h, k, ppoly_E, ppoly_S, ppoly_coef ) - real, dimension(:), intent(in) :: h !< cell widths (size N) + real, dimension(:), intent(in) :: h !< cell widths (size N) [H] integer, intent(in) :: k !< The index of the cell to work on - real, dimension(:,:), intent(in) :: ppoly_E !< Edge value of polynomial, - !! with the same units as u. - real, dimension(:,:), intent(in) :: ppoly_S !< Edge slope of polynomial, - !! in the units of u over the units of h. - real, dimension(:,:), intent(inout) :: ppoly_coef !< Coefficients of polynomial, mainly - !! with the same units as u. + real, dimension(:,:), intent(in) :: ppoly_E !< Edge value of polynomial in arbitrary units [A] + real, dimension(:,:), intent(in) :: ppoly_S !< Edge slope of polynomial [A H-1] + real, dimension(:,:), intent(inout) :: ppoly_coef !< Coefficients of polynomial [A] + ! Local variables - real :: u0_l, u0_r ! edge values - real :: u1_l, u1_r ! edge slopes - real :: h_c ! cell width - real :: a0, a1, a2, a3 ! cubic coefficients + real :: u0_l, u0_r ! edge values [A] + real :: u1_l, u1_r ! edge slopes times the cell width [A] + real :: h_c ! cell width [H] + real :: a0, a1, a2, a3 ! cubic coefficients [A] h_c = h(k) @@ -400,63 +377,30 @@ end subroutine build_cubic_interpolant !! This function checks whether the cubic curve in cell k is monotonic. !! If so, returns 1. Otherwise, returns 0. !! -!! The cubic is monotonic if the first derivative is single-signed in [0,1]. +!! The cubic is monotonic if the first derivative is single-signed in (0,1). !! Hence, we check whether the roots (if any) lie inside this interval. If there !! is no root or if both roots lie outside this interval, the cubic is monotonic. -integer function is_cubic_monotonic( ppoly_coef, k ) - real, dimension(:,:), intent(in) :: ppoly_coef !< Coefficients of cubic polynomial +logical function is_cubic_monotonic( ppoly_coef, k ) + real, dimension(:,:), intent(in) :: ppoly_coef !< Coefficients of cubic polynomial in arbitary units [A] integer, intent(in) :: k !< The index of the cell to work on ! Local variables - integer :: monotonic ! boolean indicating if monotonic or not - real :: a0, a1, a2, a3 ! cubic coefficients - real :: a, b, c ! coefficients of first derivative - real :: xi_0, xi_1 ! roots of first derivative (if any !) - real :: rho - real :: eps - - ! Define the radius of the ball around 0 and 1 in which all values are assumed - ! to be equal to 0 or 1, respectively - eps = 1e-14 - - a0 = ppoly_coef(k,1) - a1 = ppoly_coef(k,2) - a2 = ppoly_coef(k,3) - a3 = ppoly_coef(k,4) - - a = a1 - b = 2.0 * a2 - c = 3.0 * a3 - - xi_0 = -1.0 - xi_1 = -1.0 - - rho = b*b - 4.0*a*c - - if ( rho >= 0.0 ) then - if ( abs(c) > 1e-15 ) then - xi_0 = 0.5 * ( -b - sqrt( rho ) ) / c - xi_1 = 0.5 * ( -b + sqrt( rho ) ) / c - elseif ( abs(b) > 1e-15 ) then - xi_0 = - a / b - xi_1 = - a / b - endif - - ! If one of the roots of the first derivative lies in (0,1), - ! the cubic is not monotonic. - if ( ( (xi_0 > eps) .AND. (xi_0 < 1.0-eps) ) .OR. & - ( (xi_1 > eps) .AND. (xi_1 < 1.0-eps) ) ) then - monotonic = 0 - else - monotonic = 1 - endif - - else ! there are no real roots --> cubic is monotonic - monotonic = 1 + real :: a, b, c ! Coefficients of the first derivative of the cubic [A] + + a = ppoly_coef(k,2) + b = 2.0 * ppoly_coef(k,3) + c = 3.0 * ppoly_coef(k,4) + + ! Look for real roots of the quadratic derivative equation, c*x**2 + b*x + a = 0, in (0, 1) + if (b*b - 4.0*a*c <= 0.0) then ! The cubic is monotonic everywhere. + is_cubic_monotonic = .true. + elseif (a * (a + (b + c)) < 0.0) then ! The derivative changes sign between the endpoints of (0, 1) + is_cubic_monotonic = .false. + elseif (b * (b + 2.0*c) < 0.0) then ! The second derivative changes sign inside of (0, 1) + is_cubic_monotonic = .false. + else + is_cubic_monotonic = .true. endif - ! Set the return value - is_cubic_monotonic = monotonic - end function is_cubic_monotonic !> Monotonize a cubic curve by modifying the edge slopes. @@ -487,30 +431,27 @@ end function is_cubic_monotonic !! edge or onto the right edge. subroutine monotonize_cubic( h, u0_l, u0_r, sigma_l, sigma_r, slope, u1_l, u1_r ) - real, intent(in) :: h !< cell width - real, intent(in) :: u0_l !< left edge value - real, intent(in) :: u0_r !< right edge value - real, intent(in) :: sigma_l !< left 2nd-order slopes - real, intent(in) :: sigma_r !< right 2nd-order slopes - real, intent(in) :: slope !< limited PLM slope - real, intent(inout) :: u1_l !< left edge slopes - real, intent(inout) :: u1_r !< right edge slopes + real, intent(in) :: h !< cell width [H] + real, intent(in) :: u0_l !< left edge value in arbitrary units [A] + real, intent(in) :: u0_r !< right edge value [A] + real, intent(in) :: sigma_l !< left 2nd-order slopes [A H-1] + real, intent(in) :: sigma_r !< right 2nd-order slopes [A H-1] + real, intent(in) :: slope !< limited PLM slope [A H-1] + real, intent(inout) :: u1_l !< left edge slopes [A H-1] + real, intent(inout) :: u1_r !< right edge slopes [A H-1] ! Local variables - integer :: found_ip - integer :: inflexion_l ! bool telling if inflex. pt must be on left - integer :: inflexion_r ! bool telling if inflex. pt must be on right - real :: eps - real :: a1, a2, a3 - real :: u1_l_tmp ! trial left edge slope - real :: u1_r_tmp ! trial right edge slope - real :: xi_ip ! location of inflexion point - real :: slope_ip ! slope at inflexion point - - eps = 1e-14 - - found_ip = 0 - inflexion_l = 0 - inflexion_r = 0 + logical :: found_ip + logical :: inflexion_l ! bool telling if inflex. pt must be on left + logical :: inflexion_r ! bool telling if inflex. pt must be on right + real :: a1, a2, a3 ! Temporary slopes times the cell width [A] + real :: u1_l_tmp ! trial left edge slope [A H-1] + real :: u1_r_tmp ! trial right edge slope [A H-1] + real :: xi_ip ! location of inflexion point in cell coordinates (0,1) [nondim] + real :: slope_ip ! slope at inflexion point times cell width [A] + + found_ip = .false. + inflexion_l = .false. + inflexion_r = .false. ! If the edge slopes are inconsistent w.r.t. the limited PLM slope, ! set them to zero @@ -537,7 +478,7 @@ subroutine monotonize_cubic( h, u0_l, u0_r, sigma_l, sigma_r, slope, u1_l, u1_r ! If the inflexion point lies in [0,1], change boolean value if ( (xi_ip >= 0.0) .AND. (xi_ip <= 1.0) ) then - found_ip = 1 + found_ip = .true. endif endif @@ -546,25 +487,25 @@ subroutine monotonize_cubic( h, u0_l, u0_r, sigma_l, sigma_r, slope, u1_l, u1_r ! decide on which side we want to collapse the inflexion point. ! If the inflexion point lies on one of the edges, the cubic is ! guaranteed to be monotonic - if ( found_ip == 1 ) then + if ( found_ip ) then slope_ip = a1 + 2.0*a2*xi_ip + 3.0*a3*xi_ip*xi_ip ! Check whether slope is consistent if ( slope_ip*slope < 0.0 ) then if ( abs(sigma_l) < abs(sigma_r) ) then - inflexion_l = 1 + inflexion_l = .true. else - inflexion_r = 1 + inflexion_r = .true. endif endif endif ! found_ip ! At this point, if the cubic is not monotonic, we know where the ! inflexion point should lie. When the cubic is monotonic, both - ! 'inflexion_l' and 'inflexion_r' are set to 0 and nothing is to be done. + ! 'inflexion_l' and 'inflexion_r' are false and nothing is to be done. ! Move inflexion point on the left - if ( inflexion_l == 1 ) then + if ( inflexion_l ) then u1_l_tmp = 1.5*(u0_r-u0_l)/h - 0.5*u1_r u1_r_tmp = 3.0*(u0_r-u0_l)/h - 2.0*u1_l @@ -594,7 +535,7 @@ subroutine monotonize_cubic( h, u0_l, u0_r, sigma_l, sigma_r, slope, u1_l, u1_r endif ! end treating case with inflexion point on the left ! Move inflexion point on the right - if ( inflexion_r == 1 ) then + if ( inflexion_r ) then u1_l_tmp = 3.0*(u0_r-u0_l)/h - 2.0*u1_r u1_r_tmp = 1.5*(u0_r-u0_l)/h - 0.5*u1_l @@ -623,13 +564,9 @@ subroutine monotonize_cubic( h, u0_l, u0_r, sigma_l, sigma_r, slope, u1_l, u1_r endif ! end treating case with inflexion point on the right - if ( abs(u1_l*h) < eps ) then - u1_l = 0.0 - endif - - if ( abs(u1_r*h) < eps ) then - u1_r = 0.0 - endif + ! Zero out negligibly small slopes. + if ( abs(u1_l*h) < epsilon(u0_l) * (abs(u0_l) + abs(u0_r)) ) u1_l = 0.0 + if ( abs(u1_r*h) < epsilon(u0_l) * (abs(u0_l) + abs(u0_r)) ) u1_r = 0.0 end subroutine monotonize_cubic diff --git a/src/ALE/regrid_edge_slopes.F90 b/src/ALE/regrid_edge_slopes.F90 index c22a524683..8d5c055907 100644 --- a/src/ALE/regrid_edge_slopes.F90 +++ b/src/ALE/regrid_edge_slopes.F90 @@ -46,35 +46,39 @@ module regrid_edge_slopes !! !! There are N+1 unknowns and we are able to write N-1 equations. The !! boundary conditions close the system. -subroutine edge_slopes_implicit_h3( N, h, u, edge_slopes, h_neglect ) +subroutine edge_slopes_implicit_h3( N, h, u, edge_slopes, h_neglect, answers_2018 ) integer, intent(in) :: N !< Number of cells - real, dimension(:), intent(in) :: h !< cell widths (size N) - real, dimension(:), intent(in) :: u !< cell average properties (size N) - real, dimension(:,:), intent(inout) :: edge_slopes !< Returned edge slopes, with the - !! same units as u divided by the units of h. + real, dimension(:), intent(in) :: h !< cell widths (size N) [H] + real, dimension(:), intent(in) :: u !< cell average properties (size N) in arbitrary units [A] + real, dimension(:,:), intent(inout) :: edge_slopes !< Returned edge slopes [A H-1] real, optional, intent(in) :: h_neglect !< A negligibly small width + logical, optional, intent(in) :: answers_2018 !< If true use older, less acccurate expressions. ! Local variables integer :: i, j ! loop indexes - real :: h0, h1 ! cell widths - real :: h0_2, h1_2, h0h1 - real :: h0_3, h1_3 - real :: d - real :: alpha, beta ! stencil coefficients - real :: a, b - real, dimension(5) :: x ! system used to enforce - real, dimension(4,4) :: Asys ! boundary conditions + real :: h0, h1 ! cell widths [H] + real :: h0_2, h1_2, h0h1 ! products of cell widths [H2] + real :: h0_3, h1_3 ! products of three cell widths [H3] + real :: d ! A demporary variable [H3] + real :: alpha, beta ! stencil coefficients [nondim] + real :: a, b ! weights of cells [H-1] + real, parameter :: C1_12 = 1.0 / 12.0 + real, dimension(5) :: x ! Coordinate system with 0 at edges [H] + real :: dx, xavg ! Differences and averages of successive values of x [H] + real, dimension(4,4) :: Asys ! matrix used to find boundary conditions real, dimension(4) :: Bsys, Csys real, dimension(3) :: Dsys - real, dimension(N+1) :: tri_l, & ! trid. system (lower diagonal) - tri_d, & ! trid. system (middle diagonal) - tri_u, & ! trid. system (upper diagonal) - tri_b, & ! trid. system (unknowns vector) - tri_x ! trid. system (rhs) - real :: hNeglect ! A negligible thicness in the same units as h. - real :: hNeglect3 ! hNeglect^3 in the same units as h^3. + real, dimension(N+1) :: tri_l, & ! trid. system (lower diagonal) [nondim] + tri_d, & ! trid. system (middle diagonal) [nondim] + tri_u, & ! trid. system (upper diagonal) [nondim] + tri_b, & ! trid. system (unknowns vector) [A H-1] + tri_x ! trid. system (rhs) [A H-1] + real :: hNeglect ! A negligible thickness [H]. + real :: hNeglect3 ! hNeglect^3 [H3]. + logical :: use_2018_answers ! If true use older, less acccurate expressions. hNeglect = hNeglect_dflt ; if (present(h_neglect)) hNeglect = h_neglect hNeglect3 = hNeglect**3 + use_2018_answers = .true. ; if (present(answers_2018)) use_2018_answers = answers_2018 ! Loop on cells (except last one) do i = 1,N-1 @@ -113,12 +117,18 @@ subroutine edge_slopes_implicit_h3( N, h, u, edge_slopes, h_neglect ) enddo do i = 1,4 - - do j = 1,4 - Asys(i,j) = ( (x(i+1)**j) - (x(i)**j) ) / j - enddo - - Bsys(i) = u(i) * ( h(i) ) + dx = h(i) + if (use_2018_answers) then + do j = 1,4 ; Asys(i,j) = ( (x(i+1)**j) - (x(i)**j) ) / j ; enddo + else ! Use expressions with less sensitivity to roundoff + xavg = 0.5 * (x(i+1) + x(i)) + Asys(i,1) = dx + Asys(i,2) = dx * xavg + Asys(i,3) = dx * (xavg**2 + C1_12*dx**2) + Asys(i,4) = dx * xavg * (xavg**2 + 0.25*dx**2) + endif + + Bsys(i) = u(i) * dx enddo @@ -139,12 +149,17 @@ subroutine edge_slopes_implicit_h3( N, h, u, edge_slopes, h_neglect ) enddo do i = 1,4 - - do j = 1,4 - Asys(i,j) = ( (x(i+1)**j) - (x(i)**j) ) / j - enddo - - Bsys(i) = u(N-4+i) * ( h(N-4+i) ) + dx = h(N-4+i) + if (use_2018_answers) then + do j = 1,4 ; Asys(i,j) = ( (x(i+1)**j) - (x(i)**j) ) / j ; enddo + else ! Use expressions with less sensitivity to roundoff + xavg = 0.5 * (x(i+1) + x(i)) + Asys(i,1) = dx + Asys(i,2) = dx * xavg + Asys(i,3) = dx * (xavg**2 + C1_12*dx**2) + Asys(i,4) = dx * xavg * (xavg**2 + 0.25*dx**2) + endif + Bsys(i) = u(N-4+i) * dx enddo @@ -173,14 +188,13 @@ end subroutine edge_slopes_implicit_h3 !------------------------------------------------------------------------------ !> Compute ih5 edge values (implicit fifth order accurate) -subroutine edge_slopes_implicit_h5( N, h, u, edge_slopes, h_neglect ) +subroutine edge_slopes_implicit_h5( N, h, u, edge_slopes, h_neglect, answers_2018 ) integer, intent(in) :: N !< Number of cells - real, dimension(:), intent(in) :: h !< cell widths (size N) - real, dimension(:), intent(in) :: u !< cell average properties (size N) - real, dimension(:,:), intent(inout) :: edge_slopes !< Returned edge slopes, with the - !! same units as u divided by the units of h. - real, optional, intent(in) :: h_neglect !< A negligibly small width - !! in the same units as h. + real, dimension(:), intent(in) :: h !< cell widths (size N) [H] + real, dimension(:), intent(in) :: u !< cell average properties (size N) in arbitrary units [A] + real, dimension(:,:), intent(inout) :: edge_slopes !< Returned edge slopes [A H-1] + real, optional, intent(in) :: h_neglect !< A negligibly small width [H] + logical, optional, intent(in) :: answers_2018 !< If true use older, less acccurate expressions. ! ----------------------------------------------------------------------------- ! Fifth-order implicit estimates of edge values are based on a four-cell, ! three-edge stencil. A tridiagonal system is set up and is based on @@ -232,8 +246,11 @@ subroutine edge_slopes_implicit_h5( N, h, u, edge_slopes, h_neglect ) real :: h2ph3_3, h2ph3_4 ! ... real :: alpha, beta ! stencil coefficients real :: a, b, c, d ! " - real, dimension(7) :: x ! system used to enforce - real, dimension(6,6) :: Asys ! boundary conditions + real, dimension(7) :: x ! Coordinate system with 0 at edges [same units as h] + real, parameter :: C1_12 = 1.0 / 12.0 + real, parameter :: C5_6 = 5.0 / 6.0 + real :: dx, xavg ! Differences and averages of successive values of x [same units as h] + real, dimension(6,6) :: Asys ! matrix used to find boundary conditions real, dimension(6) :: Bsys, Csys ! ... real, dimension(5) :: Dsys ! derivative real, dimension(N+1) :: tri_l, & ! trid. system (lower diagonal) @@ -241,9 +258,11 @@ subroutine edge_slopes_implicit_h5( N, h, u, edge_slopes, h_neglect ) tri_u, & ! trid. system (upper diagonal) tri_b, & ! trid. system (unknowns vector) tri_x ! trid. system (rhs) - real :: hNeglect ! A negligible thicness in the same units as h. + real :: hNeglect ! A negligible thickness in the same units as h. + logical :: use_2018_answers ! If true use older, less acccurate expressions. hNeglect = hNeglect_dflt ; if (present(h_neglect)) hNeglect = h_neglect + use_2018_answers = .true. ; if (present(answers_2018)) use_2018_answers = answers_2018 ! Loop on cells (except last one) do k = 2,N-2 @@ -473,11 +492,20 @@ subroutine edge_slopes_implicit_h5( N, h, u, edge_slopes, h_neglect ) do i = 1,6 - do j = 1,6 - Asys(i,j) = ( (x(i+1)**j) - (x(i)**j) ) / j - enddo - - Bsys(i) = u(i) * h(i) + dx = h(i) + if (use_2018_answers) then + do j = 1,6 ; Asys(i,j) = ( (x(i+1)**j) - (x(i)**j) ) / j ; enddo + else ! Use expressions with less sensitivity to roundoff + xavg = 0.5 * (x(i+1) + x(i)) + Asys(i,1) = dx + Asys(i,2) = dx * xavg + Asys(i,3) = dx * (xavg**2 + C1_12*dx**2) + Asys(i,4) = dx * xavg * (xavg**2 + 0.25*dx**2) + Asys(i,5) = dx * (xavg**4 + 0.5*xavg**2*dx**2 + 0.0125*dx**4) + Asys(i,6) = dx * xavg * (xavg**4 + C5_6*xavg**2*dx**2 + 0.0625*dx**4) + endif + + Bsys(i) = u(i) * dx enddo @@ -612,13 +640,19 @@ subroutine edge_slopes_implicit_h5( N, h, u, edge_slopes, h_neglect ) enddo do i = 1,6 - - do j = 1,6 - Asys(i,j) = ( (x(i+1)**j) - (x(i)**j) ) / j - enddo - - Bsys(i) = u(N-6+i) * h(N-6+i) - + dx = h(N-6+i) + if (use_2018_answers) then + do j = 1,6 ; Asys(i,j) = ( (x(i+1)**j) - (x(i)**j) ) / j ; enddo + else ! Use expressions with less sensitivity to roundoff + xavg = 0.5 * (x(i+1) + x(i)) + Asys(i,1) = dx + Asys(i,2) = dx * xavg + Asys(i,3) = dx * (xavg**2 + C1_12*dx**2) + Asys(i,4) = dx * xavg * (xavg**2 + 0.25*dx**2) + Asys(i,5) = dx * (xavg**4 + 0.5*xavg**2*dx**2 + 0.0125*dx**4) + Asys(i,6) = dx * xavg * (xavg**4 + C5_6*xavg**2*dx**2 + 0.0625*dx**4) + endif + Bsys(i) = u(N-6+i) * dx enddo call solve_linear_system( Asys, Bsys, Csys, 6 ) diff --git a/src/ALE/regrid_edge_values.F90 b/src/ALE/regrid_edge_values.F90 index d27d69153c..f82e42e0e6 100644 --- a/src/ALE/regrid_edge_values.F90 +++ b/src/ALE/regrid_edge_values.F90 @@ -46,23 +46,20 @@ module regrid_edge_values !! Therefore, boundary cells are treated as if they were local extrama. subroutine bound_edge_values( N, h, u, edge_val, h_neglect ) integer, intent(in) :: N !< Number of cells - real, dimension(:), intent(in) :: h !< cell widths (size N) - real, dimension(:), intent(in) :: u !< cell average properties (size N) - real, dimension(:,:), intent(inout) :: edge_val !< Potentially modified edge values, - !! with the same units as u. - real, optional, intent(in) :: h_neglect !< A negligibly small width - !! in the same units as h. + real, dimension(:), intent(in) :: h !< cell widths (size N) [H] + real, dimension(:), intent(in) :: u !< cell average properties (size N) in arbitrary units [A] + real, dimension(:,:), intent(inout) :: edge_val !< Potentially modified edge values [A] + real, optional, intent(in) :: h_neglect !< A negligibly small width [H] ! Local variables integer :: k ! loop index integer :: k0, k1, k2 - real :: h_l, h_c, h_r - real :: u_l, u_c, u_r - real :: u0_l, u0_r + real :: h_l, h_c, h_r ! Layer thicknesses [H] + real :: u_l, u_c, u_r ! Cell average properties [A] + real :: u0_l, u0_r ! Edge values of properties [A] real :: sigma_l, sigma_c, sigma_r ! left, center and right - ! van Leer slopes - real :: slope ! retained PLM slope - - real :: hNeglect ! A negligible thicness in the same units as h. + ! van Leer slopes [A H-1] + real :: slope ! retained PLM slope [A H-1] + real :: hNeglect ! A negligible thickness [H]. hNeglect = hNeglect_dflt ; if (present(h_neglect)) hNeglect = h_neglect @@ -175,15 +172,15 @@ end subroutine average_discontinuous_edge_values !! If so and if they are not monotonic, replace each edge value by their average. subroutine check_discontinuous_edge_values( N, u, edge_val ) integer, intent(in) :: N !< Number of cells - real, dimension(:), intent(in) :: u !< cell averages (size N) - real, dimension(:,:), intent(inout) :: edge_val !< Cell edge values with the same units as u. + real, dimension(:), intent(in) :: u !< cell averages (size N) in arbitrary units [A] + real, dimension(:,:), intent(inout) :: edge_val !< Cell edge values [A]. ! Local variables integer :: k ! loop index - real :: u0_minus ! left value at given edge - real :: u0_plus ! right value at given edge - real :: um_minus ! left cell average - real :: um_plus ! right cell average - real :: u0_avg ! avg value at given edge + real :: u0_minus ! left value at given edge [A] + real :: u0_plus ! right value at given edge [A] + real :: um_minus ! left cell average [A] + real :: um_plus ! right cell average [A] + real :: u0_avg ! avg value at given edge [A] ! Loop on interior cells do k = 1,N-1 @@ -227,16 +224,15 @@ end subroutine check_discontinuous_edge_values !! Boundary edge values are set to be equal to the boundary cell averages. subroutine edge_values_explicit_h2( N, h, u, edge_val, h_neglect ) integer, intent(in) :: N !< Number of cells - real, dimension(:), intent(in) :: h !< cell widths (size N) - real, dimension(:), intent(in) :: u !< cell average properties (size N) - real, dimension(:,:), intent(inout) :: edge_val !< Returned edge values, with the - !! same units as u; the second index size is 2. - real, optional, intent(in) :: h_neglect !< A negligibly small width + real, dimension(:), intent(in) :: h !< cell widths (size N) [H] + real, dimension(:), intent(in) :: u !< cell average properties (size N) in arbitrary units [A] + real, dimension(:,:), intent(inout) :: edge_val !< Returned edge values [A]; the second index size is 2. + real, optional, intent(in) :: h_neglect !< A negligibly small width [H] ! Local variables integer :: k ! loop index - real :: h0, h1 ! cell widths - real :: u0, u1 ! cell averages - real :: hNeglect ! A negligible thicness in the same units as h. + real :: h0, h1 ! cell widths [H] + real :: u0, u1 ! cell averages [A] + real :: hNeglect ! A negligible thickness [H] hNeglect = hNeglect_edge_dflt ; if (present(h_neglect)) hNeglect = h_neglect @@ -289,24 +285,29 @@ end subroutine edge_values_explicit_h2 !! available interpolant. !! !! For this fourth-order scheme, at least four cells must exist. -subroutine edge_values_explicit_h4( N, h, u, edge_val, h_neglect ) +subroutine edge_values_explicit_h4( N, h, u, edge_val, h_neglect, answers_2018 ) integer, intent(in) :: N !< Number of cells - real, dimension(:), intent(in) :: h !< cell widths (size N) - real, dimension(:), intent(in) :: u !< cell average properties (size N) - real, dimension(:,:), intent(inout) :: edge_val !< Returned edge values, with the - !! same units as u; the second index size is 2. - real, optional, intent(in) :: h_neglect !< A negligibly small width + real, dimension(:), intent(in) :: h !< cell widths (size N) [H] + real, dimension(:), intent(in) :: u !< cell average properties (size N) in arbitrary units [A] + real, dimension(:,:), intent(inout) :: edge_val !< Returned edge values [A]; the second index size is 2. + real, optional, intent(in) :: h_neglect !< A negligibly small width [H] + logical, optional, intent(in) :: answers_2018 !< If true use older, less acccurate expressions. + ! Local variables integer :: i, j - real :: u0, u1, u2, u3 - real :: h0, h1, h2, h3 - real :: f1, f2, f3 ! auxiliary variables + real :: u0, u1, u2, u3 ! temporary properties [A] + real :: h0, h1, h2, h3 ! temporary thicknesses [H] + real :: f1, f2, f3 ! auxiliary variables with various units real :: e ! edge value - real, dimension(5) :: x ! used to compute edge + real, dimension(5) :: x ! Coordinate system with 0 at edges [H] + real, parameter :: C1_12 = 1.0 / 12.0 + real :: dx, xavg ! Differences and averages of successive values of x [same units as h] real, dimension(4,4) :: A ! values near the boundaries real, dimension(4) :: B, C - real :: hNeglect ! A negligible thicness in the same units as h. + real :: hNeglect ! A negligible thickness in the same units as h. + logical :: use_2018_answers ! If true use older, less acccurate expressions. + use_2018_answers = .true. ; if (present(answers_2018)) use_2018_answers = answers_2018 hNeglect = hNeglect_edge_dflt ; if (present(h_neglect)) hNeglect = h_neglect ! Loop on interior cells @@ -372,12 +373,18 @@ subroutine edge_values_explicit_h4( N, h, u, edge_val, h_neglect ) enddo do i = 1,4 + dx = max(f1, h(i) ) + if (use_2018_answers) then + do j = 1,4 ; A(i,j) = ( (x(i+1)**j) - (x(i)**j) ) / real(j) ; enddo + else ! Use expressions with less sensitivity to roundoff + xavg = 0.5 * (x(i+1) + x(i)) + A(i,1) = dx + A(i,2) = dx * xavg + A(i,3) = dx * (xavg**2 + C1_12*dx**2) + A(i,4) = dx * xavg * (xavg**2 + 0.25*dx**2) + endif - do j = 1,4 - A(i,j) = ( (x(i+1)**j) - (x(i)**j) ) / real(j) - enddo - - B(i) = u(i) * max(f1, h(i) ) + B(i) = u(i) * dx enddo @@ -410,12 +417,18 @@ subroutine edge_values_explicit_h4( N, h, u, edge_val, h_neglect ) enddo do i = 1,4 + dx = max(f1, h(N-4+i) ) + if (use_2018_answers) then + do j = 1,4 ; A(i,j) = ( (x(i+1)**j) - (x(i)**j) ) / real(j) ; enddo + else ! Use expressions with less sensitivity to roundoff + xavg = 0.5 * (x(i+1) + x(i)) + A(i,1) = dx + A(i,2) = dx * xavg + A(i,3) = dx * (xavg**2 + C1_12*dx**2) + A(i,4) = dx * xavg * (xavg**2 + 0.25*dx**2) + endif - do j = 1,4 - A(i,j) = ( (x(i+1)**j) - (x(i)**j) ) / real(j) - enddo - - B(i) = u(N-4+i) * max(f1, h(N-4+i) ) + B(i) = u(N-4+i) * dx enddo @@ -475,21 +488,24 @@ end subroutine edge_values_explicit_h4 !! !! There are N+1 unknowns and we are able to write N-1 equations. The !! boundary conditions close the system. -subroutine edge_values_implicit_h4( N, h, u, edge_val, h_neglect ) +subroutine edge_values_implicit_h4( N, h, u, edge_val, h_neglect, answers_2018 ) integer, intent(in) :: N !< Number of cells - real, dimension(:), intent(in) :: h !< cell widths (size N) - real, dimension(:), intent(in) :: u !< cell average properties (size N) - real, dimension(:,:), intent(inout) :: edge_val !< Returned edge values, with the - !! same units as u; the second index size is 2. - real, optional, intent(in) :: h_neglect !< A negligibly small width + real, dimension(:), intent(in) :: h !< cell widths (size N) [H] + real, dimension(:), intent(in) :: u !< cell average properties (size N) in arbitrary units [A] + real, dimension(:,:), intent(inout) :: edge_val !< Returned edge values [A]; the second index size is 2. + real, optional, intent(in) :: h_neglect !< A negligibly small width [H] + logical, optional, intent(in) :: answers_2018 !< If true use older, less acccurate expressions. + ! Local variables integer :: i, j ! loop indexes - real :: h0, h1 ! cell widths + real :: h0, h1 ! cell widths [H] real :: h0_2, h1_2, h0h1 real :: d2, d4 real :: alpha, beta ! stencil coefficients real :: a, b - real, dimension(5) :: x ! system used to enforce + real, dimension(5) :: x ! Coordinate system with 0 at edges [H] + real, parameter :: C1_12 = 1.0 / 12.0 + real :: dx, xavg ! Differences and averages of successive values of x [H] real, dimension(4,4) :: Asys ! boundary conditions real, dimension(4) :: Bsys, Csys real, dimension(N+1) :: tri_l, & ! trid. system (lower diagonal) @@ -497,8 +513,10 @@ subroutine edge_values_implicit_h4( N, h, u, edge_val, h_neglect ) tri_u, & ! trid. system (upper diagonal) tri_b, & ! trid. system (unknowns vector) tri_x ! trid. system (rhs) - real :: hNeglect ! A negligible thicness in the same units as h. + real :: hNeglect ! A negligible thickness [H] + logical :: use_2018_answers ! If true use older, less acccurate expressions. + use_2018_answers = .true. ; if (present(answers_2018)) use_2018_answers = answers_2018 hNeglect = hNeglect_edge_dflt ; if (present(h_neglect)) hNeglect = h_neglect ! Loop on cells (except last one) @@ -543,12 +561,18 @@ subroutine edge_values_implicit_h4( N, h, u, edge_val, h_neglect ) enddo do i = 1,4 + dx = max(h0, h(i) ) + if (use_2018_answers) then + do j = 1,4 ; Asys(i,j) = ( (x(i+1)**j) - (x(i)**j) ) / j ; enddo + else ! Use expressions with less sensitivity to roundoff + xavg = 0.5 * (x(i+1) + x(i)) + Asys(i,1) = dx + Asys(i,2) = dx * xavg + Asys(i,3) = dx * (xavg**2 + C1_12*dx**2) + Asys(i,4) = dx * xavg * (xavg**2 + 0.25*dx**2) + endif - do j = 1,4 - Asys(i,j) = ( (x(i+1)**j) - (x(i)**j) ) / j - enddo - - Bsys(i) = u(i) * max( h0, h(i) ) + Bsys(i) = u(i) * dx enddo @@ -566,12 +590,17 @@ subroutine edge_values_implicit_h4( N, h, u, edge_val, h_neglect ) enddo do i = 1,4 - - do j = 1,4 - Asys(i,j) = ( (x(i+1)**j) - (x(i)**j) ) / j - enddo - - Bsys(i) = u(N-4+i) * max( h0, h(N-4+i) ) + dx = max(h0, h(N-4+i) ) + if (use_2018_answers) then + do j = 1,4 ; Asys(i,j) = ( (x(i+1)**j) - (x(i)**j) ) / j ; enddo + else ! Use expressions with less sensitivity to roundoff + xavg = 0.5 * (x(i+1) + x(i)) + Asys(i,1) = dx + Asys(i,2) = dx * xavg + Asys(i,3) = dx * (xavg**2 + C1_12*dx**2) + Asys(i,4) = dx * xavg * (xavg**2 + 0.25*dx**2) + endif + Bsys(i) = u(N-4+i) * dx enddo @@ -628,16 +657,17 @@ end subroutine edge_values_implicit_h4 !! become computationally expensive if regridding is carried out !! often. Figuring out closed-form expressions for these coefficients !! on nonuniform meshes turned out to be intractable. -subroutine edge_values_implicit_h6( N, h, u, edge_val, h_neglect ) +subroutine edge_values_implicit_h6( N, h, u, edge_val, h_neglect, answers_2018 ) integer, intent(in) :: N !< Number of cells - real, dimension(:), intent(in) :: h !< cell widths (size N) - real, dimension(:), intent(in) :: u !< cell average properties (size N) - real, dimension(:,:), intent(inout) :: edge_val !< Returned edge values, with the - !! same units as u; the second index size is 2. - real, optional, intent(in) :: h_neglect !< A negligibly small width + real, dimension(:), intent(in) :: h !< cell widths (size N) [H] + real, dimension(:), intent(in) :: u !< cell average properties (size N) in arbitrary units [A] + real, dimension(:,:), intent(inout) :: edge_val !< Returned edge values [A]; the second index size is 2. + real, optional, intent(in) :: h_neglect !< A negligibly small width [H] + logical, optional, intent(in) :: answers_2018 !< If true use older, less acccurate expressions. + ! Local variables integer :: i, j, k ! loop indexes - real :: h0, h1, h2, h3 ! cell widths + real :: h0, h1, h2, h3 ! cell widths [H] real :: g, g_2, g_3 ! the following are real :: g_4, g_5, g_6 ! auxiliary variables real :: d2, d3, d4, d5, d6 ! to set up the systems @@ -654,7 +684,10 @@ subroutine edge_values_implicit_h6( N, h, u, edge_val, h_neglect ) real :: h0ph1_5, h2ph3_5 ! ... real :: alpha, beta ! stencil coefficients real :: a, b, c, d ! " - real, dimension(7) :: x ! system used to enforce + real, dimension(7) :: x ! Coordinate system with 0 at edges [same units as h] + real, parameter :: C1_12 = 1.0 / 12.0 + real, parameter :: C5_6 = 5.0 / 6.0 + real :: dx, xavg ! Differences and averages of successive values of x [same units as h] real, dimension(6,6) :: Asys ! boundary conditions real, dimension(6) :: Bsys, Csys ! ... real, dimension(N+1) :: tri_l, & ! trid. system (lower diagonal) @@ -662,8 +695,10 @@ subroutine edge_values_implicit_h6( N, h, u, edge_val, h_neglect ) tri_u, & ! trid. system (upper diagonal) tri_b, & ! trid. system (unknowns vector) tri_x ! trid. system (rhs) - real :: hNeglect ! A negligible thicness in the same units as h. + real :: hNeglect ! A negligible thickness [H]. + logical :: use_2018_answers ! If true use older, less acccurate expressions. + use_2018_answers = .true. ; if (present(answers_2018)) use_2018_answers = answers_2018 hNeglect = hNeglect_edge_dflt ; if (present(h_neglect)) hNeglect = h_neglect ! Loop on cells (except last one) @@ -913,12 +948,19 @@ subroutine edge_values_implicit_h6( N, h, u, edge_val, h_neglect ) enddo do i = 1,6 - - do j = 1,6 - Asys(i,j) = ( (x(i+1)**j) - (x(i)**j) ) / j - enddo - - Bsys(i) = u(i) * max( g, h(i) ) + dx = max( g, h(i) ) + if (use_2018_answers) then + do j = 1,6 ; Asys(i,j) = ( (x(i+1)**j) - (x(i)**j) ) / j ; enddo + else ! Use expressions with less sensitivity to roundoff + xavg = 0.5 * (x(i+1) + x(i)) + Asys(i,1) = dx + Asys(i,2) = dx * xavg + Asys(i,3) = dx * (xavg**2 + C1_12*dx**2) + Asys(i,4) = dx * xavg * (xavg**2 + 0.25*dx**2) + Asys(i,5) = dx * (xavg**4 + 0.5*xavg**2*dx**2 + 0.0125*dx**4) + Asys(i,6) = dx * xavg * (xavg**4 + C5_6*xavg**2*dx**2 + 0.0625*dx**4) + endif + Bsys(i) = u(i) * dx enddo @@ -1058,12 +1100,19 @@ subroutine edge_values_implicit_h6( N, h, u, edge_val, h_neglect ) enddo do i = 1,6 - - do j = 1,6 - Asys(i,j) = ( (x(i+1)**j) - (x(i)**j) ) / j - enddo - - Bsys(i) = u(N-6+i) * max( g, h(N-6+i) ) + dx = max( g, h(N-6+i) ) + if (use_2018_answers) then + do j = 1,6 ; Asys(i,j) = ( (x(i+1)**j) - (x(i)**j) ) / j ; enddo + else ! Use expressions with less sensitivity to roundoff + xavg = 0.5 * (x(i+1) + x(i)) + Asys(i,1) = dx + Asys(i,2) = dx * xavg + Asys(i,3) = dx * (xavg**2 + C1_12*dx**2) + Asys(i,4) = dx * xavg * (xavg**2 + 0.25*dx**2) + Asys(i,5) = dx * (xavg**4 + 0.5*xavg**2*dx**2 + 0.0125*dx**4) + Asys(i,6) = dx * xavg * (xavg**4 + C5_6*xavg**2*dx**2 + 0.0625*dx**4) + endif + Bsys(i) = u(N-6+i) * dx enddo diff --git a/src/ALE/regrid_interp.F90 b/src/ALE/regrid_interp.F90 index d2c384c15e..ace311cc21 100644 --- a/src/ALE/regrid_interp.F90 +++ b/src/ALE/regrid_interp.F90 @@ -30,6 +30,9 @@ module regrid_interp !> Indicate whether high-order boundary extrapolation should be used within !! boundary cells logical :: boundary_extrapolation + + !> If true use older, less acccurate expressions. + logical :: answers_2018 = .true. end type interp_CS_type public regridding_set_ppolys, interpolate_grid @@ -112,7 +115,7 @@ subroutine regridding_set_ppolys(CS, densities, n0, h0, ppoly0_E, ppoly0_S, & case ( INTERPOLATION_P1M_H4 ) degree = DEGREE_1 if ( n0 >= 4 ) then - call edge_values_explicit_h4( n0, h0, densities, ppoly0_E, h_neglect_edge ) + call edge_values_explicit_h4( n0, h0, densities, ppoly0_E, h_neglect_edge, answers_2018=CS%answers_2018 ) else call edge_values_explicit_h2( n0, h0, densities, ppoly0_E, h_neglect_edge ) endif @@ -124,7 +127,7 @@ subroutine regridding_set_ppolys(CS, densities, n0, h0, ppoly0_E, ppoly0_S, & case ( INTERPOLATION_P1M_IH4 ) degree = DEGREE_1 if ( n0 >= 4 ) then - call edge_values_implicit_h4( n0, h0, densities, ppoly0_E, h_neglect_edge ) + call edge_values_implicit_h4( n0, h0, densities, ppoly0_E, h_neglect_edge, answers_2018=CS%answers_2018 ) else call edge_values_explicit_h2( n0, h0, densities, ppoly0_E, h_neglect_edge ) endif @@ -143,7 +146,7 @@ subroutine regridding_set_ppolys(CS, densities, n0, h0, ppoly0_E, ppoly0_S, & case ( INTERPOLATION_PPM_H4 ) if ( n0 >= 4 ) then degree = DEGREE_2 - call edge_values_explicit_h4( n0, h0, densities, ppoly0_E, h_neglect_edge ) + call edge_values_explicit_h4( n0, h0, densities, ppoly0_E, h_neglect_edge, answers_2018=CS%answers_2018 ) call PPM_reconstruction( n0, h0, densities, ppoly0_E, ppoly0_coefs, h_neglect ) if (extrapolate) then call PPM_boundary_extrapolation( n0, h0, densities, ppoly0_E, & @@ -161,7 +164,7 @@ subroutine regridding_set_ppolys(CS, densities, n0, h0, ppoly0_E, ppoly0_S, & case ( INTERPOLATION_PPM_IH4 ) if ( n0 >= 4 ) then degree = DEGREE_2 - call edge_values_implicit_h4( n0, h0, densities, ppoly0_E, h_neglect_edge ) + call edge_values_implicit_h4( n0, h0, densities, ppoly0_E, h_neglect_edge, answers_2018=CS%answers_2018 ) call PPM_reconstruction( n0, h0, densities, ppoly0_E, ppoly0_coefs, h_neglect ) if (extrapolate) then call PPM_boundary_extrapolation( n0, h0, densities, ppoly0_E, & @@ -179,8 +182,8 @@ subroutine regridding_set_ppolys(CS, densities, n0, h0, ppoly0_E, ppoly0_S, & case ( INTERPOLATION_P3M_IH4IH3 ) if ( n0 >= 4 ) then degree = DEGREE_3 - call edge_values_implicit_h4( n0, h0, densities, ppoly0_E, h_neglect_edge ) - call edge_slopes_implicit_h3( n0, h0, densities, ppoly0_S, h_neglect ) + call edge_values_implicit_h4( n0, h0, densities, ppoly0_E, h_neglect_edge, answers_2018=CS%answers_2018 ) + call edge_slopes_implicit_h3( n0, h0, densities, ppoly0_S, h_neglect, answers_2018=CS%answers_2018 ) call P3M_interpolation( n0, h0, densities, ppoly0_E, ppoly0_S, & ppoly0_coefs, h_neglect ) if (extrapolate) then @@ -199,8 +202,8 @@ subroutine regridding_set_ppolys(CS, densities, n0, h0, ppoly0_E, ppoly0_S, & case ( INTERPOLATION_P3M_IH6IH5 ) if ( n0 >= 6 ) then degree = DEGREE_3 - call edge_values_implicit_h6( n0, h0, densities, ppoly0_E, h_neglect_edge ) - call edge_slopes_implicit_h5( n0, h0, densities, ppoly0_S, h_neglect ) + call edge_values_implicit_h6( n0, h0, densities, ppoly0_E, h_neglect_edge, answers_2018=CS%answers_2018 ) + call edge_slopes_implicit_h5( n0, h0, densities, ppoly0_S, h_neglect, answers_2018=CS%answers_2018 ) call P3M_interpolation( n0, h0, densities, ppoly0_E, ppoly0_S, & ppoly0_coefs, h_neglect ) if (extrapolate) then @@ -219,8 +222,8 @@ subroutine regridding_set_ppolys(CS, densities, n0, h0, ppoly0_E, ppoly0_S, & case ( INTERPOLATION_PQM_IH4IH3 ) if ( n0 >= 4 ) then degree = DEGREE_4 - call edge_values_implicit_h4( n0, h0, densities, ppoly0_E, h_neglect_edge ) - call edge_slopes_implicit_h3( n0, h0, densities, ppoly0_S, h_neglect ) + call edge_values_implicit_h4( n0, h0, densities, ppoly0_E, h_neglect_edge, answers_2018=CS%answers_2018 ) + call edge_slopes_implicit_h3( n0, h0, densities, ppoly0_S, h_neglect, answers_2018=CS%answers_2018 ) call PQM_reconstruction( n0, h0, densities, ppoly0_E, ppoly0_S, & ppoly0_coefs, h_neglect ) if (extrapolate) then @@ -239,8 +242,8 @@ subroutine regridding_set_ppolys(CS, densities, n0, h0, ppoly0_E, ppoly0_S, & case ( INTERPOLATION_PQM_IH6IH5 ) if ( n0 >= 6 ) then degree = DEGREE_4 - call edge_values_implicit_h6( n0, h0, densities, ppoly0_E, h_neglect_edge ) - call edge_slopes_implicit_h5( n0, h0, densities, ppoly0_S, h_neglect ) + call edge_values_implicit_h6( n0, h0, densities, ppoly0_E, h_neglect_edge, answers_2018=CS%answers_2018 ) + call edge_slopes_implicit_h5( n0, h0, densities, ppoly0_S, h_neglect, answers_2018=CS%answers_2018 ) call PQM_reconstruction( n0, h0, densities, ppoly0_E, ppoly0_S, & ppoly0_coefs, h_neglect ) if (extrapolate) then @@ -264,7 +267,7 @@ end subroutine regridding_set_ppolys !! 'ppoly0' (possibly discontinuous), the coordinates of the new grid 'grid1' !! are determined by finding the corresponding target interface densities. subroutine interpolate_grid( n0, h0, x0, ppoly0_E, ppoly0_coefs, & - target_values, degree, n1, h1, x1 ) + target_values, degree, n1, h1, x1, answers_2018 ) integer, intent(in) :: n0 !< Number of points on source grid real, dimension(:), intent(in) :: h0 !< Thicknesses of source grid cells real, dimension(:), intent(in) :: x0 !< Source interface positions @@ -275,7 +278,10 @@ subroutine interpolate_grid( n0, h0, x0, ppoly0_E, ppoly0_coefs, & integer, intent(in) :: n1 !< Number of points on target grid real, dimension(:), intent(inout) :: h1 !< Thicknesses of target grid cells real, dimension(:), intent(inout) :: x1 !< Target interface positions + logical, optional, intent(in) :: answers_2018 !< If true use older, less acccurate expressions. + ! Local variables + logical :: use_2018_answers ! If true use older, less acccurate expressions. integer :: k ! loop index real :: t ! current interface target density @@ -287,7 +293,8 @@ subroutine interpolate_grid( n0, h0, x0, ppoly0_E, ppoly0_coefs, & ! Find coordinates for interior target values do k = 2,n1 t = target_values(k) - x1(k) = get_polynomial_coordinate ( n0, h0, x0, ppoly0_E, ppoly0_coefs, t, degree ) + x1(k) = get_polynomial_coordinate ( n0, h0, x0, ppoly0_E, ppoly0_coefs, t, degree, & + answers_2018=answers_2018 ) h1(k-1) = x1(k) - x1(k-1) enddo h1(n1) = x1(n1+1) - x1(n1) @@ -320,7 +327,7 @@ subroutine build_and_interpolate_grid(CS, densities, n0, h0, x0, target_values, call regridding_set_ppolys(CS, densities, n0, h0, ppoly0_E, ppoly0_S, ppoly0_C, & degree, h_neglect, h_neglect_edge) call interpolate_grid(n0, h0, x0, ppoly0_E, ppoly0_C, target_values, degree, & - n1, h1, x1) + n1, h1, x1, answers_2018=CS%answers_2018) end subroutine build_and_interpolate_grid !> Given a target value, find corresponding coordinate for given polynomial @@ -340,7 +347,7 @@ end subroutine build_and_interpolate_grid !! It is assumed that the number of cells defining 'grid' and 'ppoly' are the !! same. function get_polynomial_coordinate( N, h, x_g, ppoly_E, ppoly_coefs, & - target_value, degree ) result ( x_tgt ) + target_value, degree, answers_2018 ) result ( x_tgt ) ! Arguments integer, intent(in) :: N !< Number of grid cells real, dimension(:), intent(in) :: h !< Grid cell thicknesses @@ -349,6 +356,7 @@ function get_polynomial_coordinate( N, h, x_g, ppoly_E, ppoly_coefs, & real, dimension(:,:), intent(in) :: ppoly_coefs !< Coefficients of interpolating polynomials real, intent(in) :: target_value !< Target value to find position for integer, intent(in) :: degree !< Degree of the interpolating polynomials + logical, optional, intent(in) :: answers_2018 !< If true use older, less acccurate expressions. real :: x_tgt !< The position of x_g at which target_value is found. ! Local variables integer :: i, k ! loop indices @@ -363,9 +371,11 @@ function get_polynomial_coordinate( N, h, x_g, ppoly_E, ppoly_coefs, & real :: eps ! offset used to get away from ! boundaries real :: grad ! gradient during N-R iterations + logical :: use_2018_answers ! If true use older, less acccurate expressions. eps = NR_OFFSET k_found = -1 + use_2018_answers = .true. ; if (present(answers_2018)) use_2018_answers = answers_2018 ! If the target value is outside the range of all values, we ! force the target coordinate to be equal to the lowest or @@ -441,10 +451,14 @@ function get_polynomial_coordinate( N, h, x_g, ppoly_E, ppoly_coefs, & exit endif - numerator = a(1) + a(2)*xi0 + a(3)*xi0*xi0 + a(4)*xi0*xi0*xi0 + & - a(5)*xi0*xi0*xi0*xi0 - target_value - - denominator = a(2) + 2*a(3)*xi0 + 3*a(4)*xi0*xi0 + 4*a(5)*xi0*xi0*xi0 + if (use_2018_answers) then + numerator = a(1) + a(2)*xi0 + a(3)*xi0*xi0 + a(4)*xi0*xi0*xi0 + & + a(5)*xi0*xi0*xi0*xi0 - target_value + denominator = a(2) + 2*a(3)*xi0 + 3*a(4)*xi0*xi0 + 4*a(5)*xi0*xi0*xi0 + else ! These expressions are mathematicaly equivalent but more accurate. + numerator = (a(1) - target_value) + xi0*(a(2) + xi0*(a(3) + xi0*(a(4) + a(5)*xi0))) + denominator = a(2) + xi0*(2.*a(3) + xi0*(3.*a(4) + 4.*a(5)*xi0)) + endif delta = -numerator / denominator @@ -463,7 +477,11 @@ function get_polynomial_coordinate( N, h, x_g, ppoly_E, ppoly_coefs, & if ( xi0 > 1.0 ) then xi0 = 1.0 - grad = a(2) + 2*a(3) + 3*a(4) + 4*a(5) + if (use_2018_answers) then + grad = a(2) + 2*a(3) + 3*a(4) + 4*a(5) + else ! These expressions are mathematicaly equivalent but more accurate. + grad = a(2) + (2.*a(3) + (3.*a(4) + 4.*a(5))) + endif if ( grad == 0.0 ) xi0 = xi0 - eps endif diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index ad9e235b27..4b16730fee 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -1180,7 +1180,7 @@ subroutine step_MOM_thermo(CS, G, GV, US, u, v, h, tv, fluxes, dtdia, & call cpu_clock_begin(id_clock_thermo) if (.not.CS%adiabatic) then if (CS%debug) then - call uvchksum("Pre-diabatic [uv]", u, v, G%HI, haloshift=2) + call uvchksum("Pre-diabatic [uv]", u, v, G%HI, haloshift=2, scale=US%L_T_to_m_s) call hchksum(h,"Pre-diabatic h", G%HI, haloshift=1, scale=GV%H_to_m) call uvchksum("Pre-diabatic [uv]h", CS%uhtr, CS%vhtr, G%HI, & haloshift=0, scale=GV%H_to_m*US%L_to_m**2) diff --git a/src/core/MOM_dynamics_split_RK2.F90 b/src/core/MOM_dynamics_split_RK2.F90 index c479550847..8c016b11b0 100644 --- a/src/core/MOM_dynamics_split_RK2.F90 +++ b/src/core/MOM_dynamics_split_RK2.F90 @@ -480,7 +480,7 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, & call disable_averaging(CS%diag) if (CS%debug) then - call uvchksum("before vertvisc: up", up, vp, G%HI, haloshift=0, symmetric=sym) + call uvchksum("before vertvisc: up", up, vp, G%HI, haloshift=0, symmetric=sym, scale=US%L_T_to_m_s) endif call vertvisc_coef(up, vp, h, forces, visc, dt, G, GV, US, CS%vertvisc_CSp, CS%OBC) call vertvisc_remnant(visc, CS%visc_rem_u, CS%visc_rem_v, dt, G, GV, US, CS%vertvisc_CSp) @@ -670,7 +670,7 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, & if (CS%debug) then call MOM_state_chksum("Predictor ", up, vp, hp, uh, vh, G, GV, US, symmetric=sym) - call uvchksum("Predictor avg [uv]", u_av, v_av, G%HI, haloshift=1, symmetric=sym) + call uvchksum("Predictor avg [uv]", u_av, v_av, G%HI, haloshift=1, symmetric=sym, scale=US%L_T_to_m_s) call hchksum(h_av, "Predictor avg h", G%HI, haloshift=0, scale=GV%H_to_m) ! call MOM_state_chksum("Predictor avg ", u_av, v_av, h_av, uh, vh, G, GV, US) call check_redundant("Predictor up ", up, vp, G) @@ -860,7 +860,7 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, & if (CS%id_v_BT_accel > 0) call post_data(CS%id_v_BT_accel, CS%v_accel_bt, CS%diag) if (CS%debug) then - call MOM_state_chksum("Corrector ", u, v, h, uh, vh, G, GV, US, symmetric=sym, vel_scale=1.0) + call MOM_state_chksum("Corrector ", u, v, h, uh, vh, G, GV, US, symmetric=sym) call uvchksum("Corrector avg [uv]", u_av, v_av, G%HI, haloshift=1, symmetric=sym, scale=US%L_T_to_m_s) call hchksum(h_av, "Corrector avg h", G%HI, haloshift=1, scale=GV%H_to_m) ! call MOM_state_chksum("Corrector avg ", u_av, v_av, h_av, uh, vh, G, GV, US) diff --git a/src/core/MOM_forcing_type.F90 b/src/core/MOM_forcing_type.F90 index 05f2cac00a..9794070f20 100644 --- a/src/core/MOM_forcing_type.F90 +++ b/src/core/MOM_forcing_type.F90 @@ -1284,20 +1284,22 @@ subroutine register_forcing_type_diags(Time, diag, US, use_temperature, handles, ! surface mass flux maps handles%id_prcme = register_diag_field('ocean_model', 'PRCmE', diag%axesT1, Time, & - 'Net surface water flux (precip+melt+lrunoff+ice calving-evap)', 'kg m-2 s-1',& + 'Net surface water flux (precip+melt+lrunoff+ice calving-evap)', 'kg m-2 s-1', & standard_name='water_flux_into_sea_water', cmor_field_name='wfo', & cmor_standard_name='water_flux_into_sea_water',cmor_long_name='Water Flux Into Sea Water') + ! This diagnostic is rescaled to MKS units when combined. - handles%id_evap = register_diag_field('ocean_model', 'evap', diag%axesT1, Time, & - 'Evaporation/condensation at ocean surface (evaporation is negative)', 'kg m-2 s-1',& - standard_name='water_evaporation_flux', cmor_field_name='evs', & - cmor_standard_name='water_evaporation_flux', & + handles%id_evap = register_diag_field('ocean_model', 'evap', diag%axesT1, Time, & + 'Evaporation/condensation at ocean surface (evaporation is negative)', & + 'kg m-2 s-1', conversion=US%R_to_kg_m3*US%Z_to_m*US%s_to_T, & + standard_name='water_evaporation_flux', cmor_field_name='evs', & + cmor_standard_name='water_evaporation_flux', & cmor_long_name='Water Evaporation Flux Where Ice Free Ocean over Sea') ! smg: seaice_melt field requires updates to the sea ice model handles%id_seaice_melt = register_diag_field('ocean_model', 'seaice_melt', & diag%axesT1, Time, 'water flux to ocean from snow/sea ice melting(> 0) or formation(< 0)', & - 'kg m-2 s-1', & + 'kg m-2 s-1', conversion=US%R_to_kg_m3*US%Z_to_m*US%s_to_T, & standard_name='water_flux_into_sea_water_due_to_sea_ice_thermodynamics', & cmor_field_name='fsitherm', & cmor_standard_name='water_flux_into_sea_water_due_to_sea_ice_thermodynamics',& @@ -1305,6 +1307,7 @@ subroutine register_forcing_type_diags(Time, diag, US, use_temperature, handles, handles%id_precip = register_diag_field('ocean_model', 'precip', diag%axesT1, Time, & 'Liquid + frozen precipitation into ocean', 'kg m-2 s-1') + ! This diagnostic is rescaled to MKS units when combined. handles%id_fprec = register_diag_field('ocean_model', 'fprec', diag%axesT1, Time, & 'Frozen precipitation into ocean', & @@ -1324,32 +1327,39 @@ subroutine register_forcing_type_diags(Time, diag, US, use_temperature, handles, units='kg m-2 s-1', conversion=US%R_to_kg_m3*US%Z_to_m*US%s_to_T) handles%id_frunoff = register_diag_field('ocean_model', 'frunoff', diag%axesT1, Time, & - 'Frozen runoff (calving) and iceberg melt into ocean', 'kg m-2 s-1', & + 'Frozen runoff (calving) and iceberg melt into ocean', & + units='kg m-2 s-1', conversion=US%R_to_kg_m3*US%Z_to_m*US%s_to_T, & standard_name='water_flux_into_sea_water_from_icebergs', & cmor_field_name='ficeberg', & cmor_standard_name='water_flux_into_sea_water_from_icebergs', & cmor_long_name='Water Flux into Seawater from Icebergs') handles%id_lrunoff = register_diag_field('ocean_model', 'lrunoff', diag%axesT1, Time, & - 'Liquid runoff (rivers) into ocean', 'kg m-2 s-1', & + 'Liquid runoff (rivers) into ocean', & + units='kg m-2 s-1', conversion=US%R_to_kg_m3*US%Z_to_m*US%s_to_T, & standard_name='water_flux_into_sea_water_from_rivers', cmor_field_name='friver', & cmor_standard_name='water_flux_into_sea_water_from_rivers', & cmor_long_name='Water Flux into Sea Water From Rivers') handles%id_net_massout = register_diag_field('ocean_model', 'net_massout', diag%axesT1, Time, & 'Net mass leaving the ocean due to evaporation, seaice formation', 'kg m-2 s-1') + ! This diagnostic is rescaled to MKS units when combined. handles%id_net_massin = register_diag_field('ocean_model', 'net_massin', diag%axesT1, Time, & 'Net mass entering ocean due to precip, runoff, ice melt', 'kg m-2 s-1') + ! This diagnostic is rescaled to MKS units when combined. handles%id_massout_flux = register_diag_field('ocean_model', 'massout_flux', diag%axesT1, Time, & 'Net mass flux of freshwater out of the ocean (used in the boundary flux calculation)', & 'kg m-2', conversion=diag%GV%H_to_kg_m2) + ! This diagnostic is calculated in MKS units. handles%id_massin_flux = register_diag_field('ocean_model', 'massin_flux', diag%axesT1, Time, & 'Net mass flux of freshwater into the ocean (used in boundary flux calculation)', 'kg m-2') + ! This diagnostic is calculated in MKS units. + !========================================================================= - ! area integrated surface mass transport + ! area integrated surface mass transport, all are rescaled to MKS units before area integration. handles%id_total_prcme = register_scalar_field('ocean_model', 'total_PRCmE', Time, diag, & long_name='Area integrated net surface water flux (precip+melt+liq runoff+ice calving-evap)',& diff --git a/src/diagnostics/MOM_sum_output.F90 b/src/diagnostics/MOM_sum_output.F90 index f99b6d7f7c..668f185152 100644 --- a/src/diagnostics/MOM_sum_output.F90 +++ b/src/diagnostics/MOM_sum_output.F90 @@ -534,9 +534,10 @@ subroutine write_energy(u, v, h, tv, day, n, G, GV, US, CS, tracer_CSp, OBC, dt_ call find_eta(h, tv, G, GV, US, eta) do k=1,nz ; do j=js,je ; do i=is,ie - tmp1(i,j,k) = (eta(i,j,K)-eta(i,j,K+1)) * areaTm(i,j) + tmp1(i,j,k) = US%Z_to_m*(eta(i,j,K)-eta(i,j,K+1)) * areaTm(i,j) enddo ; enddo ; enddo - vol_tot = US%Z_to_m*reproducing_sum(tmp1, sums=vol_lay) + vol_tot = reproducing_sum(tmp1, sums=vol_lay) + do k=1,nz ; vol_lay(k) = US%m_to_Z * vol_lay(k) ; enddo else do k=1,nz ; do j=js,je ; do i=is,ie tmp1(i,j,k) = H_to_kg_m2 * h(i,j,k) * areaTm(i,j) diff --git a/src/framework/MOM_spatial_means.F90 b/src/framework/MOM_spatial_means.F90 index 829afb851f..85d5ce452b 100644 --- a/src/framework/MOM_spatial_means.F90 +++ b/src/framework/MOM_spatial_means.F90 @@ -43,7 +43,7 @@ function global_area_mean(var, G, scale) do j=js,je ; do i=is,ie tmpForSumming(i,j) = var(i,j) * (scalefac * G%areaT(i,j) * G%mask2dT(i,j)) enddo ; enddo - global_area_mean = reproducing_sum(tmpForSumming) * (G%US%m_to_L**2 * G%IareaT_global) + global_area_mean = reproducing_sum(tmpForSumming) * G%IareaT_global end function global_area_mean @@ -182,17 +182,20 @@ end function global_mass_integral !> Determine the global mean of a field along rows of constant i, returning it !! in a 1-d array using the local indexing. This uses reproducing sums. -subroutine global_i_mean(array, i_mean, G, mask, scale) +subroutine global_i_mean(array, i_mean, G, mask, scale, tmp_scale) type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure real, dimension(SZI_(G),SZJ_(G)), intent(in) :: array !< The variable being averaged real, dimension(SZJ_(G)), intent(out) :: i_mean !< Global mean of array along its i-axis real, dimension(SZI_(G),SZJ_(G)), & - optional, intent(in) :: mask !< An array used for weighting the i-mean - real, optional, intent(in) :: scale !< A rescaling factor for the variable + optional, intent(in) :: mask !< An array used for weighting the i-mean + real, optional, intent(in) :: scale !< A rescaling factor for the output variable + real, optional, intent(in) :: tmp_scale !< A rescaling factor for the internal + !! calculations that is removed from the output ! Local variables type(EFP_type), allocatable, dimension(:) :: asum, mask_sum real :: scalefac ! A scaling factor for the variable. + real :: unscale ! A factor for undoing any internal rescaling before output. real :: mask_sum_r integer :: is, ie, js, je, idg_off, jdg_off integer :: i, j @@ -201,6 +204,10 @@ subroutine global_i_mean(array, i_mean, G, mask, scale) idg_off = G%idg_offset ; jdg_off = G%jdg_offset scalefac = 1.0 ; if (present(scale)) scalefac = scale + unscale = 1.0 + if (present(tmp_scale)) then ; if (tmp_scale /= 0.0) then + scalefac = scalefac * tmp_scale ; unscale = 1.0 / tmp_scale + endif ; endif call reset_EFP_overflow_error() allocate(asum(G%jsg:G%jeg)) @@ -253,24 +260,29 @@ subroutine global_i_mean(array, i_mean, G, mask, scale) enddo endif + if (unscale /= 1.0) then ; do j=js,je ; i_mean(j) = unscale*i_mean(j) ; enddo ; endif + deallocate(asum) end subroutine global_i_mean !> Determine the global mean of a field along rows of constant j, returning it !! in a 1-d array using the local indexing. This uses reproducing sums. -subroutine global_j_mean(array, j_mean, G, mask, scale) +subroutine global_j_mean(array, j_mean, G, mask, scale, tmp_scale) type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure real, dimension(SZI_(G),SZJ_(G)), intent(in) :: array !< The variable being averaged real, dimension(SZI_(G)), intent(out) :: j_mean !< Global mean of array along its j-axis real, dimension(SZI_(G),SZJ_(G)), & - optional, intent(in) :: mask !< An array used for weighting the j-mean - real, optional, intent(in) :: scale !< A rescaling factor for the variable + optional, intent(in) :: mask !< An array used for weighting the j-mean + real, optional, intent(in) :: scale !< A rescaling factor for the output variable + real, optional, intent(in) :: tmp_scale !< A rescaling factor for the internal + !! calculations that is removed from the output ! Local variables type(EFP_type), allocatable, dimension(:) :: asum, mask_sum real :: mask_sum_r real :: scalefac ! A scaling factor for the variable. + real :: unscale ! A factor for undoing any internal rescaling before output. integer :: is, ie, js, je, idg_off, jdg_off integer :: i, j @@ -278,6 +290,10 @@ subroutine global_j_mean(array, j_mean, G, mask, scale) idg_off = G%idg_offset ; jdg_off = G%jdg_offset scalefac = 1.0 ; if (present(scale)) scalefac = scale + unscale = 1.0 + if (present(tmp_scale)) then ; if (tmp_scale /= 0.0) then + scalefac = scalefac * tmp_scale ; unscale = 1.0 / tmp_scale + endif ; endif call reset_EFP_overflow_error() allocate(asum(G%isg:G%ieg)) @@ -330,6 +346,8 @@ subroutine global_j_mean(array, j_mean, G, mask, scale) enddo endif + if (unscale /= 1.0) then ; do i=is,ie ; j_mean(i) = unscale*j_mean(i) ; enddo ; endif + deallocate(asum) end subroutine global_j_mean diff --git a/src/initialization/MOM_fixed_initialization.F90 b/src/initialization/MOM_fixed_initialization.F90 index 8ed9a0a4c7..0ddca45c51 100644 --- a/src/initialization/MOM_fixed_initialization.F90 +++ b/src/initialization/MOM_fixed_initialization.F90 @@ -159,7 +159,7 @@ subroutine MOM_initialize_fixed(G, US, OBC, PF, write_geom, output_dir) call initialize_grid_rotation_angle(G, PF) ! Compute global integrals of grid values for later use in scalar diagnostics ! - call compute_global_grid_integrals(G) + call compute_global_grid_integrals(G, US=US) ! Write out all of the grid data used by this run. if (write_geom) call write_ocean_geometry_file(G, PF, output_dir, US=US) diff --git a/src/initialization/MOM_shared_initialization.F90 b/src/initialization/MOM_shared_initialization.F90 index 3d0fe6f1ed..3338f1fedb 100644 --- a/src/initialization/MOM_shared_initialization.F90 +++ b/src/initialization/MOM_shared_initialization.F90 @@ -1145,17 +1145,21 @@ end subroutine set_velocity_depth_min ! ----------------------------------------------------------------------------- !> Pre-compute global integrals of grid quantities (like masked ocean area) for !! later use in reporting diagnostics -subroutine compute_global_grid_integrals(G) - type(dyn_horgrid_type), intent(inout) :: G !< The dynamic horizontal grid +subroutine compute_global_grid_integrals(G, US) + type(dyn_horgrid_type), intent(inout) :: G !< The dynamic horizontal grid + type(unit_scale_type), optional, intent(in) :: US !< A dimensional unit scaling type ! Local variables real, dimension(G%isc:G%iec, G%jsc:G%jec) :: tmpForSumming + real :: area_scale ! A scaling factor for area into MKS units integer :: i,j + area_scale = 1.0 ; if (present(US)) area_scale = US%L_to_m**2 + tmpForSumming(:,:) = 0. G%areaT_global = 0.0 ; G%IareaT_global = 0.0 do j=G%jsc,G%jec ; do i=G%isc,G%iec - tmpForSumming(i,j) = G%areaT(i,j) * G%mask2dT(i,j) + tmpForSumming(i,j) = area_scale*G%areaT(i,j) * G%mask2dT(i,j) enddo ; enddo G%areaT_global = reproducing_sum(tmpForSumming) diff --git a/src/initialization/MOM_state_initialization.F90 b/src/initialization/MOM_state_initialization.F90 index 03310d70f3..ff08912191 100644 --- a/src/initialization/MOM_state_initialization.F90 +++ b/src/initialization/MOM_state_initialization.F90 @@ -1889,16 +1889,19 @@ end subroutine set_velocity_depth_max !> Subroutine to pre-compute global integrals of grid quantities for !! later use in reporting diagnostics -subroutine compute_global_grid_integrals(G) +subroutine compute_global_grid_integrals(G, US) type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type ! Local variables real, dimension(G%isc:G%iec, G%jsc:G%jec) :: tmpForSumming + real :: area_scale integer :: i,j + area_scale = US%L_to_m**2 tmpForSumming(:,:) = 0. G%areaT_global = 0.0 ; G%IareaT_global = 0.0 do j=G%jsc,G%jec ; do i=G%isc,G%iec - tmpForSumming(i,j) = G%US%L_to_m**2*G%areaT(i,j) * G%mask2dT(i,j) + tmpForSumming(i,j) = area_scale*G%areaT(i,j) * G%mask2dT(i,j) enddo ; enddo G%areaT_global = reproducing_sum(tmpForSumming) G%IareaT_global = 1. / (G%areaT_global) diff --git a/src/parameterizations/lateral/MOM_MEKE.F90 b/src/parameterizations/lateral/MOM_MEKE.F90 index 38bf24ee60..a2257369a8 100644 --- a/src/parameterizations/lateral/MOM_MEKE.F90 +++ b/src/parameterizations/lateral/MOM_MEKE.F90 @@ -188,7 +188,7 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, US, CS, hu, h call hchksum(MEKE%GM_src, 'MEKE GM_src', G%HI, scale=US%R_to_kg_m3*US%Z_to_m*US%L_to_m**2*US%s_to_T**3) if (associated(MEKE%MEKE)) call hchksum(MEKE%MEKE, 'MEKE MEKE', G%HI, scale=US%L_T_to_m_s**2) call uvchksum("MEKE SN_[uv]", SN_u, SN_v, G%HI, scale=US%s_to_T) - call uvchksum("MEKE h[uv]", hu, hv, G%HI, haloshift=1, scale=GV%H_to_m) + call uvchksum("MEKE h[uv]", hu, hv, G%HI, haloshift=1, scale=GV%H_to_m*US%L_to_m**2) endif sdt = dt*CS%MEKE_dtScale ! Scaled dt to use for time-stepping diff --git a/src/parameterizations/vertical/MOM_set_diffusivity.F90 b/src/parameterizations/vertical/MOM_set_diffusivity.F90 index b4c100dc5d..eb1afb6bb8 100644 --- a/src/parameterizations/vertical/MOM_set_diffusivity.F90 +++ b/src/parameterizations/vertical/MOM_set_diffusivity.F90 @@ -3,6 +3,7 @@ module MOM_set_diffusivity ! This file is part of MOM6. See LICENSE.md for the license. +use MOM_checksums, only : hchksum_pair use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end use MOM_cpu_clock, only : CLOCK_MODULE_DRIVER, CLOCK_MODULE, CLOCK_ROUTINE use MOM_diag_mediator, only : diag_ctrl, time_type @@ -344,8 +345,7 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, & if (CS%useKappaShear) then if (CS%debug) then - call hchksum(u_h, "before calc_KS u_h",G%HI) - call hchksum(v_h, "before calc_KS v_h",G%HI) + call hchksum_pair("before calc_KS [uv]_h", u_h, v_h, G%HI, scale=US%L_T_to_m_s) endif call cpu_clock_begin(id_clock_kappaShear) if (CS%Vertex_shear) then diff --git a/src/parameterizations/vertical/MOM_sponge.F90 b/src/parameterizations/vertical/MOM_sponge.F90 index dd0887845c..6016dbb98b 100644 --- a/src/parameterizations/vertical/MOM_sponge.F90 +++ b/src/parameterizations/vertical/MOM_sponge.F90 @@ -420,7 +420,7 @@ subroutine apply_sponge(h, dt, G, GV, US, ea, eb, CS, Rcv_ml) eta_anom(i,j) = e_D(i,j,k) - CS%Ref_eta_im(j,k) if (CS%Ref_eta_im(j,K) < -G%bathyT(i,j)) eta_anom(i,j) = 0.0 enddo ; enddo - call global_i_mean(eta_anom(:,:), eta_mean_anom(:,K), G) + call global_i_mean(eta_anom(:,:), eta_mean_anom(:,K), G, tmp_scale=US%Z_to_m) enddo if (CS%fldno > 0) allocate(fld_mean_anom(G%isd:G%ied,nz,CS%fldno)) diff --git a/src/tracer/MOM_tracer_advect.F90 b/src/tracer/MOM_tracer_advect.F90 index e050933dc2..e425629c77 100644 --- a/src/tracer/MOM_tracer_advect.F90 +++ b/src/tracer/MOM_tracer_advect.F90 @@ -485,8 +485,8 @@ subroutine advect_x(Tr, hprev, uhr, uh_neglect, OBC, domore_u, ntr, Idt, & else uhh(I) = uhr(I,j,k) endif - !ts2(I) = 0.5*(1.0 + uhh(I)/(hprev(i+1,j,k)+h_neglect)) - CFL(I) = - uhh(I)/(hprev(i+1,j,k)+h_neglect) ! CFL is positive + !ts2(I) = 0.5*(1.0 + uhh(I) / (hprev(i+1,j,k) + h_neglect*G%areaT(i+1,j))) + CFL(I) = - uhh(I) / (hprev(i+1,j,k) + h_neglect*G%areaT(i+1,j)) ! CFL is positive else hup = hprev(i,j,k) - G%areaT(i,j)*min_h hlos = MAX(0.0,-uhr(I-1,j,k)) @@ -497,8 +497,8 @@ subroutine advect_x(Tr, hprev, uhr, uh_neglect, OBC, domore_u, ntr, Idt, & else uhh(I) = uhr(I,j,k) endif - !ts2(I) = 0.5*(1.0 - uhh(I)/(hprev(i,j,k)+h_neglect)) - CFL(I) = uhh(I)/(hprev(i,j,k)+h_neglect) ! CFL is positive + !ts2(I) = 0.5*(1.0 - uhh(I) / (hprev(i,j,k) + h_neglect*G%areaT(i,j))) + CFL(I) = uhh(I) / (hprev(i,j,k) + h_neglect*G%areaT(i,j)) ! CFL is positive endif enddo @@ -573,7 +573,7 @@ subroutine advect_x(Tr, hprev, uhr, uh_neglect, OBC, domore_u, ntr, Idt, & ! Original implementation of PLM !flux_x(I,m) = uhh(I)*(Tr(m)%t(i+1,j,k) - slope_x(i+1,m)*ts2(I)) endif - !ts2(I) = 0.5*(1.0 - uhh(I)/(hprev(i,j,k)+h_neglect)) + !ts2(I) = 0.5*(1.0 - uhh(I)/(hprev(i,j,k)+h_neglect*G%areaT(i,j))) enddo ; enddo endif ! usePPM @@ -856,8 +856,8 @@ subroutine advect_y(Tr, hprev, vhr, vh_neglect, OBC, domore_v, ntr, Idt, & else vhh(i,J) = vhr(i,J,k) endif - !ts2(i) = 0.5*(1.0 + vhh(i,J) / (hprev(i,j+1,k)+h_neglect)) - CFL(i) = - vhh(i,J) / (hprev(i,j+1,k)+h_neglect) ! CFL is positive + !ts2(i) = 0.5*(1.0 + vhh(i,J) / (hprev(i,j+1,k) + h_neglect*G%areaT(i,j+1)) + CFL(i) = - vhh(i,J) / (hprev(i,j+1,k) + h_neglect*G%areaT(i,j+1)) ! CFL is positive else hup = hprev(i,j,k) - G%areaT(i,j)*min_h hlos = MAX(0.0,-vhr(i,J-1,k)) @@ -868,8 +868,8 @@ subroutine advect_y(Tr, hprev, vhr, vh_neglect, OBC, domore_v, ntr, Idt, & else vhh(i,J) = vhr(i,J,k) endif - !ts2(i) = 0.5*(1.0 - vhh(i,J) / (hprev(i,j,k)+h_neglect)) - CFL(i) = vhh(i,J) / (hprev(i,j,k)+h_neglect) ! CFL is positive + !ts2(i) = 0.5*(1.0 - vhh(i,J) / (hprev(i,j,k) + h_neglect*G%areaT(i,j))) + CFL(i) = vhh(i,J) / (hprev(i,j,k) + h_neglect*G%areaT(i,j)) ! CFL is positive endif enddo From cbdcf8a52a80a6ba3a2b20b29041ad92125b59d2 Mon Sep 17 00:00:00 2001 From: Jess <20195932+wrongkindofdoctor@users.noreply.github.com> Date: Fri, 17 Jul 2020 16:21:47 -0400 Subject: [PATCH 5/9] Create hola_tierra.yml --- .github/workflows/hola_tierra.yml | 27 +++++++++++++++++++++++++++ 1 file changed, 27 insertions(+) create mode 100644 .github/workflows/hola_tierra.yml diff --git a/.github/workflows/hola_tierra.yml b/.github/workflows/hola_tierra.yml new file mode 100644 index 0000000000..82f9b7d87e --- /dev/null +++ b/.github/workflows/hola_tierra.yml @@ -0,0 +1,27 @@ +# This is a basic workflow to help you get started with Actions + +name: CI + +# Controls when the action will run. Triggers the workflow on push or pull request +# events but only for the dev/gfdl branch +on: + push: + branches: [ user/jml/add_fms2io_to_MOM_restart ] + pull_request: + branches: [ dev/gfdl ] + +# A workflow run is made up of one or more jobs that can run sequentially or in parallel +jobs: + # This workflow contains a single job called "build" + build: + # The type of runner that the job will run on + runs-on: ubuntu-latest + + # Steps represent a sequence of tasks that will be executed as part of the job + steps: + # Checks-out your repository under $GITHUB_WORKSPACE, so your job can access it + - uses: actions/checkout@v2 + + # Runs a single command using the runners shell + - name: Run a one-line script + run: echo Hola, tierra! From 5c2daa5dad3ca8e16c65fdce3b7dd3a6a5b1c152 Mon Sep 17 00:00:00 2001 From: wrongkindofdoctor <> Date: Wed, 8 Jul 2020 17:31:12 -0400 Subject: [PATCH 6/9] converted save_restart and restore_state to interface that call versions of the routines with the fms-io or fms2-io interfaces added module use statments for fms2_io and MOM_io helper routines to MOM_restart added use_fms2=.true. arguments to save_restart and restore_state calls added write_ic=.true. to the save_restart call in MOM.F90 added module MOM_axis with routines to define and register axes and their metadata added module MOM_read_data_fms2.F90 with wrappers for fms2_io read_data interfaces and required routines added module MOM_write_field_fms2.F90 with wrappers for fms2_io write_data interfaces updated module use statments in MOM_io and MOM_restart to reference routines in MOM_read_data_fms2, MOM_write_field_fms2, and MOM_axis made write_field and create_file interfaces in MOM_io added create_file routines to MOM_io that accept file names or file objects to create/overwrite netcdf files that will be written to via write_field calls fixed compile-time errors added new MOM_read_data routines to MOM_read_data interface in MOM_io added placeholder call for new write_field routines to MOM_io changed use_fms2 to a required first argument in save_restart_fms2 and restore_state_fms2 changed write_ic to a required argument in write_initial_conditions fixed the layer and interface checks in MOM_get_diagnostic_axis_data commented out manual checksum registration in save_restart_fms2 so that internal fms2-io checksum computation is used added checks for time units to restore_state and save_restart added logic to make the restart time 1 to save_restart_fms2 if there is an abnormally large value passed to the routine added interface routine file_exists_FMS2 that uses the fms2_io file_exists call added subroutine get_num_restart_files to MOM_restart that searches for known variants of the input file names and returns then number of restart files available for querying, and the optional list of filepaths added loop to search the files for all mandatory variables in the list of file paths returned to by cal to get_num_restart_files added calls to get the variable dimension names and pass them as arguments to register_restart_field in restore_state_fms2 removed exit from inner variable loop in restore_state_fms2 code cleanup moved missing_fields=0 outside of the CS loop in restore_state_fms2 moved missing_fields=0 outside of the CS loop in restore_state_fms2 converted save_restart and restore_state to interface that call versions of the routines with the fms-io or fms2-io interfaces added module use statments for fms2_io and MOM_io helper routines to MOM_restart added use_fms2=.true. arguments to save_restart and restore_state calls added write_ic=.true. to the save_restart call in MOM.F90 added module MOM_axis with routines to define and register axes and their metadata added module MOM_read_data_fms2.F90 with wrappers for fms2_io read_data interfaces and required routines added module MOM_write_field_fms2.F90 with wrappers for fms2_io write_data interfaces updated module use statments in MOM_io and MOM_restart to reference routines in MOM_read_data_fms2, MOM_write_field_fms2, and MOM_axis made write_field and create_file interfaces in MOM_io added create_file routines to MOM_io that accept file names or file objects to create/overwrite netcdf files that will be written to via write_field calls fixed compile-time errors added new MOM_read_data routines to MOM_read_data interface in MOM_io added placeholder call for new write_field routines to MOM_io changed use_fms2 to a required first argument in save_restart_fms2 and restore_state_fms2 changed write_ic to a required argument in write_initial_conditions fixed the layer and interface checks in MOM_get_diagnostic_axis_data commented out manual checksum registration in save_restart_fms2 so that internal fms2-io checksum computation is used added checks for time units to restore_state and save_restart added logic to make the restart time 1 to save_restart_fms2 if there is an abnormally large value passed to the routine added interface routine file_exists_FMS2 that uses the fms2_io file_exists call added subroutine get_num_restart_files to MOM_restart that searches for known variants of the input file names and returns then number of restart files available for querying, and the optional list of filepaths added loop to search the files for all mandatory variables in the list of file paths returned to by cal to get_num_restart_files added calls to get the variable dimension names and pass them as arguments to register_restart_field in restore_state_fms2 removed exit from inner variable loop in restore_state_fms2 code cleanup removed test workflow directory moved missing_fields=0 outside of the CS loop in restore_state_fms2 converted save_restart and restore_state to interface that call versions of the routines with the fms-io or fms2-io interfaces added module use statments for fms2_io and MOM_io helper routines to MOM_restart added use_fms2=.true. arguments to save_restart and restore_state calls added write_ic=.true. to the save_restart call in MOM.F90 added module MOM_axis with routines to define and register axes and their metadata added module MOM_read_data_fms2.F90 with wrappers for fms2_io read_data interfaces and required routines added module MOM_write_field_fms2.F90 with wrappers for fms2_io write_data interfaces updated module use statments in MOM_io and MOM_restart to reference routines in MOM_read_data_fms2, MOM_write_field_fms2, and MOM_axis made write_field and create_file interfaces in MOM_io added create_file routines to MOM_io that accept file names or file objects to create/overwrite netcdf files that will be written to via write_field calls fixed compile-time errors added new MOM_read_data routines to MOM_read_data interface in MOM_io added placeholder call for new write_field routines to MOM_io changed use_fms2 to a required first argument in save_restart_fms2 and restore_state_fms2 changed write_ic to a required argument in write_initial_conditions fixed the layer and interface checks in MOM_get_diagnostic_axis_data commented out manual checksum registration in save_restart_fms2 so that internal fms2-io checksum computation is used added checks for time units to restore_state and save_restart added logic to make the restart time 1 to save_restart_fms2 if there is an abnormally large value passed to the routine added interface routine file_exists_FMS2 that uses the fms2_io file_exists call added subroutine get_num_restart_files to MOM_restart that searches for known variants of the input file names and returns then number of restart files available for querying, and the optional list of filepaths added loop to search the files for all mandatory variables in the list of file paths returned to by cal to get_num_restart_files added calls to get the variable dimension names and pass them as arguments to register_restart_field in restore_state_fms2 removed exit from inner variable loop in restore_state_fms2 code cleanup removed test workflow directory removed white space updated FMS tag in .testing Makefile fixed argument comments to use doxygen style in MOM_write_field_fms2 code cleanup removed \TODO from MOM_restart fixed documentation for module variables in MOM_read_data_fms2 and MOM_write_field_fms2 removed doxygenized TODO statements removed new MOM_read_data routines from interface, and commented out calls in MOM_io fixed doxygen definitions more doxygen fixes changed save_restart and restore_state to wrapper routines with opitional use_fms2 and write_ic arguments added use_fms2=.true. and write_ic=.true. to save_restart and restore_state calls removed the error messages from append_substring tried reordering the write_ic and use_fms2 checks in save_restart to fix error with invalid memory reference in the MOM.F90 call to save_restart-write_initial_conditions --- .github/workflows/hola_tierra.yml | 27 - .testing/Makefile | 2 +- .../MOM_surface_forcing_gfdl.F90 | 6 +- config_src/coupled_driver/ocean_model_MOM.F90 | 10 +- config_src/mct_driver/mom_ocean_model_mct.F90 | 11 +- .../mct_driver/mom_surface_forcing_mct.F90 | 6 +- config_src/mct_driver/ocn_comp_mct.F90 | 2 +- .../nuopc_driver/mom_ocean_model_nuopc.F90 | 13 +- .../mom_surface_forcing_nuopc.F90 | 6 +- config_src/solo_driver/MOM_driver.F90 | 10 +- .../solo_driver/MOM_surface_forcing.F90 | 7 +- src/core/MOM.F90 | 4 +- src/framework/MOM_axis.F90 | 625 +++++++ src/framework/MOM_io.F90 | 525 +++++- src/framework/MOM_read_data_fms2.F90 | 1540 +++++++++++++++ src/framework/MOM_restart.F90 | 895 ++++++++- src/framework/MOM_string_functions.F90 | 29 + src/framework/MOM_write_field_fms2.F90 | 1663 +++++++++++++++++ src/ice_shelf/MOM_ice_shelf.F90 | 11 +- .../MOM_state_initialization.F90 | 4 +- 20 files changed, 5313 insertions(+), 83 deletions(-) delete mode 100644 .github/workflows/hola_tierra.yml create mode 100644 src/framework/MOM_axis.F90 create mode 100644 src/framework/MOM_read_data_fms2.F90 create mode 100644 src/framework/MOM_write_field_fms2.F90 diff --git a/.github/workflows/hola_tierra.yml b/.github/workflows/hola_tierra.yml deleted file mode 100644 index 82f9b7d87e..0000000000 --- a/.github/workflows/hola_tierra.yml +++ /dev/null @@ -1,27 +0,0 @@ -# This is a basic workflow to help you get started with Actions - -name: CI - -# Controls when the action will run. Triggers the workflow on push or pull request -# events but only for the dev/gfdl branch -on: - push: - branches: [ user/jml/add_fms2io_to_MOM_restart ] - pull_request: - branches: [ dev/gfdl ] - -# A workflow run is made up of one or more jobs that can run sequentially or in parallel -jobs: - # This workflow contains a single job called "build" - build: - # The type of runner that the job will run on - runs-on: ubuntu-latest - - # Steps represent a sequence of tasks that will be executed as part of the job - steps: - # Checks-out your repository under $GITHUB_WORKSPACE, so your job can access it - - uses: actions/checkout@v2 - - # Runs a single command using the runners shell - - name: Run a one-line script - run: echo Hola, tierra! diff --git a/.testing/Makefile b/.testing/Makefile index ab978fdadc..05fb630a31 100644 --- a/.testing/Makefile +++ b/.testing/Makefile @@ -20,7 +20,7 @@ MKMF := $(abspath $(DEPS)/mkmf/bin/mkmf) # FMS framework FMS_URL ?= https://github.com/NOAA-GFDL/FMS.git -FMS_COMMIT ?= 2019.01.03 +FMS_COMMIT ?= 2020.03-alpha1 FMS := $(DEPS)/fms #--- diff --git a/config_src/coupled_driver/MOM_surface_forcing_gfdl.F90 b/config_src/coupled_driver/MOM_surface_forcing_gfdl.F90 index 7075fb7c10..4a730d6e6d 100644 --- a/config_src/coupled_driver/MOM_surface_forcing_gfdl.F90 +++ b/config_src/coupled_driver/MOM_surface_forcing_gfdl.F90 @@ -1224,7 +1224,8 @@ subroutine forcing_save_restart(CS, G, Time, directory, time_stamped, & if (.not.associated(CS)) return if (.not.associated(CS%restart_CSp)) return - call save_restart(directory, Time, G, CS%restart_CSp, time_stamped) + ! NOTE: use_fms2=.true. routes routine to fms2 IO interface; omit this argument to use the old interface + call save_restart(directory, Time, G, CS%restart_CSp, time_stamped, use_fms2=.true.) end subroutine forcing_save_restart @@ -1589,8 +1590,9 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, wind_stagger) if ((dirs%input_filename(1:1) == 'n') .and. & (LEN_TRIM(dirs%input_filename) == 1)) new_sim = .true. if (.not.new_sim) then + ! NOTE: use_fms2=.true. routes routine to fms2 IO interface; omit this argument to use the old interface call restore_state(dirs%input_filename, dirs%restart_input_dir, Time_frc, & - G, CS%restart_CSp) + G, CS%restart_CSp, use_fms2=.true.) endif endif diff --git a/config_src/coupled_driver/ocean_model_MOM.F90 b/config_src/coupled_driver/ocean_model_MOM.F90 index 082099158c..ff365a9e78 100644 --- a/config_src/coupled_driver/ocean_model_MOM.F90 +++ b/config_src/coupled_driver/ocean_model_MOM.F90 @@ -684,8 +684,9 @@ subroutine ocean_model_restart(OS, timestamp) "restart files can only be created after the buoyancy forcing is applied.") if (BTEST(OS%Restart_control,1)) then + ! NOTE: use_fms2=.true. routes routine to fms2 IO interface call save_restart(OS%dirs%restart_output_dir, OS%Time, OS%grid, & - OS%restart_CSp, .true., GV=OS%GV) + OS%restart_CSp, .true., GV=OS%GV, use_fms2=.true.) call forcing_save_restart(OS%forcing_CSp, OS%grid, OS%Time, & OS%dirs%restart_output_dir, .true.) if (OS%use_ice_shelf) then @@ -693,8 +694,9 @@ subroutine ocean_model_restart(OS, timestamp) endif endif if (BTEST(OS%Restart_control,0)) then + ! NOTE: use_fms2=.true. routes routine to fms2 IO interface call save_restart(OS%dirs%restart_output_dir, OS%Time, OS%grid, & - OS%restart_CSp, GV=OS%GV) + OS%restart_CSp, GV=OS%GV, use_fms2=.true.) call forcing_save_restart(OS%forcing_CSp, OS%grid, OS%Time, & OS%dirs%restart_output_dir) if (OS%use_ice_shelf) then @@ -746,8 +748,8 @@ subroutine ocean_model_save_restart(OS, Time, directory, filename_suffix) if (present(directory)) then ; restart_dir = directory else ; restart_dir = OS%dirs%restart_output_dir ; endif - - call save_restart(restart_dir, Time, OS%grid, OS%restart_CSp, GV=OS%GV) + ! NOTE: use_fms2=.true. routes routine to fms2 IO interface + call save_restart(restart_dir, Time, OS%grid, OS%restart_CSp, GV=OS%GV, use_fms2=.true.) call forcing_save_restart(OS%forcing_CSp, OS%grid, Time, restart_dir) diff --git a/config_src/mct_driver/mom_ocean_model_mct.F90 b/config_src/mct_driver/mom_ocean_model_mct.F90 index f8a4a19532..3c75cb12eb 100644 --- a/config_src/mct_driver/mom_ocean_model_mct.F90 +++ b/config_src/mct_driver/mom_ocean_model_mct.F90 @@ -690,8 +690,9 @@ subroutine ocean_model_restart(OS, timestamp, restartname) "restart files can only be created after the buoyancy forcing is applied.") if (present(restartname)) then + ! NOTE: use_fms2=.true. routes routine to fms2 IO interface call save_restart(OS%dirs%restart_output_dir, OS%Time, OS%grid, & - OS%restart_CSp, GV=OS%GV, filename=restartname) + OS%restart_CSp, GV=OS%GV, filename=restartname, use_fms2=.true.) call forcing_save_restart(OS%forcing_CSp, OS%grid, OS%Time, & OS%dirs%restart_output_dir) ! Is this needed? if (OS%use_ice_shelf) then @@ -700,8 +701,9 @@ subroutine ocean_model_restart(OS, timestamp, restartname) endif else if (BTEST(OS%Restart_control,1)) then + ! NOTE:use_fms2=.true. routes routine to fms2 IO interface call save_restart(OS%dirs%restart_output_dir, OS%Time, OS%grid, & - OS%restart_CSp, .true., GV=OS%GV) + OS%restart_CSp, .true., GV=OS%GV, use_fms2=.true.) call forcing_save_restart(OS%forcing_CSp, OS%grid, OS%Time, & OS%dirs%restart_output_dir, .true.) if (OS%use_ice_shelf) then @@ -709,8 +711,9 @@ subroutine ocean_model_restart(OS, timestamp, restartname) endif endif if (BTEST(OS%Restart_control,0)) then + ! NOTE: use_fms2=.true. routes routine to fms2 IO interface call save_restart(OS%dirs%restart_output_dir, OS%Time, OS%grid, & - OS%restart_CSp, GV=OS%GV) + OS%restart_CSp, GV=OS%GV, use_fms2=.true.) call forcing_save_restart(OS%forcing_CSp, OS%grid, OS%Time, & OS%dirs%restart_output_dir) if (OS%use_ice_shelf) then @@ -766,7 +769,7 @@ subroutine ocean_model_save_restart(OS, Time, directory, filename_suffix) if (present(directory)) then ; restart_dir = directory else ; restart_dir = OS%dirs%restart_output_dir ; endif - call save_restart(restart_dir, Time, OS%grid, OS%restart_CSp, GV=OS%GV) + call save_restart(restart_dir, Time, OS%grid, OS%restart_CSp, GV=OS%GV, use_fms2=.true.) call forcing_save_restart(OS%forcing_CSp, OS%grid, Time, restart_dir) diff --git a/config_src/mct_driver/mom_surface_forcing_mct.F90 b/config_src/mct_driver/mom_surface_forcing_mct.F90 index a42a8c3015..88b7f01654 100644 --- a/config_src/mct_driver/mom_surface_forcing_mct.F90 +++ b/config_src/mct_driver/mom_surface_forcing_mct.F90 @@ -1001,7 +1001,8 @@ subroutine forcing_save_restart(CS, G, Time, directory, time_stamped, & if (.not.associated(CS)) return if (.not.associated(CS%restart_CSp)) return - call save_restart(directory, Time, G, CS%restart_CSp, time_stamped) + ! NOTE: use_fms2=.true. routes routine to fms2 IO interface + call save_restart(.true., directory, Time, G, CS%restart_CSp, time_stamped, use_fms2=.true.) end subroutine forcing_save_restart @@ -1325,8 +1326,9 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, restore_salt, if ((dirs%input_filename(1:1) == 'n') .and. & (LEN_TRIM(dirs%input_filename) == 1)) new_sim = .true. if (.not.new_sim) then + ! NOTE: use_fms2=.true. routes routine to fms2 IO interface call restore_state(dirs%input_filename, dirs%restart_input_dir, Time_frc, & - G, CS%restart_CSp) + G, CS%restart_CSp, use_fms2=.true.) endif endif diff --git a/config_src/mct_driver/ocn_comp_mct.F90 b/config_src/mct_driver/ocn_comp_mct.F90 index b1ce9a60c0..9f1912d79f 100644 --- a/config_src/mct_driver/ocn_comp_mct.F90 +++ b/config_src/mct_driver/ocn_comp_mct.F90 @@ -534,7 +534,7 @@ subroutine ocn_run_mct( EClock, cdata_o, x2o_o, o2x_o) write(restartname,'(A,".mom6.r.",I4.4,"-",I2.2,"-",I2.2,"-",I5.5)') trim(runid), year, month, day, seconds call save_restart(glb%ocn_state%dirs%restart_output_dir, glb%ocn_state%Time, glb%grid, & - glb%ocn_state%restart_CSp, .false., filename=restartname, GV=glb%ocn_state%GV) + glb%ocn_state%restart_CSp, .false., filename=restartname, GV=glb%ocn_state%GV, use_fms2=.true.) ! write name of restart file in the rpointer file nu = shr_file_getUnit() diff --git a/config_src/nuopc_driver/mom_ocean_model_nuopc.F90 b/config_src/nuopc_driver/mom_ocean_model_nuopc.F90 index 9946aec4f9..a8765bdc08 100644 --- a/config_src/nuopc_driver/mom_ocean_model_nuopc.F90 +++ b/config_src/nuopc_driver/mom_ocean_model_nuopc.F90 @@ -686,8 +686,9 @@ subroutine ocean_model_restart(OS, timestamp, restartname) "restart files can only be created after the buoyancy forcing is applied.") if (present(restartname)) then + ! NOTE: use_fms2=.true. routes routine to fms2 IO interface call save_restart(OS%dirs%restart_output_dir, OS%Time, OS%grid, & - OS%restart_CSp, GV=OS%GV, filename=restartname) + OS%restart_CSp, GV=OS%GV, filename=restartname, use_fms2=.true.) call forcing_save_restart(OS%forcing_CSp, OS%grid, OS%Time, & OS%dirs%restart_output_dir) ! Is this needed? if (OS%use_ice_shelf) then @@ -696,8 +697,9 @@ subroutine ocean_model_restart(OS, timestamp, restartname) endif else if (BTEST(OS%Restart_control,1)) then + ! NOTE: use_fms2=.true. routes routine to fms2 IO interface call save_restart(OS%dirs%restart_output_dir, OS%Time, OS%grid, & - OS%restart_CSp, .true., GV=OS%GV) + OS%restart_CSp, .true., GV=OS%GV, use_fms2=.true.) call forcing_save_restart(OS%forcing_CSp, OS%grid, OS%Time, & OS%dirs%restart_output_dir, .true.) if (OS%use_ice_shelf) then @@ -705,8 +707,9 @@ subroutine ocean_model_restart(OS, timestamp, restartname) endif endif if (BTEST(OS%Restart_control,0)) then + ! NOTE: use_fms2=.true. routes routine to fms2 IO interface call save_restart(OS%dirs%restart_output_dir, OS%Time, OS%grid, & - OS%restart_CSp, GV=OS%GV) + OS%restart_CSp, GV=OS%GV, use_fms2=.true.) call forcing_save_restart(OS%forcing_CSp, OS%grid, OS%Time, & OS%dirs%restart_output_dir) if (OS%use_ice_shelf) then @@ -760,8 +763,8 @@ subroutine ocean_model_save_restart(OS, Time, directory, filename_suffix) if (present(directory)) then ; restart_dir = directory else ; restart_dir = OS%dirs%restart_output_dir ; endif - - call save_restart(restart_dir, Time, OS%grid, OS%restart_CSp, GV=OS%GV) + ! NOTE: use_fms2=.true. routes routine to fms2 IO interface + call save_restart(restart_dir, Time, OS%grid, OS%restart_CSp, GV=OS%GV, use_fms2=.true.) call forcing_save_restart(OS%forcing_CSp, OS%grid, Time, restart_dir) diff --git a/config_src/nuopc_driver/mom_surface_forcing_nuopc.F90 b/config_src/nuopc_driver/mom_surface_forcing_nuopc.F90 index 3d49c66ce6..a565da3d93 100644 --- a/config_src/nuopc_driver/mom_surface_forcing_nuopc.F90 +++ b/config_src/nuopc_driver/mom_surface_forcing_nuopc.F90 @@ -1000,7 +1000,8 @@ subroutine forcing_save_restart(CS, G, Time, directory, time_stamped, & if (.not.associated(CS)) return if (.not.associated(CS%restart_CSp)) return - call save_restart(directory, Time, G, CS%restart_CSp, time_stamped) + ! NOTE: use_fms2=.true. routes routine to fms2 IO interface + call save_restart(directory, Time, G, CS%restart_CSp, time_stamped, use_fms2=.true.) end subroutine forcing_save_restart @@ -1330,8 +1331,9 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, restore_salt, if ((dirs%input_filename(1:1) == 'n') .and. & (LEN_TRIM(dirs%input_filename) == 1)) new_sim = .true. if (.not.new_sim) then + ! NOTE: use_fms2=.true. routes routine to fms2 IO interface call restore_state(dirs%input_filename, dirs%restart_input_dir, Time_frc, & - G, CS%restart_CSp) + G, CS%restart_CSp, use_fms2=.true.) endif endif diff --git a/config_src/solo_driver/MOM_driver.F90 b/config_src/solo_driver/MOM_driver.F90 index f180cd9717..c6fbe0e4e6 100644 --- a/config_src/solo_driver/MOM_driver.F90 +++ b/config_src/solo_driver/MOM_driver.F90 @@ -583,16 +583,18 @@ program MOM_main if ((permit_incr_restart) .and. (fluxes%fluxes_used) .and. & (Time + (Time_step_ocean/2) > restart_time)) then if (BTEST(Restart_control,1)) then + ! NOTE: use_fms2=.true. routes routine to fms2 IO interface call save_restart(dirs%restart_output_dir, Time, grid, & - restart_CSp, .true., GV=GV) + restart_CSp, .true., GV=GV, use_fms2=.true.) call forcing_save_restart(surface_forcing_CSp, grid, Time, & dirs%restart_output_dir, .true.) if (use_ice_shelf) call ice_shelf_save_restart(ice_shelf_CSp, Time, & dirs%restart_output_dir, .true.) endif if (BTEST(Restart_control,0)) then + ! NOTE: use_fms2=.true. routes routine to fms2 IO interface call save_restart(dirs%restart_output_dir, Time, grid, & - restart_CSp, GV=GV) + restart_CSp, GV=GV, use_fms2=.true.) call forcing_save_restart(surface_forcing_CSp, grid, Time, & dirs%restart_output_dir) if (use_ice_shelf) call ice_shelf_save_restart(ice_shelf_CSp, Time, & @@ -616,8 +618,8 @@ program MOM_main "End of MOM_main reached with unused buoyancy fluxes. "//& "For conservation, the ocean restart files can only be "//& "created after the buoyancy forcing is applied.") - - call save_restart(dirs%restart_output_dir, Time, grid, restart_CSp, GV=GV) + ! NOTE: use_fms2=.true. routes routine to fms2 IO interface + call save_restart(dirs%restart_output_dir, Time, grid, restart_CSp, GV=GV, use_fms2=.true.) if (use_ice_shelf) call ice_shelf_save_restart(ice_shelf_CSp, Time, & dirs%restart_output_dir) ! Write ocean solo restart file. diff --git a/config_src/solo_driver/MOM_surface_forcing.F90 b/config_src/solo_driver/MOM_surface_forcing.F90 index 0a56abb681..5b10ea46e4 100644 --- a/config_src/solo_driver/MOM_surface_forcing.F90 +++ b/config_src/solo_driver/MOM_surface_forcing.F90 @@ -1524,8 +1524,8 @@ subroutine forcing_save_restart(CS, G, Time, directory, time_stamped, & if (.not.associated(CS)) return if (.not.associated(CS%restart_CSp)) return - - call save_restart(directory, Time, G, CS%restart_CSp, time_stamped) + ! NOTE: use_fms2=.true. routes routine to fms2 IO interface + call save_restart(directory, Time, G, CS%restart_CSp, time_stamped, use_fms2=.true.) end subroutine forcing_save_restart @@ -1925,8 +1925,9 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, tracer_flow_C if ((dirs%input_filename(1:1) == 'n') .and. & (LEN_TRIM(dirs%input_filename) == 1)) new_sim = .true. if (.not.new_sim) then + ! NOTE: use_fms2=.true. routes routine to fms2 IO interface call restore_state(dirs%input_filename, dirs%restart_input_dir, Time_frc, & - G, CS%restart_CSp) + G, CS%restart_CSp, use_fms2=.true.) endif endif diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index a9b9c7fec4..2c48796f57 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -2782,9 +2782,9 @@ subroutine finish_MOM_initialization(Time, dirs, CS, restart_CSp) call find_eta(CS%h, CS%tv, G, GV, US, z_interface, eta_to_m=1.0) call register_restart_field(z_interface, "eta", .true., restart_CSp_tmp, & "Interface heights", "meter", z_grid='i') - + ! NOTE: write_ic=.true. routes routine to fms2 IO write_initial_conditions interface call save_restart(dirs%output_directory, Time, CS%G_in, & - restart_CSp_tmp, filename=CS%IC_file, GV=GV) + restart_CSp_tmp, filename=CS%IC_file, GV=GV, write_ic=.true.) deallocate(z_interface) deallocate(restart_CSp_tmp) endif diff --git a/src/framework/MOM_axis.F90 b/src/framework/MOM_axis.F90 new file mode 100644 index 0000000000..48f70bec70 --- /dev/null +++ b/src/framework/MOM_axis.F90 @@ -0,0 +1,625 @@ +!> This module contains routines that define and register axes to files +module MOM_axis + +! This file is part of MOM6. See LICENSE.md for the license. +use MOM_domains, only : MOM_domain_type +use MOM_error_handler, only : MOM_error, NOTE, FATAL, WARNING +use MOM_grid, only : ocean_grid_type +use MOM_dyn_horgrid, only : dyn_horgrid_type +use MOM_string_functions, only : lowercase +use MOM_verticalGrid, only : verticalGrid_type +use fms2_io_mod, only : is_dimension_registered, register_axis, is_dimension_unlimited +use fms2_io_mod, only : FmsNetcdfDomainFile_t, FmsNetcdfFile_t, unlimited +use fms2_io_mod, only : get_variable_size, get_variable_num_dimensions, check_if_open +use fms2_io_mod, only : fms2_open_file=>open_file, fms2_close_file=>close_file +use fms2_io_mod, only : get_variable_dimension_names, read_data, get_unlimited_dimension_name +use fms2_io_mod, only : get_dimension_size +use mpp_domains_mod, only : domain2d, CENTER, CORNER, NORTH_FACE=>NORTH, EAST_FACE=>EAST +use mpp_domains_mod, only : mpp_get_compute_domain +use netcdf +implicit none ; private + +public MOM_register_diagnostic_axis, get_var_dimension_metadata, get_time_units +public MOM_get_diagnostic_axis_data, MOM_register_variable_axes, get_time_index +public convert_checksum_to_string +!> A type for making arrays of pointers to real 1-d arrays +type p1d + real, dimension(:), pointer :: p => NULL() !< A pointer to a 1d array +end type p1d + +!> A structure with information about a single axis variable +type axis_atts + character(len=64) :: name !< Names of the axis + character(len=48) :: units !< Physical dimensions of the axis + character(len=240) :: longname !< Long name of the axis + character(len=8) :: positive !< Positive-definite direction: up, down, east, west, north, south + integer :: horgrid_position !< Horizontal grid position + logical :: is_domain_decomposed !< if .true. the axis data are domain-decomposed + !! and need to be indexed by the compute domain + !! before passing to write_data +end type axis_atts + +!> Type for describing an axis variable (e.g., lath, lonh, Time) +type, public :: axis_data_type + !> An array of descriptions of the registered axes + type(axis_atts), pointer :: axis(:) => NULL() !< structure with axis attributes + type(p1d), pointer :: data(:) => NULL() !< pointer to the axis data +end type axis_data_type + +!> interface for registering axes associated with a variable to a netCDF file object +interface MOM_register_variable_axes + module procedure MOM_register_variable_axes_subdomain + module procedure MOM_register_variable_axes_full +end interface MOM_register_variable_axes + +contains + +!> register a MOM diagnostic axis to a domain-decomposed file +subroutine MOM_register_diagnostic_axis(fileObj, axisName, axisLength) + type(FmsNetcdfDomainFile_t), intent(inout) :: fileObj !< netCDF file object returned by call to open_file + character(len=*), intent(in) :: axisName !< name of the axis to register to file + integer, intent(in), optional :: axisLength !< length of axis/dimension ;only needed for Layer, Interface, Time, + !! Period + select case (trim(lowercase(axisName))) + case ('latq'); call register_axis(fileObj,'latq','y', domain_position=NORTH_FACE) + case ('lath'); call register_axis(fileObj,'lath','y', domain_position=CENTER) + case ('lonq'); call register_axis(fileObj,'lonq','x', domain_position=EAST_FACE) + case ('lonh'); call register_axis(fileObj,'lonh','x', domain_position=CENTER) + case default + if (.not. present(axisLength)) call MOM_error(FATAL,"MOM_io:register_diagnostic_axis: "//& + "An axis_length argument is required to register the axis "//trim(axisName)) + call register_axis(fileObj, trim(axisName), axisLength) + end select +end subroutine MOM_register_diagnostic_axis + + +!> Get the horizontal grid, vertical grid, and/or time dimension names and lengths +!! for a single variable from the hor_grid, t_grid, and z_grid values returned by a prior call to query_vardesc +subroutine get_var_dimension_metadata(hor_grid, z_grid, t_grid_in, & + dim_names, dim_lengths, num_dims, G, dG, GV) + + character(len=*), intent(in) :: hor_grid !< horizontal grid + character(len=*), intent(in) :: z_grid !< vertical grid + character(len=*), intent(in) :: t_grid_in !< time grid + character(len=*), dimension(:), intent(inout) :: dim_names !< array of dimension names + integer, dimension(:), intent(inout) :: dim_lengths !< array of dimension sizes + integer, intent(inout) :: num_dims !< number of axes to register in the restart file + type(ocean_grid_type), optional, intent(in) :: G !< The ocean's grid structure + type(dyn_horgrid_type), optional, intent(in) :: dG !< dynamic horizontal grid structure; G or dG + !! is required if the new file uses any + !! horizontal grid axes. + type(verticalGrid_type), optional, intent(in) :: GV !< ocean vertical grid structure + + ! local + logical :: use_lath + logical :: use_lonh + logical :: use_latq + logical :: use_lonq + character(len=8) :: t_grid + character(len=8) :: t_grid_read + integer :: isg, ieg, jsg, jeg, IsgB, IegB, JsgB, JegB + !integer :: npes + real, pointer, dimension(:) :: gridLatT => NULL(), & ! The latitude or longitude of T or B points for + gridLatB => NULL(), & ! the purpose of labeling the output axes. + gridLonT => NULL(), & + gridLonB => NULL() + type(MOM_domain_type), pointer :: domain => NULL() ! Domain used to get the pe count + + use_lath = .false. + use_lonh = .false. + use_latq = .false. + use_lonq = .false. + + ! set the ocean grid coordinates + + if (present(G)) then + gridLatT => G%gridLatT ; gridLatB => G%gridLatB + gridLonT => G%gridLonT ; gridLonB => G%gridLonB + isg = G%isg ; ieg = G%ieg ; jsg = G%jsg ; jeg = G%jeg + IsgB = G%IsgB ; IegB = G%IegB ; JsgB = G%JsgB ; JegB = G%JegB + + call get_horizontal_grid_logic(hor_grid, use_lath, use_lonh, use_latq, use_lonq) + elseif (present(dG)) then + gridLatT => dG%gridLatT ; gridLatB => dG%gridLatB + gridLonT => dG%gridLonT ; gridLonB => dG%gridLonB + isg = dG%isg ; ieg = dG%ieg ; jsg = dG%jsg ; jeg = dG%jeg + IsgB = dG%IsgB ; IegB = dG%IegB ; JsgB = dG%JsgB ; JegB = dG%JegB + + call get_horizontal_grid_logic(hor_grid, use_lath, use_lonh, use_latq, use_lonq) + endif + + ! add longitude name to dimension name array + if (use_lonh) then + num_dims = num_dims+1 + dim_names(num_dims) = "" + dim_names(num_dims)(1:len_trim("lonh")) = "lonh" + dim_lengths(num_dims) = size(gridLonT(isg:ieg)) + elseif (use_lonq) then + num_dims = num_dims+1 + dim_names(num_dims) = "" + dim_names(num_dims)(1:len_trim("lonq")) = "lonq" + dim_lengths(num_dims) = size(gridLonB(IsgB:IegB)) + endif + ! add latitude name to dimension name array + if (use_lath) then + num_dims = num_dims+1 + dim_names(num_dims) = "" + dim_names(num_dims)(1:len_trim("lath")) = "lath" + dim_lengths(num_dims) = size(gridLatT(jsg:jeg)) + elseif (use_latq) then + num_dims = num_dims+1 + dim_names(num_dims) = "" + dim_names(num_dims)(1:len_trim("latq")) = "latq" + dim_lengths(num_dims) = size(gridLatB(JsgB:JegB)) + endif + + if (present(GV)) then + ! vertical grid + select case (trim(z_grid)) + case ('L') + num_dims = num_dims+1 + dim_names(num_dims) = "" + dim_names(num_dims)(1:len_trim("Layer")) = "Layer" + dim_lengths(num_dims) = GV%ke + case ('i') + num_dims = num_dims+1 + dim_names(num_dims) = "" + dim_names(num_dims)(1:len_trim("Interface")) = "Interface" + dim_lengths(num_dims) = GV%ke+1 + case ('1') ! Do nothing. + case default + call MOM_error(FATAL, "MOM_io: get_var_dimension_features: "//& + " has an unrecognized z_grid argument"//trim(z_grid)) + end select + endif + ! time + t_grid = adjustl(t_grid_in) + select case (t_grid(1:1)) + case ('s', 'a', 'm') + num_dims = num_dims+1 + dim_names(num_dims) = "" + dim_names(num_dims)(1:len_trim("Time")) = "Time" + dim_lengths(num_dims) = unlimited + case ('p') + if (len_trim(t_grid(2:8)) <= 0) then + call MOM_error(FATAL,"MOM_io:get_var_dimension_features: "//& + "No periodic axis length was specified in "//trim(t_grid)) + endif + num_dims = num_dims+1 + dim_names(num_dims) = "" + dim_names(num_dims)(1:len_trim("Period")) = "Period" + dim_lengths(num_dims) = unlimited + case ('1') ! Do nothing. + case default + call MOM_error(WARNING, "MOM_io: get_var_dimension_metadata: "//& + "Unrecognized t_grid "//trim(t_grid)) + end select +end subroutine get_var_dimension_metadata + + +!> Populate the axis_data structure with axis data and attributes for diagnostic and restart files +subroutine MOM_get_diagnostic_axis_data(axis_data_CS, axis_name, axis_number, G, dG, GV, time_val, time_units) + + type(axis_data_type), intent(inout) :: axis_data_CS !< structure containing the axis data and metadata + character(len=*), intent(in) :: axis_name !< name of the axis + integer, intent(in) :: axis_number !< positional value (wrt to file) of the axis to register + type(ocean_grid_type), optional, intent(in) :: G !< ocean horizontal grid structure + type(dyn_horgrid_type), optional, intent(in) :: dG !< dynamic horizontal grid structure; G or dG + !! is required if the file uses any + !! horizontal grid axes. + type(verticalGrid_type), target, optional, intent(in) :: GV !< ocean vertical grid structure + real,dimension(:), target, optional, intent(in) :: time_val !< time value + character(len=*), optional,intent(in) :: time_units!< units for non-periodic time axis + ! local + character(len=40) :: x_axis_units='', y_axis_units='' + integer :: isg, ieg, jsg, jeg, IsgB, IegB, JsgB, JegB + real, pointer, dimension(:) :: gridLatT => NULL(), & ! The latitude or longitude of T or B points for + gridLatB => NULL(), & ! the purpose of labeling the output axes. + gridLonT => NULL(), & + gridLonB => NULL() + + ! initialize axis_data_CS elements + axis_data_CS%axis(axis_number)%name = '' + axis_data_CS%axis(axis_number)%longname = '' + axis_data_CS%axis(axis_number)%units = '' + axis_data_CS%axis(axis_number)%horgrid_position = 0 + axis_data_CS%axis(axis_number)%is_domain_decomposed = .false. + axis_data_CS%axis(axis_number)%positive = '' + axis_data_CS%data(axis_number)%p => NULL() + + ! set the ocean grid coordinates and metadata + if (present(G)) then + gridLatT => G%gridLatT ; gridLatB => G%gridLatB + gridLonT => G%gridLonT ; gridLonB => G%gridLonB + x_axis_units = G%x_axis_units ; y_axis_units = G%y_axis_units + isg = G%isg ; ieg = G%ieg ; jsg = G%jsg ; jeg = G%jeg + IsgB = G%IsgB ; IegB = G%IegB ; JsgB = G%JsgB ; JegB = G%JegB + elseif (present(dG)) then + gridLatT => dG%gridLatT ; gridLatB => dG%gridLatB + gridLonT => dG%gridLonT ; gridLonB => dG%gridLonB + x_axis_units = dG%x_axis_units ; y_axis_units = dG%y_axis_units + isg = dG%isg ; ieg = dG%ieg ; jsg = dG%jsg ; jeg = dG%jeg + IsgB = dG%IsgB ; IegB = dG%IegB ; JsgB = dG%JsgB ; JegB = dG%JegB + endif + + select case(trim(lowercase(axis_name))) + case('lath') + if (associated(gridLatT)) & + axis_data_CS%data(axis_number)%p=>gridLatT(jsg:jeg) + + axis_data_CS%axis(axis_number)%name = trim(axis_name) + axis_data_CS%axis(axis_number)%longname = 'Latitude' + axis_data_CS%axis(axis_number)%units = y_axis_units + axis_data_CS%axis(axis_number)%horgrid_position = CENTER + axis_data_CS%axis(axis_number)%is_domain_decomposed = .true. + case('lonh') + if (associated(gridLonT)) & + axis_data_CS%data(axis_number)%p=>gridLonT(isg:ieg) + + axis_data_CS%axis(axis_number)%name = trim(axis_name) + axis_data_CS%axis(axis_number)%horgrid_position = CENTER + axis_data_CS%axis(axis_number)%longname = 'Longitude' + axis_data_CS%axis(axis_number)%units = x_axis_units + axis_data_CS%axis(axis_number)%is_domain_decomposed = .true. + case('latq') + if (associated(gridLatB)) & + axis_data_CS%data(axis_number)%p=>gridLatB(JsgB:JegB) + + axis_data_CS%axis(axis_number)%name = trim(axis_name) + axis_data_CS%axis(axis_number)%longname = 'Latitude' + axis_data_CS%axis(axis_number)%units = y_axis_units + axis_data_CS%axis(axis_number)%horgrid_position = NORTH_FACE + axis_data_CS%axis(axis_number)%is_domain_decomposed = .true. + case('lonq') + if (associated(gridLonB)) & + axis_data_CS%data(axis_number)%p=>gridLonB(IsgB:IegB) + + axis_data_CS%axis(axis_number)%name = trim(axis_name) + axis_data_CS%axis(axis_number)%longname = 'Longitude' + axis_data_CS%axis(axis_number)%units = x_axis_units + axis_data_CS%axis(axis_number)%horgrid_position = EAST_FACE + axis_data_CS%axis(axis_number)%is_domain_decomposed = .true. + case('layer') + if (present(GV)) then + axis_data_CS%data(axis_number)%p=>GV%sLayer(1:GV%ke) + axis_data_CS%axis(axis_number)%name = trim(axis_name) + axis_data_CS%axis(axis_number)%longname = 'Layer pseudo-depth, -z*' + axis_data_CS%axis(axis_number)%units = GV%zAxisUnits + axis_data_CS%axis(axis_number)%positive = 'up' + endif + case('interface') + if (present(GV)) then + axis_data_CS%data(axis_number)%p=>GV%sInterface(1:GV%ke+1) + axis_data_CS%axis(axis_number)%name = trim(axis_name) + axis_data_CS%axis(axis_number)%longname = 'Interface pseudo-depth, -z*' + axis_data_CS%axis(axis_number)%units = GV%zAxisUnits + axis_data_CS%axis(axis_number)%positive = 'up' + endif + case('time') + if (.not.(present(time_val))) & + call MOM_error(FATAL, "MOM_io::get_diagnostic_axis_data: requires time_val"//& + " and time_units arguments for "//trim(axis_name)) + + axis_data_CS%data(axis_number)%p=>time_val + axis_data_CS%axis(axis_number)%name = trim(axis_name) + axis_data_CS%axis(axis_number)%longname = 'Time' + + if (present(time_units)) then + axis_data_CS%axis(axis_number)%units = time_units + else + axis_data_CS%axis(axis_number)%units = 'days' + endif + case('period') + if (.not.(present(time_val))) & + call MOM_error(FATAL, "MOM_axis::get_diagnostic_axis_data: requires a time_val argument "// & + "for "//trim(axis_name)) + axis_data_CS%data(axis_number)%p=>time_val + axis_data_CS%axis(axis_number)%name = trim(axis_name) + axis_data_CS%axis(axis_number)%longname = 'Periods for cyclical variables' + case default + call MOM_error(WARNING, "MOM_axis::get_diagnostic_axis_data:"//trim(axis_name)//" is an unrecognized axis") + end select + +end subroutine MOM_get_diagnostic_axis_data + + +!> set the logical variables that determine which diagnositic axes to use +subroutine get_horizontal_grid_logic(grid_string_id, use_lath, use_lonh, use_latq, use_lonq) + character(len=*), intent(in) :: grid_string_id !< horizontal grid string + logical, intent(out) :: use_lath !< if .true., y-axis is oriented in CENTER position + logical, intent(out) :: use_lonh !< if .true., x-axis is oriented in CENTER position + logical, intent(out) :: use_latq !< if .true., y-axis is oriented in NORTH_FACE position + logical, intent(out) :: use_lonq !< if .true., x-axis is oriented in EAST_FACE position + + use_lath = .false. + use_lonh = .false. + use_latq = .false. + use_lonq = .false. + select case (trim(grid_string_id)) + case ('h') ; use_lath = .true. ; use_lonh = .true. ! x=CENTER, y=CENTER + case ('q') ; use_latq = .true. ; use_lonq = .true. ! x=EAST_FACE, y=NORTH_FACE + case ('u') ; use_lath = .true. ; use_lonq = .true. ! x=EAST_FACE, y=CENTER + case ('v') ; use_latq = .true. ; use_lonh = .true. ! x=CENTER, y=NORTH_FACE + case ('T') ; use_lath = .true. ; use_lonh = .true. ! x=CENTER, y=CENTER + case ('Bu') ; use_latq = .true. ; use_lonq = .true. ! x=EAST_FACE, y=NORTH_FACE + case ('Cu') ; use_lath = .true. ; use_lonq = .true. ! x=EAST_FACE, y=CENTER + case ('Cv') ; use_latq = .true. ; use_lonh = .true. ! x=CENTER, y=NORTH_FACE + case ('1') ; ! x=0, y=0 + case default + call MOM_error(FATAL, "MOM_axis:get_var_dimension_features "//& + "Unrecognized hor_grid argument "//trim(grid_string_id)) + end select +end subroutine get_horizontal_grid_logic + +!> Define the time units for the input time value +function get_time_units(time_value) result(time_units_out) + real, intent(in) :: time_value !< numerical time value in seconds + !! i.e., before dividing by 86400. + ! local + character(len=10) :: time_units ! time units + character(len=10) :: time_units_out ! time units trimmed + time_units = '' + time_units_out = '' + if (time_value < 0.0) then + time_units = "days" ! The default value. + elseif (mod(time_value,86400.0)==0.0) then + time_units = "days" + elseif ((time_value >= 0.99) .and. (time_value < 1.01)) then + time_units = "seconds" + elseif ((time_value >= 3599.0) .and. (time_value < 3601.0)) then + time_units = "hours" + elseif ((time_value >= 86399.0) .and. (time_value < 86401.0)) then + time_units = "days" + elseif ((time_value >= 3.0e7) .and. (time_value < 3.2e7)) then + time_units = "years" + else + write(time_units,'(es8.2," s")') time_value + endif + time_units_out = trim(time_units) +end function get_time_units + +!> function to get the index of a time_value from a netCDF file +function get_time_index(filename, time_to_find) result (time_index) + character(len=*) :: filename ! name of the file to read in + real, intent(in) :: time_to_find ! time value to search for in file + ! local + type(fmsNetcdfFile_t) :: fileobj ! netCDF file object returned by open_file + real, allocatable, dimension(:) :: file_times ! array of time values read from file + integer :: dim_unlim_size, i, time_index + character(len=nf90_max_name) :: dim_unlim_name ! name of the unlimited dimension in the file + logical :: file_open_success + + time_index = 1 + dim_unlim_size = 0 + dim_unlim_name = "" + file_open_success = .false. + + if (.not. check_if_open(fileobj)) & + !call MOM_error(FATAL, "get_time_index_nodd: netcdf file object must be open.") + file_open_success=fms2_open_file(fileobj, trim(filename), "read", is_restart=.false.) + + call get_unlimited_dimension_name(fileobj, dim_unlim_name) + call get_dimension_size(fileObj, trim(dim_unlim_name), dim_unlim_size) + ! time index will be one more than the unlimited dimension size if the time_to_find is not in the file + if (dim_unlim_size .gt. 0) then + time_index = dim_unlim_size+1 + allocate(file_times(dim_unlim_size)) + call read_data(fileobj,trim(dim_unlim_name), file_times) + + do i=1,dim_unlim_size + if (ABS(file_times(i)-time_to_find) .gt. TINY(time_to_find)) then + continue + else + time_index = i + exit + endif + enddo + deallocate(file_times) + endif + if (check_if_open(fileobj)) call fms2_close_file(fileobj) +end function get_time_index + +!> register axes associated with a variable from a domain-decomposed netCDF file that are mapped to +!! a sub-domain (e.g., a supergrid). +!> \note The user must specify units for variables with longitude/x-axis and/or latitude/y-axis axes to obtain +!! the correct domain decomposition for the data buffer. +subroutine MOM_register_variable_axes_subdomain(fileObj, variableName, io_domain, xPosition, yPosition) + type(FmsNetcdfFile_t), intent(inout) :: fileObj !< netCDF file object returned by call to open_file + character(len=*), intent(in) :: variableName !< name of the variable + type(domain2d), intent(in) :: io_domain !< type that contains the mpp io domain + integer, intent(in), optional :: xPosition !< domain position of the x-axis + integer, intent(in), optional :: yPosition !< domain position of the y-axi + ! local + character(len=40) :: units ! units corresponding to a specific variable dimension + character(len=40), allocatable, dimension(:) :: dim_names ! variable dimension names + integer :: i, isg, ieg, isc, iec, jsg, jeg, jsc, jec, xlen, ylen + integer :: ndims ! number of dimensions + integer :: xPos, yPos, pos ! domain positions for x and y axes. Default is CENTER + integer, allocatable, dimension(:) :: dimSizes ! variable dimension sizes + + if (.not. check_if_open(fileObj)) call MOM_error(FATAL,"MOM_axis:register_variable_axes_subdomain: The fileObj "// & + " has not been opened. Call fms2_open_file(fileObj,...) "// & + "before passing the fileObj argument to this function.") + xPos=CENTER + yPos=CENTER + if (present(xPosition)) xPos=xPosition + if (present(yPosition)) yPos=yPosition + ! get variable dimension names and lengths + ndims = get_variable_num_dimensions(fileObj, trim(variableName)) + allocate(dimSizes(ndims)) + allocate(dim_names(ndims)) + call get_variable_size(fileObj, trim(variableName), dimSizes, broadcast=.true.) + call get_variable_dimension_names(fileObj, trim(variableName), dim_names) + ! determine the position to pass to the mpp domain calls + if (xPos .eq. EAST_FACE) then + if (yPos .eq. NORTH_FACE) then + pos = CORNER + else + pos = EAST_FACE + endif + elseif (yPos .eq. NORTH_FACE) then + pos = NORTH_FACE + endif + ! Get the lengths of the global indicies + call mpp_get_compute_domain(io_domain, xsize=xlen, ysize=ylen, position=pos) + ! register the axes + !>\note: This is not a comprehensive check for all possible supported horizontal axes associated with variables + !! read from netCDF files. Developers should add/remove cases as needed. + do i=1,ndims + !if (.not.(is_dimension_registered(fileObj, trim(dim_names(i))))) then + select case(trim(lowercase(dim_names(i)))) + case ("grid_x_t") + call register_axis(fileObj, trim(dim_names(i)), xlen) + case ("nx") + call register_axis(fileObj, trim(dim_names(i)), xlen) + case("nxp") + call register_axis(fileObj, trim(dim_names(i)), xlen) + case("longitude") + call register_axis(fileObj, trim(dim_names(i)), xlen) + case("long") + call register_axis(fileObj, trim(dim_names(i)), xlen) + case("lon") + call register_axis(fileObj, trim(dim_names(i)), xlen) + case("lonh") + call register_axis(fileObj, trim(dim_names(i)), xlen) + case("lonq") + call register_axis(fileObj, trim(dim_names(i)), xlen) + case("xh") + call register_axis(fileObj, trim(dim_names(i)), xlen) + case ("grid_y_t") + call register_axis(fileObj, trim(dim_names(i)), ylen) + case ("ny") + call register_axis(fileObj, trim(dim_names(i)), ylen) + case("nyp") + call register_axis(fileObj, trim(dim_names(i)), ylen) + case("latitude") + call register_axis(fileObj, trim(dim_names(i)), ylen) + case("lat") + call register_axis(fileObj, trim(dim_names(i)), ylen) + case("lath") + call register_axis(fileObj, trim(dim_names(i)), ylen) + case("latq") + call register_axis(fileObj, trim(dim_names(i)), ylen) + case("yh") + call register_axis(fileObj, trim(dim_names(i)), ylen) + case default ! assumes that the axis is not domain-decomposed + if (.not. is_dimension_unlimited(fileObj, trim(dim_names(i)))) & + call MOM_error(WARNING,"MOM_register_variable_axes_subdomain: the axis "//trim(dim_names(i))//& + "is not included in the valid x and y dimension cases. If the code hangs, check the whether "//& + "an x or y axis is being registered as a non-domain-decomposed variable, "//& + "and add it to the accepted cases if necessary.") + call register_axis(fileObj, trim(dim_names(i)), dimSizes(i)) + end select + ! endif + enddo + + if (allocated(dimSizes)) deallocate(dimSizes) + if (allocated(dim_names)) deallocate(dim_names) +end subroutine MOM_register_variable_axes_subdomain + +!> register axes associated with a variable from a domain-decomposed netCDF file +!> @note The user must specify units for variables with longitude/x-axis and/or latitude/y-axis axes +!! to obtain the correct domain decomposition for the data buffer. +subroutine MOM_register_variable_axes_full(fileObj, variableName, xPosition, yPosition) + type(FmsNetcdfDomainFile_t), intent(inout) :: fileObj !< netCDF file object returned by call to open_file + character(len=*), intent(in) :: variableName !< name of the variable + integer, intent(in), optional :: xPosition !< domain position of the x-axis + integer, intent(in), optional :: yPosition !< domain position of the y-axis + ! local + character(len=40) :: units ! units corresponding to a specific variable dimension + character(len=40), allocatable, dimension(:) :: dim_names ! variable dimension names + integer :: i + integer :: ndims ! number of dimensions + integer :: xPos, yPos ! domain positions for x and y axes. Default is CENTER + integer, allocatable, dimension(:) :: dimSizes ! variable dimension sizes + + if (.not. check_if_open(fileObj)) call MOM_error(FATAL,"MOM_axis:register_variable_axes: The fileObj has "// & + "not been opened. Call fms2_open_file(fileObj,...) before "// & + "passing the fileObj argument to this function.") + xPos=CENTER + yPos=CENTER + if (present(xPosition)) xPos=xPosition + if (present(yPosition)) yPos=yPosition + ! get variable dimension names and lengths + ndims = get_variable_num_dimensions(fileObj, trim(variableName)) + allocate(dimSizes(ndims)) + allocate(dim_names(ndims)) + call get_variable_size(fileObj, trim(variableName), dimSizes) + call get_variable_dimension_names(fileObj, trim(variableName), dim_names) + ! register the axes + !>@note: This is not a comprehensive check for all possible supported horizontal axes associated with variables + !! read from netCDF files. Developers should add/remove cases as needed. + do i=1,ndims + if (.not.(is_dimension_registered(fileobj, trim(dim_names(i))))) then + select case(trim(lowercase(dim_names(i)))) + case ("grid_x_t") + call register_axis(fileObj, trim(dim_names(i)),"x", domain_position=xPos) + case ("nx") + call register_axis(fileObj, trim(dim_names(i)),"x", domain_position=xPos) + case("nxp") + call register_axis(fileObj, trim(dim_names(i)),"x", domain_position=xPos) + case("longitude") + call register_axis(fileObj, trim(dim_names(i)),"x", domain_position=xPos) + case("long") + call register_axis(fileObj, trim(dim_names(i)),"x", domain_position=xPos) + case("lon") + call register_axis(fileObj, trim(dim_names(i)),"x", domain_position=xPos) + case("lonh") + call register_axis(fileObj, trim(dim_names(i)),"x", domain_position=xPos) + case("lonq") + call register_axis(fileObj, trim(dim_names(i)),"x", domain_position=xPos) + case("xh") + call register_axis(fileObj, trim(dim_names(i)),"x", domain_position=xPos) + case("i") + call register_axis(fileObj, trim(dim_names(i)),"x", domain_position=xPos) + case ("grid_y_t") + call register_axis(fileObj, trim(dim_names(i)),"y", domain_position=yPos) + case ("ny") + call register_axis(fileObj, trim(dim_names(i)),"y", domain_position=yPos) + case("nyp") + call register_axis(fileObj, trim(dim_names(i)),"y", domain_position=yPos) + case("latitude") + call register_axis(fileObj, trim(dim_names(i)),"y", domain_position=yPos) + case("lat") + call register_axis(fileObj, trim(dim_names(i)),"y", domain_position=yPos) + case("lath") + call register_axis(fileObj, trim(dim_names(i)),"y", domain_position=yPos) + case("latq") + call register_axis(fileObj, trim(dim_names(i)),"y", domain_position=yPos) + case("yh") + call register_axis(fileObj, trim(dim_names(i)),"y", domain_position=yPos) + case("j") + call register_axis(fileObj, trim(dim_names(i)),"y", domain_position=yPos) + case default ! assumes that the axis is not domain-decomposed + if (.not. is_dimension_unlimited(fileObj, trim(dim_names(i)))) & + call MOM_error(WARNING,"MOM_register_variable_axes_full: the axis "//trim(dim_names(i))//" is not "//& + "included in the valid x and y dimension cases. If the code hangs, check the whether "//& + "an x or y axis is being registered as a non-domain-decomposed variable, "//& + "and add it to the accepted cases if necessary.") + call register_axis(fileObj, trim(dim_names(i)), dimSizes(i)) + end select + endif + enddo + + deallocate(dimSizes) + deallocate(dim_names) +end subroutine MOM_register_variable_axes_full + + +!> convert the variable checksum integer(s) to a single string +!! If there is more than 1 checksum, commas are inserted between +!! each checksum value in the output string +function convert_checksum_to_string(checksum_int) result (checksum_string) + integer(kind=8), intent(in) :: checksum_int !< checksum integer values +! local + character(len=64) :: checksum_string + integer :: i + + checksum_string = '' + + write (checksum_string,'(Z16)') checksum_int ! Z16 is the hexadecimal format code + +end function convert_checksum_to_string + + +end module MOM_axis diff --git a/src/framework/MOM_io.F90 b/src/framework/MOM_io.F90 index c516c96e86..6768e47dfa 100644 --- a/src/framework/MOM_io.F90 +++ b/src/framework/MOM_io.F90 @@ -4,13 +4,17 @@ module MOM_io ! This file is part of MOM6. See LICENSE.md for the license. +use MOM_axis, only : MOM_get_diagnostic_axis_data, MOM_register_diagnostic_axis +use MOM_axis, only : axis_data_type, get_time_index, get_var_dimension_metadata +use MOM_axis, only : get_time_units, convert_checksum_to_string use MOM_error_handler, only : MOM_error, NOTE, FATAL, WARNING use MOM_domains, only : MOM_domain_type, AGRID, BGRID_NE, CGRID_NE use MOM_domains, only : get_simple_array_i_ind, get_simple_array_j_ind use MOM_file_parser, only : log_version, param_file_type use MOM_grid, only : ocean_grid_type use MOM_dyn_horgrid, only : dyn_horgrid_type -use MOM_string_functions, only : lowercase, slasher +use MOM_string_functions, only : lowercase, slasher, append_substring +use MOM_time_manager, only : time_type, time_type_to_real use MOM_verticalGrid, only : verticalGrid_type use ensemble_manager_mod, only : get_ensemble_id @@ -18,8 +22,12 @@ module MOM_io use fms_io_mod, only : file_exist, field_size, read_data use fms_io_mod, only : field_exists => field_exist, io_infra_end=>fms_io_exit use fms_io_mod, only : get_filename_appendix => get_filename_appendix +use mpp_mod, only : mpp_pe, mpp_max, mpp_npes use mpp_domains_mod, only : domain1d, domain2d, mpp_get_domain_components use mpp_domains_mod, only : CENTER, CORNER, NORTH_FACE=>NORTH, EAST_FACE=>EAST +use mpp_domains_mod, only : mpp_get_data_domain, mpp_get_compute_domain, mpp_get_global_domain +use mpp_domains_mod, only : mpp_get_domain_npes, mpp_define_io_domain, mpp_get_io_domain +use mpp_domains_mod, only : mpp_get_io_domain_layout use mpp_io_mod, only : open_file => mpp_open, close_file => mpp_close use mpp_io_mod, only : mpp_write_meta, write_field => mpp_write, mpp_get_info use mpp_io_mod, only : mpp_get_atts, mpp_get_axes, get_axis_data=>mpp_get_axis_data, axistype @@ -33,6 +41,28 @@ module MOM_io use mpp_io_mod, only : get_file_fields=>mpp_get_fields, get_file_times=>mpp_get_times use mpp_io_mod, only : io_infra_init=>mpp_io_init +! fms2_io +use fms2_io_mod, only : check_if_open, get_dimension_names,get_dimension_size +use fms2_io_mod, only : get_compute_domain_dimension_indices, get_global_attribute +use fms2_io_mod, only : get_global_io_domain_indices, get_num_dimensions, get_num_variables +use fms2_io_mod, only : get_unlimited_dimension_name, get_variable_dimension_names, get_variable_names +use fms2_io_mod, only : get_variable_num_dimensions, get_variable_size, get_variable_units +use fms2_io_mod, only : get_variable_unlimited_dimension_index, global_att_exists, is_dimension_unlimited +use fms2_io_mod, only : is_dimension_registered, register_restart_field, register_axis +use fms2_io_mod, only : register_field, register_variable_attribute, fms2_open_file => open_file +use fms2_io_mod, only : fms2_close_file => close_file, write_data, attribute_exists => variable_att_exists +use fms2_io_mod, only : dimension_exists, variable_exists, fms2_io_file_exists => file_exists +use fms2_io_mod, only : FmsNetcdfDomainFile_t, FmsNetcdfFile_t, unlimited + +!use, intrinsic :: iso_fortran_env + +!NOTE: uncomment when ready to replace mpp_read calls +!use MOM_read_data_fms2, only : MOM_read_data_4d_DD, MOM_read_data_3d_DD, MOM_read_data_2d_DD +!use MOM_read_data_fms2, only : MOM_read_data_1d_DD, MOM_read_data_scalar +!use MOM_read_data_fms2, only : MOM_read_data_4d_noDD, MOM_read_data_3d_noDD, MOM_read_data_2d_noDD +!use MOM_read_data_fms2, only : MOM_read_data_1d_noDD, MOM_read_vector_2d_fms2, MOM_read_vector_3d_fms2 + +! use MOM_write_field_fms2, only : write_field !NOTE: uncomment when ready to replace mpp_write calls use netcdf implicit none ; private @@ -66,22 +96,30 @@ module MOM_io !> Indicate whether a file exists, perhaps with domain decomposition interface file_exists + module procedure FMS2_file_exists module procedure FMS_file_exists module procedure MOM_file_exists end interface -!> Read a data field from a file +!> Read a pair of data fields representing the two components of a vector from a file +interface MOM_read_vector + module procedure MOM_read_vector_3d + module procedure MOM_read_vector_2d +end interface + +!> interface to read data from a netcdf file interface MOM_read_data module procedure MOM_read_data_4d module procedure MOM_read_data_3d module procedure MOM_read_data_2d module procedure MOM_read_data_1d -end interface +end interface MOM_read_data -!> Read a pair of data fields representing the two components of a vector from a file -interface MOM_read_vector - module procedure MOM_read_vector_3d - module procedure MOM_read_vector_2d +!> Open a netcdf file in write or overwrite mode using the fms-io or fms2-io netcdf interfaces +interface create_file + module procedure create_file_old + module procedure create_file_fms2_filename + module procedure create_file_fms2_fileobj end interface contains @@ -89,7 +127,7 @@ module MOM_io !> Routine creates a new NetCDF file. It also sets up !! structures that describe this file and variables that will !! later be written to this file. Type for describing a variable, typically a tracer -subroutine create_file(unit, filename, vars, novars, fields, threading, timeunit, G, dG, GV, checksums) +subroutine create_file_old(unit, filename, vars, novars, fields, threading, timeunit, G, dG, GV, checksums) integer, intent(out) :: unit !< unit id of an open file or -1 on a !! nonwriting PE with single file output character(len=*), intent(in) :: filename !< full path to the file to create @@ -342,7 +380,463 @@ subroutine create_file(unit, filename, vars, novars, fields, threading, timeunit if (use_int) call write_field(unit, axis_int) if (use_periodic) call write_field(unit, axis_periodic) -end subroutine create_file +end subroutine create_file_old + + +!> This routine opens a netcdf file in "write" or "overwrite" mode, registers the global diagnostic axes, and writes +!! the axis data and metadata to the file +subroutine create_file_fms2_filename(filename, vars, numVariables, use_fms2, register_time, G, DG, GV, checksums, & + is_restart) + character(len=*), intent(in) :: filename !< full path to the netcdf file + type(vardesc), dimension(:), intent(in) :: vars !< structures describing the output + integer, intent(in) :: numVariables !< number of variables to write to the file + logical, intent(in) :: use_fms2 !< flag indicating whether to use this routine + logical, optional, intent(in) :: register_time !< if .true., register a time dimension to the file + type(ocean_grid_type), optional, intent(in) :: G !< ocean horizontal grid structure; G or dG + !! is required if the new file uses any + !! horizontal grid axes. + type(dyn_horgrid_type), optional, intent(in) :: dG !< dynamic horizontal grid structure; G or dG + !! is required if the new file uses any + !! horizontal grid axes. + type(verticalGrid_type), optional, intent(in) :: GV !< ocean vertical grid structure, which is + !! required if the new file uses any + !! vertical grid axes. + integer(kind=8), dimension(:,:), optional, intent(in) :: checksums(:,:) !< checksums of the variables + logical, optional, intent(in) :: is_restart !< indicates whether file is a restart file + + ! local + type(FmsNetcdfFile_t) :: fileObjNoDD ! non-domain-decomposed netcdf file object returned by open_file + type(FmsNetcdfDomainFile_t) :: fileObjDD ! domain-decomposed netcdf file object returned by open_file + type(axis_data_type) :: axis_data_CS ! structure for coordinate variable metadata + type(MOM_domain_type), pointer :: Domain => NULL() + logical :: file_open_successDD, file_open_successNoDD ! true if netcdf file is opened + logical :: one_file, domain_set ! indicates whether the file will be domain-decomposed or not + logical :: reg_time ! register the time if .true. + logical :: is_restart_file + character(len=10) :: nc_mode + character(len=64) :: checksum_char ! checksum character array created from checksum argument + character(len=1024) :: filename_temp + character(len=48), allocatable, dimension(:,:) :: dim_names ! variable dimension names + integer :: i, is, ie, j, substring_index, total_axes + integer :: num_dims ! number of dimensions + integer :: thread ! indicates whether threading is used + integer, dimension(4) :: dim_lengths ! variable dimension lengths + integer, allocatable :: pelist(:) ! list of pes associated with the file + real :: time + + ! determine whether the file will be domain-decomposed or not + domain_set=.false. + if (present(G)) then + domain_set = .true. ; Domain => G%Domain + elseif (present(dG)) then + domain_set = .true. ; Domain => dG%Domain + endif + + is_restart_file = .false. + if (present(is_restart)) is_restart_file = is_restart + ! append '.nc' to the file name if it is missing + filename_temp = "" + substring_index = 0 + substring_index = index(trim(filename), ".nc") + if (substring_index < 1) then + filename_temp = append_substring(filename,".nc") + else + filename_temp = filename + endif + + nc_mode = "" + if (file_exists(trim(filename_temp), .true.)) then + nc_mode = "overwrite" + else + nc_mode = "write" + endif + + reg_time = .false. + if (present(register_time)) reg_time = register_time + + ! open the file + file_open_successNoDD=.false. + file_open_successDD=.false. + + if (domain_set) then + ! define the io domain if on one pe and the io domain is not set + if (mpp_get_domain_npes(domain%mpp_domain) .eq. 1 ) then + if (.not. associated(mpp_get_io_domain(domain%mpp_domain))) & + call mpp_define_io_domain(domain%mpp_domain, (/1,1/)) + endif + + if (.not. check_if_open(fileObjDD)) & + file_open_successDD=fms2_open_file(fileObjDD, filename_temp, trim(nc_mode), Domain%mpp_domain, & + is_restart=is_restart_file) + else + ! get the pes associated with the file. + !>\note this is required so that only pe(1) is identified as the root pe to create the file + !! Otherwise, multiple pes may try to open the file in write (NC_NOCLOBBER) mode, leading to failure + allocate(pelist(mpp_npes())) + pelist(:) = 0 + do i=1,size(pelist) + pelist(i) = i-1 + enddo + + if (.not. check_if_open(fileObjNoDD)) & + file_open_successNoDD=fms2_open_file(fileObjNoDD, filename_temp, trim(nc_mode), & + is_restart=is_restart_file, pelist=pelist) + endif + ! allocate the output data variable dimension attributes + allocate(dim_names(numVariables,4)) + dim_names(:,:) = "" + ! allocate the axis data and attribute types for the file + !> \note The user should increase the sizes of the axis and data attributes to accommodate more axes if necessary. + allocate(axis_data_CS%axis(7)) + allocate(axis_data_CS%data(7)) + ! axis registration procedure for the domain-decomposed case + if (file_open_successDD) then + do i=1,numVariables + num_dims=0 + dim_lengths(:) = 0 + + !> \note The time dimension is registered separately at the end of the procedure if reg_time = .true. + !! so the t_grid argument in get_var_dimension_metadata is set to '1' (do nothing) + if (present(G)) then + call get_var_dimension_metadata(vars(i)%hor_grid, vars(i)%z_grid, '1', dim_names(i,:), & + dim_lengths, num_dims, G=G) + elseif(present(dG)) then + call get_var_dimension_metadata(vars(i)%hor_grid, vars(i)%z_grid, '1', dim_names(i,:), & + dim_lengths, num_dims, dG=dG) + endif + + if(present(GV)) & + call get_var_dimension_metadata(vars(i)%hor_grid, vars(i)%z_grid, '1', dim_names(i,:), & + dim_lengths, num_dims, GV=GV) + !> \note num_dims will be 0 for scalar values + if (num_dims .le. 0) cycle + + do j=1,num_dims + ! register the variable axes to the file if they are not already registered + if (dim_lengths(j) .gt. 0) then + if (.not.(dimension_exists(fileObjDD, dim_names(i,j)))) then + + if (present(G)) then + if (present(GV)) then + call MOM_get_diagnostic_axis_data(axis_data_CS, dim_names(i,j), j, G=G, GV=GV) + else + call MOM_get_diagnostic_axis_data(axis_data_CS, dim_names(i,j), j, G=G) + endif + elseif (present(dG)) then + if (present(GV)) then + call MOM_get_diagnostic_axis_data(axis_data_CS, dim_names(i,j), j, dG=dG, GV=GV) + else + call MOM_get_diagnostic_axis_data(axis_data_CS, dim_names(i,j), j, dG=dG) + endif + elseif (present(GV)) then + call MOM_get_diagnostic_axis_data(axis_data_CS, dim_names(i,j), j, GV=GV) + endif + call MOM_register_diagnostic_axis(fileObjDD, trim(dim_names(i,j)), dim_lengths(j)) + endif + ! register the axis attributes and write the axis data to the file + if (.not.(variable_exists(fileObjDD, trim(axis_data_CS%axis(j)%name)))) then + if (associated(axis_data_CS%data(j)%p)) then + + call register_field(fileObjDD, trim(axis_data_CS%axis(j)%name), & + "double", dimensions=(/trim(axis_data_CS%axis(j)%name)/)) + + call register_variable_attribute(fileObjDD, trim(axis_data_CS%axis(j)%name), & + 'long_name', axis_data_CS%axis(j)%longname) + + call register_variable_attribute(fileObjDD, trim(axis_data_CS%axis(j)%name), & + 'units', trim(axis_data_CS%axis(j)%units)) + + if (len_trim(axis_data_CS%axis(j)%positive)>1) & + call register_variable_attribute(fileObjDD, trim(axis_data_CS%axis(j)%name), & + 'positive', trim(axis_data_CS%axis(j)%positive)) + + if (axis_data_CS%axis(j)%is_domain_decomposed) then + call get_global_io_domain_indices(fileObjDD, trim(axis_data_CS%axis(j)%name), is, ie) + call write_data(fileObjDD, trim(axis_data_CS%axis(j)%name), axis_data_CS%data(j)%p(is:ie)) + else + call write_data(fileObjDD, trim(axis_data_CS%axis(j)%name), axis_data_CS%data(j)%p) + endif + endif + endif + endif + enddo + enddo + + if (reg_time) then + if (.not.(dimension_exists(fileObjDD,"Time"))) & + call register_axis(fileObjDD, "Time", unlimited) + endif + + if (check_if_open(fileObjDD)) call fms2_close_file(fileObjDD) + ! axis registration and write procedure for the non-domain-decomposed case + elseif (file_open_successNoDD) then + do i=1,numVariables + num_dims=0 + dim_lengths(:) = 0 + + !> \note The time dimension is registered separately at the end of the procedure if reg_time = .true. + !! so the t_grid argument in get_var_dimension_metadata is set to '1' (do nothing) + if (present(G)) then + call get_var_dimension_metadata(vars(i)%hor_grid, vars(i)%z_grid, '1', dim_names(i,:), & + dim_lengths, num_dims, G=G) + elseif(present(dG)) then + call get_var_dimension_metadata(vars(i)%hor_grid, vars(i)%z_grid, '1', dim_names(i,:), & + dim_lengths, num_dims, dG=dG) + endif + + if(present(GV)) & + call get_var_dimension_metadata(vars(i)%hor_grid, vars(i)%z_grid, '1', dim_names(i,:), & + dim_lengths, num_dims, GV=GV) + !> \note num_dims will be 0 for scalar variables + if (num_dims .le. 0) cycle + + do j=1,num_dims + ! register the variable axes to the file if they are not already registered + if (dim_lengths(j) .gt. 0) then + if (.not.(dimension_exists(fileObjNoDD, dim_names(i,j)))) then + if (present(G)) then + if (present(GV)) then + call MOM_get_diagnostic_axis_data(axis_data_CS, dim_names(i,j), j, G=G, GV=GV) + else + call MOM_get_diagnostic_axis_data(axis_data_CS, dim_names(i,j), j, G=G) + endif + elseif (present(dG)) then + if (present(GV)) then + call MOM_get_diagnostic_axis_data(axis_data_CS, dim_names(i,j), j, dG=dG, GV=GV) + else + call MOM_get_diagnostic_axis_data(axis_data_CS, dim_names(i,j), j, dG=dG) + endif + elseif (present(GV)) then + call MOM_get_diagnostic_axis_data(axis_data_CS, dim_names(i,j), j, GV=GV) + endif + call register_axis(fileObjNoDD, trim(dim_names(i,j)), dim_lengths(j)) + endif + ! register the axis attributes and write the axis data to the file + if (.not.(variable_exists(fileObjNoDD, trim(axis_data_CS%axis(j)%name)))) then + if (associated(axis_data_CS%data(j)%p)) then + call register_field(fileObjNoDD, trim(axis_data_CS%axis(j)%name), & + "double", dimensions=(/trim(axis_data_CS%axis(j)%name)/)) + + call register_variable_attribute(fileObjNoDD, trim(axis_data_CS%axis(j)%name), & + 'long_name', axis_data_CS%axis(j)%longname) + + call register_variable_attribute(fileObjNoDD, trim(axis_data_CS%axis(j)%name), & + 'units', trim(axis_data_CS%axis(j)%units)) + + if (len_trim(axis_data_CS%axis(j)%positive)>1) & + call register_variable_attribute(fileObjNoDD, trim(axis_data_CS%axis(j)%name), & + 'positive', trim(axis_data_CS%axis(j)%positive)) + + if (lowercase(trim(axis_data_CS%axis(j)%name)) .ne. 'time') then + call write_data(fileObjNoDD, trim(axis_data_CS%axis(j)%name), axis_data_CS%data(j)%p) + endif + endif + endif + endif + enddo + enddo + + if (reg_time) then + if (.not.(dimension_exists(fileObjNoDD,"Time"))) & + call register_axis(fileObjNoDD, "Time" , unlimited) + endif + + if (check_if_open(fileObjNoDD)) call fms2_close_file(fileObjNoDD) + endif + + deallocate(dim_names) + deallocate(axis_data_CS%axis) + deallocate(axis_data_CS%data) + if (allocated(pelist)) deallocate(pelist) + nullify(Domain) + +end subroutine create_file_fms2_filename + +!> This routine opens a netcdf file in "write" or "overwrite" mode, registers the global diagnostic axes, and writes +!! the axis data and metadata to the file. It returns the netcdf file object for additional writing. +subroutine create_file_fms2_fileobj(filename, fileObjDD, vars, numVariables, register_time, G, DG, GV, & + checksums, is_restart) + character(len=*), intent(in) :: filename !< full path to the netcdf file + type(FmsNetcdfDomainFile_t), intent(inout) :: fileObjDD !< domain-decomposed netcdf file object + !! returned by open_file + type(vardesc), dimension(:), intent(in) :: vars !< structures describing the output + integer, intent(in) :: numVariables !< number of variables to write to the file + logical, optional, intent(in) :: register_time !< if .true., register a time dimension to the file + type(ocean_grid_type), optional, intent(in) :: G !< ocean horizontal grid structure; G or dG + !! is required if the new file uses any + !! horizontal grid axes. + type(dyn_horgrid_type), optional, intent(in) :: dG !< dynamic horizontal grid structure; G or dG + !! is required if the new file uses any + !! horizontal grid axes. + type(verticalGrid_type), optional, intent(in) :: GV !< ocean vertical grid structure, which is + !! required if the new file uses any + !! vertical grid axes. + integer(kind=8), dimension(:,:), optional, intent(in) :: checksums(:,:) !< checksums of the variables + logical, optional, intent(in) :: is_restart !< indicates whether file is a restart file + + ! local + type(axis_data_type) :: axis_data_CS ! structure for coordinate variable metadata + type(MOM_domain_type), pointer :: Domain => NULL() + logical :: file_open_successDD ! true if netcdf file is opened + logical :: one_file, domain_set ! indicates whether the file will be domain-decomposed or not + logical :: reg_time ! register the time if .true. + logical :: is_restart_file ! .true. if the file is a restart file + character(len=10) :: nc_mode + character(len=64) :: checksum_char ! checksum character array created from checksum argument + character(len=1024) :: filename_temp + character(len=48), allocatable, dimension(:,:) :: dim_names ! variable dimension names + integer :: i, is, ie, j, substring_index, total_axes + integer :: num_dims ! number of dimensions + integer :: thread ! indicates whether threading is used + integer, dimension(4) :: dim_lengths ! variable dimension lengths + integer, allocatable :: pelist(:) ! list of pes associated with the file + real :: time + + ! determine whether the file will be domain-decomposed or not + domain_set=.false. + if (present(G)) then + domain_set = .true. ; Domain => G%Domain + elseif (present(dG)) then + domain_set = .true. ; Domain => dG%Domain + endif + + is_restart_file = .false. + if (present(is_restart)) is_restart_file = is_restart + ! append '.nc' to the file name if it is missing + filename_temp = "" + substring_index = 0 + substring_index = index(trim(filename), ".nc") + if (substring_index < 1) then + filename_temp = append_substring(filename,".nc") + else + filename_temp = filename + endif + + nc_mode = "" + if (file_exists(trim(filename_temp), .true.)) then + nc_mode = "overwrite" + else + nc_mode = "write" + endif + + reg_time = .false. + if (present(register_time)) reg_time = register_time + ! open the file + file_open_successDD=.false. + ! define the io domain if on one pe and the io domain is not set + if (domain_set) then + if (mpp_get_domain_npes(domain%mpp_domain) .eq. 1 ) then + if (.not. associated(mpp_get_io_domain(domain%mpp_domain))) & + call mpp_define_io_domain(domain%mpp_domain, (/1,1/)) + endif + else + ! get the pes associated with the file. + !>\note this is required so that only pe(1) is identified as the root pe to create the file + !! Otherwise, multiple pes may try to open the file in write (NC_NOCLOBBER) mode, leading to failure + allocate(pelist(mpp_npes())) + pelist(:) = 0 + do i=1,size(pelist) + pelist(i) = i-1 + enddo + endif + if (.not. check_if_open(fileObjDD)) & + !write(output_unit, '(A)'), "Create_file: Opening file ", trim(filename_temp) + file_open_successDD=fms2_open_file(fileObjDD, filename_temp, trim(nc_mode), Domain%mpp_domain, & + is_restart=is_restart_file) + ! allocate the output data variable dimension attributes + allocate(dim_names(numVariables,4)) + dim_names(:,:) = "" + ! allocate the axis data and attribute types for the file + !> \note The user should increase the sizes of the axis and data attributes to accommodate more axes if necessary. + allocate(axis_data_CS%axis(7)) + allocate(axis_data_CS%data(7)) + ! axis registration procedure for the domain-decomposed case + if (file_open_successDD) then + do i=1,numVariables + num_dims=0 + dim_lengths(:) = 0 + !> \note The time dimension is registered separately at the end of the procedure if reg_time = .true. + !! so the t_grid argument in get_var_dimension_metadata is set to '1' (do nothing) + if (present(G)) then + call get_var_dimension_metadata(vars(i)%hor_grid, vars(i)%z_grid, '1', dim_names(i,:), & + dim_lengths, num_dims, G=G) + elseif(present(dG)) then + call get_var_dimension_metadata(vars(i)%hor_grid, vars(i)%z_grid, '1', dim_names(i,:), & + dim_lengths, num_dims, dG=dG) + endif + + if(present(GV)) & + call get_var_dimension_metadata(vars(i)%hor_grid, vars(i)%z_grid, '1', dim_names(i,:), & + dim_lengths, num_dims, GV=GV) + !> \note num_dims will be 0 for scalar values + if (num_dims .le. 0) cycle + + do j=1,num_dims + ! register the variable axes to the file if they are not already registered + if (dim_lengths(j) .gt. 0) then + if (.not.(dimension_exists(fileObjDD, dim_names(i,j)))) then + + if (present(G)) then + if (present(GV)) then + call MOM_get_diagnostic_axis_data(axis_data_CS, dim_names(i,j), j, G=G, GV=GV) + else + call MOM_get_diagnostic_axis_data(axis_data_CS, dim_names(i,j), j, G=G) + endif + elseif (present(dG)) then + if (present(GV)) then + call MOM_get_diagnostic_axis_data(axis_data_CS, dim_names(i,j), j, dG=dG, GV=GV) + else + call MOM_get_diagnostic_axis_data(axis_data_CS, dim_names(i,j), j, dG=dG) + endif + elseif (present(GV)) then + call MOM_get_diagnostic_axis_data(axis_data_CS, dim_names(i,j), j, GV=GV) + endif + call MOM_register_diagnostic_axis(fileObjDD, trim(dim_names(i,j)), dim_lengths(j)) + endif + ! register the axis attributes and write the axis data to the file + if (.not.(variable_exists(fileObjDD, trim(axis_data_CS%axis(j)%name)))) then + if (associated(axis_data_CS%data(j)%p)) then + + call register_field(fileObjDD, trim(axis_data_CS%axis(j)%name), & + "double", dimensions=(/trim(axis_data_CS%axis(j)%name)/)) + + call register_variable_attribute(fileObjDD, trim(axis_data_CS%axis(j)%name), & + 'long_name', axis_data_CS%axis(j)%longname) + + call register_variable_attribute(fileObjDD, trim(axis_data_CS%axis(j)%name), & + 'units', trim(axis_data_CS%axis(j)%units)) + + if (len_trim(axis_data_CS%axis(j)%positive)>1) & + call register_variable_attribute(fileObjDD, trim(axis_data_CS%axis(j)%name), & + 'positive', trim(axis_data_CS%axis(j)%positive)) + + if (axis_data_CS%axis(j)%is_domain_decomposed) then + call get_global_io_domain_indices(fileObjDD, trim(axis_data_CS%axis(j)%name), is, ie) + call write_data(fileObjDD, trim(axis_data_CS%axis(j)%name), axis_data_CS%data(j)%p(is:ie)) + else + call write_data(fileObjDD, trim(axis_data_CS%axis(j)%name), axis_data_CS%data(j)%p) + endif + endif + endif + endif + enddo + enddo + + if (reg_time) then + if (.not.(dimension_exists(fileObjDD,"Time"))) & + call register_axis(fileObjDD, "Time", unlimited) + endif + else + call MOM_error(FATAL, "MOM_io::create_file_fms2_filobj: unable to open file "//trim(filename)) + endif + + deallocate(dim_names) + deallocate(axis_data_CS%axis) + deallocate(axis_data_CS%data) + if (allocated(pelist)) deallocate(pelist) + nullify(Domain) + +end subroutine create_file_fms2_fileobj !> This routine opens an existing NetCDF file for output. If it @@ -844,6 +1338,19 @@ function FMS_file_exists(filename, domain, no_domain) end function FMS_file_exists +!> Returns true if the named file exists +function FMS2_file_exists(filename, use_fms2) + character(len=*), intent(in) :: filename !< The name of the file being inquired about + logical, intent(in) :: use_fms2 !< flag indicating to use the fms2-io interface +! This function uses the fms2_io function file_exists to determine whether +! a named file (or its decomposed variant) exists. + + logical :: FMS2_file_exists + + FMS2_file_exists = fms2_io_file_exists(filename) + +end function FMS2_file_exists + !> This function uses the fms_io function read_data to read 1-D !! data field named "fieldname" from file "filename". subroutine MOM_read_data_1d(filename, fieldname, data, timelevel, scale) diff --git a/src/framework/MOM_read_data_fms2.F90 b/src/framework/MOM_read_data_fms2.F90 new file mode 100644 index 0000000000..d15d5a3085 --- /dev/null +++ b/src/framework/MOM_read_data_fms2.F90 @@ -0,0 +1,1540 @@ +!> This module contains routines that wrap the fms2 read_data calls +module MOM_read_data_fms2 + +! This file is part of MOM6. See LICENSE.md for the license. +use MOM_axis, only : MOM_register_variable_axes +use MOM_error_handler, only : MOM_error, NOTE, FATAL, WARNING +use MOM_domains, only : MOM_domain_type, AGRID, BGRID_NE, CGRID_NE +use MOM_domains, only : get_simple_array_i_ind, get_simple_array_j_ind +use MOM_grid, only : ocean_grid_type +use MOM_dyn_horgrid, only : dyn_horgrid_type +use MOM_string_functions, only : lowercase +use MOM_verticalGrid, only : verticalGrid_type +use fms2_io_mod, only : read_data, attribute_exists => variable_att_exists, variable_exists +use fms2_io_mod, only : register_field, register_variable_attribute, fms2_open_file => open_file +use fms2_io_mod, only : fms2_close_file => close_file, write_data, get_variable_dimension_names +use fms2_io_mod, only : check_if_open, get_dimension_names, get_dimension_size +use fms2_io_mod, only : is_dimension_registered, register_axis, get_variable_size +use fms2_io_mod, only : FmsNetcdfDomainFile_t, FmsNetcdfFile_t, unlimited, get_variable_names +use fms2_io_mod, only : get_variable_num_dimensions, get_variable_units, is_dimension_unlimited +use fms2_io_mod, only : get_num_variables +use mpp_domains_mod, only : domain2d +use mpp_domains_mod, only : CENTER, CORNER, NORTH_FACE=>NORTH, EAST_FACE=>EAST +use mpp_domains_mod, only : mpp_get_domain_npes, mpp_define_io_domain, mpp_get_io_domain +use mpp_domains_mod, only : mpp_get_data_domain, mpp_get_compute_domain, mpp_get_global_domain + +implicit none ; private + +public MOM_read_data_scalar, MOM_read_vector_2d_fms2, MOM_read_vector_3d_fms2 +public MOM_read_data_4d_noDD, MOM_read_data_3d_noDD, MOM_read_data_2d_noDD, MOM_read_data_1d_noDD +public MOM_read_data_4d_DD, MOM_read_data_3d_DD, MOM_read_data_2d_DD, MOM_read_data_1d_DD + +! CAUTION: The following variables are saved by default, and are only necessary for consecutive calls to +! MOM_read_data with the same file name. The user should ensure that fms2_close_file on +! the fileobj_read structures are called at every requisite time step at after the last +! variable is written to the file by omitting the optional leave_file_open argument, or setting it to .false. + +!> netCDF domain-decomposed file object returned by call to +!! open_file in MOM_read_data_DD calls +type(FmsNetcdfDomainFile_t), private :: fileobj_read_dd + +!> netCDF domain-decomposed file object returned by call to +!! open_file in MOM_read_data_noDD calls +type(FmsNetcdfFile_t), private :: fileobj_read + +!> Type with variable metadata for a netCDF file opened to read domain-decomposed data +type file_variable_meta_DD + integer :: nvars = 0!< number of variables in a netCDF file opened to read domain-decomposed data + character(len=96), allocatable, dimension(:) :: var_names !< array for names of variables in a netCDF + !! file opened to read domain-decomposed data +end type file_variable_meta_DD + +!> Type with variable metadata for a netCDF file opened to read non-domain-decomposed data +type file_variable_meta_noDD + integer :: nvars = 0 !< number of variables in a netCDF file opened to read non-domain-decomposed data + character(len=96), allocatable, dimension(:) :: var_names !< array for names of variables in a netCDF + !! file opened to read non-domain-decomposed data +end type file_variable_meta_noDD +!> type to hold metadata for variables in a domain-decomposed file +type (file_variable_meta_DD), private :: file_var_meta_DD + +!> type to hold metadata for variables in a non-domain-decomposed file +type (file_variable_meta_noDD), private :: file_var_meta_noDD + +!> index of the time_level value that is written to netCDF file bythe write_field routines. +integer, private :: write_field_time_index + +!> interface to apply a scale factor to an array after reading in a field +interface scale_data + module procedure scale_data_4d + module procedure scale_data_3d + module procedure scale_data_2d + module procedure scale_data_1d +end interface + +contains + +!> This routine calls the fms_io read_data subroutine to read 1-D domain-decomposed data field named "fieldname" +!! from file "filename". The routine multiplies the data by "scale" if the optional argument is included in the call. +subroutine MOM_read_data_1d_DD(filename, fieldname, data, domain, use_fms2, start_index, edge_lengths, & + timelevel, scale, x_position, y_position, leave_file_open) + character(len=*), intent(in) :: filename !< The name of the file to read + character(len=*), intent(in) :: fieldname !< The variable name of the data in the file + real, dimension(:), intent(inout) :: data !< The 1-dimensional data array to pass to read_data + type(MOM_domain_type), intent(in) :: domain !< MOM domain attribute with the mpp_domain decomposition + logical, intent(in) :: use_fms2 !< flag to distinguish interface from the old write_field interface + integer, dimension(1), optional, intent(in) :: start_index !< starting index of data buffer. Default is 1 + integer, dimension(1), optional, intent(in) :: edge_lengths !< number of data values to read in + !! default is the variable size + integer, optional, intent(in) :: timelevel !< time level to read + real, optional, intent(in) :: scale !< A scaling factor that the field is multiplied by + integer, optional, intent(in) :: x_position !< domain position of x-dimension; CENTER (default) or EAST_FACE + integer, optional, intent(in) :: y_position !< domain position of y-dimension; CENTER (default) or NORTH_FACE + logical, optional, intent(in) :: leave_file_open !< if .true., leave file open + ! local + logical :: file_open_success !.true. if call to open_file is successful + logical :: variable_found ! .true. if lowercase(fieldname) matches one of the lowercase file variable names + logical :: close_the_file ! indicates whether to close the file after write_data is called; default is .true. + integer :: i, num_var_dims, dim_unlim_size + integer, dimension(1) :: start, nread ! indices for first data value and number of values to read + character(len=40), allocatable :: dim_names(:) ! variable dimension names + character(len=96) :: variable_to_read ! variable to read from the netcdf file + integer :: xpos, ypos ! x and y domain positions + + xpos = CENTER + ypos = CENTER + if (present(x_position)) xpos = x_position + if (present(y_position)) ypos = y_position + + close_the_file = .true. + if (present(leave_file_open)) close_the_file = .not.(leave_file_open) + ! open the file + if (.not.(check_if_open(fileobj_read_dd))) then + ! define the io domain for 1-pe jobs because it is required to read domain-decomposed files + if (mpp_get_domain_npes(domain%mpp_domain) .eq. 1 ) then + if (.not. associated(mpp_get_io_domain(domain%mpp_domain))) & + call mpp_define_io_domain(domain%mpp_domain, (/1,1/)) + endif + file_open_success = fms2_open_file(fileobj_read_dd, filename, "read", domain%mpp_domain, is_restart=.false.) + file_var_meta_DD%nvars = get_num_variables(fileobj_read_dd) + if (file_var_meta_DD%nvars .lt. 1) call MOM_error(FATAL, "nvars is less than 1 for file "// & + trim(filename)) + if (.not.(allocated(file_var_meta_DD%var_names))) allocate(file_var_meta_DD%var_names(file_var_meta_DD%nvars)) + call get_variable_names(fileobj_read_dd, file_var_meta_DD%var_names) + endif + ! search for the variable in the file + variable_to_read = "" + variable_found = .false. + do i=1,file_var_meta_DD%nvars + if (lowercase(trim(file_var_meta_DD%var_names(i))) .eq. lowercase(trim(fieldname))) then + variable_found = .true. + variable_to_read = trim(file_var_meta_DD%var_names(i)) + exit + endif + enddo + if (.not.(variable_found)) call MOM_error(FATAL, "MOM_read_data_fms2:MOM_read_data_1d_DD: "//& + trim(fieldname)//" not found in"//trim(filename)) + ! register the variable axes + call MOM_register_variable_axes(fileobj_read_dd, trim(variable_to_read), xPosition=xpos, yPosition=ypos) + ! set the start and nread values that will be passed as the read_data start_index and edge_lengths arguments + allocate(dim_names(num_var_dims)) + dim_names(:) = "" + call get_variable_dimension_names(fileobj_read_dd, trim(variable_to_read), dim_names) + + start(1)=1 + if (present(timelevel)) then + if (is_dimension_unlimited(fileobj_read_dd, dim_names(1))) start(1) = timelevel + elseif (present(start_index)) then + start(1) = start_index(1) + endif + + if (present(edge_lengths)) then + nread(1) = edge_lengths(1) + else + call get_dimension_size(fileobj_read_dd, trim(dim_names(1)), nread(1)) + endif + ! read the data + dim_unlim_size = 0 + if (present(timelevel)) then + do i=1,num_var_dims + if (is_dimension_unlimited(fileobj_read_dd, dim_names(i))) then + call get_dimension_size(fileobj_read_dd, dim_names(i), dim_unlim_size) + exit + endif + enddo + if (dim_unlim_size .gt. 0) then + call read_data(fileobj_read_dd, trim(variable_to_read), data, corner=start, edge_lengths=nread, & + unlim_dim_level=timelevel) + else + call MOM_error(WARNING, "MOM_read_data_fms2::MOM_read_data_1d_DD: time level specified, but the variable "//& + trim(fieldName)// " does not have an unlimited dimension.") + call read_data(fileobj_read_dd, trim(variable_to_read), data, corner=start, edge_lengths=nread) + endif + else + call read_data(fileobj_read_dd, trim(variable_to_read), data, corner=start, edge_lengths=nread) + endif + ! scale the data + if (present(scale)) then ; if (scale /= 1.0) then + call scale_data(data, scale) + endif ; endif + ! close the file + if (close_the_file) then + if (check_if_open(fileobj_read_dd)) call fms2_close_file(fileobj_read_dd) + if (allocated(file_var_meta_DD%var_names)) deallocate(file_var_meta_DD%var_names) + file_var_meta_DD%nvars = 0 + endif + if (allocated(dim_names)) deallocate(dim_names) +end subroutine MOM_read_data_1d_DD + +!> This routine calls the fms_io read_data subroutine to read 2-D domain-decomposed data field named "fieldname" +!! from file "filename". The routine multiplies the data by "scale" if the optional argument is included in the call. +subroutine MOM_read_data_2d_DD(filename, fieldname, data, domain, use_fms2, start_index, edge_lengths, & + timelevel, scale, x_position, y_position, leave_file_open) + character(len=*), intent(in) :: filename !< The name of the file to read + character(len=*), intent(in) :: fieldname !< The variable name of the data in the file + real, dimension(:,:), intent(inout) :: data !< The 2-dimensional data array to pass to read_data + type(MOM_domain_type), intent(in) :: domain !< MOM domain attribute with the mpp_domain decomposition + logical, intent(in) :: use_fms2 !< flag to distinguish interface from the old write_field interface + integer, dimension(2), optional, intent(in) :: start_index !< starting indices of data buffer. Default is 1 + integer, dimension(2), optional, intent(in) :: edge_lengths !< number of data values to read in. + !! Default values are the variable dimension sizes + integer, optional, intent(in) :: timelevel !< time level to read + real, optional, intent(in):: scale !< A scaling factor that the field is multiplied by + integer, intent(in), optional :: x_position !< domain position of x-dimension; CENTER (default) or EAST_FACE + integer, intent(in), optional :: y_position !< domain position of y-dimension; CENTER (default) or NORTH_FACE + logical, optional, intent(in) :: leave_file_open !< if .true., leave file open + ! local + logical :: file_open_success !.true. if call to open_file is successful + logical :: variable_found ! .true. if lowercase(fieldname) matches one of the lowercase file variable names + logical :: close_the_file ! indicates whether to close the file after write_data is called; default is .true. + integer :: i, dim_unlim_size, num_var_dims, first(2), last(2) + integer :: start(2), nread(2) ! indices for first data value and number of values to read + character(len=40), allocatable :: dim_names(:) ! variable dimension names + character(len=96) :: variable_to_read ! variable to read from the netcdf file + integer :: xpos, ypos, pos ! x and y domain positions + integer :: isc, iec, jsc, jec, isg, ieg, jsg, jeg + type(domain2D), pointer :: io_domain => NULL() + + xpos = CENTER + ypos = CENTER + if (present(x_position)) xpos = x_position + if (present(y_position)) ypos = y_position + + close_the_file = .true. + if (present(leave_file_open)) close_the_file = .not.(leave_file_open) + + ! open the file + if (.not.(check_if_open(fileobj_read_dd))) then + ! define the io domain for 1-pe jobs because it is required to read domain-decomposed files + if (mpp_get_domain_npes(domain%mpp_domain) .eq. 1 ) then + if (.not. associated(mpp_get_io_domain(domain%mpp_domain))) & + call mpp_define_io_domain(domain%mpp_domain, (/1,1/)) + endif + file_open_success = fms2_open_file(fileobj_read_dd, filename, "read", domain%mpp_domain, is_restart=.false.) + file_var_meta_DD%nvars = get_num_variables(fileobj_read_dd) + if (file_var_meta_DD%nvars .lt. 1) call MOM_error(FATAL, "nvars is less than 1 for file "// & + trim(filename)) + if (.not.(allocated(file_var_meta_DD%var_names))) allocate(file_var_meta_DD%var_names(file_var_meta_DD%nvars)) + call get_variable_names(fileobj_read_dd, file_var_meta_DD%var_names) + endif + ! search for the variable in the file + variable_to_read = "" + variable_found = .false. + do i=1,file_var_meta_DD%nvars + if (lowercase(trim(file_var_meta_DD%var_names(i))) .eq. lowercase(trim(fieldname))) then + variable_found = .true. + variable_to_read = trim(file_var_meta_DD%var_names(i)) + exit + endif + enddo + if (.not.(variable_found)) call MOM_error(FATAL, "MOM_read_data_fms2:MOM_read_data_2d_DD: "//& + trim(fieldname)//" not found in "//trim(filename)) + ! register the variable axes + call MOM_register_variable_axes(fileobj_read_dd, trim(variable_to_read), xPosition=xpos, yPosition=ypos) + + pos = CENTER + if (present(x_position)) then + if (present(y_position)) then + pos = CORNER + else + pos = xpos + endif + elseif (present(y_position)) then + pos = ypos + endif + ! set the start and nread values that will be passed as the read_data corner and edge_lengths argument + num_var_dims = get_variable_num_dimensions(fileobj_read_dd, trim(variable_to_read)) + allocate(dim_names(num_var_dims)) + dim_names(:) = "" + call get_variable_dimension_names(fileobj_read_dd, trim(variable_to_read), dim_names) + ! get the IO domain + !io_domain => mpp_get_io_domain(domain%mpp_domain) + ! Get the global indicies + !call mpp_get_global_domain(io_domain, xbegin=isg, xend=ieg, ybegin=jsg, yend=jeg, position=pos) + ! Get the compute indicies + !call mpp_get_compute_domain(io_domain, xbegin=isc, xend=iec, ybegin=jsc, yend=jec, position=pos) + !last(1) = iec - isg + 1 ! get array indices for the axis data + !last(2) = jec - jsg + 1 + !first(1) = isc - isg + 1 + !first(2) = jsc - jsg + 1 + + start(:) = 1 + if (present(start_index)) then + start = start_index + !else + ! start(:) = first(:) + endif + + if (present(edge_lengths)) then + nread = edge_lengths + else + nread = shape(data) + endif + ! read the data + dim_unlim_size=0 + if (present(timelevel)) then + do i=1,num_var_dims + if (is_dimension_unlimited(fileobj_read_dd, dim_names(i))) then + call get_dimension_size(fileobj_read_dd, dim_names(i), dim_unlim_size) + endif + enddo + if (dim_unlim_size .gt. 0) then + call read_data(fileobj_read_dd, trim(variable_to_read), data, corner=start, edge_lengths=nread, & + unlim_dim_level=timelevel) + else + call read_data(fileobj_read_dd, trim(variable_to_read), data, corner=start, edge_lengths=nread) + endif + else + call read_data(fileobj_read_dd, trim(variable_to_read), data, corner=start, edge_lengths=nread) + endif + ! scale the data + if (present(scale)) then ; if (scale /= 1.0) then + call scale_data(data, scale) + endif ; endif + ! close the file + if (close_the_file) then + if (check_if_open(fileobj_read_dd)) call fms2_close_file(fileobj_read_dd) + if (allocated(file_var_meta_DD%var_names)) deallocate(file_var_meta_DD%var_names) + file_var_meta_DD%nvars = 0 + endif + if (allocated(dim_names)) deallocate(dim_names) + if (associated(io_domain)) nullify(io_domain) +end subroutine MOM_read_data_2d_DD + +!> This routine calls the fms_io read_data subroutine to read 3-D domain-decomposed data field named "fieldname" +!! from file "filename". The routine multiplies the data by "scale" if the optional argument is included in the call. +subroutine MOM_read_data_3d_DD(filename, fieldname, data, domain, use_fms2, start_index, edge_lengths, & + timelevel, scale, x_position, y_position, leave_file_open) + character(len=*), intent(in) :: filename !< The name of the file to read + character(len=*), intent(in) :: fieldname !< The variable name of the data in the file + real, dimension(:,:,:), intent(inout) :: data !< The 3-dimensional data array to pass to read_data + type(MOM_domain_type), intent(in) :: domain !< MOM domain attribute with the mpp_domain decomposition + logical, intent(in) :: use_fms2 !< flag indicating whether to use this routine + integer, dimension(3), optional, intent(in) :: start_index !< starting indices of data buffer. Default is 1 + integer, dimension(3), optional, intent(in) :: edge_lengths !< number of data values to read in. + !! Default values are the variable dimension sizes + integer, optional, intent(in) :: timelevel !< time level to read + real, optional, intent(in):: scale !< A scaling factor that the field is multiplied by + integer, intent(in), optional :: x_position !< domain position of x-dimension; CENTER (default) or EAST_FACE + integer, intent(in), optional :: y_position !< domain position of y-dimension; CENTER (default) or NORTH_FACE + logical, optional, intent(in) :: leave_file_open !< if .true., leave file open + ! local + logical :: file_open_success !.true. if call to open_file is successful + logical :: variable_found ! if .true., the variable was found in the netCDF file + logical :: close_the_file ! indicates whether to close the file after write_data is called; default is .true. + integer :: i, dim_unlim_size, num_var_dims + integer, dimension(3) :: start, nread, first, last ! indices for first data value and number of values to read + character(len=40), allocatable :: dim_names(:) ! variable dimension names + character(len=96) :: variable_to_read ! variable to read from the netcdf file + integer :: xpos, ypos, pos ! x and y domain positions + integer :: isc, iec, jsc, jec, isg, ieg, jsg, jeg + type(domain2D), pointer :: io_domain => NULL() + + xpos = CENTER + ypos = CENTER + if (present(x_position)) xpos = x_position + if (present(y_position)) ypos = y_position + + close_the_file = .true. + if (present(leave_file_open)) close_the_file = .not.(leave_file_open) + ! open the file + if (.not.(check_if_open(fileobj_read_dd))) then + ! define the io domain for 1-pe jobs because it is required to read domain-decomposed files + if (mpp_get_domain_npes(domain%mpp_domain) .eq. 1 ) then + if (.not. associated(mpp_get_io_domain(domain%mpp_domain))) & + call mpp_define_io_domain(domain%mpp_domain, (/1,1/)) + endif + file_open_success = fms2_open_file(fileobj_read_dd, filename, "read", domain%mpp_domain, is_restart=.false.) + file_var_meta_DD%nvars = get_num_variables(fileobj_read_dd) + if (file_var_meta_DD%nvars .lt. 1) call MOM_error(FATAL, "nvars is less than 1 for file "// & + trim(filename)) + if (.not.(allocated(file_var_meta_DD%var_names))) allocate(file_var_meta_DD%var_names(file_var_meta_DD%nvars)) + call get_variable_names(fileobj_read_dd, file_var_meta_DD%var_names) + endif + ! search for the variable in the file + variable_to_read = "" + variable_found = .false. + do i=1,file_var_meta_DD%nvars + if (lowercase(trim(file_var_meta_DD%var_names(i))) .eq. lowercase(trim(fieldname))) then + variable_found = .true. + variable_to_read = trim(file_var_meta_DD%var_names(i)) + exit + endif + enddo + if (.not.(variable_found)) call MOM_error(FATAL, "MOM_read_data_fms2:MOM_read_data_3d_DD: "//& + trim(fieldname)//" not found in"//trim(filename)) + ! register the variable axes + call MOM_register_variable_axes(fileobj_read_dd, trim(variable_to_read), xPosition=xpos, yPosition=ypos) + pos = CENTER + if (present(x_position)) then + if (present(y_position)) then + pos = CORNER + else + pos = xpos + endif + elseif (present(y_position)) then + pos = ypos + endif + ! set the start and nread values that will be passed as the read_data corner and edge_lengths argument + num_var_dims = get_variable_num_dimensions(fileobj_read_dd, trim(variable_to_read)) + allocate(dim_names(num_var_dims)) + dim_names(:) = "" + call get_variable_dimension_names(fileobj_read_dd, trim(variable_to_read), dim_names) + ! get the IO domain + io_domain => mpp_get_io_domain(domain%mpp_domain) + ! Get the global indicies + ! call mpp_get_global_domain(io_domain, xbegin=isg, xend=ieg, ybegin=jsg, yend=jeg, position=pos) + ! call mpp_get_compute_domain(io_domain, xbegin=isc, xend=iec, ybegin=jsc, yend=jec, position=pos) + !last(1) = iec - isg + 1 ! get array indices for the axis data + !last(2) = jec - jsg + 1 + !first(1) = isc - isg + 1 + !first(2) = jsc - jsg + 1 + + start(:) = 1 + if (present(start_index)) then + start = start_index + !else + ! start(1:2) = first(1:2) + endif + + if (present(edge_lengths)) then + nread = edge_lengths + else + !nread(1) = last(1) - first(1) + 1 + !nread(2) = last(2) - first(2) + 1 + nread = shape(data) + endif + ! read the data + dim_unlim_size=0 + if (present(timelevel)) then + do i=1,num_var_dims + if (is_dimension_unlimited(fileobj_read_dd, dim_names(i))) then + call get_dimension_size(fileobj_read_dd, dim_names(i), dim_unlim_size) + endif + enddo + if (dim_unlim_size .gt. 0) then + call read_data(fileobj_read_dd, trim(variable_to_read), data, corner=start, edge_lengths=nread, & + unlim_dim_level=timelevel) + else + call MOM_error(WARNING, "MOM_read_data_fms2::MOM_read_data_3d_DD: time level specified, but the variable "//& + trim(fieldName)// " does not have an unlimited dimension.") + call read_data(fileobj_read_dd, trim(variable_to_read), data, corner=start, edge_lengths=nread) + endif + else + call read_data(fileobj_read_dd, trim(variable_to_read), data, corner=start, edge_lengths=nread) + endif + ! scale the data + if (present(scale)) then ; if (scale /= 1.0) then + call scale_data(data, scale) + endif ; endif + ! close the file + if (close_the_file) then + if (check_if_open(fileobj_read_dd)) call fms2_close_file(fileobj_read_dd) + if (allocated(file_var_meta_DD%var_names)) deallocate(file_var_meta_DD%var_names) + file_var_meta_DD%nvars = 0 + endif + + if (allocated(dim_names)) deallocate(dim_names) + if (associated(io_domain)) nullify(io_domain) +end subroutine MOM_read_data_3d_DD + +!> This routine calls the fms_io read_data subroutine to read 4-D domain-decomposed data field named "fieldname" +!! from file "filename". The routine multiplies the data by "scale" if the optional argument is included in the call. +subroutine MOM_read_data_4d_DD(filename, fieldname, data, domain, use_fms2, start_index, edge_lengths, & + timelevel, scale, x_position, y_position, leave_file_open) + character(len=*), intent(in) :: filename !< The name of the file to read + character(len=*), intent(in) :: fieldname !< The variable name of the data in the file + real, dimension(:,:,:,:), intent(inout) :: data !< The 1-dimensional data array to pass to read_data + type(MOM_domain_type), intent(in) :: domain !< MOM domain attribute with the mpp_domain decomposition + logical, intent(in) :: use_fms2 !< flag indicating whether to use this routine + integer, dimension(4), optional, intent(in) :: start_index !< starting indices of data buffer. Default is 1 + integer, dimension(4), optional, intent(in) :: edge_lengths !< number of data values to read in. + !! Default values are the variable dimension sizes + integer, optional, intent(in) :: timelevel !< time level to read + real, optional, intent(in):: scale !< A scaling factor that the field is multiplied by + integer, intent(in), optional :: x_position !< domain position of x-dimension; CENTER (default) or EAST_FACE + integer, intent(in), optional :: y_position !< domain position of y-dimension; CENTER (default) or NORTH_FACE + logical, optional, intent(in) :: leave_file_open !< if .true., leave file open + ! local + logical :: file_open_success !.true. if call to open_file is successful + logical :: variable_found ! .true. if lowercase(fieldname) matches one of the lowercase file variable names + logical :: close_the_file ! indicates whether to close the file after write_data is called; default is .true. + integer :: i, dim_unlim_size, num_var_dims + integer, dimension(4) :: start, nread, first, last ! indices for first data value and number of values to read + character(len=40), allocatable :: dim_names(:) ! variable dimension names + character(len=96) :: variable_to_read ! variable to read from the netcdf file + integer :: xpos, ypos, pos ! x and y domain positions + integer :: isc, iec, jsc, jec, isg, ieg, jsg, jeg + type(domain2D), pointer :: io_domain => NULL() + + xpos = CENTER + ypos = CENTER + if (present(x_position)) xpos = x_position + if (present(y_position)) ypos = y_position + + close_the_file = .true. + if (present(leave_file_open)) close_the_file = .not.(leave_file_open) + ! open the file + if (.not.(check_if_open(fileobj_read_dd))) then + ! define the io domain for 1-pe jobs because it is required to read domain-decomposed files + if (mpp_get_domain_npes(domain%mpp_domain) .eq. 1 ) then + if (.not. associated(mpp_get_io_domain(domain%mpp_domain))) & + call mpp_define_io_domain(domain%mpp_domain, (/1,1/)) + endif + file_open_success = fms2_open_file(fileobj_read_dd, filename, "read", domain%mpp_domain, is_restart=.false.) + file_var_meta_DD%nvars = get_num_variables(fileobj_read_dd) + if (file_var_meta_DD%nvars .lt. 1) call MOM_error(FATAL, "nvars is less than 1 for file "// & + trim(filename)) + if (.not.(allocated(file_var_meta_DD%var_names))) allocate(file_var_meta_DD%var_names(file_var_meta_DD%nvars)) + call get_variable_names(fileobj_read_dd, file_var_meta_DD%var_names) + endif + ! search for the variable in the file + variable_to_read = "" + variable_found = .false. + do i=1,file_var_meta_DD%nvars + if (lowercase(trim(file_var_meta_DD%var_names(i))) .eq. lowercase(trim(fieldname))) then + variable_found = .true. + variable_to_read = trim(file_var_meta_DD%var_names(i)) + exit + endif + enddo + if (.not.(variable_found)) & + call MOM_error(FATAL, "MOM_read_data_fms2:MOM_read_data_4d_DD: "//trim(fieldname)//" not found in"//& + trim(filename)) + ! register the variable axes + call MOM_register_variable_axes(fileobj_read_dd, trim(variable_to_read), xPosition=xpos, yPosition=ypos) + pos = CENTER + if (present(x_position)) then + if (present(y_position)) then + pos = CORNER + else + pos = xpos + endif + elseif (present(y_position)) then + pos = ypos + endif + ! set the start and nread values that will be passed as the read_data corner and edge_lengths argument + num_var_dims = get_variable_num_dimensions(fileobj_read_dd, trim(variable_to_read)) + allocate(dim_names(num_var_dims)) + dim_names(:) = "" + call get_variable_dimension_names(fileobj_read_dd, trim(variable_to_read), dim_names) + ! get the IO domain + !io_domain => mpp_get_io_domain(domain%mpp_domain) + ! Get the global indicies + !call mpp_get_global_domain(domain%mpp_domain, xbegin=isg, xend=ieg, ybegin=jsg, yend=jeg, position=pos) + ! Get the compute indicies + ! call mpp_get_compute_domain(domain%mpp_domain, xbegin=isc, xend=iec, ybegin=jsc, yend=jec, position=pos) + !last(1) = iec - isg + 1 ! get array indices for the axis data + !first(1) = isc - isg + 1 + + start(:) = 1 + if (present(start_index)) then + start(:) = start_index(:) + !else + !start(1:2) = first(1:2) + endif + + if (present(edge_lengths)) then + nread = edge_lengths + else + !nread(1) = last(1) - first(1) + 1 + !nread(2) = last(2) - first(2) + 1 + nread = shape(data) + endif + ! read the data + dim_unlim_size=0 + if (present(timelevel)) then + do i=1, num_var_dims + if (is_dimension_unlimited(fileobj_read_dd, dim_names(i))) then + call get_dimension_size(fileobj_read_dd, dim_names(i), dim_unlim_size) + endif + if (i .eq. 4) then + nread(i) = 1 + start(i) = timelevel + endif + enddo + if (dim_unlim_size .gt. 0) then + call read_data(fileobj_read_dd, trim(variable_to_read), data, corner=start, edge_lengths=nread, & + unlim_dim_level=timelevel) + else + call MOM_error(WARNING, "MOM_read_data_fms2::MOM_read_data_4d_DD: time level specified, but the variable "//& + trim(fieldName)// " does not have an unlimited dimension.") + call read_data(fileobj_read_dd, trim(variable_to_read), data, corner=start, edge_lengths=nread) + endif + else + call read_data(fileobj_read_dd, trim(variable_to_read), data, corner=start, edge_lengths=nread) + endif + ! scale the data + if (present(scale)) then ; if (scale /= 1.0) then + call scale_data(data, scale) + endif ; endif + ! close the file + if (close_the_file) then + if (check_if_open(fileobj_read_dd)) call fms2_close_file(fileobj_read_dd) + if (allocated(file_var_meta_DD%var_names)) deallocate(file_var_meta_DD%var_names) + file_var_meta_DD%nvars = 0 + endif + if (associated(io_domain)) nullify(io_domain) + if (allocated(dim_names)) deallocate(dim_names) +end subroutine MOM_read_data_4d_DD + +!!> This routine calls the fms_io read_data subroutine to read a scalar (0-D) field named "fieldname" +!! from file "filename". +subroutine MOM_read_data_scalar(filename, fieldname, data, use_fms2, leave_file_open) + character(len=*), intent(in) :: filename !< The name of the file to read + character(len=*), intent(in) :: fieldname !< The variable name of the data in the file + real, intent(inout) :: data !< data buffer to pass to read_data + logical, intent(in) :: use_fms2 !< flag distinguishing interface from old MOM_read_data + logical, optional, intent(in) :: leave_file_open !< if .true., leave file open + ! local + integer :: i + logical :: file_open_success !.true. if call to open_file is successful + logical :: close_the_file ! indicates whether to close the file after write_data is called; default is .true. + logical :: variable_found ! .true. if lowercase(fieldname) matches one of the lowercase file variable names + character(len=96) :: variable_to_read ! variable to read from the netcdf file + + close_the_file = .true. + if (present(leave_file_open)) close_the_file = .not.(leave_file_open) + ! open the file + if (.not.(check_if_open(fileobj_read))) then + file_open_success = fms2_open_file(fileobj_read, filename, "read", is_restart=.false.) + file_var_meta_noDD%nvars = get_num_variables(fileobj_read) + if (file_var_meta_noDD%nvars .lt. 1) call MOM_error(FATAL, "nvars is less than 1 for file "// & + trim(filename)) + if (.not.(allocated(file_var_meta_noDD%var_names))) & + allocate(file_var_meta_noDD%var_names(file_var_meta_noDD%nvars)) + call get_variable_names(fileobj_read, file_var_meta_noDD%var_names) + endif + ! search for the variable in the file + variable_to_read = "" + variable_found = .false. + do i=1,file_var_meta_noDD%nvars + if (lowercase(trim(file_var_meta_noDD%var_names(i))) .eq. lowercase(trim(fieldname))) then + variable_found = .true. + variable_to_read = trim(file_var_meta_noDD%var_names(i)) + exit + endif + enddo + if (.not.(variable_found)) call MOM_error(FATAL, "MOM_read_data_fms2:MOM_read_data_scalar: "//trim(fieldname)// & + " not found in"//trim(filename)) + ! read the data + call read_data(fileobj_read, trim(fieldname), data) + ! close the file + if (close_the_file) then + if (check_if_open(fileobj_read)) call fms2_close_file(fileobj_read) + if (allocated(file_var_meta_noDD%var_names)) deallocate(file_var_meta_noDD%var_names) + file_var_meta_noDD%nvars = 0 + endif +end subroutine MOM_read_data_scalar + +!> This routine calls the fms_io read_data subroutine to read 1-D non-domain-decomposed data field named "fieldname" +!! from file "filename". The routine multiplies the data by "scale" if the optional argument is included in the call. +subroutine MOM_read_data_1d_noDD(filename, fieldname, data, use_fms2, start_index, & + edge_lengths, timelevel, scale, leave_file_open) + character(len=*), intent(in) :: filename !< The name of the file to read + character(len=*), intent(in) :: fieldname !< The variable name of the data in the file + real, dimension(:), intent(inout) :: data !< The 1-dimensional data array to pass to read_data + logical, intent(in) :: use_fms2 !< flag to distinguish interface from old MOM_read_data interface + integer, dimension(1), optional, intent(in) :: start_index !< starting index of data buffer. Default is 1 + integer, dimension(1), optional, intent(in) :: edge_lengths !< number of data values to read in; default is + !! the variable size + integer, optional, intent(in) :: timelevel !< time level to read + real, optional, intent(in) :: scale !< A scaling factor that the field is multiplied by + logical, optional, intent(in) :: leave_file_open !< if .true., leave file open + ! local + logical :: file_open_success !.true. if call to open_file is successful + logical :: close_the_file ! indicates whether to close the file after write_data is called; default is .true. + logical :: variable_found ! .true. if lowercase(fieldname) matches one of the lowercase file variable names + integer :: i, num_var_dims, dim_unlim_size + integer, dimension(1) :: start, nread ! indices for first data value and number of values to read + character(len=40), allocatable:: dim_names(:) ! variable dimension names + character(len=96) :: variable_to_read ! variable to read from the netcdf file + + close_the_file = .true. + if (present(leave_file_open)) close_the_file = .not.(leave_file_open) + ! open the file + if (.not.(check_if_open(fileobj_read))) then + file_open_success = fms2_open_file(fileobj_read, filename, "read", is_restart=.false.) + file_var_meta_noDD%nvars = get_num_variables(fileobj_read) + if (file_var_meta_noDD%nvars .lt. 1) call MOM_error(FATAL, "nvars is less than 1 for file "// & + trim(filename)) + if (.not.(allocated(file_var_meta_noDD%var_names))) & + allocate(file_var_meta_noDD%var_names(file_var_meta_noDD%nvars)) + call get_variable_names(fileobj_read, file_var_meta_noDD%var_names) + endif + ! search for the variable in the file + variable_to_read = "" + variable_found = .false. + do i=1,file_var_meta_noDD%nvars + if (lowercase(trim(file_var_meta_noDD%var_names(i))) .eq. lowercase(trim(fieldname))) then + variable_found = .true. + variable_to_read = trim(file_var_meta_noDD%var_names(i)) + exit + endif + enddo + if (.not.(variable_found)) call MOM_error(FATAL, "MOM_io:MOM_read_data_1d_noDD: "//trim(fieldname)//& + " not found in "//trim(filename)) + + num_var_dims = get_variable_num_dimensions(fileobj_read, trim(fieldname)) + allocate(dim_names(num_var_dims)) + dim_names(:) = "" + call get_variable_dimension_names(fileobj_read, trim(variable_to_read), dim_names) + + ! set the start and nread values that will be passed as the read_data start_index and edge_lengths arguments + start(1)=1 + if (present(timelevel)) then + if (is_dimension_unlimited(fileobj_read, dim_names(1))) start(1) = timelevel + elseif (present(start_index)) then + start(1) = start_index(1) + endif + + if (present(edge_lengths)) then + nread(1) = edge_lengths(1) + else + nread = shape(data) + endif + ! read the data + dim_unlim_size = 0 + if (present(timelevel)) then + do i=1,num_var_dims + if (is_dimension_unlimited(fileobj_read, dim_names(i))) then + call get_dimension_size(fileobj_read, dim_names(i), dim_unlim_size) + exit + endif + enddo + if (dim_unlim_size .gt. 0) then + call read_data(fileobj_read, trim(variable_to_read), data, corner=start, edge_lengths=nread, & + unlim_dim_level=timelevel) + else + call MOM_error(WARNING, "MOM_read_data_fms2::MOM_read_data_1d_noDD: time level specified, but the variable "//& + trim(fieldName)// " does not have an unlimited dimension.") + call read_data(fileobj_read, trim(variable_to_read), data, corner=start, edge_lengths=nread) + endif + else + call read_data(fileobj_read, trim(variable_to_read), data, corner=start, edge_lengths=nread) + endif + ! scale the data + if (present(scale)) then ; if (scale /= 1.0) then + call scale_data(data, scale) + endif ; endif + ! close the file + if (close_the_file) then + if (check_if_open(fileobj_read)) call fms2_close_file(fileobj_read) + if (allocated(file_var_meta_noDD%var_names)) deallocate(file_var_meta_noDD%var_names) + file_var_meta_noDD%nvars = 0 + endif + if (allocated(dim_names)) deallocate(dim_names) +end subroutine MOM_read_data_1d_noDD + +!> This routine calls the fms_io read_data subroutine to read 2-D non-domain-decomposed data field named "fieldname" +!! from file "filename". The routine multiplies the data by "scale" if the optional argument is included in the call. +subroutine MOM_read_data_2d_noDD(filename, fieldname, data, use_fms2, start_index, & + edge_lengths, timelevel, scale, leave_file_open) + character(len=*), intent(in) :: filename !< The name of the file to read + character(len=*), intent(in) :: fieldname !< The variable name of the data in the file + real, dimension(:,:), intent(inout) :: data !< The 2-dimensional data array to pass to read_data + logical, intent(in) :: use_fms2 !< flag to distinguish interface from old MOM_read_data interface + integer, dimension(2), optional, intent(in) :: start_index !< starting indices of data buffer. Default is 1 + integer, dimension(2), optional, intent(in) :: edge_lengths !< number of data values to read in. + !! Default values are the variable dimension sizes + integer, optional, intent(in) :: timelevel !< time level to read + real, optional, intent(in):: scale !< A scaling factor that the field is multiplied by + logical, optional, intent(in) :: leave_file_open !< if .true., leave file open + ! local + logical :: file_open_success !.true. if call to open_file is successful + logical :: variable_found ! .true. if lowercase(fieldname) matches one of the lowercase file variable names + logical :: close_the_file ! indicates whether to close the file after write_data is called; default is .true. + integer :: i, dim_unlim_size, num_var_dims + integer, dimension(2) :: start, nread ! indices for first data value and number of values to read + character(len=40), allocatable :: dim_names(:) ! variable dimension names + character(len=96) :: variable_to_read ! variable to read from the netcdf file + + close_the_file = .true. + if (present(leave_file_open)) close_the_file = .not.(leave_file_open) + ! open the file + if (.not.(check_if_open(fileobj_read))) then + file_open_success = fms2_open_file(fileobj_read, filename, "read", is_restart=.false.) + file_var_meta_noDD%nvars = get_num_variables(fileobj_read) + if (file_var_meta_noDD%nvars .lt. 1) call MOM_error(FATAL, "nvars is less than 1 for file "// & + trim(filename)) + if (.not.(allocated(file_var_meta_noDD%var_names))) & + allocate(file_var_meta_noDD%var_names(file_var_meta_noDD%nvars)) + call get_variable_names(fileobj_read, file_var_meta_noDD%var_names) + endif + ! search for the variable in the file + variable_to_read = "" + variable_found = .false. + do i=1,file_var_meta_noDD%nvars + if (lowercase(trim(file_var_meta_noDD%var_names(i))) .eq. lowercase(trim(fieldname))) then + variable_found = .true. + variable_to_read = trim(file_var_meta_noDD%var_names(i)) + exit + endif + enddo + if (.not.(variable_found)) & + call MOM_error(FATAL, "MOM_io:MOM_read_data_2d_noDD: "//trim(fieldname)//& + " not found in "//trim(filename)) + ! set the start and nread values that will be passed as the read_data corner and edge_lengths arguments + start(:) = 1 + if (present(start_index)) start = start_index + + if (present(edge_lengths)) then + nread = edge_lengths + else + nread = shape(data) + endif + ! read the data + dim_unlim_size=0 + if (present(timelevel)) then + num_var_dims = get_variable_num_dimensions(fileobj_read, trim(fieldname)) + allocate(dim_names(num_var_dims)) + call get_variable_dimension_names(fileobj_read, trim(variable_to_read), dim_names) + dim_names(:) = "" + do i=1,num_var_dims + if (is_dimension_unlimited(fileobj_read, dim_names(i))) then + call get_dimension_size(fileobj_read, dim_names(i), dim_unlim_size) + endif + enddo + if (dim_unlim_size .LE. 0) then + call MOM_error(WARNING, "MOM_io::MOM_read_data_2d_noDD: time level specified, but the variable "//& + trim(fieldName)// " does not have an unlimited dimension.") + call read_data(fileobj_read, trim(variable_to_read), data, corner=start, edge_lengths=nread) + else + call read_data(fileobj_read, trim(variable_to_read), data, corner=start, edge_lengths=nread, & + unlim_dim_level=timelevel) + endif + else + call read_data(fileobj_read, trim(variable_to_read), data, corner=start, edge_lengths=nread) + endif + ! scale the data + if (present(scale)) then ; if (scale /= 1.0) then + call scale_data(data, scale) + endif ; endif + ! close the file + if (close_the_file) then + if (check_if_open(fileobj_read)) call fms2_close_file(fileobj_read) + if (allocated(file_var_meta_noDD%var_names)) deallocate(file_var_meta_noDD%var_names) + file_var_meta_noDD%nvars = 0 + endif + if(allocated(dim_names)) deallocate(dim_names) + +end subroutine MOM_read_data_2d_noDD + +!> This routine calls the fms_io read_data subroutine to read 3-D non-domain-decomposed data field named "fieldname" +!! from file "filename". The routine multiplies the data by "scale" if the optional argument is included in the call. +subroutine MOM_read_data_3d_noDD(filename, fieldname, data, use_fms2, start_index, & + edge_lengths, timelevel, scale, leave_file_open) + character(len=*), intent(in) :: filename !< The name of the file to read + character(len=*), intent(in) :: fieldname !< The variable name of the data in the file + real, dimension(:,:,:), intent(inout) :: data !< The 3-dimensional data array to pass to read_data + logical, intent(in) :: use_fms2 !< flag to distinguish interface from old MOM_read_data interface + integer, dimension(3), optional, intent(in) :: start_index !< starting indices of data buffer. Default is 1 + integer, dimension(3), optional, intent(in) :: edge_lengths !< number of data values to read in. + !! Default values are the variable dimension sizes + integer, optional, intent(in) :: timelevel !< time level to read + real, optional, intent(in):: scale !< A scaling factor that the field is multiplied by + logical, optional, intent(in) :: leave_file_open !< if .true., leave file open + ! local + logical :: file_open_success !.true. if call to open_file is successful + logical :: variable_found ! .true. if lowercase(fieldname) matches one of the lowercase file variable names + logical :: close_the_file ! indicates whether to close the file after write_data is called; default is .true. + integer :: i, dim_unlim_size, num_var_dims + integer, dimension(3) :: start, nread ! indices for first data value and number of values to read + character(len=40), allocatable :: dim_names(:) ! variable dimension names + character(len=96) :: variable_to_read ! variable to read from the netcdf file + + close_the_file = .true. + if (present(leave_file_open)) close_the_file = .not.(leave_file_open) + ! open the file + if (.not.(check_if_open(fileobj_read))) then + file_open_success = fms2_open_file(fileobj_read, filename, "read", is_restart=.false.) + file_var_meta_noDD%nvars = get_num_variables(fileobj_read) + if (file_var_meta_noDD%nvars .lt. 1) call MOM_error(FATAL, "nvars is less than 1 for file "// & + trim(filename)) + if (.not.(allocated(file_var_meta_noDD%var_names))) & + allocate(file_var_meta_noDD%var_names(file_var_meta_noDD%nvars)) + call get_variable_names(fileobj_read, file_var_meta_noDD%var_names) + endif + ! search for the variable in the file + variable_to_read = "" + variable_found = .false. + do i=1,file_var_meta_noDD%nvars + if (lowercase(trim(file_var_meta_noDD%var_names(i))) .eq. lowercase(trim(fieldname))) then + variable_found = .true. + variable_to_read = trim(file_var_meta_noDD%var_names(i)) + exit + endif + enddo + if (.not.(variable_found)) call MOM_error(FATAL, "MOM_io:MOM_read_data_3d_noDD: "//trim(fieldname)//& + " not found in "//trim(filename)) + ! get the variable dimensions + num_var_dims = get_variable_num_dimensions(fileobj_read, trim(fieldname)) + allocate(dim_names(num_var_dims)) + dim_names(:) = "" + call get_variable_dimension_names(fileobj_read, trim(variable_to_read), dim_names) + ! set the start and nread values that will be passed as the read_data corner and edge_lengths arguments + start(:) = 1 + if (present(start_index)) start = start_index + + if (present(edge_lengths)) then + nread = edge_lengths + else + nread = shape(data) + endif + ! read the data + dim_unlim_size=0 + if (present(timelevel)) then + do i=1,num_var_dims + if (is_dimension_unlimited(fileobj_read, dim_names(i))) then + call get_dimension_size(fileobj_read, dim_names(i), dim_unlim_size) + endif + enddo + if (dim_unlim_size .LE. 0) then + call MOM_error(WARNING, "MOM_read_data_fms2::MOM_read_data_3d_noDD: time level specified, but the variable "//& + trim(fieldName)// " does not have an unlimited dimension.") + call read_data(fileobj_read, trim(variable_to_read), data, corner=start, edge_lengths=nread) + else + call read_data(fileobj_read, trim(variable_to_read), data, corner=start, edge_lengths=nread, & + unlim_dim_level=timelevel) + endif + else + call read_data(fileobj_read, trim(variable_to_read), data, corner=start, edge_lengths=nread) + endif + ! scale the data + if (present(scale)) then ; if (scale /= 1.0) then + call scale_data(data, scale) + endif ; endif + ! close the file + if (close_the_file) then + if (check_if_open(fileobj_read)) call fms2_close_file(fileobj_read) + if (allocated(file_var_meta_noDD%var_names)) deallocate(file_var_meta_noDD%var_names) + file_var_meta_noDD%nvars = 0 + endif + if (allocated(dim_names)) deallocate(dim_names) +end subroutine MOM_read_data_3d_noDD + +!> This routine calls the fms_io read_data subroutine to read 4-D non-domain-decomposed data field named "fieldname" +!! from file "filename". The routine multiplies the data by "scale" if the optional argument is included in the call. +subroutine MOM_read_data_4d_noDD(filename, fieldname, data, use_fms2, start_index, & + edge_lengths, timelevel, scale, leave_file_open) + character(len=*), intent(in) :: filename !< The name of the file to read + character(len=*), intent(in) :: fieldname !< The variable name of the data in the file + real, dimension(:,:,:,:), intent(inout) :: data !< The 4-dimensional data array to pass to read_data + logical, intent(in) :: use_fms2 !< flag to distinguish interface from old MOM_read_data interface + integer, dimension(4), optional, intent(in) :: start_index !< starting indices of data buffer. Default is 1 + integer, dimension(4), optional, intent(in) :: edge_lengths !< number of data values to read in. + !! Default values are the variable dimension sizes + integer, optional, intent(in) :: timelevel !< time level to read + real, optional, intent(in):: scale !< A scaling factor that the field is multiplied by + ! local + logical :: file_open_success !.true. if call to open_file is successful + logical :: variable_found ! .true. if lowercase(fieldname) matches one of the lowercase file variable names + logical :: close_the_file ! indicates whether to close the file after read_data is called; default is .true. + integer :: i, dim_unlim_size, num_var_dims + integer, dimension(4) :: start, nread ! indices for first data value and number of values to read + character(len=40), allocatable :: dim_names(:) ! variable dimension names + character(len=96) :: variable_to_read ! variable to read from the netcdf file + logical, optional, intent(in) :: leave_file_open !< if .true., leave file open + + close_the_file = .true. + if (present(leave_file_open)) close_the_file = .not.(leave_file_open) + ! open the file + if (.not.(check_if_open(fileobj_read))) then + file_open_success = fms2_open_file(fileobj_read, filename, "read", is_restart=.false.) + file_var_meta_noDD%nvars = get_num_variables(fileobj_read) + if (file_var_meta_noDD%nvars .lt. 1) call MOM_error(FATAL, "nvars is less than 1 for file "// & + trim(filename)) + if (.not.(allocated(file_var_meta_noDD%var_names))) & + allocate(file_var_meta_noDD%var_names(file_var_meta_noDD%nvars)) + call get_variable_names(fileobj_read, file_var_meta_noDD%var_names) + endif + ! search for the variable in the file + variable_to_read = "" + variable_found = .false. + do i=1,file_var_meta_noDD%nvars + if (lowercase(trim(file_var_meta_noDD%var_names(i))) .eq. lowercase(trim(fieldname))) then + variable_found = .true. + variable_to_read = trim(file_var_meta_noDD%var_names(i)) + exit + endif + enddo + if (.not.(variable_found)) call MOM_error(FATAL, "MOM_read_data_fms2:MOM_read_data_4d_noDD: "//& + trim(fieldname)//" not found in "//trim(filename)) + ! get the variable dimensions + num_var_dims = get_variable_num_dimensions(fileobj_read, trim(fieldname)) + allocate(dim_names(num_var_dims)) + dim_names(:) = "" + call get_variable_dimension_names(fileobj_read, trim(variable_to_read), dim_names) + ! set the start and nread values that will be passed as the read_data corner and edge_lengths arguments + start(:) = 1 + if (present(start_index)) start = start_index + + if (present(edge_lengths)) then + nread = edge_lengths + else + nread = shape(data) + endif + ! read the data + dim_unlim_size=0 + if (present(timelevel)) then + do i=1, num_var_dims + if (is_dimension_unlimited(fileobj_read, dim_names(i))) then + call get_dimension_size(fileobj_read, dim_names(i), dim_unlim_size) + endif + if (i .eq. 4) then + nread(i) = 1 + start(i) = timelevel + endif + enddo + if (dim_unlim_size .LE. 0) then + call MOM_error(WARNING, "MOM_io::MOM_read_data_4d_noDD: time level specified, but the variable "//& + trim(fieldName)// " does not have an unlimited dimension.") + call read_data(fileobj_read, trim(variable_to_read), data, corner=start, edge_lengths=nread) + else + call read_data(fileobj_read, trim(variable_to_read), data, corner=start, edge_lengths=nread, & + unlim_dim_level=timelevel) + endif + else + call read_data(fileobj_read, trim(variable_to_read), data, corner=start, edge_lengths=nread) + endif + ! scale the data + if (present(scale)) then ; if (scale /= 1.0) then + call scale_data(data, scale) + endif ; endif + ! close the file + if (close_the_file) then + if (check_if_open(fileobj_read)) call fms2_close_file(fileobj_read) + if (allocated(file_var_meta_noDD%var_names)) deallocate(file_var_meta_noDD%var_names) + file_var_meta_noDD%nvars = 0 + endif + if (allocated(dim_names)) deallocate(dim_names) +end subroutine MOM_read_data_4d_noDD + +!> This routine calls the fms_io read_data subroutine to read 2-D domain-decomposed data field named "fieldname" +!! from file "filename". The routine multiplies the data by "scale" if the optional argument is included in the call. +!!The supergrid variable axis lengths are determined from compute domain lengths, and +!! the domain indices are computed from the difference between the global and compute domain indices +subroutine MOM_read_data_2d_supergrid(filename, fieldname, data, domain, is_supergrid, start_index, edge_lengths, & + timelevel, scale, x_position, y_position, leave_file_open) + character(len=*), intent(in) :: filename !< The name of the file to read + character(len=*), intent(in) :: fieldname !< The variable name of the data in the file + real, dimension(:,:), intent(inout) :: data !< The 2-dimensional data array to pass to read_data + type(MOM_domain_type), intent(in) :: domain !< MOM domain attribute with the mpp_domain decomposition + logical, intent(in) :: is_supergrid !< flag indicating whether to use supergrid + integer, dimension(2), optional, intent(in) :: start_index !< starting indices of data buffer. Default is 1 + integer, dimension(2), optional, intent(in) :: edge_lengths !< number of data values to read in. + !! Default values are the variable dimension sizes + integer, optional, intent(in) :: timelevel !< time level to read + real, optional, intent(in):: scale !< A scaling factor that the field is multiplied by + integer, intent(in), optional :: x_position !< domain position of x-dimension; CENTER (default) or EAST_FACE + integer, intent(in), optional :: y_position !< domain position of y-dimension; CENTER (default) or NORTH_FACE + logical, optional, intent(in) :: leave_file_open !< if .true., leave file open + ! local + logical :: file_open_success !.true. if call to open_file is successful + logical :: variable_found ! .true. if lowercase(fieldname) matches one of the lowercase file variable names + logical :: close_the_file ! indicates whether to close the file after write_data is called; default is .true. + integer :: i, dim_unlim_size, npes, num_var_dims, first(2), last(2) + integer :: start(2), nread(2) ! indices for first data value and number of values to read + character(len=40), allocatable :: dim_names(:) ! variable dimension names + character(len=96) :: variable_to_read ! variable to read from the netcdf file + integer :: xpos, ypos, pos ! x and y domain positions + integer :: isc, iec, jsc, jec, isd, ied, jsd, jed, isg, ieg, jsg, jeg + integer :: xsize_c, ysize_c, xsize_d, ysize_d + real, allocatable :: array(:,:) ! dummy array to pass to read data + type(domain2D), pointer :: io_domain => NULL() + + xpos = CENTER + ypos = CENTER + if (present(x_position)) xpos = x_position + if (present(y_position)) ypos = y_position + + close_the_file = .true. + if (present(leave_file_open)) close_the_file = .not.(leave_file_open) + npes=-1; npes = mpp_get_domain_npes(domain%mpp_domain) + ! open the file + if (.not.(check_if_open(fileobj_read_dd))) then + ! define the io domain for 1-pe jobs because it is required to read domain-decomposed files + if (npes .eq. 1 ) then + if (.not. associated(mpp_get_io_domain(domain%mpp_domain))) & + call mpp_define_io_domain(domain%mpp_domain, (/1,1/)) + endif + file_open_success = fms2_open_file(fileobj_read_dd, filename, "read", domain%mpp_domain, is_restart=.false.) + file_var_meta_DD%nvars = get_num_variables(fileobj_read_dd) + if (file_var_meta_DD%nvars .lt. 1) call MOM_error(FATAL, "nvars is less than 1 for file "// & + trim(filename)) + if (.not.(allocated(file_var_meta_DD%var_names))) & + allocate(file_var_meta_DD%var_names(file_var_meta_DD%nvars)) + call get_variable_names(fileobj_read_dd, file_var_meta_DD%var_names) + endif + ! search for the variable in the file + variable_to_read = trim(fieldname) + variable_found = .false. + do i=1,file_var_meta_DD%nvars + if (trim(lowercase(file_var_meta_DD%var_names(i))) .eq. trim(lowercase(fieldname))) then + variable_found = .true. + variable_to_read = trim(file_var_meta_DD%var_names(i)) + exit + endif + enddo + if (.not.(variable_found)) call MOM_error(WARNING, "MOM_read_data_fms2:MOM_read_data_2d_supergrid: "//& + trim(fieldname)//" not found in "//trim(filename)) + + pos = CENTER + if (xpos .eq. NORTH_FACE) then + if (ypos .eq. EAST_FACE) then + pos = CORNER + else + pos = xpos + endif + elseif (ypos .eq. EAST_FACE) then + pos = ypos + endif + ! set the start and nread values that will be passed as the read_data corner and edge_lengths argument + num_var_dims = get_variable_num_dimensions(fileobj_read_dd, trim(variable_to_read)) + allocate(dim_names(num_var_dims)) + dim_names(:) = "" + call get_variable_dimension_names(fileobj_read_dd, trim(variable_to_read), dim_names) + ! get the IO domain + io_domain => mpp_get_io_domain(domain%mpp_domain) + ! register the variable axes + !call MOM_register_variable_axes(fileobj_read, trim(variable_to_read), io_domain, xPosition=xpos, yPosition=ypos) + call mpp_get_data_domain(domain%mpp_domain,isd,ied,jsd,jed,xsize=xsize_d,ysize=ysize_d,position=pos) + call mpp_get_global_domain(domain%mpp_domain,isg,ieg,jsg,jeg,position=pos) + call mpp_get_compute_domain(domain%mpp_domain,isc,iec,jsc,jec,position=pos) + ! get the start indices + start(:) = 1 + if (present(start_index)) then + start = start_index + else!if((size(data,1) .eq. xsize_d) .and. (size(data,2) .eq. ysize_d)) then ! on_data_domain + if (npes .gt. 1) then + start(1) = isc - isg + 1 + start(2) = jsc - jsg + 1 + else + if (iec-isc+1 .ne. ieg-isg+1) start(1) = isc - isg + 1 + if (jec-jsc+1 .ne. jeg-jsg+1) start(2) = jsc - jsg + 1 + endif + endif + ! get the values for the edge_lengths (nread) + nread = shape(data) + if (present(edge_lengths)) then + nread = edge_lengths + else!if((size(data,1) .eq. xsize_d) .and. (size(data,2) .eq. ysize_d)) then ! on_data_domain + if (npes .gt. 1) then + nread(1) = iec - isc + 1 + nread(2) = jec - jsc + 1 + else + if (iec-isc+1 .ne. ieg-isg+1) nread(1) = iec - isc + 1 + if (jec-jsc+1 .ne. jeg-jsg+1) nread(2) = jec - jsc + 1 + endif + endif + ! allocate the dummy array + if (.not. allocated(array)) allocate(array(size(data,1),size(data,2))) + ! read the data + dim_unlim_size=0 + if (present(timelevel)) then + do i=1,num_var_dims + if (is_dimension_unlimited(fileobj_read_dd, dim_names(i))) then + call get_dimension_size(fileobj_read_dd, dim_names(i), dim_unlim_size) + endif + enddo + if (dim_unlim_size .gt. 0) then + call read_data(fileobj_read_dd, trim(variable_to_read), array, corner=start, edge_lengths=nread, & + unlim_dim_level=timelevel) + else + call read_data(fileobj_read_dd, trim(variable_to_read), array, corner=start, edge_lengths=nread) + endif + else + call read_data(fileobj_read_dd, trim(variable_to_read), array, corner=start, edge_lengths=nread) + endif + if((size(array,1) .eq. xsize_d) .and. (size(array,2) .eq. ysize_d)) then ! on_data_domain + data(isc-isd+1:iec-isd+1,jsc-jsd+1:jec-jsd+1) = array(isc-isd+1:iec-isd+1,jsc-jsd+1:jec-jsd+1) + else + data = array + endif + ! scale the data + if (present(scale)) then ; if (scale /= 1.0) then + call scale_data(data, scale) + endif ; endif + ! close the file + if (close_the_file) then + if (check_if_open(fileobj_read_dd)) call fms2_close_file(fileobj_read_dd) + if (allocated(file_var_meta_DD%var_names)) deallocate(file_var_meta_DD%var_names) + file_var_meta_noDD%nvars = 0 + endif + if (allocated(dim_names)) deallocate(dim_names) + if (associated(io_domain)) nullify(io_domain) + if (allocated(array)) deallocate(array) +end subroutine MOM_read_data_2d_supergrid + + +!> This routine uses the fms2_io read_data interface to read a pair of distributed +!! 2-D data fields with names given by "[uv]_fieldname" from file "filename". Valid values for +!! "stagger" include CGRID_NE, BGRID_NE, and AGRID. +subroutine MOM_read_vector_2d_fms2(filename, u_fieldname, v_fieldname, u_data, v_data, MOM_Domain, & + use_fms2, timelevel, stagger, scale, leave_file_open) + character(len=*), intent(in) :: filename !< name of the netcdf file to read + character(len=*), intent(in) :: u_fieldname !< The variable name of the u data in the file + character(len=*), intent(in) :: v_fieldname !< The variable name of the v data in the file + real, dimension(:,:), intent(inout) :: u_data !< The 2 dimensional array into which the + !! u-component of the data should be read + real, dimension(:,:), intent(inout) :: v_data !< The 2 dimensional array into which the + !! v-component of the data should be read + type(MOM_domain_type), intent(in) :: MOM_Domain !< The MOM_Domain that describes the decomposition + logical, intent(in) :: use_fms2 !< flag indicating whether to use this routine + integer, optional, intent(in) :: timelevel !< The time level in the file to read + integer, optional, intent(in) :: stagger !< A flag indicating where this vector is discretized + real, optional, intent(in) :: scale !< A scaling factor that the fields are multiplied + !! by before they are returned. + logical, optional, intent(in) :: leave_file_open !< if .true., leave file open + ! local + integer :: is, ie, js, je, i, ndims, dim_unlim_index + integer :: u_pos, v_pos + integer, allocatable :: dim_sizes_u(:), dim_sizes_v(:) + character(len=32), allocatable :: dim_names_u(:), dim_names_v(:), units_u(:), units_v(:) + character(len=1) :: x_or_y ! orientation of cartesian coordinate axis + logical :: is_valid + logical :: file_open_success ! .true. if open file is successful + logical :: close_the_file ! indicates whether to close the file after MOM_read_vector is called; default is .true. + + close_the_file = .true. + if (present(leave_file_open)) close_the_file = .not.(leave_file_open) + + ! open the file + if (.not.(check_if_open(fileobj_read_dd))) & + file_open_success = fms2_open_file(fileobj_read_dd, filename, "read", MOM_domain%mpp_domain, is_restart=.false.) + if (.not. file_open_success) call MOM_error(FATAL, "MOM_read_vector_2d_fms2: netcdf file "//& + trim(filename)//" not opened.") + + u_pos = EAST_FACE ; v_pos = NORTH_FACE + if (present(stagger)) then + if (stagger == CGRID_NE .or. stagger == BGRID_NE ) then ; u_pos = EAST_FACE ; v_pos = NORTH_FACE + elseif (stagger == AGRID) then ; u_pos = CENTER ; v_pos = CENTER ; endif + endif + + ndims = get_variable_num_dimensions(fileobj_read_dd, u_fieldname) + allocate(dim_sizes_u(ndims)) + allocate(dim_sizes_v(ndims)) + allocate(dim_names_u(ndims)) + allocate(dim_names_v(ndims)) + allocate(units_u(ndims)) + allocate(units_v(ndims)) + + units_u(:) = "" + units_v(:) = "" + dim_names_u(:) = "" + dim_names_v(:) = "" + dim_sizes_u(:) = 0 + dim_sizes_v(:) = 0 + + call get_variable_size(fileobj_read_dd, u_fieldname, dim_sizes_u) + call get_variable_size(fileobj_read_dd, v_fieldname, dim_sizes_v) + call get_variable_dimension_names(fileobj_read_dd, u_fieldname, dim_names_u) + call get_variable_dimension_names(fileobj_read_dd, v_fieldname, dim_names_v) + + do i=1,ndims + ! register the u axes + if (.not.(is_dimension_registered(fileobj_read_dd, dim_names_u(i)))) then + call get_variable_units(fileobj_read_dd, dim_names_u(i), units_u(i)) + call validate_lat_lon_units(units_u(i), x_or_y, is_valid) + if (is_valid) then + call register_axis(fileobj_read_dd, dim_names_u(i), x_or_y, domain_position=u_pos) + else + call register_axis(fileobj_read_dd, dim_names_u(i), dim_sizes_u(i)) + endif + endif + ! Register the v axes if they differ from the u axes + if (trim(lowercase(dim_names_v(i))) .ne. trim(lowercase(dim_names_u(i)))) then + if (.not.(is_dimension_registered(fileobj_read_dd, dim_names_v(i)))) then + call get_variable_units(fileobj_read_dd, dim_names_v(i), units_v(i)) + call validate_lat_lon_units(units_v(i), x_or_y, is_valid) + if (is_valid) then + call register_axis(fileobj_read_dd, dim_names_v(i), x_or_y, domain_position=v_pos) + else + call register_axis(fileobj_read_dd, dim_names_v(i), dim_sizes_v(i)) + endif + endif + endif + enddo + ! read the data + dim_unlim_index = 0 + if (present(timelevel)) then + do i=1,ndims + if (is_dimension_unlimited(fileobj_read_dd, dim_names_u(i))) then + dim_unlim_index = i + exit + endif + enddo + if (dim_unlim_index .gt. 0) then + call read_data(fileobj_read_dd, u_fieldname,u_data, unlim_dim_level=timelevel) + call read_data(fileobj_read_dd, v_fieldname, v_data, unlim_dim_level=timelevel) + else + call read_data(fileobj_read_dd, u_fieldname, u_data) + call read_data(fileobj_read_dd, v_fieldname, v_data) + endif + else + call read_data(fileobj_read_dd, u_fieldname, u_data) + call read_data(fileobj_read_dd, v_fieldname, v_data) + endif + ! close the file + if (close_the_file) then + if (check_if_open(fileobj_read_dd)) call fms2_close_file(fileobj_read_dd) + endif + ! scale the data + if (present(scale)) then ; if (scale /= 1.0) then + call get_simple_array_i_ind(MOM_Domain, size(u_data,1), is, ie) + call get_simple_array_j_ind(MOM_Domain, size(u_data,2), js, je) + u_data(is:ie,js:je) = scale*u_data(is:ie,js:je) + call get_simple_array_i_ind(MOM_Domain, size(v_data,1), is, ie) + call get_simple_array_j_ind(MOM_Domain, size(v_data,2), js, je) + v_data(is:ie,js:je) = scale*v_data(is:ie,js:je) + endif ; endif + if (allocated(dim_names_u)) deallocate(dim_names_u) + if (allocated(dim_names_v)) deallocate(dim_names_v) + if (allocated(dim_sizes_u)) deallocate(dim_sizes_u) + if (allocated(dim_sizes_v)) deallocate(dim_sizes_v) + if (allocated(units_u)) deallocate(units_u) + if (allocated(units_v)) deallocate(units_v) +end subroutine MOM_read_vector_2d_fms2 + +!> This routine uses the fms2_io read_data interface to read a pair of distributed +!! 3-D data fields with names given by "[uv]_fieldname" from file "filename". Valid values for +!! "stagger" include CGRID_NE, BGRID_NE, and AGRID. +subroutine MOM_read_vector_3d_fms2(filename, u_fieldname, v_fieldname, u_data, v_data, MOM_Domain, & + use_fms2, timelevel, stagger, scale, leave_file_open) + character(len=*), intent(in) :: filename !< name of the netcdf file to read + character(len=*), intent(in) :: u_fieldname !< The variable name of the u data in the file + character(len=*), intent(in) :: v_fieldname !< The variable name of the v data in the file + real, dimension(:,:,:), intent(inout) :: u_data !< The 3 dimensional array into which the + !! u-component of the data should be read + real, dimension(:,:,:), intent(inout) :: v_data !< The 3 dimensional array into which the + !! v-component of the data should be read + type(MOM_domain_type), intent(in) :: MOM_Domain !< The MOM_Domain that describes the decomposition + logical, intent(in) :: use_fms2 !< flag indicating whether to call this routine + integer, optional, intent(in) :: timelevel !< The time level in the file to read + integer, optional, intent(in) :: stagger !< A flag indicating where this vector is discretized + real, optional, intent(in) :: scale !< A scaling factor that the fields are multiplied + !! by before they are returned. + logical, optional, intent(in) :: leave_file_open !< if .true., leave file open + ! local + integer :: is, ie, js, je, i, dim_unlim, ndims + integer :: u_pos, v_pos + integer, allocatable :: dim_sizes_u(:), dim_sizes_v(:) + character(len=32), allocatable :: dim_names_u(:), dim_names_v(:), units_u(:), units_v(:) + character(len=1) :: x_or_y + logical :: is_valid + logical :: file_open_success ! .true. if open file is successful + logical :: close_the_file ! indicates whether to close the file after MOM_read_vector is called; default is .true. + + close_the_file = .true. + if (present(leave_file_open)) close_the_file = .not.(leave_file_open) + + ! open the file + if (.not.(check_if_open(fileobj_read_dd))) then + file_open_success = fms2_open_file(fileobj_read_dd, filename, "read", MOM_domain%mpp_domain, is_restart=.false.) + if (.not. file_open_success) & + call MOM_error(FATAL, "MOM_read_vector_3d_fms2: netcdf file "//trim(filename)//" not opened.") + endif + + u_pos = EAST_FACE ; v_pos = NORTH_FACE + if (present(stagger)) then + if (stagger == CGRID_NE) then ; u_pos = EAST_FACE ; v_pos = NORTH_FACE + elseif (stagger == BGRID_NE) then ; u_pos = CORNER ; v_pos = CORNER + elseif (stagger == AGRID) then ; u_pos = CENTER ; v_pos = CENTER ; endif + endif + + ndims = get_variable_num_dimensions(fileobj_read_dd, u_fieldname) + allocate(dim_sizes_u(ndims)) + allocate(dim_sizes_v(ndims)) + allocate(dim_names_u(ndims)) + allocate(dim_names_v(ndims)) + allocate(units_u(ndims)) + allocate(units_v(ndims)) + + units_u(:) = "" + units_v(:) = "" + dim_names_u(:) = "" + dim_names_v(:) = "" + + call get_variable_size(fileobj_read_dd, u_fieldname, dim_sizes_u, broadcast=.true.) + call get_variable_size(fileobj_read_dd, v_fieldname, dim_sizes_v, broadcast=.true.) + call get_variable_dimension_names(fileobj_read_dd, u_fieldname, dim_names_u, broadcast=.true.) + call get_variable_dimension_names(fileobj_read_dd, v_fieldname, dim_names_v, broadcast=.true.) + + do i=1,ndims + ! register the u axes + if (.not.(is_dimension_registered(fileobj_read_dd, dim_names_u(i)))) then + call get_variable_units(fileobj_read_dd, dim_names_u(i), units_u(i)) + call validate_lat_lon_units(units_u(i), x_or_y, is_valid) + if (is_valid) then + call register_axis(fileobj_read_dd, dim_names_u(i), x_or_y, domain_position=u_pos) + else + call register_axis(fileobj_read_dd, dim_names_u(i), dim_sizes_u(i)) + endif + endif + ! Register the v axes if they differ from the u axes + if (trim(lowercase(dim_names_v(i))) .ne. trim(lowercase(dim_names_u(i)))) then + if (.not.(is_dimension_registered(fileobj_read_dd, dim_names_v(i)))) then + call get_variable_units(fileobj_read_dd, dim_names_v(i), units_v(i)) + call validate_lat_lon_units(units_v(i), x_or_y, is_valid) + if (is_valid) then + call register_axis(fileobj_read_dd, dim_names_v(i), x_or_y, domain_position=v_pos) + else + call register_axis(fileobj_read_dd, dim_names_v(i), dim_sizes_v(i)) + endif + endif + endif + enddo + ! read the data + dim_unlim = 0 + if (present(timelevel)) then + do i=1,ndims + if (is_dimension_unlimited(fileobj_read_dd, dim_names_u(i))) then + dim_unlim = i + exit + endif + enddo + if (dim_unlim .gt. 0) then + call read_data(fileobj_read_dd, u_fieldname, u_data, unlim_dim_level=timelevel) + call read_data(fileobj_read_dd, v_fieldname, v_data, unlim_dim_level=timelevel) + else + call read_data(fileobj_read_dd, u_fieldname, u_data, edge_lengths=dim_sizes_u) + call read_data(fileobj_read_dd, v_fieldname, v_data, edge_lengths=dim_sizes_v) + endif + else + call read_data(fileobj_read_dd, u_fieldname, u_data, edge_lengths=dim_sizes_u) + call read_data(fileobj_read_dd, v_fieldname, v_data, edge_lengths=dim_sizes_v) + endif + ! close the file + if (close_the_file) then + if (check_if_open(fileobj_read_dd)) call fms2_close_file(fileobj_read_dd) + endif + ! scale the data + if (present(scale)) then ; if (scale /= 1.0) then + call get_simple_array_i_ind(MOM_Domain, size(u_data,1), is, ie) + call get_simple_array_j_ind(MOM_Domain, size(u_data,2), js, je) + u_data(is:ie,js:je,:) = scale*u_data(is:ie,js:je,:) + call get_simple_array_i_ind(MOM_Domain, size(v_data,1), is, ie) + call get_simple_array_j_ind(MOM_Domain, size(v_data,2), js, je) + v_data(is:ie,js:je,:) = scale*v_data(is:ie,js:je,:) + endif ; endif + if (allocated(dim_names_u)) deallocate(dim_names_u) + if (allocated(dim_names_v)) deallocate(dim_names_v) + if (allocated(dim_sizes_u)) deallocate(dim_sizes_u) + if (allocated(dim_sizes_v)) deallocate(dim_sizes_v) + if (allocated(units_u)) deallocate(units_u) + if (allocated(units_v)) deallocate(units_v) +end subroutine MOM_read_vector_3d_fms2 + +!> apply a scale factor to a 1d array +subroutine scale_data_1d(data, scale_factor) + real, dimension(:), intent(inout) :: data !< The 1-dimensional data array + real, intent(in) :: scale_factor !< Scale factor + + if (scale_factor /= 1.0) then + data(:) = scale_factor*data(:) + endif +end subroutine scale_data_1d + +!> apply a scale factor to a 2d array +subroutine scale_data_2d(data, scale_factor, MOM_domain) + real, dimension(:,:), intent(inout) :: data !< The 2-dimensional data array + real, intent(in) :: scale_factor !< Scale factor + type(MOM_domain_type), optional, intent(in) :: MOM_Domain !< The domain that describes the decomposition + ! local + integer :: is, ie, js, je + + if (scale_factor /= 1.0) then + if (present(MOM_domain)) then + call get_simple_array_i_ind(MOM_Domain, size(data,1), is, ie) + call get_simple_array_j_ind(MOM_Domain, size(data,2), js, je) + data(is:ie,js:je) = scale_factor*data(is:ie,js:je) + else + data(:,:) = scale_factor*data(:,:) + endif + endif +end subroutine scale_data_2d + +!> apply a scale factor to a 3d array +subroutine scale_data_3d(data, scale_factor, MOM_domain) + real, dimension(:,:,:), intent(inout) :: data !< The 3-dimensional data array + real, intent(in) :: scale_factor !< Scale factor + type(MOM_domain_type), optional, intent(in) :: MOM_Domain !< The domain that describes the decomposition + ! local + integer :: is, ie, js, je + + if (scale_factor /= 1.0) then + if (present(MOM_domain)) then + call get_simple_array_i_ind(MOM_Domain, size(data,1), is, ie) + call get_simple_array_j_ind(MOM_Domain, size(data,2), js, je) + data(is:ie,js:je,:) = scale_factor*data(is:ie,js:je,:) + else + data(:,:,:) = scale_factor*data(:,:,:) + endif + endif +end subroutine scale_data_3d + +!> apply a scale factor to a 4d array +subroutine scale_data_4d(data, scale_factor, MOM_domain) + real, dimension(:,:,:,:), intent(inout) :: data !< The 4-dimensional data array + real, intent(in) :: scale_factor !< Scale factor + type(MOM_domain_type), optional, intent(in) :: MOM_Domain !< The domain that describes the decomposition + ! local + integer :: is, ie, js, je + + if (scale_factor /= 1.0) then + if (present(MOM_domain)) then + call get_simple_array_i_ind(MOM_Domain, size(data,1), is, ie) + call get_simple_array_j_ind(MOM_Domain, size(data,2), js, je) + data(is:ie,js:je,:,:) = scale_factor*data(is:ie,js:je,:,:) + else + data(:,:,:,:) = scale_factor*data(:,:,:,:) + endif + endif +end subroutine scale_data_4d + +!> check that latitude or longitude units are valid CF-compliant values +!! return true or false and x_or_y character value corresponding to the axis direction +subroutine validate_lat_lon_units(unit_string, x_or_y, units_are_valid) +character(len=*), intent(in) :: unit_string !< string of units +character(len=1), intent(out) :: x_or_y !< "x" for longitude or "y" latitude +logical, intent(out) :: units_are_valid !< .true. if units match acceptable values; default is .false. + +select case (lowercase(trim(unit_string))) + case ("degrees_north"); units_are_valid = .true.; x_or_y = "y" + case ("degree_north"); units_are_valid = .true.; x_or_y = "y" + case ("degrees_n"); units_are_valid = .true.; x_or_y = "y" + case ("degree_n"); units_are_valid = .true.; x_or_y = "y" + case ("degreen"); units_are_valid = .true.; x_or_y = "y" + case ("degreesn"); units_are_valid = .true.; x_or_y = "y" + case ("degrees_east"); units_are_valid = .true.; x_or_y = "x" + case ("degree_east"); units_are_valid = .true.;x_or_y = "x" + case ("degreese"); units_are_valid = .true.; x_or_y = "x" + case ("degreee"); units_are_valid = .true.; x_or_y = "x" + case ("degree_e"); units_are_valid = .true.; x_or_y = "x" + case ("degrees_e"); units_are_valid = .true.; x_or_y = "x" + case default; units_are_valid = .false.; x_or_y = "" +end select + +end subroutine validate_lat_lon_units + +end module MOM_read_data_fms2 diff --git a/src/framework/MOM_restart.F90 b/src/framework/MOM_restart.F90 index ed29b99b55..07c054351a 100644 --- a/src/framework/MOM_restart.F90 +++ b/src/framework/MOM_restart.F90 @@ -2,34 +2,47 @@ module MOM_restart ! This file is part of MOM6. See LICENSE.md for the license. - -use MOM_domains, only : pe_here, num_PEs use MOM_error_handler, only : MOM_error, FATAL, WARNING, NOTE, is_root_pe use MOM_file_parser, only : get_param, log_param, log_version, param_file_type -use MOM_string_functions, only : lowercase +use MOM_string_functions, only : lowercase, append_substring use MOM_grid, only : ocean_grid_type use MOM_io, only : create_file, fieldtype, file_exists, open_file, close_file -use MOM_io, only : MOM_read_data, read_data, get_filename_appendix +use MOM_io, only : MOM_read_data, read_data, get_filename_appendix ! NOTE get_filename_appendix is not in fms2-io use MOM_io, only : get_file_info, get_file_atts, get_file_fields, get_file_times use MOM_io, only : vardesc, var_desc, query_vardesc, modify_vardesc use MOM_io, only : MULTIPLE, NETCDF_FILE, READONLY_FILE, SINGLE_FILE use MOM_io, only : CENTER, CORNER, NORTH_FACE, EAST_FACE +use MOM_axis, only : get_time_units, convert_checksum_to_string +use MOM_axis, only : axis_data_type, MOM_get_diagnostic_axis_data +use MOM_axis, only : MOM_register_diagnostic_axis, get_var_dimension_metadata use MOM_time_manager, only : time_type, time_type_to_real, real_to_time use MOM_time_manager, only : days_in_month, get_date, set_date use MOM_transform_FMS, only : mpp_chksum => rotated_mpp_chksum use MOM_transform_FMS, only : write_field => rotated_write_field use MOM_verticalGrid, only : verticalGrid_type +use mpp_domains_mod, only: mpp_define_io_domain, mpp_get_domain_npes, mpp_get_io_domain +use mpp_domains_mod, only: mpp_get_compute_domain, mpp_get_global_domain use mpp_io_mod, only : mpp_attribute_exist, mpp_get_atts -use mpp_mod, only : mpp_pe - +use mpp_mod, only: mpp_pe, mpp_max +! fms2-io interfaces +use fms2_io_mod, only : fms2_register_restart_field => register_restart_field +use fms2_io_mod, only : check_if_open, is_dimension_registered, register_field, register_axis +use fms2_io_mod, only : register_variable_attribute, read_data, read_restart, write_restart +use fms2_io_mod, only : write_data, fms2_close_file=>close_file, fms2_open_file=>open_file +use fms2_io_mod, only : global_att_exists, get_global_attribute, get_global_io_domain_indices +use fms2_io_mod, only : get_dimension_names, get_dimension_size, get_num_dimensions, variable_exists +use fms2_io_mod, only : dimension_exists, FmsNetcdfDomainFile_t, unlimited, get_variable_size +use fms2_io_mod, only : get_variable_num_dimensions, get_variable_dimension_names + +use platform_mod implicit none ; private public restart_init, restart_end, restore_state, register_restart_field public save_restart, query_initialized, restart_init_end, vardesc public restart_files_exist, determine_is_new_run, is_new_run public register_restart_field_as_obsolete +public write_initial_conditions public register_restart_pair - !> A type for making arrays of pointers to 4-d arrays type p4d real, dimension(:,:,:,:), pointer :: p => NULL() !< A pointer to a 4d array @@ -848,8 +861,32 @@ function query_initialized_4d_name(f_ptr, name, CS) result(query_initialized) end function query_initialized_4d_name +!> wrapper routine for save_restart_old, save_restart_fms2, and write_initial_conditions_file +subroutine save_restart(directory, time, G, CS, time_stamped, filename, GV, use_fms2, write_ic) + character(len=*), intent(in) :: directory !< The directory where the restart files + !! are to be written + type(time_type), intent(in) :: time !< The current model time + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure + type(MOM_restart_CS), pointer :: CS !< The control structure returned by a previous + !! call to restart_init. + logical, optional, intent(in) :: time_stamped !< If present and true, add time-stamp + !! to the restart file names. + character(len=*), optional, intent(in) :: filename !< A filename that overrides the name in CS%restartfile. + type(verticalGrid_type), optional, intent(in) :: GV !< The ocean's vertical grid structure + logical, optional, intent(in) :: use_fms2 !< flag to call save_restart_fms2 + logical, optional, intent(in) :: write_ic !< flag to call write_initial_conditions + + if (present(write_ic) .and. write_ic) then + call write_initial_conditions(directory, time, G, CS, time_stamped=time_stamped, filename=filename, GV=GV) + elseif (present(use_fms2) .and. use_fms2) then + call save_restart_fms2(directory, time, G, CS, time_stamped=time_stamped, filename=filename, GV=GV) + else + call save_restart_old(directory, time, G, CS, time_stamped=time_stamped, filename=filename, GV=GV) + endif +end subroutine save_restart + !> save_restart saves all registered variables to restart files. -subroutine save_restart(directory, time, G, CS, time_stamped, filename, GV) +subroutine save_restart_old(directory, time, G, CS, time_stamped, filename, GV) character(len=*), intent(in) :: directory !< The directory where the restart files !! are to be written type(time_type), intent(in) :: time !< The current model time @@ -1056,12 +1093,488 @@ subroutine save_restart(directory, time, G, CS, time_stamped, filename, GV) num_files = num_files+1 enddo -end subroutine save_restart +end subroutine save_restart_old + +!> save all registered variables to a restart file using fms2-io +subroutine save_restart_fms2(directory, time, G, CS, time_stamped, filename, GV) + character(len=*), intent(in) :: directory !< The directory where the restart files + !! are to be written + type(time_type), intent(in) :: time !< The current model time + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure + type(MOM_restart_CS), pointer :: CS !< The control structure returned by a previous + !! call to restart_init. + logical, optional, intent(in) :: time_stamped !< If present and true, add time-stamp + !! to the restart file names. + character(len=*), optional, intent(in) :: filename !< A filename that overrides the name in CS%restartfile. + type(verticalGrid_type), optional, intent(in) :: GV !< The ocean's vertical grid structure + + ! Local variables + type(vardesc) :: vars(CS%max_fields) ! Descriptions of the fields that + ! are to be read from the restart file. + type(fieldtype) :: fields(CS%max_fields) ! + type(FmsNetcdfDomainFile_t) :: fileObjWrite ! netcdf file object returned by a call to open_file + character(len=1024) :: restartpath ! The restart file path (dir/file). + character(len=512) :: restartname ! The restart file name (no dir). + character(len=700) :: restartpath_temp ! temporary location for the restart file path (dir/file). + character(len=600) :: restartname_temp ! temporary location for restart name + character(len=512) :: base_file_name ! Temporary location for restart file name (no dir) + character(len=8) :: suffix ! A suffix (like _2) that is appended + ! to the name of files after the first. + integer(kind=8) :: var_sz, size_in_file ! The size in bytes of each variable + ! and the variables already in a file. + integer(kind=8) :: max_file_size = 2147483647_8 ! The maximum size in bytes + ! for any one file. With NetCDF3, + ! this should be 2 Gb or less. + integer :: start_var, next_var ! The starting variables of the + ! current and next files. + integer :: unit ! The mpp unit of the open file. + integer :: m, nz, i, k, num_files + integer :: seconds, days, year, month, hour, minute + character(len=8) :: hor_grid, z_grid, t_grid ! Variable grid info. + character(len=8) :: t_grid_read + character(len=64) :: var_name ! A variable's name. + character(len=256) :: date_appendix ! date string to append to a file name if desired + character(len=64) :: dim_names(4) ! Array to hold up to 4 strings for the variable axis names + integer, dimension(4) :: dim_lengths ! Array of integer lengths corresponding to the name(s) in axis_names + integer :: name_length + integer(kind=8) :: check_val(CS%max_fields,1) + integer :: is, ie + integer :: substring_index + integer :: horgrid_position + integer :: num_dims, total_axes + integer :: var_periods + logical :: fileOpenSuccess ! true if netcdf file is opened + real :: restart_time + character(len=32) :: filename_appendix = '' ! fms appendix to filename for ensemble runs + character(len=16) :: restart_time_units + character(len=64) :: checksum_char + character(len=64) :: units + character(len=256) :: longname + real, dimension(:), allocatable :: data_temp + type(axis_data_type) :: axis_data_CS + integer :: isL, ieL, jsL, jeL, pos + integer :: turns + + turns = CS%turns + + if (.not.associated(CS)) call MOM_error(FATAL, "MOM_restart " // & + "save_restart_fms2: Module must be initialized before it is used.") + if (CS%novars > CS%max_fields) call restart_error(CS) + + ! With parallel read & write, it is possible to disable the following... + + ! The maximum file size is 4294967292, according to the NetCDF documentation. + if (CS%large_file_support) max_file_size = 4294967292_8 + + horgrid_position = 1 + name_length = 0 + num_files = 0 + restartname = "" + base_file_name = "" + restartname_temp = "" + date_appendix = "" + restart_time_units = "" + + ! define the io domain for 1-pe jobs because it is required to write domain-decomposed files + if (mpp_get_domain_npes(G%domain%mpp_domain) .eq. 1 ) then + if (.not. associated(mpp_get_io_domain(G%domain%mpp_domain))) & + call mpp_define_io_domain(G%domain%mpp_domain, (/1,1/)) + endif + ! get the number of vertical levels + nz = 1 ; if (present(GV)) nz = GV%ke + + if (present(filename)) then + base_file_name = trim(filename) + else + base_file_name=trim(CS%restartfile) + endif + ! append a time stamp to the file name if time_stamp is specified + if (PRESENT(time_stamped)) then + if (time_stamped) then + call get_date(time,year,month,days,hour,minute,seconds) + ! Compute the year-day, because I don't like months. - RWH + do m=1,month-1 + days = days + days_in_month(set_date(year,m,2,0,0,0)) + enddo + seconds = seconds + 60*minute + 3600*hour + if (year <= 9999) then + write(date_appendix,'("_Y",I4.4,"_D",I3.3,"_S",I5.5)') year, days, seconds + elseif (year <= 99999) then + write(date_appendix,'("_Y",I5.5,"_D",I3.3,"_S",I5.5)') year, days, seconds + else + write(date_appendix,'("_Y",I10.10,"_D",I3.3,"_S",I5.5)') year, days, seconds + endif + restartname_temp = trim(base_file_name)//trim(date_appendix) + endif + else + restartname_temp = trim(base_file_name) + endif + + ! get the restart time units + restart_time = time_type_to_real(time) / 86400.0 + restart_time_units = "days" + next_var = 1 + do while (next_var <= CS%novars ) + start_var = next_var + ! get variable sizes in bytes + size_in_file = 8*(2*G%Domain%niglobal+2*G%Domain%njglobal+2*nz+1000) + + do m=start_var,CS%novars + call query_vardesc(CS%restart_field(m)%vars, hor_grid=hor_grid, & + z_grid=z_grid, t_grid=t_grid, caller="save_restart") + if (hor_grid == '1') then + var_sz = 8 + else + var_sz = 8*(G%Domain%niglobal+1)*(G%Domain%njglobal+1) + endif + select case (z_grid) + case ('L') ; var_sz = var_sz * nz + case ('i') ; var_sz = var_sz * (nz+1) + end select + t_grid = adjustl(t_grid) + if (t_grid(1:1) == 'p') then + if (len_trim(t_grid(2:8)) > 0) then + var_periods = -1 + t_grid_read = adjustl(t_grid(2:8)) + read(t_grid_read,*) var_periods + if (var_periods > 1) var_sz = var_sz * var_periods + endif + endif + + if ((m==start_var) .OR. (size_in_file < max_file_size-var_sz)) then + size_in_file = size_in_file + var_sz + else ; exit + endif + + enddo + next_var = m + + restartpath = "" + restartpath_temp = "" + suffix = "" + + !query fms_io if there is a filename_appendix (for ensemble runs) + ! TODO move filename_appendix functionality to fms2-io or MOM6 framework + name_length = len_trim(restartname_temp) + call get_filename_appendix(filename_appendix) + if (len_trim(filename_appendix) > 0) then + if (restartname_temp(name_length-2:name_length) == '.nc') then + restartname = restartname_temp(1:name_length-3)//'.'//trim(filename_appendix)//'.nc' + else + if (trim(filename_appendix) .ne. " ") then + restartname = restartname_temp(1:name_length) //'.'//trim(filename_appendix) + else + restartname(1:name_length) = trim(restartname_temp) + endif + endif + else + restartname(1:name_length) = trim(restartname_temp) + endif + + if (num_files < 10) then + write(suffix,'("_",I1)') num_files + else + write(suffix,'("_",I2)') num_files + endif + + if (num_files .gt. 0) then + name_length = len_trim(directory//restartname//suffix) + restartpath_temp = trim(directory)//trim(restartname)//trim(suffix) + else + name_length = len_trim(directory//restartname) + restartpath_temp = trim(directory)//trim(restartname) + endif + ! append '.nc' to the restart file path if it is missing + substring_index = index(trim(restartpath_temp), ".nc") + if (substring_index <= 0) then + restartpath = append_substring(restartpath_temp,".nc") + else + restartpath(1:len_trim(restartpath_temp)) = trim(restartpath_temp) + endif + ! create the file and register and write the global axes to the file + if (present(GV)) then + call create_file(trim(restartpath), fileObjWrite, CS%restart_field%vars, CS%novars, register_time=.true., & + G=G, GV=GV, is_restart=.true.) + else + call create_file(trim(restartpath), fileObjWrite, CS%restart_field%vars, CS%novars, register_time=.true., & + G=G, is_restart=.true.) + endif + ! register the time data + if (.not. variable_exists(fileObjWrite, "Time")) then + call register_field(fileObjWrite, "Time", "double", dimensions=(/"Time"/)) + call register_variable_attribute(fileObjWrite, "Time", "units", restart_time_units) + endif + + do m=start_var,next_var-1 + vars(m-start_var+1) = CS%restart_field(m)%vars + enddo + + call query_vardesc(vars(1), t_grid=t_grid, hor_grid=hor_grid, caller="save_restart") + + t_grid = adjustl(t_grid) + if (t_grid(1:1) /= 'p') & + call modify_vardesc(vars(1), t_grid='s', caller="save_restart") + select case (hor_grid) + case ('q') ; pos = CORNER + case ('h') ; pos = CENTER + case ('u') ; pos = EAST_FACE + case ('v') ; pos = NORTH_FACE + case ('Bu') ; pos = CORNER + case ('T') ; pos = CENTER + case ('Cu') ; pos = EAST_FACE + case ('Cv') ; pos = NORTH_FACE + case ('1') ; pos = 0 + case default ; pos = 0 + end select + !Prepare the checksum of the restart fields to be written to restart files + if (modulo(turns, 2) /= 0) then + call get_checksum_loop_ranges(G, pos, jsL, jeL, isL, ieL) + else + call get_checksum_loop_ranges(G, pos, isL, ieL, jsL, jeL) + endif + + do m=start_var,next_var-1 + if (associated(CS%var_ptr3d(m)%p)) then + check_val(m-start_var+1,1) = & + mpp_chksum(CS%var_ptr3d(m)%p(isL:ieL,jsL:jeL,:), turns=-turns) + elseif (associated(CS%var_ptr2d(m)%p)) then + check_val(m-start_var+1,1) = & + mpp_chksum(CS%var_ptr2d(m)%p(isL:ieL,jsL:jeL), turns=-turns) + elseif (associated(CS%var_ptr4d(m)%p)) then + check_val(m-start_var+1,1) = & + mpp_chksum(CS%var_ptr4d(m)%p(isL:ieL,jsL:jeL,:,:), turns=-turns) + elseif (associated(CS%var_ptr1d(m)%p)) then + check_val(m-start_var+1,1) = mpp_chksum(CS%var_ptr1d(m)%p) + elseif (associated(CS%var_ptr0d(m)%p)) then + check_val(m-start_var+1,1) = mpp_chksum(CS%var_ptr0d(m)%p,pelist=(/mpp_pe()/)) + endif + enddo + + do m=start_var,next_var-1 + longname = "" + num_dims = 0 + units = "" + dim_names(:) = "" + if (.not.(variable_exists(fileObjWrite, CS%restart_field(m)%var_name))) then + call query_vardesc(vars(m-start_var+1), hor_grid=hor_grid, & + z_grid=z_grid, t_grid=t_grid, longname=longname, & + units=units, caller="save_restart") + + call get_var_dimension_metadata(hor_grid, z_grid, t_grid, & + dim_names, dim_lengths, num_dims, G=G, GV=GV) + ! register the restart variables to the file + if (associated(CS%var_ptr3d(m)%p)) then + call fms2_register_restart_field(fileObjWrite, CS%restart_field(m-start_var+1)%var_name, & + CS%var_ptr3d(m)%p, dimensions=dim_names(1:num_dims)) + elseif (associated(CS%var_ptr2d(m)%p)) then + call fms2_register_restart_field(fileObjWrite, CS%restart_field(m-start_var+1)%var_name, & + CS%var_ptr2d(m)%p, dimensions=dim_names(1:num_dims)) + elseif (associated(CS%var_ptr4d(m)%p)) then + call fms2_register_restart_field(fileObjWrite, CS%restart_field(m-start_var+1)%var_name, & + CS%var_ptr4d(m)%p, dimensions=dim_names(1:num_dims)) + elseif (associated(CS%var_ptr1d(m)%p)) then + ! need to pass dim_names argument as a 1-D array + call fms2_register_restart_field(fileObjWrite, CS%restart_field(m-start_var+1)%var_name, & + CS%var_ptr1d(m)%p, dimensions=(/dim_names(1:num_dims)/)) + elseif (associated(CS%var_ptr0d(m)%p)) then + ! need to pass dim_names argument as a 1-D array + call fms2_register_restart_field(fileObjWrite, CS%restart_field(m-start_var+1)%var_name, & + CS%var_ptr0d(m)%p, dimensions=(/dim_names(1:num_dims)/)) + endif + ! convert the checksum to a string + checksum_char = '' + checksum_char = convert_checksum_to_string(check_val(m,1)) + !! register the variable attributes + !call register_variable_attribute(fileObjWrite, CS%restart_field(m-start_var+1)%var_name, & + ! 'checksum', trim(checksum_char)) + call register_variable_attribute(fileObjWrite, CS%restart_field(m-start_var+1)%var_name, & + 'units', units) + call register_variable_attribute(fileObjWrite, CS%restart_field(m-start_var+1)%var_name, & + 'long_name', longname) + endif + enddo + ! write the time data + call write_data(fileObjWrite, "Time", (/restart_time/)) + ! write the restart file + call write_restart(fileObjWrite) + ! close the file + if (check_if_open(fileObjWrite)) call fms2_close_file(fileObjWrite) + + if (associated(axis_data_CS%axis)) deallocate(axis_data_CS%axis) + if (associated(axis_data_CS%data)) deallocate(axis_data_CS%data) + + num_files = num_files+1 + enddo + +end subroutine save_restart_fms2 + +!> write initial condition fields to a netCDF file +subroutine write_initial_conditions(directory, time, G, CS, time_stamped, filename, GV) + character(len=*), intent(in) :: directory !< The directory where the restart files + !! are to be written + type(time_type), intent(in) :: time !< The current model time + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure + type(MOM_restart_CS), pointer :: CS !< The control structure returned by a previous + !! call to restart_init. + logical, optional, intent(in) :: time_stamped !< If present and true, add time-stamp + !! to the restart file names. + character(len=*), optional, intent(in) :: filename !< A filename that overrides the name in CS%restartfile. + type(verticalGrid_type), optional, intent(in) :: GV !< The ocean's vertical grid structure + ! local + type(vardesc) :: vd ! structure for variable metadata + type(FmsNetcdfDomainFile_t) :: fileObjWrite ! netCDF file object returned by call to open_file + type(axis_data_type) :: axis_data_CS ! structure for coordinate variable metadata + integer :: substring_index + integer :: name_length + integer :: num_dims ! counter for variable dimensions + integer :: total_axes ! counter for all coordinate axes in file + integer :: i, is, ie, k, m, isc, jsc, iec, jec, isg, jsg, ieg, jeg + integer :: var_periods + integer, dimension(4) :: dim_lengths + integer, allocatable :: pos(:),first(:,:), last(:,:) + logical :: fileOpenSuccess ! .true. if netcdf file is opened + character(len=200) :: base_file_name + character(len=200) :: dim_names(4) + character(len=20) :: time_units + character(len=64) :: units + character(len=256) :: longname + character(len=8) :: hor_grid, z_grid, t_grid ! Variable grid info. + real :: ic_time + real, dimension(:), allocatable :: data_temp + + ! define the io domain for 1-pe jobs because it is required to write domain-decomposed files + if (mpp_get_domain_npes(G%domain%mpp_domain) .eq. 1 ) then + if (.not. associated(mpp_get_io_domain(G%domain%mpp_domain))) & + call mpp_define_io_domain(G%domain%mpp_domain, (/1,1/)) + endif + ! append '.nc' to the restart file name if it is missing + ! TODO: require users to specify full file path including the file name appendix + ! in calls to open_file + substring_index = index(trim(filename), ".nc") + if (substring_index <= 0) then + base_file_name = append_substring(trim(directory)//trim(filename),".nc") + else + name_length = len(trim(directory)//trim(filename)) + base_file_name(1:name_length) = trim(directory)//trim(filename) + endif + ! get the time units + ic_time = time_type_to_real(time) / 86400.0 + time_units = get_time_units(ic_time*86400.0) + ! create the file and register and write the global axes to the file + if (present(GV)) then + call create_file(trim(base_file_name), fileObjWrite, CS%restart_field%vars, CS%novars, register_time=.true., & + G=G, GV=GV) + else + call create_file(trim(base_file_name), fileObjWrite, CS%restart_field%vars, CS%novars, register_time=.true., G=G) + endif + ! register the time data + if (.not. variable_exists(fileObjWrite, "Time")) then + call register_field(fileObjWrite, "Time", "double", dimensions=(/"Time"/)) + call register_variable_attribute(fileObjWrite, "Time", "units", time_units) + endif + ! allocate position indices for x- and y-dimensions associated with variables + allocate(pos(CS%novars)) + allocate(first(CS%novars,2)); allocate(last(CS%novars,2)); + first(:,:) = 0; last(:,:) = 0 + pos(:) = CENTER + ! register and write the field variables to the initial conditions file + do m=1,CS%novars + longname = "" + num_dims = 0 + units = "" + dim_names(:) = "" + + call query_vardesc(CS%restart_field(m)%vars, hor_grid=hor_grid, & + z_grid=z_grid, t_grid=t_grid, longname=longname, & + units=units, caller="save_restart") + + call get_var_dimension_metadata(hor_grid, z_grid, t_grid, & + dim_names, dim_lengths, num_dims, G=G, GV=GV) + select case (hor_grid) + case ('q') ; pos(m) = CORNER + case ('h') ; pos(m) = CENTER + case ('u') ; pos(m) = EAST_FACE + case ('v') ; pos(m) = NORTH_FACE + case ('Bu') ; pos(m) = CORNER + case ('T') ; pos(m) = CENTER + case ('Cu') ; pos(m) = EAST_FACE + case ('Cv') ; pos(m) = NORTH_FACE + case ('1') ; pos(m) = 0 + case default ; pos(m)= 0 + end select + ! register the variables + if (associated(CS%var_ptr3d(m)%p)) then + call register_field(fileObjWrite, CS%restart_field(m)%var_name, "double", & + dimensions=dim_names(1:num_dims)) + elseif (associated(CS%var_ptr2d(m)%p)) then + call register_field(fileObjWrite, CS%restart_field(m)%var_name, "double", & + dimensions=dim_names(1:num_dims)) + elseif (associated(CS%var_ptr4d(m)%p)) then + call register_field(fileObjWrite, CS%restart_field(m)%var_name, "double", & + dimensions=dim_names(1:num_dims)) + elseif (associated(CS%var_ptr1d(m)%p)) then + ! need to explicitly define dim_names array for 1-D variable + call register_field(fileObjWrite, CS%restart_field(m)%var_name, "double", & + dimensions=(/dim_names(1)/)) + elseif (associated(CS%var_ptr0d(m)%p)) then + ! need to explicitly define dim_names array for scalar variable + call register_field(fileObjWrite, CS%restart_field(m)%var_name, "double", & + dimensions=(/dim_names(1)/)) + endif + ! register the variable attributes + call register_variable_attribute(fileObjWrite, CS%restart_field(m)%var_name, "units", units) + call register_variable_attribute(fileObjWrite, CS%restart_field(m)%var_name, "long_name", longname) + enddo + + do m=1,CS%novars + if (associated(CS%var_ptr3d(m)%p)) then + call write_data(fileObjWrite, CS%restart_field(m)%var_name, CS%var_ptr3d(m)%p, & + unlim_dim_level=1) + elseif (associated(CS%var_ptr2d(m)%p)) then + call write_data(fileObjWrite, CS%restart_field(m)%var_name, CS%var_ptr2d(m)%p, & + unlim_dim_level=1) + elseif (associated(CS%var_ptr4d(m)%p)) then + call write_data(fileObjWrite, CS%restart_field(m)%var_name, CS%var_ptr4d(m)%p, & + unlim_dim_level=1) + elseif (associated(CS%var_ptr1d(m)%p)) then + call write_data(fileObjWrite, CS%restart_field(m)%var_name, CS%var_ptr1d(m)%p, & + unlim_dim_level=1) + elseif (associated(CS%var_ptr0d(m)%p)) then + call write_data(fileObjWrite, CS%restart_field(m)%var_name,CS%var_ptr0d(m)%p) + endif + enddo + ! write the time data + call write_data(fileObjWrite, "Time", (/ic_time/)) + ! close the IC file and deallocate the allocatable arrays + if(check_if_open(fileObjWrite)) call fms2_close_file(fileObjWrite) + + if (associated(axis_data_CS%axis)) deallocate(axis_data_CS%axis) + if (associated(axis_data_CS%data)) deallocate(axis_data_CS%data) + deallocate(pos); deallocate(first); deallocate(last) +end subroutine write_initial_conditions + +!> wrapper routine for restore_state_old and restore_state_fms2 +subroutine restore_state(filename, directory, day, G, CS, use_fms2) + character(len=*), intent(in) :: filename !< The list of restart file names or a single + !! character 'r' to read automatically named files. + character(len=*), intent(in) :: directory !< The directory in which to find restart files + type(time_type), intent(out) :: day !< The time of the restarted run + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(MOM_restart_CS), pointer :: CS !< The control structure returned by a previous + !! call to restart_init. + logical, optional, intent(in) :: use_fms2 !< if .true., call restore_state_fms2 + + if (present(use_fms2) .and. use_fms2) then + call restore_state_fms2(filename, directory, day, G, CS) + else + call restore_state_old(filename, directory, day, G, CS) + endif +end subroutine restore_state !> restore_state reads the model state from previously generated files. All !! restart variables are read from the first file in the input filename list !! in which they are found. -subroutine restore_state(filename, directory, day, G, CS) +subroutine restore_state_old(filename, directory, day, G, CS) character(len=*), intent(in) :: filename !< The list of restart file names or a single !! character 'r' to read automatically named files. character(len=*), intent(in) :: directory !< The directory in which to find restart files @@ -1282,9 +1795,202 @@ subroutine restore_state(filename, directory, day, G, CS) endif enddo -end subroutine restore_state +end subroutine restore_state_old + +!> restore_state_fms2 reads the model state from previously generated files using fms2-io. All +!! restart variables are read from the first file in the input filename list +!! in which they are found. +subroutine restore_state_fms2(filename, directory, day, G, CS) + character(len=*), intent(in) :: filename !< The list of restart file names or a single + !! character 'r' to read automatically named files. + character(len=*), intent(in) :: directory !< The directory in which to find restart files + type(time_type), intent(out) :: day !< The time of the restarted run + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(MOM_restart_CS), pointer :: CS !< The control structure returned by a previous + !! call to restart_init. + + ! This subroutine reads the model state from previously + ! generated files. All restart variables are read from the first + ! file in the input filename list in which they are found. + ! Local variables + character(len=200) :: filepath ! The path (dir/file) to the file being opened. + character(len=80) :: fname ! The name of the current file. + character(len=8) :: suffix ! A suffix (like "_2") that is added to any + ! additional restart files. + character(len=512) :: mesg ! A message for warnings. + character(len=80) :: varname ! A variable's name. + integer :: i, m, n + integer :: isL, ieL, jsL, jeL, is0, js0 + integer :: ntime, pos + character(len=200) :: unit_path(CS%max_fields) ! The file names. + logical :: unit_is_global(CS%max_fields) ! True if the file is global. + character(len=200) :: base_file_name + character(len=1024) :: temp_file_name + character(len=8) :: hor_grid, z_grid, t_grid ! Variable grid info. + real :: t1, t2 ! Two times. + real, allocatable :: time_vals(:) + logical :: check_exist, is_there_a_checksum + integer(l8_kind),dimension(3) :: checksum_file + integer(kind=8) :: checksum_data + integer :: missing_fields + logical :: fileOpenSuccess ! .true. if netcdf file object is opened + type(FmsNetcdfDomainFile_t) :: fileObjRead ! netcdf file object returned by open_file + integer :: str_index, num_file, is,ie,js,je + character(len=64) :: checksum_char, time_units + character(len=20), dimension(:), allocatable :: axis_names + character(len=32) :: dim_names(4) + integer :: dim_lengths(4), num_dims, dim_size + + if (.not.associated(CS)) call MOM_error(FATAL, "MOM_restart " // & + "restore_state: Module must be initialized before it is used.") + if (CS%novars > CS%max_fields) call restart_error(CS) + ! define the io domain if using 1 pe and the io domain is not set + if (mpp_get_domain_npes(G%domain%mpp_domain) .eq. 1 ) then + if (.not. associated(mpp_get_io_domain(G%domain%mpp_domain))) & + call mpp_define_io_domain(G%domain%mpp_domain, (/1,1/)) + endif + + str_index = 0 + ! get the base restart file name + temp_file_name='' + if ((LEN_TRIM(filename) == 1 .and. filename(1:1) == 'F') .or. (trim(filename)=='r')) then + temp_file_name = trim(CS%restartfile) + else + temp_file_name = trim(filename) + endif + ! append '.nc.' to the file name if it is missing + base_file_name = "" + str_index = INDEX(temp_file_name, ".nc") + if (str_index <=0) then + base_file_name = trim(append_substring(temp_file_name, ".nc")) + else + base_file_name = trim(temp_file_name) + endif + + num_file = get_num_restart_files(temp_file_name, directory, G, CS, file_paths=unit_path) + CS%restart_field(:)%initialized = .false. + ! Read each variable from the first file in which it is found. + do n=1,num_file + ! Open the restart file. + if (.not.(check_if_open(fileObjRead))) & + fileOpenSuccess=fms2_open_file(fileObjRead, trim(unit_path(n)), "read", & + G%domain%mpp_domain, is_restart=.true.) + if (fileOpenSuccess) & + call MOM_error(NOTE, "MOM_restart_fms2: MOM run restarted using : "//trim(unit_path(n))) + + call get_dimension_size(fileObjRead, "Time", ntime) + + if (ntime .lt. 1) then + call MOM_error(NOTE, "MOM_restart_fms2: time is scalar.") + ntime=1 + endif + allocate(time_vals(ntime)) + call read_data(fileObjRead, "Time", time_vals) + t1 = time_vals(1) + deallocate(time_vals) + t2 = t1 + call mpp_max(t2) + if (t1 .ne. t2) then + call MOM_error(FATAL, "times are different in different restart files.") + endif + + day = real_to_time(t1*86400.0) + ! Register the horizontal axes that correspond to x and y of the domain. + num_dims=get_num_dimensions(fileObjRead) + allocate(axis_names(num_dims)) + axis_names(:)= "" + call get_dimension_names(fileObjRead, axis_names) + do i = 1,num_dims + call get_dimension_size(fileObjRead, trim(axis_names(i)), dim_size) + call MOM_register_diagnostic_axis(fileObjRead, trim(axis_names(i)), dim_size) + enddo + ! Read in each variable from the restart files. + missing_fields = 0 + do m = 1, CS%novars + varname = '' + varname = trim(CS%restart_field(m)%var_name) + ! Check for obsolete fields + do i = 1,CS%num_obsolete_vars + if (adjustl(lowercase(trim(varname))) .eq. adjustl(lowercase(trim(CS%restart_obsolete(i)%field_name)))) then + call MOM_error(FATAL, "MOM_restart:restore_state_fms2: Attempting to use obsolete restart field "//& + trim(varname)//" - the new corresponding restart field is "//& + trim(CS%restart_obsolete(i)%replacement_name)) + endif + enddo + + if (CS%restart_field(m)%initialized) cycle + call query_vardesc(CS%restart_field(m)%vars, hor_grid=hor_grid, & + caller="restore_state_fms2") + select case (hor_grid) + case ('q') ; pos = CORNER + case ('h') ; pos = CENTER + case ('u') ; pos = EAST_FACE + case ('v') ; pos = NORTH_FACE + case ('Bu') ; pos = CORNER + case ('T') ; pos = CENTER + case ('Cu') ; pos = EAST_FACE + case ('Cv') ; pos = NORTH_FACE + case ('1') ; pos = 0 + case default ; pos = 0 + end select + + call get_checksum_loop_ranges(G, pos, isL, ieL, jsL, jeL) + ! Check if the variable is mandatory and present in the restart file(s) + if (.not. variable_exists(fileObjRead, trim(varname))) then + if (CS%restart_field(m)%mand_var) then + call MOM_error(WARNING, "MOM_restart_fms2: Unable to find mandatory variable " & + //trim(varname)//" in restart file "//trim(directory)//trim(base_file_name)) + missing_fields = missing_fields+1 + cycle + endif + endif + ! Get the variable's "domain position." + num_dims = 0 + dim_names(:) = "" + num_dims=get_variable_num_dimensions(fileobjRead, trim(varname)) + call get_variable_dimension_names(fileObjRead, trim(varname), dim_names(1:num_dims)) + ! Register the restart fields and compute the checksums. + if (associated(CS%var_ptr1d(m)%p)) then + call fms2_register_restart_field(fileObjRead, trim(varname), CS%var_ptr1d(m)%p, & + dimensions=(/dim_names(1)/)) + elseif (associated(CS%var_ptr0d(m)%p)) then + call fms2_register_restart_field(fileObjRead, trim(varname), CS%var_ptr0d(m)%p) + elseif (associated(CS%var_ptr2d(m)%p)) then + call fms2_register_restart_field(fileObjRead, trim(varname), CS%var_ptr2d(m)%p, & + dimensions=dim_names(1:num_dims)) + elseif (associated(CS%var_ptr3d(m)%p)) then + call fms2_register_restart_field(fileObjRead, trim(varname), CS%var_ptr3d(m)%p, & + dimensions=dim_names(1:num_dims)) + elseif (associated(CS%var_ptr4d(m)%p)) then + call fms2_register_restart_field(fileObjRead, trim(varname), CS%var_ptr4d(m)%p, & + dimensions=dim_names(1:num_dims)) + else + call MOM_error(FATAL, "MOM_restart restore_state_fms2: No pointers set for "//trim(varname)) + endif + CS%restart_field(m)%initialized = .true. + enddo ! m=CS%novars + ! Read in restart data and then close the file. + call read_restart(fileObjRead, unlim_dim_level=1) + ! close the file + if (check_if_open(fileObjRead)) call fms2_close_file(fileObjRead) + if (allocated(axis_names)) deallocate(axis_names) + if (missing_fields == 0) exit + enddo + + do m=1,CS%novars + if (.not.(CS%restart_field(m)%initialized)) then + CS%restart = .false. + if (CS%restart_field(m)%mand_var) then + call MOM_error(FATAL,"MOM_restart: Unable to find mandatory variable " & + //trim(CS%restart_field(m)%var_name)//" in restart files.") + endif + endif + enddo + +end subroutine restore_state_fms2 !> restart_files_exist determines whether any restart files exist. +! TODO remove this function when fms2-io is fully implemented function restart_files_exist(filename, directory, G, CS) character(len=*), intent(in) :: filename !< The list of restart file names or a single !! character 'r' to read automatically named files. @@ -1497,6 +2203,136 @@ function open_restart_units(filename, directory, G, CS, units, file_paths, & end function open_restart_units +!> get_num_restart_files determines the number of existing restart files and returns paths +!! and whether the files are global or spatially decomposed. +function get_num_restart_files(filename, directory, G, CS, file_paths) result(num_files) + character(len=*), intent(in) :: filename !< The list of restart file names or a single + !! character 'r' to read automatically named files. + character(len=*), intent(in) :: directory !< The directory in which to find restart files + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(MOM_restart_CS), pointer :: CS !< The control structure returned by a previous + !! call to restart_init. + character(len=*), dimension(:), & + optional, intent(out) :: file_paths !< The full paths to open files. + !logical, dimension(:), & + ! optional, intent(out) :: global_files !< True if a file is global. + + integer :: num_files !< The number of files (both automatically named restart + !! files and others explicitly in filename) that have been opened. + +! This subroutine reads the model state from previously +! generated files. All restart variables are read from the first +! file in the input filename list in which they are found. + + ! Local variables + character(len=256) :: filepath ! The path (dir/file) to the file being opened. + character(len=256) :: fname ! The name of the current file. + character(len=8) :: suffix ! A suffix (like "_2") that is added to any + ! additional restart files + integer :: num_restart ! The number of restart files that have already + ! been opened. + integer :: start_char ! The location of the starting character in the + ! current file name. + integer :: f, n, m, err, length, str_index + logical :: fexists + character(len=32) :: filename_appendix = '' !fms appendix to filename for ensemble runs + character(len=80) :: restartname + character(len=240) :: filepath_temp, filepath_temp2 + + if (.not.associated(CS)) call MOM_error(FATAL, "MOM_restart " // & + "get_num_restart_files: Module must be initialized before it is used.") + ! Determine the file name + num_restart = 0 ; n=0; start_char = 1; str_index=0 + if (present(file_paths)) file_paths(:) = "" + do while (start_char <= len_trim(filename) ) + do m=start_char,len_trim(filename) + if (filename(m:m) == ' ') exit + enddo + fname = filename(start_char:m-1) + start_char = m + do while (start_char <= len_trim(filename)) + if (filename(start_char:start_char) == ' ') then + start_char = start_char + 1 + else + exit + endif + enddo + + err = 0 + if (num_restart > 0) err = 1 ! Avoid going through the file list twice. + do while (err == 0) + restartname = trim(CS%restartfile) + ! query fms_io if there is a filename_appendix (for ensemble runs) + ! TODO add support to fms2-io, or move to MOM6 framework + call get_filename_appendix(filename_appendix) + if (len_trim(filename_appendix) > 0 .and. trim(filename_appendix) .ne. " ") then + length = len_trim(restartname) + if (restartname(length-2:length) == '.nc') then + restartname = restartname(1:length-3)//'.'//trim(filename_appendix)//'.nc' + else + restartname = restartname(1:length) //'.'//trim(filename_appendix) + endif + endif + filepath = trim(directory) // trim(restartname) + + if (num_restart < 10) then + write(suffix,'("_",I1)') num_restart + else + write(suffix,'("_",I2)') num_restart + endif + if (num_restart > 0) filepath = trim(filepath) // suffix + + filepath_temp = trim(filepath)//".nc" + if (file_exists(trim(filepath_temp),.true.) .or. file_exists(trim(filepath_temp)//".0000",.true.)) then + n = n+1 + if (present(file_paths)) file_paths(n) = trim(filepath_temp) + num_restart = num_restart + 1 + call MOM_error(NOTE, "MOM_restart:get_num_restart_files: Found restart file : "//trim(filepath)) + endif + ! search for files with "res_#" in the name + str_index = index(filepath_temp,".res.nc") + if (str_index .gt. 0) then + f = 0 + do while (f .le. n) + f=f+1 + filepath_temp2="" + ! check for names with extra .res.nc added by fms2-io + if ( f .lt. 10) then + write(filepath_temp2,'(A,I1,A)') trim(filepath_temp(1:str_index-1))//".res_",f,".res.nc" + elseif (f .ge. 10 .and. f .lt. 100) then + write(filepath_temp2,'(A,I2,A)') trim(filepath_temp(1:str_index-1))//".res_",f,".res.nc" + endif + if (file_exists(trim(filepath_temp2),.true.) .or. file_exists(trim(filepath_temp2)//".0000",.true.)) then + call MOM_error(NOTE, "MOM_restart:get_num_restart_files: Found restart file : "//trim(filepath_temp2)) + num_restart=num_restart+1 + n=n+1 + if (present(file_paths)) file_paths(n) = trim(filepath_temp2) + else + ! check for fms-io-style name + filepath_temp2="" + if ( f .lt. 10) then + write(filepath_temp2,'(A,I1,A)') trim(filepath_temp(1:str_index-1))//".res_",f,".nc" + elseif (f .ge. 10 .and. f .lt. 100) then + write(filepath_temp2,'(A,I2,A)') trim(filepath_temp(1:str_index-1))//".res_",f,".nc" + endif + if (file_exists(trim(filepath_temp2),.true.) .or. file_exists(trim(filepath_temp2)//".0000",.true.)) then + call MOM_error(NOTE, "MOM_restart:get_num_restart_files: Found restart file : "//trim(filepath_temp2)) + num_restart=num_restart+1 + n=n+1 + if (present(file_paths)) file_paths(n) = trim(filepath_temp2) + else + exit + endif + endif + enddo ! while (f .le. n-1) + endif + err = 1 ; exit + enddo ! while (err == 0) loop + enddo ! while (start_char < strlen(filename)) loop + num_files = n + +end function get_num_restart_files + !> Initialize this module and set up a restart control structure. subroutine restart_init(param_file, CS, restart_root) type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters @@ -1650,4 +2486,41 @@ subroutine get_checksum_loop_ranges(G, pos, isL, ieL, jsL, jeL) end subroutine get_checksum_loop_ranges +!> get the size of a variable in bytes +function get_variable_byte_size(hor_grid, z_grid, t_grid, G, num_zlevels) result(var_sz) + character(len=*), intent(in) :: hor_grid !< horizontal grid string + character(len=*), intent(in) :: z_grid !< vertical grid string + character(len=*), intent(in) :: t_grid !< time string + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure; + integer, intent(in) :: num_zlevels !< number of vertical levels + ! local + integer(kind=8) :: var_sz !< The size in bytes of each variable + integer :: var_periods + character(len=8) :: t_grid_read='' + + var_periods = 0 + + if (trim(hor_grid) == '1') then + var_sz = 8 + else + var_sz = 8*(G%Domain%niglobal+1)*(G%Domain%njglobal+1) + endif + + select case (trim(z_grid)) + case ('L') ; var_sz = var_sz * num_zlevels + case ('i') ; var_sz = var_sz * (num_zlevels+1) + end select + + if (adjustl(t_grid(1:1)) == 'p') then + if (len_trim(t_grid(2:8)) > 0) then + var_periods = -1 + t_grid_read = adjustl(t_grid(2:8)) + read(t_grid_read,*) var_periods + if (var_periods > 1) var_sz = var_sz * var_periods + endif + endif + +end function get_variable_byte_size + + end module MOM_restart diff --git a/src/framework/MOM_string_functions.F90 b/src/framework/MOM_string_functions.F90 index 1293499930..309a839750 100644 --- a/src/framework/MOM_string_functions.F90 +++ b/src/framework/MOM_string_functions.F90 @@ -17,6 +17,7 @@ module MOM_string_functions public extract_real public remove_spaces public slasher +public append_substring contains @@ -419,6 +420,34 @@ function slasher(dir) endif end function slasher +!> append a string (substring) to another string (string_in) and return the +!! concatenated string (string_out) +function append_substring(string_in, substring) result(string_out) + character(len=*), intent(in) :: string_in !< input string + character(len=*), intent(in) :: substring !< string to append string_in + ! local + character(len=1024) :: string_out + character(len=1024) :: string_joined + integer :: string_in_length + integer :: substring_length + + string_out = '' + string_joined = '' + string_in_length = 0 + substring_length = 0 + + string_in_length = len_trim(string_in) + substring_length = len_trim(substring) + + if (string_in_length > 0) then + if (substring_length > 0) then + string_joined = trim(string_in)//trim(substring) + string_out(1:len_trim(string_joined)) = trim(string_joined) + endif + endif + +end function append_substring + !> \namespace mom_string_functions !! !! By Alistair Adcroft and Robert Hallberg, last updated Sept. 2013. diff --git a/src/framework/MOM_write_field_fms2.F90 b/src/framework/MOM_write_field_fms2.F90 new file mode 100644 index 0000000000..2bfda13c9a --- /dev/null +++ b/src/framework/MOM_write_field_fms2.F90 @@ -0,0 +1,1663 @@ +!> This module contains wrapper functions to write data to netcdf files +module MOM_write_field_fms2 + +! This file is part of MOM6. See LICENSE.md for the license. + + +use MOM_axis, only : MOM_get_diagnostic_axis_data, MOM_register_diagnostic_axis +use MOM_axis, only : axis_data_type, get_time_index, get_var_dimension_metadata +use MOM_axis, only : get_time_units, convert_checksum_to_string +use MOM_error_handler, only : MOM_error, NOTE, FATAL, WARNING +use MOM_domains, only : MOM_domain_type +use MOM_domains, only : get_simple_array_i_ind, get_simple_array_j_ind +use MOM_grid, only : ocean_grid_type +use MOM_dyn_horgrid, only : dyn_horgrid_type +use MOM_string_functions, only : lowercase, append_substring +use MOM_verticalGrid, only : verticalGrid_type +use mpp_mod, only : mpp_pe, mpp_npes +use mpp_domains_mod, only : domain2d +use mpp_domains_mod, only : CENTER, CORNER, NORTH_FACE=>NORTH, EAST_FACE=>EAST +use mpp_domains_mod, only : mpp_get_domain_npes, mpp_define_io_domain, mpp_get_io_domain +use netcdf +! fms2_io +use fms2_io_mod, only : check_if_open, get_dimension_size +use fms2_io_mod, only : get_num_dimensions, get_num_variables, get_variable_names +use fms2_io_mod, only : get_unlimited_dimension_name, get_variable_dimension_names +use fms2_io_mod, only : get_variable_num_dimensions, get_variable_size, get_variable_units +use fms2_io_mod, only : get_variable_unlimited_dimension_index, is_dimension_unlimited +use fms2_io_mod, only : is_dimension_registered, register_axis +use fms2_io_mod, only : register_field, register_variable_attribute, fms2_open_file => open_file +use fms2_io_mod, only : fms2_close_file => close_file, write_data, variable_exists +use fms2_io_mod, only : FmsNetcdfDomainFile_t, FmsNetcdfFile_t, unlimited + +implicit none; private + +public write_field + +! CAUTION: The following variables are saved by default, and are only necessary for consecutive calls to +! write_field with the same file name. The user should ensure that fms2_close_file on +! the fileobj_write_field structures are called at every requisite time step at after the last +! variable is written to the file by omitting the optional leave_file_open argument, or setting it to .false. + +!> netCDF non-domain-decomposed file object returned by call to open_file in write_field calls +type(FmsNetcdfFile_t), private :: fileobj_write_field + +!> netCDF domain-decomposed file object returned by call to open_file in write_field calls +type(FmsNetcdfDomainFile_t), private :: fileobj_write_field_dd + +!> index of the time_level value that is written to netCDF file by the write_field routines +integer, private :: write_field_time_index + +!> interface to write data to a netcdf file generated by create_file +interface write_field + module procedure write_field_4d_DD + module procedure write_field_3d_DD + module procedure write_field_2d_DD + module procedure write_field_1d_DD + module procedure write_scalar + module procedure write_field_4d_noDD + module procedure write_field_3d_noDD + module procedure write_field_2d_noDD + module procedure write_field_1d_noDD +end interface + +!> interface to apply a scale factor to an array after reading in a field +interface scale_data + module procedure scale_data_4d + module procedure scale_data_3d + module procedure scale_data_2d + module procedure scale_data_1d +end interface + +contains +!> This function uses the fms_io function write_data to write a 1-D domain-decomposed data field named "fieldname" +!! to the file "filename" in "write", "overwrite", or "append" mode. It should be called after create_file in the MOM +!! file write procedure. +subroutine write_field_1d_DD(filename, fieldname, data, mode, domain, hor_grid, z_grid, & + start_index, edge_lengths, time_level, time_units, scale, & + checksums, G, dG, GV, leave_file_open, units, longname) + character(len=*), intent(in) :: filename !< The name of the file to read + character(len=*), intent(in) :: fieldname !< The variable name of the data in the file + real, target, dimension(:), intent(in) :: data !< The 1-dimensional data array to pass to read_data + character(len=*), intent(in) :: mode !< "write", "overwrite", or "append" + type(MOM_domain_type),intent(in) :: domain !< MOM domain attribute with the mpp_domain decomposition + character(len=*), intent(in) :: hor_grid !< horizontal grid descriptor + character(len=*), intent(in) :: z_grid !< vertical grid descriptor + integer, dimension(1), optional, intent(in) :: start_index !< starting index of data buffer. Default is 1 + integer, dimension(1), optional, intent(in) :: edge_lengths !< number of data values to read in; default is + !! the variable size + real, optional, intent(in) :: time_level !< time value to write + real, optional, intent(in) :: time_units !< length of the units for time [s]. The + !! default value is 86400.0, for 1 day. + real, optional, intent(in) :: scale !< A scaling factor that the fields are multiplied by before they are written. + integer(kind=8), dimension(:,:), optional, intent(in) :: checksums !< variable checksum + type(ocean_grid_type), optional, intent(in) :: G !< ocean horizontal grid structure; G or dG + !! is required if the new file uses any + !! horizontal grid axes. + type(dyn_horgrid_type), optional, intent(in) :: dG !< dynamic horizontal grid structure; G or dG + !! is required if the new file uses any + !! horizontal grid axes. + type(verticalGrid_type), optional, intent(in) :: GV !< ocean vertical grid structure, which is + !! required if the new file uses any + !! vertical grid axes. + logical, optional, intent(in) :: leave_file_open !< if .true., leave the file open + character(len=*), optional, intent(in) :: units !< variable units + character(len=*), optional, intent(in) :: longname !< long name variable attribute + ! local + logical :: file_open_success !.true. if call to open_file is successful + logical :: close_the_file ! indicates whether to close the file after write_data is called; default is .true. + real, pointer, dimension(:) :: data_tmp => null() ! enables data to be passed to functions as intent(inout) + integer :: num_dims, substring_index + integer :: dim_unlim_size! size of the unlimited dimension + integer, dimension(1) :: start, nwrite ! indices for first data value and number of values to write + character(len=20) :: t_units ! time units + character(len=nf90_max_name) :: dim_unlim_name ! name of the unlimited dimension in the file + character(len=64) :: checksum_char ! checksum character array created from checksum argument + character(len=1024) :: filename_temp + character(len=48), dimension(2) :: dim_names !< variable dimension names (or name, in the 1-D case); 1 extra + !! dimension in case appending along the time axis + integer, dimension(2) :: dim_lengths !< variable dimension lengths (or length, in the 1-D case) + + close_the_file = .true. + if (present(leave_file_open)) close_the_file = .not.(leave_file_open) + + dim_unlim_size=0 + dim_unlim_name="" + dim_names(:) = "" + dim_lengths(:) = 0 + num_dims = 0 + ! append '.nc' to the file name if it is missing + filename_temp = "" + substring_index = 0 + substring_index = index(trim(filename), ".nc") + if (substring_index <= 0) then + filename_temp = append_substring(filename,".nc") + else + filename_temp = filename + endif + ! get the dimension names and lengths + ! NOTE: the t_grid argument is set to '1' (do nothing) because the presence of a time dimension is user-specified + ! and not assumed from the t_grid value + if (present(G)) then + call get_var_dimension_metadata(hor_grid, z_grid, '1', dim_names, & + dim_lengths, num_dims, G=G) + elseif(present(dG)) then + call get_var_dimension_metadata(hor_grid, z_grid, '1', dim_names, & + dim_lengths, num_dims, dG=dG) + endif + + if (present(GV)) & + call get_var_dimension_metadata(hor_grid, z_grid, '1', dim_names, & + dim_lengths, num_dims, GV=GV) + ! define the start and edge_length arguments + start(:) = 1 + nwrite(:) = dim_lengths(1) + if (present(start_index)) then + start(1) = max(1, start_index(1)) + endif + + if (present(edge_lengths)) then + nwrite(1) = max(dim_lengths(1),edge_lengths(1)) + endif + + data_tmp => data + ! scale the data + if (present(scale)) then ; if (scale /= 1.0) then + call scale_data(data_tmp,scale) + endif ; endif + + if (.not.(check_if_open(fileobj_write_field_dd))) then + if ((lowercase(trim(mode)) .ne. "write") .and. (lowercase(trim(mode)) .ne. "append") .and. & + (lowercase(trim(mode)) .ne. "overwrite")) & + call MOM_error(FATAL,"MOM_write_field_fms2:write_1d_DD:mode argument must be write, overwrite, or append") + ! define the io domain for 1-pe jobs because it is required to write domain-decomposed files + if (mpp_get_domain_npes(domain%mpp_domain) .eq. 1 ) then + if (.not. associated(mpp_get_io_domain(domain%mpp_domain))) & + call mpp_define_io_domain(domain%mpp_domain, (/1,1/)) + endif + ! get the time_level index + if (present(time_level)) write_field_time_index = get_time_index(trim(filename_temp), time_level) + ! open the file in write or append mode + file_open_success = fms2_open_file(fileobj_write_field_dd, trim(filename_temp), lowercase(trim(mode)), & + domain%mpp_domain, is_restart=.false.) + ! register the diagnostic axis associated with the variable + call MOM_register_diagnostic_axis(fileobj_write_field_dd, trim(dim_names(1)), dim_lengths(1)) + endif + ! register and write the time_level + if (present(time_level)) then + if (.not. (variable_exists(fileobj_write_field_dd, trim(dim_unlim_name)))) then + ! set the time units + t_units = "" + if (present(time_units)) then + t_units = get_time_units(time_units) + else + t_units = "days" + endif + + call register_field(fileobj_write_field_dd, trim(dim_unlim_name), "double", dimensions=(/trim(dim_unlim_name)/)) + call register_variable_attribute(fileobj_write_field_dd, trim(dim_unlim_name), 'units', trim(t_units)) + call write_data(fileobj_write_field_dd, trim(dim_unlim_name), (/time_level/), corner=(/write_field_time_index/)) + else + ! write the time_level if it is larger than the most recent file time + if (write_field_time_index .gt. dim_unlim_size) & + call write_data(fileobj_write_field_dd, trim(dim_unlim_name), (/time_level/), & + corner=(/write_field_time_index/), edge_lengths=(/1/)) + endif + endif + ! register the field if it is not already in the file + if (.not.(variable_exists(fileobj_write_field_dd, trim(fieldname)))) then + call register_field(fileobj_write_field_dd, trim(fieldname), "double", dimensions=dim_names(1:num_dims)) + if (present(units)) & + call register_variable_attribute(fileobj_write_field_dd, trim(fieldname), 'units', trim(units)) + if (present(longname)) & + call register_variable_attribute(fileobj_write_field_dd, trim(fieldname), 'long_name', trim(longname)) + ! write the checksum attribute + if (present(checksums)) then + ! convert the checksum to a string + checksum_char = "" + checksum_char = convert_checksum_to_string(checksums(1,1)) + call register_variable_attribute(fileobj_write_field_dd, trim(fieldname), "checksum", checksum_char) + endif + endif + ! write the variable + if (present(time_level)) then + call write_data(fileobj_write_field_dd, trim(fieldname), data_tmp, corner=start, edge_lengths=nwrite, & + unlim_dim_level=write_field_time_index) + else + call write_data(fileobj_write_field_dd, trim(fieldname), data_tmp, corner=start, edge_lengths=nwrite) + endif + ! close the file + if (close_the_file) then + if (check_if_open(fileobj_write_field_dd)) call fms2_close_file(fileobj_write_field_dd) + write_field_time_index = 0 + endif + nullify(data_tmp) +end subroutine write_field_1d_DD + +!> This function uses the fms_io function write_data to write a 2-D domain-decomposed data field named "fieldname" +!! to the file "filename" in "write", "overwrite", or "append" mode. It should be called after create_file in the MOM +!! file write procedure. +subroutine write_field_2d_DD(filename, fieldname, data, mode, domain, hor_grid, z_grid, & + start_index, edge_lengths, time_level, time_units, scale, & + checksums, G, dG, GV, leave_file_open, units, longname) + character(len=*), intent(in) :: filename !< The name of the file to read + character(len=*), intent(in) :: fieldname !< The variable name of the data in the file + real, target, dimension(:,:), intent(in) :: data !< The 1-dimensional data array to pass to read_data + character(len=*), intent(in) :: mode !< "write", "overwrite", or "append" + type(MOM_domain_type),intent(in) :: domain !< MOM domain attribute with the mpp_domain decomposition + character(len=*), intent(in) :: hor_grid !< horizontal grid descriptor + character(len=*), intent(in) :: z_grid !< vertical grid descriptor + integer, dimension(1), optional, intent(in) :: start_index !< starting index of data buffer. Default is 1 + integer, dimension(1), optional, intent(in) :: edge_lengths !< number of data values to read in; default is + !! the variable size + real, optional, intent(in) :: time_level !< time value to write + real, optional, intent(in) :: time_units !< length of the units for time [s]. The + !! default value is 86400.0, for 1 day. + real, optional, intent(in) :: scale !< A scaling factor that the fields are multiplied by before they are written. + integer(kind=8), dimension(:,:), optional, intent(in) :: checksums !< variable checksum + type(ocean_grid_type), optional, intent(in) :: G !< ocean horizontal grid structure; G or dG + !! is required if the new file uses any + !! horizontal grid axes. + type(dyn_horgrid_type), optional, intent(in) :: dG !< dynamic horizontal grid structure; G or dG + !! is required if the new file uses any + !! horizontal grid axes. + type(verticalGrid_type), optional, intent(in) :: GV !< ocean vertical grid structure, which is + !! required if the new file uses any + !! vertical grid axes. + logical, optional, intent(in) :: leave_file_open !< flag indicating whether to leave the file open + character(len=*), optional, intent(in) :: units !< variable units + character(len=*), optional, intent(in) :: longname !< long name variable attribute + ! local + logical :: file_open_success !.true. if call to open_file is successful + logical :: close_the_file ! indicates whether to close the file after write_data is called; default is .true. + real, pointer :: data_tmp(:,:) => null() + integer :: i, is, ie, js, je, j, ndims, num_dims, substring_index + integer, allocatable, dimension(:) :: x_inds, y_inds + integer :: dim_unlim_size ! size of the unlimited dimension + integer :: file_dim_length + integer, dimension(2) :: start, nwrite ! indices for starting points and number of values to write + character(len=20) :: t_units ! time units + character(len=nf90_max_name) :: dim_unlim_name ! name of the unlimited dimension in the file + character(len=1024) :: filename_temp + character(len=64) :: checksum_char ! checksum character array created from checksum argument + character(len=48), dimension(3) :: dim_names ! variable dimension names; 1 extra dimension in case appending + ! along the time axis + character(len=48), allocatable, dimension(:) :: file_dim_names + integer, dimension(3) :: dim_lengths ! variable dimension lengths + + close_the_file = .true. + if (present(leave_file_open)) close_the_file = .not.(leave_file_open) + + dim_lengths(:) = 0 + dim_names(:) = "" + dim_unlim_size = 0 + dim_unlim_name = "" + ndims = 2 + num_dims = 0 + ! append '.nc' to the file name if it is missing + filename_temp = "" + substring_index = 0 + substring_index = index(trim(filename), ".nc") + if (substring_index <= 0) then + filename_temp = append_substring(filename,".nc") + else + filename_temp = filename + endif + ! get the dimension names and lengths + ! NOTE: the t_grid argument is set to '1' (do nothing) because the presence of a time dimension + ! is user-specified rather than derived from the t_grid value + if (present(G)) then + call get_var_dimension_metadata(hor_grid, z_grid, '1', dim_names, & + dim_lengths, num_dims, G=G) + elseif(present(dG)) then + call get_var_dimension_metadata(hor_grid, z_grid, '1', dim_names, & + dim_lengths, num_dims, dG=dG) + endif + if (present(GV)) & + call get_var_dimension_metadata(hor_grid, z_grid, '1', dim_names, & + dim_lengths, num_dims, GV=GV) + ! set the start (start_index) and nwrite (edge_lengths) values + start(:) = 1 + nwrite(:) = dim_lengths(1:ndims) + + if (present(start_index)) then + do i=1,ndims + start(i) = max(1,start_index(i)) + enddo + endif + + if (present(edge_lengths)) then + do i=1,ndims + nwrite(i) = max(dim_lengths(i),edge_lengths(i)) + enddo + endif + + data_tmp => data + ! scale the data + if (present(scale)) then ; if (scale /= 1.0) then + call scale_data(data_tmp,scale) + endif ; endif + + if (.not.(check_if_open(fileobj_write_field_dd))) then + if ((lowercase(trim(mode)) .ne. "write") .and. (lowercase(trim(mode)) .ne. "append") .and. & + (lowercase(trim(mode)) .ne. "overwrite")) & + call MOM_error(FATAL,"MOM_write_field_fms2:write_2d_DD:mode argument must be write, overwrite, or append") + ! define the io domain for 1-pe jobs because it is required to write domain-decomposed files + if (mpp_get_domain_npes(domain%mpp_domain) .eq. 1 ) then + if (.not. associated(mpp_get_io_domain(domain%mpp_domain))) & + call mpp_define_io_domain(domain%mpp_domain, (/1,1/)) + endif + ! get the time_level index + if (present(time_level)) write_field_time_index = get_time_index(trim(filename_temp), time_level) + ! open the file in write or append mode + file_open_success = fms2_open_file(fileobj_write_field_dd, trim(filename_temp), lowercase(trim(mode)), & + domain%mpp_domain, is_restart=.false.) + endif + ! register the horizontal diagnostic axes associated with the variable + do i=1,num_dims + if (.not.(is_dimension_registered(fileobj_write_field_dd, trim(dim_names(i))))) & + call MOM_register_diagnostic_axis(fileobj_write_field_dd, trim(dim_names(i)), dim_lengths(i)) + enddo + ! register and write the time_level + if (present(time_level)) then + call get_unlimited_dimension_name(fileobj_write_field_dd, dim_unlim_name) + call get_dimension_size(fileobj_write_field_dd, trim(dim_unlim_name), dim_unlim_size) + num_dims=num_dims+1 + dim_names(num_dims) = trim(dim_unlim_name) + + if (.not. (variable_exists(fileobj_write_field_dd, trim(dim_unlim_name)))) then + ! set the time units + t_units = "" + if (present(time_units)) then + t_units = get_time_units(time_units) + else + t_units = "days" + endif + + call register_field(fileobj_write_field_dd, trim(dim_unlim_name), "double", dimensions=(/trim(dim_unlim_name)/)) + call register_variable_attribute(fileobj_write_field_dd, trim(dim_unlim_name), 'units', trim(t_units)) + call write_data(fileobj_write_field_dd, trim(dim_unlim_name), (/time_level/), corner=(/write_field_time_index/)) + else + ! write the time_level if it is larger than the most recent file time + if (write_field_time_index .gt. dim_unlim_size) & + call write_data(fileobj_write_field_dd, trim(dim_unlim_name), (/time_level/), & + corner=(/write_field_time_index/), edge_lengths=(/1/)) + endif + endif + ! register the variable if it is not already in the file + if (.not.(variable_exists(fileobj_write_field_dd, trim(fieldname)))) then + call register_field(fileobj_write_field_dd, trim(fieldname), "double", dimensions=dim_names(1:num_dims)) + if (present(units)) & + call register_variable_attribute(fileobj_write_field_dd, trim(fieldname), 'units', trim(units)) + if (present(longname)) & + call register_variable_attribute(fileobj_write_field_dd, trim(fieldname), 'long_name', trim(longname)) + ! write the checksum attribute + if (present(checksums)) then + ! convert the checksum to a string + checksum_char = "" + checksum_char = convert_checksum_to_string(checksums(1,1)) + call register_variable_attribute(fileobj_write_field_dd, trim(fieldname), "checksum", checksum_char) + endif + endif + ! write the variable + if (present(time_level)) then + call write_data(fileobj_write_field_dd, trim(fieldname), data_tmp, corner=start, edge_lengths=nwrite, & + unlim_dim_level=write_field_time_index) + else + call write_data(fileobj_write_field_dd, trim(fieldname), data_tmp, corner=start, edge_lengths=nwrite) + endif + ! close the file + if (close_the_file) then + if (check_if_open(fileobj_write_field_dd)) call fms2_close_file(fileobj_write_field_dd) + write_field_time_index=0 + if (allocated(file_dim_names)) deallocate(file_dim_names) + endif + nullify(data_tmp) +end subroutine write_field_2d_DD + +!> This function uses the fms_io function write_data to write a 3-D domain-decomposed data field named "fieldname" +!! to the file "filename" in "write", "overwrite", or "append" mode. It should be called after create_file in the MOM +!! file write procedure. +subroutine write_field_3d_DD(filename, fieldname, data, mode, domain, hor_grid, z_grid, & + start_index, edge_lengths, time_level, time_units, scale, & + checksums, G, dG, GV, leave_file_open, units, longname) + character(len=*), intent(in) :: filename !< The name of the file to read + character(len=*), intent(in) :: fieldname !< The variable name of the data in the file + real, target, dimension(:,:,:), intent(in) :: data !< The 1-dimensional data array to pass to read_data + character(len=*), intent(in) :: mode !< "write", "overwrite", or "append" + type(MOM_domain_type),intent(in) :: domain !< MOM domain attribute with the mpp_domain decomposition + character(len=*), intent(in) :: hor_grid !< horizontal grid descriptor + character(len=*), intent(in) :: z_grid !< vertical grid descriptor + integer, dimension(1), optional, intent(in) :: start_index !< starting index of data buffer. Default is 1 + integer, dimension(1), optional, intent(in) :: edge_lengths !< number of data values to read in; default is + !! the variable size + real, optional, intent(in) :: time_level !< time value to write + real, optional, intent(in) :: time_units !< length of the units for time [s]. The + !! default value is 86400.0, for 1 day. + real, optional, intent(in) :: scale !< A scaling factor that the fields are multiplied by before they are written. + integer(kind=8), dimension(:,:), optional, intent(in) :: checksums !< variable checksum + type(ocean_grid_type), optional, intent(in) :: G !< ocean horizontal grid structure; G or dG + !! is required if the new file uses any + !! horizontal grid axes. + type(dyn_horgrid_type), optional, intent(in) :: dG !< dynamic horizontal grid structure; G or dG + !! is required if the new file uses any + !! horizontal grid axes. + type(verticalGrid_type), optional, intent(in) :: GV !< ocean vertical grid structure, which is + !! required if the new file uses any + !! vertical grid axes. + logical, optional, intent(in) :: leave_file_open !< flag indicating whether to leave the file open + character(len=*), optional, intent(in) :: units !< variable units + character(len=*), optional, intent(in) :: longname !< long name variable attribute + ! local + logical :: file_open_success !.true. if call to open_file is successful + logical :: close_the_file ! indicates whether to close the file after write_data is called; default is .true. + real, pointer, dimension(:,:,:) :: data_tmp => null() ! enables data to be passed to functions as intent(inout) + integer :: i, is, ie, js, je, ndims, num_dims, substring_index + integer :: dim_unlim_size ! size of the unlimited dimension + integer, dimension(3) :: start, nwrite ! indices for first data value and number of values to write + character(len=20) :: t_units ! time units + character(len=nf90_max_name) :: dim_unlim_name ! name of the unlimited dimension in the file + character(len=1024) :: filename_temp + character(len=64) :: checksum_char ! checksum character array created from checksum argument + character(len=48), dimension(4) :: dim_names !< variable dimension names; 1 extra dimension in case appending + !! along the time axis + integer, dimension(4) :: dim_lengths !< variable dimension lengths + + close_the_file = .true. + if (present(leave_file_open)) close_the_file = .not.(leave_file_open) + + dim_unlim_size = 0 + dim_unlim_name = "" + dim_names(:) = "" + dim_lengths(:) = 0 + num_dims = 0 + ! append '.nc' to the file name if it is missing + filename_temp = "" + substring_index = 0 + substring_index = index(trim(filename), ".nc") + if (substring_index <= 0) then + filename_temp = append_substring(filename,".nc") + else + filename_temp = filename + endif + ! get the dimension names and lengths + ! NOTE: the t_grid argument is set to '1' (do nothing) because the presence of a time dimension is user-specified + ! and not assumed from the t_grid value + if (present(G)) then + call get_var_dimension_metadata(hor_grid, z_grid, '1', dim_names, & + dim_lengths, num_dims, G=G) + elseif(present(dG)) then + call get_var_dimension_metadata(hor_grid, z_grid, '1', dim_names, & + dim_lengths, num_dims, dG=dG) + endif + + if (present(GV)) & + call get_var_dimension_metadata(hor_grid, z_grid, '1', dim_names, & + dim_lengths, num_dims, GV=GV) + ! set the start (start_index) and nwrite (edge_lengths) values + ndims = 3 + start(:) = 1 + nwrite(:) = dim_lengths(1:3) + if (present(start_index)) then + do i=1,ndims + start(i) = max(1,start_index(i)) + enddo + endif + + if (present(edge_lengths)) then + do i=1,ndims + nwrite(i) = max(dim_lengths(i), edge_lengths(i)) + enddo + endif + + data_tmp => data + ! scale the data + if (present(scale)) then ; if (scale /= 1.0) then + call scale_data(data_tmp,scale) + endif ; endif + ! open the file + if (.not.(check_if_open(fileobj_write_field_dd))) then + if ((lowercase(trim(mode)) .ne. "write") .and. (lowercase(trim(mode)) .ne. "append") .and. & + (lowercase(trim(mode)) .ne. "overwrite")) & + call MOM_error(FATAL,"MOM_write_field_fms2:write_3d_DD:mode argument must be write, overwrite, or append") + ! define the io domain for 1-pe jobs because it is required to write domain-decomposed files + if (mpp_get_domain_npes(domain%mpp_domain) .eq. 1 ) then + if (.not. associated(mpp_get_io_domain(domain%mpp_domain))) & + call mpp_define_io_domain(domain%mpp_domain, (/1,1/)) + endif + ! get the time_level index + if (present(time_level)) write_field_time_index = get_time_index(trim(filename_temp), time_level) + ! open the file in write or append mode + file_open_success = fms2_open_file(fileobj_write_field_dd, trim(filename_temp), lowercase(trim(mode)), & + domain%mpp_domain, is_restart=.false.) + ! register the horizontal and vertical diagnostic axes associated with the variable + do i=1,ndims + call MOM_register_diagnostic_axis(fileobj_write_field_dd, trim(dim_names(i)), dim_lengths(i)) + enddo + endif + ! register and write the time_level + if (present(time_level)) then + call get_unlimited_dimension_name(fileobj_write_field_dd ,dim_unlim_name) + call get_dimension_size(fileobj_write_field_dd, trim(dim_unlim_name), dim_unlim_size) + num_dims=num_dims+1 + dim_names(num_dims) = trim(dim_unlim_name) + + if (.not. (variable_exists(fileobj_write_field_dd, trim(dim_unlim_name)))) then + ! set the time units + t_units = "" + if (present(time_units)) then + t_units = get_time_units(time_units) + else + t_units = "days" + endif + + call register_field(fileobj_write_field_dd, trim(dim_unlim_name), "double", dimensions=(/trim(dim_unlim_name)/)) + call register_variable_attribute(fileobj_write_field_dd, trim(dim_unlim_name), 'units', trim(t_units)) + call write_data(fileobj_write_field_dd, trim(dim_unlim_name), (/time_level/), corner=(/write_field_time_index/)) + else + ! write the time_level if it is larger than the most recent file time + if (write_field_time_index .gt. dim_unlim_size ) & + call write_data(fileobj_write_field_dd, trim(dim_unlim_name), (/time_level/), & + corner=(/write_field_time_index/), edge_lengths=(/1/)) + endif + endif + ! register the field if it is not already in the file + if (.not.(variable_exists(fileobj_write_field_dd, trim(fieldname)))) then + call register_field(fileobj_write_field_dd, trim(fieldname), "double", dimensions=dim_names(1:num_dims)) + if (present(units)) & + call register_variable_attribute(fileobj_write_field_dd, trim(fieldname), 'units', trim(units)) + if (present(longname)) & + call register_variable_attribute(fileobj_write_field_dd, trim(fieldname), 'long_name', trim(longname)) + ! write the checksum attribute + if (present(checksums)) then + ! convert the checksum to a string + checksum_char = "" + checksum_char = convert_checksum_to_string(checksums(1,1)) + call register_variable_attribute(fileobj_write_field_dd, trim(fieldname), "checksum", checksum_char) + endif + endif + ! write the data + if (present(time_level)) then + call get_dimension_size(fileobj_write_field_dd, trim(dim_unlim_name), dim_unlim_size) + call write_data(fileobj_write_field_dd, trim(fieldname), data_tmp, corner=start, edge_lengths=nwrite, & + unlim_dim_level=write_field_time_index) + else + call write_data(fileobj_write_field_dd, trim(fieldname), data_tmp, corner=start, edge_lengths=nwrite) + endif + ! close the file + if (close_the_file) then + if (check_if_open(fileobj_write_field_dd)) call fms2_close_file(fileobj_write_field_dd) + write_field_time_index=0 + endif + nullify(data_tmp) + +end subroutine write_field_3d_DD + +!> This function uses the fms_io function write_data to write a 4-D domain-decomposed data field named "fieldname" +!! to the file "filename" in "write", "overwrite", or "append" mode. It should be called after create_file in the MOM +!! file write procedure. +subroutine write_field_4d_DD(filename, fieldname, data, mode, domain, hor_grid, z_grid, t_grid, & + start_index, edge_lengths, time_level, time_units, scale, & + checksums, G, dG, GV, leave_file_open, units, longname) + character(len=*), intent(in) :: filename !< The name of the file to read + character(len=*), intent(in) :: fieldname !< The variable name of the data in the file + real, target, dimension(:,:,:,:), intent(in) :: data !< The 1-dimensional data array to pass to read_data + character(len=*), intent(in) :: mode !< "write", "overwrite", or "append" + type(MOM_domain_type),intent(in) :: domain !< MOM domain attribute with the mpp_domain decomposition + character(len=*), intent(in) :: hor_grid !< horizontal grid descriptor + character(len=*), intent(in) :: z_grid !< vertical grid descriptor + character(len=*), intent(in) :: t_grid !< time descriptor + integer, dimension(1), optional, intent(in) :: start_index !< starting index of data buffer. Default is 1 + integer, dimension(1), optional, intent(in) :: edge_lengths !< number of data values to read in; default is + !! the variable size + real, optional, intent(in) :: time_level !< time value to write + real, optional, intent(in) :: time_units !< length of the units for time [s]. The + !! default value is 86400.0, for 1 day. + real, optional, intent(in) :: scale !< A scaling factor that the fields are multiplied by before they are written. + integer(kind=8), dimension(:,:), optional, intent(in) :: checksums !< variable checksum + type(ocean_grid_type), optional, intent(in) :: G !< ocean horizontal grid structure; G or dG + !! is required if the new file uses any + !! horizontal grid axes. + type(dyn_horgrid_type), optional, intent(in) :: dG !< dynamic horizontal grid structure; G or dG + !! is required if the new file uses any + !! horizontal grid axes. + type(verticalGrid_type), optional, intent(in) :: GV !< ocean vertical grid structure, which is + !! required if the new file uses any + !! vertical grid axes. + logical, optional, intent(in) :: leave_file_open !< flag indicating whether to leave the file open + character(len=*), optional, intent(in) :: units !< variable units + character(len=*), optional, intent(in) :: longname !< long name variable attribute + ! local + logical :: file_open_success !.true. if call to open_file is successful + logical :: close_the_file ! indicates whether to close the file after write_data is called; default is .true. + real, pointer, dimension(:,:,:,:) :: data_tmp => null() ! enables data to be passed to functions as intent(inout) + real :: file_time ! most recent time currently written to file + integer :: i, ndims, num_dims, substring_index + integer :: dim_unlim_size ! size of the unlimited dimension + integer, dimension(4) :: start, nwrite ! indices for first data value and number of values to write + character(len=20) :: t_units ! time units + character(len=nf90_max_name) :: dim_unlim_name ! name of the unlimited dimension in the file + character(len=1024) :: filename_temp + character(len=64) :: checksum_char ! checksum character array created from checksum argument + character(len=48), dimension(4) :: dim_names ! variable dimension names + integer, dimension(4) :: dim_lengths ! variable dimension lengths + + close_the_file = .true. + if (present(leave_file_open)) close_the_file = .not.(leave_file_open) + + num_dims = 0 + dim_unlim_size = 0 + dim_unlim_name = "" + dim_names(:) = "" + dim_lengths(:) = 0 + ! append '.nc' to the file name if it is missing + filename_temp = "" + substring_index = 0 + substring_index = index(trim(filename), ".nc") + if (substring_index <= 0) then + filename_temp = append_substring(filename,".nc") + else + filename_temp = filename + endif + ! get the dimension names and lengths + if (present(G)) then + call get_var_dimension_metadata(hor_grid, z_grid, t_grid, dim_names, & + dim_lengths, num_dims, G=G) + elseif(present(dG)) then + call get_var_dimension_metadata(hor_grid, z_grid, t_grid, dim_names, & + dim_lengths, num_dims, dG=dG) + endif + + if (present(GV)) & + call get_var_dimension_metadata(hor_grid, z_grid, t_grid, dim_names, & + dim_lengths, num_dims, GV=GV) + ! set the start (start_index) and nwrite (edge_lengths) values + ndims = 4 + start(:) = 1 + nwrite(:) = dim_lengths(:) + if (present(start_index)) then + do i=1,ndims + start(i) = max(1,start_index(i)) + enddo + endif + + if (present(edge_lengths)) then + do i=1,ndims + nwrite(i) = max(dim_lengths(i), edge_lengths(i)) + enddo + endif + + data_tmp => data + ! scale the data + if (present(scale)) then ; if (scale /= 1.0) then + call scale_data(data_tmp,scale) + endif ; endif + ! open the file + if (.not.(check_if_open(fileobj_write_field_dd))) then + if ((lowercase(trim(mode)) .ne. "write") .and. (lowercase(trim(mode)) .ne. "append") .and. & + (lowercase(trim(mode)) .ne. "overwrite")) & + call MOM_error(FATAL,"MOM_write_field_fms2:write_4d_DD:mode argument must be write, overwrite, or append") + ! define the io domain for 1-pe jobs because it is required to write domain-decomposed files + if (mpp_get_domain_npes(domain%mpp_domain) .eq. 1 ) then + if (.not. associated(mpp_get_io_domain(domain%mpp_domain))) & + call mpp_define_io_domain(domain%mpp_domain, (/1,1/)) + endif + ! get the index of the corresponding time_level the first time the file is opened + if (present(time_level)) write_field_time_index = get_time_index(trim(filename_temp), time_level) + ! open the file in write or append mode + file_open_success = fms2_open_file(fileobj_write_field_dd, trim(filename_temp), lowercase(trim(mode)), & + domain%mpp_domain, is_restart=.false.) + ! register the horizontal and vertical diagnostic axes associated with the variable + do i=1,ndims + call MOM_register_diagnostic_axis(fileobj_write_field_dd, trim(dim_names(i)), dim_lengths(i)) + enddo + endif + ! register the time dimension and write the time_level + if (present(time_level)) then + call get_unlimited_dimension_name(fileobj_write_field_dd, dim_unlim_name) + call get_dimension_size(fileobj_write_field_dd, trim(dim_unlim_name), dim_unlim_size) + num_dims=num_dims+1 + dim_names(num_dims) = trim(dim_unlim_name) + + if (.not. (variable_exists(fileobj_write_field_dd, trim(dim_unlim_name)))) then + ! set the time units + t_units = "" + if (present(time_units)) then + t_units = get_time_units(time_units) + else + t_units = "days" + endif + + call register_field(fileobj_write_field_dd, trim(dim_unlim_name), "double", dimensions=(/trim(dim_unlim_name)/)) + call register_variable_attribute(fileobj_write_field_dd, trim(dim_unlim_name), 'units', trim(t_units)) + call write_data(fileobj_write_field_dd, trim(dim_unlim_name), (/time_level/), corner=(/write_field_time_index/)) + else + ! write the time_level if it is larger than the most recent file time + if (write_field_time_index .gt. dim_unlim_size) & + call write_data(fileobj_write_field_dd, trim(dim_unlim_name), (/time_level/), & + corner=(/write_field_time_index/), edge_lengths=(/1/)) + endif + endif + ! register the variable if it is not already in the file + if (.not.(variable_exists(fileobj_write_field_dd, trim(fieldname)))) then + call register_field(fileobj_write_field_dd, trim(fieldname), "double", dimensions=dim_names(1:num_dims)) + if (present(units)) & + call register_variable_attribute(fileobj_write_field_dd, trim(fieldname), 'units', trim(units)) + if (present(longname)) & + call register_variable_attribute(fileobj_write_field_dd, trim(fieldname), 'long_name', trim(longname)) + ! write the checksum attribute + if (present(checksums)) then + ! convert the checksum to a string + checksum_char = "" + checksum_char = convert_checksum_to_string(checksums(1,1)) + call register_variable_attribute(fileobj_write_field_dd, trim(fieldname), "checksum", checksum_char) + endif + endif + ! write the data + if (present(time_level)) then + call get_dimension_size(fileobj_write_field_dd, trim(dim_unlim_name), dim_unlim_size) + call write_data(fileobj_write_field_dd, trim(fieldname), data_tmp, corner=start, edge_lengths=nwrite, & + unlim_dim_level=write_field_time_index) + else + call write_data(fileobj_write_field_dd, trim(fieldname), data_tmp, corner=start, edge_lengths=nwrite) + endif + ! close the file + if (close_the_file) then + if (check_if_open(fileobj_write_field_dd)) call fms2_close_file(fileobj_write_field_dd) + write_field_time_index=0 + endif + nullify(data_tmp) +end subroutine write_field_4d_DD + +!> This routine uses the fms_io function write_data to write a scalar variable named "fieldname" +!! to the file "filename" in "write", "overwrite", or "append" mode. It should be called after create_file in the MOM +!! file write procedure. +subroutine write_scalar(filename, fieldname, data, mode, time_level, time_units, leave_file_open, units, longname) + character(len=*), intent(in) :: filename !< The name of the file to read + character(len=*), intent(in) :: fieldname !< The variable name of the data in the file + real, intent(in) :: data !< The 1-dimensional data array to pass to read_data + character(len=*), intent(in) :: mode !< "write", "overwrite", or "append" + real, optional, intent(in) :: time_level !< time value to write + real, optional, intent(in) :: time_units !< length of the units for time [s]. The + !! default value is 86400.0, for 1 day + logical, optional, intent(in) :: leave_file_open !< flag indicating whether to leave the file open + character(len=*), optional, intent(in) :: units !< variable units + character(len=*), optional, intent(in) :: longname !< long name variable attribute + ! local + logical :: file_open_success !.true. if call to open_file is successful + logical :: close_the_file ! indicates whether to close the file after write_data is called; default is .true. + character(len=20) :: t_units ! time units + character(len=nf90_max_name) :: dim_unlim_name ! name of the unlimited dimension in the file + character(len=1024) :: filename_temp + character(len=48), dimension(1) :: dim_names ! variable dimension names + integer :: i, num_dims, substring_index + integer :: dim_unlim_size ! size of the unlimited dimension + real, allocatable, dimension(:) :: file_times + integer, dimension(1) :: dim_lengths ! variable dimension lengths + integer, allocatable, dimension(:) :: pelist ! list of pes associated with the netCDF file + + dim_unlim_size = 0 + dim_unlim_name= "" + dim_names(:) = "" + dim_lengths(:) = 0 + num_dims = 0 + + close_the_file = .true. + if (present(leave_file_open)) close_the_file = .not.(leave_file_open) + + ! append '.nc' to the file name if it is missing + filename_temp = "" + substring_index = 0 + substring_index = index(trim(filename), ".nc") + if (substring_index <= 0) then + filename_temp = append_substring(filename,".nc") + else + filename_temp = filename + endif + + if (.not.(check_if_open(fileobj_write_field))) then + if ((lowercase(trim(mode)) .ne. "write") .and. (lowercase(trim(mode)) .ne. "append") .and. & + (lowercase(trim(mode)) .ne. "overwrite")) & + call MOM_error(FATAL,"MOM_write_field_fms2:write_scaler:mode argument must be write, overwrite, or append") + ! get the index of the corresponding time_level the first time the file is opened + if (present(time_level)) write_field_time_index = get_time_index(trim(filename_temp), time_level) + ! get the pes associated with the file. + !>\note this is required so that only pe(1) is identified as the root pe to create the file + !! Otherwise, multiple pes may try to open the file in write (NC_NOCLOBBER) mode, leading to failure + if (.not.(allocated(pelist))) then + allocate(pelist(mpp_npes())) + pelist(:) = 0 + do i=1,size(pelist) + pelist(i) = i-1 + enddo + endif + ! open the file in write or append mode + file_open_success = fms2_open_file(fileobj_write_field, trim(filename_temp), trim(mode), is_restart=.false., & + pelist=pelist) + endif + if (present(time_level)) then + call get_unlimited_dimension_name(fileobj_write_field, dim_unlim_name) + call get_dimension_size(fileobj_write_field, trim(dim_unlim_name), dim_unlim_size) + ! write the time value if it is not already written to the file + if (.not.(variable_exists(fileobj_write_field, trim(dim_unlim_name)))) then + ! set the time units + t_units = "" + if (present(time_units)) then + t_units = get_time_units(time_units) + else + t_units = "days" + endif + + call register_field(fileobj_write_field, trim(dim_unlim_name), "double", dimensions=(/trim(dim_unlim_name)/)) + call register_variable_attribute(fileobj_write_field, trim(dim_unlim_name), 'units', trim(t_units)) + call write_data(fileobj_write_field, trim(dim_unlim_name), (/time_level/)) + else + ! write the next time value if it is larger than the most recent file time + if (write_field_time_index .gt. dim_unlim_size) & + call write_data(fileobj_write_field, trim(dim_unlim_name), (/time_level/), corner=(/write_field_time_index/), & + edge_lengths=(/1/)) + endif + endif + ! register the variable + if (.not.(variable_exists(fileobj_write_field, trim(fieldname)))) then + if (present(time_level)) then + call register_field(fileobj_write_field, trim(fieldname), "double", dimensions=(/trim(dim_unlim_name)/)) + else + call register_field(fileobj_write_field, trim(fieldname), "double") + endif + if (present(units)) & + call register_variable_attribute(fileobj_write_field, trim(fieldname), 'units', trim(units)) + if (present(longname)) & + call register_variable_attribute(fileobj_write_field, trim(fieldname), 'long_name', trim(longname)) + endif + ! write the data + if (present(time_level)) then + call write_data(fileobj_write_field, trim(fieldname), data, unlim_dim_level=write_field_time_index) + else + call write_data(fileobj_write_field, trim(fieldname), data) + endif + ! close the file + if (close_the_file) then + if (check_if_open(fileobj_write_field)) call fms2_close_file(fileobj_write_field) + if (allocated(pelist)) deallocate(pelist) + write_field_time_index=0 + endif +end subroutine write_scalar + +!> This function uses the fms_io function write_data to write a 1-D non-domain-decomposed data field named "fieldname" +!! to the file "filename" in "write", "overwrite", or "append" mode. It should be called after create_file in the MOM +!! file write procedure. +subroutine write_field_1d_noDD(filename, fieldname, data, mode, hor_grid, z_grid, & + start_index, edge_lengths, time_level, time_units, scale, & + checksums, G, dG, GV, leave_file_open, units, longname) + character(len=*), intent(in) :: filename !< The name of the file to read + character(len=*), intent(in) :: fieldname !< The variable name of the data in the file + real, target, dimension(:), intent(in) :: data !< The 1-dimensional data array to pass to read_data + character(len=*), intent(in) :: mode !< "write", "overwrite", or "append" + character(len=*), intent(in) :: hor_grid !< horizontal grid descriptor + character(len=*), intent(in) :: z_grid !< vertical grid descriptor + integer, dimension(1), optional, intent(in) :: start_index !< starting index of data buffer. Default is 1 + integer, dimension(1), optional, intent(in) :: edge_lengths !< number of data values to read in; default is the + !! variable size + real, optional, intent(in) :: time_level !< time value to write + real, optional, intent(in) :: time_units !< length of the units for time [s]. The + !! default value is 86400.0, for 1 day. + real, optional, intent(in) :: scale !< A scaling factor that the fields are multiplied by before they are written. + integer(kind=8), dimension(:,:), optional, intent(in) :: checksums !< variable checksum + type(ocean_grid_type), optional, intent(in) :: G !< ocean horizontal grid structure; G or dG + !! is required if the new file uses any + !! horizontal grid axes. + type(dyn_horgrid_type), optional, intent(in) :: dG !< dynamic horizontal grid structure; G or dG + !! is required if the new file uses any + !! horizontal grid axes. + type(verticalGrid_type), optional, intent(in) :: GV !< ocean vertical grid structure, which is + !! required if the new file uses any + !! vertical grid axes. + logical, optional, intent(in) :: leave_file_open !< if .true., leave file open + character(len=*), optional, intent(in) :: units !< variable units + character(len=*), optional, intent(in) :: longname !< long name variable attribute + ! local + logical :: file_open_success !.true. if call to open_file is successful + real, pointer, dimension(:) :: data_tmp => null() ! enables data to be passed to functions as intent(inout) + integer :: i, ndims, num_dims, substring_index + integer :: dim_unlim_size ! size of the unlimited dimension + integer, dimension(1) :: start, nwrite ! indices for first data value and number of values to write + character(len=20) :: t_units ! time units + character(len=nf90_max_name) :: dim_unlim_name ! name of the unlimited dimension in the file + character(len=1024) :: filename_temp + character(len=64) :: checksum_char ! checksum character array created from checksum argument + character(len=48), dimension(2) :: dim_names ! variable dimension names (up to 2 if appended at time level) + integer, dimension(2) :: dim_lengths ! variable dimension lengths + integer, allocatable, dimension(:) :: pelist ! list of pes associated with the netCDF file + logical :: close_the_file ! indicates whether to close the file after write_data is called; default is .true. + + close_the_file = .true. + if (present(leave_file_open)) close_the_file = .not.(leave_file_open) + + dim_unlim_size = 0 + dim_unlim_name= "Time" + dim_names(:) = "" + dim_lengths(:) = 0 + num_dims = 0 + + ! append '.nc' to the file name if it is missing + filename_temp = "" + substring_index = 0 + substring_index = index(trim(filename), ".nc") + if (substring_index <= 0) then + filename_temp = append_substring(filename,".nc") + else + filename_temp = filename + endif + ! get the dimension names and lengths + ! NOTE: the t_grid argument is set to '1' (do nothing) because the presence of a time dimension is user-specified + ! and not assumed from the t_grid value. + if (present(G)) then + call get_var_dimension_metadata(hor_grid, z_grid, '1', dim_names, & + dim_lengths, num_dims, G=G) + elseif(present(dG)) then + call get_var_dimension_metadata(hor_grid, z_grid, '1', dim_names, & + dim_lengths, num_dims, dG=dG) + endif + + if (present(GV)) & + call get_var_dimension_metadata(hor_grid, z_grid, '1', dim_names, & + dim_lengths, num_dims, GV=GV) + ! set the start (start_index) and nwrite (edge_lengths) values + start(:) = 1 + nwrite(:) = dim_lengths(1) + if (present(start_index)) then + start(1) = max(1,start_index(1)) + endif + + if (present(edge_lengths)) then + nwrite(1) = max(dim_lengths(1),edge_lengths(1)) + endif + + data_tmp => data + ! scale the data + if (present(scale)) then ; if (scale /= 1.0) then + call scale_data(data_tmp,scale) + endif ; endif + + if (.not.(check_if_open(fileobj_write_field))) then + if ((lowercase(trim(mode)) .ne. "write") .and. (lowercase(trim(mode)) .ne. "append") .and. & + (lowercase(trim(mode)) .ne. "overwrite")) & + call MOM_error(FATAL,"MOM_write_field_fms2:write_1d_noDD:mode argument must be write, overwrite, or append") + ! get the index of the corresponding time_level the first time the file is opened + if (present(time_level)) write_field_time_index = get_time_index(trim(filename_temp), time_level) + ! get the pes associated with the file. + !>\note this is required so that only pe(1) is identified as the root pe to create the file + !! Otherwise, multiple pes may try to open the file in write (NC_NOCLOBBER) mode, leading to failure + if (.not.(allocated(pelist))) then + allocate(pelist(mpp_npes())) + pelist(:) = 0 + do i=1,size(pelist) + pelist(i) = i-1 + enddo + endif + ! open the file in write or append mode + file_open_success = fms2_open_file(fileobj_write_field, trim(filename_temp), lowercase(trim(mode)), & + is_restart=.false., pelist=pelist) + endif + ! write the data, and the time value if it is not already written to the file + if (present(time_level)) then + call get_unlimited_dimension_name(fileobj_write_field,dim_unlim_name) + call get_dimension_size(fileobj_write_field, trim(dim_unlim_name), dim_unlim_size) + num_dims=num_dims+1 + dim_names(num_dims) = trim(dim_unlim_name) + + if (.not. (variable_exists(fileobj_write_field, trim(dim_unlim_name)))) then + ! set the time units + t_units = "" + if (present(time_units)) then + t_units = get_time_units(time_units) + else + t_units = "days" + endif + + call register_field(fileobj_write_field, trim(dim_unlim_name), "double", dimensions=(/trim(dim_unlim_name)/)) + call register_variable_attribute(fileobj_write_field, trim(dim_unlim_name), 'units', trim(t_units)) + call write_data(fileobj_write_field, trim(dim_unlim_name), (/time_level/), corner=(/write_field_time_index/)) + else + ! write the time value if it is larger than the most recent file time + if (write_field_time_index .gt. dim_unlim_size) & + call write_data(fileobj_write_field, trim(dim_unlim_name), (/time_level/), corner=(/write_field_time_index/), & + edge_lengths=(/1/)) + endif + endif + ! register the field if it is not already in the file + if (.not.(variable_exists(fileobj_write_field, trim(fieldname)))) then + call register_field(fileobj_write_field, trim(fieldname), "double", dimensions=dim_names(1:num_dims)) + if (present(units)) & + call register_variable_attribute(fileobj_write_field, trim(fieldname), 'units', trim(units)) + if (present(longname)) & + call register_variable_attribute(fileobj_write_field, trim(fieldname), 'long_name', trim(longname)) + ! write the checksum attribute + if (present(checksums)) then + ! convert the checksum to a string + checksum_char = '' + checksum_char = convert_checksum_to_string(checksums(1,1)) + call register_variable_attribute(fileobj_write_field, trim(fieldname), "checksum", checksum_char) + endif + endif + ! write the variable to the file + if (present(time_level)) then + call write_data(fileobj_write_field, trim(fieldname), data_tmp, corner=start, edge_lengths=nwrite, & + unlim_dim_level=write_field_time_index) + else + call write_data(fileobj_write_field, trim(fieldname), data_tmp, corner=start, edge_lengths=nwrite) + endif + ! close the file + if (close_the_file) then + if (check_if_open(fileobj_write_field)) call fms2_close_file(fileobj_write_field) + if (allocated(pelist)) deallocate(pelist) + write_field_time_index = 0 + endif + nullify(data_tmp) + +end subroutine write_field_1d_noDD + +!> This function uses the fms_io function write_data to write a scalar variable named "fieldname" +!! to the file "filename" in "write", "overwrite", or "append" mode. It should be called after create_file in the MOM +!! file write procedure. +subroutine write_field_2d_noDD(filename, fieldname, data, mode, hor_grid, z_grid, & + start_index, edge_lengths, time_level, time_units, scale, & + checksums, G, dG, GV, leave_file_open, units, longname) + character(len=*), intent(in) :: filename !< The name of the file to read + character(len=*), intent(in) :: fieldname !< The variable name of the data in the file + real, target, dimension(:,:), intent(in) :: data !< The 2-dimensional data array to pass to read_data + character(len=*), intent(in) :: mode !< "write", "overwrite", or "append" + character(len=*), intent(in) :: hor_grid !< horizontal grid descriptor + character(len=*), intent(in) :: z_grid !< vertical grid descriptor + integer, dimension(2), optional, intent(in) :: start_index !< starting index of data buffer. Default is 1 + integer, dimension(2), optional, intent(in) :: edge_lengths !< number of data values to read in; default is the + !! variable size + real, optional, intent(in) :: time_level !< time value to write + real, optional, intent(in) :: time_units !< length of the units for time [s]. The + !! default value is 86400.0, for 1 day. + real, optional, intent(in) :: scale !< A scaling factor that the fields are multiplied by before they are written. + integer(kind=8), dimension(:,:), optional, intent(in) :: checksums !< variable checksum + type(ocean_grid_type), optional, intent(in) :: G !< ocean horizontal grid structure; G or dG + !! is required if the new file uses any + !! horizontal grid axes. + type(dyn_horgrid_type), optional, intent(in) :: dG !< dynamic horizontal grid structure; G or dG + !! is required if the new file uses any + !! horizontal grid axes. + type(verticalGrid_type), optional, intent(in) :: GV !< ocean vertical grid structure, which is + !! required if the new file uses any + !! vertical grid axes. + logical, optional, intent(in) :: leave_file_open !< flag indicating whether to leave the file open + character(len=*), optional, intent(in) :: units !< variable units + character(len=*), optional, intent(in) :: longname !< long name variable attribute + ! local + logical :: file_open_success ! .true. if call to open_file is successful + logical :: close_the_file ! indicates whether to close the file after write_data is called; default is .true. + real, pointer, dimension (:,:) :: data_tmp => null() ! enables data to be passed to functions as intent(inout) + integer :: i, ndims, num_dims, substring_index + integer :: dim_unlim_size ! size of the unlimited dimension + integer, dimension(2) :: start, nwrite ! indices for starting points and number of values to write + character(len=20) :: t_units ! time units + character(len=nf90_max_name) :: dim_unlim_name ! name of the unlimited dimension in the file + character(len=1024) :: filename_temp + character(len=64) :: checksum_char ! checksum character array created from checksum argument + character(len=48), dimension(3) :: dim_names ! variable dimension names + integer, dimension(3) :: dim_lengths ! variable dimension lengths + integer, allocatable, dimension(:) :: pelist ! list of pes associated with the netCDF file + + close_the_file = .true. + if (present(leave_file_open)) close_the_file = .not.(leave_file_open) + + dim_unlim_size = 0 + dim_unlim_name = "" + dim_names(:) = "" + dim_lengths(:) = 0 + num_dims = 0 + + ! append '.nc' to the file name if it is missing + filename_temp = "" + substring_index = 0 + substring_index = index(trim(filename), ".nc") + if (substring_index <= 0) then + filename_temp = append_substring(filename,".nc") + else + filename_temp = filename + endif + + ! get the dimension names and lengths + ! NOTE: the t_grid argument is set to '1' (do nothing) because the presence of a time dimension is user-specified + ! and not assumed from the t_grid value + if (present(G)) then + call get_var_dimension_metadata(hor_grid, z_grid, '1', dim_names, & + dim_lengths, num_dims, G=G) + elseif(present(dG)) then + call get_var_dimension_metadata(hor_grid, z_grid, '1', dim_names, & + dim_lengths, num_dims, dG=dG) + endif + + if (present(GV)) & + call get_var_dimension_metadata(hor_grid, z_grid, '1', dim_names, & + dim_lengths, num_dims, GV=GV) + + ! set the start (start_index) and nwrite (edge_lengths) values + ndims=2 + start(:) = 1 + nwrite(:) = dim_lengths(1:2) + if (present(start_index)) then + do i=1,ndims + start(i) = max(1,start_index(i)) + enddo + endif + + if (present(edge_lengths)) then + do i=1,ndims + nwrite(i) = max(dim_lengths(i),edge_lengths(i)) + enddo + endif + + data_tmp => data + ! scale the data + if (present(scale)) then ; if (scale /= 1.0) then + call scale_data(data_tmp,scale) + endif ; endif + + if (.not.(check_if_open(fileobj_write_field))) then + if ((lowercase(trim(mode)) .ne. "write") .and. (lowercase(trim(mode)) .ne. "append") .and. & + (lowercase(trim(mode)) .ne. "overwrite")) & + call MOM_error(FATAL,"MOM_write_field_fms2:write_2d_noDD:mode argument must be write, overwrite, or append") + ! get the time_level index + if (present(time_level)) write_field_time_index = get_time_index(trim(filename_temp), time_level) + ! get the pes associated with the file. + !>\note this is required so that only pe(1) is identified as the root pe to create the file + !! Otherwise, multiple pes may try to open the file in write (NC_NOCLOBBER) mode, leading to failure + if(.not.(allocated(pelist))) then + allocate(pelist(mpp_npes())) + pelist(:) = 0 + do i=1,size(pelist) + pelist(i) = i-1 + enddo + endif + ! open the file in write or append mode + file_open_success = fms2_open_file(fileobj_write_field, trim(filename_temp), lowercase(trim(mode)), & + is_restart=.false., pelist=pelist) + endif + + if (present(time_level)) then + call get_unlimited_dimension_name(fileobj_write_field,dim_unlim_name) + call get_dimension_size(fileobj_write_field, trim(dim_unlim_name), dim_unlim_size) + num_dims=num_dims+1 + dim_names(num_dims) = trim(dim_unlim_name) + + if (.not. (variable_exists(fileobj_write_field, trim(dim_unlim_name)))) then + ! set the time units + t_units = "" + if (present(time_units)) then + t_units = get_time_units(time_units) + else + t_units = "days" + endif + + call register_field(fileobj_write_field, trim(dim_unlim_name), "double", dimensions=(/trim(dim_unlim_name)/)) + call register_variable_attribute(fileobj_write_field, trim(dim_unlim_name), 'units', trim(t_units)) + call write_data(fileobj_write_field, trim(dim_unlim_name), (/time_level/), corner=(/write_field_time_index/)) + else + ! write the time value if it is larger than the most recent file time + if (write_field_time_index .gt. dim_unlim_size) & + call write_data(fileobj_write_field, trim(dim_unlim_name), (/time_level/), corner=(/write_field_time_index/), & + edge_lengths=(/1/)) + endif + endif + + ! register the variable to the file + if (.not.(variable_exists(fileobj_write_field, trim(fieldname)))) then + call register_field(fileobj_write_field, trim(fieldname), "double", dimensions=dim_names(1:num_dims)) + if (present(units)) & + call register_variable_attribute(fileobj_write_field, trim(fieldname), 'units', trim(units)) + if (present(longname)) & + call register_variable_attribute(fileobj_write_field, trim(fieldname), 'long_name', trim(longname)) + ! write the checksum attribute + if (present(checksums)) then + ! convert the checksum to a string + checksum_char = "" + checksum_char = convert_checksum_to_string(checksums(1,1)) + call register_variable_attribute(fileobj_write_field, trim(fieldname), "checksum", checksum_char) + endif + endif + ! write the variable to the file + if (present(time_level)) then + call write_data(fileobj_write_field, trim(fieldname), data_tmp, corner=start, edge_lengths=nwrite, & + unlim_dim_level=write_field_time_index) + else + call write_data(fileobj_write_field, trim(fieldname), data_tmp, corner=start, edge_lengths=nwrite) + endif + ! close the file + if (close_the_file) then + if (check_if_open(fileobj_write_field)) call fms2_close_file(fileobj_write_field) + if (allocated(pelist)) deallocate(pelist) + write_field_time_index=0 + endif + nullify(data_tmp) +end subroutine write_field_2d_noDD + +!> This function uses the fms_io function write_data to write a 3-D non-domain-decomposed data field named "fieldname" +!! to the file "filename" in "write", "overwrite", or "append" mode. It should be called after create_file in the MOM +!! file write procedure. +subroutine write_field_3d_noDD(filename, fieldname, data, mode, hor_grid, z_grid, & + start_index, edge_lengths, time_level, time_units, scale, & + checksums, G, dG, GV, leave_file_open, units, longname) + character(len=*), intent(in) :: filename !< The name of the file to read + character(len=*), intent(in) :: fieldname !< The variable name of the data in the file + real, target, dimension(:,:,:), intent(in) :: data !< The 3-dimensional data array to pass to read_data + character(len=*), intent(in) :: mode !< "write", "overwrite", or "append" + character(len=*), intent(in) :: hor_grid !< horizontal grid descriptor + character(len=*), intent(in) :: z_grid !< vertical grid descriptor + integer, dimension(4), optional, intent(in) :: start_index !< starting index of data buffer. Default is 1 + integer, dimension(4), optional, intent(in) :: edge_lengths !< number of data values to read in; default is the + !! variable size + real, optional, intent(in) :: time_level !< time value to write + real, optional, intent(in) :: time_units !< length of the units for time [s]. The + !! default value is 86400.0, for 1 day. + real, optional, intent(in) :: scale !< A scaling factor that the fields are multiplied by before they are written. + integer(kind=8), dimension(:,:), optional, intent(in) :: checksums !< variable checksum + type(ocean_grid_type), optional, intent(in) :: G !< ocean horizontal grid structure; G or dG + !! is required if the new file uses any + !! horizontal grid axes. + type(dyn_horgrid_type), optional, intent(in) :: dG !< dynamic horizontal grid structure; G or dG + !! is required if the new file uses any + !! horizontal grid axes. + type(verticalGrid_type), optional, intent(in) :: GV !< ocean vertical grid structure, which is + !! required if the new file uses any + !! vertical grid axes. + logical, optional, intent(in) :: leave_file_open !< flag indicating whether to leave the file open + character(len=*), optional, intent(in) :: units !< variable units + character(len=*), optional, intent(in) :: longname !< long name variable attribute + ! local + logical :: file_open_success !.true. if call to open_file is successful + logical :: close_the_file ! indicates whether to close the file after write_data is called; default is .true. + real, pointer, dimension(:,:,:) :: data_tmp => null() ! enables data to be passed to functions as intent(inout) + integer :: i, ndims, num_dims, substring_index + integer :: dim_unlim_size ! size of the unlimited dimension + integer, dimension(3) :: start, nwrite ! indices for first data value and number of values to write + character(len=20) :: t_units ! time_units + character(len=nf90_max_name) :: dim_unlim_name ! name of the unlimited dimension in the file + character(len=1024) :: filename_temp + character(len=64) :: checksum_char ! checksum character array created from checksum argument + character(len=48), dimension(4) :: dim_names ! variable dimension names + integer, dimension(4) :: dim_lengths ! variable dimension lengths + integer, allocatable, dimension(:) :: pelist ! list of pes associated with the netCDF file + + close_the_file = .true. + if (present(leave_file_open)) close_the_file = .not.(leave_file_open) + + dim_unlim_size = 0 + dim_unlim_name = "" + dim_names(:) = "" + dim_lengths(:) = 0 + num_dims = 0 + ! append '.nc' to the file name if it is missing + filename_temp = "" + substring_index = 0 + substring_index = index(trim(filename), ".nc") + if (substring_index <= 0) then + filename_temp = append_substring(filename,".nc") + else + filename_temp = filename + endif + ! get the dimension names and lengths + ! NOTE: the t_grid argument is set to '1' (do nothing) because the presence of a time dimension is user-specified + ! and not assumed from the t_grid value + if (present(G)) then + call get_var_dimension_metadata(hor_grid, z_grid, '1', dim_names, & + dim_lengths, num_dims, G=G) + elseif(present(dG)) then + call get_var_dimension_metadata(hor_grid, z_grid, '1', dim_names, & + dim_lengths, num_dims, dG=dG) + endif + + if (present(GV)) & + call get_var_dimension_metadata(hor_grid, z_grid, '1', dim_names, & + dim_lengths, num_dims, GV=GV) + ! set the start (start_index) and nwrite (edge_lengths) values + ndims = 3 + start(:) = 1 + nwrite(:) = dim_lengths(1:3) + if (present(start_index)) then + do i=1,ndims + start(i) = max(1,start_index(i)) + enddo + endif + + if (present(edge_lengths)) then + do i=1,ndims + nwrite(i) = max(dim_lengths(i), edge_lengths(i)) + enddo + endif + + data_tmp => data + ! scale the data + if (present(scale)) then ; if (scale /= 1.0) then + call scale_data(data_tmp,scale) + endif ; endif + ! open the file + if (.not.(check_if_open(fileobj_write_field))) then + if ((lowercase(trim(mode)) .ne. "write") .and. (lowercase(trim(mode)) .ne. "append") .and. & + (lowercase(trim(mode)) .ne. "overwrite")) & + call MOM_error(FATAL,"MOM_io:write_3d_noDD:mode argument must be write, overwrite, or append") + ! get the time_level index + if (present(time_level)) write_field_time_index = get_time_index(trim(filename_temp), time_level) + ! get the pes associated with the file. + !>\note this is required so that only pe(1) is identified as the root pe to create the file + !! Otherwise, multiple pes may try to open the file in write (NC_NOCLOBBER) mode, leading to failure + if (.not.(allocated(pelist))) then + allocate(pelist(mpp_npes())) + pelist(:) = 0 + do i=1,size(pelist) + pelist(i) = i-1 + enddo + endif + ! open the file in write or append mode + file_open_success = fms2_open_file(fileobj_write_field, trim(filename_temp), lowercase(trim(mode)), & + is_restart=.false., pelist=pelist) + endif + ! register and write the time_level + if (present(time_level)) then + call get_unlimited_dimension_name(fileobj_write_field,dim_unlim_name) + call get_dimension_size(fileobj_write_field, trim(dim_unlim_name), dim_unlim_size) + num_dims=num_dims+1 + dim_names(num_dims) = trim(dim_unlim_name) + + if (.not. (variable_exists(fileobj_write_field, trim(dim_unlim_name)))) then + ! set the time units + t_units = "" + if (present(time_units)) then + t_units = get_time_units(time_units) + else + t_units = "days" + endif + + call register_field(fileobj_write_field, trim(dim_unlim_name), "double", dimensions=(/trim(dim_unlim_name)/)) + call register_variable_attribute(fileobj_write_field, trim(dim_unlim_name), 'units', trim(t_units)) + call write_data(fileobj_write_field, trim(dim_unlim_name), (/time_level/), corner=(/write_field_time_index/)) + else + ! write the time_level if it is larger than the most recent file time + if (write_field_time_index .gt. dim_unlim_size) & + call write_data(fileobj_write_field, trim(dim_unlim_name), (/time_level/), corner=(/write_field_time_index/), & + edge_lengths=(/1/)) + endif + endif + ! register the field if it is not already in the file + if (.not.(variable_exists(fileobj_write_field, trim(fieldname)))) then + call register_field(fileobj_write_field, trim(fieldname), "double", dimensions=dim_names(1:num_dims)) + if (present(units)) & + call register_variable_attribute(fileobj_write_field, trim(fieldname), 'units', trim(units)) + if (present(longname)) & + call register_variable_attribute(fileobj_write_field, trim(fieldname), 'long_name', trim(longname)) + ! write the checksum attribute + if (present(checksums)) then + ! convert the checksum to a string + checksum_char = "" + checksum_char = convert_checksum_to_string(checksums(1,1)) + call register_variable_attribute(fileobj_write_field, trim(fieldname), "checksum", checksum_char) + endif + endif + + if (present(time_level)) then + call get_dimension_size(fileobj_write_field, trim(dim_unlim_name), dim_unlim_size) + call write_data(fileobj_write_field, trim(fieldname), data_tmp, corner=start, edge_lengths=nwrite, & + unlim_dim_level=write_field_time_index) + else + call write_data(fileobj_write_field, trim(fieldname), data_tmp, corner=start, edge_lengths=nwrite) + endif + ! close the file + if (close_the_file) then + if (check_if_open(fileobj_write_field)) call fms2_close_file(fileobj_write_field) + if (allocated(pelist)) deallocate(pelist) + write_field_time_index=0 + endif + nullify(data_tmp) +end subroutine write_field_3d_noDD + +!> This function uses the fms_io function write_data to write a 4-D non-domain-decomposed data field named "fieldname" +!! to the file "filename" in "write", "overwrite", or "append" mode. It should be called after create_file in the MOM +!! file write procedure. +subroutine write_field_4d_noDD(filename, fieldname, data, mode, hor_grid, z_grid, t_grid, & + start_index, edge_lengths, time_level, time_units, scale, & + checksums, G, dG, GV, leave_file_open, units, longname) + character(len=*), intent(in) :: filename !< The name of the file to read + character(len=*), intent(in) :: fieldname !< The variable name of the data in the file + real, target, dimension(:,:,:,:), intent(in) :: data !< The 1-dimensional data array to pass to read_data + character(len=*), intent(in) :: mode !< "write", "overwrite", or "append" + character(len=*), intent(in) :: hor_grid !< horizontal grid descriptor + character(len=*), intent(in) :: z_grid !< vertical grid descriptor + character(len=*), intent(in) :: t_grid !< time descriptor + integer, dimension(4), optional, intent(in) :: start_index !< starting index of data buffer. Default is 1 + integer, dimension(4), optional, intent(in) :: edge_lengths !< number of data values to read in; default is the + !! variable size + real, optional, intent(in) :: time_level !< time value to write + real, optional, intent(in) :: time_units !< length of the units for time [s]. The + !! default value is 86400.0, for 1 day. + real, optional, intent(in) :: scale !< A scaling factor that the fields are multiplied by before they are written. + integer(kind=8), dimension(:,:), optional, intent(in) :: checksums !< variable checksum + type(ocean_grid_type), optional, intent(in) :: G !< ocean horizontal grid structure; G or dG + !! is required if the new file uses any + !! horizontal grid axes. + type(dyn_horgrid_type), optional, intent(in) :: dG !< dynamic horizontal grid structure; G or dG + !! is required if the new file uses any + !! horizontal grid axes. + type(verticalGrid_type), optional, intent(in) :: GV !< ocean vertical grid structure, which is + !! required if the new file uses any + !! vertical grid axes. + logical, optional, intent(in) :: leave_file_open !< flag indicating whether to leave the file open + character(len=*), optional, intent(in) :: units !< variable units + character(len=*), optional, intent(in) :: longname !< long name variable attribute + ! local + logical :: file_open_success !.true. if call to open_file is successful + logical :: close_the_file ! indicates whether to close the file after write_data is called; default is .true. + real, pointer, dimension(:,:,:,:) :: data_tmp => null() ! enables data to be passed to functions as intent(inout) + integer :: i, ndims, num_dims, substring_index + integer :: dim_unlim_size ! size of the unlimited dimension + integer, dimension(4) :: start, nwrite ! indices for first data value and number of values to write + character(len=20) :: t_units ! time units + character(len=nf90_max_name) :: dim_unlim_name ! name of the unlimited dimension in the file + character(len=1024) :: filename_temp + character(len=64) :: checksum_char ! checksum character array created from checksum argument + character(len=48), dimension(4) :: dim_names ! variable dimension names + integer, dimension(4) :: dim_lengths ! variable dimension lengths + integer, allocatable, dimension(:) :: pelist ! list of pes associated with the netCDF file + + close_the_file = .true. + if (present(leave_file_open)) close_the_file = .not.(leave_file_open) + + dim_unlim_size = 0 + dim_unlim_name = "" + dim_names(:) = "" + dim_lengths(:) = 0 + ndims = 4 + num_dims = 0 + ! append '.nc' to the file name if it is missing + filename_temp = "" + substring_index = 0 + substring_index = index(trim(filename), ".nc") + if (substring_index <= 0) then + filename_temp = append_substring(filename,".nc") + else + filename_temp = filename + endif + + ! get the dimension names and lengths + if (present(G)) then + call get_var_dimension_metadata(hor_grid, z_grid, t_grid, dim_names, & + dim_lengths, num_dims, G=G) + elseif(present(dG)) then + call get_var_dimension_metadata(hor_grid, z_grid, t_grid, dim_names, & + dim_lengths, num_dims, dG=dG) + endif + if (present(GV)) & + call get_var_dimension_metadata(hor_grid, z_grid, t_grid, dim_names, & + dim_lengths, num_dims, GV=GV) + ! set the start (start_index) and nwrite (edge_lengths) values + start(:) = 1 + nwrite(:) = dim_lengths(:) + if (present(start_index)) then + do i=1,ndims + start(i) = max(1, start_index(i)) + enddo + endif + + if (present(edge_lengths)) then + do i=1,ndims + nwrite(i) = max(dim_lengths(i), edge_lengths(i)) + enddo + endif + + data_tmp => data + ! scale the data + if (present(scale)) then ; if (scale /= 1.0) then + call scale_data(data_tmp,scale) + endif ; endif + ! open the file + if (.not.(check_if_open(fileobj_write_field))) then + if ((lowercase(trim(mode)) .ne. "write") .and. (lowercase(trim(mode)) .ne. "append") .and. & + (lowercase(trim(mode)) .ne. "overwrite")) & + call MOM_error(FATAL,"MOM_write_field_fms2:write_4d_noDD:mode argument must be write, overwrite, or append") + ! get the time_level index + if (present(time_level)) write_field_time_index = get_time_index(trim(filename_temp), time_level) + ! get the pes associated with the file. + !>\note this is required so that only pe(1) is identified as the root pe to create the file + !! Otherwise, multiple pes may try to open the file in write (NC_NOCLOBBER) mode, leading to failure + if (.not.(allocated(pelist))) then + allocate(pelist(mpp_npes())) + pelist(:) = 0 + do i=1,size(pelist) + pelist(i) = i-1 + enddo + endif + ! open the file in write or append mode + file_open_success = fms2_open_file(fileobj_write_field, trim(filename_temp), lowercase(trim(mode)), & + is_restart=.false., pelist=pelist) + endif + ! register and write the time_level + if (present(time_level)) then + call get_unlimited_dimension_name(fileobj_write_field,dim_unlim_name) + call get_dimension_size(fileobj_write_field, trim(dim_unlim_name), dim_unlim_size) + num_dims=num_dims+1 + dim_names(num_dims) = trim(dim_unlim_name) + ! write the time value if it is not already written to the file + if (.not. (variable_exists(fileobj_write_field, trim(dim_unlim_name)))) then + ! set the time units + t_units = "" + if (present(time_units)) then + t_units = get_time_units(time_units) + else + t_units = "days" + endif + + call register_field(fileobj_write_field, trim(dim_unlim_name), "double", dimensions=(/trim(dim_unlim_name)/)) + call register_variable_attribute(fileobj_write_field, trim(dim_unlim_name), 'units', trim(t_units)) + call write_data(fileobj_write_field, trim(dim_unlim_name), (/time_level/), corner=(/write_field_time_index/)) + else + if (write_field_time_index .gt. dim_unlim_size) & + call write_data(fileobj_write_field, trim(dim_unlim_name), (/time_level/), corner=(/write_field_time_index/), & + edge_lengths=(/1/)) + endif + endif + ! register the variable + if (.not.(variable_exists(fileobj_write_field, trim(fieldname)))) then + call register_field(fileobj_write_field, trim(fieldname), "double", dimensions=dim_names(1:num_dims)) + if (present(units)) & + call register_variable_attribute(fileobj_write_field, trim(fieldname), 'units', trim(units)) + if (present(longname)) & + call register_variable_attribute(fileobj_write_field, trim(fieldname), 'long_name', trim(longname)) + ! write the checksum attribute + if (present(checksums)) then + ! convert the checksum to a string + checksum_char = "" + checksum_char = convert_checksum_to_string(checksums(1,1)) + call register_variable_attribute(fileobj_write_field, trim(fieldname), "checksum", checksum_char) + endif + endif + ! write the variable to the file + if (present(time_level)) then + call write_data(fileobj_write_field, trim(fieldname), data_tmp, corner=start, edge_lengths=nwrite, & + unlim_dim_level=write_field_time_index) + else + call write_data(fileobj_write_field, trim(fieldname), data_tmp, corner=start, edge_lengths=nwrite) + endif + ! close the file + if (close_the_file) then + if (check_if_open(fileobj_write_field)) call fms2_close_file(fileobj_write_field) + deallocate(pelist) + write_field_time_index=0 + endif + nullify(data_tmp) +end subroutine write_field_4d_nodd + +!> apply a scale factor to a 1d array +subroutine scale_data_1d(data, scale_factor) + real, dimension(:), intent(inout) :: data !< The 1-dimensional data array + real, intent(in) :: scale_factor !< Scale factor + + if (scale_factor /= 1.0) then + data(:) = scale_factor*data(:) + endif +end subroutine scale_data_1d + +!> apply a scale factor to a 2d array +subroutine scale_data_2d(data, scale_factor, MOM_domain) + real, dimension(:,:), intent(inout) :: data !< The 2-dimensional data array + real, intent(in) :: scale_factor !< Scale factor + type(MOM_domain_type), optional, intent(in) :: MOM_Domain !< The domain that describes the decomposition + ! local + integer :: is, ie, js, je + + if (scale_factor /= 1.0) then + if (present(MOM_domain)) then + call get_simple_array_i_ind(MOM_Domain, size(data,1), is, ie) + call get_simple_array_j_ind(MOM_Domain, size(data,2), js, je) + data(is:ie,js:je) = scale_factor*data(is:ie,js:je) + else + data(:,:) = scale_factor*data(:,:) + endif + endif +end subroutine scale_data_2d + +!> apply a scale factor to a 3d array +subroutine scale_data_3d(data, scale_factor, MOM_domain) + real, dimension(:,:,:), intent(inout) :: data !< The 3-dimensional data array + real, intent(in) :: scale_factor !< Scale factor + type(MOM_domain_type), optional, intent(in) :: MOM_Domain !< The domain that describes the decomposition + ! local + integer :: is, ie, js, je + + if (scale_factor /= 1.0) then + if (present(MOM_domain)) then + call get_simple_array_i_ind(MOM_Domain, size(data,1), is, ie) + call get_simple_array_j_ind(MOM_Domain, size(data,2), js, je) + data(is:ie,js:je,:) = scale_factor*data(is:ie,js:je,:) + else + data(:,:,:) = scale_factor*data(:,:,:) + endif + endif +end subroutine scale_data_3d + +!> apply a scale factor to a 4d array +subroutine scale_data_4d(data, scale_factor, MOM_domain) + real, dimension(:,:,:,:), intent(inout) :: data !< The 4-dimensional data array + real, intent(in) :: scale_factor !< Scale factor + type(MOM_domain_type), optional, intent(in) :: MOM_Domain !< The domain that describes the decomposition + ! local + integer :: is, ie, js, je + + if (scale_factor /= 1.0) then + if (present(MOM_domain)) then + call get_simple_array_i_ind(MOM_Domain, size(data,1), is, ie) + call get_simple_array_j_ind(MOM_Domain, size(data,2), js, je) + data(is:ie,js:je,:,:) = scale_factor*data(is:ie,js:je,:,:) + else + data(:,:,:,:) = scale_factor*data(:,:,:,:) + endif + endif +end subroutine scale_data_4d + + +end module MOM_write_field_fms2 diff --git a/src/ice_shelf/MOM_ice_shelf.F90 b/src/ice_shelf/MOM_ice_shelf.F90 index 66fd873f67..fe9a5bc75f 100644 --- a/src/ice_shelf/MOM_ice_shelf.F90 +++ b/src/ice_shelf/MOM_ice_shelf.F90 @@ -1512,8 +1512,9 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl elseif (.not.new_sim) then ! This line calls a subroutine that reads the initial conditions from a restart file. call MOM_mesg("MOM_ice_shelf.F90, initialize_ice_shelf: Restoring ice shelf from file.") - call restore_state(dirs%input_filename, dirs%restart_input_dir, Time, & - G, CS%restart_CSp) + ! NOTE: use_fms2=.true. routes routine to fms2 IO interface + call restore_state(dirs%input_filename, dirs%restart_input_dir, Time, & + G, CS%restart_CSp, use_fms2=.true.) if ((US%m_to_Z_restart /= 0.0) .and. (US%m_to_Z_restart /= US%m_to_Z)) then Z_rescale = US%m_to_Z / US%m_to_Z_restart @@ -1587,7 +1588,7 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl if (save_IC .and. .not.((dirs%input_filename(1:1) == 'r') .and. & (LEN_TRIM(dirs%input_filename) == 1))) then call save_restart(dirs%output_directory, CS%Time, G, & - CS%restart_CSp, filename=IC_file) + CS%restart_CSp, filename=IC_file, write_ic=.true.) endif @@ -1780,8 +1781,8 @@ subroutine ice_shelf_save_restart(CS, Time, directory, time_stamped, filename_su if (present(directory)) then ; restart_dir = directory else ; restart_dir = CS%restart_output_dir ; endif - - call save_restart(restart_dir, Time, CS%grid, CS%restart_CSp, time_stamped) + ! NOTE: first use_fms2=.true. routes routine to fms2 IO interface + call save_restart(restart_dir, Time, CS%grid, CS%restart_CSp, time_stamped, use_fms2=.true.) end subroutine ice_shelf_save_restart diff --git a/src/initialization/MOM_state_initialization.F90 b/src/initialization/MOM_state_initialization.F90 index 9f505325bf..983c008473 100644 --- a/src/initialization/MOM_state_initialization.F90 +++ b/src/initialization/MOM_state_initialization.F90 @@ -481,8 +481,10 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, US, PF, dirs, & if (.not.new_sim) then ! This block restores the state from a restart file. ! This line calls a subroutine that reads the initial conditions ! from a previously generated file. + + ! NOTE: use_fms2=.true. routes routine to fms2 IO interface call restore_state(dirs%input_filename, dirs%restart_input_dir, Time, & - G, restart_CS) + G, restart_CS, use_fms2=.true.) if (present(Time_in)) Time = Time_in if ((GV%m_to_H_restart /= 0.0) .and. (GV%m_to_H_restart /= GV%m_to_H)) then H_rescale = GV%m_to_H / GV%m_to_H_restart From a74c7eaba8d7ef3e067ff23db83d312e4fcb9e3a Mon Sep 17 00:00:00 2001 From: wrongkindofdoctor <> Date: Fri, 31 Jul 2020 15:52:01 -0400 Subject: [PATCH 7/9] changed FMS release to 2020.03-beta1 --- .testing/Makefile | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.testing/Makefile b/.testing/Makefile index 05fb630a31..4d45bc4575 100644 --- a/.testing/Makefile +++ b/.testing/Makefile @@ -20,7 +20,7 @@ MKMF := $(abspath $(DEPS)/mkmf/bin/mkmf) # FMS framework FMS_URL ?= https://github.com/NOAA-GFDL/FMS.git -FMS_COMMIT ?= 2020.03-alpha1 +FMS_COMMIT ?= 2020.03-beta1 FMS := $(DEPS)/fms #--- From 809b3ac52763b45daec4ea6ef2e8d2c3b35ff47e Mon Sep 17 00:00:00 2001 From: wrongkindofdoctor <> Date: Fri, 31 Jul 2020 17:41:26 -0400 Subject: [PATCH 8/9] added local logical variables to save restart wrapper that are set using the use_fms2 and write_ic flags if present to avoid invalid memory reference error added str_len argument to register_variable_attribute calls added support to for rotated fields to write_initial_conditions and save_restart_fms2 removed whitespace --- src/framework/MOM_io.F90 | 18 +++-- src/framework/MOM_restart.F90 | 143 ++++++++++++++++++++++++---------- 2 files changed, 114 insertions(+), 47 deletions(-) diff --git a/src/framework/MOM_io.F90 b/src/framework/MOM_io.F90 index 6768e47dfa..b36e8e5dd8 100644 --- a/src/framework/MOM_io.F90 +++ b/src/framework/MOM_io.F90 @@ -541,14 +541,17 @@ subroutine create_file_fms2_filename(filename, vars, numVariables, use_fms2, reg "double", dimensions=(/trim(axis_data_CS%axis(j)%name)/)) call register_variable_attribute(fileObjDD, trim(axis_data_CS%axis(j)%name), & - 'long_name', axis_data_CS%axis(j)%longname) + 'long_name', axis_data_CS%axis(j)%longname, & + str_len=len_trim(axis_data_CS%axis(j)%longname)) call register_variable_attribute(fileObjDD, trim(axis_data_CS%axis(j)%name), & - 'units', trim(axis_data_CS%axis(j)%units)) + 'units', trim(axis_data_CS%axis(j)%units), & + str_len=len_trim(axis_data_CS%axis(j)%units)) if (len_trim(axis_data_CS%axis(j)%positive)>1) & call register_variable_attribute(fileObjDD, trim(axis_data_CS%axis(j)%name), & - 'positive', trim(axis_data_CS%axis(j)%positive)) + 'positive', trim(axis_data_CS%axis(j)%positive), & + str_len=len_trim(axis_data_CS%axis(j)%positive)) if (axis_data_CS%axis(j)%is_domain_decomposed) then call get_global_io_domain_indices(fileObjDD, trim(axis_data_CS%axis(j)%name), is, ie) @@ -801,14 +804,17 @@ subroutine create_file_fms2_fileobj(filename, fileObjDD, vars, numVariables, reg "double", dimensions=(/trim(axis_data_CS%axis(j)%name)/)) call register_variable_attribute(fileObjDD, trim(axis_data_CS%axis(j)%name), & - 'long_name', axis_data_CS%axis(j)%longname) + 'long_name', axis_data_CS%axis(j)%longname, & + str_len=len_trim(axis_data_CS%axis(j)%longname)) call register_variable_attribute(fileObjDD, trim(axis_data_CS%axis(j)%name), & - 'units', trim(axis_data_CS%axis(j)%units)) + 'units', trim(axis_data_CS%axis(j)%units), & + str_len=len_trim(axis_data_CS%axis(j)%units)) if (len_trim(axis_data_CS%axis(j)%positive)>1) & call register_variable_attribute(fileObjDD, trim(axis_data_CS%axis(j)%name), & - 'positive', trim(axis_data_CS%axis(j)%positive)) + 'positive', trim(axis_data_CS%axis(j)%positive), & + str_len=len_trim(axis_data_CS%axis(j)%positive)) if (axis_data_CS%axis(j)%is_domain_decomposed) then call get_global_io_domain_indices(fileObjDD, trim(axis_data_CS%axis(j)%name), is, ie) diff --git a/src/framework/MOM_restart.F90 b/src/framework/MOM_restart.F90 index 07c054351a..f9dc13758e 100644 --- a/src/framework/MOM_restart.F90 +++ b/src/framework/MOM_restart.F90 @@ -12,6 +12,7 @@ module MOM_restart use MOM_io, only : vardesc, var_desc, query_vardesc, modify_vardesc use MOM_io, only : MULTIPLE, NETCDF_FILE, READONLY_FILE, SINGLE_FILE use MOM_io, only : CENTER, CORNER, NORTH_FACE, EAST_FACE +use MOM_array_transform, only : allocate_rotated_array, rotate_array use MOM_axis, only : get_time_units, convert_checksum_to_string use MOM_axis, only : axis_data_type, MOM_get_diagnostic_axis_data use MOM_axis, only : MOM_register_diagnostic_axis, get_var_dimension_metadata @@ -875,10 +876,16 @@ subroutine save_restart(directory, time, G, CS, time_stamped, filename, GV, use_ type(verticalGrid_type), optional, intent(in) :: GV !< The ocean's vertical grid structure logical, optional, intent(in) :: use_fms2 !< flag to call save_restart_fms2 logical, optional, intent(in) :: write_ic !< flag to call write_initial_conditions + ! local + logical :: write_initcond, call_fms2 + write_initcond = .false. + call_fms2 = .false. + if (present(use_fms2)) call_fms2 = use_fms2 + if (present(write_ic)) write_initcond = write_ic - if (present(write_ic) .and. write_ic) then + if (write_initcond) then call write_initial_conditions(directory, time, G, CS, time_stamped=time_stamped, filename=filename, GV=GV) - elseif (present(use_fms2) .and. use_fms2) then + elseif (call_fms2) then call save_restart_fms2(directory, time, G, CS, time_stamped=time_stamped, filename=filename, GV=GV) else call save_restart_old(directory, time, G, CS, time_stamped=time_stamped, filename=filename, GV=GV) @@ -1151,11 +1158,26 @@ subroutine save_restart_fms2(directory, time, G, CS, time_stamped, filename, GV) character(len=64) :: units character(len=256) :: longname real, dimension(:), allocatable :: data_temp + type a2d + real, allocatable :: a(:,:) + end type a2d + type a3d + real, allocatable :: a(:,:,:) + end type a3d + type a4d + real, allocatable :: a(:,:,:,:) + end type a4d + type(a2d), allocatable :: field_rot2d(:) + type(a3d), allocatable :: field_rot3d(:) + type(a4d), allocatable :: field_rot4d(:) type(axis_data_type) :: axis_data_CS integer :: isL, ieL, jsL, jeL, pos integer :: turns turns = CS%turns + allocate(field_rot2d(CS%novars)) + allocate(field_rot3d(CS%novars)) + allocate(field_rot4d(CS%novars)) if (.not.associated(CS)) call MOM_error(FATAL, "MOM_restart " // & "save_restart_fms2: Module must be initialized before it is used.") @@ -1302,7 +1324,8 @@ subroutine save_restart_fms2(directory, time, G, CS, time_stamped, filename, GV) ! register the time data if (.not. variable_exists(fileObjWrite, "Time")) then call register_field(fileObjWrite, "Time", "double", dimensions=(/"Time"/)) - call register_variable_attribute(fileObjWrite, "Time", "units", restart_time_units) + call register_variable_attribute(fileObjWrite, "Time", "units", restart_time_units, & + str_len=len_trim(restart_time_units)) endif do m=start_var,next_var-1 @@ -1364,14 +1387,35 @@ subroutine save_restart_fms2(directory, time, G, CS, time_stamped, filename, GV) dim_names, dim_lengths, num_dims, G=G, GV=GV) ! register the restart variables to the file if (associated(CS%var_ptr3d(m)%p)) then - call fms2_register_restart_field(fileObjWrite, CS%restart_field(m-start_var+1)%var_name, & - CS%var_ptr3d(m)%p, dimensions=dim_names(1:num_dims)) + if (modulo(turns, 2) /= 0) then + call allocate_rotated_array(CS%var_ptr3d(m)%p, [1,1,1], turns, field_rot3d(m)%a) + call rotate_array(CS%var_ptr3d(m)%p, turns, field_rot3d(m)%a) + call fms2_register_restart_field(fileObjWrite, CS%restart_field(m-start_var+1)%var_name, & + field_rot3d(m)%a, dimensions=dim_names(1:num_dims)) + else + call fms2_register_restart_field(fileObjWrite, CS%restart_field(m-start_var+1)%var_name, & + CS%var_ptr3d(m)%p, dimensions=dim_names(1:num_dims)) + endif elseif (associated(CS%var_ptr2d(m)%p)) then - call fms2_register_restart_field(fileObjWrite, CS%restart_field(m-start_var+1)%var_name, & - CS%var_ptr2d(m)%p, dimensions=dim_names(1:num_dims)) + if (modulo(turns, 2) /= 0) then + call allocate_rotated_array(CS%var_ptr2d(m)%p, [1,1], turns, field_rot2d(m)%a) + call rotate_array(CS%var_ptr2d(m)%p, turns, field_rot2d(m)%a) + call fms2_register_restart_field(fileObjWrite, CS%restart_field(m-start_var+1)%var_name, & + field_rot2d(m)%a, dimensions=dim_names(1:num_dims)) + else + call fms2_register_restart_field(fileObjWrite, CS%restart_field(m-start_var+1)%var_name, & + CS%var_ptr2d(m)%p, dimensions=dim_names(1:num_dims)) + endif elseif (associated(CS%var_ptr4d(m)%p)) then - call fms2_register_restart_field(fileObjWrite, CS%restart_field(m-start_var+1)%var_name, & - CS%var_ptr4d(m)%p, dimensions=dim_names(1:num_dims)) + if (modulo(turns, 2) /= 0) then + call allocate_rotated_array(CS%var_ptr4d(m)%p, [1,1,1,1], turns, field_rot4d(m)%a) + call rotate_array(CS%var_ptr4d(m)%p, turns, field_rot4d(m)%a) + call fms2_register_restart_field(fileObjWrite, CS%restart_field(m-start_var+1)%var_name, & + field_rot4d(m)%a, dimensions=dim_names(1:num_dims)) + else + call fms2_register_restart_field(fileObjWrite, CS%restart_field(m-start_var+1)%var_name, & + CS%var_ptr4d(m)%p, dimensions=dim_names(1:num_dims)) + endif elseif (associated(CS%var_ptr1d(m)%p)) then ! need to pass dim_names argument as a 1-D array call fms2_register_restart_field(fileObjWrite, CS%restart_field(m-start_var+1)%var_name, & @@ -1388,9 +1432,9 @@ subroutine save_restart_fms2(directory, time, G, CS, time_stamped, filename, GV) !call register_variable_attribute(fileObjWrite, CS%restart_field(m-start_var+1)%var_name, & ! 'checksum', trim(checksum_char)) call register_variable_attribute(fileObjWrite, CS%restart_field(m-start_var+1)%var_name, & - 'units', units) + 'units', units, str_len=len_trim(units)) call register_variable_attribute(fileObjWrite, CS%restart_field(m-start_var+1)%var_name, & - 'long_name', longname) + 'long_name', longname, str_len=len_trim(longname)) endif enddo ! write the time data @@ -1404,8 +1448,15 @@ subroutine save_restart_fms2(directory, time, G, CS, time_stamped, filename, GV) if (associated(axis_data_CS%data)) deallocate(axis_data_CS%data) num_files = num_files+1 + do m=1,CS%novars + if (allocated(field_rot4d(m)%a)) deallocate(field_rot4d(m)%a) + if (allocated(field_rot3d(m)%a)) deallocate(field_rot3d(m)%a) + if (allocated(field_rot2d(m)%a)) deallocate(field_rot2d(m)%a) + enddo enddo - + if (allocated(field_rot2d)) deallocate(field_rot2d) + if (allocated(field_rot3d)) deallocate(field_rot3d) + if (allocated(field_rot4d)) deallocate(field_rot4d) end subroutine save_restart_fms2 !> write initial condition fields to a netCDF file @@ -1431,7 +1482,6 @@ subroutine write_initial_conditions(directory, time, G, CS, time_stamped, filena integer :: i, is, ie, k, m, isc, jsc, iec, jec, isg, jsg, ieg, jeg integer :: var_periods integer, dimension(4) :: dim_lengths - integer, allocatable :: pos(:),first(:,:), last(:,:) logical :: fileOpenSuccess ! .true. if netcdf file is opened character(len=200) :: base_file_name character(len=200) :: dim_names(4) @@ -1441,6 +1491,10 @@ subroutine write_initial_conditions(directory, time, G, CS, time_stamped, filena character(len=8) :: hor_grid, z_grid, t_grid ! Variable grid info. real :: ic_time real, dimension(:), allocatable :: data_temp + real, allocatable :: field_rot_2d(:,:), field_rot_3d(:,:,:), field_rot_4d(:,:,:,:) + integer :: turns + + turns = CS%turns ! define the io domain for 1-pe jobs because it is required to write domain-decomposed files if (mpp_get_domain_npes(G%domain%mpp_domain) .eq. 1 ) then @@ -1470,13 +1524,8 @@ subroutine write_initial_conditions(directory, time, G, CS, time_stamped, filena ! register the time data if (.not. variable_exists(fileObjWrite, "Time")) then call register_field(fileObjWrite, "Time", "double", dimensions=(/"Time"/)) - call register_variable_attribute(fileObjWrite, "Time", "units", time_units) + call register_variable_attribute(fileObjWrite, "Time", "units", time_units, str_len=len_trim(time_units)) endif - ! allocate position indices for x- and y-dimensions associated with variables - allocate(pos(CS%novars)) - allocate(first(CS%novars,2)); allocate(last(CS%novars,2)); - first(:,:) = 0; last(:,:) = 0 - pos(:) = CENTER ! register and write the field variables to the initial conditions file do m=1,CS%novars longname = "" @@ -1490,22 +1539,10 @@ subroutine write_initial_conditions(directory, time, G, CS, time_stamped, filena call get_var_dimension_metadata(hor_grid, z_grid, t_grid, & dim_names, dim_lengths, num_dims, G=G, GV=GV) - select case (hor_grid) - case ('q') ; pos(m) = CORNER - case ('h') ; pos(m) = CENTER - case ('u') ; pos(m) = EAST_FACE - case ('v') ; pos(m) = NORTH_FACE - case ('Bu') ; pos(m) = CORNER - case ('T') ; pos(m) = CENTER - case ('Cu') ; pos(m) = EAST_FACE - case ('Cv') ; pos(m) = NORTH_FACE - case ('1') ; pos(m) = 0 - case default ; pos(m)= 0 - end select ! register the variables if (associated(CS%var_ptr3d(m)%p)) then call register_field(fileObjWrite, CS%restart_field(m)%var_name, "double", & - dimensions=dim_names(1:num_dims)) + dimensions=dim_names(1:num_dims)) elseif (associated(CS%var_ptr2d(m)%p)) then call register_field(fileObjWrite, CS%restart_field(m)%var_name, "double", & dimensions=dim_names(1:num_dims)) @@ -1522,20 +1559,46 @@ subroutine write_initial_conditions(directory, time, G, CS, time_stamped, filena dimensions=(/dim_names(1)/)) endif ! register the variable attributes - call register_variable_attribute(fileObjWrite, CS%restart_field(m)%var_name, "units", units) - call register_variable_attribute(fileObjWrite, CS%restart_field(m)%var_name, "long_name", longname) + call register_variable_attribute(fileObjWrite, CS%restart_field(m)%var_name, "units", units, & + str_len=len_trim(units)) + call register_variable_attribute(fileObjWrite, CS%restart_field(m)%var_name, "long_name", longname, & + str_len=len_trim(longname)) enddo do m=1,CS%novars if (associated(CS%var_ptr3d(m)%p)) then - call write_data(fileObjWrite, CS%restart_field(m)%var_name, CS%var_ptr3d(m)%p, & + if (modulo(turns, 2) /= 0) then + call allocate_rotated_array(CS%var_ptr3d(m)%p, [1,1,1], turns, field_rot_3d) + call rotate_array(CS%var_ptr3d(m)%p, turns, field_rot_3d) + call write_data(fileObjWrite, CS%restart_field(m)%var_name, field_rot_3d, & + unlim_dim_level=1) + deallocate(field_rot_3d) + else + call write_data(fileObjWrite, CS%restart_field(m)%var_name, CS%var_ptr3d(m)%p, & unlim_dim_level=1) + endif elseif (associated(CS%var_ptr2d(m)%p)) then - call write_data(fileObjWrite, CS%restart_field(m)%var_name, CS%var_ptr2d(m)%p, & - unlim_dim_level=1) + if (modulo(turns, 2) /= 0) then + call allocate_rotated_array(CS%var_ptr2d(m)%p, [1,1], turns, field_rot_2d) + call rotate_array(CS%var_ptr2d(m)%p, turns, field_rot_2d) + call write_data(fileObjWrite, CS%restart_field(m)%var_name, field_rot_2d, & + unlim_dim_level=1) + deallocate(field_rot_2d) + else + call write_data(fileObjWrite, CS%restart_field(m)%var_name, CS%var_ptr2d(m)%p, & + unlim_dim_level=1) + endif elseif (associated(CS%var_ptr4d(m)%p)) then - call write_data(fileObjWrite, CS%restart_field(m)%var_name, CS%var_ptr4d(m)%p, & - unlim_dim_level=1) + if (modulo(turns, 2) /= 0) then + call allocate_rotated_array(CS%var_ptr4d(m)%p, [1,1,1,1], turns, field_rot_4d) + call rotate_array(CS%var_ptr4d(m)%p, turns, field_rot_4d) + call write_data(fileObjWrite, CS%restart_field(m)%var_name, field_rot_4d, & + unlim_dim_level=1) + deallocate(field_rot_4d) + else + call write_data(fileObjWrite, CS%restart_field(m)%var_name, CS%var_ptr4d(m)%p, & + unlim_dim_level=1) + endif elseif (associated(CS%var_ptr1d(m)%p)) then call write_data(fileObjWrite, CS%restart_field(m)%var_name, CS%var_ptr1d(m)%p, & unlim_dim_level=1) @@ -1550,7 +1613,6 @@ subroutine write_initial_conditions(directory, time, G, CS, time_stamped, filena if (associated(axis_data_CS%axis)) deallocate(axis_data_CS%axis) if (associated(axis_data_CS%data)) deallocate(axis_data_CS%data) - deallocate(pos); deallocate(first); deallocate(last) end subroutine write_initial_conditions !> wrapper routine for restore_state_old and restore_state_fms2 @@ -2522,5 +2584,4 @@ function get_variable_byte_size(hor_grid, z_grid, t_grid, G, num_zlevels) result end function get_variable_byte_size - end module MOM_restart From 2e46ea6d7b9bf48bf0a3838cf523b9e1a155953c Mon Sep 17 00:00:00 2001 From: wrongkindofdoctor Date: Tue, 18 Aug 2020 14:47:03 -0400 Subject: [PATCH 9/9] removed errant .true. in save_restart call removed use_fms2 optional arguments in save_restart, restore_state, and create_file made use_fms2 a MOM_restart module variable Update MOM_state_initialization.F90 Remove space. Update MOM_ice_shelf.F90 Add space. Update MOM_driver.F90 Add space Update mom_surface_forcing_mct.F90 remove whitespace Update ocean_model_MOM.F90 Add space Update mom_ocean_model_nuopc.F90 Add space Update MOM_surface_forcing.F90 Add space Changes needed work ESM4 to run with new io --- .../MOM_surface_forcing_gfdl.F90 | 6 ++-- config_src/coupled_driver/ocean_model_MOM.F90 | 10 +++--- config_src/mct_driver/mom_ocean_model_mct.F90 | 11 +++---- .../mct_driver/mom_surface_forcing_mct.F90 | 6 ++-- config_src/mct_driver/ocn_comp_mct.F90 | 2 +- .../nuopc_driver/mom_ocean_model_nuopc.F90 | 13 +++----- .../mom_surface_forcing_nuopc.F90 | 6 ++-- config_src/solo_driver/MOM_driver.F90 | 10 +++--- .../solo_driver/MOM_surface_forcing.F90 | 7 ++-- src/framework/MOM_io.F90 | 9 +++-- src/framework/MOM_read_data_fms2.F90 | 33 +++++++------------ src/framework/MOM_restart.F90 | 22 +++++++------ src/ice_shelf/MOM_ice_shelf.F90 | 7 ++-- .../MOM_state_initialization.F90 | 4 +-- 14 files changed, 58 insertions(+), 88 deletions(-) diff --git a/config_src/coupled_driver/MOM_surface_forcing_gfdl.F90 b/config_src/coupled_driver/MOM_surface_forcing_gfdl.F90 index 4a730d6e6d..7075fb7c10 100644 --- a/config_src/coupled_driver/MOM_surface_forcing_gfdl.F90 +++ b/config_src/coupled_driver/MOM_surface_forcing_gfdl.F90 @@ -1224,8 +1224,7 @@ subroutine forcing_save_restart(CS, G, Time, directory, time_stamped, & if (.not.associated(CS)) return if (.not.associated(CS%restart_CSp)) return - ! NOTE: use_fms2=.true. routes routine to fms2 IO interface; omit this argument to use the old interface - call save_restart(directory, Time, G, CS%restart_CSp, time_stamped, use_fms2=.true.) + call save_restart(directory, Time, G, CS%restart_CSp, time_stamped) end subroutine forcing_save_restart @@ -1590,9 +1589,8 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, wind_stagger) if ((dirs%input_filename(1:1) == 'n') .and. & (LEN_TRIM(dirs%input_filename) == 1)) new_sim = .true. if (.not.new_sim) then - ! NOTE: use_fms2=.true. routes routine to fms2 IO interface; omit this argument to use the old interface call restore_state(dirs%input_filename, dirs%restart_input_dir, Time_frc, & - G, CS%restart_CSp, use_fms2=.true.) + G, CS%restart_CSp) endif endif diff --git a/config_src/coupled_driver/ocean_model_MOM.F90 b/config_src/coupled_driver/ocean_model_MOM.F90 index ff365a9e78..082099158c 100644 --- a/config_src/coupled_driver/ocean_model_MOM.F90 +++ b/config_src/coupled_driver/ocean_model_MOM.F90 @@ -684,9 +684,8 @@ subroutine ocean_model_restart(OS, timestamp) "restart files can only be created after the buoyancy forcing is applied.") if (BTEST(OS%Restart_control,1)) then - ! NOTE: use_fms2=.true. routes routine to fms2 IO interface call save_restart(OS%dirs%restart_output_dir, OS%Time, OS%grid, & - OS%restart_CSp, .true., GV=OS%GV, use_fms2=.true.) + OS%restart_CSp, .true., GV=OS%GV) call forcing_save_restart(OS%forcing_CSp, OS%grid, OS%Time, & OS%dirs%restart_output_dir, .true.) if (OS%use_ice_shelf) then @@ -694,9 +693,8 @@ subroutine ocean_model_restart(OS, timestamp) endif endif if (BTEST(OS%Restart_control,0)) then - ! NOTE: use_fms2=.true. routes routine to fms2 IO interface call save_restart(OS%dirs%restart_output_dir, OS%Time, OS%grid, & - OS%restart_CSp, GV=OS%GV, use_fms2=.true.) + OS%restart_CSp, GV=OS%GV) call forcing_save_restart(OS%forcing_CSp, OS%grid, OS%Time, & OS%dirs%restart_output_dir) if (OS%use_ice_shelf) then @@ -748,8 +746,8 @@ subroutine ocean_model_save_restart(OS, Time, directory, filename_suffix) if (present(directory)) then ; restart_dir = directory else ; restart_dir = OS%dirs%restart_output_dir ; endif - ! NOTE: use_fms2=.true. routes routine to fms2 IO interface - call save_restart(restart_dir, Time, OS%grid, OS%restart_CSp, GV=OS%GV, use_fms2=.true.) + + call save_restart(restart_dir, Time, OS%grid, OS%restart_CSp, GV=OS%GV) call forcing_save_restart(OS%forcing_CSp, OS%grid, Time, restart_dir) diff --git a/config_src/mct_driver/mom_ocean_model_mct.F90 b/config_src/mct_driver/mom_ocean_model_mct.F90 index 3c75cb12eb..f8a4a19532 100644 --- a/config_src/mct_driver/mom_ocean_model_mct.F90 +++ b/config_src/mct_driver/mom_ocean_model_mct.F90 @@ -690,9 +690,8 @@ subroutine ocean_model_restart(OS, timestamp, restartname) "restart files can only be created after the buoyancy forcing is applied.") if (present(restartname)) then - ! NOTE: use_fms2=.true. routes routine to fms2 IO interface call save_restart(OS%dirs%restart_output_dir, OS%Time, OS%grid, & - OS%restart_CSp, GV=OS%GV, filename=restartname, use_fms2=.true.) + OS%restart_CSp, GV=OS%GV, filename=restartname) call forcing_save_restart(OS%forcing_CSp, OS%grid, OS%Time, & OS%dirs%restart_output_dir) ! Is this needed? if (OS%use_ice_shelf) then @@ -701,9 +700,8 @@ subroutine ocean_model_restart(OS, timestamp, restartname) endif else if (BTEST(OS%Restart_control,1)) then - ! NOTE:use_fms2=.true. routes routine to fms2 IO interface call save_restart(OS%dirs%restart_output_dir, OS%Time, OS%grid, & - OS%restart_CSp, .true., GV=OS%GV, use_fms2=.true.) + OS%restart_CSp, .true., GV=OS%GV) call forcing_save_restart(OS%forcing_CSp, OS%grid, OS%Time, & OS%dirs%restart_output_dir, .true.) if (OS%use_ice_shelf) then @@ -711,9 +709,8 @@ subroutine ocean_model_restart(OS, timestamp, restartname) endif endif if (BTEST(OS%Restart_control,0)) then - ! NOTE: use_fms2=.true. routes routine to fms2 IO interface call save_restart(OS%dirs%restart_output_dir, OS%Time, OS%grid, & - OS%restart_CSp, GV=OS%GV, use_fms2=.true.) + OS%restart_CSp, GV=OS%GV) call forcing_save_restart(OS%forcing_CSp, OS%grid, OS%Time, & OS%dirs%restart_output_dir) if (OS%use_ice_shelf) then @@ -769,7 +766,7 @@ subroutine ocean_model_save_restart(OS, Time, directory, filename_suffix) if (present(directory)) then ; restart_dir = directory else ; restart_dir = OS%dirs%restart_output_dir ; endif - call save_restart(restart_dir, Time, OS%grid, OS%restart_CSp, GV=OS%GV, use_fms2=.true.) + call save_restart(restart_dir, Time, OS%grid, OS%restart_CSp, GV=OS%GV) call forcing_save_restart(OS%forcing_CSp, OS%grid, Time, restart_dir) diff --git a/config_src/mct_driver/mom_surface_forcing_mct.F90 b/config_src/mct_driver/mom_surface_forcing_mct.F90 index 88b7f01654..a42a8c3015 100644 --- a/config_src/mct_driver/mom_surface_forcing_mct.F90 +++ b/config_src/mct_driver/mom_surface_forcing_mct.F90 @@ -1001,8 +1001,7 @@ subroutine forcing_save_restart(CS, G, Time, directory, time_stamped, & if (.not.associated(CS)) return if (.not.associated(CS%restart_CSp)) return - ! NOTE: use_fms2=.true. routes routine to fms2 IO interface - call save_restart(.true., directory, Time, G, CS%restart_CSp, time_stamped, use_fms2=.true.) + call save_restart(directory, Time, G, CS%restart_CSp, time_stamped) end subroutine forcing_save_restart @@ -1326,9 +1325,8 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, restore_salt, if ((dirs%input_filename(1:1) == 'n') .and. & (LEN_TRIM(dirs%input_filename) == 1)) new_sim = .true. if (.not.new_sim) then - ! NOTE: use_fms2=.true. routes routine to fms2 IO interface call restore_state(dirs%input_filename, dirs%restart_input_dir, Time_frc, & - G, CS%restart_CSp, use_fms2=.true.) + G, CS%restart_CSp) endif endif diff --git a/config_src/mct_driver/ocn_comp_mct.F90 b/config_src/mct_driver/ocn_comp_mct.F90 index 9f1912d79f..b1ce9a60c0 100644 --- a/config_src/mct_driver/ocn_comp_mct.F90 +++ b/config_src/mct_driver/ocn_comp_mct.F90 @@ -534,7 +534,7 @@ subroutine ocn_run_mct( EClock, cdata_o, x2o_o, o2x_o) write(restartname,'(A,".mom6.r.",I4.4,"-",I2.2,"-",I2.2,"-",I5.5)') trim(runid), year, month, day, seconds call save_restart(glb%ocn_state%dirs%restart_output_dir, glb%ocn_state%Time, glb%grid, & - glb%ocn_state%restart_CSp, .false., filename=restartname, GV=glb%ocn_state%GV, use_fms2=.true.) + glb%ocn_state%restart_CSp, .false., filename=restartname, GV=glb%ocn_state%GV) ! write name of restart file in the rpointer file nu = shr_file_getUnit() diff --git a/config_src/nuopc_driver/mom_ocean_model_nuopc.F90 b/config_src/nuopc_driver/mom_ocean_model_nuopc.F90 index a8765bdc08..9946aec4f9 100644 --- a/config_src/nuopc_driver/mom_ocean_model_nuopc.F90 +++ b/config_src/nuopc_driver/mom_ocean_model_nuopc.F90 @@ -686,9 +686,8 @@ subroutine ocean_model_restart(OS, timestamp, restartname) "restart files can only be created after the buoyancy forcing is applied.") if (present(restartname)) then - ! NOTE: use_fms2=.true. routes routine to fms2 IO interface call save_restart(OS%dirs%restart_output_dir, OS%Time, OS%grid, & - OS%restart_CSp, GV=OS%GV, filename=restartname, use_fms2=.true.) + OS%restart_CSp, GV=OS%GV, filename=restartname) call forcing_save_restart(OS%forcing_CSp, OS%grid, OS%Time, & OS%dirs%restart_output_dir) ! Is this needed? if (OS%use_ice_shelf) then @@ -697,9 +696,8 @@ subroutine ocean_model_restart(OS, timestamp, restartname) endif else if (BTEST(OS%Restart_control,1)) then - ! NOTE: use_fms2=.true. routes routine to fms2 IO interface call save_restart(OS%dirs%restart_output_dir, OS%Time, OS%grid, & - OS%restart_CSp, .true., GV=OS%GV, use_fms2=.true.) + OS%restart_CSp, .true., GV=OS%GV) call forcing_save_restart(OS%forcing_CSp, OS%grid, OS%Time, & OS%dirs%restart_output_dir, .true.) if (OS%use_ice_shelf) then @@ -707,9 +705,8 @@ subroutine ocean_model_restart(OS, timestamp, restartname) endif endif if (BTEST(OS%Restart_control,0)) then - ! NOTE: use_fms2=.true. routes routine to fms2 IO interface call save_restart(OS%dirs%restart_output_dir, OS%Time, OS%grid, & - OS%restart_CSp, GV=OS%GV, use_fms2=.true.) + OS%restart_CSp, GV=OS%GV) call forcing_save_restart(OS%forcing_CSp, OS%grid, OS%Time, & OS%dirs%restart_output_dir) if (OS%use_ice_shelf) then @@ -763,8 +760,8 @@ subroutine ocean_model_save_restart(OS, Time, directory, filename_suffix) if (present(directory)) then ; restart_dir = directory else ; restart_dir = OS%dirs%restart_output_dir ; endif - ! NOTE: use_fms2=.true. routes routine to fms2 IO interface - call save_restart(restart_dir, Time, OS%grid, OS%restart_CSp, GV=OS%GV, use_fms2=.true.) + + call save_restart(restart_dir, Time, OS%grid, OS%restart_CSp, GV=OS%GV) call forcing_save_restart(OS%forcing_CSp, OS%grid, Time, restart_dir) diff --git a/config_src/nuopc_driver/mom_surface_forcing_nuopc.F90 b/config_src/nuopc_driver/mom_surface_forcing_nuopc.F90 index a565da3d93..3d49c66ce6 100644 --- a/config_src/nuopc_driver/mom_surface_forcing_nuopc.F90 +++ b/config_src/nuopc_driver/mom_surface_forcing_nuopc.F90 @@ -1000,8 +1000,7 @@ subroutine forcing_save_restart(CS, G, Time, directory, time_stamped, & if (.not.associated(CS)) return if (.not.associated(CS%restart_CSp)) return - ! NOTE: use_fms2=.true. routes routine to fms2 IO interface - call save_restart(directory, Time, G, CS%restart_CSp, time_stamped, use_fms2=.true.) + call save_restart(directory, Time, G, CS%restart_CSp, time_stamped) end subroutine forcing_save_restart @@ -1331,9 +1330,8 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, restore_salt, if ((dirs%input_filename(1:1) == 'n') .and. & (LEN_TRIM(dirs%input_filename) == 1)) new_sim = .true. if (.not.new_sim) then - ! NOTE: use_fms2=.true. routes routine to fms2 IO interface call restore_state(dirs%input_filename, dirs%restart_input_dir, Time_frc, & - G, CS%restart_CSp, use_fms2=.true.) + G, CS%restart_CSp) endif endif diff --git a/config_src/solo_driver/MOM_driver.F90 b/config_src/solo_driver/MOM_driver.F90 index c6fbe0e4e6..f180cd9717 100644 --- a/config_src/solo_driver/MOM_driver.F90 +++ b/config_src/solo_driver/MOM_driver.F90 @@ -583,18 +583,16 @@ program MOM_main if ((permit_incr_restart) .and. (fluxes%fluxes_used) .and. & (Time + (Time_step_ocean/2) > restart_time)) then if (BTEST(Restart_control,1)) then - ! NOTE: use_fms2=.true. routes routine to fms2 IO interface call save_restart(dirs%restart_output_dir, Time, grid, & - restart_CSp, .true., GV=GV, use_fms2=.true.) + restart_CSp, .true., GV=GV) call forcing_save_restart(surface_forcing_CSp, grid, Time, & dirs%restart_output_dir, .true.) if (use_ice_shelf) call ice_shelf_save_restart(ice_shelf_CSp, Time, & dirs%restart_output_dir, .true.) endif if (BTEST(Restart_control,0)) then - ! NOTE: use_fms2=.true. routes routine to fms2 IO interface call save_restart(dirs%restart_output_dir, Time, grid, & - restart_CSp, GV=GV, use_fms2=.true.) + restart_CSp, GV=GV) call forcing_save_restart(surface_forcing_CSp, grid, Time, & dirs%restart_output_dir) if (use_ice_shelf) call ice_shelf_save_restart(ice_shelf_CSp, Time, & @@ -618,8 +616,8 @@ program MOM_main "End of MOM_main reached with unused buoyancy fluxes. "//& "For conservation, the ocean restart files can only be "//& "created after the buoyancy forcing is applied.") - ! NOTE: use_fms2=.true. routes routine to fms2 IO interface - call save_restart(dirs%restart_output_dir, Time, grid, restart_CSp, GV=GV, use_fms2=.true.) + + call save_restart(dirs%restart_output_dir, Time, grid, restart_CSp, GV=GV) if (use_ice_shelf) call ice_shelf_save_restart(ice_shelf_CSp, Time, & dirs%restart_output_dir) ! Write ocean solo restart file. diff --git a/config_src/solo_driver/MOM_surface_forcing.F90 b/config_src/solo_driver/MOM_surface_forcing.F90 index 5b10ea46e4..0a56abb681 100644 --- a/config_src/solo_driver/MOM_surface_forcing.F90 +++ b/config_src/solo_driver/MOM_surface_forcing.F90 @@ -1524,8 +1524,8 @@ subroutine forcing_save_restart(CS, G, Time, directory, time_stamped, & if (.not.associated(CS)) return if (.not.associated(CS%restart_CSp)) return - ! NOTE: use_fms2=.true. routes routine to fms2 IO interface - call save_restart(directory, Time, G, CS%restart_CSp, time_stamped, use_fms2=.true.) + + call save_restart(directory, Time, G, CS%restart_CSp, time_stamped) end subroutine forcing_save_restart @@ -1925,9 +1925,8 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, tracer_flow_C if ((dirs%input_filename(1:1) == 'n') .and. & (LEN_TRIM(dirs%input_filename) == 1)) new_sim = .true. if (.not.new_sim) then - ! NOTE: use_fms2=.true. routes routine to fms2 IO interface call restore_state(dirs%input_filename, dirs%restart_input_dir, Time_frc, & - G, CS%restart_CSp, use_fms2=.true.) + G, CS%restart_CSp) endif endif diff --git a/src/framework/MOM_io.F90 b/src/framework/MOM_io.F90 index b36e8e5dd8..c4246f5d20 100644 --- a/src/framework/MOM_io.F90 +++ b/src/framework/MOM_io.F90 @@ -385,12 +385,11 @@ end subroutine create_file_old !> This routine opens a netcdf file in "write" or "overwrite" mode, registers the global diagnostic axes, and writes !! the axis data and metadata to the file -subroutine create_file_fms2_filename(filename, vars, numVariables, use_fms2, register_time, G, DG, GV, checksums, & +subroutine create_file_fms2_filename(filename, vars, numVariables, register_time, G, DG, GV, checksums, & is_restart) character(len=*), intent(in) :: filename !< full path to the netcdf file type(vardesc), dimension(:), intent(in) :: vars !< structures describing the output integer, intent(in) :: numVariables !< number of variables to write to the file - logical, intent(in) :: use_fms2 !< flag indicating whether to use this routine logical, optional, intent(in) :: register_time !< if .true., register a time dimension to the file type(ocean_grid_type), optional, intent(in) :: G !< ocean horizontal grid structure; G or dG !! is required if the new file uses any @@ -467,7 +466,7 @@ subroutine create_file_fms2_filename(filename, vars, numVariables, use_fms2, reg if (.not. check_if_open(fileObjDD)) & file_open_successDD=fms2_open_file(fileObjDD, filename_temp, trim(nc_mode), Domain%mpp_domain, & - is_restart=is_restart_file) + is_restart=is_restart_file, dont_add_res_to_filename=.true.) else ! get the pes associated with the file. !>\note this is required so that only pe(1) is identified as the root pe to create the file @@ -480,7 +479,7 @@ subroutine create_file_fms2_filename(filename, vars, numVariables, use_fms2, reg if (.not. check_if_open(fileObjNoDD)) & file_open_successNoDD=fms2_open_file(fileObjNoDD, filename_temp, trim(nc_mode), & - is_restart=is_restart_file, pelist=pelist) + is_restart=is_restart_file, pelist=pelist, dont_add_res_to_filename=.true.) endif ! allocate the output data variable dimension attributes allocate(dim_names(numVariables,4)) @@ -745,7 +744,7 @@ subroutine create_file_fms2_fileobj(filename, fileObjDD, vars, numVariables, reg if (.not. check_if_open(fileObjDD)) & !write(output_unit, '(A)'), "Create_file: Opening file ", trim(filename_temp) file_open_successDD=fms2_open_file(fileObjDD, filename_temp, trim(nc_mode), Domain%mpp_domain, & - is_restart=is_restart_file) + is_restart=is_restart_file, dont_add_res_to_filename=.true.) ! allocate the output data variable dimension attributes allocate(dim_names(numVariables,4)) dim_names(:,:) = "" diff --git a/src/framework/MOM_read_data_fms2.F90 b/src/framework/MOM_read_data_fms2.F90 index d15d5a3085..e5d20ccc57 100644 --- a/src/framework/MOM_read_data_fms2.F90 +++ b/src/framework/MOM_read_data_fms2.F90 @@ -76,13 +76,12 @@ module MOM_read_data_fms2 !> This routine calls the fms_io read_data subroutine to read 1-D domain-decomposed data field named "fieldname" !! from file "filename". The routine multiplies the data by "scale" if the optional argument is included in the call. -subroutine MOM_read_data_1d_DD(filename, fieldname, data, domain, use_fms2, start_index, edge_lengths, & +subroutine MOM_read_data_1d_DD(filename, fieldname, data, domain, start_index, edge_lengths, & timelevel, scale, x_position, y_position, leave_file_open) character(len=*), intent(in) :: filename !< The name of the file to read character(len=*), intent(in) :: fieldname !< The variable name of the data in the file real, dimension(:), intent(inout) :: data !< The 1-dimensional data array to pass to read_data type(MOM_domain_type), intent(in) :: domain !< MOM domain attribute with the mpp_domain decomposition - logical, intent(in) :: use_fms2 !< flag to distinguish interface from the old write_field interface integer, dimension(1), optional, intent(in) :: start_index !< starting index of data buffer. Default is 1 integer, dimension(1), optional, intent(in) :: edge_lengths !< number of data values to read in !! default is the variable size @@ -188,13 +187,12 @@ end subroutine MOM_read_data_1d_DD !> This routine calls the fms_io read_data subroutine to read 2-D domain-decomposed data field named "fieldname" !! from file "filename". The routine multiplies the data by "scale" if the optional argument is included in the call. -subroutine MOM_read_data_2d_DD(filename, fieldname, data, domain, use_fms2, start_index, edge_lengths, & +subroutine MOM_read_data_2d_DD(filename, fieldname, data, domain,start_index, edge_lengths, & timelevel, scale, x_position, y_position, leave_file_open) character(len=*), intent(in) :: filename !< The name of the file to read character(len=*), intent(in) :: fieldname !< The variable name of the data in the file real, dimension(:,:), intent(inout) :: data !< The 2-dimensional data array to pass to read_data type(MOM_domain_type), intent(in) :: domain !< MOM domain attribute with the mpp_domain decomposition - logical, intent(in) :: use_fms2 !< flag to distinguish interface from the old write_field interface integer, dimension(2), optional, intent(in) :: start_index !< starting indices of data buffer. Default is 1 integer, dimension(2), optional, intent(in) :: edge_lengths !< number of data values to read in. !! Default values are the variable dimension sizes @@ -323,13 +321,12 @@ end subroutine MOM_read_data_2d_DD !> This routine calls the fms_io read_data subroutine to read 3-D domain-decomposed data field named "fieldname" !! from file "filename". The routine multiplies the data by "scale" if the optional argument is included in the call. -subroutine MOM_read_data_3d_DD(filename, fieldname, data, domain, use_fms2, start_index, edge_lengths, & +subroutine MOM_read_data_3d_DD(filename, fieldname, data, domain, start_index, edge_lengths, & timelevel, scale, x_position, y_position, leave_file_open) character(len=*), intent(in) :: filename !< The name of the file to read character(len=*), intent(in) :: fieldname !< The variable name of the data in the file real, dimension(:,:,:), intent(inout) :: data !< The 3-dimensional data array to pass to read_data type(MOM_domain_type), intent(in) :: domain !< MOM domain attribute with the mpp_domain decomposition - logical, intent(in) :: use_fms2 !< flag indicating whether to use this routine integer, dimension(3), optional, intent(in) :: start_index !< starting indices of data buffer. Default is 1 integer, dimension(3), optional, intent(in) :: edge_lengths !< number of data values to read in. !! Default values are the variable dimension sizes @@ -460,13 +457,12 @@ end subroutine MOM_read_data_3d_DD !> This routine calls the fms_io read_data subroutine to read 4-D domain-decomposed data field named "fieldname" !! from file "filename". The routine multiplies the data by "scale" if the optional argument is included in the call. -subroutine MOM_read_data_4d_DD(filename, fieldname, data, domain, use_fms2, start_index, edge_lengths, & +subroutine MOM_read_data_4d_DD(filename, fieldname, data, domain, start_index, edge_lengths, & timelevel, scale, x_position, y_position, leave_file_open) character(len=*), intent(in) :: filename !< The name of the file to read character(len=*), intent(in) :: fieldname !< The variable name of the data in the file real, dimension(:,:,:,:), intent(inout) :: data !< The 1-dimensional data array to pass to read_data type(MOM_domain_type), intent(in) :: domain !< MOM domain attribute with the mpp_domain decomposition - logical, intent(in) :: use_fms2 !< flag indicating whether to use this routine integer, dimension(4), optional, intent(in) :: start_index !< starting indices of data buffer. Default is 1 integer, dimension(4), optional, intent(in) :: edge_lengths !< number of data values to read in. !! Default values are the variable dimension sizes @@ -600,11 +596,10 @@ end subroutine MOM_read_data_4d_DD !!> This routine calls the fms_io read_data subroutine to read a scalar (0-D) field named "fieldname" !! from file "filename". -subroutine MOM_read_data_scalar(filename, fieldname, data, use_fms2, leave_file_open) +subroutine MOM_read_data_scalar(filename, fieldname, data, leave_file_open) character(len=*), intent(in) :: filename !< The name of the file to read character(len=*), intent(in) :: fieldname !< The variable name of the data in the file real, intent(inout) :: data !< data buffer to pass to read_data - logical, intent(in) :: use_fms2 !< flag distinguishing interface from old MOM_read_data logical, optional, intent(in) :: leave_file_open !< if .true., leave file open ! local integer :: i @@ -649,12 +644,11 @@ end subroutine MOM_read_data_scalar !> This routine calls the fms_io read_data subroutine to read 1-D non-domain-decomposed data field named "fieldname" !! from file "filename". The routine multiplies the data by "scale" if the optional argument is included in the call. -subroutine MOM_read_data_1d_noDD(filename, fieldname, data, use_fms2, start_index, & +subroutine MOM_read_data_1d_noDD(filename, fieldname, data, start_index, & edge_lengths, timelevel, scale, leave_file_open) character(len=*), intent(in) :: filename !< The name of the file to read character(len=*), intent(in) :: fieldname !< The variable name of the data in the file real, dimension(:), intent(inout) :: data !< The 1-dimensional data array to pass to read_data - logical, intent(in) :: use_fms2 !< flag to distinguish interface from old MOM_read_data interface integer, dimension(1), optional, intent(in) :: start_index !< starting index of data buffer. Default is 1 integer, dimension(1), optional, intent(in) :: edge_lengths !< number of data values to read in; default is !! the variable size @@ -748,12 +742,11 @@ end subroutine MOM_read_data_1d_noDD !> This routine calls the fms_io read_data subroutine to read 2-D non-domain-decomposed data field named "fieldname" !! from file "filename". The routine multiplies the data by "scale" if the optional argument is included in the call. -subroutine MOM_read_data_2d_noDD(filename, fieldname, data, use_fms2, start_index, & +subroutine MOM_read_data_2d_noDD(filename, fieldname, data, start_index, & edge_lengths, timelevel, scale, leave_file_open) character(len=*), intent(in) :: filename !< The name of the file to read character(len=*), intent(in) :: fieldname !< The variable name of the data in the file real, dimension(:,:), intent(inout) :: data !< The 2-dimensional data array to pass to read_data - logical, intent(in) :: use_fms2 !< flag to distinguish interface from old MOM_read_data interface integer, dimension(2), optional, intent(in) :: start_index !< starting indices of data buffer. Default is 1 integer, dimension(2), optional, intent(in) :: edge_lengths !< number of data values to read in. !! Default values are the variable dimension sizes @@ -842,12 +835,11 @@ end subroutine MOM_read_data_2d_noDD !> This routine calls the fms_io read_data subroutine to read 3-D non-domain-decomposed data field named "fieldname" !! from file "filename". The routine multiplies the data by "scale" if the optional argument is included in the call. -subroutine MOM_read_data_3d_noDD(filename, fieldname, data, use_fms2, start_index, & +subroutine MOM_read_data_3d_noDD(filename, fieldname, data, start_index, & edge_lengths, timelevel, scale, leave_file_open) character(len=*), intent(in) :: filename !< The name of the file to read character(len=*), intent(in) :: fieldname !< The variable name of the data in the file real, dimension(:,:,:), intent(inout) :: data !< The 3-dimensional data array to pass to read_data - logical, intent(in) :: use_fms2 !< flag to distinguish interface from old MOM_read_data interface integer, dimension(3), optional, intent(in) :: start_index !< starting indices of data buffer. Default is 1 integer, dimension(3), optional, intent(in) :: edge_lengths !< number of data values to read in. !! Default values are the variable dimension sizes @@ -935,12 +927,11 @@ end subroutine MOM_read_data_3d_noDD !> This routine calls the fms_io read_data subroutine to read 4-D non-domain-decomposed data field named "fieldname" !! from file "filename". The routine multiplies the data by "scale" if the optional argument is included in the call. -subroutine MOM_read_data_4d_noDD(filename, fieldname, data, use_fms2, start_index, & +subroutine MOM_read_data_4d_noDD(filename, fieldname, data, start_index, & edge_lengths, timelevel, scale, leave_file_open) character(len=*), intent(in) :: filename !< The name of the file to read character(len=*), intent(in) :: fieldname !< The variable name of the data in the file real, dimension(:,:,:,:), intent(inout) :: data !< The 4-dimensional data array to pass to read_data - logical, intent(in) :: use_fms2 !< flag to distinguish interface from old MOM_read_data interface integer, dimension(4), optional, intent(in) :: start_index !< starting indices of data buffer. Default is 1 integer, dimension(4), optional, intent(in) :: edge_lengths !< number of data values to read in. !! Default values are the variable dimension sizes @@ -1191,7 +1182,7 @@ end subroutine MOM_read_data_2d_supergrid !! 2-D data fields with names given by "[uv]_fieldname" from file "filename". Valid values for !! "stagger" include CGRID_NE, BGRID_NE, and AGRID. subroutine MOM_read_vector_2d_fms2(filename, u_fieldname, v_fieldname, u_data, v_data, MOM_Domain, & - use_fms2, timelevel, stagger, scale, leave_file_open) + timelevel, stagger, scale, leave_file_open) character(len=*), intent(in) :: filename !< name of the netcdf file to read character(len=*), intent(in) :: u_fieldname !< The variable name of the u data in the file character(len=*), intent(in) :: v_fieldname !< The variable name of the v data in the file @@ -1200,7 +1191,6 @@ subroutine MOM_read_vector_2d_fms2(filename, u_fieldname, v_fieldname, u_data, v real, dimension(:,:), intent(inout) :: v_data !< The 2 dimensional array into which the !! v-component of the data should be read type(MOM_domain_type), intent(in) :: MOM_Domain !< The MOM_Domain that describes the decomposition - logical, intent(in) :: use_fms2 !< flag indicating whether to use this routine integer, optional, intent(in) :: timelevel !< The time level in the file to read integer, optional, intent(in) :: stagger !< A flag indicating where this vector is discretized real, optional, intent(in) :: scale !< A scaling factor that the fields are multiplied @@ -1320,7 +1310,7 @@ end subroutine MOM_read_vector_2d_fms2 !! 3-D data fields with names given by "[uv]_fieldname" from file "filename". Valid values for !! "stagger" include CGRID_NE, BGRID_NE, and AGRID. subroutine MOM_read_vector_3d_fms2(filename, u_fieldname, v_fieldname, u_data, v_data, MOM_Domain, & - use_fms2, timelevel, stagger, scale, leave_file_open) + timelevel, stagger, scale, leave_file_open) character(len=*), intent(in) :: filename !< name of the netcdf file to read character(len=*), intent(in) :: u_fieldname !< The variable name of the u data in the file character(len=*), intent(in) :: v_fieldname !< The variable name of the v data in the file @@ -1329,7 +1319,6 @@ subroutine MOM_read_vector_3d_fms2(filename, u_fieldname, v_fieldname, u_data, v real, dimension(:,:,:), intent(inout) :: v_data !< The 3 dimensional array into which the !! v-component of the data should be read type(MOM_domain_type), intent(in) :: MOM_Domain !< The MOM_Domain that describes the decomposition - logical, intent(in) :: use_fms2 !< flag indicating whether to call this routine integer, optional, intent(in) :: timelevel !< The time level in the file to read integer, optional, intent(in) :: stagger !< A flag indicating where this vector is discretized real, optional, intent(in) :: scale !< A scaling factor that the fields are multiplied diff --git a/src/framework/MOM_restart.F90 b/src/framework/MOM_restart.F90 index f9dc13758e..a9242b08a4 100644 --- a/src/framework/MOM_restart.F90 +++ b/src/framework/MOM_restart.F90 @@ -38,6 +38,8 @@ module MOM_restart use platform_mod implicit none ; private +logical :: use_fms2 = .true. !< Flag to use fms2-io interfaces + public restart_init, restart_end, restore_state, register_restart_field public save_restart, query_initialized, restart_init_end, vardesc public restart_files_exist, determine_is_new_run, is_new_run @@ -863,7 +865,7 @@ function query_initialized_4d_name(f_ptr, name, CS) result(query_initialized) end function query_initialized_4d_name !> wrapper routine for save_restart_old, save_restart_fms2, and write_initial_conditions_file -subroutine save_restart(directory, time, G, CS, time_stamped, filename, GV, use_fms2, write_ic) +subroutine save_restart(directory, time, G, CS, time_stamped, filename, GV, write_ic) character(len=*), intent(in) :: directory !< The directory where the restart files !! are to be written type(time_type), intent(in) :: time !< The current model time @@ -874,18 +876,16 @@ subroutine save_restart(directory, time, G, CS, time_stamped, filename, GV, use_ !! to the restart file names. character(len=*), optional, intent(in) :: filename !< A filename that overrides the name in CS%restartfile. type(verticalGrid_type), optional, intent(in) :: GV !< The ocean's vertical grid structure - logical, optional, intent(in) :: use_fms2 !< flag to call save_restart_fms2 logical, optional, intent(in) :: write_ic !< flag to call write_initial_conditions ! local logical :: write_initcond, call_fms2 write_initcond = .false. call_fms2 = .false. - if (present(use_fms2)) call_fms2 = use_fms2 if (present(write_ic)) write_initcond = write_ic if (write_initcond) then call write_initial_conditions(directory, time, G, CS, time_stamped=time_stamped, filename=filename, GV=GV) - elseif (call_fms2) then + elseif (use_fms2) then call save_restart_fms2(directory, time, G, CS, time_stamped=time_stamped, filename=filename, GV=GV) else call save_restart_old(directory, time, G, CS, time_stamped=time_stamped, filename=filename, GV=GV) @@ -1616,7 +1616,7 @@ subroutine write_initial_conditions(directory, time, G, CS, time_stamped, filena end subroutine write_initial_conditions !> wrapper routine for restore_state_old and restore_state_fms2 -subroutine restore_state(filename, directory, day, G, CS, use_fms2) +subroutine restore_state(filename, directory, day, G, CS) character(len=*), intent(in) :: filename !< The list of restart file names or a single !! character 'r' to read automatically named files. character(len=*), intent(in) :: directory !< The directory in which to find restart files @@ -1624,9 +1624,7 @@ subroutine restore_state(filename, directory, day, G, CS, use_fms2) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(MOM_restart_CS), pointer :: CS !< The control structure returned by a previous !! call to restart_init. - logical, optional, intent(in) :: use_fms2 !< if .true., call restore_state_fms2 - - if (present(use_fms2) .and. use_fms2) then + if (use_fms2) then call restore_state_fms2(filename, directory, day, G, CS) else call restore_state_old(filename, directory, day, G, CS) @@ -1936,9 +1934,12 @@ subroutine restore_state_fms2(filename, directory, day, G, CS) ! Open the restart file. if (.not.(check_if_open(fileObjRead))) & fileOpenSuccess=fms2_open_file(fileObjRead, trim(unit_path(n)), "read", & - G%domain%mpp_domain, is_restart=.true.) - if (fileOpenSuccess) & + G%domain%mpp_domain, is_restart=.true., dont_add_res_to_filename=.true.) + if (fileOpenSuccess) then call MOM_error(NOTE, "MOM_restart_fms2: MOM run restarted using : "//trim(unit_path(n))) + else + call MOM_error(FATAL, "MOM_restart_fms2: Error opening file: "//trim(unit_path(n))) + endif call get_dimension_size(fileObjRead, "Time", ntime) @@ -2005,6 +2006,7 @@ subroutine restore_state_fms2(filename, directory, day, G, CS) missing_fields = missing_fields+1 cycle endif + cycle endif ! Get the variable's "domain position." num_dims = 0 diff --git a/src/ice_shelf/MOM_ice_shelf.F90 b/src/ice_shelf/MOM_ice_shelf.F90 index fe9a5bc75f..feaebadfc7 100644 --- a/src/ice_shelf/MOM_ice_shelf.F90 +++ b/src/ice_shelf/MOM_ice_shelf.F90 @@ -1512,9 +1512,8 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl elseif (.not.new_sim) then ! This line calls a subroutine that reads the initial conditions from a restart file. call MOM_mesg("MOM_ice_shelf.F90, initialize_ice_shelf: Restoring ice shelf from file.") - ! NOTE: use_fms2=.true. routes routine to fms2 IO interface call restore_state(dirs%input_filename, dirs%restart_input_dir, Time, & - G, CS%restart_CSp, use_fms2=.true.) + G, CS%restart_CSp) if ((US%m_to_Z_restart /= 0.0) .and. (US%m_to_Z_restart /= US%m_to_Z)) then Z_rescale = US%m_to_Z / US%m_to_Z_restart @@ -1781,8 +1780,8 @@ subroutine ice_shelf_save_restart(CS, Time, directory, time_stamped, filename_su if (present(directory)) then ; restart_dir = directory else ; restart_dir = CS%restart_output_dir ; endif - ! NOTE: first use_fms2=.true. routes routine to fms2 IO interface - call save_restart(restart_dir, Time, CS%grid, CS%restart_CSp, time_stamped, use_fms2=.true.) + + call save_restart(restart_dir, Time, CS%grid, CS%restart_CSp, time_stamped) end subroutine ice_shelf_save_restart diff --git a/src/initialization/MOM_state_initialization.F90 b/src/initialization/MOM_state_initialization.F90 index 983c008473..9f505325bf 100644 --- a/src/initialization/MOM_state_initialization.F90 +++ b/src/initialization/MOM_state_initialization.F90 @@ -481,10 +481,8 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, US, PF, dirs, & if (.not.new_sim) then ! This block restores the state from a restart file. ! This line calls a subroutine that reads the initial conditions ! from a previously generated file. - - ! NOTE: use_fms2=.true. routes routine to fms2 IO interface call restore_state(dirs%input_filename, dirs%restart_input_dir, Time, & - G, restart_CS, use_fms2=.true.) + G, restart_CS) if (present(Time_in)) Time = Time_in if ((GV%m_to_H_restart /= 0.0) .and. (GV%m_to_H_restart /= GV%m_to_H)) then H_rescale = GV%m_to_H / GV%m_to_H_restart