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 001/112] 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 002/112] 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 003/112] 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 004/112] 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 005/112] 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 006/112] 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 007/112] 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 008/112] 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 009/112] 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 From f806579bcd51833ffbb7e04a15cae3635947542d Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 5 Mar 2021 19:37:36 -0500 Subject: [PATCH 010/112] Correct module use statements in infra/FMS1 Corrected three module use statements in infra/FMS1 to eliminate any dependencies of code in config_src/infra/FMS1 on code in src/framework. These use statements eventually point to the same place as before, but with less indirection. This change should facilitate later steps to compile everything in and under the config_src/infra directories as libraries. All answers are bitwise identical. --- config_src/infra/FMS1/MOM_diag_manager_infra.F90 | 4 ++-- config_src/infra/FMS1/MOM_domain_infra.F90 | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/config_src/infra/FMS1/MOM_diag_manager_infra.F90 b/config_src/infra/FMS1/MOM_diag_manager_infra.F90 index 702c464814..18c80cf24c 100644 --- a/config_src/infra/FMS1/MOM_diag_manager_infra.F90 +++ b/config_src/infra/FMS1/MOM_diag_manager_infra.F90 @@ -20,9 +20,9 @@ module MOM_diag_manager_infra use diag_manager_mod, only : register_diag_field_fms => register_diag_field use diag_manager_mod, only : register_static_field_fms => register_static_field use diag_manager_mod, only : get_diag_field_id_fms => get_diag_field_id -use time_manager_mod, only : time_type +use MOM_time_manager, only : time_type use MOM_domain_infra, only : MOM_domain_type -use MOM_error_handler, only : MOM_error, FATAL, WARNING +use MOM_error_infra, only : MOM_error => MOM_err, FATAL, WARNING implicit none ; private diff --git a/config_src/infra/FMS1/MOM_domain_infra.F90 b/config_src/infra/FMS1/MOM_domain_infra.F90 index 86e85e60a6..7c3424ca15 100644 --- a/config_src/infra/FMS1/MOM_domain_infra.F90 +++ b/config_src/infra/FMS1/MOM_domain_infra.F90 @@ -4,7 +4,7 @@ module MOM_domain_infra ! This file is part of MOM6. See LICENSE.md for the license. use MOM_coms_infra, only : PE_here, root_PE, num_PEs -use MOM_cpu_clock, only : cpu_clock_begin, cpu_clock_end +use MOM_cpu_clock_infra, only : cpu_clock_begin, cpu_clock_end use MOM_error_infra, only : MOM_error=>MOM_err, NOTE, WARNING, FATAL use mpp_domains_mod, only : domain2D, domain1D From d4531ca374fe70ca772d59a5bc5e0dd4d7c368d6 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 5 Mar 2021 19:38:49 -0500 Subject: [PATCH 011/112] Duplicated infra/FMS1 into infra/FMS2 Duplicated all of the modules in infra/FMS1 into new copies in infra/FMS2, in preparation for merging in the FMS2 i/o changes to the new infra/FMS2 directory. All answers are bitwise identical, regardless of which config_src/infra directory is used. --- config_src/infra/FMS2/MOM_coms_infra.F90 | 455 ++++ config_src/infra/FMS2/MOM_constants.F90 | 14 + .../infra/FMS2/MOM_couplertype_infra.F90 | 247 +++ config_src/infra/FMS2/MOM_cpu_clock_infra.F90 | 93 + .../infra/FMS2/MOM_data_override_infra.F90 | 105 + .../infra/FMS2/MOM_diag_manager_infra.F90 | 423 ++++ config_src/infra/FMS2/MOM_domain_infra.F90 | 1941 +++++++++++++++++ .../infra/FMS2/MOM_ensemble_manager_infra.F90 | 95 + config_src/infra/FMS2/MOM_error_infra.F90 | 42 + config_src/infra/FMS2/MOM_interp_infra.F90 | 251 +++ config_src/infra/FMS2/MOM_io_infra.F90 | 801 +++++++ config_src/infra/FMS2/MOM_time_manager.F90 | 54 + 12 files changed, 4521 insertions(+) create mode 100644 config_src/infra/FMS2/MOM_coms_infra.F90 create mode 100644 config_src/infra/FMS2/MOM_constants.F90 create mode 100644 config_src/infra/FMS2/MOM_couplertype_infra.F90 create mode 100644 config_src/infra/FMS2/MOM_cpu_clock_infra.F90 create mode 100644 config_src/infra/FMS2/MOM_data_override_infra.F90 create mode 100644 config_src/infra/FMS2/MOM_diag_manager_infra.F90 create mode 100644 config_src/infra/FMS2/MOM_domain_infra.F90 create mode 100644 config_src/infra/FMS2/MOM_ensemble_manager_infra.F90 create mode 100644 config_src/infra/FMS2/MOM_error_infra.F90 create mode 100644 config_src/infra/FMS2/MOM_interp_infra.F90 create mode 100644 config_src/infra/FMS2/MOM_io_infra.F90 create mode 100644 config_src/infra/FMS2/MOM_time_manager.F90 diff --git a/config_src/infra/FMS2/MOM_coms_infra.F90 b/config_src/infra/FMS2/MOM_coms_infra.F90 new file mode 100644 index 0000000000..555b4df119 --- /dev/null +++ b/config_src/infra/FMS2/MOM_coms_infra.F90 @@ -0,0 +1,455 @@ +!> Thin interfaces to non-domain-oriented mpp communication subroutines +module MOM_coms_infra + +! This file is part of MOM6. See LICENSE.md for the license. + +use iso_fortran_env, only : int32, int64 + +use mpp_mod, only : mpp_pe, mpp_root_pe, mpp_npes, mpp_set_root_pe +use mpp_mod, only : mpp_set_current_pelist, mpp_get_current_pelist +use mpp_mod, only : mpp_broadcast, mpp_sync, mpp_sync_self, mpp_chksum +use mpp_mod, only : mpp_sum, mpp_max, mpp_min +use memutils_mod, only : print_memuse_stats +use fms_mod, only : fms_end, fms_init + +implicit none ; private + +public :: PE_here, root_PE, num_PEs, set_rootPE, Set_PElist, Get_PElist +public :: broadcast, sum_across_PEs, min_across_PEs, max_across_PEs +public :: field_chksum, MOM_infra_init, MOM_infra_end + +! This module provides interfaces to the non-domain-oriented communication +! subroutines. + +!> Communicate an array, string or scalar from one PE to others +interface broadcast + module procedure broadcast_char, broadcast_int32_0D, broadcast_int64_0D, broadcast_int1D + module procedure broadcast_real0D, broadcast_real1D, broadcast_real2D +end interface broadcast + +!> Compute a checksum for a field distributed over a PE list. If no PE list is +!! provided, then the current active PE list is used. +interface field_chksum + module procedure field_chksum_real_0d + module procedure field_chksum_real_1d + module procedure field_chksum_real_2d + module procedure field_chksum_real_3d + module procedure field_chksum_real_4d +end interface field_chksum + +!> Find the sum of field across PEs, and update PEs with the sums. +interface sum_across_PEs + module procedure sum_across_PEs_int4_0d + module procedure sum_across_PEs_int4_1d + module procedure sum_across_PEs_int8_0d + module procedure sum_across_PEs_int8_1d + module procedure sum_across_PEs_int8_2d + module procedure sum_across_PEs_real_0d + module procedure sum_across_PEs_real_1d + module procedure sum_across_PEs_real_2d +end interface sum_across_PEs + +!> Find the maximum value of field across PEs, and update PEs with the values. +interface max_across_PEs + module procedure max_across_PEs_int_0d + module procedure max_across_PEs_real_0d + module procedure max_across_PEs_real_1d +end interface max_across_PEs + +!> Find the minimum value of field across PEs, and update PEs with the values. +interface min_across_PEs + module procedure min_across_PEs_int_0d + module procedure min_across_PEs_real_0d + module procedure min_across_PEs_real_1d +end interface min_across_PEs + +contains + +!> Return the ID of the PE for the current process. +function PE_here() result(pe) + integer :: pe !< PE ID of the current process + pe = mpp_pe() +end function PE_here + +!> Return the ID of the root PE for the PE list of the current procss. +function root_PE() result(pe) + integer :: pe !< root PE ID + pe = mpp_root_pe() +end function root_PE + +!> Return the number of PEs for the current PE list. +function num_PEs() result(npes) + integer :: npes !< Number of PEs + npes = mpp_npes() +end function num_PEs + +!> Designate a PE as the root PE +subroutine set_rootPE(pe) + integer, intent(in) :: pe !< ID of the PE to be assigned as root + call mpp_set_root_pe(pe) +end subroutine + +!> Set the current PE list. If no list is provided, then the current PE list +!! is set to the list of all available PEs on the communicator. Setting the +!! list will trigger a rank synchronization unless the `no_sync` flag is set. +subroutine Set_PEList(pelist, no_sync) + integer, optional, intent(in) :: pelist(:) !< List of PEs to set for communication + logical, optional, intent(in) :: no_sync !< Do not sync after list update. + call mpp_set_current_pelist(pelist, no_sync) +end subroutine Set_PEList + +!> Retrieve the current PE list and any metadata if requested. +subroutine Get_PEList(pelist, name, commID) + integer, intent(out) :: pelist(:) !< List of PE IDs of the current PE list + character(len=*), optional, intent(out) :: name !< Name of PE list + integer, optional, intent(out) :: commID !< Communicator ID of PE list + + call mpp_get_current_pelist(pelist, name, commiD) +end subroutine Get_PEList + +!> Communicate a 1-D array of character strings from one PE to others +subroutine broadcast_char(dat, length, from_PE, PElist, blocking) + character(len=*), intent(inout) :: dat(:) !< The data to communicate and destination + integer, intent(in) :: length !< The length of each string + integer, optional, intent(in) :: from_PE !< The source PE, by default the root PE + integer, optional, intent(in) :: PElist(:) !< The list of participating PEs, by default the + !! active PE set as previously set via Set_PElist. + logical, optional, intent(in) :: blocking !< If true, barriers are added around the call + + integer :: src_PE ! The processor that is sending the data + logical :: do_block ! If true add synchronizing barriers + + do_block = .false. ; if (present(blocking)) do_block = blocking + if (present(from_PE)) then ; src_PE = from_PE ; else ; src_PE = root_PE() ; endif + + if (do_block) call mpp_sync(PElist) + call mpp_broadcast(dat, length, src_PE, PElist) + if (do_block) call mpp_sync_self(PElist) + +end subroutine broadcast_char + +!> Communicate an integer from one PE to others +subroutine broadcast_int64_0D(dat, from_PE, PElist, blocking) + integer(kind=int64), intent(inout) :: dat !< The data to communicate and destination + integer, optional, intent(in) :: from_PE !< The source PE, by default the root PE + integer, optional, intent(in) :: PElist(:) !< The list of participating PEs, by default the + !! active PE set as previously set via Set_PElist. + logical, optional, intent(in) :: blocking !< If true, barriers are added around the call + + integer :: src_PE ! The processor that is sending the data + logical :: do_block ! If true add synchronizing barriers + + do_block = .false. ; if (present(blocking)) do_block = blocking + if (present(from_PE)) then ; src_PE = from_PE ; else ; src_PE = root_PE() ; endif + + if (do_block) call mpp_sync(PElist) + call mpp_broadcast(dat, src_PE, PElist) + if (do_block) call mpp_sync_self(PElist) + +end subroutine broadcast_int64_0D + + +!> Communicate an integer from one PE to others +subroutine broadcast_int32_0D(dat, from_PE, PElist, blocking) + integer(kind=int32), intent(inout) :: dat !< The data to communicate and destination + integer, optional, intent(in) :: from_PE !< The source PE, by default the root PE + integer, optional, intent(in) :: PElist(:) !< The list of participating PEs, by default the + !! active PE set as previously set via Set_PElist. + logical, optional, intent(in) :: blocking !< If true, barriers are added around the call + + integer :: src_PE ! The processor that is sending the data + logical :: do_block ! If true add synchronizing barriers + + do_block = .false. ; if (present(blocking)) do_block = blocking + if (present(from_PE)) then ; src_PE = from_PE ; else ; src_PE = root_PE() ; endif + + if (do_block) call mpp_sync(PElist) + call mpp_broadcast(dat, src_PE, PElist) + if (do_block) call mpp_sync_self(PElist) + +end subroutine broadcast_int32_0D + +!> Communicate a 1-D array of integers from one PE to others +subroutine broadcast_int1D(dat, length, from_PE, PElist, blocking) + integer, dimension(:), intent(inout) :: dat !< The data to communicate and destination + integer, intent(in) :: length !< The number of data elements + integer, optional, intent(in) :: from_PE !< The source PE, by default the root PE + integer, optional, intent(in) :: PElist(:) !< The list of participating PEs, by default the + !! active PE set as previously set via Set_PElist. + logical, optional, intent(in) :: blocking !< If true, barriers are added around the call + + integer :: src_PE ! The processor that is sending the data + logical :: do_block ! If true add synchronizing barriers + + do_block = .false. ; if (present(blocking)) do_block = blocking + if (present(from_PE)) then ; src_PE = from_PE ; else ; src_PE = root_PE() ; endif + + if (do_block) call mpp_sync(PElist) + call mpp_broadcast(dat, length, src_PE, PElist) + if (do_block) call mpp_sync_self(PElist) + +end subroutine broadcast_int1D + +!> Communicate a real number from one PE to others +subroutine broadcast_real0D(dat, from_PE, PElist, blocking) + real, intent(inout) :: dat !< The data to communicate and destination + integer, optional, intent(in) :: from_PE !< The source PE, by default the root PE + integer, optional, intent(in) :: PElist(:) !< The list of participating PEs, by default the + !! active PE set as previously set via Set_PElist. + logical, optional, intent(in) :: blocking !< If true, barriers are added around the call + + integer :: src_PE ! The processor that is sending the data + logical :: do_block ! If true add synchronizing barriers + + do_block = .false. ; if (present(blocking)) do_block = blocking + if (present(from_PE)) then ; src_PE = from_PE ; else ; src_PE = root_PE() ; endif + + if (do_block) call mpp_sync(PElist) + call mpp_broadcast(dat, src_PE, PElist) + if (do_block) call mpp_sync_self(PElist) + +end subroutine broadcast_real0D + +!> Communicate a 1-D array of reals from one PE to others +subroutine broadcast_real1D(dat, length, from_PE, PElist, blocking) + real, dimension(:), intent(inout) :: dat !< The data to communicate and destination + integer, intent(in) :: length !< The number of data elements + integer, optional, intent(in) :: from_PE !< The source PE, by default the root PE + integer, optional, intent(in) :: PElist(:) !< The list of participating PEs, by default the + !! active PE set as previously set via Set_PElist. + logical, optional, intent(in) :: blocking !< If true, barriers are added around the call + + integer :: src_PE ! The processor that is sending the data + logical :: do_block ! If true add synchronizing barriers + + do_block = .false. ; if (present(blocking)) do_block = blocking + if (present(from_PE)) then ; src_PE = from_PE ; else ; src_PE = root_PE() ; endif + + if (do_block) call mpp_sync(PElist) + call mpp_broadcast(dat, length, src_PE, PElist) + if (do_block) call mpp_sync_self(PElist) + +end subroutine broadcast_real1D + +!> Communicate a 2-D array of reals from one PE to others +subroutine broadcast_real2D(dat, length, from_PE, PElist, blocking) + real, dimension(:,:), intent(inout) :: dat !< The data to communicate and destination + integer, intent(in) :: length !< The total number of data elements + integer, optional, intent(in) :: from_PE !< The source PE, by default the root PE + integer, optional, intent(in) :: PElist(:) !< The list of participating PEs, by default the + !! active PE set as previously set via Set_PElist. + logical, optional, intent(in) :: blocking !< If true, barriers are added around the call + + integer :: src_PE ! The processor that is sending the data + logical :: do_block ! If true add synchronizing barriers + + do_block = .false. ; if (present(blocking)) do_block = blocking + if (present(from_PE)) then ; src_PE = from_PE ; else ; src_PE = root_PE() ; endif + + if (do_block) call mpp_sync(PElist) + call mpp_broadcast(dat, length, src_PE, PElist) + if (do_block) call mpp_sync_self(PElist) + +end subroutine broadcast_real2D + +! field_chksum wrappers + +!> Compute a checksum for a field distributed over a PE list. If no PE list is +!! provided, then the current active PE list is used. +function field_chksum_real_0d(field, pelist, mask_val) result(chksum) + real, intent(in) :: field !< Input scalar + integer, optional, intent(in) :: pelist(:) !< PE list of ranks to checksum + real, optional, intent(in) :: mask_val !< FMS mask value + integer(kind=int64) :: chksum !< checksum of array + + chksum = mpp_chksum(field, pelist, mask_val) +end function field_chksum_real_0d + +!> Compute a checksum for a field distributed over a PE list. If no PE list is +!! provided, then the current active PE list is used. +function field_chksum_real_1d(field, pelist, mask_val) result(chksum) + real, dimension(:), intent(in) :: field !< Input array + integer, optional, intent(in) :: pelist(:) !< PE list of ranks to checksum + real, optional, intent(in) :: mask_val !< FMS mask value + integer(kind=int64) :: chksum !< checksum of array + + chksum = mpp_chksum(field, pelist, mask_val) +end function field_chksum_real_1d + +!> Compute a checksum for a field distributed over a PE list. If no PE list is +!! provided, then the current active PE list is used. +function field_chksum_real_2d(field, pelist, mask_val) result(chksum) + real, dimension(:,:), intent(in) :: field !< Unrotated input field + integer, optional, intent(in) :: pelist(:) !< PE list of ranks to checksum + real, optional, intent(in) :: mask_val !< FMS mask value + integer(kind=int64) :: chksum !< checksum of array + + chksum = mpp_chksum(field, pelist, mask_val) +end function field_chksum_real_2d + +!> Compute a checksum for a field distributed over a PE list. If no PE list is +!! provided, then the current active PE list is used. +function field_chksum_real_3d(field, pelist, mask_val) result(chksum) + real, dimension(:,:,:), intent(in) :: field !< Unrotated input field + integer, optional, intent(in) :: pelist(:) !< PE list of ranks to checksum + real, optional, intent(in) :: mask_val !< FMS mask value + integer(kind=int64) :: chksum !< checksum of array + + chksum = mpp_chksum(field, pelist, mask_val) +end function field_chksum_real_3d + +!> Compute a checksum for a field distributed over a PE list. If no PE list is +!! provided, then the current active PE list is used. +function field_chksum_real_4d(field, pelist, mask_val) result(chksum) + real, dimension(:,:,:,:), intent(in) :: field !< Unrotated input field + integer, optional, intent(in) :: pelist(:) !< PE list of ranks to checksum + real, optional, intent(in) :: mask_val !< FMS mask value + integer(kind=int64) :: chksum !< checksum of array + + chksum = mpp_chksum(field, pelist, mask_val) +end function field_chksum_real_4d + +! sum_across_PEs wrappers + +!> Find the sum of field across PEs, and return this sum in field. +subroutine sum_across_PEs_int4_0d(field, pelist) + integer(kind=int32), intent(inout) :: field !< Value on this PE, and the sum across PEs upon return + integer, optional, intent(in) :: pelist(:) !< List of PEs to work with + + call mpp_sum(field, pelist) +end subroutine sum_across_PEs_int4_0d + +!> Find the sum of the values in corresponding positions of field across PEs, and return these sums in field. +subroutine sum_across_PEs_int4_1d(field, length, pelist) + integer(kind=int32), dimension(:), intent(inout) :: field !< The values to add, the sums upon return + integer, intent(in) :: length !< Number of elements in field to add + integer, optional, intent(in) :: pelist(:) !< List of PEs to work with + + call mpp_sum(field, length, pelist) +end subroutine sum_across_PEs_int4_1d + +!> Find the sum of field across PEs, and return this sum in field. +subroutine sum_across_PEs_int8_0d(field, pelist) + integer(kind=int64), intent(inout) :: field !< Value on this PE, and the sum across PEs upon return + integer, optional, intent(in) :: pelist(:) !< List of PEs to work with + + call mpp_sum(field, pelist) +end subroutine sum_across_PEs_int8_0d + +!> Find the sum of the values in corresponding positions of field across PEs, and return these sums in field. +subroutine sum_across_PEs_int8_1d(field, length, pelist) + integer(kind=int64), dimension(:), intent(inout) :: field !< The values to add, the sums upon return + integer, intent(in) :: length !< Number of elements in field to add + integer, optional, intent(in) :: pelist(:) !< List of PEs to work with + + call mpp_sum(field, length, pelist) +end subroutine sum_across_PEs_int8_1d + +!> Find the sum of the values in corresponding positions of field across PEs, and return these sums in field. +subroutine sum_across_PEs_int8_2d(field, length, pelist) + integer(kind=int64), & + dimension(:,:), intent(inout) :: field !< The values to add, the sums upon return + integer, intent(in) :: length !< The total number of positions to sum, usually + !! the product of the array sizes. + integer, optional, intent(in) :: pelist(:) !< List of PEs to work with + + call mpp_sum(field, length, pelist) +end subroutine sum_across_PEs_int8_2d + +!> Find the sum of field across PEs, and return this sum in field. +subroutine sum_across_PEs_real_0d(field, pelist) + real, intent(inout) :: field !< Value on this PE, and the sum across PEs upon return + integer, optional, intent(in) :: pelist(:) !< List of PEs to work with + + call mpp_sum(field, pelist) +end subroutine sum_across_PEs_real_0d + +!> Find the sum of the values in corresponding positions of field across PEs, and return these sums in field. +subroutine sum_across_PEs_real_1d(field, length, pelist) + real, dimension(:), intent(inout) :: field !< The values to add, the sums upon return + integer, intent(in) :: length !< Number of elements in field to add + integer, optional, intent(in) :: pelist(:) !< List of PEs to work with + + call mpp_sum(field, length, pelist) +end subroutine sum_across_PEs_real_1d + +!> Find the sum of the values in corresponding positions of field across PEs, and return these sums in field. +subroutine sum_across_PEs_real_2d(field, length, pelist) + real, dimension(:,:), intent(inout) :: field !< The values to add, the sums upon return + integer, intent(in) :: length !< The total number of positions to sum, usually + !! the product of the array sizes. + integer, optional, intent(in) :: pelist(:) !< List of PEs to work with + + call mpp_sum(field, length, pelist) +end subroutine sum_across_PEs_real_2d + +! max_across_PEs wrappers + +!> Find the maximum value of field across PEs, and store this maximum in field. +subroutine max_across_PEs_int_0d(field, pelist) + integer, intent(inout) :: field !< The values to compare, the maximum upon return + integer, optional, intent(in) :: pelist(:) !< List of PEs to work with + + call mpp_max(field, pelist) +end subroutine max_across_PEs_int_0d + +!> Find the maximum value of field across PEs, and store this maximum in field. +subroutine max_across_PEs_real_0d(field, pelist) + real, intent(inout) :: field !< The values to compare, the maximum upon return + integer, optional, intent(in) :: pelist(:) !< List of PEs to work with + + call mpp_max(field, pelist) +end subroutine max_across_PEs_real_0d + +!> Find the maximum values in each position of field across PEs, and store these minima in field. +subroutine max_across_PEs_real_1d(field, length, pelist) + real, dimension(:), intent(inout) :: field !< The list of values being compared, with the + !! maxima in each position upon return + integer, intent(in) :: length !< Number of elements in field to compare + integer, optional, intent(in) :: pelist(:) !< List of PEs to work with + + call mpp_max(field, length, pelist) +end subroutine max_across_PEs_real_1d + +! min_across_PEs wrappers + +!> Find the minimum value of field across PEs, and store this minimum in field. +subroutine min_across_PEs_int_0d(field, pelist) + integer, intent(inout) :: field !< The values to compare, the minimum upon return + integer, optional, intent(in) :: pelist(:) !< List of PEs to work with + + call mpp_min(field, pelist) +end subroutine min_across_PEs_int_0d + +!> Find the minimum value of field across PEs, and store this minimum in field. +subroutine min_across_PEs_real_0d(field, pelist) + real, intent(inout) :: field !< The values to compare, the minimum upon return + integer, optional, intent(in) :: pelist(:) !< List of PEs to work with + call mpp_min(field, pelist) +end subroutine min_across_PEs_real_0d + +!> Find the minimum values in each position of field across PEs, and store these minima in field. +subroutine min_across_PEs_real_1d(field, length, pelist) + real, dimension(:), intent(inout) :: field !< The list of values being compared, with the + !! minima in each position upon return + integer, intent(in) :: length !< Number of elements in field to compare + integer, optional, intent(in) :: pelist(:) !< List of PEs to work with + + call mpp_min(field, length, pelist) +end subroutine min_across_PEs_real_1d + +!> Initialize the model framework, including PE communication over a designated communicator. +!! If no communicator ID is provided, the framework's default communicator is used. +subroutine MOM_infra_init(localcomm) + integer, optional, intent(in) :: localcomm !< Communicator ID to initialize + call fms_init(localcomm) +end subroutine + +!> This subroutine carries out all of the calls required to close out the infrastructure cleanly. +!! This should only be called in ocean-only runs, as the coupler takes care of this in coupled runs. +subroutine MOM_infra_end + call print_memuse_stats( 'Memory HiWaterMark', always=.TRUE. ) + call fms_end() +end subroutine MOM_infra_end + +end module MOM_coms_infra diff --git a/config_src/infra/FMS2/MOM_constants.F90 b/config_src/infra/FMS2/MOM_constants.F90 new file mode 100644 index 0000000000..2db177e08c --- /dev/null +++ b/config_src/infra/FMS2/MOM_constants.F90 @@ -0,0 +1,14 @@ +!> Provides a few physical constants +module MOM_constants + +! This file is part of MOM6. See LICENSE.md for the license. + +use constants_mod, only : HLV, HLF + +implicit none ; private + +!> The constant offset for converting temperatures in Kelvin to Celsius +real, public, parameter :: CELSIUS_KELVIN_OFFSET = 273.15 +public :: HLV, HLF + +end module MOM_constants diff --git a/config_src/infra/FMS2/MOM_couplertype_infra.F90 b/config_src/infra/FMS2/MOM_couplertype_infra.F90 new file mode 100644 index 0000000000..fd947691ca --- /dev/null +++ b/config_src/infra/FMS2/MOM_couplertype_infra.F90 @@ -0,0 +1,247 @@ +!> This module wraps the FMS coupler types module +module MOM_couplertype_infra + +! This file is part of MOM6. See LICENSE.md for the license. + +use coupler_types_mod, only : coupler_type_spawn, coupler_type_initialized, coupler_type_destructor +use coupler_types_mod, only : coupler_type_set_diags, coupler_type_send_data +use coupler_types_mod, only : coupler_type_write_chksums +use coupler_types_mod, only : coupler_type_copy_data, coupler_type_increment_data +use coupler_types_mod, only : coupler_type_extract_data, coupler_type_set_data +use coupler_types_mod, only : ind_flux, ind_alpha, ind_csurf +use coupler_types_mod, only : coupler_1d_bc_type, coupler_2d_bc_type +use atmos_ocean_fluxes_mod, only : aof_set_coupler_flux +use MOM_time_manager, only : time_type + +implicit none ; private + +public :: CT_spawn, CT_initialized, CT_destructor +public :: CT_set_diags, CT_send_data, CT_write_chksums +public :: CT_set_data, CT_increment_data +public :: CT_copy_data, CT_extract_data +public :: atmos_ocn_coupler_flux +public :: ind_flux, ind_alpha, ind_csurf +public :: coupler_1d_bc_type, coupler_2d_bc_type + +!> This is the interface to spawn one coupler_bc_type into another. +interface CT_spawn + module procedure CT_spawn_1d_2d, CT_spawn_2d_2d +end interface CT_spawn + +!> This function interface indicates whether a coupler_bc_type has been initialized. +interface CT_initialized + module procedure CT_initialized_1d, CT_initialized_2d +end interface CT_initialized + +!> This is the interface to deallocate any data associated with a coupler_bc_type. +interface CT_destructor + module procedure CT_destructor_1d, CT_destructor_2d +end interface CT_destructor + +contains + +!> This subroutine sets many of the parameters for calculating an atmosphere-ocean tracer flux +!! and retuns an integer index for that flux. +function atmos_ocn_coupler_flux(name, flux_type, implementation, param, mol_wt, & + ice_restart_file, ocean_restart_file, units, caller, verbosity) & + result (coupler_index) + + character(len=*), intent(in) :: name !< A name to use for the flux + character(len=*), intent(in) :: flux_type !< A string describing the type of this flux, + !! perhaps 'air_sea_gas_flux'. + character(len=*), intent(in) :: implementation !< A name describing the specific + !! implementation of this flux, such as 'ocmip2'. + real, dimension(:), optional, intent(in) :: param !< An array of parameters used for the fluxes + real, optional, intent(in) :: mol_wt !< The molecular weight of this tracer + character(len=*), optional, intent(in) :: ice_restart_file !< A sea-ice restart file to use with this flux. + character(len=*), optional, intent(in) :: ocean_restart_file !< An ocean restart file to use with this flux. + character(len=*), optional, intent(in) :: units !< The units of the flux + character(len=*), optional, intent(in) :: caller !< The name of the calling routine + integer, optional, intent(in) :: verbosity !< A 0-9 integer indicating a level of verbosity. + integer :: coupler_index !< The resulting integer handle to use for this flux in subsequent calls. + + coupler_index = aof_set_coupler_flux(name, flux_type, implementation, & + param=param, mol_wt=mol_wt, ice_restart_file=ice_restart_file, & + ocean_restart_file=ocean_restart_file, & + units=units, caller=caller, verbosity=verbosity) + +end function atmos_ocn_coupler_flux + +!> Generate a 2-D coupler type using a 1-D coupler type as a template. +subroutine CT_spawn_1d_2d(var_in, var, idim, jdim, suffix, as_needed) + type(coupler_1d_bc_type), intent(in) :: var_in !< structure from which to copy information + type(coupler_2d_bc_type), intent(inout) :: var !< structure into which to copy information + integer, dimension(4), intent(in) :: idim !< The data and computational domain extents of + !! the first dimension in a non-decreasing list + integer, dimension(4), intent(in) :: jdim !< The data and computational domain extents of + !! the second dimension in a non-decreasing list + character(len=*), optional, intent(in) :: suffix !< optional suffix to make the name identifier unique + logical, optional, intent(in) :: as_needed !< Only do the spawn if the target type (var) + !! is not set and the parent type (var_in) is set. + + call coupler_type_spawn(var_in, var, idim, jdim, suffix=suffix, as_needed=as_needed) + +end subroutine CT_spawn_1d_2d + +!> Generate one 2-D coupler type using another 2-D coupler type as a template. +subroutine CT_spawn_2d_2d(var_in, var, idim, jdim, suffix, as_needed) + type(coupler_2d_bc_type), intent(in) :: var_in !< structure from which to copy information + type(coupler_2d_bc_type), intent(inout) :: var !< structure into which to copy information + integer, dimension(4), intent(in) :: idim !< The data and computational domain extents of + !! the first dimension in a non-decreasing list + integer, dimension(4), intent(in) :: jdim !< The data and computational domain extents of + !! the second dimension in a non-decreasing list + character(len=*), optional, intent(in) :: suffix !< optional suffix to make the name identifier unique + logical, optional, intent(in) :: as_needed !< Only do the spawn if the target type (var) + !! is not set and the parent type (var_in) is set. + + call coupler_type_spawn(var_in, var, idim, jdim, suffix=suffix, as_needed=as_needed) + +end subroutine CT_spawn_2d_2d + +!> Copy all elements of the data in of one coupler_2d_bc_type into another. Both must have the same array sizes. +subroutine CT_copy_data(var_in, var, halo_size, bc_index, field_index, & + exclude_flux_type, only_flux_type, pass_through_ice) + type(coupler_2d_bc_type), intent(in) :: var_in !< BC_type structure with the data to copy + type(coupler_2d_bc_type), intent(inout) :: var !< The recipient BC_type structure + integer, optional, intent(in) :: halo_size !< The extent of the halo to copy; 0 by default + integer, optional, intent(in) :: bc_index !< The index of the boundary condition + !! that is being copied + integer, optional, intent(in) :: field_index !< The index of the field in the + !! boundary condition that is being copied + character(len=*), optional, intent(in) :: exclude_flux_type !< A string describing which types of fluxes + !! to exclude from this copy. + character(len=*), optional, intent(in) :: only_flux_type !< A string describing which types of fluxes + !! to include from this copy. + logical, optional, intent(in) :: pass_through_ice !< If true, only copy BCs whose + !! value of pass_through ice matches this + + call coupler_type_copy_data(var_in, var, halo_size, bc_index, field_index, & + exclude_flux_type, only_flux_type, pass_through_ice) +end subroutine CT_copy_data + +!> Increment data in all elements of one coupler_2d_bc_type with the data from another. Both +!! must have the same array sizes. +subroutine CT_increment_data(var_in, var, halo_size, scale_factor, scale_prev) + type(coupler_2d_bc_type), intent(in) :: var_in !< coupler_type structure with the data to add to the other type + type(coupler_2d_bc_type), intent(inout) :: var !< The coupler_type structure whose fields are being incremented + integer, optional, intent(in) :: halo_size !< The extent of the halo to increment; 0 by default + real, optional, intent(in) :: scale_factor !< A scaling factor for the data that is being added + real, optional, intent(in) :: scale_prev !< A scaling factor for the data that is already here + + call coupler_type_increment_data(var_in, var, halo_size=halo_size, scale_factor=scale_factor, & + scale_prev=scale_prev) + +end subroutine CT_increment_data + +!> Extract a 2d field from a coupler_2d_bc_type into a two-dimensional array. +subroutine CT_extract_data(var_in, bc_index, field_index, array_out, & + scale_factor, halo_size, idim, jdim) + type(coupler_2d_bc_type), intent(in) :: var_in !< BC_type structure with the data to extract + integer, intent(in) :: bc_index !< The index of the boundary condition + !! that is being copied + integer, intent(in) :: field_index !< The index of the field in the boundary + !! condition that is being copied, or the + !! surface flux by default. + real, dimension(1:,1:), intent(out) :: array_out !< The recipient array for the field; its size + !! must match the size of the data being copied + !! unless idim and jdim are supplied. + real, optional, intent(in) :: scale_factor !< A scaling factor for the data that is being added + integer, optional, intent(in) :: halo_size !< The extent of the halo to copy; 0 by default + integer, dimension(4), optional, intent(in) :: idim !< The data and computational domain extents of + !! the first dimension of the output array + !! in a non-decreasing list + integer, dimension(4), optional, intent(in) :: jdim !< The data and computational domain extents of + !! the second dimension of the output array + !! in a non-decreasing list + call coupler_type_extract_data(var_in, bc_index, field_index, array_out, scale_factor, halo_size, idim, jdim) + +end subroutine CT_extract_data + +!> Set single 2d field in coupler_2d_bc_type from a two-dimensional array. +subroutine CT_set_data(array_in, bc_index, field_index, var, & + scale_factor, halo_size, idim, jdim) + real, dimension(1:,1:), intent(in) :: array_in !< The source array for the field; its size + !! must match the size of the data being copied + !! unless idim and jdim are supplied. + integer, intent(in) :: bc_index !< The index of the boundary condition + !! that is being copied + integer, intent(in) :: field_index !< The index of the field in the + !! boundary condition that is being set. The + !! surface concentration is set by default. + type(coupler_2d_bc_type), intent(inout) :: var !< BC_type structure with the data to set + real, optional, intent(in) :: scale_factor !< A scaling factor for the data that is being added + integer, optional, intent(in) :: halo_size !< The extent of the halo to copy; 0 by default + integer, dimension(4), optional, intent(in) :: idim !< The data and computational domain extents of + !! the first dimension of the output array + !! in a non-decreasing list + integer, dimension(4), optional, intent(in) :: jdim !< The data and computational domain extents of + !! the second dimension of the output array + !! in a non-decreasing list + + integer :: subfield ! An integer indicating which field to set. + + call coupler_type_set_data(array_in, bc_index, field_index, var, scale_factor, halo_size, idim, jdim) + +end subroutine CT_set_data + +!> Register the diagnostics of a coupler_2d_bc_type +subroutine CT_set_diags(var, diag_name, axes, time) + type(coupler_2d_bc_type), intent(inout) :: var !< BC_type structure for which to register diagnostics + character(len=*), intent(in) :: diag_name !< name for diagnostic file, or blank not to register the fields + integer, dimension(:), intent(in) :: axes !< array of axes identifiers for diagnostic variable registration + type(time_type), intent(in) :: time !< model time variable for registering diagnostic field + + call coupler_type_set_diags(var, diag_name, axes, time) + +end subroutine CT_set_diags + +!> Write out all diagnostics of elements of a coupler_2d_bc_type +subroutine CT_send_data(var, Time) + type(coupler_2d_bc_type), intent(in) :: var !< BC_type structure with the diagnostics to write + type(time_type), intent(in) :: time !< The current model time + + call coupler_type_send_data(var, Time) +end subroutine CT_send_data + +!> Write out checksums for the elements of a coupler_2d_bc_type +subroutine CT_write_chksums(var, outunit, name_lead) + type(coupler_2d_bc_type), intent(in) :: var !< BC_type structure for which to register diagnostics + integer, intent(in) :: outunit !< The index of a open output file + character(len=*), optional, intent(in) :: name_lead !< An optional prefix for the variable names + + call coupler_type_write_chksums(var, outunit, name_lead) + +end subroutine CT_write_chksums + +!> Indicate whether a coupler_1d_bc_type has been initialized. +logical function CT_initialized_1d(var) + type(coupler_1d_bc_type), intent(in) :: var !< BC_type structure to be deconstructed + + CT_initialized_1d = coupler_type_initialized(var) +end function CT_initialized_1d + +!> Indicate whether a coupler_2d_bc_type has been initialized. +logical function CT_initialized_2d(var) + type(coupler_2d_bc_type), intent(in) :: var !< BC_type structure to be deconstructed + + CT_initialized_2d = coupler_type_initialized(var) +end function CT_initialized_2d + +!> Deallocate all data associated with a coupler_1d_bc_type +subroutine CT_destructor_1d(var) + type(coupler_1d_bc_type), intent(inout) :: var !< BC_type structure to be deconstructed + + call coupler_type_destructor(var) + +end subroutine CT_destructor_1d + +!> Deallocate all data associated with a coupler_2d_bc_type +subroutine CT_destructor_2d(var) + type(coupler_2d_bc_type), intent(inout) :: var !< BC_type structure to be deconstructed + + call coupler_type_destructor(var) + +end subroutine CT_destructor_2d + +end module MOM_couplertype_infra diff --git a/config_src/infra/FMS2/MOM_cpu_clock_infra.F90 b/config_src/infra/FMS2/MOM_cpu_clock_infra.F90 new file mode 100644 index 0000000000..47d7bbedaa --- /dev/null +++ b/config_src/infra/FMS2/MOM_cpu_clock_infra.F90 @@ -0,0 +1,93 @@ +!> Wraps the MPP cpu clock functions +!! +!! The functions and constants should be accessed via mom_cpu_clock +module MOM_cpu_clock_infra + +! This file is part of MOM6. See LICENSE.md for the license. + +! These interfaces and constants from MPP/FMS will not be directly exposed outside of this module +use fms_mod, only : clock_flag_default +use mpp_mod, only : mpp_clock_begin +use mpp_mod, only : mpp_clock_end, mpp_clock_id +use mpp_mod, only : MPP_CLOCK_COMPONENT => CLOCK_COMPONENT +use mpp_mod, only : MPP_CLOCK_SUBCOMPONENT => CLOCK_SUBCOMPONENT +use mpp_mod, only : MPP_CLOCK_MODULE_DRIVER => CLOCK_MODULE_DRIVER +use mpp_mod, only : MPP_CLOCK_MODULE => CLOCK_MODULE +use mpp_mod, only : MPP_CLOCK_ROUTINE => CLOCK_ROUTINE +use mpp_mod, only : MPP_CLOCK_LOOP => CLOCK_LOOP +use mpp_mod, only : MPP_CLOCK_INFRA => CLOCK_INFRA + +implicit none ; private + +! Public entities +public :: cpu_clock_id, cpu_clock_begin, cpu_clock_end +public :: CLOCK_COMPONENT, CLOCK_SUBCOMPONENT, CLOCK_MODULE_DRIVER, CLOCK_MODULE +public :: CLOCK_ROUTINE, CLOCK_LOOP, CLOCK_INFRA + +!> A granularity value to passed to cpu_clock_id() to indicate the clock is for a +!! component, e.g. the entire MOM6 model +integer, parameter :: CLOCK_COMPONENT = MPP_CLOCK_COMPONENT + +!> A granularity value to passed to cpu_clock_id() to indicate the clock is for a +!! sub-component, e.g. dynamics or thermodynamics +integer, parameter :: CLOCK_SUBCOMPONENT = MPP_CLOCK_SUBCOMPONENT + +!> A granularity value to passed to cpu_clock_id() to indicate the clock is for a +!! module driver, e.g. a routine that calls multiple other routines +integer, parameter :: CLOCK_MODULE_DRIVER = MPP_CLOCK_MODULE_DRIVER + +!> A granularity value to passed to cpu_clock_id() to indicate the clock is for a +!! module, e.g. the main entry routine for a module +integer, parameter :: CLOCK_MODULE = MPP_CLOCK_MODULE + +!> A granularity value to passed to cpu_clock_id() to indicate the clock is for a +!! subroutine or function +integer, parameter :: CLOCK_ROUTINE = MPP_CLOCK_ROUTINE + +!> A granularity value to passed to cpu_clock_id() to indicate the clock is for a +!! section with in a routine, e.g. around a loop +integer, parameter :: CLOCK_LOOP = MPP_CLOCK_LOOP + +!> A granularity value to passed to cpu_clock_id() to indicate the clock is for an +!! infrastructure operation, e.g. a halo update +integer, parameter :: CLOCK_INFRA = MPP_CLOCK_INFRA + +contains + +!> Turns on clock with handle "id" +subroutine cpu_clock_begin(id) + integer, intent(in) :: id !< Handle for clock + + call mpp_clock_begin(id) + +end subroutine cpu_clock_begin + +!> Turns off clock with handle "id" +subroutine cpu_clock_end(id) + integer, intent(in) :: id !< Handle for clock + + call mpp_clock_end(id) + +end subroutine cpu_clock_end + +!> Returns the integer handle for a named CPU clock. +integer function cpu_clock_id( name, synchro_flag, grain ) + character(len=*), intent(in) :: name !< The unique name of the CPU clock + integer, optional, intent(in) :: synchro_flag !< An integer flag that controls whether the PEs + !! are synchronized before the cpu clocks start counting. + !! Synchronization occurs before the start of a clock if this + !! is odd, while additional (expensive) statistics can set + !! for other values. If absent, the default is taken from the + !! settings for FMS. + integer, optional, intent(in) :: grain !< The timing granularity for this clock, usually set to + !! the values of CLOCK_COMPONENT, CLOCK_ROUTINE, CLOCK_LOOP, etc. + + if (present(synchro_flag)) then + cpu_clock_id = mpp_clock_id(name, flags=synchro_flag, grain=grain) + else + cpu_clock_id = mpp_clock_id(name, flags=clock_flag_default, grain=grain) + endif + +end function cpu_clock_id + +end module MOM_cpu_clock_infra diff --git a/config_src/infra/FMS2/MOM_data_override_infra.F90 b/config_src/infra/FMS2/MOM_data_override_infra.F90 new file mode 100644 index 0000000000..1484f0c128 --- /dev/null +++ b/config_src/infra/FMS2/MOM_data_override_infra.F90 @@ -0,0 +1,105 @@ +!> These interfaces allow for ocean or sea-ice variables to be replaced with data. +module MOM_data_override_infra + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_domain_infra, only : MOM_domain_type, domain2d +use MOM_domain_infra, only : get_simple_array_i_ind, get_simple_array_j_ind +use MOM_time_manager, only : time_type +use data_override_mod, only : data_override_init +use data_override_mod, only : data_override +use data_override_mod, only : data_override_unset_domains + +implicit none ; private + +public :: impose_data_init, impose_data, impose_data_unset_domains + +!> Potentially override the values of a field in the model with values from a dataset. +interface impose_data + module procedure data_override_MD, data_override_2d +end interface + +contains + +!> Initialize the data override capability and set the domains for the ocean and ice components. +!> There should be a call to impose_data_init before impose_data is called. +subroutine impose_data_init(MOM_domain_in, Ocean_domain_in, Ice_domain_in) + type (MOM_domain_type), intent(in), optional :: MOM_domain_in + type (domain2d), intent(in), optional :: Ocean_domain_in + type (domain2d), intent(in), optional :: Ice_domain_in + + if (present(MOM_domain_in)) then + call data_override_init(Ocean_domain_in=MOM_domain_in%mpp_domain, Ice_domain_in=Ice_domain_in) + else + call data_override_init(Ocean_domain_in=Ocean_domain_in, Ice_domain_in=Ice_domain_in) + endif +end subroutine impose_data_init + + +!> Potentially override a 2-d field on a MOM6 domain with values from a dataset. +subroutine data_override_MD(domain, fieldname, data_2D, time, scale, override, is_ice) + type(MOM_domain_type), intent(in) :: domain !< MOM domain from which to extract information + character(len=*), intent(in) :: fieldname !< Name of the field to override + real, dimension(:,:), intent(inout) :: data_2D !< Data that may be modified by this call. + type(time_type), intent(in) :: time !< The model time, and the time for the data + real, optional, intent(in) :: scale !< A scaling factor that an overridden field is + !! multiplied by before it is returned. However, + !! if there is no override, there is no rescaling. + logical, optional, intent(out) :: override !< True if the field has been overridden successfully + logical, optional, intent(in) :: is_ice !< If present and true, use the ice domain. + + logical :: overridden, is_ocean + integer :: i, j, is, ie, js, je + + overridden = .false. + is_ocean = .true. ; if (present(is_ice)) is_ocean = .not.is_ice + if (is_ocean) then + call data_override('OCN', fieldname, data_2D, time, override=overridden) + else + call data_override('ICE', fieldname, data_2D, time, override=overridden) + endif + + if (overridden .and. present(scale)) then ; if (scale /= 1.0) then + ! Rescale data in the computational domain if the data override has occurred. + call get_simple_array_i_ind(domain, size(data_2D,1), is, ie) + call get_simple_array_j_ind(domain, size(data_2D,2), js, je) + do j=js,je ; do i=is,ie + data_2D(i,j) = scale*data_2D(i,j) + enddo ; enddo + endif ; endif + + if (present(override)) override = overridden + +end subroutine data_override_MD + + +!> Potentially override a 2-d field with values from a dataset. +subroutine data_override_2d(gridname, fieldname, data_2D, time, override) + character(len=3), intent(in) :: gridname !< String identifying the model component, in MOM6 + !! and SIS this may be either 'OCN' or 'ICE' + character(len=*), intent(in) :: fieldname !< Name of the field to override + real, dimension(:,:), intent(inout) :: data_2D !< Data that may be modified by this call + type(time_type), intent(in) :: time !< The model time, and the time for the data + logical, optional, intent(out) :: override !< True if the field has been overridden successfully + + call data_override(gridname, fieldname, data_2D, time, override) + +end subroutine data_override_2d + +!> Unset domains that had previously been set for use by data_override. +subroutine impose_data_unset_domains(unset_Ocean, unset_Ice, must_be_set) + logical, intent(in), optional :: unset_Ocean !< If present and true, unset the ocean domain for overrides + logical, intent(in), optional :: unset_Ice !< If present and true, unset the sea-ice domain for overrides + logical, intent(in), optional :: must_be_set !< If present and true, it is a fatal error to unset + !! a domain that is not set. + + call data_override_unset_domains(unset_Ocean=unset_Ocean, unset_Ice=unset_Ice, & + must_be_set=must_be_set) +end subroutine impose_data_unset_domains + +end module MOM_data_override_infra + +!> \namespace MOM_data_override_infra +!! +!! The routines here wrap routines from the FMS module data_override_mod, which potentially replace +!! model values with values read from a data file. diff --git a/config_src/infra/FMS2/MOM_diag_manager_infra.F90 b/config_src/infra/FMS2/MOM_diag_manager_infra.F90 new file mode 100644 index 0000000000..18c80cf24c --- /dev/null +++ b/config_src/infra/FMS2/MOM_diag_manager_infra.F90 @@ -0,0 +1,423 @@ +!> A wrapper for the FMS diag_manager routines. This module should be the +!! only MOM6 module which imports the FMS shared infrastructure for +!! diagnostics. Pass through interfaces are being documented +!! here and renamed in order to clearly identify these APIs as being +!! consistent with the FMS infrastructure (Any future updates to +!! those APIs would be applied here). +module MOM_diag_manager_infra + +! This file is part of MOM6. See LICENSE.md for the license. + +use diag_axis_mod, only : fms_axis_init=>diag_axis_init +use diag_axis_mod, only : fms_get_diag_axis_name => get_diag_axis_name +use diag_axis_mod, only : EAST, NORTH +use diag_data_mod, only : null_axis_id +use diag_manager_mod, only : fms_diag_manager_init => diag_manager_init +use diag_manager_mod, only : fms_diag_manager_end => diag_manager_end +use diag_manager_mod, only : send_data_fms => send_data +use diag_manager_mod, only : fms_diag_field_add_attribute => diag_field_add_attribute +use diag_manager_mod, only : DIAG_FIELD_NOT_FOUND +use diag_manager_mod, only : register_diag_field_fms => register_diag_field +use diag_manager_mod, only : register_static_field_fms => register_static_field +use diag_manager_mod, only : get_diag_field_id_fms => get_diag_field_id +use MOM_time_manager, only : time_type +use MOM_domain_infra, only : MOM_domain_type +use MOM_error_infra, only : MOM_error => MOM_err, FATAL, WARNING + +implicit none ; private + +!> transmit data for diagnostic output +interface register_diag_field_infra + module procedure register_diag_field_infra_scalar + module procedure register_diag_field_infra_array +end interface register_diag_field_infra + +!> transmit data for diagnostic output +interface send_data_infra + module procedure send_data_infra_0d, send_data_infra_1d + module procedure send_data_infra_2d, send_data_infra_3d +#ifdef OVERLOAD_R8 + module procedure send_data_infra_2d_r8, send_data_infra_3d_r8 +#endif +end interface send_data_infra + +!> Add an attribute to a diagnostic field +interface MOM_diag_field_add_attribute + module procedure MOM_diag_field_add_attribute_scalar_r + module procedure MOM_diag_field_add_attribute_scalar_i + module procedure MOM_diag_field_add_attribute_scalar_c + module procedure MOM_diag_field_add_attribute_r1d + module procedure MOM_diag_field_add_attribute_i1d +end interface MOM_diag_field_add_attribute + + +! Public interfaces +public MOM_diag_axis_init +public get_MOM_diag_axis_name +public MOM_diag_manager_init +public MOM_diag_manager_end +public send_data_infra +public MOM_diag_field_add_attribute +public register_diag_field_infra +public register_static_field_infra +public get_MOM_diag_field_id +! Public data +public null_axis_id +public DIAG_FIELD_NOT_FOUND +public EAST, NORTH + + +contains + +!> Initialize a diagnostic axis +integer function MOM_diag_axis_init(name, data, units, cart_name, long_name, MOM_domain, position, & + & direction, edges, set_name, coarsen, null_axis) + character(len=*), intent(in) :: name !< The name of this axis + real, dimension(:), intent(in) :: data !< The array of coordinate values + character(len=*), intent(in) :: units !< The units for the axis data + character(len=*), intent(in) :: cart_name !< Cartesian axis ("X", "Y", "Z", "T", or "N" for none) + character(len=*), & + optional, intent(in) :: long_name !< The long name of this axis + type(MOM_domain_type), & + optional, intent(in) :: MOM_Domain !< A MOM_Domain that describes the decomposition + integer, optional, intent(in) :: position !< This indicates the relative position of this + !! axis. The default is CENTER, but EAST and NORTH + !! are common options. + integer, optional, intent(in) :: direction !< This indicates the direction along which this + !! axis increases: 1 for upward, -1 for downward, or + !! 0 for non-vertical axes (the default) + integer, optional, intent(in) :: edges !< The axis_id of the complementary axis that + !! describes the edges of this axis + character(len=*), & + optional, intent(in) :: set_name !< A name to use for this set of axes. + integer, optional, intent(in) :: coarsen !< An optional degree of coarsening for the grid, 1 + !! by default. + logical, optional, intent(in) :: null_axis !< If present and true, return the special null axis + !! id for use with scalars. + + integer :: coarsening ! The degree of grid coarsening + + if (present(null_axis)) then ; if (null_axis) then + ! Return the special null axis id for scalars + MOM_diag_axis_init = null_axis_id + return + endif ; endif + + if (present(MOM_domain)) then + coarsening = 1 ; if (present(coarsen)) coarsening = coarsen + if (coarsening == 1) then + MOM_diag_axis_init = fms_axis_init(name, data, units, cart_name, long_name=long_name, & + direction=direction, set_name=set_name, edges=edges, & + domain2=MOM_domain%mpp_domain, domain_position=position) + elseif (coarsening == 2) then + MOM_diag_axis_init = fms_axis_init(name, data, units, cart_name, long_name=long_name, & + direction=direction, set_name=set_name, edges=edges, & + domain2=MOM_domain%mpp_domain_d2, domain_position=position) + else + call MOM_error(FATAL, "diag_axis_init called with an invalid value of coarsen.") + endif + else + if (present(coarsen)) then ; if (coarsen /= 1) then + call MOM_error(FATAL, "diag_axis_init does not support grid coarsening without a MOM_domain.") + endif ; endif + MOM_diag_axis_init = fms_axis_init(name, data, units, cart_name, long_name=long_name, & + direction=direction, set_name=set_name, edges=edges) + endif + +end function MOM_diag_axis_init + +!> Returns the short name of the axis +subroutine get_MOM_diag_axis_name(id, name) + integer, intent(in) :: id !< The axis numeric id + character(len=*), intent(out) :: name !< The short name of the axis + + call fms_get_diag_axis_name(id, name) + +end subroutine get_MOM_diag_axis_name + +!> Return a unique numeric ID field a module/field name combination. +integer function get_MOM_diag_field_id(module_name, field_name) + character(len=*), intent(in) :: module_name !< A module name string to query. + character(len=*), intent(in) :: field_name !< A field name string to query. + + + get_MOM_diag_field_id = -1 + get_MOM_diag_field_id = get_diag_field_id_fms(module_name, field_name) + +end function get_MOM_diag_field_id + +!> Initializes the diagnostic manager +subroutine MOM_diag_manager_init(diag_model_subset, time_init, err_msg) + integer, optional, intent(in) :: diag_model_subset !< An optional diagnostic subset + integer, dimension(6), optional, intent(in) :: time_init !< An optional reference time for diagnostics + !! The default uses the value contained in the + !! diag_table. Format is Y-M-D-H-M-S + character(len=*), optional, intent(out) :: err_msg !< Error message. + call FMS_diag_manager_init(diag_model_subset, time_init, err_msg) + +end subroutine MOM_diag_manager_init + +!> Close the diagnostic manager +subroutine MOM_diag_manager_end(time) + type(time_type), intent(in) :: time !< Model time at call to close. + + call FMS_diag_manager_end(time) + +end subroutine MOM_diag_manager_end + +!> Register a MOM diagnostic field for scalars +integer function register_diag_field_infra_scalar(module_name, field_name, init_time, & + long_name, units, missing_value, range, standard_name, do_not_log, & + err_msg, area, volume) + character(len=*), intent(in) :: module_name !< The name of the associated module + character(len=*), intent(in) :: field_name !< The name of the field + type(time_type), optional, intent(in) :: init_time !< The registration time + character(len=*), optional, intent(in) :: long_name !< A long name for the field + character(len=*), optional, intent(in) :: units !< Field units + character(len=*), optional, intent(in) :: standard_name !< A standard name for the field + real, optional, intent(in) :: missing_value !< Missing value attribute + real, dimension(2), optional, intent(in) :: range !< A valid range of the field + logical, optional, intent(in) :: do_not_log !< if TRUE, field information is not logged + character(len=*), optional, intent(out):: err_msg !< An error message to return + integer, optional, intent(in) :: area !< Diagnostic ID of the field containing the area attribute + integer, optional, intent(in) :: volume !< Diagnostic ID of the field containing the volume attribute + + register_diag_field_infra_scalar = register_diag_field_fms(module_name, field_name, init_time, & + long_name, units, missing_value, range, standard_name, do_not_log, err_msg, area, volume) + +end function register_diag_field_infra_scalar + +!> Register a MOM diagnostic field for scalars +integer function register_diag_field_infra_array(module_name, field_name, axes, init_time, & + long_name, units, missing_value, range, mask_variant, standard_name, verbose, & + do_not_log, err_msg, interp_method, tile_count, area, volume) + character(len=*), intent(in) :: module_name !< The name of the associated module + character(len=*), intent(in) :: field_name !< The name of the field + integer, dimension(:), intent(in) :: axes !< Diagnostic IDs of axis attributes for the field + type(time_type), optional, intent(in) :: init_time !< The registration time + character(len=*), optional, intent(in) :: long_name !< A long name for the field + character(len=*), optional, intent(in) :: units !< Units of the field + real, optional, intent(in) :: missing_value !< Missing value attribute + real, dimension(2), optional, intent(in) :: range !< A valid range of the field + logical, optional, intent(in) :: mask_variant !< If true, the field mask is varying in time + character(len=*), optional, intent(in) :: standard_name !< A standard name for the field + logical, optional, intent(in) :: verbose !< If true, provide additional log information + logical, optional, intent(in) :: do_not_log !< if TRUE, field information is not logged + character(len=*), optional, intent(in) :: interp_method !< If 'none' indicates the field should + !! not be interpolated as a scalar + integer, optional, intent(in) :: tile_count !< The tile number for the current PE + character(len=*), optional, intent(out):: err_msg !< An error message to return + integer, optional, intent(in) :: area !< Diagnostic ID of the field containing the area attribute + integer, optional, intent(in) :: volume !< Diagnostic ID of the field containing the volume attribute + + register_diag_field_infra_array = register_diag_field_fms(module_name, field_name, axes, init_time, & + long_name, units, missing_value, range, mask_variant, standard_name, verbose, do_not_log, & + err_msg, interp_method, tile_count, area, volume) + +end function register_diag_field_infra_array + + +integer function register_static_field_infra(module_name, field_name, axes, long_name, units, & + missing_value, range, mask_variant, standard_name, do_not_log, interp_method, & + tile_count, area, volume) + character(len=*), intent(in) :: module_name !< The name of the associated module + character(len=*), intent(in) :: field_name !< The name of the field + integer, dimension(:), intent(in) :: axes !< Diagnostic IDs of axis attributes for the field + character(len=*), optional, intent(in) :: long_name !< A long name for the field + character(len=*), optional, intent(in) :: units !< Units of the field + real, optional, intent(in) :: missing_value !< Missing value attribute + real, dimension(2), optional, intent(in) :: range !< A valid range of the field + logical, optional, intent(in) :: mask_variant !< If true, the field mask is varying in time + character(len=*), optional, intent(in) :: standard_name !< A standard name for the field + logical, optional, intent(in) :: do_not_log !< if TRUE, field information is not logged + character(len=*), optional, intent(in) :: interp_method !< If 'none' indicates the field should + !! not be interpolated as a scalar + integer, optional, intent(in) :: tile_count !< The tile number for the current PE + integer, optional, intent(in) :: area !< Diagnostic ID of the field containing the area attribute + integer, optional, intent(in) :: volume !< Diagnostic ID of the field containing the volume attribute + + register_static_field_infra = register_static_field_fms(module_name, field_name, axes, long_name, units,& + & missing_value, range, mask_variant, standard_name, dynamic=.false.,do_not_log=do_not_log, & + interp_method=interp_method,tile_count=tile_count, area=area, volume=volume) +end function register_static_field_infra + +!> Returns true if the argument data are successfully passed to a diagnostic manager +!! with the indicated unique reference id, false otherwise. +logical function send_data_infra_0d(diag_field_id, field, time, err_msg) + integer, intent(in) :: diag_field_id !< The diagnostic manager identifier for this field + real, intent(in) :: field !< The value being recorded + TYPE(time_type), optional, intent(in) :: time !< The time for the current record + CHARACTER(len=*), optional, intent(out) :: err_msg !< An optional error message + + send_data_infra_0d = send_data_fms(diag_field_id, field, time, err_msg) +end function send_data_infra_0d + +!> Returns true if the argument data are successfully passed to a diagnostic manager +!! with the indicated unique reference id, false otherwise. +logical function send_data_infra_1d(diag_field_id, field, is_in, ie_in, time, mask, rmask, weight, err_msg) + integer, intent(in) :: diag_field_id !< The diagnostic manager identifier for this field + real, dimension(:), intent(in) :: field !< A 1-d array of values being recorded + integer, optional, intent(in) :: is_in !< The starting index for the data being recorded + integer, optional, intent(in) :: ie_in !< The end index for the data being recorded + type(time_type), optional, intent(in) :: time !< The time for the current record + logical, dimension(:), optional, intent(in) :: mask !< An optional rank 1 logical mask + real, dimension(:), optional, intent(in) :: rmask !< An optional rank 1 mask array + real, optional, intent(in) :: weight !< A scalar weight factor to apply to the current + !! record if there is averaging in time + character(len=*), optional, intent(out) :: err_msg !< A log indicating the status of the post upon + !! returning to the calling routine + + send_data_infra_1d = send_data_fms(diag_field_id, field, time, is_in, mask, rmask, ie_in, weight, err_msg) + +end function send_data_infra_1d + +!> Returns true if the argument data are successfully passed to a diagnostic manager +!! with the indicated unique reference id, false otherwise. +logical function send_data_infra_2d(diag_field_id, field, is_in, ie_in, js_in, je_in, & + time, mask, rmask, weight, err_msg) + integer, intent(in) :: diag_field_id !< The diagnostic manager identifier for this field + real, dimension(:,:), intent(in) :: field !< A 2-d array of values being recorded + integer, optional, intent(in) :: is_in !< The starting i-index for the data being recorded + integer, optional, intent(in) :: ie_in !< The end i-index for the data being recorded + integer, optional, intent(in) :: js_in !< The starting j-index for the data being recorded + integer, optional, intent(in) :: je_in !< The end j-index for the data being recorded + type(time_type), optional, intent(in) :: time !< The time for the current record + logical, dimension(:,:), optional, intent(in) :: mask !< An optional 2-d logical mask + real, dimension(:,:), optional, intent(in) :: rmask !< An optional 2-d mask array + real, optional, intent(in) :: weight !< A scalar weight factor to apply to the current + !! record if there is averaging in time + character(len=*), optional, intent(out) :: err_msg !< A log indicating the status of the post upon + !! returning to the calling routine + + send_data_infra_2d = send_data_fms(diag_field_id, field, time, is_in, js_in, mask, & + rmask, ie_in, je_in, weight, err_msg) + +end function send_data_infra_2d + +!> Returns true if the argument data are successfully passed to a diagnostic manager +!! with the indicated unique reference id, false otherwise. +logical function send_data_infra_3d(diag_field_id, field, is_in, ie_in, js_in, je_in, ks_in, ke_in, & + time, mask, rmask, weight, err_msg) + integer, intent(in) :: diag_field_id !< The diagnostic manager identifier for this field + real, dimension(:,:,:), intent(in) :: field !< A rank 1 array of floating point values being recorded + integer, optional, intent(in) :: is_in !< The starting i-index for the data being recorded + integer, optional, intent(in) :: ie_in !< The end i-index for the data being recorded + integer, optional, intent(in) :: js_in !< The starting j-index for the data being recorded + integer, optional, intent(in) :: je_in !< The end j-index for the data being recorded + integer, optional, intent(in) :: ks_in !< The starting k-index for the data being recorded + integer, optional, intent(in) :: ke_in !< The end k-index for the data being recorded + type(time_type), optional, intent(in) :: time !< The time for the current record + logical, dimension(:,:,:), optional, intent(in) :: mask !< An optional 3-d logical mask + real, dimension(:,:,:), optional, intent(in) :: rmask !< An optional 3-d mask array + real, optional, intent(in) :: weight !< A scalar weight factor to apply to the current + !! record if there is averaging in time + character(len=*), optional, intent(out) :: err_msg !< A log indicating the status of the post upon + !! returning to the calling routine + + send_data_infra_3d = send_data_fms(diag_field_id, field, time, is_in, js_in, ks_in, mask, & + rmask, ie_in, je_in, ke_in, weight, err_msg) + +end function send_data_infra_3d + + +#ifdef OVERLOAD_R8 +!> Returns true if the argument data are successfully passed to a diagnostic manager +!! with the indicated unique reference id, false otherwise. +logical function send_data_infra_2d_r8(diag_field_id, field, is_in, ie_in, js_in, je_in, & + time, mask, rmask, weight, err_msg) + integer, intent(in) :: diag_field_id !< The diagnostic manager identifier for this field + real(kind=8), dimension(:,:), intent(in) :: field !< A 2-d array of values being recorded + integer, optional, intent(in) :: is_in !< The starting i-index for the data being recorded + integer, optional, intent(in) :: ie_in !< The end i-index for the data being recorded + integer, optional, intent(in) :: js_in !< The starting j-index for the data being recorded + integer, optional, intent(in) :: je_in !< The end j-index for the data being recorded + type(time_type), optional, intent(in) :: time !< The time for the current record + logical, dimension(:,:), optional, intent(in) :: mask !< An optional 2-d logical mask + real, dimension(:,:), optional, intent(in) :: rmask !< An optional 2-d mask array + real, optional, intent(in) :: weight !< A scalar weight factor to apply to the current + !! record if there is averaging in time + character(len=*), optional, intent(out) :: err_msg !< A log indicating the status of the post upon + !! returning to the calling routine + + send_data_infra_2d_r8 = send_data_fms(diag_field_id, field, time, is_in, js_in, mask, & + rmask, ie_in, je_in, weight, err_msg) + +end function send_data_infra_2d_r8 + +!> Returns true if the argument data are successfully passed to a diagnostic manager +!! with the indicated unique reference id, false otherwise. +logical function send_data_infra_3d_r8(diag_field_id, field, is_in, ie_in, js_in, je_in, ks_in, ke_in, & + time, mask, rmask, weight, err_msg) + integer, intent(in) :: diag_field_id !< The diagnostic manager identifier for this field + real(kind=8), dimension(:,:,:), intent(in) :: field !< A rank 1 array of floating point values being recorded + integer, optional, intent(in) :: is_in !< The starting i-index for the data being recorded + integer, optional, intent(in) :: ie_in !< The end i-index for the data being recorded + integer, optional, intent(in) :: js_in !< The starting j-index for the data being recorded + integer, optional, intent(in) :: je_in !< The end j-index for the data being recorded + integer, optional, intent(in) :: ks_in !< The starting k-index for the data being recorded + integer, optional, intent(in) :: ke_in !< The end k-index for the data being recorded + type(time_type), optional, intent(in) :: time !< The time for the current record + logical, dimension(:,:,:), optional, intent(in) :: mask !< An optional 3-d logical mask + real, dimension(:,:,:), optional, intent(in) :: rmask !< An optional 3-d mask array + real, optional, intent(in) :: weight !< A scalar weight factor to apply to the current + !! record if there is averaging in time + character(len=*), optional, intent(out) :: err_msg !< A log indicating the status of the post upon + !! returning to the calling routine + + send_data_infra_3d_r8 = send_data_fms(diag_field_id, field, time, is_in, js_in, ks_in, mask, rmask, & + ie_in, je_in, ke_in, weight, err_msg) + +end function send_data_infra_3d_r8 +#endif + +!> Add a real scalar attribute to a diagnostic field +subroutine MOM_diag_field_add_attribute_scalar_r(diag_field_id, att_name, att_value) + integer, intent(in) :: diag_field_id !< The diagnostic manager identifier for this field + character(len=*), intent(in) :: att_name !< The name of the attribute + real, intent(in) :: att_value !< A real scalar value + + call FMS_diag_field_add_attribute(diag_field_id, att_name, att_value) + +end subroutine MOM_diag_field_add_attribute_scalar_r + +!> Add an integer attribute to a diagnostic field +subroutine MOM_diag_field_add_attribute_scalar_i(diag_field_id, att_name, att_value) + integer, intent(in) :: diag_field_id !< The diagnostic manager identifier for this field + character(len=*), intent(in) :: att_name !< The name of the attribute + integer, intent(in) :: att_value !< An integer scalar value + + call FMS_diag_field_add_attribute(diag_field_id, att_name, att_value) + +end subroutine MOM_diag_field_add_attribute_scalar_i + +!> Add a character string attribute to a diagnostic field +subroutine MOM_diag_field_add_attribute_scalar_c(diag_field_id, att_name, att_value) + integer, intent(in) :: diag_field_id !< The diagnostic manager identifier for this field + character(len=*), intent(in) :: att_name !< The name of the attribute + character(len=*), intent(in) :: att_value !< A character string value + + call FMS_diag_field_add_attribute(diag_field_id, att_name, att_value) + +end subroutine MOM_diag_field_add_attribute_scalar_c + +!> Add a real list of attributes attribute to a diagnostic field +subroutine MOM_diag_field_add_attribute_r1d(diag_field_id, att_name, att_value) + integer, intent(in) :: diag_field_id !< The diagnostic manager identifier for this field + character(len=*), intent(in) :: att_name !< The name of the attribute + real, dimension(:), intent(in) :: att_value !< An array of real values + + call FMS_diag_field_add_attribute(diag_field_id, att_name, att_value) + +end subroutine MOM_diag_field_add_attribute_r1d + +!> Add a integer list of attributes attribute to a diagnostic field +subroutine MOM_diag_field_add_attribute_i1d(diag_field_id, att_name, att_value) + integer, intent(in) :: diag_field_id !< The diagnostic manager identifier for this field + character(len=*), intent(in) :: att_name !< The name of the attribute + integer, dimension(:), intent(in) :: att_value !< An array of integer values + + call FMS_diag_field_add_attribute(diag_field_id, att_name, att_value) + +end subroutine MOM_diag_field_add_attribute_i1d + +end module MOM_diag_manager_infra diff --git a/config_src/infra/FMS2/MOM_domain_infra.F90 b/config_src/infra/FMS2/MOM_domain_infra.F90 new file mode 100644 index 0000000000..7c3424ca15 --- /dev/null +++ b/config_src/infra/FMS2/MOM_domain_infra.F90 @@ -0,0 +1,1941 @@ +!> Describes the decomposed MOM domain and has routines for communications across PEs +module MOM_domain_infra + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_coms_infra, only : PE_here, root_PE, num_PEs +use MOM_cpu_clock_infra, only : cpu_clock_begin, cpu_clock_end +use MOM_error_infra, only : MOM_error=>MOM_err, NOTE, WARNING, FATAL + +use mpp_domains_mod, only : domain2D, domain1D +use mpp_domains_mod, only : mpp_define_io_domain, mpp_define_domains, mpp_deallocate_domain +use mpp_domains_mod, only : mpp_get_domain_components, mpp_get_domain_extents +use mpp_domains_mod, only : mpp_get_compute_domain, mpp_get_data_domain, mpp_get_global_domain +use mpp_domains_mod, only : mpp_get_boundary, mpp_update_domains +use mpp_domains_mod, only : mpp_start_update_domains, mpp_complete_update_domains +use mpp_domains_mod, only : mpp_create_group_update, mpp_do_group_update +use mpp_domains_mod, only : mpp_reset_group_update_field, mpp_group_update_initialized +use mpp_domains_mod, only : mpp_start_group_update, mpp_complete_group_update +use mpp_domains_mod, only : mpp_compute_block_extent +use mpp_domains_mod, only : mpp_broadcast_domain, mpp_redistribute, mpp_global_field +use mpp_domains_mod, only : AGRID, BGRID_NE, CGRID_NE, SCALAR_PAIR, BITWISE_EXACT_SUM +use mpp_domains_mod, only : CYCLIC_GLOBAL_DOMAIN, FOLD_NORTH_EDGE +use mpp_domains_mod, only : To_East => WUPDATE, To_West => EUPDATE, Omit_Corners => EDGEUPDATE +use mpp_domains_mod, only : To_North => SUPDATE, To_South => NUPDATE +use mpp_domains_mod, only : CENTER, CORNER, NORTH_FACE => NORTH, EAST_FACE => EAST +use fms_io_mod, only : file_exist, parse_mask_table +use fms_affinity_mod, only : fms_affinity_init, fms_affinity_set, fms_affinity_get + +! This subroutine is not in MOM6/src but may be required by legacy drivers +use mpp_domains_mod, only : global_field_sum => mpp_global_sum + +! The `group_pass_type` fields are never accessed, so we keep it as an FMS type +use mpp_domains_mod, only : group_pass_type => mpp_group_update_type + +implicit none ; private + +! These types are inherited from mpp, but are treated as opaque here. +public :: domain2D, domain1D, group_pass_type +! These interfaces are actually implemented or have explicit interfaces in this file. +public :: create_MOM_domain, clone_MOM_domain, get_domain_components, get_domain_extent +public :: deallocate_MOM_domain, get_global_shape, compute_block_extent +public :: pass_var, pass_vector, fill_symmetric_edges, rescale_comp_data +public :: pass_var_start, pass_var_complete, pass_vector_start, pass_vector_complete +public :: create_group_pass, do_group_pass, start_group_pass, complete_group_pass +public :: redistribute_array, broadcast_domain, global_field +public :: get_simple_array_i_ind, get_simple_array_j_ind +public :: MOM_thread_affinity_set, set_MOM_thread_affinity +! These are encoding constant parmeters. +public :: To_East, To_West, To_North, To_South, To_All, Omit_Corners +public :: AGRID, BGRID_NE, CGRID_NE, SCALAR_PAIR +public :: CORNER, CENTER, NORTH_FACE, EAST_FACE +! These are no longer used by MOM6 because the reproducing sum works so well, but they are +! still referenced by some of the non-GFDL couplers. +public :: global_field_sum, BITWISE_EXACT_SUM + +!> Do a halo update on an array +interface pass_var + module procedure pass_var_3d, pass_var_2d +end interface pass_var + +!> Do a halo update on a pair of arrays representing the two components of a vector +interface pass_vector + module procedure pass_vector_3d, pass_vector_2d +end interface pass_vector + +!> Initiate a non-blocking halo update on an array +interface pass_var_start + module procedure pass_var_start_3d, pass_var_start_2d +end interface pass_var_start + +!> Complete a non-blocking halo update on an array +interface pass_var_complete + module procedure pass_var_complete_3d, pass_var_complete_2d +end interface pass_var_complete + +!> Initiate a halo update on a pair of arrays representing the two components of a vector +interface pass_vector_start + module procedure pass_vector_start_3d, pass_vector_start_2d +end interface pass_vector_start + +!> Complete a halo update on a pair of arrays representing the two components of a vector +interface pass_vector_complete + module procedure pass_vector_complete_3d, pass_vector_complete_2d +end interface pass_vector_complete + +!> Set up a group of halo updates +interface create_group_pass + module procedure create_var_group_pass_2d + module procedure create_var_group_pass_3d + module procedure create_vector_group_pass_2d + module procedure create_vector_group_pass_3d +end interface create_group_pass + +!> Do a set of halo updates that fill in the values at the duplicated edges +!! of a staggered symmetric memory domain +interface fill_symmetric_edges + module procedure fill_vector_symmetric_edges_2d !, fill_vector_symmetric_edges_3d +! module procedure fill_scalar_symmetric_edges_2d, fill_scalar_symmetric_edges_3d +end interface fill_symmetric_edges + +!> Rescale the values of an array in its computational domain by a constant factor +interface rescale_comp_data + module procedure rescale_comp_data_4d, rescale_comp_data_3d, rescale_comp_data_2d +end interface rescale_comp_data + +!> Pass an array from one MOM domain to another +interface redistribute_array + module procedure redistribute_array_3d, redistribute_array_2d +end interface redistribute_array + +!> Copy one MOM_domain_type into another +interface clone_MOM_domain + module procedure clone_MD_to_MD, clone_MD_to_d2D +end interface clone_MOM_domain + +!> Extract the 1-d domain components from a MOM_domain or domain2d +interface get_domain_components + module procedure get_domain_components_MD, get_domain_components_d2D +end interface get_domain_components + +!> Returns the index ranges that have been stored in a MOM_domain_type +interface get_domain_extent + module procedure get_domain_extent_MD, get_domain_extent_d2D +end interface get_domain_extent + + +!> The MOM_domain_type contains information about the domain decomposition. +type, public :: MOM_domain_type + character(len=64) :: name !< The name of this domain + type(domain2D), pointer :: mpp_domain => NULL() !< The FMS domain with halos + !! on this processor, centered at h points. + type(domain2D), pointer :: mpp_domain_d2 => NULL() !< A coarse FMS domain with halos + !! on this processor, centered at h points. + integer :: niglobal !< The total horizontal i-domain size. + integer :: njglobal !< The total horizontal j-domain size. + integer :: nihalo !< The i-halo size in memory. + integer :: njhalo !< The j-halo size in memory. + logical :: symmetric !< True if symmetric memory is used with this domain. + logical :: nonblocking_updates !< If true, non-blocking halo updates are + !! allowed. The default is .false. (for now). + logical :: thin_halo_updates !< If true, optional arguments may be used to + !! specify the width of the halos that are + !! updated with each call. + integer :: layout(2) !< This domain's processor layout. This is + !! saved to enable the construction of related + !! new domains with different resolutions or + !! other properties. + integer :: io_layout(2) !< The IO-layout used with this domain. + integer :: X_FLAGS !< Flag that specifies the properties of the + !! domain in the i-direction in a define_domain call. + integer :: Y_FLAGS !< Flag that specifies the properties of the + !! domain in the j-direction in a define_domain call. + logical, pointer :: maskmap(:,:) => NULL() !< A pointer to an array indicating + !! which logical processors are actually used for + !! the ocean code. The other logical processors + !! would be contain only land points and are not + !! assigned to actual processors. This need not be + !! assigned if all logical processors are used. +end type MOM_domain_type + +integer, parameter :: To_All = To_East + To_West + To_North + To_South !< A flag for passing in all directions + +contains + +!> pass_var_3d does a halo update for a three-dimensional array. +subroutine pass_var_3d(array, MOM_dom, sideflag, complete, position, halo, & + clock) + real, dimension(:,:,:), intent(inout) :: array !< The array which is having its halos points + !! exchanged. + type(MOM_domain_type), intent(inout) :: MOM_dom !< The MOM_domain_type containing the mpp_domain + !! needed to determine where data should be + !! sent. + integer, optional, intent(in) :: sideflag !< An optional integer indicating which + !! directions the data should be sent. It is TO_ALL or the sum of any of TO_EAST, TO_WEST, + !! TO_NORTH, and TO_SOUTH. For example, TO_EAST sends the data to the processor to the east, + !! sothe halos on the western side are filled. TO_ALL is the default if sideflag is omitted. + logical, optional, intent(in) :: complete !< An optional argument indicating whether the + !! halo updates should be completed before + !! progress resumes. Omitting complete is the + !! same as setting complete to .true. + integer, optional, intent(in) :: position !< An optional argument indicating the position. + !! This is CENTER by default and is often CORNER, + !! but could also be EAST_FACE or NORTH_FACE. + integer, optional, intent(in) :: halo !< The size of the halo to update - the full + !! halo by default. + integer, optional, intent(in) :: clock !< The handle for a cpu time clock that should be + !! started then stopped to time this routine. + + integer :: dirflag + logical :: block_til_complete + + if (present(clock)) then ; if (clock>0) call cpu_clock_begin(clock) ; endif + + dirflag = To_All ! 60 + if (present(sideflag)) then ; if (sideflag > 0) dirflag = sideflag ; endif + block_til_complete = .true. + if (present(complete)) block_til_complete = complete + + if (present(halo) .and. MOM_dom%thin_halo_updates) then + call mpp_update_domains(array, MOM_dom%mpp_domain, flags=dirflag, & + complete=block_til_complete, position=position, & + whalo=halo, ehalo=halo, shalo=halo, nhalo=halo) + else + call mpp_update_domains(array, MOM_dom%mpp_domain, flags=dirflag, & + complete=block_til_complete, position=position) + endif + + if (present(clock)) then ; if (clock>0) call cpu_clock_end(clock) ; endif + +end subroutine pass_var_3d + +!> pass_var_2d does a halo update for a two-dimensional array. +subroutine pass_var_2d(array, MOM_dom, sideflag, complete, position, halo, inner_halo, clock) + real, dimension(:,:), intent(inout) :: array !< The array which is having its halos points + !! exchanged. + type(MOM_domain_type), intent(inout) :: MOM_dom !< The MOM_domain_type containing the mpp_domain + !! needed to determine where data should be sent. + integer, optional, intent(in) :: sideflag !< An optional integer indicating which + !! directions the data should be sent. It is TO_ALL or the sum of any of TO_EAST, TO_WEST, + !! TO_NORTH, and TO_SOUTH. For example, TO_EAST sends the data to the processor to the east, + !! so the halos on the western side are filled. TO_ALL is the default if sideflag is omitted. + logical, optional, intent(in) :: complete !< An optional argument indicating whether the + !! halo updates should be completed before + !! progress resumes. Omitting complete is the + !! same as setting complete to .true. + integer, optional, intent(in) :: position !< An optional argument indicating the position. + !! This is CENTER by default and is often CORNER, + !! but could also be EAST_FACE or NORTH_FACE. + integer, optional, intent(in) :: halo !< The size of the halo to update - the full halo + !! by default. + integer, optional, intent(in) :: inner_halo !< The size of an inner halo to avoid updating, + !! or 0 to avoid updating symmetric memory + !! computational domain points. Setting this >=0 + !! also enforces that complete=.true. + integer, optional, intent(in) :: clock !< The handle for a cpu time clock that should be + !! started then stopped to time this routine. + + ! Local variables + real, allocatable, dimension(:,:) :: tmp + integer :: pos, i_halo, j_halo + integer :: isc, iec, jsc, jec, isd, ied, jsd, jed, IscB, IecB, JscB, JecB + integer :: inner, i, j, isfw, iefw, isfe, iefe, jsfs, jefs, jsfn, jefn + integer :: dirflag + logical :: block_til_complete + + if (present(clock)) then ; if (clock>0) call cpu_clock_begin(clock) ; endif + + dirflag = To_All ! 60 + if (present(sideflag)) then ; if (sideflag > 0) dirflag = sideflag ; endif + block_til_complete = .true. ; if (present(complete)) block_til_complete = complete + pos = CENTER ; if (present(position)) pos = position + + if (present(inner_halo)) then ; if (inner_halo >= 0) then + ! Store the original values. + allocate(tmp(size(array,1), size(array,2))) + tmp(:,:) = array(:,:) + block_til_complete = .true. + endif ; endif + + if (present(halo) .and. MOM_dom%thin_halo_updates) then + call mpp_update_domains(array, MOM_dom%mpp_domain, flags=dirflag, & + complete=block_til_complete, position=position, & + whalo=halo, ehalo=halo, shalo=halo, nhalo=halo) + else + call mpp_update_domains(array, MOM_dom%mpp_domain, flags=dirflag, & + complete=block_til_complete, position=position) + endif + + if (present(inner_halo)) then ; if (inner_halo >= 0) then + call mpp_get_compute_domain(MOM_dom%mpp_domain, isc, iec, jsc, jec) + call mpp_get_data_domain(MOM_dom%mpp_domain, isd, ied, jsd, jed) + ! Convert to local indices for arrays starting at 1. + isc = isc - (isd-1) ; iec = iec - (isd-1) ; ied = ied - (isd-1) ; isd = 1 + jsc = jsc - (jsd-1) ; jec = jec - (jsd-1) ; jed = jed - (jsd-1) ; jsd = 1 + i_halo = min(inner_halo, isc-1) ; j_halo = min(inner_halo, jsc-1) + + ! Figure out the array index extents of the eastern, western, northern and southern regions to copy. + if (pos == CENTER) then + if (size(array,1) == ied) then + isfw = isc - i_halo ; iefw = isc ; isfe = iec ; iefe = iec + i_halo + else ; call MOM_error(FATAL, "pass_var_2d: wrong i-size for CENTER array.") ; endif + if (size(array,2) == jed) then + isfw = isc - i_halo ; iefw = isc ; isfe = iec ; iefe = iec + i_halo + else ; call MOM_error(FATAL, "pass_var_2d: wrong j-size for CENTER array.") ; endif + elseif (pos == CORNER) then + if (size(array,1) == ied) then + isfw = max(isc - (i_halo+1), 1) ; iefw = isc ; isfe = iec ; iefe = iec + i_halo + elseif (size(array,1) == ied+1) then + isfw = isc - i_halo ; iefw = isc+1 ; isfe = iec+1 ; iefe = min(iec + 1 + i_halo, ied+1) + else ; call MOM_error(FATAL, "pass_var_2d: wrong i-size for CORNER array.") ; endif + if (size(array,2) == jed) then + jsfs = max(jsc - (j_halo+1), 1) ; jefs = jsc ; jsfn = jec ; jefn = jec + j_halo + elseif (size(array,2) == jed+1) then + jsfs = jsc - j_halo ; jefs = jsc+1 ; jsfn = jec+1 ; jefn = min(jec + 1 + j_halo, jed+1) + else ; call MOM_error(FATAL, "pass_var_2d: wrong j-size for CORNER array.") ; endif + elseif (pos == NORTH_FACE) then + if (size(array,1) == ied) then + isfw = isc - i_halo ; iefw = isc ; isfe = iec ; iefe = iec + i_halo + else ; call MOM_error(FATAL, "pass_var_2d: wrong i-size for NORTH_FACE array.") ; endif + if (size(array,2) == jed) then + jsfs = max(jsc - (j_halo+1), 1) ; jefs = jsc ; jsfn = jec ; jefn = jec + j_halo + elseif (size(array,2) == jed+1) then + jsfs = jsc - j_halo ; jefs = jsc+1 ; jsfn = jec+1 ; jefn = min(jec + 1 + j_halo, jed+1) + else ; call MOM_error(FATAL, "pass_var_2d: wrong j-size for NORTH_FACE array.") ; endif + elseif (pos == EAST_FACE) then + if (size(array,1) == ied) then + isfw = max(isc - (i_halo+1), 1) ; iefw = isc ; isfe = iec ; iefe = iec + i_halo + elseif (size(array,1) == ied+1) then + isfw = isc - i_halo ; iefw = isc+1 ; isfe = iec+1 ; iefe = min(iec + 1 + i_halo, ied+1) + else ; call MOM_error(FATAL, "pass_var_2d: wrong i-size for EAST_FACE array.") ; endif + if (size(array,2) == jed) then + isfw = isc - i_halo ; iefw = isc ; isfe = iec ; iefe = iec + i_halo + else ; call MOM_error(FATAL, "pass_var_2d: wrong j-size for EAST_FACE array.") ; endif + else + call MOM_error(FATAL, "pass_var_2d: Unrecognized position") + endif + + ! Copy back the stored inner halo points + do j=jsfs,jefn ; do i=isfw,iefw ; array(i,j) = tmp(i,j) ; enddo ; enddo + do j=jsfs,jefn ; do i=isfe,iefe ; array(i,j) = tmp(i,j) ; enddo ; enddo + do j=jsfs,jefs ; do i=isfw,iefe ; array(i,j) = tmp(i,j) ; enddo ; enddo + do j=jsfn,jefn ; do i=isfw,iefe ; array(i,j) = tmp(i,j) ; enddo ; enddo + + deallocate(tmp) + endif ; endif + + if (present(clock)) then ; if (clock>0) call cpu_clock_end(clock) ; endif + +end subroutine pass_var_2d + +!> pass_var_start_2d starts a halo update for a two-dimensional array. +function pass_var_start_2d(array, MOM_dom, sideflag, position, complete, halo, & + clock) + real, dimension(:,:), intent(inout) :: array !< The array which is having its halos points + !! exchanged. + type(MOM_domain_type), intent(inout) :: MOM_dom !< The MOM_domain_type containing the mpp_domain + !! needed to determine where data should be + !! sent. + integer, optional, intent(in) :: sideflag !< An optional integer indicating which + !! directions the data should be sent. It is TO_ALL or the sum of any of TO_EAST, TO_WEST, + !! TO_NORTH, and TO_SOUTH. For example, TO_EAST sends the data to the processor to the east, + !! so the halos on the western side are filled. TO_ALL is the default if sideflag is omitted. + integer, optional, intent(in) :: position !< An optional argument indicating the position. + !! This is CENTER by default and is often CORNER, + !! but could also be EAST_FACE or NORTH_FACE. + logical, optional, intent(in) :: complete !< An optional argument indicating whether the + !! halo updates should be completed before + !! progress resumes. Omitting complete is the + !! same as setting complete to .true. + integer, optional, intent(in) :: halo !< The size of the halo to update - the full + !! halo by default. + integer, optional, intent(in) :: clock !< The handle for a cpu time clock that should be + !! started then stopped to time this routine. + integer :: pass_var_start_2d !0) call cpu_clock_begin(clock) ; endif + + dirflag = To_All ! 60 + if (present(sideflag)) then ; if (sideflag > 0) dirflag = sideflag ; endif + + if (present(halo) .and. MOM_dom%thin_halo_updates) then + pass_var_start_2d = mpp_start_update_domains(array, MOM_dom%mpp_domain, & + flags=dirflag, position=position, & + whalo=halo, ehalo=halo, shalo=halo, nhalo=halo) + else + pass_var_start_2d = mpp_start_update_domains(array, MOM_dom%mpp_domain, & + flags=dirflag, position=position) + endif + + if (present(clock)) then ; if (clock>0) call cpu_clock_end(clock) ; endif + +end function pass_var_start_2d + +!> pass_var_start_3d starts a halo update for a three-dimensional array. +function pass_var_start_3d(array, MOM_dom, sideflag, position, complete, halo, & + clock) + real, dimension(:,:,:), intent(inout) :: array !< The array which is having its halos points + !! exchanged. + type(MOM_domain_type), intent(inout) :: MOM_dom !< The MOM_domain_type containing the mpp_domain + !! needed to determine where data should be + !! sent. + integer, optional, intent(in) :: sideflag !< An optional integer indicating which + !! directions the data should be sent. It is TO_ALL or the sum of any of TO_EAST, TO_WEST, + !! TO_NORTH, and TO_SOUTH. For example, TO_EAST sends the data to the processor to the east, + !! so the halos on the western side are filled. TO_ALL is the default if sideflag is omitted. + integer, optional, intent(in) :: position !< An optional argument indicating the position. + !! This is CENTER by default and is often CORNER, + !! but could also be EAST_FACE or NORTH_FACE. + logical, optional, intent(in) :: complete !< An optional argument indicating whether the + !! halo updates should be completed before + !! progress resumes. Omitting complete is the + !! same as setting complete to .true. + integer, optional, intent(in) :: halo !< The size of the halo to update - the full + !! halo by default. + integer, optional, intent(in) :: clock !< The handle for a cpu time clock that should be + !! started then stopped to time this routine. + integer :: pass_var_start_3d !< The integer index for this update. + + integer :: dirflag + + if (present(clock)) then ; if (clock>0) call cpu_clock_begin(clock) ; endif + + dirflag = To_All ! 60 + if (present(sideflag)) then ; if (sideflag > 0) dirflag = sideflag ; endif + + if (present(halo) .and. MOM_dom%thin_halo_updates) then + pass_var_start_3d = mpp_start_update_domains(array, MOM_dom%mpp_domain, & + flags=dirflag, position=position, & + whalo=halo, ehalo=halo, shalo=halo, nhalo=halo) + else + pass_var_start_3d = mpp_start_update_domains(array, MOM_dom%mpp_domain, & + flags=dirflag, position=position) + endif + + if (present(clock)) then ; if (clock>0) call cpu_clock_end(clock) ; endif + +end function pass_var_start_3d + +!> pass_var_complete_2d completes a halo update for a two-dimensional array. +subroutine pass_var_complete_2d(id_update, array, MOM_dom, sideflag, position, halo, & + clock) + integer, intent(in) :: id_update !< The integer id of this update which has + !! been returned from a previous call to + !! pass_var_start. + real, dimension(:,:), intent(inout) :: array !< The array which is having its halos points + !! exchanged. + type(MOM_domain_type), intent(inout) :: MOM_dom !< The MOM_domain_type containing the mpp_domain + !! needed to determine where data should be + !! sent. + integer, optional, intent(in) :: sideflag !< An optional integer indicating which + !! directions the data should be sent. It is TO_ALL or the sum of any of TO_EAST, TO_WEST, + !! TO_NORTH, and TO_SOUTH. For example, TO_EAST sends the data to the processor to the east, + !! so the halos on the western side are filled. TO_ALL is the default if sideflag is omitted. + integer, optional, intent(in) :: position !< An optional argument indicating the position. + !! This is CENTER by default and is often CORNER, + !! but could also be EAST_FACE or NORTH_FACE. + integer, optional, intent(in) :: halo !< The size of the halo to update - the full + !! halo by default. + integer, optional, intent(in) :: clock !< The handle for a cpu time clock that should be + !! started then stopped to time this routine. + + integer :: dirflag + + if (present(clock)) then ; if (clock>0) call cpu_clock_begin(clock) ; endif + + dirflag = To_All ! 60 + if (present(sideflag)) then ; if (sideflag > 0) dirflag = sideflag ; endif + + if (present(halo) .and. MOM_dom%thin_halo_updates) then + call mpp_complete_update_domains(id_update, array, MOM_dom%mpp_domain, & + flags=dirflag, position=position, & + whalo=halo, ehalo=halo, shalo=halo, nhalo=halo) + else + call mpp_complete_update_domains(id_update, array, MOM_dom%mpp_domain, & + flags=dirflag, position=position) + endif + + if (present(clock)) then ; if (clock>0) call cpu_clock_end(clock) ; endif + +end subroutine pass_var_complete_2d + +!> pass_var_complete_3d completes a halo update for a three-dimensional array. +subroutine pass_var_complete_3d(id_update, array, MOM_dom, sideflag, position, halo, & + clock) + integer, intent(in) :: id_update !< The integer id of this update which has + !! been returned from a previous call to + !! pass_var_start. + real, dimension(:,:,:), intent(inout) :: array !< The array which is having its halos points + !! exchanged. + type(MOM_domain_type), intent(inout) :: MOM_dom !< The MOM_domain_type containing the mpp_domain + !! needed to determine where data should be + !! sent. + integer, optional, intent(in) :: sideflag !< An optional integer indicating which + !! directions the data should be sent. It is TO_ALL or the sum of any of TO_EAST, TO_WEST, + !! TO_NORTH, and TO_SOUTH. For example, TO_EAST sends the data to the processor to the east, + !! so the halos on the western side are filled. TO_ALL is the default if sideflag is omitted. + integer, optional, intent(in) :: position !< An optional argument indicating the position. + !! This is CENTER by default and is often CORNER, + !! but could also be EAST_FACE or NORTH_FACE. + integer, optional, intent(in) :: halo !< The size of the halo to update - the full + !! halo by default. + integer, optional, intent(in) :: clock !< The handle for a cpu time clock that should be + !! started then stopped to time this routine. + + integer :: dirflag + + if (present(clock)) then ; if (clock>0) call cpu_clock_begin(clock) ; endif + + dirflag = To_All ! 60 + if (present(sideflag)) then ; if (sideflag > 0) dirflag = sideflag ; endif + + if (present(halo) .and. MOM_dom%thin_halo_updates) then + call mpp_complete_update_domains(id_update, array, MOM_dom%mpp_domain, & + flags=dirflag, position=position, & + whalo=halo, ehalo=halo, shalo=halo, nhalo=halo) + else + call mpp_complete_update_domains(id_update, array, MOM_dom%mpp_domain, & + flags=dirflag, position=position) + endif + + if (present(clock)) then ; if (clock>0) call cpu_clock_end(clock) ; endif + +end subroutine pass_var_complete_3d + +!> pass_vector_2d does a halo update for a pair of two-dimensional arrays +!! representing the components of a two-dimensional horizontal vector. +subroutine pass_vector_2d(u_cmpt, v_cmpt, MOM_dom, direction, stagger, complete, halo, & + clock) + real, dimension(:,:), intent(inout) :: u_cmpt !< The nominal zonal (u) component of the vector + !! pair which is having its halos points + !! exchanged. + real, dimension(:,:), intent(inout) :: v_cmpt !< The nominal meridional (v) component of the + !! vector pair which is having its halos points + !! exchanged. + type(MOM_domain_type), intent(inout) :: MOM_dom !< The MOM_domain_type containing the mpp_domain + !! needed to determine where data should be + !! sent. + integer, optional, intent(in) :: direction !< An optional integer indicating which + !! directions the data should be sent. It is TO_ALL or the sum of any of TO_EAST, TO_WEST, + !! TO_NORTH, and TO_SOUTH, possibly plus SCALAR_PAIR if these are paired non-directional + !! scalars discretized at the typical vector component locations. For example, TO_EAST sends + !! the data to the processor to the east, so the halos on the western side are filled. TO_ALL + !! is the default if omitted. + integer, optional, intent(in) :: stagger !< An optional flag, which may be one of A_GRID, + !! BGRID_NE, or CGRID_NE, indicating where the two components of the vector are + !! discretized. Omitting stagger is the same as setting it to CGRID_NE. + logical, optional, intent(in) :: complete !< An optional argument indicating whether the + !! halo updates should be completed before progress resumes. + !! Omitting complete is the same as setting complete to .true. + integer, optional, intent(in) :: halo !< The size of the halo to update - the full + !! halo by default. + integer, optional, intent(in) :: clock !< The handle for a cpu time clock that should be + !! started then stopped to time this routine. + + ! Local variables + integer :: stagger_local + integer :: dirflag + logical :: block_til_complete + + if (present(clock)) then ; if (clock>0) call cpu_clock_begin(clock) ; endif + + stagger_local = CGRID_NE ! Default value for type of grid + if (present(stagger)) stagger_local = stagger + + dirflag = To_All ! 60 + if (present(direction)) then ; if (direction > 0) dirflag = direction ; endif + block_til_complete = .true. + if (present(complete)) block_til_complete = complete + + if (present(halo) .and. MOM_dom%thin_halo_updates) then + call mpp_update_domains(u_cmpt, v_cmpt, MOM_dom%mpp_domain, flags=dirflag, & + gridtype=stagger_local, complete = block_til_complete, & + whalo=halo, ehalo=halo, shalo=halo, nhalo=halo) + else + call mpp_update_domains(u_cmpt, v_cmpt, MOM_dom%mpp_domain, flags=dirflag, & + gridtype=stagger_local, complete = block_til_complete) + endif + + if (present(clock)) then ; if (clock>0) call cpu_clock_end(clock) ; endif + +end subroutine pass_vector_2d + +!> fill_vector_symmetric_edges_2d does an usual set of halo updates that only +!! fill in the values at the edge of a pair of symmetric memory two-dimensional +!! arrays representing the components of a two-dimensional horizontal vector. +!! If symmetric memory is not being used, this subroutine does nothing except to +!! possibly turn optional cpu clocks on or off. +subroutine fill_vector_symmetric_edges_2d(u_cmpt, v_cmpt, MOM_dom, stagger, scalar, & + clock) + real, dimension(:,:), intent(inout) :: u_cmpt !< The nominal zonal (u) component of the vector + !! pair which is having its halos points + !! exchanged. + real, dimension(:,:), intent(inout) :: v_cmpt !< The nominal meridional (v) component of the + !! vector pair which is having its halos points + !! exchanged. + type(MOM_domain_type), intent(inout) :: MOM_dom !< The MOM_domain_type containing the mpp_domain + !! needed to determine where data should be + !! sent. + integer, optional, intent(in) :: stagger !< An optional flag, which may be one of A_GRID, + !! BGRID_NE, or CGRID_NE, indicating where the two components of the vector are + !! discretized. Omitting stagger is the same as setting it to CGRID_NE. + logical, optional, intent(in) :: scalar !< An optional argument indicating whether. + integer, optional, intent(in) :: clock !< The handle for a cpu time clock that should be + !! started then stopped to time this routine. + + ! Local variables + integer :: stagger_local + integer :: dirflag + integer :: i, j, isc, iec, jsc, jec, isd, ied, jsd, jed, IscB, IecB, JscB, JecB + real, allocatable, dimension(:) :: sbuff_x, sbuff_y, wbuff_x, wbuff_y + logical :: block_til_complete + + if (.not. MOM_dom%symmetric) then + return + endif + + if (present(clock)) then ; if (clock>0) call cpu_clock_begin(clock) ; endif + + stagger_local = CGRID_NE ! Default value for type of grid + if (present(stagger)) stagger_local = stagger + + if (.not.(stagger_local == CGRID_NE .or. stagger_local == BGRID_NE)) return + + call mpp_get_compute_domain(MOM_dom%mpp_domain, isc, iec, jsc, jec) + call mpp_get_data_domain(MOM_dom%mpp_domain, isd, ied, jsd, jed) + + ! Adjust isc, etc., to account for the fact that the input arrays indices all + ! start at 1 (and are effectively on a SW grid!). + isc = isc - (isd-1) ; iec = iec - (isd-1) + jsc = jsc - (jsd-1) ; jec = jec - (jsd-1) + IscB = isc ; IecB = iec+1 ; JscB = jsc ; JecB = jec+1 + + dirflag = To_All ! 60 + if (present(scalar)) then ; if (scalar) dirflag = To_All+SCALAR_PAIR ; endif + + if (stagger_local == CGRID_NE) then + allocate(wbuff_x(jsc:jec)) ; allocate(sbuff_y(isc:iec)) + wbuff_x(:) = 0.0 ; sbuff_y(:) = 0.0 + call mpp_get_boundary(u_cmpt, v_cmpt, MOM_dom%mpp_domain, flags=dirflag, & + wbufferx=wbuff_x, sbuffery=sbuff_y, & + gridtype=CGRID_NE) + do i=isc,iec + v_cmpt(i,JscB) = sbuff_y(i) + enddo + do j=jsc,jec + u_cmpt(IscB,j) = wbuff_x(j) + enddo + deallocate(wbuff_x) ; deallocate(sbuff_y) + elseif (stagger_local == BGRID_NE) then + allocate(wbuff_x(JscB:JecB)) ; allocate(sbuff_x(IscB:IecB)) + allocate(wbuff_y(JscB:JecB)) ; allocate(sbuff_y(IscB:IecB)) + wbuff_x(:) = 0.0 ; wbuff_y(:) = 0.0 ; sbuff_x(:) = 0.0 ; sbuff_y(:) = 0.0 + call mpp_get_boundary(u_cmpt, v_cmpt, MOM_dom%mpp_domain, flags=dirflag, & + wbufferx=wbuff_x, sbufferx=sbuff_x, & + wbuffery=wbuff_y, sbuffery=sbuff_y, & + gridtype=BGRID_NE) + do I=IscB,IecB + u_cmpt(I,JscB) = sbuff_x(I) ; v_cmpt(I,JscB) = sbuff_y(I) + enddo + do J=JscB,JecB + u_cmpt(IscB,J) = wbuff_x(J) ; v_cmpt(IscB,J) = wbuff_y(J) + enddo + deallocate(wbuff_x) ; deallocate(sbuff_x) + deallocate(wbuff_y) ; deallocate(sbuff_y) + endif + + if (present(clock)) then ; if (clock>0) call cpu_clock_end(clock) ; endif + +end subroutine fill_vector_symmetric_edges_2d + +!> pass_vector_3d does a halo update for a pair of three-dimensional arrays +!! representing the components of a three-dimensional horizontal vector. +subroutine pass_vector_3d(u_cmpt, v_cmpt, MOM_dom, direction, stagger, complete, halo, & + clock) + real, dimension(:,:,:), intent(inout) :: u_cmpt !< The nominal zonal (u) component of the vector + !! pair which is having its halos points + !! exchanged. + real, dimension(:,:,:), intent(inout) :: v_cmpt !< The nominal meridional (v) component of the + !! vector pair which is having its halos points + !! exchanged. + type(MOM_domain_type), intent(inout) :: MOM_dom !< The MOM_domain_type containing the mpp_domain + !! needed to determine where data should be + !! sent. + integer, optional, intent(in) :: direction !< An optional integer indicating which + !! directions the data should be sent. It is TO_ALL or the sum of any of TO_EAST, TO_WEST, + !! TO_NORTH, and TO_SOUTH, possibly plus SCALAR_PAIR if these are paired non-directional + !! scalars discretized at the typical vector component locations. For example, TO_EAST sends + !! the data to the processor to the east, so the halos on the western side are filled. TO_ALL + !! is the default if omitted. + integer, optional, intent(in) :: stagger !< An optional flag, which may be one of A_GRID, + !! BGRID_NE, or CGRID_NE, indicating where the two components of the vector are + !! discretized. Omitting stagger is the same as setting it to CGRID_NE. + logical, optional, intent(in) :: complete !< An optional argument indicating whether the + !! halo updates should be completed before progress resumes. + !! Omitting complete is the same as setting complete to .true. + integer, optional, intent(in) :: halo !< The size of the halo to update - the full + !! halo by default. + integer, optional, intent(in) :: clock !< The handle for a cpu time clock that should be + !! started then stopped to time this routine. + + ! Local variables + integer :: stagger_local + integer :: dirflag + logical :: block_til_complete + + if (present(clock)) then ; if (clock>0) call cpu_clock_begin(clock) ; endif + + stagger_local = CGRID_NE ! Default value for type of grid + if (present(stagger)) stagger_local = stagger + + dirflag = To_All ! 60 + if (present(direction)) then ; if (direction > 0) dirflag = direction ; endif + block_til_complete = .true. + if (present(complete)) block_til_complete = complete + + if (present(halo) .and. MOM_dom%thin_halo_updates) then + call mpp_update_domains(u_cmpt, v_cmpt, MOM_dom%mpp_domain, flags=dirflag, & + gridtype=stagger_local, complete = block_til_complete, & + whalo=halo, ehalo=halo, shalo=halo, nhalo=halo) + else + call mpp_update_domains(u_cmpt, v_cmpt, MOM_dom%mpp_domain, flags=dirflag, & + gridtype=stagger_local, complete = block_til_complete) + endif + + if (present(clock)) then ; if (clock>0) call cpu_clock_end(clock) ; endif + +end subroutine pass_vector_3d + +!> pass_vector_start_2d starts a halo update for a pair of two-dimensional arrays +!! representing the components of a two-dimensional horizontal vector. +function pass_vector_start_2d(u_cmpt, v_cmpt, MOM_dom, direction, stagger, complete, halo, & + clock) + real, dimension(:,:), intent(inout) :: u_cmpt !< The nominal zonal (u) component of the vector + !! pair which is having its halos points + !! exchanged. + real, dimension(:,:), intent(inout) :: v_cmpt !< The nominal meridional (v) component of the + !! vector pair which is having its halos points + !! exchanged. + type(MOM_domain_type), intent(inout) :: MOM_dom !< The MOM_domain_type containing the mpp_domain + !! needed to determine where data should be + !! sent. + integer, optional, intent(in) :: direction !< An optional integer indicating which + !! directions the data should be sent. It is TO_ALL or the sum of any of TO_EAST, TO_WEST, + !! TO_NORTH, and TO_SOUTH, possibly plus SCALAR_PAIR if these are paired non-directional + !! scalars discretized at the typical vector component locations. For example, TO_EAST sends + !! the data to the processor to the east, so the halos on the western side are filled. TO_ALL + !! is the default if omitted. + integer, optional, intent(in) :: stagger !< An optional flag, which may be one of A_GRID, + !! BGRID_NE, or CGRID_NE, indicating where the two components of the vector are + !! discretized. Omitting stagger is the same as setting it to CGRID_NE. + logical, optional, intent(in) :: complete !< An optional argument indicating whether the + !! halo updates should be completed before progress resumes. + !! Omitting complete is the same as setting complete to .true. + integer, optional, intent(in) :: halo !< The size of the halo to update - the full + !! halo by default. + integer, optional, intent(in) :: clock !< The handle for a cpu time clock that should be + !! started then stopped to time this routine. + integer :: pass_vector_start_2d !< The integer index for this + !! update. + + ! Local variables + integer :: stagger_local + integer :: dirflag + + if (present(clock)) then ; if (clock>0) call cpu_clock_begin(clock) ; endif + + stagger_local = CGRID_NE ! Default value for type of grid + if (present(stagger)) stagger_local = stagger + + dirflag = To_All ! 60 + if (present(direction)) then ; if (direction > 0) dirflag = direction ; endif + + if (present(halo) .and. MOM_dom%thin_halo_updates) then + pass_vector_start_2d = mpp_start_update_domains(u_cmpt, v_cmpt, & + MOM_dom%mpp_domain, flags=dirflag, gridtype=stagger_local, & + whalo=halo, ehalo=halo, shalo=halo, nhalo=halo) + else + pass_vector_start_2d = mpp_start_update_domains(u_cmpt, v_cmpt, & + MOM_dom%mpp_domain, flags=dirflag, gridtype=stagger_local) + endif + + if (present(clock)) then ; if (clock>0) call cpu_clock_end(clock) ; endif + +end function pass_vector_start_2d + +!> pass_vector_start_3d starts a halo update for a pair of three-dimensional arrays +!! representing the components of a three-dimensional horizontal vector. +function pass_vector_start_3d(u_cmpt, v_cmpt, MOM_dom, direction, stagger, complete, halo, & + clock) + real, dimension(:,:,:), intent(inout) :: u_cmpt !< The nominal zonal (u) component of the vector + !! pair which is having its halos points + !! exchanged. + real, dimension(:,:,:), intent(inout) :: v_cmpt !< The nominal meridional (v) component of the + !! vector pair which is having its halos points + !! exchanged. + type(MOM_domain_type), intent(inout) :: MOM_dom !< The MOM_domain_type containing the mpp_domain + !! needed to determine where data should be + !! sent. + integer, optional, intent(in) :: direction !< An optional integer indicating which + !! directions the data should be sent. It is TO_ALL or the sum of any of TO_EAST, TO_WEST, + !! TO_NORTH, and TO_SOUTH, possibly plus SCALAR_PAIR if these are paired non-directional + !! scalars discretized at the typical vector component locations. For example, TO_EAST sends + !! the data to the processor to the east, so the halos on the western side are filled. TO_ALL + !! is the default if omitted. + integer, optional, intent(in) :: stagger !< An optional flag, which may be one of A_GRID, + !! BGRID_NE, or CGRID_NE, indicating where the two components of the vector are + !! discretized. Omitting stagger is the same as setting it to CGRID_NE. + logical, optional, intent(in) :: complete !< An optional argument indicating whether the + !! halo updates should be completed before progress resumes. + !! Omitting complete is the same as setting complete to .true. + integer, optional, intent(in) :: halo !< The size of the halo to update - the full + !! halo by default. + integer, optional, intent(in) :: clock !< The handle for a cpu time clock that should be + !! started then stopped to time this routine. + integer :: pass_vector_start_3d !< The integer index for this + !! update. + ! Local variables + integer :: stagger_local + integer :: dirflag + + if (present(clock)) then ; if (clock>0) call cpu_clock_begin(clock) ; endif + + stagger_local = CGRID_NE ! Default value for type of grid + if (present(stagger)) stagger_local = stagger + + dirflag = To_All ! 60 + if (present(direction)) then ; if (direction > 0) dirflag = direction ; endif + + if (present(halo) .and. MOM_dom%thin_halo_updates) then + pass_vector_start_3d = mpp_start_update_domains(u_cmpt, v_cmpt, & + MOM_dom%mpp_domain, flags=dirflag, gridtype=stagger_local, & + whalo=halo, ehalo=halo, shalo=halo, nhalo=halo) + else + pass_vector_start_3d = mpp_start_update_domains(u_cmpt, v_cmpt, & + MOM_dom%mpp_domain, flags=dirflag, gridtype=stagger_local) + endif + + if (present(clock)) then ; if (clock>0) call cpu_clock_end(clock) ; endif + +end function pass_vector_start_3d + +!> pass_vector_complete_2d completes a halo update for a pair of two-dimensional arrays +!! representing the components of a two-dimensional horizontal vector. +subroutine pass_vector_complete_2d(id_update, u_cmpt, v_cmpt, MOM_dom, direction, stagger, halo, & + clock) + integer, intent(in) :: id_update !< The integer id of this update which has been + !! returned from a previous call to + !! pass_var_start. + real, dimension(:,:), intent(inout) :: u_cmpt !< The nominal zonal (u) component of the vector + !! pair which is having its halos points + !! exchanged. + real, dimension(:,:), intent(inout) :: v_cmpt !< The nominal meridional (v) component of the + !! vector pair which is having its halos points + !! exchanged. + type(MOM_domain_type), intent(inout) :: MOM_dom !< The MOM_domain_type containing the mpp_domain + !! needed to determine where data should be + !! sent. + integer, optional, intent(in) :: direction !< An optional integer indicating which + !! directions the data should be sent. It is TO_ALL or the sum of any of TO_EAST, TO_WEST, + !! TO_NORTH, and TO_SOUTH, possibly plus SCALAR_PAIR if these are paired non-directional + !! scalars discretized at the typical vector component locations. For example, TO_EAST sends + !! the data to the processor to the east, so the halos on the western side are filled. TO_ALL + !! is the default if omitted. + integer, optional, intent(in) :: stagger !< An optional flag, which may be one of A_GRID, + !! BGRID_NE, or CGRID_NE, indicating where the two components of the vector are + !! discretized. Omitting stagger is the same as setting it to CGRID_NE. + integer, optional, intent(in) :: halo !< The size of the halo to update - the full + !! halo by default. + integer, optional, intent(in) :: clock !< The handle for a cpu time clock that should be + !! started then stopped to time this routine. + ! Local variables + integer :: stagger_local + integer :: dirflag + + if (present(clock)) then ; if (clock>0) call cpu_clock_begin(clock) ; endif + + stagger_local = CGRID_NE ! Default value for type of grid + if (present(stagger)) stagger_local = stagger + + dirflag = To_All ! 60 + if (present(direction)) then ; if (direction > 0) dirflag = direction ; endif + + if (present(halo) .and. MOM_dom%thin_halo_updates) then + call mpp_complete_update_domains(id_update, u_cmpt, v_cmpt, & + MOM_dom%mpp_domain, flags=dirflag, gridtype=stagger_local, & + whalo=halo, ehalo=halo, shalo=halo, nhalo=halo) + else + call mpp_complete_update_domains(id_update, u_cmpt, v_cmpt, & + MOM_dom%mpp_domain, flags=dirflag, gridtype=stagger_local) + endif + + if (present(clock)) then ; if (clock>0) call cpu_clock_end(clock) ; endif + +end subroutine pass_vector_complete_2d + +!> pass_vector_complete_3d completes a halo update for a pair of three-dimensional +!! arrays representing the components of a three-dimensional horizontal vector. +subroutine pass_vector_complete_3d(id_update, u_cmpt, v_cmpt, MOM_dom, direction, stagger, halo, & + clock) + integer, intent(in) :: id_update !< The integer id of this update which has been + !! returned from a previous call to + !! pass_var_start. + real, dimension(:,:,:), intent(inout) :: u_cmpt !< The nominal zonal (u) component of the vector + !! pair which is having its halos points + !! exchanged. + real, dimension(:,:,:), intent(inout) :: v_cmpt !< The nominal meridional (v) component of the + !! vector pair which is having its halos points + !! exchanged. + type(MOM_domain_type), intent(inout) :: MOM_dom !< The MOM_domain_type containing the mpp_domain + !! needed to determine where data should be + !! sent. + integer, optional, intent(in) :: direction !< An optional integer indicating which + !! directions the data should be sent. It is TO_ALL or the sum of any of TO_EAST, TO_WEST, + !! TO_NORTH, and TO_SOUTH, possibly plus SCALAR_PAIR if these are paired non-directional + !! scalars discretized at the typical vector component locations. For example, TO_EAST sends + !! the data to the processor to the east, so the halos on the western side are filled. TO_ALL + !! is the default if omitted. + integer, optional, intent(in) :: stagger !< An optional flag, which may be one of A_GRID, + !! BGRID_NE, or CGRID_NE, indicating where the two components of the vector are + !! discretized. Omitting stagger is the same as setting it to CGRID_NE. + integer, optional, intent(in) :: halo !< The size of the halo to update - the full + !! halo by default. + integer, optional, intent(in) :: clock !< The handle for a cpu time clock that should be + !! started then stopped to time this routine. + ! Local variables + integer :: stagger_local + integer :: dirflag + + if (present(clock)) then ; if (clock>0) call cpu_clock_begin(clock) ; endif + + stagger_local = CGRID_NE ! Default value for type of grid + if (present(stagger)) stagger_local = stagger + + dirflag = To_All ! 60 + if (present(direction)) then ; if (direction > 0) dirflag = direction ; endif + + if (present(halo) .and. MOM_dom%thin_halo_updates) then + call mpp_complete_update_domains(id_update, u_cmpt, v_cmpt, & + MOM_dom%mpp_domain, flags=dirflag, gridtype=stagger_local, & + whalo=halo, ehalo=halo, shalo=halo, nhalo=halo) + else + call mpp_complete_update_domains(id_update, u_cmpt, v_cmpt, & + MOM_dom%mpp_domain, flags=dirflag, gridtype=stagger_local) + endif + + if (present(clock)) then ; if (clock>0) call cpu_clock_end(clock) ; endif + +end subroutine pass_vector_complete_3d + +!> create_var_group_pass_2d sets up a group of two-dimensional array halo updates. +subroutine create_var_group_pass_2d(group, array, MOM_dom, sideflag, position, & + halo, clock) + type(group_pass_type), intent(inout) :: group !< The data type that store information for + !! group update. This data will be used in + !! do_group_pass. + real, dimension(:,:), intent(inout) :: array !< The array which is having its halos points + !! exchanged. + type(MOM_domain_type), intent(inout) :: MOM_dom !< The MOM_domain_type containing the mpp_domain + !! needed to determine where data should be + !! sent. + integer, optional, intent(in) :: sideflag !< An optional integer indicating which + !! directions the data should be sent. It is TO_ALL or the sum of any of TO_EAST, TO_WEST, + !! TO_NORTH, and TO_SOUTH. For example, TO_EAST sends the data to the processor to the east, + !! so the halos on the western side are filled. TO_ALL is the default if sideflag is omitted. + integer, optional, intent(in) :: position !< An optional argument indicating the position. + !! This is CENTER by default and is often CORNER, + !! but could also be EAST_FACE or NORTH_FACE. + integer, optional, intent(in) :: halo !< The size of the halo to update - the full + !! halo by default. + integer, optional, intent(in) :: clock !< The handle for a cpu time clock that should be + !! started then stopped to time this routine. + ! Local variables + integer :: dirflag + + if (present(clock)) then ; if (clock>0) call cpu_clock_begin(clock) ; endif + + dirflag = To_All ! 60 + if (present(sideflag)) then ; if (sideflag > 0) dirflag = sideflag ; endif + + if (mpp_group_update_initialized(group)) then + call mpp_reset_group_update_field(group,array) + elseif (present(halo) .and. MOM_dom%thin_halo_updates) then + call mpp_create_group_update(group, array, MOM_dom%mpp_domain, flags=dirflag, & + position=position, whalo=halo, ehalo=halo, & + shalo=halo, nhalo=halo) + else + call mpp_create_group_update(group, array, MOM_dom%mpp_domain, flags=dirflag, & + position=position) + endif + + if (present(clock)) then ; if (clock>0) call cpu_clock_end(clock) ; endif + +end subroutine create_var_group_pass_2d + +!> create_var_group_pass_3d sets up a group of three-dimensional array halo updates. +subroutine create_var_group_pass_3d(group, array, MOM_dom, sideflag, position, halo, & + clock) + type(group_pass_type), intent(inout) :: group !< The data type that store information for + !! group update. This data will be used in + !! do_group_pass. + real, dimension(:,:,:), intent(inout) :: array !< The array which is having its halos points + !! exchanged. + type(MOM_domain_type), intent(inout) :: MOM_dom !< The MOM_domain_type containing the mpp_domain + !! needed to determine where data should be + !! sent. + integer, optional, intent(in) :: sideflag !< An optional integer indicating which + !! directions the data should be sent. It is TO_ALL or the sum of any of TO_EAST, TO_WEST, + !! TO_NORTH, and TO_SOUTH. For example, TO_EAST sends the data to the processor to the east, + !! so the halos on the western side are filled. TO_ALL is the default if sideflag is omitted. + integer, optional, intent(in) :: position !< An optional argument indicating the position. + !! This is CENTER by default and is often CORNER, + !! but could also be EAST_FACE or NORTH_FACE. + integer, optional, intent(in) :: halo !< The size of the halo to update - the full + !! halo by default. + integer, optional, intent(in) :: clock !< The handle for a cpu time clock that should be + !! started then stopped to time this routine. + ! Local variables + integer :: dirflag + + if (present(clock)) then ; if (clock>0) call cpu_clock_begin(clock) ; endif + + dirflag = To_All ! 60 + if (present(sideflag)) then ; if (sideflag > 0) dirflag = sideflag ; endif + + if (mpp_group_update_initialized(group)) then + call mpp_reset_group_update_field(group,array) + elseif (present(halo) .and. MOM_dom%thin_halo_updates) then + call mpp_create_group_update(group, array, MOM_dom%mpp_domain, flags=dirflag, & + position=position, whalo=halo, ehalo=halo, & + shalo=halo, nhalo=halo) + else + call mpp_create_group_update(group, array, MOM_dom%mpp_domain, flags=dirflag, & + position=position) + endif + + if (present(clock)) then ; if (clock>0) call cpu_clock_end(clock) ; endif + +end subroutine create_var_group_pass_3d + +!> create_vector_group_pass_2d sets up a group of two-dimensional vector halo updates. +subroutine create_vector_group_pass_2d(group, u_cmpt, v_cmpt, MOM_dom, direction, stagger, halo, & + clock) + type(group_pass_type), intent(inout) :: group !< The data type that store information for + !! group update. This data will be used in + !! do_group_pass. + real, dimension(:,:), intent(inout) :: u_cmpt !< The nominal zonal (u) component of the vector + !! pair which is having its halos points + !! exchanged. + real, dimension(:,:), intent(inout) :: v_cmpt !< The nominal meridional (v) component of the + !! vector pair which is having its halos points + !! exchanged. + + type(MOM_domain_type), intent(inout) :: MOM_dom !< The MOM_domain_type containing the mpp_domain + !! needed to determine where data should be + !! sent + integer, optional, intent(in) :: direction !< An optional integer indicating which + !! directions the data should be sent. It is TO_ALL or the sum of any of TO_EAST, TO_WEST, + !! TO_NORTH, and TO_SOUTH, possibly plus SCALAR_PAIR if these are paired non-directional + !! scalars discretized at the typical vector component locations. For example, TO_EAST sends + !! the data to the processor to the east, so the halos on the western side are filled. TO_ALL + !! is the default if omitted. + integer, optional, intent(in) :: stagger !< An optional flag, which may be one of A_GRID, + !! BGRID_NE, or CGRID_NE, indicating where the two components of the vector are + !! discretized. Omitting stagger is the same as setting it to CGRID_NE. + integer, optional, intent(in) :: halo !< The size of the halo to update - the full + !! halo by default. + integer, optional, intent(in) :: clock !< The handle for a cpu time clock that should be + !! started then stopped to time this routine. + ! Local variables + integer :: stagger_local + integer :: dirflag + + if (present(clock)) then ; if (clock>0) call cpu_clock_begin(clock) ; endif + + stagger_local = CGRID_NE ! Default value for type of grid + if (present(stagger)) stagger_local = stagger + + dirflag = To_All ! 60 + if (present(direction)) then ; if (direction > 0) dirflag = direction ; endif + + if (mpp_group_update_initialized(group)) then + call mpp_reset_group_update_field(group,u_cmpt, v_cmpt) + elseif (present(halo) .and. MOM_dom%thin_halo_updates) then + call mpp_create_group_update(group, u_cmpt, v_cmpt, MOM_dom%mpp_domain, & + flags=dirflag, gridtype=stagger_local, whalo=halo, ehalo=halo, & + shalo=halo, nhalo=halo) + else + call mpp_create_group_update(group, u_cmpt, v_cmpt, MOM_dom%mpp_domain, & + flags=dirflag, gridtype=stagger_local) + endif + + if (present(clock)) then ; if (clock>0) call cpu_clock_end(clock) ; endif + +end subroutine create_vector_group_pass_2d + +!> create_vector_group_pass_3d sets up a group of three-dimensional vector halo updates. +subroutine create_vector_group_pass_3d(group, u_cmpt, v_cmpt, MOM_dom, direction, stagger, halo, & + clock) + type(group_pass_type), intent(inout) :: group !< The data type that store information for + !! group update. This data will be used in + !! do_group_pass. + real, dimension(:,:,:), intent(inout) :: u_cmpt !< The nominal zonal (u) component of the vector + !! pair which is having its halos points + !! exchanged. + real, dimension(:,:,:), intent(inout) :: v_cmpt !< The nominal meridional (v) component of the + !! vector pair which is having its halos points + !! exchanged. + + type(MOM_domain_type), intent(inout) :: MOM_dom !< The MOM_domain_type containing the mpp_domain + !! needed to determine where data should be + !! sent. + integer, optional, intent(in) :: direction !< An optional integer indicating which + !! directions the data should be sent. It is TO_ALL or the sum of any of TO_EAST, TO_WEST, + !! TO_NORTH, and TO_SOUTH, possibly plus SCALAR_PAIR if these are paired non-directional + !! scalars discretized at the typical vector component locations. For example, TO_EAST sends + !! the data to the processor to the east, so the halos on the western side are filled. TO_ALL + !! is the default if omitted. + integer, optional, intent(in) :: stagger !< An optional flag, which may be one of A_GRID, + !! BGRID_NE, or CGRID_NE, indicating where the two components of the vector are + !! discretized. Omitting stagger is the same as setting it to CGRID_NE. + integer, optional, intent(in) :: halo !< The size of the halo to update - the full + !! halo by default. + integer, optional, intent(in) :: clock !< The handle for a cpu time clock that should be + !! started then stopped to time this routine. + + ! Local variables + integer :: stagger_local + integer :: dirflag + + if (present(clock)) then ; if (clock>0) call cpu_clock_begin(clock) ; endif + + stagger_local = CGRID_NE ! Default value for type of grid + if (present(stagger)) stagger_local = stagger + + dirflag = To_All ! 60 + if (present(direction)) then ; if (direction > 0) dirflag = direction ; endif + + if (mpp_group_update_initialized(group)) then + call mpp_reset_group_update_field(group,u_cmpt, v_cmpt) + elseif (present(halo) .and. MOM_dom%thin_halo_updates) then + call mpp_create_group_update(group, u_cmpt, v_cmpt, MOM_dom%mpp_domain, & + flags=dirflag, gridtype=stagger_local, whalo=halo, ehalo=halo, & + shalo=halo, nhalo=halo) + else + call mpp_create_group_update(group, u_cmpt, v_cmpt, MOM_dom%mpp_domain, & + flags=dirflag, gridtype=stagger_local) + endif + + if (present(clock)) then ; if (clock>0) call cpu_clock_end(clock) ; endif + +end subroutine create_vector_group_pass_3d + +!> do_group_pass carries out a group halo update. +subroutine do_group_pass(group, MOM_dom, clock) + type(group_pass_type), intent(inout) :: group !< The data type that store information for + !! group update. This data will be used in + !! do_group_pass. + type(MOM_domain_type), intent(inout) :: MOM_dom !< The MOM_domain_type containing the mpp_domain + !! needed to determine where data should be + !! sent. + integer, optional, intent(in) :: clock !< The handle for a cpu time clock that should be + !! started then stopped to time this routine. + real :: d_type + + if (present(clock)) then ; if (clock>0) call cpu_clock_begin(clock) ; endif + + call mpp_do_group_update(group, MOM_dom%mpp_domain, d_type) + + if (present(clock)) then ; if (clock>0) call cpu_clock_end(clock) ; endif + +end subroutine do_group_pass + +!> start_group_pass starts out a group halo update. +subroutine start_group_pass(group, MOM_dom, clock) + type(group_pass_type), intent(inout) :: group !< The data type that store information for + !! group update. This data will be used in + !! do_group_pass. + type(MOM_domain_type), intent(inout) :: MOM_dom !< The MOM_domain_type containing the mpp_domain + !! needed to determine where data should be + !! sent. + integer, optional, intent(in) :: clock !< The handle for a cpu time clock that should be + !! started then stopped to time this routine. + + real :: d_type + + if (present(clock)) then ; if (clock>0) call cpu_clock_begin(clock) ; endif + + call mpp_start_group_update(group, MOM_dom%mpp_domain, d_type) + + if (present(clock)) then ; if (clock>0) call cpu_clock_end(clock) ; endif + +end subroutine start_group_pass + +!> complete_group_pass completes a group halo update. +subroutine complete_group_pass(group, MOM_dom, clock) + type(group_pass_type), intent(inout) :: group !< The data type that store information for + !! group update. This data will be used in + !! do_group_pass. + type(MOM_domain_type), intent(inout) :: MOM_dom !< The MOM_domain_type containing the mpp_domain + !! needed to determine where data should be + !! sent. + integer, optional, intent(in) :: clock !< The handle for a cpu time clock that should be + !! started then stopped to time this routine. + real :: d_type + + if (present(clock)) then ; if (clock>0) call cpu_clock_begin(clock) ; endif + + call mpp_complete_group_update(group, MOM_dom%mpp_domain, d_type) + + if (present(clock)) then ; if (clock>0) call cpu_clock_end(clock) ; endif + +end subroutine complete_group_pass + + +!> Pass a 2-D array from one MOM domain to another +subroutine redistribute_array_2d(Domain1, array1, Domain2, array2, complete) + type(domain2d), & + intent(in) :: Domain1 !< The MOM domain from which to extract information. + real, dimension(:,:), intent(in) :: array1 !< The array from which to extract information. + type(domain2d), & + intent(in) :: Domain2 !< The MOM domain receiving information. + real, dimension(:,:), intent(out) :: array2 !< The array receiving information. + logical, optional, intent(in) :: complete !< If true, finish communication before proceeding. + + ! Local variables + logical :: do_complete + + do_complete=.true.;if (PRESENT(complete)) do_complete = complete + + call mpp_redistribute(Domain1, array1, Domain2, array2, do_complete) + +end subroutine redistribute_array_2d + +!> Pass a 3-D array from one MOM domain to another +subroutine redistribute_array_3d(Domain1, array1, Domain2, array2, complete) + type(domain2d), & + intent(in) :: Domain1 !< The MOM domain from which to extract information. + real, dimension(:,:,:), intent(in) :: array1 !< The array from which to extract information. + type(domain2d), & + intent(in) :: Domain2 !< The MOM domain receiving information. + real, dimension(:,:,:), intent(out) :: array2 !< The array receiving information. + logical, optional, intent(in) :: complete !< If true, finish communication before proceeding. + + ! Local variables + logical :: do_complete + + do_complete=.true.;if (PRESENT(complete)) do_complete = complete + + call mpp_redistribute(Domain1, array1, Domain2, array2, do_complete) + +end subroutine redistribute_array_3d + + +!> Rescale the values of a 4-D array in its computational domain by a constant factor +subroutine rescale_comp_data_4d(domain, array, scale) + type(MOM_domain_type), intent(in) :: domain !< MOM domain from which to extract information + real, dimension(:,:,:,:), intent(inout) :: array !< The array which is having the data in its + !! computational domain rescaled + real, intent(in) :: scale !< A scaling factor by which to multiply the + !! values in the computational domain of array + integer :: is, ie, js, je + + if (scale == 1.0) return + + call get_simple_array_i_ind(domain, size(array,1), is, ie) + call get_simple_array_j_ind(domain, size(array,2), js, je) + array(is:ie,js:je,:,:) = scale*array(is:ie,js:je,:,:) + +end subroutine rescale_comp_data_4d + +!> Rescale the values of a 3-D array in its computational domain by a constant factor +subroutine rescale_comp_data_3d(domain, array, scale) + type(MOM_domain_type), intent(in) :: domain !< MOM domain from which to extract information + real, dimension(:,:,:), intent(inout) :: array !< The array which is having the data in its + !! computational domain rescaled + real, intent(in) :: scale !< A scaling factor by which to multiply the + !! values in the computational domain of array + integer :: is, ie, js, je + + if (scale == 1.0) return + + call get_simple_array_i_ind(domain, size(array,1), is, ie) + call get_simple_array_j_ind(domain, size(array,2), js, je) + array(is:ie,js:je,:) = scale*array(is:ie,js:je,:) + +end subroutine rescale_comp_data_3d + +!> Rescale the values of a 2-D array in its computational domain by a constant factor +subroutine rescale_comp_data_2d(domain, array, scale) + type(MOM_domain_type), intent(in) :: domain !< MOM domain from which to extract information + real, dimension(:,:), intent(inout) :: array !< The array which is having the data in its + !! computational domain rescaled + real, intent(in) :: scale !< A scaling factor by which to multiply the + !! values in the computational domain of array + integer :: is, ie, js, je + + if (scale == 1.0) return + + call get_simple_array_i_ind(domain, size(array,1), is, ie) + call get_simple_array_j_ind(domain, size(array,2), js, je) + array(is:ie,js:je) = scale*array(is:ie,js:je) + +end subroutine rescale_comp_data_2d + +!> create_MOM_domain creates and initializes a MOM_domain_type variables, based on the information +!! provided in arguments. +subroutine create_MOM_domain(MOM_dom, n_global, n_halo, reentrant, tripolar_N, layout, io_layout, & + domain_name, mask_table, symmetric, thin_halos, nonblocking) + type(MOM_domain_type), pointer :: MOM_dom !< A pointer to the MOM_domain_type being defined here. + integer, dimension(2), intent(in) :: n_global !< The number of points on the global grid in + !! the i- and j-directions + integer, dimension(2), intent(in) :: n_halo !< The number of halo points on each processor + logical, dimension(2), intent(in) :: reentrant !< If true the grid is periodic in the i- and j- directions + logical, intent(in) :: tripolar_N !< If true the grid uses northern tripolar connectivity + integer, dimension(2), intent(in) :: layout !< The layout of logical PEs in the i- and j-directions. + integer, dimension(2), optional, intent(in) :: io_layout !< The layout for parallel input and output. + character(len=*), optional, intent(in) :: domain_name !< A name for this domain, "MOM" if missing. + character(len=*), optional, intent(in) :: mask_table !< The full relative or absolute path to the mask table. + logical, optional, intent(in) :: symmetric !< If present, this specifies whether this domain + !! uses symmetric memory, or true if missing. + logical, optional, intent(in) :: thin_halos !< If present, this specifies whether to permit the use of + !! thin halo updates, or true if missing. + logical, optional, intent(in) :: nonblocking !< If present, this specifies whether to permit the use of + !! nonblocking halo updates, or false if missing. + + ! local variables + integer, dimension(4) :: global_indices ! The lower and upper global i- and j-index bounds + integer :: X_FLAGS ! A combination of integers encoding the x-direction grid connectivity. + integer :: Y_FLAGS ! A combination of integers encoding the y-direction grid connectivity. + integer :: xhalo_d2, yhalo_d2 + character(len=200) :: mesg ! A string for use in error messages + logical :: mask_table_exists ! Mask_table is present and the file it points to exists + + if (.not.associated(MOM_dom)) then + allocate(MOM_dom) + allocate(MOM_dom%mpp_domain) + allocate(MOM_dom%mpp_domain_d2) + endif + + MOM_dom%name = "MOM" ; if (present(domain_name)) MOM_dom%name = trim(domain_name) + + X_FLAGS = 0 ; Y_FLAGS = 0 + if (reentrant(1)) X_FLAGS = CYCLIC_GLOBAL_DOMAIN + if (reentrant(2)) Y_FLAGS = CYCLIC_GLOBAL_DOMAIN + if (tripolar_N) then + Y_FLAGS = FOLD_NORTH_EDGE + if (reentrant(2)) call MOM_error(FATAL,"MOM_domains: "// & + "TRIPOLAR_N and REENTRANT_Y may not be used together.") + endif + + MOM_dom%nonblocking_updates = nonblocking + MOM_dom%thin_halo_updates = thin_halos + MOM_dom%symmetric = .true. ; if (present(symmetric)) MOM_dom%symmetric = symmetric + MOM_dom%niglobal = n_global(1) ; MOM_dom%njglobal = n_global(2) + MOM_dom%nihalo = n_halo(1) ; MOM_dom%njhalo = n_halo(2) + + ! Save the extra data for creating other domains of different resolution that overlay this domain. + MOM_dom%X_FLAGS = X_FLAGS + MOM_dom%Y_FLAGS = Y_FLAGS + MOM_dom%layout(:) = layout(:) + + ! Set up the io_layout, with error handling. + MOM_dom%io_layout(:) = (/ 1, 1 /) + if (present(io_layout)) then + if (io_layout(1) == 0) then + MOM_dom%io_layout(1) = layout(1) + elseif (io_layout(1) > 1) then + MOM_dom%io_layout(1) = io_layout(1) + if (modulo(layout(1), io_layout(1)) /= 0) then + write(mesg,'("MOM_domains_init: The i-direction I/O-layout, IO_LAYOUT(1)=",i4, & + &", does not evenly divide the i-direction layout, NIPROC=,",i4,".")') io_layout(1), layout(1) + call MOM_error(FATAL, mesg) + endif + endif + + if (io_layout(2) == 0) then + MOM_dom%io_layout(2) = layout(2) + elseif (io_layout(2) > 1) then + MOM_dom%io_layout(2) = io_layout(2) + if (modulo(layout(2), io_layout(2)) /= 0) then + write(mesg,'("MOM_domains_init: The j-direction I/O-layout, IO_LAYOUT(2)=",i4, & + &", does not evenly divide the j-direction layout, NJPROC=,",i4,".")') io_layout(2), layout(2) + call MOM_error(FATAL, mesg) + endif + endif + endif + + if (present(mask_table)) then + mask_table_exists = file_exist(mask_table) + if (mask_table_exists) then + allocate(MOM_dom%maskmap(layout(1), layout(2))) + call parse_mask_table(mask_table, MOM_dom%maskmap, MOM_dom%name) + endif + else + mask_table_exists = .false. + endif + + call clone_MD_to_d2D(MOM_dom, MOM_dom%mpp_domain) + + !For downsampled domain, recommend a halo of 1 (or 0?) since we're not doing wide-stencil computations. + !But that does not work because the downsampled field would not have the correct size to pass the checks, e.g., we get + !error: downsample_diag_indices_get: peculiar size 28 in i-direction\ndoes not match one of 24 25 26 27 + ! call clone_MD_to_d2D(MOM_dom, MOM_dom%mpp_domain_d2, halo_size=(MOM_dom%nihalo/2), coarsen=2) + call clone_MD_to_d2D(MOM_dom, MOM_dom%mpp_domain_d2, coarsen=2) + +end subroutine create_MOM_domain + +!> dealloc_MOM_domain deallocates memory associated with a pointer to a MOM_domain_type +!! and potentially all of its contents +subroutine deallocate_MOM_domain(MOM_domain, cursory) + type(MOM_domain_type), pointer :: MOM_domain !< A pointer to the MOM_domain_type being deallocated + logical, optional, intent(in) :: cursory !< If true do not deallocate fields associated + !! with the underlying infrastructure + logical :: invasive ! If true, deallocate fields associated with the underlying infrastructure + + invasive = .true. ; if (present(cursory)) invasive = .not.cursory + + if (associated(MOM_domain)) then + if (associated(MOM_domain%mpp_domain)) then + if (invasive) call mpp_deallocate_domain(MOM_domain%mpp_domain) + deallocate(MOM_domain%mpp_domain) + endif + if (associated(MOM_domain%mpp_domain_d2)) then + if (invasive) call mpp_deallocate_domain(MOM_domain%mpp_domain_d2) + deallocate(MOM_domain%mpp_domain_d2) + endif + if (associated(MOM_domain%maskmap)) deallocate(MOM_domain%maskmap) + deallocate(MOM_domain) + endif + +end subroutine deallocate_MOM_domain + +!> MOM_thread_affinity_set returns true if the number of openMP threads have been set to a value greater than 1. +function MOM_thread_affinity_set() + ! Local variables + !$ integer :: ocean_nthreads ! Number of openMP threads + !$ integer :: omp_get_num_threads ! An openMP function that returns the number of threads + logical :: MOM_thread_affinity_set + + MOM_thread_affinity_set = .false. + !$ call fms_affinity_init() + !$OMP PARALLEL + !$OMP MASTER + !$ ocean_nthreads = omp_get_num_threads() + !$OMP END MASTER + !$OMP END PARALLEL + !$ MOM_thread_affinity_set = (ocean_nthreads > 1 ) +end function MOM_thread_affinity_set + +!> set_MOM_thread_affinity sets the number of openMP threads to use with the ocean. +subroutine set_MOM_thread_affinity(ocean_nthreads, ocean_hyper_thread) + integer, intent(in) :: ocean_nthreads !< Number of openMP threads to use for the ocean model + logical, intent(in) :: ocean_hyper_thread !< If true, use hyper threading + + ! Local variables + !$ integer :: omp_get_thread_num, omp_get_num_threads !< These are the results of openMP functions + + !$ call fms_affinity_init() ! fms_affinity_init can be safely called more than once. + !$ call fms_affinity_set('OCEAN', ocean_hyper_thread, ocean_nthreads) + !$ call omp_set_num_threads(ocean_nthreads) + !$OMP PARALLEL + !$ write(6,*) "MOM_domains_mod OMPthreading ", fms_affinity_get(), omp_get_thread_num(), omp_get_num_threads() + !$ flush(6) + !$OMP END PARALLEL +end subroutine set_MOM_thread_affinity + +!> This subroutine retrieves the 1-d domains that make up the 2d-domain in a MOM_domain +subroutine get_domain_components_MD(MOM_dom, x_domain, y_domain) + type(MOM_domain_type), intent(in) :: MOM_dom !< The MOM_domain whose contents are being extracted + type(domain1D), optional, intent(inout) :: x_domain !< The 1-d logical x-domain + type(domain1D), optional, intent(inout) :: y_domain !< The 1-d logical y-domain + + call mpp_get_domain_components(MOM_dom%mpp_domain, x_domain, y_domain) +end subroutine get_domain_components_MD + +!> This subroutine retrieves the 1-d domains that make up a 2d-domain +subroutine get_domain_components_d2D(domain, x_domain, y_domain) + type(domain2D), intent(in) :: domain !< The 2D domain whose contents are being extracted + type(domain1D), optional, intent(inout) :: x_domain !< The 1-d logical x-domain + type(domain1D), optional, intent(inout) :: y_domain !< The 1-d logical y-domain + + call mpp_get_domain_components(domain, x_domain, y_domain) +end subroutine get_domain_components_d2D + +!> clone_MD_to_MD copies one MOM_domain_type into another, while allowing +!! some properties of the new type to differ from the original one. +subroutine clone_MD_to_MD(MD_in, MOM_dom, min_halo, halo_size, symmetric, domain_name, & + turns, refine, extra_halo) + type(MOM_domain_type), intent(in) :: MD_in !< An existing MOM_domain + type(MOM_domain_type), pointer :: MOM_dom !< A pointer to a MOM_domain that will be + !! allocated if it is unassociated, and will have data + !! copied from MD_in + integer, dimension(2), & + optional, intent(inout) :: min_halo !< If present, this sets the + !! minimum halo size for this domain in the i- and j- + !! directions, and returns the actual halo size used. + integer, optional, intent(in) :: halo_size !< If present, this sets the halo + !! size for the domain in the i- and j-directions. + !! min_halo and halo_size can not both be present. + logical, optional, intent(in) :: symmetric !< If present, this specifies + !! whether the new domain is symmetric, regardless of + !! whether the macro SYMMETRIC_MEMORY_ is defined. + character(len=*), & + optional, intent(in) :: domain_name !< A name for the new domain, copied + !! from MD_in if missing. + integer, optional, intent(in) :: turns !< Number of quarter turns + integer, optional, intent(in) :: refine !< A factor by which to enhance the grid resolution. + integer, optional, intent(in) :: extra_halo !< An extra number of points in the halos + !! compared with MD_in + + integer :: global_indices(4) + logical :: mask_table_exists + integer, dimension(:), allocatable :: exni ! The extents of the grid for each i-row of the layout. + ! The sum of exni must equal MOM_dom%niglobal. + integer, dimension(:), allocatable :: exnj ! The extents of the grid for each j-row of the layout. + ! The sum of exni must equal MOM_dom%niglobal. + integer :: qturns ! The number of quarter turns, restricted to the range of 0 to 3. + integer :: i, j, nl1, nl2 + + qturns = 0 + if (present(turns)) qturns = modulo(turns, 4) + + if (.not.associated(MOM_dom)) then + allocate(MOM_dom) + allocate(MOM_dom%mpp_domain) + allocate(MOM_dom%mpp_domain_d2) + endif + +! Save the extra data for creating other domains of different resolution that overlay this domain + MOM_dom%symmetric = MD_in%symmetric + MOM_dom%nonblocking_updates = MD_in%nonblocking_updates + MOM_dom%thin_halo_updates = MD_in%thin_halo_updates + + if (modulo(qturns, 2) /= 0) then + MOM_dom%niglobal = MD_in%njglobal ; MOM_dom%njglobal = MD_in%niglobal + MOM_dom%nihalo = MD_in%njhalo ; MOM_dom%njhalo = MD_in%nihalo + call get_layout_extents(MD_in, exnj, exni) + + MOM_dom%X_FLAGS = MD_in%Y_FLAGS ; MOM_dom%Y_FLAGS = MD_in%X_FLAGS + MOM_dom%layout(:) = MD_in%layout(2:1:-1) + MOM_dom%io_layout(:) = MD_in%io_layout(2:1:-1) + else + MOM_dom%niglobal = MD_in%niglobal ; MOM_dom%njglobal = MD_in%njglobal + MOM_dom%nihalo = MD_in%nihalo ; MOM_dom%njhalo = MD_in%njhalo + call get_layout_extents(MD_in, exni, exnj) + + MOM_dom%X_FLAGS = MD_in%X_FLAGS ; MOM_dom%Y_FLAGS = MD_in%Y_FLAGS + MOM_dom%layout(:) = MD_in%layout(:) + MOM_dom%io_layout(:) = MD_in%io_layout(:) + endif + + ! Ensure that the points per processor are the same on the source and densitation grids. + select case (qturns) + case (1) ; call invert(exni) + case (2) ; call invert(exni) ; call invert(exnj) + case (3) ; call invert(exnj) + end select + + if (associated(MD_in%maskmap)) then + mask_table_exists = .true. + allocate(MOM_dom%maskmap(MOM_dom%layout(1), MOM_dom%layout(2))) + + nl1 = MOM_dom%layout(1) ; nl2 = MOM_dom%layout(2) + select case (qturns) + case (0) + do j=1,nl2 ; do i=1,nl1 + MOM_dom%maskmap(i,j) = MD_in%maskmap(i, j) + enddo ; enddo + case (1) + do j=1,nl2 ; do i=1,nl1 + MOM_dom%maskmap(i,j) = MD_in%maskmap(j, nl1+1-i) + enddo ; enddo + case (2) + do j=1,nl2 ; do i=1,nl1 + MOM_dom%maskmap(i,j) = MD_in%maskmap(nl1+1-i, nl2+1-j) + enddo ; enddo + case (3) + do j=1,nl2 ; do i=1,nl1 + MOM_dom%maskmap(i,j) = MD_in%maskmap(nl2+1-j, i) + enddo ; enddo + end select + else + mask_table_exists = .false. + endif + + ! Optionally enhance the grid resolution. + if (present(refine)) then ; if (refine > 1) then + MOM_dom%niglobal = refine*MOM_dom%niglobal ; MOM_dom%njglobal = refine*MOM_dom%njglobal + MOM_dom%nihalo = refine*MOM_dom%nihalo ; MOM_dom%njhalo = refine*MOM_dom%njhalo + do i=1,MOM_dom%layout(1) ; exni(i) = refine*exni(i) ; enddo + do j=1,MOM_dom%layout(2) ; exnj(j) = refine*exnj(j) ; enddo + endif ; endif + + ! Optionally enhance the grid resolution. + if (present(extra_halo)) then ; if (extra_halo > 0) then + MOM_dom%nihalo = MOM_dom%nihalo + extra_halo ; MOM_dom%njhalo = MOM_dom%njhalo + extra_halo + endif ; endif + + if (present(halo_size) .and. present(min_halo)) call MOM_error(FATAL, & + "clone_MOM_domain can not have both halo_size and min_halo present.") + + if (present(min_halo)) then + MOM_dom%nihalo = max(MOM_dom%nihalo, min_halo(1)) + min_halo(1) = MOM_dom%nihalo + MOM_dom%njhalo = max(MOM_dom%njhalo, min_halo(2)) + min_halo(2) = MOM_dom%njhalo + endif + + if (present(halo_size)) then + MOM_dom%nihalo = halo_size ; MOM_dom%njhalo = halo_size + endif + + if (present(symmetric)) then ; MOM_dom%symmetric = symmetric ; endif + + if (present(domain_name)) then + MOM_dom%name = trim(domain_name) + else + MOM_dom%name = MD_in%name + endif + + call clone_MD_to_d2D(MOM_dom, MOM_dom%mpp_domain, xextent=exni, yextent=exnj) + + call clone_MD_to_d2D(MOM_dom, MOM_dom%mpp_domain_d2, domain_name=MOM_dom%name, coarsen=2) + +end subroutine clone_MD_to_MD + + +!> clone_MD_to_d2D uses information from a MOM_domain_type to create a new +!! domain2d type, while allowing some properties of the new type to differ from +!! the original one. +subroutine clone_MD_to_d2D(MD_in, mpp_domain, min_halo, halo_size, symmetric, & + domain_name, turns, xextent, yextent, coarsen) + type(MOM_domain_type), intent(in) :: MD_in !< An existing MOM_domain to be cloned + type(domain2d), intent(inout) :: mpp_domain !< The new mpp_domain to be set up + integer, dimension(2), & + optional, intent(inout) :: min_halo !< If present, this sets the + !! minimum halo size for this domain in the i- and j- + !! directions, and returns the actual halo size used. + integer, optional, intent(in) :: halo_size !< If present, this sets the halo + !! size for the domain in the i- and j-directions. + !! min_halo and halo_size can not both be present. + logical, optional, intent(in) :: symmetric !< If present, this specifies + !! whether the new domain is symmetric, regardless of + !! whether the macro SYMMETRIC_MEMORY_ is defined or + !! whether MD_in is symmetric. + character(len=*), & + optional, intent(in) :: domain_name !< A name for the new domain, "MOM" + !! if missing. + integer, optional, intent(in) :: turns !< Number of quarter turns - not implemented here. + integer, optional, intent(in) :: coarsen !< A factor by which to coarsen this grid. + !! The default of 1 is for no coarsening. + integer, dimension(:), optional, intent(in) :: xextent !< The number of grid points in the + !! tracer computational domain for division of the x-layout. + integer, dimension(:), optional, intent(in) :: yextent !< The number of grid points in the + !! tracer computational domain for division of the y-layout. + + integer :: global_indices(4) + integer :: nihalo, njhalo + logical :: symmetric_dom, do_coarsen + character(len=64) :: dom_name + + if (present(turns)) & + call MOM_error(FATAL, "Rotation not supported for MOM_domain to domain2d") + + if (present(halo_size) .and. present(min_halo)) call MOM_error(FATAL, & + "clone_MOM_domain can not have both halo_size and min_halo present.") + + do_coarsen = .false. ; if (present(coarsen)) then ; do_coarsen = (coarsen > 1) ; endif + + nihalo = MD_in%nihalo ; njhalo = MD_in%njhalo + if (do_coarsen) then + nihalo = int(MD_in%nihalo / coarsen) ; njhalo = int(MD_in%njhalo / coarsen) + endif + + if (present(min_halo)) then + nihalo = max(nihalo, min_halo(1)) + njhalo = max(njhalo, min_halo(2)) + min_halo(1) = nihalo ; min_halo(2) = njhalo + endif + if (present(halo_size)) then + nihalo = halo_size ; njhalo = halo_size + endif + + symmetric_dom = MD_in%symmetric + if (present(symmetric)) then ; symmetric_dom = symmetric ; endif + + dom_name = MD_in%name + if (do_coarsen) dom_name = trim(MD_in%name)//"c" + if (present(domain_name)) dom_name = trim(domain_name) + + global_indices(1:4) = (/ 1, MD_in%niglobal, 1, MD_in%njglobal /) + if (do_coarsen) then + global_indices(1:4) = (/ 1, (MD_in%niglobal/coarsen), 1, (MD_in%njglobal/coarsen) /) + endif + + if (associated(MD_in%maskmap)) then + call mpp_define_domains( global_indices, MD_in%layout, mpp_domain, & + xflags=MD_in%X_FLAGS, yflags=MD_in%Y_FLAGS, xhalo=nihalo, yhalo=njhalo, & + xextent=xextent, yextent=yextent, symmetry=symmetric_dom, name=dom_name, & + maskmap=MD_in%maskmap ) + else + call mpp_define_domains( global_indices, MD_in%layout, mpp_domain, & + xflags=MD_in%X_FLAGS, yflags=MD_in%Y_FLAGS, xhalo=nihalo, yhalo=njhalo, & + symmetry=symmetric_dom, xextent=xextent, yextent=yextent, name=dom_name) + endif + + if ((MD_in%io_layout(1) + MD_in%io_layout(2) > 0) .and. & + (MD_in%layout(1)*MD_in%layout(2) > 1)) then + call mpp_define_io_domain(mpp_domain, MD_in%io_layout) + endif + +end subroutine clone_MD_to_d2D + +!> Returns the index ranges that have been stored in a MOM_domain_type +subroutine get_domain_extent_MD(Domain, isc, iec, jsc, jec, isd, ied, jsd, jed, & + isg, ieg, jsg, jeg, idg_offset, jdg_offset, & + symmetric, local_indexing, index_offset, coarsen) + type(MOM_domain_type), & + intent(in) :: Domain !< The MOM domain from which to extract information + integer, intent(out) :: isc !< The start i-index of the computational domain + integer, intent(out) :: iec !< The end i-index of the computational domain + integer, intent(out) :: jsc !< The start j-index of the computational domain + integer, intent(out) :: jec !< The end j-index of the computational domain + integer, intent(out) :: isd !< The start i-index of the data domain + integer, intent(out) :: ied !< The end i-index of the data domain + integer, intent(out) :: jsd !< The start j-index of the data domain + integer, intent(out) :: jed !< The end j-index of the data domain + integer, optional, intent(out) :: isg !< The start i-index of the global domain + integer, optional, intent(out) :: ieg !< The end i-index of the global domain + integer, optional, intent(out) :: jsg !< The start j-index of the global domain + integer, optional, intent(out) :: jeg !< The end j-index of the global domain + integer, optional, intent(out) :: idg_offset !< The offset between the corresponding global and + !! data i-index spaces. + integer, optional, intent(out) :: jdg_offset !< The offset between the corresponding global and + !! data j-index spaces. + logical, optional, intent(out) :: symmetric !< True if symmetric memory is used. + logical, optional, intent(in) :: local_indexing !< If true, local tracer array indices start at 1, + !! as in most MOM6 code. The default is true. + integer, optional, intent(in) :: index_offset !< A fixed additional offset to all indices. This + !! can be useful for some types of debugging with + !! dynamic memory allocation. The default is 0. + integer, optional, intent(in) :: coarsen !< A factor by which the grid is coarsened. + !! The default is 1, for no coarsening. + + ! Local variables + integer :: isg_, ieg_, jsg_, jeg_ + integer :: ind_off, idg_off, jdg_off, coarsen_lev + logical :: local + + local = .true. ; if (present(local_indexing)) local = local_indexing + ind_off = 0 ; if (present(index_offset)) ind_off = index_offset + + coarsen_lev = 1 ; if (present(coarsen)) coarsen_lev = coarsen + + if (coarsen_lev == 1) then + call mpp_get_compute_domain(Domain%mpp_domain, isc, iec, jsc, jec) + call mpp_get_data_domain(Domain%mpp_domain, isd, ied, jsd, jed) + call mpp_get_global_domain(Domain%mpp_domain, isg_, ieg_, jsg_, jeg_) + elseif (coarsen_lev == 2) then + if (.not.associated(Domain%mpp_domain_d2)) call MOM_error(FATAL, & + "get_domain_extent called with coarsen=2, but Domain%mpp_domain_d2 is not associated.") + call mpp_get_compute_domain(Domain%mpp_domain_d2, isc, iec, jsc, jec) + call mpp_get_data_domain(Domain%mpp_domain_d2, isd, ied, jsd, jed) + call mpp_get_global_domain(Domain%mpp_domain_d2, isg_, ieg_, jsg_, jeg_) + else + call MOM_error(FATAL, "get_domain_extent called with an unsupported level of coarsening.") + endif + + if (local) then + ! This code institutes the MOM convention that local array indices start at 1. + idg_off = isd - 1 ; jdg_off = jsd - 1 + isc = isc - isd + 1 ; iec = iec - isd + 1 ; jsc = jsc - jsd + 1 ; jec = jec - jsd + 1 + ied = ied - isd + 1 ; jed = jed - jsd + 1 + isd = 1 ; jsd = 1 + else + idg_off = 0 ; jdg_off = 0 + endif + if (ind_off /= 0) then + idg_off = idg_off + ind_off ; jdg_off = jdg_off + ind_off + isc = isc + ind_off ; iec = iec + ind_off + jsc = jsc + ind_off ; jec = jec + ind_off + isd = isd + ind_off ; ied = ied + ind_off + jsd = jsd + ind_off ; jed = jed + ind_off + endif + if (present(isg)) isg = isg_ + if (present(ieg)) ieg = ieg_ + if (present(jsg)) jsg = jsg_ + if (present(jeg)) jeg = jeg_ + if (present(idg_offset)) idg_offset = idg_off + if (present(jdg_offset)) jdg_offset = jdg_off + if (present(symmetric)) symmetric = Domain%symmetric + +end subroutine get_domain_extent_MD + +!> Returns the index ranges that have been stored in a domain2D type +subroutine get_domain_extent_d2D(Domain, isc, iec, jsc, jec, isd, ied, jsd, jed) + type(domain2d), intent(in) :: Domain !< The MOM domain from which to extract information + integer, intent(out) :: isc !< The start i-index of the computational domain + integer, intent(out) :: iec !< The end i-index of the computational domain + integer, intent(out) :: jsc !< The start j-index of the computational domain + integer, intent(out) :: jec !< The end j-index of the computational domain + integer, optional, intent(out) :: isd !< The start i-index of the data domain + integer, optional, intent(out) :: ied !< The end i-index of the data domain + integer, optional, intent(out) :: jsd !< The start j-index of the data domain + integer, optional, intent(out) :: jed !< The end j-index of the data domain + + ! Local variables + integer :: isd_, ied_, jsd_, jed_, jsg_, jeg_, isg_, ieg_ + + call mpp_get_compute_domain(Domain, isc, iec, jsc, jec) + call mpp_get_data_domain(Domain, isd_, ied_, jsd_, jed_) + + if (present(isd)) isd = isd_ + if (present(ied)) ied = ied_ + if (present(jsd)) jsd = jsd_ + if (present(jed)) jed = jed_ + +end subroutine get_domain_extent_d2D + +!> Return the (potentially symmetric) computational domain i-bounds for an array +!! passed without index specifications (i.e. indices start at 1) based on an array size. +subroutine get_simple_array_i_ind(domain, size, is, ie, symmetric) + type(MOM_domain_type), intent(in) :: domain !< MOM domain from which to extract information + integer, intent(in) :: size !< The i-array size + integer, intent(out) :: is !< The computational domain starting i-index. + integer, intent(out) :: ie !< The computational domain ending i-index. + logical, optional, intent(in) :: symmetric !< If present, indicates whether symmetric sizes + !! can be considered. + ! Local variables + logical :: sym + character(len=120) :: mesg, mesg2 + integer :: isc, iec, jsc, jec, isd, ied, jsd, jed + + call mpp_get_compute_domain(Domain%mpp_domain, isc, iec, jsc, jec) + call mpp_get_data_domain(Domain%mpp_domain, isd, ied, jsd, jed) + + isc = isc-isd+1 ; iec = iec-isd+1 ; ied = ied-isd+1 ; isd = 1 + sym = Domain%symmetric ; if (present(symmetric)) sym = symmetric + + if (size == ied) then ; is = isc ; ie = iec + elseif (size == 1+iec-isc) then ; is = 1 ; ie = size + elseif (sym .and. (size == 1+ied)) then ; is = isc ; ie = iec+1 + elseif (sym .and. (size == 2+iec-isc)) then ; is = 1 ; ie = size+1 + else + write(mesg,'("Unrecognized size ", i6, "in call to get_simple_array_i_ind. \")') size + if (sym) then + write(mesg2,'("Valid sizes are : ", 2i7)') ied, 1+iec-isc + else + write(mesg2,'("Valid sizes are : ", 4i7)') ied, 1+iec-isc, 1+ied, 2+iec-isc + endif + call MOM_error(FATAL, trim(mesg)//trim(mesg2)) + endif + +end subroutine get_simple_array_i_ind + + +!> Return the (potentially symmetric) computational domain j-bounds for an array +!! passed without index specifications (i.e. indices start at 1) based on an array size. +subroutine get_simple_array_j_ind(domain, size, js, je, symmetric) + type(MOM_domain_type), intent(in) :: domain !< MOM domain from which to extract information + integer, intent(in) :: size !< The j-array size + integer, intent(out) :: js !< The computational domain starting j-index. + integer, intent(out) :: je !< The computational domain ending j-index. + logical, optional, intent(in) :: symmetric !< If present, indicates whether symmetric sizes + !! can be considered. + ! Local variables + logical :: sym + character(len=120) :: mesg, mesg2 + integer :: isc, iec, jsc, jec, isd, ied, jsd, jed + + call mpp_get_compute_domain(Domain%mpp_domain, isc, iec, jsc, jec) + call mpp_get_data_domain(Domain%mpp_domain, isd, ied, jsd, jed) + + jsc = jsc-jsd+1 ; jec = jec-jsd+1 ; jed = jed-jsd+1 ; jsd = 1 + sym = Domain%symmetric ; if (present(symmetric)) sym = symmetric + + if (size == jed) then ; js = jsc ; je = jec + elseif (size == 1+jec-jsc) then ; js = 1 ; je = size + elseif (sym .and. (size == 1+jed)) then ; js = jsc ; je = jec+1 + elseif (sym .and. (size == 2+jec-jsc)) then ; js = 1 ; je = size+1 + else + write(mesg,'("Unrecognized size ", i6, "in call to get_simple_array_j_ind. \")') size + if (sym) then + write(mesg2,'("Valid sizes are : ", 2i7)') jed, 1+jec-jsc + else + write(mesg2,'("Valid sizes are : ", 4i7)') jed, 1+jec-jsc, 1+jed, 2+jec-jsc + endif + call MOM_error(FATAL, trim(mesg)//trim(mesg2)) + endif + +end subroutine get_simple_array_j_ind + +!> Invert the contents of a 1-d array +subroutine invert(array) + integer, dimension(:), intent(inout) :: array !< The 1-d array to invert + integer :: i, ni, swap + ni = size(array) + do i=1,ni + swap = array(i) + array(i) = array(ni+1-i) + array(ni+1-i) = swap + enddo +end subroutine invert + +!> Returns the global shape of h-point arrays +subroutine get_global_shape(domain, niglobal, njglobal) + type(MOM_domain_type), intent(in) :: domain !< MOM domain from which to extract information + integer, intent(out) :: niglobal !< i-index global size of h-point arrays + integer, intent(out) :: njglobal !< j-index global size of h-point arrays + + niglobal = domain%niglobal + njglobal = domain%njglobal +end subroutine get_global_shape + +!> Get the array ranges in one dimension for the divisions of a global index space +subroutine compute_block_extent(isg, ieg, ndivs, ibegin, iend) + integer, intent(in) :: isg !< The starting index of the global index space + integer, intent(in) :: ieg !< The ending index of the global index space + integer, intent(in) :: ndivs !< The number of divisions + integer, dimension(:), intent(out) :: ibegin !< The starting index of each division + integer, dimension(:), intent(out) :: iend !< The ending index of each division + + call mpp_compute_block_extent(isg, ieg, ndivs, ibegin, iend) +end subroutine compute_block_extent + +!> Broadcast a 2-d domain from the root PE to the other PEs +subroutine broadcast_domain(domain) + type(domain2d), intent(inout) :: domain !< The domain2d type that will be shared across PEs. + + call mpp_broadcast_domain(domain) +end subroutine broadcast_domain + +!> Broadcast an entire 2-d array from the root processor to all others. +subroutine global_field(domain, local, global) + type(domain2d), intent(inout) :: domain !< The domain2d type that describes the decomposition + real, dimension(:,:), intent(in) :: local !< The portion of the array on the local PE + real, dimension(:,:), intent(out) :: global !< The whole global array + + call mpp_global_field(domain, local, global) +end subroutine global_field + +!> Returns arrays of the i- and j- sizes of the h-point computational domains for each +!! element of the grid layout. Any input values in the extent arrays are discarded, so +!! they are effectively intent out despite their declared intent of inout. +subroutine get_layout_extents(Domain, extent_i, extent_j) + type(MOM_domain_type), intent(in) :: domain !< MOM domain from which to extract information + integer, dimension(:), allocatable, intent(inout) :: extent_i !< The number of points in the + !! i-direction in each i-row of the layout + integer, dimension(:), allocatable, intent(inout) :: extent_j !< The number of points in the + !! j-direction in each j-row of the layout + + if (allocated(extent_i)) deallocate(extent_i) + if (allocated(extent_j)) deallocate(extent_j) + allocate(extent_i(domain%layout(1))) ; extent_i(:) = 0 + allocate(extent_j(domain%layout(2))) ; extent_j(:) = 0 + call mpp_get_domain_extents(domain%mpp_domain, extent_i, extent_j) +end subroutine get_layout_extents + +end module MOM_domain_infra diff --git a/config_src/infra/FMS2/MOM_ensemble_manager_infra.F90 b/config_src/infra/FMS2/MOM_ensemble_manager_infra.F90 new file mode 100644 index 0000000000..66bbb86e2f --- /dev/null +++ b/config_src/infra/FMS2/MOM_ensemble_manager_infra.F90 @@ -0,0 +1,95 @@ +!> A simple (very thin) wrapper for managing ensemble member layout information +module MOM_ensemble_manager_infra + +! This file is part of MOM6. See LICENSE.md for the license. + +use ensemble_manager_mod, only : FMS_ensemble_manager_init => ensemble_manager_init +use ensemble_manager_mod, only : FMS_ensemble_pelist_setup => ensemble_pelist_setup +use ensemble_manager_mod, only : FMS_get_ensemble_id => get_ensemble_id +use ensemble_manager_mod, only : FMS_get_ensemble_size => get_ensemble_size +use ensemble_manager_mod, only : FMS_get_ensemble_pelist => get_ensemble_pelist +use ensemble_manager_mod, only : FMS_get_ensemble_filter_pelist => get_ensemble_filter_pelist + +implicit none ; private + +public :: ensemble_manager_init, ensemble_pelist_setup +public :: get_ensemble_id, get_ensemble_size +public :: get_ensemble_pelist, get_ensemble_filter_pelist + +contains + +!> Initializes the ensemble manager which divides available resources +!! in order to concurrently execute an ensemble of model realizations. +subroutine ensemble_manager_init() + + call FMS_ensemble_manager_init() + +end subroutine ensemble_manager_init + +!> Create a list of processing elements (PEs) across components +!! associated with the current ensemble member. +subroutine ensemble_pelist_setup(concurrent, atmos_npes, ocean_npes, land_npes, ice_npes, & + Atm_pelist, Ocean_pelist, Land_pelist, Ice_pelist) + logical, intent(in) :: concurrent !< A logical flag, if True, then ocean fast + !! PEs are run concurrently with + !! slow PEs within the coupler. + integer, intent(in) :: atmos_npes !< The number of atmospheric (fast) PEs + integer, intent(in) :: ocean_npes !< The number of ocean (slow) PEs + integer, intent(in) :: land_npes !< The number of land PEs (fast) + integer, intent(in) :: ice_npes !< The number of ice (fast) PEs + integer, dimension(:), intent(inout) :: Atm_pelist !< A list of Atm PEs + integer, dimension(:), intent(inout) :: Ocean_pelist !< A list of Ocean PEs + integer, dimension(:), intent(inout) :: Land_pelist !< A list of Land PEs + integer, dimension(:), intent(inout) :: Ice_pelist !< A list of Ice PEs + + + call FMS_ensemble_pelist_setup(concurrent, atmos_npes, ocean_npes, land_npes, ice_npes, & + Atm_pelist, Ocean_pelist, Land_pelist, Ice_pelist) + +end subroutine ensemble_pelist_setup + +!> Returns the numeric id for the current ensemble member +function get_ensemble_id() + integer :: get_ensemble_id + + get_ensemble_id = FMS_get_ensemble_id() + +end function get_ensemble_id + +!> Returns ensemble information as follows, +!! index (1) :: ensemble size +!! index (2) :: Number of PEs per ensemble member +!! index (3) :: Number of ocean PEs per ensemble member +!! index (4) :: Number of atmos PEs per ensemble member +!! index (5) :: Number of land PEs per ensemble member +!! index (6) :: Number of ice PEs per ensemble member +function get_ensemble_size() + integer, dimension(6) :: get_ensemble_size + + get_ensemble_size = FMS_get_ensemble_size() + +end function get_ensemble_size + +!> Returns the list of PEs associated with all ensemble members +!! Results are stored in the argument array which must be large +!! enough to contain the list. If the optional name argument is present, +!! the returned processor list are for a particular component (atmos, ocean ,land, ice) +subroutine get_ensemble_pelist(pelist, name) + integer, intent(inout) :: pelist(:,:) !< A processor list for all ensemble members + character(len=*), optional, intent(in) :: name !< An optional component name (atmos, ocean, land, ice) + + call FMS_get_ensemble_pelist(pelist, name) + +end subroutine get_ensemble_pelist + +!> Returns the list of PEs associated with the named ensemble filter application. +!! Valid component names include ('atmos', 'ocean', 'land', and 'ice') +subroutine get_ensemble_filter_pelist(pelist, name) + integer, intent(inout) :: pelist(:) !< A processor list for the ensemble filter + character(len=*), intent(in) :: name !< The component name (atmos, ocean, land, ice) + + call FMS_get_Ensemble_filter_pelist(pelist, name) + +end subroutine get_ensemble_filter_pelist + +end module MOM_ensemble_manager_infra diff --git a/config_src/infra/FMS2/MOM_error_infra.F90 b/config_src/infra/FMS2/MOM_error_infra.F90 new file mode 100644 index 0000000000..e5a8b8dc68 --- /dev/null +++ b/config_src/infra/FMS2/MOM_error_infra.F90 @@ -0,0 +1,42 @@ +!> Routines for error handling and I/O management +module MOM_error_infra + +! This file is part of MOM6. See LICENSE.md for the license. + +use mpp_mod, only : mpp_error, mpp_pe, mpp_root_pe, mpp_stdlog=>stdlog, mpp_stdout=>stdout +use mpp_mod, only : NOTE, WARNING, FATAL + +implicit none ; private + +public :: MOM_err, is_root_pe, stdlog, stdout +!> Integer parameters encoding the severity of an error message +public :: NOTE, WARNING, FATAL + +contains + +!> MOM_err writes an error message, and may cause the run to stop depending on the +!! severity of the error. +subroutine MOM_err(severity, message) + integer, intent(in) :: severity !< The severity level of this error + character(len=*), intent(in) :: message !< A message to write out + + call mpp_error(severity, message) +end subroutine MOM_err + +!> stdout returns the standard Fortran unit number for output +integer function stdout() + stdout = mpp_stdout() +end function stdout + +!> stdlog returns the standard Fortran unit number to use to log messages +integer function stdlog() + stdlog = mpp_stdlog() +end function stdlog + +!> is_root_pe returns .true. if the current PE is the root PE. +logical function is_root_pe() + is_root_pe = .false. + if (mpp_pe() == mpp_root_pe()) is_root_pe = .true. +end function is_root_pe + +end module MOM_error_infra diff --git a/config_src/infra/FMS2/MOM_interp_infra.F90 b/config_src/infra/FMS2/MOM_interp_infra.F90 new file mode 100644 index 0000000000..ca5b2b8516 --- /dev/null +++ b/config_src/infra/FMS2/MOM_interp_infra.F90 @@ -0,0 +1,251 @@ +!> This module wraps the FMS temporal and spatial interpolation routines +module MOM_interp_infra + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_domain_infra, only : MOM_domain_type, domain2d +use MOM_io_infra, only : axistype +use MOM_time_manager, only : time_type +use horiz_interp_mod, only : horiz_interp_new, horiz_interp, horiz_interp_init, horiz_interp_type +use time_interp_external_mod, only : time_interp_external +use time_interp_external_mod, only : init_external_field, time_interp_external_init +use time_interp_external_mod, only : get_external_field_size +use time_interp_external_mod, only : get_external_field_axes, get_external_field_missing + +implicit none ; private + +public :: horiz_interp_type, horiz_interp_init +public :: time_interp_extern, init_extern_field, time_interp_external_init +public :: get_external_field_info +public :: run_horiz_interp, build_horiz_interp_weights + +!> Read a field based on model time, and rotate to the model domain. +interface time_interp_extern + module procedure time_interp_extern_0d + module procedure time_interp_extern_2d + module procedure time_interp_extern_3d +end interface time_interp_extern + +!> perform horizontal interpolation of field +interface run_horiz_interp + module procedure horiz_interp_from_weights_field2d + module procedure horiz_interp_from_weights_field3d +end interface + +!> build weights for horizontal interpolation of field +interface build_horiz_interp_weights + module procedure build_horiz_interp_weights_2d_to_2d +end interface build_horiz_interp_weights + +contains + +!> perform horizontal interpolation of a 2d field using pre-computed weights +!! source and destination coordinates are 2d +subroutine horiz_interp_from_weights_field2d(Interp, data_in, data_out, verbose, mask_in, mask_out, & + missing_value, missing_permit, err_msg) + + type(horiz_interp_type), intent(in) :: Interp !< type containing interpolation options and weights + real, dimension(:,:), intent(in) :: data_in !< input data + real, dimension(:,:), intent(out) :: data_out !< output data + integer, optional, intent(in) :: verbose !< verbosity level + real, dimension(:,:), optional, intent(in) :: mask_in !< mask for input data + real, dimension(:,:), optional, intent(out) :: mask_out !< mask for output data + real, optional, intent(in) :: missing_value !< A value indicating missing data + integer, optional, intent(in) :: missing_permit !< number of allowed points with + !! missing value for interpolation (0-3) + character(len=*), optional, intent(out) :: err_msg !< error message + + call horiz_interp(Interp, data_in, data_out, verbose, & + mask_in, mask_out, missing_value, missing_permit, & + err_msg, new_missing_handle=.true. ) + +end subroutine horiz_interp_from_weights_field2d + + +!> perform horizontal interpolation of a 3d field using pre-computed weights +!! source and destination coordinates are 2d +subroutine horiz_interp_from_weights_field3d(Interp, data_in, data_out, verbose, mask_in, mask_out, & + missing_value, missing_permit, err_msg) + + type(horiz_interp_type), intent(in) :: Interp !< type containing interpolation options and weights + real, dimension(:,:,:), intent(in) :: data_in !< input data + real, dimension(:,:,:), intent(out) :: data_out !< output data + integer, optional, intent(in) :: verbose !< verbosity level + real, dimension(:,:,:), optional, intent(in) :: mask_in !< mask for input data + real, dimension(:,:,:), optional, intent(out) :: mask_out !< mask for output data + real, optional, intent(in) :: missing_value !< A value indicating missing data + integer, optional, intent(in) :: missing_permit !< number of allowed points with + !! missing value for interpolation (0-3) + character(len=*), optional, intent(out) :: err_msg !< error message + + call horiz_interp(Interp, data_in, data_out, verbose, mask_in, mask_out, & + missing_value, missing_permit, err_msg) + +end subroutine horiz_interp_from_weights_field3d + + +!> build horizontal interpolation weights from source grid defined by 2d lon/lat to destination grid +!! defined by 2d lon/lat +subroutine build_horiz_interp_weights_2d_to_2d(Interp, lon_in, lat_in, lon_out, lat_out, & + verbose, interp_method, num_nbrs, max_dist, & + src_modulo, mask_in, mask_out, & + is_latlon_in, is_latlon_out) + + type(horiz_interp_type), intent(inout) :: Interp !< type containing interpolation options and weights + real, dimension(:,:), intent(in) :: lon_in !< input longitude 2d + real, dimension(:,:), intent(in) :: lat_in !< input latitude 2d + real, dimension(:,:), intent(in) :: lon_out !< output longitude 2d + real, dimension(:,:), intent(in) :: lat_out !< output latitude 2d + integer, optional, intent(in) :: verbose !< verbosity level + character(len=*), optional, intent(in) :: interp_method !< interpolation method + integer, optional, intent(in) :: num_nbrs !< number of nearest neighbors + real, optional, intent(in) :: max_dist !< maximum region of influence + logical, optional, intent(in) :: src_modulo !< periodicity of E-W boundary + real, dimension(:,:), optional, intent(in) :: mask_in !< mask for input data + real, dimension(:,:), optional, intent(inout) :: mask_out !< mask for output data + logical, optional, intent(in) :: is_latlon_in !< input grid is regular lat/lon grid + logical, optional, intent(in) :: is_latlon_out !< output grid is regular lat/lon grid + + call horiz_interp_new(Interp, lon_in, lat_in, lon_out, lat_out, & + verbose, interp_method, num_nbrs, max_dist, & + src_modulo, mask_in, mask_out, & + is_latlon_in, is_latlon_out) + +end subroutine build_horiz_interp_weights_2d_to_2d + + +!> get size of an external field from field index +function get_extern_field_size(index) + + integer, intent(in) :: index !< field index + integer :: get_extern_field_size(4) !< field size + + get_extern_field_size = get_external_field_size(index) + +end function get_extern_field_size + + +!> get axes of an external field from field index +function get_extern_field_axes(index) + + integer, intent(in) :: index !< field index + type(axistype), dimension(4) :: get_extern_field_axes !< field axes + + get_extern_field_axes = get_external_field_axes(index) + +end function get_extern_field_axes + + +!> get missing value of an external field from field index +function get_extern_field_missing(index) + + integer, intent(in) :: index !< field index + real :: get_extern_field_missing !< field missing value + + get_extern_field_missing = get_external_field_missing(index) + +end function get_extern_field_missing + + +!> Get information about the external fields. +subroutine get_external_field_info(field_id, size, axes, missing) + integer, intent(in) :: field_id !< The integer index of the external + !! field returned from a previous + !! call to init_external_field() + integer, dimension(4), optional, intent(inout) :: size !< Dimension sizes for the input data + type(axistype), dimension(4), optional, intent(inout) :: axes !< Axis types for the input data + real, optional, intent(inout) :: missing !< Missing value for the input data + + if (present(size)) then + size(1:4) = get_extern_field_size(field_id) + endif + + if (present(axes)) then + axes(1:4) = get_extern_field_axes(field_id) + endif + + if (present(missing)) then + missing = get_extern_field_missing(field_id) + endif + +end subroutine get_external_field_info + + +!> Read a scalar field based on model time. +subroutine time_interp_extern_0d(field_id, time, data_in, verbose) + integer, intent(in) :: field_id !< The integer index of the external field returned + !! from a previous call to init_external_field() + type(time_type), intent(in) :: time !< The target time for the data + real, intent(inout) :: data_in !< The interpolated value + logical, optional, intent(in) :: verbose !< If true, write verbose output for debugging + + call time_interp_external(field_id, time, data_in, verbose=verbose) +end subroutine time_interp_extern_0d + + +!> Read a 2d field from an external based on model time, potentially including horizontal +!! interpolation and rotation of the data +subroutine time_interp_extern_2d(field_id, time, data_in, interp, verbose, horz_interp, mask_out) + integer, intent(in) :: field_id !< The integer index of the external field returned + !! from a previous call to init_external_field() + type(time_type), intent(in) :: time !< The target time for the data + real, dimension(:,:), intent(inout) :: data_in !< The array in which to store the interpolated values + integer, optional, intent(in) :: interp !< A flag indicating the temporal interpolation method + logical, optional, intent(in) :: verbose !< If true, write verbose output for debugging + type(horiz_interp_type), & + optional, intent(in) :: horz_interp !< A structure to control horizontal interpolation + logical, dimension(:,:), & + optional, intent(out) :: mask_out !< An array that is true where there is valid data + + call time_interp_external(field_id, time, data_in, interp=interp, verbose=verbose, & + horz_interp=horz_interp, mask_out=mask_out) +end subroutine time_interp_extern_2d + + +!> Read a 3d field based on model time, and rotate to the model grid +subroutine time_interp_extern_3d(field_id, time, data_in, interp, verbose, horz_interp, mask_out) + integer, intent(in) :: field_id !< The integer index of the external field returned + !! from a previous call to init_external_field() + type(time_type), intent(in) :: time !< The target time for the data + real, dimension(:,:,:), intent(inout) :: data_in !< The array in which to store the interpolated values + integer, optional, intent(in) :: interp !< A flag indicating the temporal interpolation method + logical, optional, intent(in) :: verbose !< If true, write verbose output for debugging + type(horiz_interp_type), & + optional, intent(in) :: horz_interp !< A structure to control horizontal interpolation + logical, dimension(:,:,:), & + optional, intent(out) :: mask_out !< An array that is true where there is valid data + + call time_interp_external(field_id, time, data_in, interp=interp, verbose=verbose, & + horz_interp=horz_interp, mask_out=mask_out) +end subroutine time_interp_extern_3d + + +!> initialize an external field +integer function init_extern_field(file, fieldname, MOM_domain, domain, verbose, & + threading, ierr, ignore_axis_atts ) + + character(len=*), intent(in) :: file !< The name of the file to read + character(len=*), intent(in) :: fieldname !< The name of the field in the file + integer, optional, intent(in) :: threading !< A flag specifying whether the root PE reads + !! the data and broadcasts it (SINGLE_FILE) or all + !! processors read (MULTIPLE, the default). + logical, optional, intent(in) :: verbose !< If true, write verbose output for debugging + type(domain2d), optional, intent(in) :: domain !< A domain2d type that describes the decomposition + type(MOM_domain_type), & + optional, intent(in) :: MOM_Domain !< A MOM_Domain that describes the decomposition + integer, optional, intent(out) :: ierr !< Returns a non-zero error code in case of failure + logical, optional, intent(in) :: ignore_axis_atts !< If present and true, do not issue a + !! fatal error if the axis Cartesian attribute is + !! not set to a recognized value. + + if (present(MOM_Domain)) then + init_extern_field = init_external_field(file, fieldname, domain=MOM_domain%mpp_domain, & + verbose=verbose, threading=threading, ierr=ierr, ignore_axis_atts=ignore_axis_atts) + else + init_extern_field = init_external_field(file, fieldname, domain=domain, & + verbose=verbose, threading=threading, ierr=ierr, ignore_axis_atts=ignore_axis_atts) + endif + +end function init_extern_field + +end module MOM_interp_infra diff --git a/config_src/infra/FMS2/MOM_io_infra.F90 b/config_src/infra/FMS2/MOM_io_infra.F90 new file mode 100644 index 0000000000..3ea201235a --- /dev/null +++ b/config_src/infra/FMS2/MOM_io_infra.F90 @@ -0,0 +1,801 @@ +!> This module contains a thin inteface to mpp and fms I/O code +module MOM_io_infra + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_domain_infra, only : MOM_domain_type, rescale_comp_data, AGRID, BGRID_NE, CGRID_NE +use MOM_domain_infra, only : domain2d, domain1d, CENTER, CORNER, NORTH_FACE, EAST_FACE +use MOM_error_infra, only : MOM_error=>MOM_err, NOTE, FATAL, WARNING + +use fms_mod, only : write_version_number, open_namelist_file, check_nml_error +use fms_io_mod, only : file_exist, field_exist, field_size, read_data +use fms_io_mod, only : fms_io_exit, get_filename_appendix +use mpp_io_mod, only : mpp_open, mpp_close, mpp_flush +use mpp_io_mod, only : mpp_write_meta, mpp_write +use mpp_io_mod, only : mpp_get_atts, mpp_attribute_exist +use mpp_io_mod, only : mpp_get_axes, axistype, mpp_get_axis_data +use mpp_io_mod, only : mpp_get_fields, fieldtype +use mpp_io_mod, only : mpp_get_info, mpp_get_times +use mpp_io_mod, only : mpp_io_init +! These are encoding constants. +use mpp_io_mod, only : APPEND_FILE=>MPP_APPEND, WRITEONLY_FILE=>MPP_WRONLY +use mpp_io_mod, only : OVERWRITE_FILE=>MPP_OVERWR, READONLY_FILE=>MPP_RDONLY +use mpp_io_mod, only : NETCDF_FILE=>MPP_NETCDF, ASCII_FILE=>MPP_ASCII +use mpp_io_mod, only : MULTIPLE=>MPP_MULTI, SINGLE_FILE=>MPP_SINGLE +use iso_fortran_env, only : int64 + +implicit none ; private + +! These interfaces are actually implemented or have explicit interfaces in this file. +public :: open_file, open_ASCII_file, file_is_open, close_file, flush_file, file_exists +public :: get_file_info, get_file_fields, get_file_times, get_filename_suffix +public :: MOM_read_data, MOM_read_vector, write_metadata, write_field +public :: field_exists, get_field_atts, get_field_size, get_axis_data, read_field_chksum +public :: io_infra_init, io_infra_end, MOM_namelist_file, check_namelist_error, write_version +! These types are inherited from underlying infrastructure code, to act as containers for +! information about fields and axes, respectively, and are opaque to this module. +public :: fieldtype, axistype +! These are encoding constant parmeters. +public :: ASCII_FILE, NETCDF_FILE, SINGLE_FILE, MULTIPLE +public :: APPEND_FILE, READONLY_FILE, OVERWRITE_FILE, WRITEONLY_FILE +public :: CENTER, CORNER, NORTH_FACE, EAST_FACE + +!> Indicate whether a file exists, perhaps with domain decomposition +interface file_exists + module procedure FMS_file_exists + module procedure MOM_file_exists +end interface + +!> Open a file (or fileset) for parallel or single-file I/). +interface open_file + module procedure open_file_type, open_file_unit +end interface open_file + +!> Read a data field from a file +interface MOM_read_data + module procedure MOM_read_data_4d + module procedure MOM_read_data_3d + module procedure MOM_read_data_2d, MOM_read_data_2d_region + module procedure MOM_read_data_1d, MOM_read_data_1d_int + module procedure MOM_read_data_0d, MOM_read_data_0d_int +end interface + +!> Write a registered field to an output file +interface write_field + module procedure write_field_4d + module procedure write_field_3d + module procedure write_field_2d + module procedure write_field_1d + module procedure write_field_0d + module procedure MOM_write_axis +end interface write_field + +!> 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 MOM_read_vector + +!> Write metadata about a variable or axis to a file and store it for later reuse +interface write_metadata + module procedure write_metadata_axis, write_metadata_field +end interface write_metadata + +!> Close a file (or fileset). If the file handle does not point to an open file, +!! close_file simply returns without doing anything. +interface close_file + module procedure close_file_type, close_file_unit +end interface close_file + +!> Ensure that the output stream associated with a file handle is fully sent to disk +interface flush_file + module procedure flush_file_type, flush_file_unit +end interface flush_file + +!> Type for holding a handle to an open file and related information +type, public :: file_type ; private + integer :: unit = -1 !< The framework identfier or netCDF unit number of an output file + character(len=:), allocatable :: filename !< The path to this file, if it is open + logical :: open_to_read = .false. !< If true, this file or fileset can be read + logical :: open_to_write = .false. !< If true, this file or fileset can be written to +end type file_type + +contains + +!> Reads the checksum value for a field that was recorded in a file, along with a flag indicating +!! whether the file contained a valid checksum for this field. +subroutine read_field_chksum(field, chksum, valid_chksum) + type(fieldtype), intent(in) :: field !< The field whose checksum attribute is to be read. + integer(kind=int64), intent(out) :: chksum !< The checksum for the field. + logical, intent(out) :: valid_chksum !< If true, chksum has been successfully read. + ! Local variables + integer(kind=int64), dimension(3) :: checksum_file + + checksum_file(:) = -1 + valid_chksum = mpp_attribute_exist(field, "checksum") + if (valid_chksum) then + call get_field_atts(field, checksum=checksum_file) + chksum = checksum_file(1) + else + chksum = -1 + endif +end subroutine read_field_chksum + +!> Returns true if the named file or its domain-decomposed variant exists. +logical function MOM_file_exists(filename, MOM_Domain) + character(len=*), intent(in) :: filename !< The name of the file being inquired about + type(MOM_domain_type), intent(in) :: MOM_Domain !< The MOM_Domain that describes the decomposition + +! This function uses the fms_io function file_exist to determine whether +! a named file (or its decomposed variant) exists. + + MOM_file_exists = file_exist(filename, MOM_Domain%mpp_domain) + +end function MOM_file_exists + +!> Returns true if the named file or its domain-decomposed variant exists. +logical function FMS_file_exists(filename, domain, no_domain) + character(len=*), intent(in) :: filename !< The name of the file being inquired about + type(domain2d), optional, intent(in) :: domain !< The mpp domain2d that describes the decomposition + logical, optional, intent(in) :: no_domain !< This file does not use domain decomposition +! This function uses the fms_io function file_exist to determine whether +! a named file (or its decomposed variant) exists. + + FMS_file_exists = file_exist(filename, domain, no_domain) + +end function FMS_file_exists + +!> indicates whether an I/O handle is attached to an open file +logical function file_is_open(IO_handle) + type(file_type), intent(in) :: IO_handle !< Handle to a file to inquire about + + file_is_open = (IO_handle%unit >= 0) +end function file_is_open + +!> closes a file (or fileset). If the file handle does not point to an open file, +!! close_file_type simply returns without doing anything. +subroutine close_file_type(IO_handle) + type(file_type), intent(inout) :: IO_handle !< The I/O handle for the file to be closed + + call mpp_close(IO_handle%unit) + if (allocated(IO_handle%filename)) deallocate(IO_handle%filename) + IO_handle%open_to_read = .false. ; IO_handle%open_to_write = .false. +end subroutine close_file_type + +!> closes a file. If the unit does not point to an open file, +!! close_file_unit simply returns without doing anything. +subroutine close_file_unit(unit) + integer, intent(inout) :: unit !< The I/O unit for the file to be closed + + call mpp_close(unit) +end subroutine close_file_unit + +!> Ensure that the output stream associated with a file handle is fully sent to disk. +subroutine flush_file_type(file) + type(file_type), intent(in) :: file !< The I/O handle for the file to flush + + call mpp_flush(file%unit) +end subroutine flush_file_type + +!> Ensure that the output stream associated with a unit is fully sent to disk. +subroutine flush_file_unit(unit) + integer, intent(in) :: unit !< The I/O unit for the file to flush + + call mpp_flush(unit) +end subroutine flush_file_unit + +!> Initialize the underlying I/O infrastructure +subroutine io_infra_init(maxunits) + integer, optional, intent(in) :: maxunits !< An optional maximum number of file + !! unit numbers that can be used. + call mpp_io_init(maxunit=maxunits) +end subroutine io_infra_init + +!> Gracefully close out and terminate the underlying I/O infrastructure +subroutine io_infra_end() + call fms_io_exit() +end subroutine io_infra_end + +!> Open a single namelist file that is potentially readable by all PEs. +function MOM_namelist_file(file) result(unit) + character(len=*), optional, intent(in) :: file !< The file to open, by default "input.nml". + integer :: unit !< The opened unit number of the namelist file + unit = open_namelist_file(file) +end function MOM_namelist_file + +!> Checks the iostat argument that is returned after reading a namelist variable and writes a +!! message if there is an error. +subroutine check_namelist_error(IOstat, nml_name) + integer, intent(in) :: IOstat !< An I/O status field from a namelist read call + character(len=*), intent(in) :: nml_name !< The name of the namelist + integer :: ierr + ierr = check_nml_error(IOstat, nml_name) +end subroutine check_namelist_error + +!> Write a file version number to the log file or other output file +subroutine write_version(version, tag, unit) + character(len=*), intent(in) :: version !< A string that contains the routine name and version + character(len=*), optional, intent(in) :: tag !< A tag name to add to the message + integer, optional, intent(in) :: unit !< An alternate unit number for output + + call write_version_number(version, tag, unit) +end subroutine write_version + +!> open_file opens a file for parallel or single-file I/O. +subroutine open_file_unit(unit, filename, action, form, threading, fileset, nohdrs, domain, MOM_domain) + integer, intent(out) :: unit !< The I/O unit for the opened file + character(len=*), intent(in) :: filename !< The name of the file being opened + integer, optional, intent(in) :: action !< A flag indicating whether the file can be read + !! or written to and how to handle existing files. + integer, optional, intent(in) :: form !< A flag indicating the format of a new file. The + !! default is ASCII_FILE, but NETCDF_FILE is also common. + integer, optional, intent(in) :: threading !< A flag indicating whether one (SINGLE_FILE) + !! or multiple PEs (MULTIPLE) participate in I/O. + !! With the default, the root PE does I/O. + integer, optional, intent(in) :: fileset !< A flag indicating whether multiple PEs doing I/O due + !! to threading=MULTIPLE write to the same file (SINGLE_FILE) + !! or to one file per PE (MULTIPLE, the default). + logical, optional, intent(in) :: nohdrs !< If nohdrs is .TRUE., headers are not written to + !! ASCII files. The default is .false. + type(domain2d), optional, intent(in) :: domain !< A domain2d type that describes the decomposition + type(MOM_domain_type), optional, intent(in) :: MOM_Domain !< A MOM_Domain that describes the decomposition + + if (present(MOM_Domain)) then + call mpp_open(unit, filename, action=action, form=form, threading=threading, fileset=fileset, & + nohdrs=nohdrs, domain=MOM_Domain%mpp_domain) + else + call mpp_open(unit, filename, action=action, form=form, threading=threading, fileset=fileset, & + nohdrs=nohdrs, domain=domain) + endif +end subroutine open_file_unit + +!> open_file opens a file for parallel or single-file I/O. +subroutine open_file_type(IO_handle, filename, action, MOM_domain, threading, fileset) + type(file_type), intent(inout) :: IO_handle !< The handle for the opened file + character(len=*), intent(in) :: filename !< The path name of the file being opened + integer, optional, intent(in) :: action !< A flag indicating whether the file can be read + !! or written to and how to handle existing files. + !! The default is WRITE_ONLY. + type(MOM_domain_type), & + optional, intent(in) :: MOM_Domain !< A MOM_Domain that describes the decomposition + integer, optional, intent(in) :: threading !< A flag indicating whether one (SINGLE_FILE) + !! or multiple PEs (MULTIPLE) participate in I/O. + !! With the default, the root PE does I/O. + integer, optional, intent(in) :: fileset !< A flag indicating whether multiple PEs doing I/O due + !! to threading=MULTIPLE write to the same file (SINGLE_FILE) + !! or to one file per PE (MULTIPLE, the default). + + if (present(MOM_Domain)) then + call mpp_open(IO_handle%unit, filename, action=action, form=NETCDF_FILE, threading=threading, & + fileset=fileset, domain=MOM_Domain%mpp_domain) + else + call mpp_open(IO_handle%unit, filename, action=action, form=NETCDF_FILE, threading=threading, & + fileset=fileset) + endif + IO_handle%filename = trim(filename) + if (present(action)) then + if (action == READONLY_FILE) then + IO_handle%open_to_read = .true. ; IO_handle%open_to_write = .false. + else + IO_handle%open_to_read = .false. ; IO_handle%open_to_write = .true. + endif + else + IO_handle%open_to_read = .false. ; IO_handle%open_to_write = .true. + endif + +end subroutine open_file_type + +!> open_file opens an ascii file for parallel or single-file I/O using Fortran read and write calls. +subroutine open_ASCII_file(unit, file, action, threading, fileset) + integer, intent(out) :: unit !< The I/O unit for the opened file + character(len=*), intent(in) :: file !< The name of the file being opened + integer, optional, intent(in) :: action !< A flag indicating whether the file can be read + !! or written to and how to handle existing files. + integer, optional, intent(in) :: threading !< A flag indicating whether one (SINGLE_FILE) + !! or multiple PEs (MULTIPLE) participate in I/O. + !! With the default, the root PE does I/O. + integer, optional, intent(in) :: fileset !< A flag indicating whether multiple PEs doing I/O due + !! to threading=MULTIPLE write to the same file (SINGLE_FILE) + !! or to one file per PE (MULTIPLE, the default). + + call mpp_open(unit, file, action=action, form=ASCII_FILE, threading=threading, fileset=fileset, & + nohdrs=.true.) + +end subroutine open_ASCII_file + + +!> Provide a string to append to filenames, to differentiate ensemble members, for example. +subroutine get_filename_suffix(suffix) + character(len=*), intent(out) :: suffix !< A string to append to filenames + + call get_filename_appendix(suffix) +end subroutine get_filename_suffix + + +!> Get information about the number of dimensions, variables, global attributes and time levels +!! in the file associated with an open file unit +subroutine get_file_info(IO_handle, ndim, nvar, natt, ntime) + type(file_type), intent(in) :: IO_handle !< Handle for a file that is open for I/O + integer, optional, intent(out) :: ndim !< The number of dimensions in the file + integer, optional, intent(out) :: nvar !< The number of variables in the file + integer, optional, intent(out) :: natt !< The number of global attributes in the file + integer, optional, intent(out) :: ntime !< The number of time levels in the file + + ! Local variables + integer :: ndims, nvars, natts, ntimes + + call mpp_get_info(IO_handle%unit, ndims, nvars, natts, ntimes ) + + if (present(ndim)) ndim = ndims + if (present(nvar)) nvar = nvars + if (present(natt)) natt = natts + if (present(ntime)) ntime = ntimes + +end subroutine get_file_info + + +!> Get the times of records from a file + !### Modify this to also convert to time_type, using information about the dimensions? +subroutine get_file_times(IO_handle, time_values, ntime) + type(file_type), intent(in) :: IO_handle !< Handle for a file that is open for I/O + real, allocatable, dimension(:), intent(inout) :: time_values !< The real times for the records in file. + integer, optional, intent(out) :: ntime !< The number of time levels in the file + + integer :: ntimes + + if (allocated(time_values)) deallocate(time_values) + call get_file_info(IO_handle, ntime=ntimes) + if (present(ntime)) ntime = ntimes + if (ntimes > 0) then + allocate(time_values(ntimes)) + call mpp_get_times(IO_handle%unit, time_values) + endif +end subroutine get_file_times + +!> Set up the field information (e.g., names and metadata) for all of the variables in a file. The +!! argument fields must be allocated with a size that matches the number of variables in a file. +subroutine get_file_fields(IO_handle, fields) + type(file_type), intent(in) :: IO_handle !< Handle for a file that is open for I/O + type(fieldtype), dimension(:), intent(inout) :: fields !< Field-type descriptions of all of + !! the variables in a file. + call mpp_get_fields(IO_handle%unit, fields) +end subroutine get_file_fields + +!> Extract information from a field type, as stored or as found in a file +subroutine get_field_atts(field, name, units, longname, checksum) + type(fieldtype), intent(in) :: field !< The field to extract information from + character(len=*), optional, intent(out) :: name !< The variable name + character(len=*), optional, intent(out) :: units !< The units of the variable + character(len=*), optional, intent(out) :: longname !< The long name of the variable + integer(kind=int64), dimension(:), & + optional, intent(out) :: checksum !< The checksums of the variable in a file + call mpp_get_atts(field, name=name, units=units, longname=longname, checksum=checksum) +end subroutine get_field_atts + +!> Field_exists returns true if the field indicated by field_name is present in the +!! file file_name. If file_name does not exist, it returns false. +function field_exists(filename, field_name, domain, no_domain, MOM_domain) + character(len=*), intent(in) :: filename !< The name of the file being inquired about + character(len=*), intent(in) :: field_name !< The name of the field being sought + type(domain2d), target, optional, intent(in) :: domain !< A domain2d type that describes the decomposition + logical, optional, intent(in) :: no_domain !< This file does not use domain decomposition + type(MOM_domain_type), optional, intent(in) :: MOM_Domain !< A MOM_Domain that describes the decomposition + logical :: field_exists !< True if filename exists and field_name is in filename + + if (present(MOM_domain)) then + field_exists = field_exist(filename, field_name, domain=MOM_domain%mpp_domain, no_domain=no_domain) + else + field_exists = field_exist(filename, field_name, domain=domain, no_domain=no_domain) + endif + +end function field_exists + +!> Given filename and fieldname, this subroutine returns the size of the field in the file +subroutine get_field_size(filename, fieldname, sizes, field_found, no_domain) + character(len=*), intent(in) :: filename !< The name of the file to read + character(len=*), intent(in) :: fieldname !< The name of the variable whose sizes are returned + integer, dimension(:), intent(inout) :: sizes !< The sizes of the variable in each dimension + logical, optional, intent(out) :: field_found !< This indicates whether the field was found in + !! the input file. Without this argument, there + !! is a fatal error if the field is not found. + logical, optional, intent(in) :: no_domain !< If present and true, do not check for file + !! names with an appended tile number + + call field_size(filename, fieldname, sizes, field_found=field_found, no_domain=no_domain) + +end subroutine get_field_size + +!> Extracts and returns the axis data stored in an axistype. +subroutine get_axis_data( axis, dat ) + type(axistype), intent(in) :: axis !< An axis type + real, dimension(:), intent(out) :: dat !< The data in the axis variable + + call mpp_get_axis_data( axis, dat ) +end subroutine get_axis_data + +!> This routine uses the fms_io subroutine read_data to read a scalar named +!! "fieldname" from a single or domain-decomposed file "filename". +subroutine MOM_read_data_0d(filename, fieldname, data, timelevel, scale, MOM_Domain) + 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 !< The 1-dimensional array into which the data + integer, optional, intent(in) :: timelevel !< The time level in the file to read + real, optional, intent(in) :: scale !< A scaling factor that the field is multiplied + !! by before it is returned. + type(MOM_domain_type), & + optional, intent(in) :: MOM_Domain !< The MOM_Domain that describes the decomposition + + if (present(MOM_Domain)) then + call read_data(filename, fieldname, data, MOM_Domain%mpp_domain, timelevel=timelevel) + else + call read_data(filename, fieldname, data, timelevel=timelevel, no_domain=.true.) + endif + + if (present(scale)) then ; if (scale /= 1.0) then + data = scale*data + endif ; endif + +end subroutine MOM_read_data_0d + +!> This routine uses the fms_io subroutine read_data to read a 1-D data field named +!! "fieldname" from a single or domain-decomposed file "filename". +subroutine MOM_read_data_1d(filename, fieldname, data, timelevel, scale, MOM_Domain) + 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 array into which the data + integer, optional, intent(in) :: timelevel !< The time level in the file to read + real, optional, intent(in) :: scale !< A scaling factor that the field is multiplied + !! by before they are returned. + type(MOM_domain_type), & + optional, intent(in) :: MOM_Domain !< The MOM_Domain that describes the decomposition + + if (present(MOM_Domain)) then + call read_data(filename, fieldname, data, MOM_Domain%mpp_domain, timelevel=timelevel) + else + call read_data(filename, fieldname, data, timelevel=timelevel, no_domain=.true.) + endif + + if (present(scale)) then ; if (scale /= 1.0) then + data(:) = scale*data(:) + endif ; endif + +end subroutine MOM_read_data_1d + +!> This routine uses the fms_io subroutine read_data to read a distributed +!! 2-D data field named "fieldname" from file "filename". Valid values for +!! "position" include CORNER, CENTER, EAST_FACE and NORTH_FACE. +subroutine MOM_read_data_2d(filename, fieldname, data, MOM_Domain, & + timelevel, position, scale) + 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 array into which the data + !! should be read + type(MOM_domain_type), intent(in) :: MOM_Domain !< The MOM_Domain that describes the decomposition + integer, optional, intent(in) :: timelevel !< The time level in the file to read + integer, optional, intent(in) :: position !< A flag indicating where this data is located + real, optional, intent(in) :: scale !< A scaling factor that the field is multiplied + !! by before it is returned. + + call read_data(filename, fieldname, data, MOM_Domain%mpp_domain, & + timelevel=timelevel, position=position) + + if (present(scale)) then ; if (scale /= 1.0) then + call rescale_comp_data(MOM_Domain, data, scale) + endif ; endif + +end subroutine MOM_read_data_2d + +!> This routine uses the fms_io subroutine read_data to read a region from a distributed or +!! global 2-D data field named "fieldname" from file "filename". +subroutine MOM_read_data_2d_region(filename, fieldname, data, start, nread, MOM_domain, & + no_domain, scale) + 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 array into which the data + !! should be read + integer, dimension(:), intent(in) :: start !< The starting index to read in each of 4 + !! dimensions. For this 2-d read, the 3rd + !! and 4th values are always 1. + integer, dimension(:), intent(in) :: nread !< The number of points to read in each of 4 + !! dimensions. For this 2-d read, the 3rd + !! and 4th values are always 1. + type(MOM_domain_type), & + optional, intent(in) :: MOM_Domain !< The MOM_Domain that describes the decomposition + logical, optional, intent(in) :: no_domain !< If present and true, this variable does not + !! use domain decomposion. + real, optional, intent(in) :: scale !< A scaling factor that the field is multiplied + !! by before it is returned. + + if (present(MOM_Domain)) then + call read_data(filename, fieldname, data, start, nread, domain=MOM_Domain%mpp_domain, & + no_domain=no_domain) + else + call read_data(filename, fieldname, data, start, nread, no_domain=no_domain) + endif + + if (present(scale)) then ; if (scale /= 1.0) then + if (present(MOM_Domain)) then + call rescale_comp_data(MOM_Domain, data, scale) + else + ! Dangerously rescale the whole array + data(:,:) = scale*data(:,:) + endif + endif ; endif + +end subroutine MOM_read_data_2d_region + +!> This routine uses the fms_io subroutine read_data to read a distributed +!! 3-D data field named "fieldname" from file "filename". Valid values for +!! "position" include CORNER, CENTER, EAST_FACE and NORTH_FACE. +subroutine MOM_read_data_3d(filename, fieldname, data, MOM_Domain, & + timelevel, position, scale) + 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 array into which the data + !! should be read + type(MOM_domain_type), intent(in) :: MOM_Domain !< The MOM_Domain that describes the decomposition + integer, optional, intent(in) :: timelevel !< The time level in the file to read + integer, optional, intent(in) :: position !< A flag indicating where this data is located + real, optional, intent(in) :: scale !< A scaling factor that the field is multiplied + !! by before it is returned. + + call read_data(filename, fieldname, data, MOM_Domain%mpp_domain, & + timelevel=timelevel, position=position) + + if (present(scale)) then ; if (scale /= 1.0) then + call rescale_comp_data(MOM_Domain, data, scale) + endif ; endif + +end subroutine MOM_read_data_3d + +!> This routine uses the fms_io subroutine read_data to read a distributed +!! 4-D data field named "fieldname" from file "filename". Valid values for +!! "position" include CORNER, CENTER, EAST_FACE and NORTH_FACE. +subroutine MOM_read_data_4d(filename, fieldname, data, MOM_Domain, & + timelevel, position, scale) + 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 array into which the data + !! should be read + type(MOM_domain_type), intent(in) :: MOM_Domain !< The MOM_Domain that describes the decomposition + integer, optional, intent(in) :: timelevel !< The time level in the file to read + integer, optional, intent(in) :: position !< A flag indicating where this data is located + real, optional, intent(in) :: scale !< A scaling factor that the field is multiplied + !! by before it is returned. + + call read_data(filename, fieldname, data, MOM_Domain%mpp_domain, & + timelevel=timelevel, position=position) + + if (present(scale)) then ; if (scale /= 1.0) then + call rescale_comp_data(MOM_Domain, data, scale) + endif ; endif + +end subroutine MOM_read_data_4d + +!> This routine uses the fms_io subroutine read_data to read a scalar integer +!! data field named "fieldname" from file "filename". +subroutine MOM_read_data_0d_int(filename, fieldname, data, timelevel) + 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 + integer, intent(inout) :: data !< The 1-dimensional array into which the data + integer, optional, intent(in) :: timelevel !< The time level in the file to read + + call read_data(filename, fieldname, data, timelevel=timelevel, no_domain=.true.) + +end subroutine MOM_read_data_0d_int + +!> This routine uses the fms_io subroutine read_data to read a 1-D integer +!! data field named "fieldname" from file "filename". +subroutine MOM_read_data_1d_int(filename, fieldname, data, timelevel) + 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 + integer, dimension(:), intent(inout) :: data !< The 1-dimensional array into which the data + integer, optional, intent(in) :: timelevel !< The time level in the file to read + + call read_data(filename, fieldname, data, timelevel=timelevel, no_domain=.true.) + +end subroutine MOM_read_data_1d_int + + +!> This routine uses the fms_io subroutine read_data 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(filename, u_fieldname, v_fieldname, u_data, v_data, MOM_Domain, & + timelevel, stagger, scalar_pair, scale) + character(len=*), intent(in) :: filename !< The name of the 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 + 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 + logical, optional, intent(in) :: scalar_pair !< If true, a pair of scalars are to be read + real, optional, intent(in) :: scale !< A scaling factor that the fields are multiplied + !! by before they are returned. + integer :: u_pos, v_pos + + 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 + + call read_data(filename, u_fieldname, u_data, MOM_Domain%mpp_domain, & + timelevel=timelevel, position=u_pos) + call read_data(filename, v_fieldname, v_data, MOM_Domain%mpp_domain, & + timelevel=timelevel, position=v_pos) + + if (present(scale)) then ; if (scale /= 1.0) then + call rescale_comp_data(MOM_Domain, u_data, scale) + call rescale_comp_data(MOM_Domain, v_data, scale) + endif ; endif + +end subroutine MOM_read_vector_2d + +!> This routine uses the fms_io subroutine read_data 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(filename, u_fieldname, v_fieldname, u_data, v_data, MOM_Domain, & + timelevel, stagger, scalar_pair, scale) + character(len=*), intent(in) :: filename !< The name of the 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 + 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 + logical, optional, intent(in) :: scalar_pair !< If true, a pair of scalars are to be read.cretized + real, optional, intent(in) :: scale !< A scaling factor that the fields are multiplied + !! by before they are returned. + + integer :: u_pos, v_pos + + 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 + + call read_data(filename, u_fieldname, u_data, MOM_Domain%mpp_domain, & + timelevel=timelevel, position=u_pos) + call read_data(filename, v_fieldname, v_data, MOM_Domain%mpp_domain, & + timelevel=timelevel, position=v_pos) + + if (present(scale)) then ; if (scale /= 1.0) then + call rescale_comp_data(MOM_Domain, u_data, scale) + call rescale_comp_data(MOM_Domain, v_data, scale) + endif ; endif + +end subroutine MOM_read_vector_3d + + +!> Write a 4d field to an output file. +subroutine write_field_4d(IO_handle, field_md, MOM_domain, field, tstamp, tile_count, fill_value) + type(file_type), intent(in) :: IO_handle !< Handle for a file that is open for writing + type(fieldtype), intent(in) :: field_md !< Field type with metadata + type(MOM_domain_type), intent(in) :: MOM_domain !< The MOM_Domain that describes the decomposition + real, dimension(:,:,:,:), intent(inout) :: field !< Field to write + real, optional, intent(in) :: tstamp !< Model timestamp + integer, optional, intent(in) :: tile_count !< PEs per tile (default: 1) + real, optional, intent(in) :: fill_value !< Missing data fill value + + call mpp_write(IO_handle%unit, field_md, MOM_domain%mpp_domain, field, tstamp=tstamp, & + tile_count=tile_count, default_data=fill_value) +end subroutine write_field_4d + +!> Write a 3d field to an output file. +subroutine write_field_3d(IO_handle, field_md, MOM_domain, field, tstamp, tile_count, fill_value) + type(file_type), intent(in) :: IO_handle !< Handle for a file that is open for writing + type(fieldtype), intent(in) :: field_md !< Field type with metadata + type(MOM_domain_type), intent(in) :: MOM_domain !< The MOM_Domain that describes the decomposition + real, dimension(:,:,:), intent(inout) :: field !< Field to write + real, optional, intent(in) :: tstamp !< Model timestamp + integer, optional, intent(in) :: tile_count !< PEs per tile (default: 1) + real, optional, intent(in) :: fill_value !< Missing data fill value + + call mpp_write(IO_handle%unit, field_md, MOM_domain%mpp_domain, field, tstamp=tstamp, & + tile_count=tile_count, default_data=fill_value) +end subroutine write_field_3d + +!> Write a 2d field to an output file. +subroutine write_field_2d(IO_handle, field_md, MOM_domain, field, tstamp, tile_count, fill_value) + type(file_type), intent(in) :: IO_handle !< Handle for a file that is open for writing + type(fieldtype), intent(in) :: field_md !< Field type with metadata + type(MOM_domain_type), intent(in) :: MOM_domain !< The MOM_Domain that describes the decomposition + real, dimension(:,:), intent(inout) :: field !< Field to write + real, optional, intent(in) :: tstamp !< Model timestamp + integer, optional, intent(in) :: tile_count !< PEs per tile (default: 1) + real, optional, intent(in) :: fill_value !< Missing data fill value + + call mpp_write(IO_handle%unit, field_md, MOM_domain%mpp_domain, field, tstamp=tstamp, & + tile_count=tile_count, default_data=fill_value) +end subroutine write_field_2d + +!> Write a 1d field to an output file. +subroutine write_field_1d(IO_handle, field_md, field, tstamp) + type(file_type), intent(in) :: IO_handle !< Handle for a file that is open for writing + type(fieldtype), intent(in) :: field_md !< Field type with metadata + real, dimension(:), intent(in) :: field !< Field to write + real, optional, intent(in) :: tstamp !< Model timestamp + + call mpp_write(IO_handle%unit, field_md, field, tstamp=tstamp) +end subroutine write_field_1d + +!> Write a 0d field to an output file. +subroutine write_field_0d(IO_handle, field_md, field, tstamp) + type(file_type), intent(in) :: IO_handle !< Handle for a file that is open for writing + type(fieldtype), intent(in) :: field_md !< Field type with metadata + real, intent(in) :: field !< Field to write + real, optional, intent(in) :: tstamp !< Model timestamp + + call mpp_write(IO_handle%unit, field_md, field, tstamp=tstamp) +end subroutine write_field_0d + +!> Write the data for an axis +subroutine MOM_write_axis(IO_handle, axis) + type(file_type), intent(in) :: IO_handle !< Handle for a file that is open for writing + type(axistype), intent(in) :: axis !< An axis type variable with information to write + + call mpp_write(IO_handle%unit, axis) + +end subroutine MOM_write_axis + +!> Store information about an axis in a previously defined axistype and write this +!! information to the file indicated by unit. +subroutine write_metadata_axis(IO_handle, axis, name, units, longname, cartesian, sense, domain, data, calendar) + type(file_type), intent(in) :: IO_handle !< Handle for a file that is open for writing + type(axistype), intent(inout) :: axis !< The axistype where this information is stored. + character(len=*), intent(in) :: name !< The name in the file of this axis + character(len=*), intent(in) :: units !< The units of this axis + character(len=*), intent(in) :: longname !< The long description of this axis + character(len=*), optional, intent(in) :: cartesian !< A variable indicating which direction + !! this axis corresponds with. Valid values + !! include 'X', 'Y', 'Z', 'T', and 'N' for none. + integer, optional, intent(in) :: sense !< This is 1 for axes whose values increase upward, or + !! -1 if they increase downward. + type(domain1D), optional, intent(in) :: domain !< The domain decomposion for this axis + real, dimension(:), optional, intent(in) :: data !< The coordinate values of the points on this axis + character(len=*), optional, intent(in) :: calendar !< The name of the calendar used with a time axis + + call mpp_write_meta(IO_handle%unit, axis, name, units, longname, cartesian=cartesian, sense=sense, & + domain=domain, data=data, calendar=calendar) +end subroutine write_metadata_axis + +!> Store information about an output variable in a previously defined fieldtype and write this +!! information to the file indicated by unit. +subroutine write_metadata_field(IO_handle, field, axes, name, units, longname, & + min, max, fill, scale, add, pack, standard_name, checksum) + type(file_type), intent(in) :: IO_handle !< Handle for a file that is open for writing + type(fieldtype), intent(inout) :: field !< The fieldtype where this information is stored + type(axistype), dimension(:), intent(in) :: axes !< Handles for the axis used for this variable + character(len=*), intent(in) :: name !< The name in the file of this variable + character(len=*), intent(in) :: units !< The units of this variable + character(len=*), intent(in) :: longname !< The long description of this variable + real, optional, intent(in) :: min !< The minimum valid value for this variable + real, optional, intent(in) :: max !< The maximum valid value for this variable + real, optional, intent(in) :: fill !< Missing data fill value + real, optional, intent(in) :: scale !< An multiplicative factor by which to scale + !! the variable before output + real, optional, intent(in) :: add !< An offset to add to the variable before output + integer, optional, intent(in) :: pack !< A precision reduction factor with which the + !! variable. The default, 1, has no reduction, + !! but 2 is not uncommon. + character(len=*), optional, intent(in) :: standard_name !< The standard (e.g., CMOR) name for this variable + integer(kind=int64), dimension(:), & + optional, intent(in) :: checksum !< Checksum values that can be used to verify reads. + + + call mpp_write_meta(IO_handle%unit, field, axes, name, units, longname, min=min, max=max, & + fill=fill, scale=scale, add=add, pack=pack, standard_name=standard_name, checksum=checksum) + +end subroutine write_metadata_field + +end module MOM_io_infra diff --git a/config_src/infra/FMS2/MOM_time_manager.F90 b/config_src/infra/FMS2/MOM_time_manager.F90 new file mode 100644 index 0000000000..5f3279b713 --- /dev/null +++ b/config_src/infra/FMS2/MOM_time_manager.F90 @@ -0,0 +1,54 @@ +!> Wraps the FMS time manager functions +module MOM_time_manager + +! This file is part of MOM6. See LICENSE.md for the license. + +use time_manager_mod, only : time_type, get_time, set_time +use time_manager_mod, only : time_type_to_real, real_to_time_type +use time_manager_mod, only : operator(+), operator(-), operator(*), operator(/) +use time_manager_mod, only : operator(>), operator(<), operator(>=), operator(<=) +use time_manager_mod, only : operator(==), operator(/=), operator(//) +use time_manager_mod, only : set_ticks_per_second , get_ticks_per_second +use time_manager_mod, only : get_date, set_date, increment_date +use time_manager_mod, only : days_in_month, month_name +use time_manager_mod, only : set_calendar_type, get_calendar_type +use time_manager_mod, only : JULIAN, NOLEAP, THIRTY_DAY_MONTHS, GREGORIAN +use time_manager_mod, only : NO_CALENDAR + +implicit none ; private + +public :: time_type, get_time, set_time +public :: time_type_to_real, real_to_time_type, real_to_time +public :: set_ticks_per_second, get_ticks_per_second +public :: operator(+), operator(-), operator(*), operator(/) +public :: operator(>), operator(<), operator(>=), operator(<=) +public :: operator(==), operator(/=), operator(//) +public :: get_date, set_date, increment_date, month_name, days_in_month +public :: JULIAN, NOLEAP, THIRTY_DAY_MONTHS, GREGORIAN, NO_CALENDAR +public :: set_calendar_type, get_calendar_type + +contains + +!> Returns a time_type version of a real time in seconds, using an alternate implementation to the +!! FMS function real_to_time_type that is accurate over a larger range of input values. With 32 bit +!! signed integers, this version should work over the entire valid range (2^31 days or ~5.8835 +!! million years) of time_types, whereas the standard version in the FMS time_manager stops working +!! for conversions of times greater than 2^31 seconds, or ~68.1 years. +type(time_type) function real_to_time(x, err_msg) +! type(time_type) :: real_to_time !< The output time as a time_type + real, intent(in) :: x !< The input time in real seconds. + character(len=*), optional, intent(out) :: err_msg !< An optional returned error message. + + ! Local variables + integer :: seconds, days, ticks + real :: real_subsecond_remainder + + days = floor(x/86400.) + seconds = floor(x - 86400.*days) + real_subsecond_remainder = x - (days*86400. + seconds) + ticks = nint(real_subsecond_remainder * get_ticks_per_second()) + + real_to_time = set_time(seconds=seconds, days=days, ticks=ticks, err_msg=err_msg) +end function real_to_time + +end module MOM_time_manager From a077573144af91b07fc09c71cf93e764aebe0665 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sat, 6 Mar 2021 04:30:39 -0500 Subject: [PATCH 012/112] Explicitly set (1x1) io_domain as a default Added code to explicitly set a (1x1) io_domain when no other io_layout is specified, complying with changing requirements for 2020 and later versions of FMS, and following the default behavior of previous versions. All answers are bitwise identical. --- config_src/infra/FMS1/MOM_domain_infra.F90 | 2 ++ config_src/infra/FMS2/MOM_domain_infra.F90 | 2 ++ 2 files changed, 4 insertions(+) diff --git a/config_src/infra/FMS1/MOM_domain_infra.F90 b/config_src/infra/FMS1/MOM_domain_infra.F90 index 7c3424ca15..fc39777a2f 100644 --- a/config_src/infra/FMS1/MOM_domain_infra.F90 +++ b/config_src/infra/FMS1/MOM_domain_infra.F90 @@ -1689,6 +1689,8 @@ subroutine clone_MD_to_d2D(MD_in, mpp_domain, min_halo, halo_size, symmetric, & if ((MD_in%io_layout(1) + MD_in%io_layout(2) > 0) .and. & (MD_in%layout(1)*MD_in%layout(2) > 1)) then call mpp_define_io_domain(mpp_domain, MD_in%io_layout) + else + call mpp_define_io_domain(mpp_domain, (/ 1, 1 /) ) endif end subroutine clone_MD_to_d2D diff --git a/config_src/infra/FMS2/MOM_domain_infra.F90 b/config_src/infra/FMS2/MOM_domain_infra.F90 index 7c3424ca15..fc39777a2f 100644 --- a/config_src/infra/FMS2/MOM_domain_infra.F90 +++ b/config_src/infra/FMS2/MOM_domain_infra.F90 @@ -1689,6 +1689,8 @@ subroutine clone_MD_to_d2D(MD_in, mpp_domain, min_halo, halo_size, symmetric, & if ((MD_in%io_layout(1) + MD_in%io_layout(2) > 0) .and. & (MD_in%layout(1)*MD_in%layout(2) > 1)) then call mpp_define_io_domain(mpp_domain, MD_in%io_layout) + else + call mpp_define_io_domain(mpp_domain, (/ 1, 1 /) ) endif end subroutine clone_MD_to_d2D From 0ba1aa53e0e834abbdd382c3d29d4de185facb56 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sun, 7 Mar 2021 12:00:09 -0500 Subject: [PATCH 013/112] +Simplified read_data_fms2 and write_field_fms2 Eliminated scale_data from MOM_read_data_fms2, as it was duplicative of rescale_comp_data from MOM_domain_infra.F90. Also eliminated the optional scale argument from the fms2 write_field routines, because this scaling is already handled in the framework/MOM_io.F90 routines, and because the way the scaling was implemented with a pointer to defeat the intent(in) of the data array to the write routines was a deviously terrible idea that would cause endless problems. Because the mpp_domain in the MOM_domain_types have been modified to always have an io_domain set, the test and calls setting an io_domain in all of the fms2 read_data and fms2 write_data routines. In addition, there is no longer a need for a routine to read specifically from the supergrid, so the fms2 MOM_read_data_2d_supergrid routine was eliminated. The code compiles with these changes, but none of this fms2 I/O code is exercised yet in MOM6, so of course all answers are bitwise identical. --- config_src/infra/FMS2/MOM_read_data_fms2.F90 | 412 ++++-------------- .../infra/FMS2/MOM_write_field_fms2.F90 | 243 ++--------- 2 files changed, 116 insertions(+), 539 deletions(-) diff --git a/config_src/infra/FMS2/MOM_read_data_fms2.F90 b/config_src/infra/FMS2/MOM_read_data_fms2.F90 index d0bffd6df0..27bdcf98e3 100644 --- a/config_src/infra/FMS2/MOM_read_data_fms2.F90 +++ b/config_src/infra/FMS2/MOM_read_data_fms2.F90 @@ -3,13 +3,11 @@ 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_error_infra, only : MOM_error=>MOM_err, NOTE, FATAL, WARNING use MOM_domain_infra, only : MOM_domain_type, AGRID, BGRID_NE, CGRID_NE -use MOM_domain_infra, 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_domain_infra, only : domain2d, CENTER, CORNER, NORTH_FACE, EAST_FACE +use MOM_domain_infra, only : rescale_comp_data 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 @@ -18,10 +16,6 @@ module MOM_read_data_fms2 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 @@ -61,16 +55,8 @@ module MOM_read_data_fms2 !> 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 +! !> index of the time_level value that is written to netCDF file by the write_field routines. +! integer, private :: write_field_time_index contains @@ -109,11 +95,6 @@ subroutine MOM_read_data_1d_DD(filename, fieldname, data, domain, start_index, e 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 "// & @@ -172,10 +153,6 @@ subroutine MOM_read_data_1d_DD(filename, fieldname, data, domain, start_index, e 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) @@ -183,6 +160,12 @@ subroutine MOM_read_data_1d_DD(filename, fieldname, data, domain, start_index, e file_var_meta_DD%nvars = 0 endif if (allocated(dim_names)) deallocate(dim_names) + + ! Rescale the data that was read if necessary. + if (present(scale)) then ; if (scale /= 1.0) then + data(:) = scale*data(:) + endif ; endif + 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" @@ -211,7 +194,6 @@ subroutine MOM_read_data_2d_DD(filename, fieldname, data, domain,start_index, ed 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 @@ -223,11 +205,6 @@ subroutine MOM_read_data_2d_DD(filename, fieldname, data, domain,start_index, ed ! 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 "// & @@ -265,12 +242,6 @@ subroutine MOM_read_data_2d_DD(filename, fieldname, data, domain,start_index, ed 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 @@ -305,10 +276,6 @@ subroutine MOM_read_data_2d_DD(filename, fieldname, data, domain,start_index, ed 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) @@ -316,7 +283,12 @@ subroutine MOM_read_data_2d_DD(filename, fieldname, data, domain,start_index, ed file_var_meta_DD%nvars = 0 endif if (allocated(dim_names)) deallocate(dim_names) - if (associated(io_domain)) nullify(io_domain) + + ! Rescale the data that was read if necessary. + if (present(scale)) then ; if (scale /= 1.0) then + call rescale_comp_data(domain, data, scale) + endif ; endif + 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" @@ -345,7 +317,6 @@ subroutine MOM_read_data_3d_DD(filename, fieldname, data, domain, start_index, e 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 @@ -356,11 +327,6 @@ subroutine MOM_read_data_3d_DD(filename, fieldname, data, domain, start_index, e 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 "// & @@ -397,15 +363,6 @@ subroutine MOM_read_data_3d_DD(filename, fieldname, data, domain, start_index, e 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 @@ -440,10 +397,6 @@ subroutine MOM_read_data_3d_DD(filename, fieldname, data, domain, start_index, e 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) @@ -452,7 +405,12 @@ subroutine MOM_read_data_3d_DD(filename, fieldname, data, domain, start_index, e endif if (allocated(dim_names)) deallocate(dim_names) - if (associated(io_domain)) nullify(io_domain) + + ! Rescale the data that was read if necessary. + if (present(scale)) then ; if (scale /= 1.0) then + call rescale_comp_data(domain, data, scale) + endif ; endif + 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" @@ -481,7 +439,6 @@ subroutine MOM_read_data_4d_DD(filename, fieldname, data, domain, start_index, e 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 @@ -492,11 +449,6 @@ subroutine MOM_read_data_4d_DD(filename, fieldname, data, domain, start_index, e 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 "// & @@ -534,14 +486,6 @@ subroutine MOM_read_data_4d_DD(filename, fieldname, data, domain, start_index, e 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 @@ -580,26 +524,30 @@ subroutine MOM_read_data_4d_DD(filename, fieldname, data, domain, start_index, e 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) + + ! Rescale the data that was read if necessary. + if (present(scale)) then ; if (scale /= 1.0) then + call rescale_comp_data(domain, data, scale) + endif ; endif + 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, leave_file_open) +subroutine MOM_read_data_scalar(filename, fieldname, data, 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, intent(inout) :: data !< data buffer to pass to read_data + real, optional, intent(in) :: scale !< A scaling factor that the scalar is multiplied + !! by before it is returned. logical, optional, intent(in) :: leave_file_open !< if .true., leave file open ! local integer :: i @@ -640,6 +588,12 @@ subroutine MOM_read_data_scalar(filename, fieldname, data, leave_file_open) if (allocated(file_var_meta_noDD%var_names)) deallocate(file_var_meta_noDD%var_names) file_var_meta_noDD%nvars = 0 endif + + ! Rescale the data that was read if necessary. + if (present(scale)) then ; if (scale /= 1.0) then + data = scale*data + endif ; 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" @@ -727,10 +681,6 @@ subroutine MOM_read_data_1d_noDD(filename, fieldname, data, start_index, & 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) @@ -738,6 +688,12 @@ subroutine MOM_read_data_1d_noDD(filename, fieldname, data, start_index, & file_var_meta_noDD%nvars = 0 endif if (allocated(dim_names)) deallocate(dim_names) + + ! Rescale the data that was read if necessary. + if (present(scale)) then ; if (scale /= 1.0) then + data(:) = scale*data(:) + endif ; endif + 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" @@ -819,10 +775,6 @@ subroutine MOM_read_data_2d_noDD(filename, fieldname, data, start_index, & 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) @@ -831,6 +783,11 @@ subroutine MOM_read_data_2d_noDD(filename, fieldname, data, start_index, & endif if(allocated(dim_names)) deallocate(dim_names) + ! Rescale the data that was read if necessary. + if (present(scale)) then ; if (scale /= 1.0) then + data(:,:) = scale*data(:,:) + endif ; endif + 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" @@ -912,10 +869,7 @@ subroutine MOM_read_data_3d_noDD(filename, fieldname, data, start_index, & 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) @@ -923,6 +877,12 @@ subroutine MOM_read_data_3d_noDD(filename, fieldname, data, start_index, & file_var_meta_noDD%nvars = 0 endif if (allocated(dim_names)) deallocate(dim_names) + + ! Rescale the data that was read if necessary. + if (present(scale)) then ; if (scale /= 1.0) then + data(:,:,:) = scale*data(:,:,:) + endif ; endif + 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" @@ -1008,10 +968,6 @@ subroutine MOM_read_data_4d_noDD(filename, fieldname, data, start_index, & 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) @@ -1019,163 +975,13 @@ subroutine MOM_read_data_4d_noDD(filename, fieldname, data, start_index, & 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 + ! Rescale the data that was read if necessary. if (present(scale)) then ; if (scale /= 1.0) then - call scale_data(data, scale) + data(:,:,:,:) = scale*data(:,:,:,:) 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 + +end subroutine MOM_read_data_4d_noDD !> This routine uses the fms2_io read_data interface to read a pair of distributed @@ -1289,21 +1095,19 @@ subroutine MOM_read_vector_2d_fms2(filename, u_fieldname, v_fieldname, u_data, v 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) + + ! Rescale the data that was read if necessary. + if (present(scale)) then ; if (scale /= 1.0) then + call rescale_comp_data(MOM_Domain, u_data, scale) + call rescale_comp_data(MOM_Domain, v_data, scale) + endif ; endif + end subroutine MOM_read_vector_2d_fms2 !> This routine uses the fms2_io read_data interface to read a pair of distributed @@ -1417,89 +1221,21 @@ subroutine MOM_read_vector_3d_fms2(filename, u_fieldname, v_fieldname, u_data, v 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 + ! Rescale the data that was read if necessary. + if (present(scale)) then ; if (scale /= 1.0) then + call rescale_comp_data(MOM_Domain, u_data, scale) + call rescale_comp_data(MOM_Domain, v_data, scale) + endif ; endif -!> 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 +end subroutine MOM_read_vector_3d_fms2 - 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 diff --git a/config_src/infra/FMS2/MOM_write_field_fms2.F90 b/config_src/infra/FMS2/MOM_write_field_fms2.F90 index 55f25bac9c..24ba5ebb50 100644 --- a/config_src/infra/FMS2/MOM_write_field_fms2.F90 +++ b/config_src/infra/FMS2/MOM_write_field_fms2.F90 @@ -6,18 +6,16 @@ module MOM_write_field_fms2 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_coms_infra, only : PE_here, root_PE, num_PEs use MOM_domain_infra, only : MOM_domain_type -use MOM_domain_infra, only : get_simple_array_i_ind, get_simple_array_j_ind +use MOM_domain_infra, only : domain2d, CENTER, CORNER, NORTH_FACE, EAST_FACE +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, 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 + +use netcdf, only : nf90_max_name ! 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 @@ -60,20 +58,12 @@ module MOM_write_field_fms2 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, & + start_index, edge_lengths, time_level, time_units, & 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 @@ -88,7 +78,6 @@ subroutine write_field_1d_DD(filename, fieldname, data, mode, domain, hor_grid, 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 @@ -105,7 +94,6 @@ subroutine write_field_1d_DD(filename, fieldname, data, mode, domain, hor_grid, ! 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 @@ -159,21 +147,10 @@ subroutine write_field_1d_DD(filename, fieldname, data, mode, domain, hor_grid, 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 @@ -220,24 +197,24 @@ subroutine write_field_1d_DD(filename, fieldname, data, mode, domain, hor_grid, 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, & + call write_data(fileobj_write_field_dd, trim(fieldname), data, 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) + call write_data(fileobj_write_field_dd, trim(fieldname), data, 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, & + start_index, edge_lengths, time_level, time_units, & 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 @@ -252,7 +229,6 @@ subroutine write_field_2d_DD(filename, fieldname, data, mode, domain, hor_grid, 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 @@ -269,7 +245,6 @@ subroutine write_field_2d_DD(filename, fieldname, data, mode, domain, hor_grid, ! 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 @@ -331,21 +306,10 @@ subroutine write_field_2d_DD(filename, fieldname, data, mode, domain, hor_grid, 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 @@ -400,10 +364,10 @@ subroutine write_field_2d_DD(filename, fieldname, data, mode, domain, hor_grid, 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, & + call write_data(fileobj_write_field_dd, trim(fieldname), data, 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) + call write_data(fileobj_write_field_dd, trim(fieldname), data, corner=start, edge_lengths=nwrite) endif ! close the file if (close_the_file) then @@ -411,14 +375,14 @@ subroutine write_field_2d_DD(filename, fieldname, data, mode, domain, hor_grid, 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, & + start_index, edge_lengths, time_level, time_units, & 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 @@ -433,7 +397,6 @@ subroutine write_field_3d_DD(filename, fieldname, data, mode, domain, hor_grid, 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 @@ -450,7 +413,6 @@ subroutine write_field_3d_DD(filename, fieldname, data, mode, domain, hor_grid, ! 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 @@ -509,21 +471,11 @@ subroutine write_field_3d_DD(filename, fieldname, data, mode, domain, hor_grid, 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 @@ -578,17 +530,17 @@ subroutine write_field_3d_DD(filename, fieldname, data, mode, domain, hor_grid, ! 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, & + call write_data(fileobj_write_field_dd, trim(fieldname), data, 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) + call write_data(fileobj_write_field_dd, trim(fieldname), data, 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 @@ -596,7 +548,7 @@ end subroutine write_field_3d_DD !! 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, & + start_index, edge_lengths, time_level, time_units, & 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 @@ -612,8 +564,7 @@ subroutine write_field_4d_DD(filename, fieldname, data, mode, domain, hor_grid, 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 + 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. @@ -629,7 +580,6 @@ subroutine write_field_4d_DD(filename, fieldname, data, mode, domain, hor_grid, ! 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 @@ -686,21 +636,11 @@ subroutine write_field_4d_DD(filename, fieldname, data, mode, domain, hor_grid, 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 @@ -755,17 +695,17 @@ subroutine write_field_4d_DD(filename, fieldname, data, mode, domain, hor_grid, ! 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, & + call write_data(fileobj_write_field_dd, trim(fieldname), data, 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) + call write_data(fileobj_write_field_dd, trim(fieldname), data, 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" @@ -824,7 +764,7 @@ subroutine write_scalar(filename, fieldname, data, mode, time_level, time_units, !>\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())) + allocate(pelist(num_PEs())) pelist(:) = 0 do i=1,size(pelist) pelist(i) = i-1 @@ -887,7 +827,7 @@ end subroutine write_scalar !! 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, & + start_index, edge_lengths, time_level, time_units, & 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 @@ -901,7 +841,6 @@ subroutine write_field_1d_noDD(filename, fieldname, data, mode, hor_grid, z_grid 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 @@ -917,7 +856,6 @@ subroutine write_field_1d_noDD(filename, fieldname, data, mode, hor_grid, z_grid 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 @@ -973,12 +911,6 @@ subroutine write_field_1d_noDD(filename, fieldname, data, mode, hor_grid, z_grid 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")) & @@ -989,7 +921,7 @@ subroutine write_field_1d_noDD(filename, fieldname, data, mode, hor_grid, z_grid !>\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())) + allocate(pelist(num_PEs())) pelist(:) = 0 do i=1,size(pelist) pelist(i) = i-1 @@ -1042,10 +974,10 @@ subroutine write_field_1d_noDD(filename, fieldname, data, mode, hor_grid, z_grid 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, & + call write_data(fileobj_write_field, trim(fieldname), data, 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) + call write_data(fileobj_write_field, trim(fieldname), data, corner=start, edge_lengths=nwrite) endif ! close the file if (close_the_file) then @@ -1053,7 +985,7 @@ subroutine write_field_1d_noDD(filename, fieldname, data, mode, hor_grid, z_grid if (allocated(pelist)) deallocate(pelist) write_field_time_index = 0 endif - nullify(data_tmp) + end subroutine write_field_1d_noDD @@ -1061,7 +993,7 @@ end subroutine write_field_1d_noDD !! 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, & + start_index, edge_lengths, time_level, time_units, & 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 @@ -1075,7 +1007,6 @@ subroutine write_field_2d_noDD(filename, fieldname, data, mode, hor_grid, z_grid 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 @@ -1092,7 +1023,6 @@ subroutine write_field_2d_noDD(filename, fieldname, data, mode, hor_grid, z_grid ! 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 @@ -1154,12 +1084,6 @@ subroutine write_field_2d_noDD(filename, fieldname, data, mode, hor_grid, z_grid 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")) & @@ -1170,7 +1094,7 @@ subroutine write_field_2d_noDD(filename, fieldname, data, mode, hor_grid, z_grid !>\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())) + allocate(pelist(num_PEs())) pelist(:) = 0 do i=1,size(pelist) pelist(i) = i-1 @@ -1224,10 +1148,10 @@ subroutine write_field_2d_noDD(filename, fieldname, data, mode, hor_grid, z_grid 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, & + call write_data(fileobj_write_field, trim(fieldname), data, 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) + call write_data(fileobj_write_field, trim(fieldname), data, corner=start, edge_lengths=nwrite) endif ! close the file if (close_the_file) then @@ -1235,14 +1159,14 @@ subroutine write_field_2d_noDD(filename, fieldname, data, mode, hor_grid, z_grid 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, & + start_index, edge_lengths, time_level, time_units, & 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 @@ -1256,7 +1180,6 @@ subroutine write_field_3d_noDD(filename, fieldname, data, mode, hor_grid, z_grid 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 @@ -1273,7 +1196,6 @@ subroutine write_field_3d_noDD(filename, fieldname, data, mode, hor_grid, z_grid ! 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 @@ -1332,11 +1254,6 @@ subroutine write_field_3d_noDD(filename, fieldname, data, mode, hor_grid, z_grid 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. & @@ -1348,7 +1265,7 @@ subroutine write_field_3d_noDD(filename, fieldname, data, mode, hor_grid, z_grid !>\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())) + allocate(pelist(num_PEs())) pelist(:) = 0 do i=1,size(pelist) pelist(i) = i-1 @@ -1402,10 +1319,10 @@ subroutine write_field_3d_noDD(filename, fieldname, data, mode, hor_grid, z_grid 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, & + call write_data(fileobj_write_field, trim(fieldname), data, 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) + call write_data(fileobj_write_field, trim(fieldname), data, corner=start, edge_lengths=nwrite) endif ! close the file if (close_the_file) then @@ -1413,14 +1330,14 @@ subroutine write_field_3d_noDD(filename, fieldname, data, mode, hor_grid, z_grid 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, & + start_index, edge_lengths, time_level, time_units, & 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 @@ -1435,7 +1352,6 @@ subroutine write_field_4d_noDD(filename, fieldname, data, mode, hor_grid, z_grid 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 @@ -1452,7 +1368,6 @@ subroutine write_field_4d_noDD(filename, fieldname, data, mode, hor_grid, z_grid ! 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 @@ -1509,11 +1424,6 @@ subroutine write_field_4d_noDD(filename, fieldname, data, mode, hor_grid, z_grid 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. & @@ -1525,7 +1435,7 @@ subroutine write_field_4d_noDD(filename, fieldname, data, mode, hor_grid, z_grid !>\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())) + allocate(pelist(num_PEs())) pelist(:) = 0 do i=1,size(pelist) pelist(i) = i-1 @@ -1577,10 +1487,10 @@ subroutine write_field_4d_noDD(filename, fieldname, data, mode, hor_grid, z_grid 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, & + call write_data(fileobj_write_field, trim(fieldname), data, 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) + call write_data(fileobj_write_field, trim(fieldname), data, corner=start, edge_lengths=nwrite) endif ! close the file if (close_the_file) then @@ -1588,75 +1498,6 @@ subroutine write_field_4d_noDD(filename, fieldname, data, mode, hor_grid, z_grid 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 From c68fedfea56e9eca5f820bcf4320af6198f738cc Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 9 Mar 2021 05:14:14 -0500 Subject: [PATCH 014/112] +Change arguments to MOM_register_variable_axes Replaced the two optional arguments xPosition and yPosition to the two routines wrapped by the interface MOM_register_variable_axes in MOM_axis.F90 with a single optional argument, position. Also dramatically refactored the code in read_data_fms2.F90 to eliminate unused variants and adding more granular subroutines to dramatically reduce duplicative code, eliminating several (unexercised) bugs in the process; that file went from 1441 lines long to 924. The code compiles with these changes, but none of this fms2 I/O code is exercised yet in MOM6, so of course all answers are bitwise identical. --- config_src/infra/FMS2/MOM_axis.F90 | 55 +- config_src/infra/FMS2/MOM_read_data_fms2.F90 | 1243 +++++++----------- 2 files changed, 474 insertions(+), 824 deletions(-) diff --git a/config_src/infra/FMS2/MOM_axis.F90 b/config_src/infra/FMS2/MOM_axis.F90 index 48f70bec70..b5d2b3ed88 100644 --- a/config_src/infra/FMS2/MOM_axis.F90 +++ b/config_src/infra/FMS2/MOM_axis.F90 @@ -423,44 +423,33 @@ end function get_time_index !! 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) +subroutine MOM_register_variable_axes_subdomain(fileObj, variableName, io_domain, position) 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=*), intent(in) :: variableName !< name of the variable + type(domain2d), intent(in) :: io_domain !< type that contains the mpp io domain + integer, optional, intent(in) :: position !< A flag indicating where this data is discretized + + ! Local variables 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 :: pos ! Discrete variable position. 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 + + ! Get the lengths of the global indicies, using the discrete position of this variable + pos = CORNER ; if (present(position)) pos = position 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 @@ -520,12 +509,12 @@ 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) +subroutine MOM_register_variable_axes_full(fileObj, variableName, position) 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=*), intent(in) :: variableName !< name of the variable + integer, optional, intent(in) :: position !< A flag indicating where this data is discretized + + ! Local variables character(len=40) :: units ! units corresponding to a specific variable dimension character(len=40), allocatable, dimension(:) :: dim_names ! variable dimension names integer :: i @@ -536,10 +525,12 @@ subroutine MOM_register_variable_axes_full(fileObj, variableName, xPosition, yPo 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 + xpos = CENTER ; ypos = CENTER + if (present(position)) then + if ((position == CORNER) .or. (position == EAST_FACE)) xpos = EAST_FACE + if ((position == CORNER) .or. (position == NORTH_FACE)) ypos = NORTH_FACE + endif + ! get variable dimension names and lengths ndims = get_variable_num_dimensions(fileObj, trim(variableName)) allocate(dimSizes(ndims)) @@ -588,7 +579,7 @@ subroutine MOM_register_variable_axes_full(fileObj, variableName, xPosition, yPo 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") + 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)))) & diff --git a/config_src/infra/FMS2/MOM_read_data_fms2.F90 b/config_src/infra/FMS2/MOM_read_data_fms2.F90 index 27bdcf98e3..72e2d5e1d2 100644 --- a/config_src/infra/FMS2/MOM_read_data_fms2.F90 +++ b/config_src/infra/FMS2/MOM_read_data_fms2.F90 @@ -20,7 +20,7 @@ module MOM_read_data_fms2 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_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 @@ -36,130 +36,89 @@ module MOM_read_data_fms2 !! 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 +!> Type with variable metadata for a netCDF file opened to read +type var_meta_read_file 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 + !! file opened to read +end type var_meta_read_file -!> 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 (var_meta_read_file), 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 +type (var_meta_read_file), private :: file_var_meta_noDD + +! Note the convention for decomposed arrays that: +! edge_lengths(1) = iec - isc + 1 ; edge_lengths(2) = jec - jsc + 1 +! start_index(1) = isc - isg + 1 ; start_index(2) = jsc - jsg + 1 -! !> index of the time_level value that is written to netCDF file by the write_field routines. -! integer, private :: write_field_time_index 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, 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 + 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 + type(MOM_domain_type), intent(in) :: domain !< MOM domain attribute with the mpp_domain decomposition 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 + !! 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 variables 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 + integer :: time_dim ! The dimension position of a variables unlimited time axis, or -1 if it has none. + integer, parameter :: ndim = 1 ! The dimensionality of the array being read + integer, dimension(ndim) :: start, nread ! indices for first data value and number of values to read + integer :: num_var_dims ! The number of dimensions in the file. + character(len=96) :: var_to_read ! variable to read from the netcdf file + character(len=96), allocatable :: dim_names(:) ! variable dimension names + character(len=48) :: err_header ! A preamble for error messages - xpos = CENTER - ypos = CENTER - if (present(x_position)) xpos = x_position - if (present(y_position)) ypos = y_position + err_header = "MOM_read_data_fms2:MOM_read_data_1d_DD: " - 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", 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 + ! Find the matching variable name in the file, opening it and reading metadata if necessary. + call find_varname_in_DD_file(fileobj_read_dd, file_var_meta_DD, fieldname, domain, err_header, & + filename, var_to_read) + + ! Registering the variable axes essentially just specifies the discrete position of this variable. + call MOM_register_variable_axes(fileobj_read_dd, var_to_read) + ! 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(1) = edge_lengths(1) + nread(:) = edge_lengths(:) else + num_var_dims = get_variable_num_dimensions(fileobj_read, trim(var_to_read)) + allocate(dim_names(num_var_dims)) ; dim_names(:) = "" + call get_variable_dimension_names(fileobj_read, trim(var_to_read), dim_names) call get_dimension_size(fileobj_read_dd, trim(dim_names(1)), nread(1)) + deallocate(dim_names) endif - ! read the data - dim_unlim_size = 0 + + time_dim = -1 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) + time_dim = get_time_dim_num_DD(fileobj_read_dd, var_to_read, err_header, filename, timelevel) + if (time_dim == ndim) then ; nread(ndim) = 1 ; start(ndim) = timelevel ; 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 + + ! read the data + if (time_dim > 0) then + call read_data(fileobj_read_dd, trim(var_to_read), data, corner=start, edge_lengths=nread, & + unlim_dim_level=timelevel) + else + call read_data(fileobj_read_dd, trim(var_to_read), data, corner=start, edge_lengths=nread) endif - if (allocated(dim_names)) deallocate(dim_names) + + ! Close the file, if necesssary + close_the_file = .true. ; if (present(leave_file_open)) close_the_file = .not.(leave_file_open) + if (close_the_file) call close_file_read_DD(fileobj_read_dd, file_var_meta_DD) ! Rescale the data that was read if necessary. if (present(scale)) then ; if (scale /= 1.0) then @@ -170,119 +129,58 @@ 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,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 +subroutine MOM_read_data_2d_DD(filename, fieldname, data, domain, start_index, edge_lengths, & + timelevel, position, 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 + type(MOM_domain_type), intent(in) :: domain !< MOM domain attribute with the mpp_domain decomposition 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 + integer, optional, intent(in) :: timelevel !< time level to read + integer, optional, intent(in) :: position !< A flag indicating where this data is located + 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 variables 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 - - xpos = CENTER - ypos = CENTER - if (present(x_position)) xpos = x_position - if (present(y_position)) ypos = y_position + integer :: time_dim ! The dimension position of a variables unlimited time axis, or -1 if it has none. + integer, parameter :: ndim = 2 ! The dimensionality of the array being read + integer, dimension(ndim) :: start, nread ! indices for first data value and number of values to read + character(len=96) :: var_to_read ! variable to read from the netcdf file + character(len=48) :: err_header ! A preamble for error messages - close_the_file = .true. - if (present(leave_file_open)) close_the_file = .not.(leave_file_open) + err_header = "MOM_read_data_fms2:MOM_read_data_2d_DD: " - ! open the file - if (.not.(check_if_open(fileobj_read_dd))) then - 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) - !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 + ! Find the matching variable name in the file, opening it and reading metadata if necessary. + call find_varname_in_DD_file(fileobj_read_dd, file_var_meta_DD, fieldname, domain, err_header, & + filename, var_to_read) - if (present(edge_lengths)) then - nread = edge_lengths - else - nread = shape(data) + ! Registering the variable axes essentially just specifies the discrete position of this variable. + call MOM_register_variable_axes(fileobj_read_dd, var_to_read, position) + + ! 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(:) + nread(:) = shape(data) ; if (present(edge_lengths)) nread(:) = edge_lengths(:) + + time_dim = -1 + if (present(timelevel)) then + time_dim = get_time_dim_num_DD(fileobj_read_dd, var_to_read, err_header, filename, timelevel) + if (time_dim == ndim) then ; nread(ndim) = 1 ; start(ndim) = timelevel ; endif 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 + if (time_dim > 0) then + call read_data(fileobj_read_dd, trim(var_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 - ! 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 + call read_data(fileobj_read_dd, trim(var_to_read), data, corner=start, edge_lengths=nread) endif - if (allocated(dim_names)) deallocate(dim_names) + + ! Close the file, if necessary + close_the_file = .true. ; if (present(leave_file_open)) close_the_file = .not.(leave_file_open) + if (close_the_file) call close_file_read_DD(fileobj_read_dd, file_var_meta_DD) ! Rescale the data that was read if necessary. if (present(scale)) then ; if (scale /= 1.0) then @@ -294,117 +192,57 @@ 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, 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 + timelevel, position, 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 + type(MOM_domain_type), intent(in) :: domain !< MOM domain attribute with the mpp_domain decomposition 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 + !! Default values are the variable dimension sizes + integer, optional, intent(in) :: timelevel !< time level to read + integer, optional, intent(in) :: position !< A flag indicating where this data is discretized + 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 variables 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 + integer :: time_dim ! The dimension position of a variables unlimited time axis, or -1 if it has none. + integer, parameter :: ndim = 3 ! The dimensionality of the array being read + integer, dimension(ndim) :: start, nread ! indices for first data value and number of values to read + character(len=96) :: var_to_read ! variable to read from the netcdf file + character(len=48) :: err_header ! A preamble for error messages - xpos = CENTER - ypos = CENTER - if (present(x_position)) xpos = x_position - if (present(y_position)) ypos = y_position + err_header = "MOM_read_data_fms2:MOM_read_data_3d_DD: " - 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", 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) - - start(:) = 1 - if (present(start_index)) then - start = start_index - !else - ! start(1:2) = first(1:2) - endif + ! Find the matching variable name in the file, opening it and reading metadata if necessary. + call find_varname_in_DD_file(fileobj_read_dd, file_var_meta_DD, fieldname, domain, err_header, & + filename, var_to_read) - 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 + ! Registering the variable axes essentially just specifies the discrete position of this variable. + call MOM_register_variable_axes(fileobj_read_dd, var_to_read, position) + + ! 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(:) + nread(:) = shape(data) ; if (present(edge_lengths)) nread(:) = edge_lengths(:) + + time_dim = -1 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) + time_dim = get_time_dim_num_DD(fileobj_read_dd, var_to_read, err_header, filename, timelevel) + if (time_dim == ndim) then ; nread(ndim) = 1 ; start(ndim) = timelevel ; 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 + + ! read the data + if (time_dim > 0) then + call read_data(fileobj_read_dd, trim(var_to_read), data, corner=start, edge_lengths=nread, & + unlim_dim_level=timelevel) + else + call read_data(fileobj_read_dd, trim(var_to_read), data, corner=start, edge_lengths=nread) endif - if (allocated(dim_names)) deallocate(dim_names) + ! Close the file, if necessary + close_the_file = .true. ; if (present(leave_file_open)) close_the_file = .not.(leave_file_open) + if (close_the_file) call close_file_read_DD(fileobj_read_dd, file_var_meta_DD) ! Rescale the data that was read if necessary. if (present(scale)) then ; if (scale /= 1.0) then @@ -416,122 +254,57 @@ 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, 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 - 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. + timelevel, position, 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 + type(MOM_domain_type), intent(in) :: domain !< MOM domain attribute with the mpp_domain decomposition + 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 + integer, optional, intent(in) :: timelevel !< time level to read + integer, optional, intent(in) :: position !< A flag indicating where this data is located + 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 variables 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 + integer :: time_dim ! The dimension position of a variables unlimited time axis, or -1 if it has none. + integer, parameter :: ndim = 4 ! The dimensionality of the array being read + integer, dimension(ndim) :: start, nread ! indices for first data value and number of values to read + character(len=96) :: var_to_read ! variable to read from the netcdf file + character(len=48) :: err_header ! A preamble for error messages - xpos = CENTER - ypos = CENTER - if (present(x_position)) xpos = x_position - if (present(y_position)) ypos = y_position + err_header = "MOM_read_data_fms2:MOM_read_data_4d_DD: " - 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", 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) - - start(:) = 1 - if (present(start_index)) then - start(:) = start_index(:) - !else - !start(1:2) = first(1:2) - endif + ! Find the matching variable name in the file, opening it and reading metadata if necessary. + call find_varname_in_DD_file(fileobj_read_dd, file_var_meta_DD, fieldname, domain, err_header, & + filename, var_to_read) - 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) + ! Registering the variable axes essentially just specifies the discrete position of this variable. + call MOM_register_variable_axes(fileobj_read_dd, var_to_read, position) + + ! 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(:) + nread(:) = shape(data) ; if (present(edge_lengths)) nread(:) = edge_lengths(:) + + time_dim = -1 + if (present(timelevel)) then + time_dim = get_time_dim_num_DD(fileobj_read_dd, var_to_read, err_header, filename, timelevel) + if (time_dim == ndim) then ; nread(ndim) = 1 ; start(ndim) = timelevel ; endif 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 + if (time_dim > 0) then + call read_data(fileobj_read_dd, trim(var_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) + call read_data(fileobj_read_dd, trim(var_to_read), data, corner=start, edge_lengths=nread) 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) + ! Close the file, if necessary + close_the_file = .true. ; if (present(leave_file_open)) close_the_file = .not.(leave_file_open) + if (close_the_file) call close_file_read_DD(fileobj_read_dd, file_var_meta_DD) ! Rescale the data that was read if necessary. if (present(scale)) then ; if (scale /= 1.0) then @@ -542,53 +315,35 @@ 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, 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, intent(inout) :: data !< data buffer to pass to read_data - real, optional, intent(in) :: scale !< A scaling factor that the scalar is multiplied - !! by before it is returned. - 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 +subroutine MOM_read_data_scalar(filename, fieldname, data, 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, intent(inout) :: data !< The variable to read from read_data + 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 variables 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 + character(len=96) :: var_to_read ! variable to read from the netcdf file + character(len=48) :: err_header ! A preamble for error messages + + err_header = "MOM_read_data_fms2:MOM_read_data_scalar: " + + ! Find the matching variable name in the file, opening it and reading metadata if necessary. + call find_varname_in_noDD_file(fileobj_read, file_var_meta_noDD, fieldname, err_header, filename, var_to_read) - 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 + if (present(timelevel)) then + call read_data(fileobj_read, trim(var_to_read), data, unlim_dim_level=timelevel) + else + call read_data(fileobj_read, trim(var_to_read), data) endif + ! Close the file, if necessary + close_the_file = .true. ; if (present(leave_file_open)) close_the_file = .not.(leave_file_open) + if (close_the_file) call close_file_read_noDD(fileobj_read, file_var_meta_noDD) + ! Rescale the data that was read if necessary. if (present(scale)) then ; if (scale /= 1.0) then data = scale*data @@ -600,94 +355,50 @@ end subroutine MOM_read_data_scalar !! 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, 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 + 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 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 + !! 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 variables 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 + integer :: time_dim ! The dimension position of a variables unlimited time axis, or -1 if it has none. + integer, parameter :: ndim = 1 ! The dimensionality of the array being read + integer, dimension(ndim) :: start, nread ! indices for first data value and number of values to read + character(len=96) :: var_to_read ! variable to read from the netcdf file + character(len=48) :: err_header ! A preamble for error messages - 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)) + err_header = "MOM_read_data_fms2:MOM_read_data_1d_noDD: " + + ! Find the matching variable name in the file, opening it and reading metadata if necessary. + call find_varname_in_noDD_file(fileobj_read, file_var_meta_noDD, fieldname, err_header, filename, var_to_read) - 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(:) + nread(:) = shape(data) ; if (present(edge_lengths)) nread(:) = edge_lengths(:) - ! set the start and nread values that will be passed as the read_data start_index and edge_lengths arguments - start(1)=1 + time_dim = -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) + time_dim = get_time_dim_num_noDD(fileobj_read, var_to_read, err_header, filename, timelevel) + if (time_dim == ndim) then ; nread(ndim) = 1 ; start(ndim) = timelevel ; endif 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 + if (time_dim > 0) then + call read_data(fileobj_read, trim(var_to_read), data, corner=start, edge_lengths=nread, & + unlim_dim_level=timelevel) else - call read_data(fileobj_read, trim(variable_to_read), data, corner=start, edge_lengths=nread) - 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 + call read_data(fileobj_read, trim(var_to_read), data, corner=start, edge_lengths=nread) endif - if (allocated(dim_names)) deallocate(dim_names) + + ! Close the file, if necessary + close_the_file = .true. ; if (present(leave_file_open)) close_the_file = .not.(leave_file_open) + if (close_the_file) call close_file_read_noDD(fileobj_read, file_var_meta_noDD) ! Rescale the data that was read if necessary. if (present(scale)) then ; if (scale /= 1.0) then @@ -696,293 +407,65 @@ subroutine MOM_read_data_1d_noDD(filename, fieldname, data, start_index, & 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" +!> This routine calls the fms_io read_data subroutine to read a 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, 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 - 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. + edge_lengths, timelevel, position, 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 + 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 + integer, optional, intent(in) :: timelevel !< time level to read + integer, optional, intent(in) :: position !< A flag indicating where this data is located + 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 - 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 - ! 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) + ! Local variables + logical :: close_the_file ! indicates whether to close the file after write_data is called; default is .true. + integer :: time_dim ! The dimension position of a variables unlimited time axis, or -1 if it has none. + integer, parameter :: ndim = 2 ! The dimensionality of the array being read + integer, dimension(ndim) :: start, nread ! indices for first data value and number of values to read + character(len=96) :: var_to_read ! variable to read from the netcdf file + character(len=48) :: err_header ! A preamble for error messages - ! Rescale the data that was read if necessary. - if (present(scale)) then ; if (scale /= 1.0) then - data(:,:) = scale*data(:,:) - endif ; endif + err_header = "MOM_read_data_fms2:MOM_read_data_2d_DD: " -end subroutine MOM_read_data_2d_noDD + ! Find the matching variable name in the file, opening it and reading metadata if necessary. + call find_varname_in_noDD_file(fileobj_read, file_var_meta_noDD, fieldname, err_header, filename, var_to_read) -!> 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, 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 - 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 +! ! Registering the variable axes essentially just specifies the discrete position of this variable. +! call MOM_register_variable_axes(fileobj_read, var_to_read, 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))) 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 + start(:) = 1 ; if (present(start_index)) start(:) = start_index(:) + nread(:) = shape(data) ; if (present(edge_lengths)) nread(:) = edge_lengths(:) - if (present(edge_lengths)) then - nread = edge_lengths - else - nread = shape(data) - endif - ! read the data - dim_unlim_size=0 + time_dim = -1 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 - - ! 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 + time_dim = get_time_dim_num_noDD(fileobj_read, var_to_read, err_header, filename, timelevel) + if (time_dim == ndim) then ; nread(ndim) = 1 ; start(ndim) = timelevel ; endif endif - if (allocated(dim_names)) deallocate(dim_names) - - ! Rescale the data that was read if necessary. - if (present(scale)) then ; if (scale /= 1.0) then - data(:,:,:) = scale*data(:,:,:) - endif ; endif -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, 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 - 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 + if (time_dim > 0) then + call read_data(fileobj_read, trim(var_to_read), data, corner=start, edge_lengths=nread, & + unlim_dim_level=timelevel) else - call read_data(fileobj_read, trim(variable_to_read), data, corner=start, edge_lengths=nread) + call read_data(fileobj_read, trim(var_to_read), data, corner=start, edge_lengths=nread) 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) + + ! Close the file, if necessary + close_the_file = .true. ; if (present(leave_file_open)) close_the_file = .not.(leave_file_open) + if (close_the_file) call close_file_read_noDD(fileobj_read, file_var_meta_noDD) ! Rescale the data that was read if necessary. if (present(scale)) then ; if (scale /= 1.0) then - data(:,:,:,:) = scale*data(:,:,:,:) + data(:,:) = scale*data(:,:) endif ; endif -end subroutine MOM_read_data_4d_noDD - +end subroutine MOM_read_data_2d_noDD !> 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 @@ -1236,6 +719,182 @@ subroutine MOM_read_vector_3d_fms2(filename, u_fieldname, v_fieldname, u_data, v end subroutine MOM_read_vector_3d_fms2 +!> Find the case-sensitive name of the variable in a domain-decomposed file-set with a case-insensitive name match. +subroutine find_varname_in_DD_file(fileobj_read, file_meta, fieldname, domain, err_header, filename, var_to_read) + type(FmsNetcdfDomainFile_t), intent(inout) :: fileobj_read !< A handle to a file object, that + !! will be opened if necessary + type(var_meta_read_file), intent(inout) :: file_meta !< A type with metadata about variables in a file. + character(len=*), intent(in) :: fieldname !< The variable name to seek in the file + type(MOM_domain_type), intent(in) :: domain !< MOM domain attribute with the mpp_domain decomposition + character(len=*), intent(in) :: err_header !< A descriptive prefix for error messages + character(len=*), intent(in) :: filename !< The name of the file to read + character(len=*), intent(out) :: var_to_read !< The variable name to read from the file + + ! Local variables + logical :: file_open_success !.true. if call to open_file is successful + logical :: variable_found ! Is a case-insensitive version of the variable found in the netCDF file? + integer :: i + + ! Open the file if necessary + if (.not.(check_if_open(fileobj_read))) then + file_open_success = fms2_open_file(fileobj_read, filename, "read", domain%mpp_domain, is_restart=.false.) + file_meta%nvars = get_num_variables(fileobj_read) + if (file_meta%nvars < 1) call MOM_error(FATAL, "nvars is less than 1 for file "//trim(filename)) + if (.not.(allocated(file_meta%var_names))) allocate(file_meta%var_names(file_meta%nvars)) + call get_variable_names(fileobj_read, file_meta%var_names) + endif + + ! search for the variable in the file + var_to_read = "" + variable_found = .false. + do i=1,file_meta%nvars + if (lowercase(trim(file_meta%var_names(i))) == lowercase(trim(fieldname))) then + variable_found = .true. + var_to_read = trim(file_meta%var_names(i)) + exit + endif + enddo + if (.not.(variable_found)) & + call MOM_error(FATAL, trim(err_header)//trim(fieldname)//" not found in "//trim(filename)) + +end subroutine find_varname_in_DD_file + +!> Find the case-sensitive name of the variable in a domain-decomposed file-set with a case-insensitive name match. +subroutine find_varname_in_noDD_file(fileobj_read, file_meta, fieldname, err_header, filename, var_to_read) + type(FmsNetcdfFile_t), intent(inout) :: fileobj_read !< A handle to a file object, that + !! will be opened if necessary + type(var_meta_read_file), intent(inout) :: file_meta !< A type with metadata about variables in a file. + character(len=*), intent(in) :: fieldname !< The variable name to seek in the file + character(len=*), intent(in) :: err_header !< A descriptive prefix for error messages + character(len=*), intent(in) :: filename !< The name of the file to read + character(len=*), intent(out) :: var_to_read !< The variable name to read from the file + + ! Local variables + logical :: file_open_success !.true. if call to open_file is successful + logical :: variable_found ! Is a case-insensitive version of the variable found in the netCDF file? + integer :: i + + ! Open the file if necessary + if (.not.(check_if_open(fileobj_read))) then + file_open_success = fms2_open_file(fileobj_read, filename, "read", is_restart=.false.) + file_meta%nvars = get_num_variables(fileobj_read) + if (file_meta%nvars < 1) call MOM_error(FATAL, "nvars is less than 1 for file "//trim(filename)) + if (.not.(allocated(file_meta%var_names))) allocate(file_meta%var_names(file_meta%nvars)) + call get_variable_names(fileobj_read, file_meta%var_names) + endif + + ! search for the variable in the file + var_to_read = "" + variable_found = .false. + do i=1,file_meta%nvars + if (lowercase(trim(file_meta%var_names(i))) == lowercase(trim(fieldname))) then + variable_found = .true. + var_to_read = trim(file_meta%var_names(i)) + exit + endif + enddo + if (.not.(variable_found)) & + call MOM_error(FATAL, trim(err_header)//trim(fieldname)//" not found in "//trim(filename)) + +end subroutine find_varname_in_noDD_file + + +!> Close a file that had been open for domain-decomposed reading based on its handle. +subroutine close_file_read_DD(fileobj_read, file_meta) + type(FmsNetcdfDomainFile_t), intent(inout) :: fileobj_read !< A handle to a file object that will be closed + type(var_meta_read_file), intent(inout) :: file_meta !< A type with metadata about variables + !! in a file opened to read. + + if (check_if_open(fileobj_read)) call fms2_close_file(fileobj_read) + if (allocated(file_meta%var_names)) deallocate(file_meta%var_names) + file_meta%nvars = 0 +end subroutine close_file_read_DD + +!> Close a file that had been open for non-domain-decomposed reading based on its handle. +subroutine close_file_read_noDD(fileobj_read, file_meta) + type(FmsNetcdfFile_t), intent(inout) :: fileobj_read !< A handle to a file object that will be closed + type(var_meta_read_file), intent(inout) :: file_meta !< A type with metadata about variables + !! in a file opened to read. + + if (check_if_open(fileobj_read)) call fms2_close_file(fileobj_read) + if (allocated(file_meta%var_names)) deallocate(file_meta%var_names) + file_meta%nvars = 0 +end subroutine close_file_read_noDD + + +!> Return the number of the time dimesion for a variable in an open domain-decomposed file set, +!! or -1 if it has no time (or other unlimited) dimension. +integer function get_time_dim_num_DD(fileobj_read, var_to_read, err_header, filename, timelevel) + type(FmsNetcdfDomainFile_t), intent(in) :: fileobj_read !< A handle to an open file object + character(len=*), intent(in) :: var_to_read !< The variable name to read from the file + character(len=*), intent(in) :: err_header !< A descriptive prefix for error messages + character(len=*), intent(in) :: filename !< The name of the file to read + integer, optional, intent(in) :: timelevel !< A time level to read + + ! Local variables + integer :: i, dim_unlim_size, num_var_dims + character(len=96), allocatable :: dim_names(:) ! variable dimension names + + num_var_dims = get_variable_num_dimensions(fileobj_read, trim(var_to_read)) + allocate(dim_names(num_var_dims)) ; dim_names(:) = "" + call get_variable_dimension_names(fileobj_read, trim(var_to_read), dim_names) + + get_time_dim_num_DD = -1 + do i=1,num_var_dims + if (is_dimension_unlimited(fileobj_read, dim_names(i))) then + get_time_dim_num_DD = i + if (present(timelevel)) then + call get_dimension_size(fileobj_read, dim_names(i), dim_unlim_size) + if (timelevel > dim_unlim_size) call MOM_error(FATAL, trim(err_header)//& + "Attempting to read a time level of "//trim(var_to_read)//& + " that exceeds the size of "//trim(filename)) + endif + exit + endif + enddo + if (get_time_dim_num_DD < 0) & + call MOM_error(WARNING, trim(err_header)//"time level specified, but the variable "//& + trim(var_to_read)//" does not have an unlimited dimension in "//trim(filename)) + deallocate(dim_names) + +end function get_time_dim_num_DD + +!> Return the number of the time dimesion for a variable in an open non-domain-decomposed file, +!! or -1 if it has no time (or other unlimited) dimension. +integer function get_time_dim_num_noDD(fileobj_read, var_to_read, err_header, filename, timelevel) + type(FmsNetcdfFile_t), intent(in) :: fileobj_read !< A handle to an open file object + character(len=*), intent(in) :: var_to_read !< The variable name to read from the file + character(len=*), intent(in) :: err_header !< A descriptive prefix for error messages + character(len=*), intent(in) :: filename !< The name of the file to read + integer, optional, intent(in) :: timelevel !< A time level to read + + ! Local variables + integer :: i, dim_unlim_size, num_var_dims + character(len=96), allocatable :: dim_names(:) ! variable dimension names + + num_var_dims = get_variable_num_dimensions(fileobj_read, trim(var_to_read)) + allocate(dim_names(num_var_dims)) ; dim_names(:) = "" + call get_variable_dimension_names(fileobj_read, trim(var_to_read), dim_names) + + get_time_dim_num_noDD = -1 + do i=1,num_var_dims + if (is_dimension_unlimited(fileobj_read, dim_names(i))) then + get_time_dim_num_noDD = i + if (present(timelevel)) then + call get_dimension_size(fileobj_read, dim_names(i), dim_unlim_size) + if (timelevel > dim_unlim_size) call MOM_error(FATAL, trim(err_header)//& + "Attempting to read a time level of "//trim(var_to_read)//& + " that exceeds the size of "//trim(filename)) + endif + exit + endif + enddo + if (get_time_dim_num_noDD < 0) & + call MOM_error(WARNING, trim(err_header)//"time level specified, but the variable "//& + trim(var_to_read)//" does not have an unlimited dimension in "//trim(filename)) + deallocate(dim_names) + +end function get_time_dim_num_noDD !> 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 From 23a78d2f6d3dc31c4dbaaf5f776dc06a53ca4837 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 9 Mar 2021 13:31:29 -0500 Subject: [PATCH 015/112] Clean up in MOM_restart.F90 Cleaned up MOM_restart.F90 in the wake of the recent merge of FMS2 I/O related changes into MOM6. The changes include calling the recently added functions get_variable_byte_size and get_num_restart_files, and revising the names of several variables in open_restart_units and the order in which the count of files is incremented for greater clarity. There are also a number of duplicative comments that were removed while others were reformatted. All answers and output are bitwise identical. --- src/framework/MOM_restart.F90 | 384 ++++++++++------------------------ 1 file changed, 111 insertions(+), 273 deletions(-) diff --git a/src/framework/MOM_restart.F90 b/src/framework/MOM_restart.F90 index 79ff4b1434..129f52ad4c 100644 --- a/src/framework/MOM_restart.F90 +++ b/src/framework/MOM_restart.F90 @@ -131,7 +131,8 @@ module MOM_restart end interface contains -!!> Register a restart field as obsolete + +!> Register a restart field as obsolete subroutine register_restart_field_as_obsolete(field_name, replacement_name, CS) character(*), intent(in) :: field_name !< Name of restart field that is no longer in use character(*), intent(in) :: replacement_name !< Name of replacement restart field, if applicable @@ -499,8 +500,6 @@ function query_initialized_name(name, CS) result(query_initialized) character(len=*), intent(in) :: name !< The name of the field that is being queried type(MOM_restart_CS), pointer :: CS !< A pointer to a MOM_restart_CS object (intent in) logical :: query_initialized -! This subroutine returns .true. if the field referred to by name has -! initialized from a restart file, and .false. otherwise. integer :: m, n if (.not.associated(CS)) call MOM_error(FATAL, "MOM_restart " // & @@ -515,8 +514,7 @@ function query_initialized_name(name, CS) result(query_initialized) n = m ; exit endif enddo -! Assume that you are going to initialize it now, so set flag to initialized if -! queried again. + ! Assume that you are going to initialize it now, so set flag to initialized if queried again. if (n<=CS%novars) CS%restart_field(n)%initialized = .true. if ((n==CS%novars+1) .and. (is_root_pe())) & call MOM_error(NOTE,"MOM_restart: Unknown restart variable "//name// & @@ -533,8 +531,6 @@ function query_initialized_0d(f_ptr, CS) result(query_initialized) real, target, intent(in) :: f_ptr !< A pointer to the field that is being queried type(MOM_restart_CS), pointer :: CS !< A pointer to a MOM_restart_CS object (intent in) logical :: query_initialized -! This subroutine tests whether the field pointed to by f_ptr has -! been initialized from a restart file. integer :: m, n if (.not.associated(CS)) call MOM_error(FATAL, "MOM_restart " // & @@ -549,8 +545,7 @@ function query_initialized_0d(f_ptr, CS) result(query_initialized) n = m ; exit endif enddo -! Assume that you are going to initialize it now, so set flag to initialized if -! queried again. + ! Assume that you are going to initialize it now, so set flag to initialized if queried again. if (n<=CS%novars) CS%restart_field(n)%initialized = .true. end function query_initialized_0d @@ -560,8 +555,6 @@ function query_initialized_1d(f_ptr, CS) result(query_initialized) real, dimension(:), target, intent(in) :: f_ptr !< A pointer to the field that is being queried type(MOM_restart_CS), pointer :: CS !< A pointer to a MOM_restart_CS object (intent in) logical :: query_initialized -! This subroutine tests whether the field pointed to by f_ptr has -! been initialized from a restart file. integer :: m, n if (.not.associated(CS)) call MOM_error(FATAL, "MOM_restart " // & @@ -576,8 +569,7 @@ function query_initialized_1d(f_ptr, CS) result(query_initialized) n = m ; exit endif enddo -! Assume that you are going to initialize it now, so set flag to initialized if -! queried again. + ! Assume that you are going to initialize it now, so set flag to initialized if queried again. if (n<=CS%novars) CS%restart_field(n)%initialized = .true. end function query_initialized_1d @@ -588,8 +580,6 @@ function query_initialized_2d(f_ptr, CS) result(query_initialized) target, intent(in) :: f_ptr !< A pointer to the field that is being queried type(MOM_restart_CS), pointer :: CS !< A pointer to a MOM_restart_CS object (intent in) logical :: query_initialized -! This subroutine tests whether the field pointed to by f_ptr has -! been initialized from a restart file. integer :: m, n if (.not.associated(CS)) call MOM_error(FATAL, "MOM_restart " // & @@ -604,8 +594,7 @@ function query_initialized_2d(f_ptr, CS) result(query_initialized) n = m ; exit endif enddo -! Assume that you are going to initialize it now, so set flag to initialized if -! queried again. + ! Assume that you are going to initialize it now, so set flag to initialized if queried again. if (n<=CS%novars) CS%restart_field(n)%initialized = .true. end function query_initialized_2d @@ -616,8 +605,6 @@ function query_initialized_3d(f_ptr, CS) result(query_initialized) target, intent(in) :: f_ptr !< A pointer to the field that is being queried type(MOM_restart_CS), pointer :: CS !< A pointer to a MOM_restart_CS object (intent in) logical :: query_initialized -! This subroutine tests whether the field pointed to by f_ptr has -! been initialized from a restart file. integer :: m, n if (.not.associated(CS)) call MOM_error(FATAL, "MOM_restart " // & @@ -632,8 +619,7 @@ function query_initialized_3d(f_ptr, CS) result(query_initialized) n = m ; exit endif enddo -! Assume that you are going to initialize it now, so set flag to initialized if -! queried again. + ! Assume that you are going to initialize it now, so set flag to initialized if queried again. if (n<=CS%novars) CS%restart_field(n)%initialized = .true. end function query_initialized_3d @@ -644,8 +630,6 @@ function query_initialized_4d(f_ptr, CS) result(query_initialized) target, intent(in) :: f_ptr !< A pointer to the field that is being queried type(MOM_restart_CS), pointer :: CS !< A pointer to a MOM_restart_CS object (intent in) logical :: query_initialized -! This subroutine tests whether the field pointed to by f_ptr has -! been initialized from a restart file. integer :: m, n if (.not.associated(CS)) call MOM_error(FATAL, "MOM_restart " // & @@ -660,8 +644,7 @@ function query_initialized_4d(f_ptr, CS) result(query_initialized) n = m ; exit endif enddo -! Assume that you are going to initialize it now, so set flag to initialized if -! queried again. + ! Assume that you are going to initialize it now, so set flag to initialized if queried again. if (n<=CS%novars) CS%restart_field(n)%initialized = .true. end function query_initialized_4d @@ -673,8 +656,6 @@ function query_initialized_0d_name(f_ptr, name, CS) result(query_initialized) character(len=*), intent(in) :: name !< The name of the field that is being queried type(MOM_restart_CS), pointer :: CS !< A pointer to a MOM_restart_CS object (intent in) logical :: query_initialized -! This subroutine tests whether the field pointed to by f_ptr or with the -! specified variable name has been initialized from a restart file. integer :: m, n if (.not.associated(CS)) call MOM_error(FATAL, "MOM_restart " // & @@ -689,8 +670,7 @@ function query_initialized_0d_name(f_ptr, name, CS) result(query_initialized) n = m ; exit endif enddo -! Assume that you are going to initialize it now, so set flag to initialized if -! queried again. + ! Assume that you are going to initialize it now, so set flag to initialized if queried again. if (n<=CS%novars) CS%restart_field(n)%initialized = .true. if (n==CS%novars+1) then if (is_root_pe()) & @@ -709,8 +689,6 @@ function query_initialized_1d_name(f_ptr, name, CS) result(query_initialized) character(len=*), intent(in) :: name !< The name of the field that is being queried type(MOM_restart_CS), pointer :: CS !< A pointer to a MOM_restart_CS object (intent in) logical :: query_initialized -! This subroutine tests whether the field pointed to by f_ptr or with the -! specified variable name has been initialized from a restart file. integer :: m, n if (.not.associated(CS)) call MOM_error(FATAL, "MOM_restart " // & @@ -725,8 +703,7 @@ function query_initialized_1d_name(f_ptr, name, CS) result(query_initialized) n = m ; exit endif enddo -! Assume that you are going to initialize it now, so set flag to initialized if -! queried again. + ! Assume that you are going to initialize it now, so set flag to initialized if queried again. if (n<=CS%novars) CS%restart_field(n)%initialized = .true. if (n==CS%novars+1) then if (is_root_pe()) & @@ -745,8 +722,6 @@ function query_initialized_2d_name(f_ptr, name, CS) result(query_initialized) character(len=*), intent(in) :: name !< The name of the field that is being queried type(MOM_restart_CS), pointer :: CS !< A pointer to a MOM_restart_CS object (intent in) logical :: query_initialized -! This subroutine tests whether the field pointed to by f_ptr or with the -! specified variable name has been initialized from a restart file. integer :: m, n if (.not.associated(CS)) call MOM_error(FATAL, "MOM_restart " // & @@ -761,8 +736,7 @@ function query_initialized_2d_name(f_ptr, name, CS) result(query_initialized) n = m ; exit endif enddo -! Assume that you are going to initialize it now, so set flag to initialized if -! queried again. + ! Assume that you are going to initialize it now, so set flag to initialized if queried again. if (n<=CS%novars) CS%restart_field(n)%initialized = .true. if (n==CS%novars+1) then if (is_root_pe()) & @@ -781,8 +755,6 @@ function query_initialized_3d_name(f_ptr, name, CS) result(query_initialized) character(len=*), intent(in) :: name !< The name of the field that is being queried type(MOM_restart_CS), pointer :: CS !< A pointer to a MOM_restart_CS object (intent in) logical :: query_initialized -! This subroutine tests whether the field pointed to by f_ptr or with the -! specified variable name has been initialized from a restart file. integer :: m, n if (.not.associated(CS)) call MOM_error(FATAL, "MOM_restart " // & @@ -797,8 +769,7 @@ function query_initialized_3d_name(f_ptr, name, CS) result(query_initialized) n = m ; exit endif enddo -! Assume that you are going to initialize it now, so set flag to initialized if -! queried again. + ! Assume that you are going to initialize it now, so set flag to initialized if queried again. if (n<=CS%novars) CS%restart_field(n)%initialized = .true. if (n==CS%novars+1) then if (is_root_pe()) & @@ -817,8 +788,6 @@ function query_initialized_4d_name(f_ptr, name, CS) result(query_initialized) character(len=*), intent(in) :: name !< The name of the field that is being queried type(MOM_restart_CS), pointer :: CS !< A pointer to a MOM_restart_CS object (intent in) logical :: query_initialized -! This subroutine tests whether the field pointed to by f_ptr or with the -! specified variable name has been initialized from a restart file. integer :: m, n if (.not.associated(CS)) call MOM_error(FATAL, "MOM_restart " // & @@ -833,8 +802,7 @@ function query_initialized_4d_name(f_ptr, name, CS) result(query_initialized) n = m ; exit endif enddo -! Assume that you are going to initialize it now, so set flag to initialized if -! queried again. + ! Assume that you are going to initialize it now, so set flag to initialized if queried again. if (n<=CS%novars) CS%restart_field(n)%initialized = .true. if (n==CS%novars+1) then if (is_root_pe()) & @@ -852,10 +820,10 @@ subroutine save_restart(directory, time, G, CS, time_stamped, filename, GV, num_ 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. + !! 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. + !! 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 integer, optional, intent(out) :: num_rest_files !< number of restart files written @@ -865,7 +833,8 @@ subroutine save_restart(directory, time, G, CS, time_stamped, filename, GV, num_ ! 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(fieldtype) :: fields(CS%max_fields) ! Opaque types containing metadata describing + ! each variable that will be written. character(len=512) :: restartpath ! The restart file path (dir/file). character(len=256) :: restartname ! The restart file name (no dir). character(len=8) :: suffix ! A suffix (like _2) that is appended @@ -878,13 +847,12 @@ subroutine save_restart(directory, time, G, CS, time_stamped, filename, GV, num_ integer :: start_var, next_var ! The starting variables of the ! current and next files. type(file_type) :: IO_handle ! The I/O handle of the open fileset - integer :: m, nz, num_files, var_periods + integer :: m, nz, 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. real :: restart_time - character(len=32) :: filename_appendix = '' !fms appendix to filename for ensemble runs + character(len=32) :: filename_appendix = '' ! Appendix to filename for ensemble runs integer :: length integer(kind=8) :: check_val(CS%max_fields,1) integer :: isL, ieL, jsL, jeL, pos @@ -934,24 +902,7 @@ subroutine save_restart(directory, time, G, CS, time_stamped, filename, GV, num_ 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 + var_sz = get_variable_byte_size(hor_grid, z_grid, t_grid, G, nz) if ((m==start_var) .OR. (size_in_file < max_file_size-var_sz)) then size_in_file = size_in_file + var_sz @@ -961,7 +912,7 @@ subroutine save_restart(directory, time, G, CS, time_stamped, filename, GV, num_ enddo next_var = m - !query fms_io if there is a filename_appendix (for ensemble runs) + ! Determine if there is a filename_appendix (used for ensemble runs). call get_filename_appendix(filename_appendix) if (len_trim(filename_appendix) > 0) then length = len_trim(restartname) @@ -1062,20 +1013,16 @@ end subroutine save_restart !! in which they are found. 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 '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. + !! call to restart_init ! 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=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. @@ -1103,7 +1050,7 @@ subroutine restore_state(filename, directory, day, G, CS) "restore_state: Module must be initialized before it is used.") if (CS%novars > CS%max_fields) call restart_error(CS) -! Get NetCDF ids for all of the restart files. + ! Get NetCDF ids for all of the restart files. if ((LEN_TRIM(filename) == 1) .and. (filename(1:1) == 'F')) then num_file = open_restart_units('r', directory, G, CS, IO_handles=IO_handles, & file_paths=unit_path, global_files=unit_is_global) @@ -1118,7 +1065,7 @@ subroutine restore_state(filename, directory, day, G, CS) call MOM_error(FATAL,"MOM_restart: "//mesg) endif -! Get the time from the first file in the list that has one. + ! Get the time from the first file in the list that has one. do n=1,num_file call get_file_times(IO_handles(n), time_vals, ntime) if (ntime < 1) cycle @@ -1133,8 +1080,8 @@ subroutine restore_state(filename, directory, day, G, CS) if (n>num_file) call MOM_error(WARNING,"MOM_restart: " // & "No times found in restart files.") -! Check the remaining files for different times and issue a warning -! if they differ from the first time. + ! Check the remaining files for different times and issue a warning + ! if they differ from the first time. if (is_root_pe()) then do m = n+1,num_file call get_file_times(IO_handles(n), time_vals, ntime) @@ -1152,7 +1099,7 @@ subroutine restore_state(filename, directory, day, G, CS) enddo endif -! Read each variable from the first file in which it is found. + ! Read each variable from the first file in which it is found. do n=1,num_file call get_file_info(IO_handles(n), nvar=nvar) @@ -1266,7 +1213,7 @@ subroutine restore_state(filename, directory, day, G, CS) call close_file(IO_handles(n)) enddo -! Check whether any mandatory fields have not been found. + ! Check whether any mandatory fields have not been found. CS%restart = .true. do m=1,CS%novars if (.not.(CS%restart_field(m)%initialized)) then @@ -1283,23 +1230,23 @@ end subroutine restore_state !> restart_files_exist determines whether any restart files exist. 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. + !! 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. + !! call to restart_init logical :: restart_files_exist !< The function result, which indicates whether !! any of the explicitly or automatically named - !! restart files exist in directory. + !! restart files exist in directory integer :: num_files if (.not.associated(CS)) call MOM_error(FATAL, "MOM_restart " // & "restart_files_exist: Module must be initialized before it is used.") if ((LEN_TRIM(filename) == 1) .and. (filename(1:1) == 'F')) then - num_files = open_restart_units('r', directory, G, CS) + num_files = get_num_restart_files('r', directory, G, CS) else - num_files = open_restart_units(filename, directory, G, CS) + num_files = get_num_restart_files(filename, directory, G, CS) endif restart_files_exist = (num_files > 0) @@ -1310,14 +1257,14 @@ end function restart_files_exist !! and as a side effect stores this information in CS. function determine_is_new_run(filename, directory, G, CS) result(is_new_run) character(len=*), intent(in) :: filename !< The list of restart file names or a single - !! character 'r' to read automatically named files. + !! 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. + !! call to restart_init logical :: is_new_run !< The function result, which indicates whether !! this is a new run, based on the value of - !! filename and whether restart files exist. + !! filename and whether restart files exist if (.not.associated(CS)) call MOM_error(FATAL, "MOM_restart " // & "determine_is_new_run: Module must be initialized before it is used.") @@ -1328,7 +1275,7 @@ function determine_is_new_run(filename, directory, G, CS) result(is_new_run) elseif (filename(1:1) == 'n') then CS%new_run = .true. elseif (filename(1:1) == 'F') then - CS%new_run = (open_restart_units('r', directory, G, CS) == 0) + CS%new_run = (get_num_restart_files('r', directory, G, CS) == 0) else CS%new_run = .false. endif @@ -1341,10 +1288,9 @@ end function determine_is_new_run !! information stored in CS by a previous call to determine_is_new_run. function is_new_run(CS) type(MOM_restart_CS), pointer :: CS !< The control structure returned by a previous - !! call to restart_init. - logical :: is_new_run !< The function result, which indicates whether - !! this is a new run, based on the value of - !! filename and whether restart files exist. + !! call to restart_init + logical :: is_new_run !< The function result, which had been stored in CS during + !! a previous call to determine_is_new_run if (.not.associated(CS)) call MOM_error(FATAL, "MOM_restart " // & "is_new_run: Module must be initialized before it is used.") @@ -1359,47 +1305,42 @@ end function is_new_run function open_restart_units(filename, directory, G, CS, IO_handles, file_paths, & global_files) 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 '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. + !! call to restart_init type(file_type), dimension(:), & - optional, intent(out) :: IO_handles !< The I/O handles of all opened files. + optional, intent(out) :: IO_handles !< The I/O handles of all opened files character(len=*), dimension(:), & - optional, intent(out) :: file_paths !< The full paths to open files. + optional, intent(out) :: file_paths !< The full paths to open files logical, dimension(:), & - optional, intent(out) :: global_files !< True if a file is global. + 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. -! character(len=256) :: mesg ! A message for warnings. integer :: num_restart ! The number of restart files that have already - ! been opened. + ! been opened using their numbered suffix. integer :: start_char ! The location of the starting character in the ! current file name. - integer :: n, m, err, length - - - logical :: fexists - character(len=32) :: filename_appendix = '' !fms appendix to filename for ensemble runs + integer :: nf ! The number of files that have been found so far + integer :: m, length + logical :: still_looking ! If true, the code is still looking for automatically named files + logical :: fexists ! True if a file has been found + character(len=32) :: filename_appendix = '' ! Filename appendix for ensemble runs character(len=80) :: restartname if (.not.associated(CS)) call MOM_error(FATAL, "MOM_restart " // & "open_restart_units: Module must be initialized before it is used.") -! Get NetCDF ids for all of the restart files. - num_restart = 0 ; n = 1 ; start_char = 1 + ! Get NetCDF ids for all of the restart files. + num_restart = 0 ; nf = 0 ; start_char = 1 do while (start_char <= len_trim(filename) ) do m=start_char,len_trim(filename) if (filename(m:m) == ' ') exit @@ -1415,12 +1356,11 @@ function open_restart_units(filename, directory, G, CS, IO_handles, file_paths, enddo if ((fname(1:1)=='r') .and. ( len_trim(fname) == 1)) then - err = 0 - if (num_restart > 0) err = 1 ! Avoid going through the file list twice. - do while (err == 0) + still_looking = (num_restart <= 0) ! Avoid going through the file list twice. + do while (still_looking) restartname = trim(CS%restartfile) - ! query fms_io if there is a filename_appendix (for ensemble runs) + ! Determine if there is a filename_appendix (used for ensemble runs). call get_filename_appendix(filename_appendix) if (len_trim(filename_appendix) > 0) then length = len_trim(restartname) @@ -1439,33 +1379,37 @@ function open_restart_units(filename, directory, G, CS, IO_handles, file_paths, endif if (num_restart > 0) filepath = trim(filepath) // suffix - ! if (.not.file_exists(filepath)) & - filepath = trim(filepath)//".nc" + filepath = trim(filepath)//".nc" num_restart = num_restart + 1 + ! Look for a global netCDF file. inquire(file=filepath, exist=fexists) if (fexists) then + nf = nf + 1 if (present(IO_handles)) & - call open_file(IO_handles(n), trim(filepath), READONLY_FILE, & + call open_file(IO_handles(nf), trim(filepath), READONLY_FILE, & threading=MULTIPLE, fileset=SINGLE_FILE) - if (present(global_files)) global_files(n) = .true. + if (present(global_files)) global_files(nf) = .true. + if (present(file_paths)) file_paths(nf) = filepath elseif (CS%parallel_restartfiles) then ! Look for decomposed files using the I/O Layout. fexists = file_exists(filepath, G%Domain) - if (fexists .and. (present(IO_handles))) & - call open_file(IO_handles(n), trim(filepath), READONLY_FILE, MOM_domain=G%Domain) - if (fexists .and. present(global_files)) global_files(n) = .false. + if (fexists) then + nf = nf + 1 + if (present(IO_handles)) & + call open_file(IO_handles(nf), trim(filepath), READONLY_FILE, MOM_domain=G%Domain) + if (present(global_files)) global_files(nf) = .false. + if (present(file_paths)) file_paths(nf) = filepath + endif endif if (fexists) then - if (present(file_paths)) file_paths(n) = filepath - n = n + 1 if (is_root_pe() .and. (present(IO_handles))) & call MOM_error(NOTE, "MOM_restart: MOM run restarted using : "//trim(filepath)) else - err = 1 ; exit + still_looking = .false. ; exit endif - enddo ! while (err == 0) loop + enddo ! while (still_looking) loop else filepath = trim(directory)//trim(fname) inquire(file=filepath, exist=fexists) @@ -1473,12 +1417,12 @@ function open_restart_units(filename, directory, G, CS, IO_handles, file_paths, inquire(file=filepath, exist=fexists) if (fexists) then + nf = nf + 1 if (present(IO_handles)) & - call open_file(IO_handles(n), trim(filepath), READONLY_FILE, & + call open_file(IO_handles(nf), trim(filepath), READONLY_FILE, & threading=MULTIPLE, fileset=SINGLE_FILE) - if (present(global_files)) global_files(n) = .true. - if (present(file_paths)) file_paths(n) = filepath - n = n + 1 + if (present(global_files)) global_files(nf) = .true. + if (present(file_paths)) file_paths(nf) = filepath if (is_root_pe() .and. (present(IO_handles))) & call MOM_error(NOTE,"MOM_restart: MOM run restarted using : "//trim(filepath)) else @@ -1487,138 +1431,32 @@ function open_restart_units(filename, directory, G, CS, IO_handles, file_paths, endif endif - enddo ! while (start_char < strlen(filename)) loop - num_files = n-1 + enddo ! while (start_char < len_trim(filename)) loop + num_files = nf 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. +!> get_num_restart_files returns the number of existing restart files that match the provided +!! directory structure and other information stored in the control structure and optionally +!! also provides the full paths to these files. +function get_num_restart_files(filenames, directory, G, CS, file_paths) result(num_files) + character(len=*), intent(in) :: filenames !< 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. + !! 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 + optional, intent(out) :: file_paths !< The full paths to the restart files. + integer :: num_files !< The function result, the number of files (both automatically named + !! restart files and others explicitly in filename) that have been opened 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)) .or. file_exists(trim(filepath_temp)//".0000")) 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)) .or. file_exists(trim(filepath_temp2)//".0000")) 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)) .or. file_exists(trim(filepath_temp2)//".0000")) 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 + ! This call uses open_restart_units without the optional arguments needed to actually + ! open the files to determine the number of restart files. + num_files = open_restart_units(filenames, directory, G, CS, file_paths=file_paths) end function get_num_restart_files @@ -1777,34 +1615,34 @@ 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 +function get_variable_byte_size(hor_grid, z_grid, t_grid, G, num_z) result(var_sz) + character(len=8), intent(in) :: hor_grid !< The horizontal grid string to interpret + character(len=8), intent(in) :: z_grid !< The vertical grid string to interpret + character(len=8), intent(in) :: t_grid !< A time string to interpret + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + integer, intent(in) :: num_z !< The number of vertical layers in the grid + integer(kind=8) :: var_sz !< The function result, the size in bytes of a variable + + ! Local variables + integer :: var_periods ! The number of entries in a time-periodic axis + character(len=8) :: t_grid_read, t_grid_tmp ! Modified versions of t_grid if (trim(hor_grid) == '1') then var_sz = 8 - else + else ! This may be an overestimate, as it is based on symmetric-memory corner points. 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) + case ('L') ; var_sz = var_sz * num_z + case ('i') ; var_sz = var_sz * (num_z+1) end select - if (adjustl(t_grid(1:1)) == 'p') then - if (len_trim(t_grid(2:8)) > 0) then + t_grid_tmp = adjustl(t_grid) + if (t_grid_tmp(1:1) == 'p') then + if (len_trim(t_grid_tmp(2:8)) > 0) then var_periods = -1 - t_grid_read = adjustl(t_grid(2:8)) + t_grid_read = adjustl(t_grid_tmp(2:8)) read(t_grid_read,*) var_periods if (var_periods > 1) var_sz = var_sz * var_periods endif From aab2ad645142c41578cff8e6a2454932d603cfbb Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 12 Mar 2021 10:48:29 -0500 Subject: [PATCH 016/112] +Add ability to read fields via FMS2 interfaces Added the option to use FMS2 interfaces to read variables in the FMS2 version of MOM_io_infra.F90. For now, this is controlled by a hard-coded module variable, FMS2_reads, in MOM_io.F90. Also extensively revised MOM_read_fms2.F90 to add the new public subroutine prepare_to_read_var that is used from MOM_io_infra.F90, to systematically determine the directions that axes in files using the cartesian_axis attribute before resorting to using the axis names or units. All of the subroutines from MOM_read_fms2.F90 whose functionality has been merged into MOM_io_infra.F90 have now been removed. All answers are bitwise identical and reproduce the FMS1 test cases, but there is a new publicly visible routine. --- config_src/infra/FMS2/MOM_io_infra.F90 | 236 +++- config_src/infra/FMS2/MOM_read_data_fms2.F90 | 1037 ++++++------------ 2 files changed, 550 insertions(+), 723 deletions(-) diff --git a/config_src/infra/FMS2/MOM_io_infra.F90 b/config_src/infra/FMS2/MOM_io_infra.F90 index 3ea201235a..22548218d1 100644 --- a/config_src/infra/FMS2/MOM_io_infra.F90 +++ b/config_src/infra/FMS2/MOM_io_infra.F90 @@ -7,6 +7,10 @@ module MOM_io_infra use MOM_domain_infra, only : domain2d, domain1d, CENTER, CORNER, NORTH_FACE, EAST_FACE use MOM_error_infra, only : MOM_error=>MOM_err, NOTE, FATAL, WARNING +use MOM_read_data_fms2, only : prepare_to_read_var +use fms2_io_mod, only : fms2_open_file => open_file, fms2_close_file => close_file +use fms2_io_mod, only : FmsNetcdfDomainFile_t, fms2_read_data => read_data, check_if_open + use fms_mod, only : write_version_number, open_namelist_file, check_nml_error use fms_io_mod, only : file_exist, field_exist, field_size, read_data use fms_io_mod, only : fms_io_exit, get_filename_appendix @@ -46,7 +50,7 @@ module MOM_io_infra module procedure MOM_file_exists end interface -!> Open a file (or fileset) for parallel or single-file I/). +!> Open a file (or fileset) for parallel or single-file I/O. interface open_file module procedure open_file_type, open_file_unit end interface open_file @@ -100,6 +104,9 @@ module MOM_io_infra logical :: open_to_write = .false. !< If true, this file or fileset can be written to end type file_type +!> For now, this is hard-coded to exercise the new FMS2 interfaces. +logical :: FMS2_reads = .true. + contains !> Reads the checksum value for a field that was recorded in a file, along with a flag indicating @@ -425,7 +432,31 @@ subroutine MOM_read_data_0d(filename, fieldname, data, timelevel, scale, MOM_Dom type(MOM_domain_type), & optional, intent(in) :: MOM_Domain !< The MOM_Domain that describes the decomposition - if (present(MOM_Domain)) then + ! Local variables + type(FmsNetcdfDomainFile_t) :: fileobj ! A handle to a domain-decomposed file object + logical :: has_time_dim ! True if the variable has an unlimited time axis. + character(len=96) :: var_to_read ! Name of variable to read from the netcdf file + logical :: success ! True if the file was successfully opened + + if (present(MOM_Domain) .and. FMS2_reads) then + ! Open the FMS2 file-set. + success = fms2_open_file(fileobj, filename, "read", MOM_domain%mpp_domain, is_restart=.false.) + if (.not.success) call MOM_error(FATAL, "Failed to open "//trim(filename)) + + ! Find the matching case-insensitive variable name in the file and prepare to read it. + call prepare_to_read_var(fileobj, fieldname, MOM_domain, "MOM_read_data_1d: ", filename, & + var_to_read, has_time_dim, timelevel) + + ! Read the data. + if (present(timelevel) .and. has_time_dim) then + call fms2_read_data(fileobj, var_to_read, data, unlim_dim_level=timelevel) + else + call fms2_read_data(fileobj, var_to_read, data) + endif + + ! Close the file-set. + if (check_if_open(fileobj)) call fms2_close_file(fileobj) + elseif (present(MOM_Domain)) then ! Read the variable using the FMS-1 interface. call read_data(filename, fieldname, data, MOM_Domain%mpp_domain, timelevel=timelevel) else call read_data(filename, fieldname, data, timelevel=timelevel, no_domain=.true.) @@ -449,7 +480,31 @@ subroutine MOM_read_data_1d(filename, fieldname, data, timelevel, scale, MOM_Dom type(MOM_domain_type), & optional, intent(in) :: MOM_Domain !< The MOM_Domain that describes the decomposition - if (present(MOM_Domain)) then + ! Local variables + type(FmsNetcdfDomainFile_t) :: fileobj ! A handle to a domain-decomposed file object + logical :: has_time_dim ! True if the variable has an unlimited time axis. + character(len=96) :: var_to_read ! Name of variable to read from the netcdf file + logical :: success ! True if the file was successfully opened + + if (present(MOM_Domain) .and. FMS2_reads) then + ! Open the FMS2 file-set. + success = fms2_open_file(fileobj, filename, "read", MOM_domain%mpp_domain, is_restart=.false.) + if (.not.success) call MOM_error(FATAL, "Failed to open "//trim(filename)) + + ! Find the matching case-insensitive variable name in the file and prepare to read it. + call prepare_to_read_var(fileobj, fieldname, MOM_domain, "MOM_read_data_1d: ", filename, & + var_to_read, has_time_dim, timelevel) + + ! Read the data. + if (present(timelevel) .and. has_time_dim) then + call fms2_read_data(fileobj, var_to_read, data, unlim_dim_level=timelevel) + else + call fms2_read_data(fileobj, var_to_read, data) + endif + + ! Close the file-set. + if (check_if_open(fileobj)) call fms2_close_file(fileobj) + elseif (present(MOM_Domain)) then ! Read the variable using the FMS-1 interface. call read_data(filename, fieldname, data, MOM_Domain%mpp_domain, timelevel=timelevel) else call read_data(filename, fieldname, data, timelevel=timelevel, no_domain=.true.) @@ -476,8 +531,34 @@ subroutine MOM_read_data_2d(filename, fieldname, data, MOM_Domain, & real, optional, intent(in) :: scale !< A scaling factor that the field is multiplied !! by before it is returned. - call read_data(filename, fieldname, data, MOM_Domain%mpp_domain, & - timelevel=timelevel, position=position) + ! Local variables + type(FmsNetcdfDomainFile_t) :: fileobj ! A handle to a domain-decomposed file object + logical :: has_time_dim ! True if the variable has an unlimited time axis. + character(len=96) :: var_to_read ! Name of variable to read from the netcdf file + logical :: success ! True if the file was successfully opened + + if (FMS2_reads) then + ! Open the FMS2 file-set. + success = fms2_open_file(fileobj, filename, "read", MOM_domain%mpp_domain, is_restart=.false.) + if (.not.success) call MOM_error(FATAL, "Failed to open "//trim(filename)) + + ! Find the matching case-insensitive variable name in the file and prepare to read it. + call prepare_to_read_var(fileobj, fieldname, MOM_domain, "MOM_read_data_2d: ", filename, & + var_to_read, has_time_dim, timelevel, position) + + ! Read the data. + if (present(timelevel) .and. has_time_dim) then + call fms2_read_data(fileobj, var_to_read, data, unlim_dim_level=timelevel) + else + call fms2_read_data(fileobj, var_to_read, data) + endif + + ! Close the file-set. + if (check_if_open(fileobj)) call fms2_close_file(fileobj) + else ! Read the variable using the FMS-1 interface. + call read_data(filename, fieldname, data, MOM_Domain%mpp_domain, & + timelevel=timelevel, position=position) + endif if (present(scale)) then ; if (scale /= 1.0) then call rescale_comp_data(MOM_Domain, data, scale) @@ -506,6 +587,8 @@ subroutine MOM_read_data_2d_region(filename, fieldname, data, start, nread, MOM_ real, optional, intent(in) :: scale !< A scaling factor that the field is multiplied !! by before it is returned. + ! This subroutine does not have an FMS-2 variant yet. + if (present(MOM_Domain)) then call read_data(filename, fieldname, data, start, nread, domain=MOM_Domain%mpp_domain, & no_domain=no_domain) @@ -539,8 +622,34 @@ subroutine MOM_read_data_3d(filename, fieldname, data, MOM_Domain, & real, optional, intent(in) :: scale !< A scaling factor that the field is multiplied !! by before it is returned. - call read_data(filename, fieldname, data, MOM_Domain%mpp_domain, & - timelevel=timelevel, position=position) + ! Local variables + type(FmsNetcdfDomainFile_t) :: fileobj ! A handle to a domain-decomposed file object + logical :: has_time_dim ! True if the variable has an unlimited time axis. + character(len=96) :: var_to_read ! Name of variable to read from the netcdf file + logical :: success ! True if the file was successfully opened + + if (FMS2_reads) then + ! Open the FMS2 file-set. + success = fms2_open_file(fileobj, filename, "read", MOM_domain%mpp_domain, is_restart=.false.) + if (.not.success) call MOM_error(FATAL, "Failed to open "//trim(filename)) + + ! Find the matching case-insensitive variable name in the file and prepare to read it. + call prepare_to_read_var(fileobj, fieldname, MOM_domain, "MOM_read_data_3d: ", filename, & + var_to_read, has_time_dim, timelevel, position) + + ! Read the data. + if (present(timelevel) .and. has_time_dim) then + call fms2_read_data(fileobj, var_to_read, data, unlim_dim_level=timelevel) + else + call fms2_read_data(fileobj, var_to_read, data) + endif + + ! Close the file-set. + if (check_if_open(fileobj)) call fms2_close_file(fileobj) + else ! Read the variable using the FMS-1 interface. + call read_data(filename, fieldname, data, MOM_Domain%mpp_domain, & + timelevel=timelevel, position=position) + endif if (present(scale)) then ; if (scale /= 1.0) then call rescale_comp_data(MOM_Domain, data, scale) @@ -563,8 +672,35 @@ subroutine MOM_read_data_4d(filename, fieldname, data, MOM_Domain, & real, optional, intent(in) :: scale !< A scaling factor that the field is multiplied !! by before it is returned. - call read_data(filename, fieldname, data, MOM_Domain%mpp_domain, & - timelevel=timelevel, position=position) + + ! Local variables + type(FmsNetcdfDomainFile_t) :: fileobj ! A handle to a domain-decomposed file object + logical :: has_time_dim ! True if the variable has an unlimited time axis. + character(len=96) :: var_to_read ! Name of variable to read from the netcdf file + logical :: success ! True if the file was successfully opened + + if (FMS2_reads) then + ! Open the FMS2 file-set. + success = fms2_open_file(fileobj, filename, "read", MOM_domain%mpp_domain, is_restart=.false.) + if (.not.success) call MOM_error(FATAL, "Failed to open "//trim(filename)) + + ! Find the matching case-insensitive variable name in the file and prepare to read it. + call prepare_to_read_var(fileobj, fieldname, MOM_domain, "MOM_read_data_4d: ", filename, & + var_to_read, has_time_dim, timelevel, position) + + ! Read the data. + if (present(timelevel) .and. has_time_dim) then + call fms2_read_data(fileobj, var_to_read, data, unlim_dim_level=timelevel) + else + call fms2_read_data(fileobj, var_to_read, data) + endif + + ! Close the file-set. + if (check_if_open(fileobj)) call fms2_close_file(fileobj) + else ! Read the variable using the FMS-1 interface. + call read_data(filename, fieldname, data, MOM_Domain%mpp_domain, & + timelevel=timelevel, position=position) + endif if (present(scale)) then ; if (scale /= 1.0) then call rescale_comp_data(MOM_Domain, data, scale) @@ -615,7 +751,12 @@ subroutine MOM_read_vector_2d(filename, u_fieldname, v_fieldname, u_data, v_data logical, optional, intent(in) :: scalar_pair !< If true, a pair of scalars are to be read real, optional, intent(in) :: scale !< A scaling factor that the fields are multiplied !! by before they are returned. - integer :: u_pos, v_pos + ! Local variables + type(FmsNetcdfDomainFile_t) :: fileobj ! A handle to a domain-decomposed file object + logical :: has_time_dim ! True if the variables have an unlimited time axis. + character(len=96) :: u_var, v_var ! Name of u and v variables to read from the netcdf file + logical :: success ! True if the file was successfully opened + integer :: u_pos, v_pos ! Flags indicating the positions of the u- and v- components. u_pos = EAST_FACE ; v_pos = NORTH_FACE if (present(stagger)) then @@ -624,10 +765,35 @@ subroutine MOM_read_vector_2d(filename, u_fieldname, v_fieldname, u_data, v_data elseif (stagger == AGRID) then ; u_pos = CENTER ; v_pos = CENTER ; endif endif - call read_data(filename, u_fieldname, u_data, MOM_Domain%mpp_domain, & - timelevel=timelevel, position=u_pos) - call read_data(filename, v_fieldname, v_data, MOM_Domain%mpp_domain, & - timelevel=timelevel, position=v_pos) + if (FMS2_reads) then + ! Open the FMS2 file-set. + success = fms2_open_file(fileobj, filename, "read", MOM_domain%mpp_domain, is_restart=.false.) + if (.not.success) call MOM_error(FATAL, "Failed to open "//trim(filename)) + + ! Find the matching case-insensitive u- and v-variable names in the file and prepare to read them. + call prepare_to_read_var(fileobj, u_fieldname, MOM_domain, "MOM_read_vector_2d: ", filename, & + u_var, has_time_dim, timelevel, position=u_pos) + call prepare_to_read_var(fileobj, v_fieldname, MOM_domain, "MOM_read_vector_2d: ", filename, & + v_var, has_time_dim, timelevel, position=v_pos) + + ! Read the u-data and v-data. There would already been an error message for one + ! of the variables if they are inconsistent in having an unlimited dimension. + if (present(timelevel) .and. has_time_dim) then + call fms2_read_data(fileobj, u_var, u_data, unlim_dim_level=timelevel) + call fms2_read_data(fileobj, v_var, v_data, unlim_dim_level=timelevel) + else + call fms2_read_data(fileobj, u_var, u_data) + call fms2_read_data(fileobj, v_var, v_data) + endif + + ! Close the file-set. + if (check_if_open(fileobj)) call fms2_close_file(fileobj) + else ! Read the variable using the FMS-1 interface. + call read_data(filename, u_fieldname, u_data, MOM_Domain%mpp_domain, & + timelevel=timelevel, position=u_pos) + call read_data(filename, v_fieldname, v_data, MOM_Domain%mpp_domain, & + timelevel=timelevel, position=v_pos) + endif if (present(scale)) then ; if (scale /= 1.0) then call rescale_comp_data(MOM_Domain, u_data, scale) @@ -651,11 +817,16 @@ subroutine MOM_read_vector_3d(filename, u_fieldname, v_fieldname, u_data, v_data type(MOM_domain_type), intent(in) :: MOM_Domain !< The MOM_Domain that describes the decomposition 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 - logical, optional, intent(in) :: scalar_pair !< If true, a pair of scalars are to be read.cretized + logical, optional, intent(in) :: scalar_pair !< If true, a pair of scalars are to be read. real, optional, intent(in) :: scale !< A scaling factor that the fields are multiplied !! by before they are returned. - integer :: u_pos, v_pos + ! Local variables + type(FmsNetcdfDomainFile_t) :: fileobj ! A handle to a domain-decomposed file object + logical :: has_time_dim ! True if the variables have an unlimited time axis. + character(len=96) :: u_var, v_var ! Name of u and v variables to read from the netcdf file + logical :: success ! True if the file was successfully opened + integer :: u_pos, v_pos ! Flags indicating the positions of the u- and v- components. u_pos = EAST_FACE ; v_pos = NORTH_FACE if (present(stagger)) then @@ -664,10 +835,35 @@ subroutine MOM_read_vector_3d(filename, u_fieldname, v_fieldname, u_data, v_data elseif (stagger == AGRID) then ; u_pos = CENTER ; v_pos = CENTER ; endif endif - call read_data(filename, u_fieldname, u_data, MOM_Domain%mpp_domain, & - timelevel=timelevel, position=u_pos) - call read_data(filename, v_fieldname, v_data, MOM_Domain%mpp_domain, & - timelevel=timelevel, position=v_pos) + if (FMS2_reads) then + ! Open the FMS2 file-set. + success = fms2_open_file(fileobj, filename, "read", MOM_domain%mpp_domain, is_restart=.false.) + if (.not.success) call MOM_error(FATAL, "Failed to open "//trim(filename)) + + ! Find the matching case-insensitive u- and v-variable names in the file and prepare to read them. + call prepare_to_read_var(fileobj, u_fieldname, MOM_domain, "MOM_read_vector_3d: ", filename, & + u_var, has_time_dim, timelevel, position=u_pos) + call prepare_to_read_var(fileobj, v_fieldname, MOM_domain, "MOM_read_vector_3d: ", filename, & + v_var, has_time_dim, timelevel, position=v_pos) + + ! Read the u-data and v-data, dangerously assuming either both or neither have time dimensions. + ! There would already been an error message for one of the variables if they are inconsistent. + if (present(timelevel) .and. has_time_dim) then + call fms2_read_data(fileobj, u_var, u_data, unlim_dim_level=timelevel) + call fms2_read_data(fileobj, v_var, v_data, unlim_dim_level=timelevel) + else + call fms2_read_data(fileobj, u_var, u_data) + call fms2_read_data(fileobj, v_var, v_data) + endif + + ! Close the file-set. + if (check_if_open(fileobj)) call fms2_close_file(fileobj) + else ! Read the variable using the FMS-1 interface. + call read_data(filename, u_fieldname, u_data, MOM_Domain%mpp_domain, & + timelevel=timelevel, position=u_pos) + call read_data(filename, v_fieldname, v_data, MOM_Domain%mpp_domain, & + timelevel=timelevel, position=v_pos) + endif if (present(scale)) then ; if (scale /= 1.0) then call rescale_comp_data(MOM_Domain, u_data, scale) diff --git a/config_src/infra/FMS2/MOM_read_data_fms2.F90 b/config_src/infra/FMS2/MOM_read_data_fms2.F90 index 72e2d5e1d2..83a10e7e30 100644 --- a/config_src/infra/FMS2/MOM_read_data_fms2.F90 +++ b/config_src/infra/FMS2/MOM_read_data_fms2.F90 @@ -2,316 +2,314 @@ 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_infra, only : MOM_error=>MOM_err, NOTE, FATAL, WARNING +use MOM_error_infra, only : MOM_error=>MOM_err, NOTE, FATAL, WARNING, is_root_PE use MOM_domain_infra, only : MOM_domain_type, AGRID, BGRID_NE, CGRID_NE use MOM_domain_infra, only : domain2d, CENTER, CORNER, NORTH_FACE, EAST_FACE -use MOM_domain_infra, only : rescale_comp_data use MOM_string_functions, only : lowercase -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 fms2_io_mod, only : FmsNetcdfDomainFile_t, FmsNetcdfFile_t +use fms2_io_mod, only : fms2_open_file => open_file, fms2_close_file => close_file +use fms2_io_mod, only : get_num_variables, get_variable_names, check_if_open +use fms2_io_mod, only : read_data, variable_exists, get_variable_size, get_variable_units +use fms2_io_mod, only : get_variable_attribute, attribute_exists => variable_att_exists +use fms2_io_mod, only : get_variable_num_dimensions, get_variable_dimension_names +use fms2_io_mod, only : is_dimension_unlimited, get_dimension_size +use fms2_io_mod, only : is_dimension_registered, register_axis implicit none ; private -public MOM_read_data_scalar, MOM_read_vector_2d_fms2, MOM_read_vector_3d_fms2 -public 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 -type var_meta_read_file - 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 -end type var_meta_read_file - -!> type to hold metadata for variables in a domain-decomposed file -type (var_meta_read_file), private :: file_var_meta_DD - -!> type to hold metadata for variables in a non-domain-decomposed file -type (var_meta_read_file), private :: file_var_meta_noDD - -! Note the convention for decomposed arrays that: -! edge_lengths(1) = iec - isc + 1 ; edge_lengths(2) = jec - jsc + 1 -! start_index(1) = isc - isg + 1 ; start_index(2) = jsc - jsg + 1 - +public prepare_to_read_var +! public MOM_read_data_scalar, MOM_read_data_2d_noDD, MOM_read_data_1d_noDD 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, 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 - type(MOM_domain_type), intent(in) :: domain !< MOM domain attribute with the mpp_domain decomposition - 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 +!> Find the case-insensitive name match with a variable in a domain-decomposed file-set +!! opening the file(s) as necessary, prepare FMS2 to read this variable, and return some +!! information needed to call read_data correctly for this variable and file. +subroutine prepare_to_read_var(fileobj, fieldname, domain, err_header, filename, var_to_read, & + has_time_dim, timelevel, position) + type(FmsNetcdfDomainFile_t), intent(inout) :: fileobj !< A handle to an FMS2 file object, that + !! will be opened if necessary + character(len=*), intent(in) :: fieldname !< The variable name to seek in the file + type(MOM_domain_type), intent(in) :: domain !< MOM domain attribute with the mpp_domain decomposition + character(len=*), intent(in) :: err_header !< A descriptive prefix for error messages + character(len=*), intent(in) :: filename !< The name of the file to read + character(len=*), intent(out) :: var_to_read !< The variable name to read from the file + logical, optional, intent(out) :: has_time_dim !< Indicates whether fieldname has a time dimension + integer, optional, intent(in) :: timelevel !< A time level to read + integer, optional, intent(in) :: position !< A flag indicating where this variable is discretized ! Local variables - logical :: close_the_file ! indicates whether to close the file after write_data is called; default is .true. - integer :: time_dim ! The dimension position of a variables unlimited time axis, or -1 if it has none. - integer, parameter :: ndim = 1 ! The dimensionality of the array being read - integer, dimension(ndim) :: start, nread ! indices for first data value and number of values to read - integer :: num_var_dims ! The number of dimensions in the file. - character(len=96) :: var_to_read ! variable to read from the netcdf file + logical :: file_open_success !.true. if call to open_file is successful + logical :: variable_found ! Is a case-insensitive version of the variable found in the netCDF file? + character(len=96), allocatable, dimension(:) :: var_names !< array for names of variables in a netCDF + !! file opened to read character(len=96), allocatable :: dim_names(:) ! variable dimension names - character(len=48) :: err_header ! A preamble for error messages + integer :: nvars ! The number of variables in the file. + integer :: i, dim_unlim_size, num_var_dims, time_dim - err_header = "MOM_read_data_fms2:MOM_read_data_1d_DD: " + ! Open the file if necessary + if (.not.(check_if_open(fileobj))) then + file_open_success = fms2_open_file(fileobj, filename, "read", domain%mpp_domain, is_restart=.false.) + if (.not.file_open_success) call MOM_error(FATAL, trim(err_header)//" failed to open "//trim(filename)) + endif - ! Find the matching variable name in the file, opening it and reading metadata if necessary. - call find_varname_in_DD_file(fileobj_read_dd, file_var_meta_DD, fieldname, domain, err_header, & - filename, var_to_read) + ! Search for the variable in the file, looking for the case-sensitive name first. + if (variable_exists(fileobj, trim(fieldname))) then + var_to_read = trim(fieldname) + variable_found = .true. + else ! Look for case-insensitive variable name matches. + var_to_read = "" + variable_found = .false. + + nvars = get_num_variables(fileobj) + if (nvars < 1) call MOM_error(FATAL, "nvars is less than 1 for file "//trim(filename)) + allocate(var_names(nvars)) + call get_variable_names(fileobj, var_names) + + do i=1,nvars + if (lowercase(trim(var_names(i))) == lowercase(trim(fieldname))) then + variable_found = .true. + var_to_read = trim(var_names(i)) + exit + endif + enddo + if (.not.(variable_found)) & + call MOM_error(FATAL, trim(err_header)//trim(fieldname)//" not found in "//trim(filename)) + deallocate(var_names) + endif - ! Registering the variable axes essentially just specifies the discrete position of this variable. - call MOM_register_variable_axes(fileobj_read_dd, var_to_read) + ! FMS2 can not handle a timelevel argument if the variable does not have one in the file, + ! so some error checking and logic are required. + if (present(has_time_dim) .or. present(timelevel)) then + time_dim = -1 - ! 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 - num_var_dims = get_variable_num_dimensions(fileobj_read, trim(var_to_read)) + num_var_dims = get_variable_num_dimensions(fileobj, trim(var_to_read)) allocate(dim_names(num_var_dims)) ; dim_names(:) = "" - call get_variable_dimension_names(fileobj_read, trim(var_to_read), dim_names) - call get_dimension_size(fileobj_read_dd, trim(dim_names(1)), nread(1)) + call get_variable_dimension_names(fileobj, trim(var_to_read), dim_names) + + do i=1,num_var_dims + if (is_dimension_unlimited(fileobj, dim_names(i))) then + time_dim = i + if (present(timelevel)) then + call get_dimension_size(fileobj, dim_names(i), dim_unlim_size) + if ((timelevel > dim_unlim_size) .and. is_root_PE()) call MOM_error(FATAL, & + trim(err_header)//"Attempting to read a time level of "//trim(var_to_read)//& + " that exceeds the size of the time dimension in "//trim(filename)) + endif + exit + endif + enddo deallocate(dim_names) - endif - - time_dim = -1 - if (present(timelevel)) then - time_dim = get_time_dim_num_DD(fileobj_read_dd, var_to_read, err_header, filename, timelevel) - if (time_dim == ndim) then ; nread(ndim) = 1 ; start(ndim) = timelevel ; endif - endif - ! read the data - if (time_dim > 0) then - call read_data(fileobj_read_dd, trim(var_to_read), data, corner=start, edge_lengths=nread, & - unlim_dim_level=timelevel) - else - call read_data(fileobj_read_dd, trim(var_to_read), data, corner=start, edge_lengths=nread) + if (present(timelevel) .and. (time_dim < 0) .and. is_root_PE()) & + call MOM_error(WARNING, trim(err_header)//"time level specified, but the variable "//& + trim(var_to_read)//" does not have an unlimited dimension in "//trim(filename)) + if ((.not.present(timelevel)) .and. (time_dim > 0) .and. is_root_PE()) & + call MOM_error(WARNING, trim(err_header)//"The variable "//trim(var_to_read)//& + " has an unlimited dimension in "//trim(filename)//" but no time level is specified.") + if (present(has_time_dim)) has_time_dim = (time_dim > 0) endif - ! Close the file, if necesssary - close_the_file = .true. ; if (present(leave_file_open)) close_the_file = .not.(leave_file_open) - if (close_the_file) call close_file_read_DD(fileobj_read_dd, file_var_meta_DD) - - ! Rescale the data that was read if necessary. - if (present(scale)) then ; if (scale /= 1.0) then - data(:) = scale*data(:) - endif ; endif - -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, start_index, edge_lengths, & - timelevel, position, 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 - type(MOM_domain_type), intent(in) :: domain !< MOM domain attribute with the mpp_domain decomposition - 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 - integer, optional, intent(in) :: position !< A flag indicating where this data is located - 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 variables - logical :: close_the_file ! indicates whether to close the file after write_data is called; default is .true. - integer :: time_dim ! The dimension position of a variables unlimited time axis, or -1 if it has none. - integer, parameter :: ndim = 2 ! The dimensionality of the array being read - integer, dimension(ndim) :: start, nread ! indices for first data value and number of values to read - character(len=96) :: var_to_read ! variable to read from the netcdf file - character(len=48) :: err_header ! A preamble for error messages - - err_header = "MOM_read_data_fms2:MOM_read_data_2d_DD: " - - ! Find the matching variable name in the file, opening it and reading metadata if necessary. - call find_varname_in_DD_file(fileobj_read_dd, file_var_meta_DD, fieldname, domain, err_header, & - filename, var_to_read) - ! Registering the variable axes essentially just specifies the discrete position of this variable. - call MOM_register_variable_axes(fileobj_read_dd, var_to_read, position) - - ! 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(:) - nread(:) = shape(data) ; if (present(edge_lengths)) nread(:) = edge_lengths(:) - - time_dim = -1 - if (present(timelevel)) then - time_dim = get_time_dim_num_DD(fileobj_read_dd, var_to_read, err_header, filename, timelevel) - if (time_dim == ndim) then ; nread(ndim) = 1 ; start(ndim) = timelevel ; endif - endif + call MOM_register_variable_axes(fileobj, var_to_read, filename, position) - ! read the data - if (time_dim > 0) then - call read_data(fileobj_read_dd, trim(var_to_read), data, corner=start, edge_lengths=nread, & - unlim_dim_level=timelevel) - else - call read_data(fileobj_read_dd, trim(var_to_read), data, corner=start, edge_lengths=nread) - endif - - ! Close the file, if necessary - close_the_file = .true. ; if (present(leave_file_open)) close_the_file = .not.(leave_file_open) - if (close_the_file) call close_file_read_DD(fileobj_read_dd, file_var_meta_DD) - - ! Rescale the data that was read if necessary. - if (present(scale)) then ; if (scale /= 1.0) then - call rescale_comp_data(domain, data, scale) - endif ; endif - -end subroutine MOM_read_data_2d_DD +end subroutine prepare_to_read_var -!> 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, start_index, edge_lengths, & - timelevel, position, 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 - type(MOM_domain_type), intent(in) :: domain !< MOM domain attribute with the mpp_domain decomposition - 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 - integer, optional, intent(in) :: position !< A flag indicating where this data is discretized - 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 +!> 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(fileObj, variableName, filename, position) + type(FmsNetcdfDomainFile_t), intent(inout) :: fileObj !< Handle to an open FMS2 netCDF file object + character(len=*), intent(in) :: variableName !< name of the variable + character(len=*), intent(in) :: filename !< The name of the file to read + integer, optional, intent(in) :: position !< A flag indicating where this data is discretized ! Local variables - logical :: close_the_file ! indicates whether to close the file after write_data is called; default is .true. - integer :: time_dim ! The dimension position of a variables unlimited time axis, or -1 if it has none. - integer, parameter :: ndim = 3 ! The dimensionality of the array being read - integer, dimension(ndim) :: start, nread ! indices for first data value and number of values to read - character(len=96) :: var_to_read ! variable to read from the netcdf file - character(len=48) :: err_header ! A preamble for error messages - - err_header = "MOM_read_data_fms2:MOM_read_data_3d_DD: " - - ! Find the matching variable name in the file, opening it and reading metadata if necessary. - call find_varname_in_DD_file(fileobj_read_dd, file_var_meta_DD, fieldname, domain, err_header, & - filename, var_to_read) - - ! Registering the variable axes essentially just specifies the discrete position of this variable. - call MOM_register_variable_axes(fileobj_read_dd, var_to_read, position) - - ! 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(:) - nread(:) = shape(data) ; if (present(edge_lengths)) nread(:) = edge_lengths(:) - - time_dim = -1 - if (present(timelevel)) then - time_dim = get_time_dim_num_DD(fileobj_read_dd, var_to_read, err_header, filename, timelevel) - if (time_dim == ndim) then ; nread(ndim) = 1 ; start(ndim) = timelevel ; endif - endif - - ! read the data - if (time_dim > 0) then - call read_data(fileobj_read_dd, trim(var_to_read), data, corner=start, edge_lengths=nread, & - unlim_dim_level=timelevel) - else - call read_data(fileobj_read_dd, trim(var_to_read), data, corner=start, edge_lengths=nread) + character(len=40) :: units ! units corresponding to a specific variable dimension + character(len=40), allocatable, dimension(:) :: dim_names ! variable dimension names + integer, allocatable, dimension(:) :: dimSizes ! variable dimension sizes + logical, allocatable, dimension(:) :: is_x ! Is this a (likely domain-decomposed) x-axis + logical, allocatable, dimension(:) :: is_y ! Is this a (likely domain-decomposed) y-axis + logical, allocatable, dimension(:) :: is_t ! Is this a time axis or another unlimited axis + integer :: ndims ! number of dimensions + integer :: i + integer :: xPos, yPos ! domain positions for x and y axes. Default is CENTER + + 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(position)) then + if ((position == CORNER) .or. (position == EAST_FACE)) xPos = EAST_FACE + if ((position == CORNER) .or. (position == NORTH_FACE)) yPos = NORTH_FACE endif - ! Close the file, if necessary - close_the_file = .true. ; if (present(leave_file_open)) close_the_file = .not.(leave_file_open) - if (close_the_file) call close_file_read_DD(fileobj_read_dd, file_var_meta_DD) - - ! Rescale the data that was read if necessary. - if (present(scale)) then ; if (scale /= 1.0) then - call rescale_comp_data(domain, data, scale) - endif ; endif - -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, start_index, edge_lengths, & - timelevel, position, 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 - type(MOM_domain_type), intent(in) :: domain !< MOM domain attribute with the mpp_domain decomposition - 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 - integer, optional, intent(in) :: position !< A flag indicating where this data is located - 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 variables - logical :: close_the_file ! indicates whether to close the file after write_data is called; default is .true. - integer :: time_dim ! The dimension position of a variables unlimited time axis, or -1 if it has none. - integer, parameter :: ndim = 4 ! The dimensionality of the array being read - integer, dimension(ndim) :: start, nread ! indices for first data value and number of values to read - character(len=96) :: var_to_read ! variable to read from the netcdf file - character(len=48) :: err_header ! A preamble for error messages - - err_header = "MOM_read_data_fms2:MOM_read_data_4d_DD: " + ! get variable dimension names and lengths + ndims = get_variable_num_dimensions(fileObj, trim(variableName)) + allocate(dimSizes(ndims)) + allocate(dim_names(ndims)) + allocate(is_x(ndims)) ; is_x(:) = .false. + allocate(is_y(ndims)) ; is_y(:) = .false. + allocate(is_t(ndims)) ; is_t(:) = .false. + call get_variable_size(fileObj, trim(variableName), dimSizes) + call get_variable_dimension_names(fileObj, trim(variableName), dim_names) + call categorize_axes(fileObj, filename, ndims, dim_names, is_x, is_y, is_t) + + ! register the axes + do i=1,ndims + if ( .not.is_dimension_registered(fileobj, trim(dim_names(i))) ) then + if (is_x(i)) then + call register_axis(fileObj, trim(dim_names(i)), "x", domain_position=xPos) + elseif (is_y(i)) then + call register_axis(fileObj, trim(dim_names(i)), "y", domain_position=yPos) + else + call register_axis(fileObj, trim(dim_names(i)), dimSizes(i)) + endif + endif + enddo - ! Find the matching variable name in the file, opening it and reading metadata if necessary. - call find_varname_in_DD_file(fileobj_read_dd, file_var_meta_DD, fieldname, domain, err_header, & - filename, var_to_read) + deallocate(dimSizes) + deallocate(dim_names) + deallocate(is_x, is_y, is_t) +end subroutine MOM_register_variable_axes + +!> Determine whether a variable's axes are associated with x-, y- or time-dimensions. Other +!! unlimited dimensions are also labeled as time axes for these purposes. +subroutine categorize_axes(fileObj, filename, ndims, dim_names, is_x, is_y, is_t) + type(FmsNetcdfDomainFile_t), intent(in) :: fileObj !< Handle to an open FMS2 netCDF file object + character(len=*), intent(in) :: filename !< The name of the file to read + integer, intent(in) :: ndims !< The number of dimensions associated with a variable + character(len=*), dimension(ndims), intent(in) :: dim_names !< Names of the dimensions associated with a variable + logical, dimension(ndims), intent(out) :: is_x !< Indicates if each dimension a (likely decomposed) x-axis + logical, dimension(ndims), intent(out) :: is_y !< Indicates if each dimension a (likely decomposed) y-axis + logical, dimension(ndims), intent(out) :: is_t !< Indicates if each dimension unlimited (usually time) axis - ! Registering the variable axes essentially just specifies the discrete position of this variable. - call MOM_register_variable_axes(fileobj_read_dd, var_to_read, position) + integer :: i + character(len=256) :: cartesian ! A flag indicating a Cartesian direction - usually a single character. + character(len=512) :: dim_list ! A concatenated list of dimension names. + character(len=40) :: units ! units corresponding to a specific variable dimension + logical :: x_found, y_found ! Indicate whether an x- or y- dimension have been found. - ! 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(:) - nread(:) = shape(data) ; if (present(edge_lengths)) nread(:) = edge_lengths(:) + x_found = .false. ; y_found = .false. + is_x(:) = .false. ; is_y(:) = .false. + do i=1,ndims + is_t(i) = is_dimension_unlimited(fileObj, trim(dim_names(i))) + ! First look for indicative variable attributes + if (.not.is_t(i)) then + if (variable_exists(fileobj, trim(dim_names(i)))) then + if (attribute_exists(fileobj, trim(dim_names(i)), "cartesian_axis")) then + call get_variable_attribute(fileobj, trim(dim_names(i)), "cartesian_axis", cartesian) + cartesian = adjustl(cartesian) + if ((index(cartesian, "X") == 1) .or. (index(cartesian, "x") == 1)) is_x(i) = .true. + if ((index(cartesian, "Y") == 1) .or. (index(cartesian, "y") == 1)) is_y(i) = .true. + if ((index(cartesian, "T") == 1) .or. (index(cartesian, "t") == 1)) is_t(i) = .true. + ! if (is_root_pe() .and. is_x(i)) & + ! call MOM_error(NOTE, "X-dimension determined from cartesian_axis for "//trim(dim_names(i))) + ! if (is_root_pe() .and. is_y(i)) & + ! call MOM_error(NOTE, "Y-dimension determined from cartesian_axis for "//trim(dim_names(i))) + endif + endif + endif + if (is_x(i)) x_found = .true. + if (is_y(i)) y_found = .true. + enddo - time_dim = -1 - if (present(timelevel)) then - time_dim = get_time_dim_num_DD(fileobj_read_dd, var_to_read, err_header, filename, timelevel) - if (time_dim == ndim) then ; nread(ndim) = 1 ; start(ndim) = timelevel ; endif + if (.not.(x_found .and. y_found)) then + ! Next look for hints from axis names for uncharacterized axes + do i=1,ndims ; if (.not.(is_x(i) .or. is_y(i) .or. is_t(i))) then + call categorize_axis_from_name(dim_names(i), is_x(i), is_y(i)) + if (is_x(i)) x_found = .true. + if (is_y(i)) y_found = .true. + endif ; enddo endif - ! read the data - if (time_dim > 0) then - call read_data(fileobj_read_dd, trim(var_to_read), data, corner=start, edge_lengths=nread, & - unlim_dim_level=timelevel) - else - call read_data(fileobj_read_dd, trim(var_to_read), data, corner=start, edge_lengths=nread) + if (.not.(x_found .and. y_found)) then + ! Look for hints from CF-compliant axis units for uncharacterized axes + do i=1,ndims ; if (.not.(is_x(i) .or. is_y(i) .or. is_t(i))) then + call get_variable_units(fileobj, trim(dim_names(i)), units) + call categorize_axis_from_units(units, is_x(i), is_y(i)) + if (is_x(i)) x_found = .true. + if (is_y(i)) y_found = .true. + endif ; enddo endif - ! Close the file, if necessary - close_the_file = .true. ; if (present(leave_file_open)) close_the_file = .not.(leave_file_open) - if (close_the_file) call close_file_read_DD(fileobj_read_dd, file_var_meta_DD) - - ! Rescale the data that was read if necessary. - if (present(scale)) then ; if (scale /= 1.0) then - call rescale_comp_data(domain, data, scale) - endif ; endif + if (.not.(x_found .and. y_found) .and. (ndims>2) .or. ((ndims==2) .and. .not.is_t(ndims))) then + ! This is a case where one would expect to find x-and y-dimensions, but none have been found. + if (is_root_pe()) then + dim_list = trim(dim_names(1))//", "//trim(dim_names(2)) + do i=3,ndims ; dim_list = trim(dim_list)//", "//trim(dim_names(i)) ; enddo + call MOM_error(WARNING, "categorize_axes: Failed to identify x- and y- axes in the axis list ("//& + trim(dim_list)//") of a variable being read from "//trim(filename)) + endif + endif -end subroutine MOM_read_data_4d_DD +end subroutine categorize_axes + +!> Determine whether an axis is associated with the x- or y-directions based on a comparison of +!! its units with CF-compliant variants of latitude or longitude units. +subroutine categorize_axis_from_units(unit_string, is_x, is_y) + character(len=*), intent(in) :: unit_string !< string of units + logical, intent(out) :: is_x !< Indicates if the axis units are associated with an x-direction axis + logical, intent(out) :: is_y !< Indicates if the axis units are associated with an y-direction axis + + is_x = .false. ; is_y = .false. + select case (lowercase(trim(unit_string))) + case ("degrees_north"); is_y = .true. + case ("degree_north") ; is_y = .true. + case ("degrees_n") ; is_y = .true. + case ("degree_n") ; is_y = .true. + case ("degreen") ; is_y = .true. + case ("degreesn") ; is_y = .true. + case ("degrees_east") ; is_x = .true. + case ("degree_east") ; is_x = .true. + case ("degreese") ; is_x = .true. + case ("degreee") ; is_x = .true. + case ("degree_e") ; is_x = .true. + case ("degrees_e") ; is_x = .true. + case default ; is_x = .false. ; is_y = .false. + end select + +end subroutine categorize_axis_from_units + +!> Tries to determine whether the axis name is commonly associated with an x- or y- axis. This +!! approach is fragile and unreliable, but it a backup to reading a CARTESIAN file attribute. +subroutine categorize_axis_from_name(dimname, is_x, is_y) + character(len=*), intent(in) :: dimname !< A dimension name + logical, intent(out) :: is_x !< Indicates if the axis name is associated with an x-direction axis + logical, intent(out) :: is_y !< Indicates if the axis name is associated with an y-direction axis + + is_x = .false. ; is_y = .false. + select case(trim(lowercase(dimname))) + case ("grid_x_t") ; is_x = .true. + case ("nx") ; is_x = .true. + case ("nxp") ; is_x = .true. + case ("longitude") ; is_x = .true. + case ("long") ; is_x = .true. + case ("lon") ; is_x = .true. + case ("lonh") ; is_x = .true. + case ("lonq") ; is_x = .true. + case ("xh") ; is_x = .true. + case ("xq") ; is_x = .true. + case ("i") ; is_x = .true. + + case ("grid_y_t") ; is_y = .true. + case ("ny") ; is_y = .true. + case ("nyp") ; is_y = .true. + case ("latitude") ; is_y = .true. + case ("lat") ; is_y = .true. + case ("lath") ; is_y = .true. + case ("latq") ; is_y = .true. + case ("yh") ; is_y = .true. + case ("yq") ; is_y = .true. + case ("j") ; is_y = .true. + + case default ; is_x = .false. ; is_y = .false. + end select + +end subroutine categorize_axis_from_name + +!===== Everything below this pertains to reading non-decomposed variables ===! +!===== using FMS2 interfaces will probably be discarded eventually. =========! !!> This routine calls the fms_io read_data subroutine to read a scalar (0-D) field named "fieldname" !! from file "filename". @@ -324,25 +322,26 @@ subroutine MOM_read_data_scalar(filename, fieldname, data, timelevel, scale, lea logical, optional, intent(in) :: leave_file_open !< if .true., leave file open ! Local variables - logical :: close_the_file ! indicates whether to close the file after write_data is called; default is .true. + type(FmsNetcdfFile_t) :: fileobj ! A handle to a simple netCDF file + logical :: close_the_file ! indicates whether to close the file after read_data is called. character(len=96) :: var_to_read ! variable to read from the netcdf file character(len=48) :: err_header ! A preamble for error messages err_header = "MOM_read_data_fms2:MOM_read_data_scalar: " ! Find the matching variable name in the file, opening it and reading metadata if necessary. - call find_varname_in_noDD_file(fileobj_read, file_var_meta_noDD, fieldname, err_header, filename, var_to_read) + call find_varname_in_file(fileobj, fieldname, err_header, filename, var_to_read) ! read the data if (present(timelevel)) then - call read_data(fileobj_read, trim(var_to_read), data, unlim_dim_level=timelevel) + call read_data(fileobj, trim(var_to_read), data, unlim_dim_level=timelevel) else - call read_data(fileobj_read, trim(var_to_read), data) + call read_data(fileobj, trim(var_to_read), data) endif ! Close the file, if necessary close_the_file = .true. ; if (present(leave_file_open)) close_the_file = .not.(leave_file_open) - if (close_the_file) call close_file_read_noDD(fileobj_read, file_var_meta_noDD) + if (close_the_file .and. check_if_open(fileobj)) call fms2_close_file(fileobj) ! Rescale the data that was read if necessary. if (present(scale)) then ; if (scale /= 1.0) then @@ -366,7 +365,8 @@ subroutine MOM_read_data_1d_noDD(filename, fieldname, data, start_index, & logical, optional, intent(in) :: leave_file_open !< if .true., leave file open ! Local variables - logical :: close_the_file ! indicates whether to close the file after write_data is called; default is .true. + type(FmsNetcdfFile_t) :: fileobj ! A handle to a simple netCDF file + logical :: close_the_file ! indicates whether to close the file after read_data is called. integer :: time_dim ! The dimension position of a variables unlimited time axis, or -1 if it has none. integer, parameter :: ndim = 1 ! The dimensionality of the array being read integer, dimension(ndim) :: start, nread ! indices for first data value and number of values to read @@ -375,8 +375,8 @@ subroutine MOM_read_data_1d_noDD(filename, fieldname, data, start_index, & err_header = "MOM_read_data_fms2:MOM_read_data_1d_noDD: " - ! Find the matching variable name in the file, opening it and reading metadata if necessary. - call find_varname_in_noDD_file(fileobj_read, file_var_meta_noDD, fieldname, err_header, filename, var_to_read) + ! Find the matching case-insensitive variable name in the file, opening the file if necessary. + call find_varname_in_file(fileobj, fieldname, err_header, filename, var_to_read) ! 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(:) @@ -384,21 +384,21 @@ subroutine MOM_read_data_1d_noDD(filename, fieldname, data, start_index, & time_dim = -1 if (present(timelevel)) then - time_dim = get_time_dim_num_noDD(fileobj_read, var_to_read, err_header, filename, timelevel) + time_dim = get_time_dim(fileobj, var_to_read, err_header, filename, timelevel) if (time_dim == ndim) then ; nread(ndim) = 1 ; start(ndim) = timelevel ; endif endif ! read the data if (time_dim > 0) then - call read_data(fileobj_read, trim(var_to_read), data, corner=start, edge_lengths=nread, & + call read_data(fileobj, trim(var_to_read), data, corner=start, edge_lengths=nread, & unlim_dim_level=timelevel) else - call read_data(fileobj_read, trim(var_to_read), data, corner=start, edge_lengths=nread) + call read_data(fileobj, trim(var_to_read), data, corner=start, edge_lengths=nread) endif ! Close the file, if necessary close_the_file = .true. ; if (present(leave_file_open)) close_the_file = .not.(leave_file_open) - if (close_the_file) call close_file_read_noDD(fileobj_read, file_var_meta_noDD) + if (close_the_file .and. check_if_open(fileobj)) call fms2_close_file(fileobj) ! Rescale the data that was read if necessary. if (present(scale)) then ; if (scale /= 1.0) then @@ -423,7 +423,8 @@ subroutine MOM_read_data_2d_noDD(filename, fieldname, data, start_index, & logical, optional, intent(in) :: leave_file_open !< if .true., leave file open ! Local variables - logical :: close_the_file ! indicates whether to close the file after write_data is called; default is .true. + type(FmsNetcdfFile_t) :: fileobj ! A handle to a simple netCDF file + logical :: close_the_file ! indicates whether to close the file after read_data is called. integer :: time_dim ! The dimension position of a variables unlimited time axis, or -1 if it has none. integer, parameter :: ndim = 2 ! The dimensionality of the array being read integer, dimension(ndim) :: start, nread ! indices for first data value and number of values to read @@ -432,11 +433,8 @@ subroutine MOM_read_data_2d_noDD(filename, fieldname, data, start_index, & err_header = "MOM_read_data_fms2:MOM_read_data_2d_DD: " - ! Find the matching variable name in the file, opening it and reading metadata if necessary. - call find_varname_in_noDD_file(fileobj_read, file_var_meta_noDD, fieldname, err_header, filename, var_to_read) - -! ! Registering the variable axes essentially just specifies the discrete position of this variable. -! call MOM_register_variable_axes(fileobj_read, var_to_read, position) + ! Find the matching case-insensitive variable name in the file, opening the file if necessary. + call find_varname_in_file(fileobj, fieldname, err_header, filename, var_to_read) ! 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(:) @@ -444,21 +442,21 @@ subroutine MOM_read_data_2d_noDD(filename, fieldname, data, start_index, & time_dim = -1 if (present(timelevel)) then - time_dim = get_time_dim_num_noDD(fileobj_read, var_to_read, err_header, filename, timelevel) + time_dim = get_time_dim(fileobj, var_to_read, err_header, filename, timelevel) if (time_dim == ndim) then ; nread(ndim) = 1 ; start(ndim) = timelevel ; endif endif ! read the data if (time_dim > 0) then - call read_data(fileobj_read, trim(var_to_read), data, corner=start, edge_lengths=nread, & + call read_data(fileobj, trim(var_to_read), data, corner=start, edge_lengths=nread, & unlim_dim_level=timelevel) else - call read_data(fileobj_read, trim(var_to_read), data, corner=start, edge_lengths=nread) + call read_data(fileobj, trim(var_to_read), data, corner=start, edge_lengths=nread) endif ! Close the file, if necessary close_the_file = .true. ; if (present(leave_file_open)) close_the_file = .not.(leave_file_open) - if (close_the_file) call close_file_read_noDD(fileobj_read, file_var_meta_noDD) + if (close_the_file .and. check_if_open(fileobj)) call fms2_close_file(fileobj) ! Rescale the data that was read if necessary. if (present(scale)) then ; if (scale /= 1.0) then @@ -467,265 +465,12 @@ subroutine MOM_read_data_2d_noDD(filename, fieldname, data, start_index, & end subroutine MOM_read_data_2d_noDD -!> 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, & - 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 - 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 - 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) - - ! Rescale the data that was read if necessary. - if (present(scale)) then ; if (scale /= 1.0) then - call rescale_comp_data(MOM_Domain, u_data, scale) - call rescale_comp_data(MOM_Domain, v_data, scale) - endif ; endif - -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, & - 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 - 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 - 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) - - ! Rescale the data that was read if necessary. - if (present(scale)) then ; if (scale /= 1.0) then - call rescale_comp_data(MOM_Domain, u_data, scale) - call rescale_comp_data(MOM_Domain, v_data, scale) - endif ; endif - -end subroutine MOM_read_vector_3d_fms2 - -!> Find the case-sensitive name of the variable in a domain-decomposed file-set with a case-insensitive name match. -subroutine find_varname_in_DD_file(fileobj_read, file_meta, fieldname, domain, err_header, filename, var_to_read) - type(FmsNetcdfDomainFile_t), intent(inout) :: fileobj_read !< A handle to a file object, that +!> Find the case-sensitive name of the variable in a netCDF file with a case-insensitive name match. +subroutine find_varname_in_file(fileobj, fieldname, err_header, filename, var_to_read) + type(FmsNetcdfFile_t), intent(inout) :: fileobj !< A handle to a file object, that !! will be opened if necessary - type(var_meta_read_file), intent(inout) :: file_meta !< A type with metadata about variables in a file. character(len=*), intent(in) :: fieldname !< The variable name to seek in the file - type(MOM_domain_type), intent(in) :: domain !< MOM domain attribute with the mpp_domain decomposition character(len=*), intent(in) :: err_header !< A descriptive prefix for error messages character(len=*), intent(in) :: filename !< The name of the file to read character(len=*), intent(out) :: var_to_read !< The variable name to read from the file @@ -733,136 +478,47 @@ subroutine find_varname_in_DD_file(fileobj_read, file_meta, fieldname, domain, e ! Local variables logical :: file_open_success !.true. if call to open_file is successful logical :: variable_found ! Is a case-insensitive version of the variable found in the netCDF file? + character(len=96), allocatable, dimension(:) :: var_names !< array for names of variables in a netCDF + !! file opened to read + integer :: nvars ! The number of variables in the file. integer :: i - ! Open the file if necessary - if (.not.(check_if_open(fileobj_read))) then - file_open_success = fms2_open_file(fileobj_read, filename, "read", domain%mpp_domain, is_restart=.false.) - file_meta%nvars = get_num_variables(fileobj_read) - if (file_meta%nvars < 1) call MOM_error(FATAL, "nvars is less than 1 for file "//trim(filename)) - if (.not.(allocated(file_meta%var_names))) allocate(file_meta%var_names(file_meta%nvars)) - call get_variable_names(fileobj_read, file_meta%var_names) - endif - - ! search for the variable in the file var_to_read = "" - variable_found = .false. - do i=1,file_meta%nvars - if (lowercase(trim(file_meta%var_names(i))) == lowercase(trim(fieldname))) then - variable_found = .true. - var_to_read = trim(file_meta%var_names(i)) - exit - endif - enddo - if (.not.(variable_found)) & - call MOM_error(FATAL, trim(err_header)//trim(fieldname)//" not found in "//trim(filename)) - -end subroutine find_varname_in_DD_file - -!> Find the case-sensitive name of the variable in a domain-decomposed file-set with a case-insensitive name match. -subroutine find_varname_in_noDD_file(fileobj_read, file_meta, fieldname, err_header, filename, var_to_read) - type(FmsNetcdfFile_t), intent(inout) :: fileobj_read !< A handle to a file object, that - !! will be opened if necessary - type(var_meta_read_file), intent(inout) :: file_meta !< A type with metadata about variables in a file. - character(len=*), intent(in) :: fieldname !< The variable name to seek in the file - character(len=*), intent(in) :: err_header !< A descriptive prefix for error messages - character(len=*), intent(in) :: filename !< The name of the file to read - character(len=*), intent(out) :: var_to_read !< The variable name to read from the file - - ! Local variables - logical :: file_open_success !.true. if call to open_file is successful - logical :: variable_found ! Is a case-insensitive version of the variable found in the netCDF file? - integer :: i ! Open the file if necessary - if (.not.(check_if_open(fileobj_read))) then - file_open_success = fms2_open_file(fileobj_read, filename, "read", is_restart=.false.) - file_meta%nvars = get_num_variables(fileobj_read) - if (file_meta%nvars < 1) call MOM_error(FATAL, "nvars is less than 1 for file "//trim(filename)) - if (.not.(allocated(file_meta%var_names))) allocate(file_meta%var_names(file_meta%nvars)) - call get_variable_names(fileobj_read, file_meta%var_names) + if (.not.(check_if_open(fileobj))) then + file_open_success = fms2_open_file(fileobj, filename, "read", is_restart=.false.) + if (.not.file_open_success) call MOM_error(FATAL, trim(err_header)//" failed to open "//trim(filename)) endif - ! search for the variable in the file - var_to_read = "" - variable_found = .false. - do i=1,file_meta%nvars - if (lowercase(trim(file_meta%var_names(i))) == lowercase(trim(fieldname))) then - variable_found = .true. - var_to_read = trim(file_meta%var_names(i)) - exit - endif - enddo - if (.not.(variable_found)) & - call MOM_error(FATAL, trim(err_header)//trim(fieldname)//" not found in "//trim(filename)) - -end subroutine find_varname_in_noDD_file - - -!> Close a file that had been open for domain-decomposed reading based on its handle. -subroutine close_file_read_DD(fileobj_read, file_meta) - type(FmsNetcdfDomainFile_t), intent(inout) :: fileobj_read !< A handle to a file object that will be closed - type(var_meta_read_file), intent(inout) :: file_meta !< A type with metadata about variables - !! in a file opened to read. - - if (check_if_open(fileobj_read)) call fms2_close_file(fileobj_read) - if (allocated(file_meta%var_names)) deallocate(file_meta%var_names) - file_meta%nvars = 0 -end subroutine close_file_read_DD - -!> Close a file that had been open for non-domain-decomposed reading based on its handle. -subroutine close_file_read_noDD(fileobj_read, file_meta) - type(FmsNetcdfFile_t), intent(inout) :: fileobj_read !< A handle to a file object that will be closed - type(var_meta_read_file), intent(inout) :: file_meta !< A type with metadata about variables - !! in a file opened to read. - - if (check_if_open(fileobj_read)) call fms2_close_file(fileobj_read) - if (allocated(file_meta%var_names)) deallocate(file_meta%var_names) - file_meta%nvars = 0 -end subroutine close_file_read_noDD - - -!> Return the number of the time dimesion for a variable in an open domain-decomposed file set, -!! or -1 if it has no time (or other unlimited) dimension. -integer function get_time_dim_num_DD(fileobj_read, var_to_read, err_header, filename, timelevel) - type(FmsNetcdfDomainFile_t), intent(in) :: fileobj_read !< A handle to an open file object - character(len=*), intent(in) :: var_to_read !< The variable name to read from the file - character(len=*), intent(in) :: err_header !< A descriptive prefix for error messages - character(len=*), intent(in) :: filename !< The name of the file to read - integer, optional, intent(in) :: timelevel !< A time level to read - - ! Local variables - integer :: i, dim_unlim_size, num_var_dims - character(len=96), allocatable :: dim_names(:) ! variable dimension names - - num_var_dims = get_variable_num_dimensions(fileobj_read, trim(var_to_read)) - allocate(dim_names(num_var_dims)) ; dim_names(:) = "" - call get_variable_dimension_names(fileobj_read, trim(var_to_read), dim_names) - - get_time_dim_num_DD = -1 - do i=1,num_var_dims - if (is_dimension_unlimited(fileobj_read, dim_names(i))) then - get_time_dim_num_DD = i - if (present(timelevel)) then - call get_dimension_size(fileobj_read, dim_names(i), dim_unlim_size) - if (timelevel > dim_unlim_size) call MOM_error(FATAL, trim(err_header)//& - "Attempting to read a time level of "//trim(var_to_read)//& - " that exceeds the size of "//trim(filename)) + if (variable_exists(fileobj, fieldname)) then + var_to_read = fieldname + else + variable_found = .false. + nvars = get_num_variables(fileobj) + if (nvars < 1) call MOM_error(FATAL, "nvars is less than 1 for file "//trim(filename)) + allocate(var_names(nvars)) + call get_variable_names(fileobj, var_names) + + ! search for the variable in the file + do i=1,nvars + if (lowercase(trim(var_names(i))) == lowercase(trim(fieldname))) then + variable_found = .true. + var_to_read = trim(var_names(i)) + exit endif - exit - endif - enddo - if (get_time_dim_num_DD < 0) & - call MOM_error(WARNING, trim(err_header)//"time level specified, but the variable "//& - trim(var_to_read)//" does not have an unlimited dimension in "//trim(filename)) - deallocate(dim_names) + enddo + if (.not.(variable_found)) & + call MOM_error(FATAL, trim(err_header)//trim(fieldname)//" not found in "//trim(filename)) + deallocate(var_names) + endif -end function get_time_dim_num_DD +end subroutine find_varname_in_file -!> Return the number of the time dimesion for a variable in an open non-domain-decomposed file, +!> Return the number of the time dimension for a variable in an open non-domain-decomposed file, !! or -1 if it has no time (or other unlimited) dimension. -integer function get_time_dim_num_noDD(fileobj_read, var_to_read, err_header, filename, timelevel) - type(FmsNetcdfFile_t), intent(in) :: fileobj_read !< A handle to an open file object +integer function get_time_dim(fileobj, var_to_read, err_header, filename, timelevel) + type(FmsNetcdfFile_t), intent(in) :: fileobj !< A handle to an open file object character(len=*), intent(in) :: var_to_read !< The variable name to read from the file character(len=*), intent(in) :: err_header !< A descriptive prefix for error messages character(len=*), intent(in) :: filename !< The name of the file to read @@ -872,16 +528,16 @@ integer function get_time_dim_num_noDD(fileobj_read, var_to_read, err_header, fi integer :: i, dim_unlim_size, num_var_dims character(len=96), allocatable :: dim_names(:) ! variable dimension names - num_var_dims = get_variable_num_dimensions(fileobj_read, trim(var_to_read)) + num_var_dims = get_variable_num_dimensions(fileobj, trim(var_to_read)) allocate(dim_names(num_var_dims)) ; dim_names(:) = "" - call get_variable_dimension_names(fileobj_read, trim(var_to_read), dim_names) + call get_variable_dimension_names(fileobj, trim(var_to_read), dim_names) - get_time_dim_num_noDD = -1 + get_time_dim = -1 do i=1,num_var_dims - if (is_dimension_unlimited(fileobj_read, dim_names(i))) then - get_time_dim_num_noDD = i + if (is_dimension_unlimited(fileobj, dim_names(i))) then + get_time_dim = i if (present(timelevel)) then - call get_dimension_size(fileobj_read, dim_names(i), dim_unlim_size) + call get_dimension_size(fileobj, dim_names(i), dim_unlim_size) if (timelevel > dim_unlim_size) call MOM_error(FATAL, trim(err_header)//& "Attempting to read a time level of "//trim(var_to_read)//& " that exceeds the size of "//trim(filename)) @@ -889,36 +545,11 @@ integer function get_time_dim_num_noDD(fileobj_read, var_to_read, err_header, fi exit endif enddo - if (get_time_dim_num_noDD < 0) & + if (get_time_dim < 0) & call MOM_error(WARNING, trim(err_header)//"time level specified, but the variable "//& trim(var_to_read)//" does not have an unlimited dimension in "//trim(filename)) deallocate(dim_names) -end function get_time_dim_num_noDD - -!> 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 function get_time_dim end module MOM_read_data_fms2 From 09173f7dc2a48a4cfdb9552f2f2ff0a714834b1c Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sat, 13 Mar 2021 04:23:31 -0500 Subject: [PATCH 017/112] Only write checksums from root PE for FMS_cap Modified the routines that write out the checksums of various types related to the surface ocean state so that only the root PE writes the checksums. The modified routines are ocn_ice_bnd_type_chksum and ocean_public_type_chksum in config_src/infra/FMS_cap. The analogous routines with the nuopc_cap and mct_cap have not been modified; although doing so would be a very good idea, it should be done by someone who is actively testing them. In some large-PE tests cases this reduces the volume of output to stdout by over 90% without any loss of information. All solutions are bitwise identical, but there may be minor white-space reformatting of the output in some cases. --- .../FMS_cap/MOM_surface_forcing_gfdl.F90 | 56 +++++++++++-------- .../drivers/FMS_cap/ocean_model_MOM.F90 | 27 +++++---- 2 files changed, 48 insertions(+), 35 deletions(-) diff --git a/config_src/drivers/FMS_cap/MOM_surface_forcing_gfdl.F90 b/config_src/drivers/FMS_cap/MOM_surface_forcing_gfdl.F90 index bb89c4e85e..871368fc73 100644 --- a/config_src/drivers/FMS_cap/MOM_surface_forcing_gfdl.F90 +++ b/config_src/drivers/FMS_cap/MOM_surface_forcing_gfdl.F90 @@ -36,6 +36,7 @@ module MOM_surface_forcing_gfdl use MOM_variables, only : surface use user_revise_forcing, only : user_alter_forcing, user_revise_forcing_init use user_revise_forcing, only : user_revise_forcing_CS +use iso_fortran_env, only : int64 implicit none ; private @@ -1622,32 +1623,39 @@ subroutine ice_ocn_bnd_type_chksum(id, timestep, iobt) type(ice_ocean_boundary_type), & intent(in) :: iobt !< An ice-ocean boundary type with fluxes to drive the !! ocean in a coupled model whose checksums are reported - integer :: n,m, outunit + ! Local variables + integer(kind=int64) :: chks ! A checksum for the field + logical :: root ! True only on the root PE + integer :: outunit ! The output unit to write to outunit = stdout - - write(outunit,*) "BEGIN CHECKSUM(ice_ocean_boundary_type):: ", id, timestep - write(outunit,100) 'iobt%u_flux ', field_chksum( iobt%u_flux ) - write(outunit,100) 'iobt%v_flux ', field_chksum( iobt%v_flux ) - write(outunit,100) 'iobt%t_flux ', field_chksum( iobt%t_flux ) - write(outunit,100) 'iobt%q_flux ', field_chksum( iobt%q_flux ) - write(outunit,100) 'iobt%salt_flux ', field_chksum( iobt%salt_flux ) - write(outunit,100) 'iobt%lw_flux ', field_chksum( iobt%lw_flux ) - write(outunit,100) 'iobt%sw_flux_vis_dir', field_chksum( iobt%sw_flux_vis_dir) - write(outunit,100) 'iobt%sw_flux_vis_dif', field_chksum( iobt%sw_flux_vis_dif) - write(outunit,100) 'iobt%sw_flux_nir_dir', field_chksum( iobt%sw_flux_nir_dir) - write(outunit,100) 'iobt%sw_flux_nir_dif', field_chksum( iobt%sw_flux_nir_dif) - write(outunit,100) 'iobt%lprec ', field_chksum( iobt%lprec ) - write(outunit,100) 'iobt%fprec ', field_chksum( iobt%fprec ) - write(outunit,100) 'iobt%runoff ', field_chksum( iobt%runoff ) - write(outunit,100) 'iobt%calving ', field_chksum( iobt%calving ) - write(outunit,100) 'iobt%p ', field_chksum( iobt%p ) - if (associated(iobt%ustar_berg)) & - write(outunit,100) 'iobt%ustar_berg ', field_chksum( iobt%ustar_berg ) - if (associated(iobt%area_berg)) & - write(outunit,100) 'iobt%area_berg ', field_chksum( iobt%area_berg ) - if (associated(iobt%mass_berg)) & - write(outunit,100) 'iobt%mass_berg ', field_chksum( iobt%mass_berg ) + root = is_root_pe() + + if (root) write(outunit,*) "BEGIN CHECKSUM(ice_ocean_boundary_type):: ", id, timestep + chks = field_chksum( iobt%u_flux ) ; if (root) write(outunit,100) 'iobt%u_flux ', chks + chks = field_chksum( iobt%v_flux ) ; if (root) write(outunit,100) 'iobt%v_flux ', chks + chks = field_chksum( iobt%t_flux ) ; if (root) write(outunit,100) 'iobt%t_flux ', chks + chks = field_chksum( iobt%q_flux ) ; if (root) write(outunit,100) 'iobt%q_flux ', chks + chks = field_chksum( iobt%salt_flux ) ; if (root) write(outunit,100) 'iobt%salt_flux ', chks + chks = field_chksum( iobt%lw_flux ) ; if (root) write(outunit,100) 'iobt%lw_flux ', chks + chks = field_chksum( iobt%sw_flux_vis_dir) ; if (root) write(outunit,100) 'iobt%sw_flux_vis_dir', chks + chks = field_chksum( iobt%sw_flux_vis_dif) ; if (root) write(outunit,100) 'iobt%sw_flux_vis_dif', chks + chks = field_chksum( iobt%sw_flux_nir_dir) ; if (root) write(outunit,100) 'iobt%sw_flux_nir_dir', chks + chks = field_chksum( iobt%sw_flux_nir_dif) ; if (root) write(outunit,100) 'iobt%sw_flux_nir_dif', chks + chks = field_chksum( iobt%lprec ) ; if (root) write(outunit,100) 'iobt%lprec ', chks + chks = field_chksum( iobt%fprec ) ; if (root) write(outunit,100) 'iobt%fprec ', chks + chks = field_chksum( iobt%runoff ) ; if (root) write(outunit,100) 'iobt%runoff ', chks + chks = field_chksum( iobt%calving ) ; if (root) write(outunit,100) 'iobt%calving ', chks + chks = field_chksum( iobt%p ) ; if (root) write(outunit,100) 'iobt%p ', chks + if (associated(iobt%ustar_berg)) then + chks = field_chksum( iobt%ustar_berg ) ; if (root) write(outunit,100) 'iobt%ustar_berg ', chks + endif + if (associated(iobt%area_berg)) then + chks = field_chksum( iobt%area_berg ) ; if (root) write(outunit,100) 'iobt%area_berg ', chks + endif + if (associated(iobt%mass_berg)) then + chks = field_chksum( iobt%mass_berg ) ; if (root) write(outunit,100) 'iobt%mass_berg ', chks + endif 100 FORMAT(" CHECKSUM::",A20," = ",Z20) call coupler_type_write_chksums(iobt%fluxes, outunit, 'iobt%') diff --git a/config_src/drivers/FMS_cap/ocean_model_MOM.F90 b/config_src/drivers/FMS_cap/ocean_model_MOM.F90 index f635e886a5..21b09134fd 100644 --- a/config_src/drivers/FMS_cap/ocean_model_MOM.F90 +++ b/config_src/drivers/FMS_cap/ocean_model_MOM.F90 @@ -56,6 +56,7 @@ module ocean_model_mod use MOM_ice_shelf, only : add_shelf_forces, ice_shelf_end, ice_shelf_save_restart use MOM_wave_interface, only: wave_parameters_CS, MOM_wave_interface_init use MOM_wave_interface, only: MOM_wave_interface_init_lite, Update_Surface_Waves +use iso_fortran_env, only : int64 #include @@ -1094,25 +1095,29 @@ subroutine ocean_model_data1D_get(OS, Ocean, name, value) end subroutine ocean_model_data1D_get -!> Write out FMS-format checsums on fields from the ocean surface state +!> Write out checksums for fields from the ocean surface state subroutine ocean_public_type_chksum(id, timestep, ocn) character(len=*), intent(in) :: id !< An identifying string for this call integer, intent(in) :: timestep !< The number of elapsed timesteps type(ocean_public_type), intent(in) :: ocn !< A structure containing various publicly !! visible ocean surface fields. - integer :: n, m, outunit + ! Local variables + integer(kind=int64) :: chks ! A checksum for the field + logical :: root ! True only on the root PE + integer :: outunit ! The output unit to write to outunit = stdout - - write(outunit,*) "BEGIN CHECKSUM(ocean_type):: ", id, timestep - write(outunit,100) 'ocean%t_surf ', field_chksum(ocn%t_surf ) - write(outunit,100) 'ocean%s_surf ', field_chksum(ocn%s_surf ) - write(outunit,100) 'ocean%u_surf ', field_chksum(ocn%u_surf ) - write(outunit,100) 'ocean%v_surf ', field_chksum(ocn%v_surf ) - write(outunit,100) 'ocean%sea_lev ', field_chksum(ocn%sea_lev) - write(outunit,100) 'ocean%frazil ', field_chksum(ocn%frazil ) - write(outunit,100) 'ocean%melt_potential ', field_chksum(ocn%melt_potential) + root = is_root_pe() + + if (root) write(outunit,*) "BEGIN CHECKSUM(ocean_type):: ", id, timestep + chks = field_chksum(ocn%t_surf ) ; if (root) write(outunit,100) 'ocean%t_surf ', chks + chks = field_chksum(ocn%s_surf ) ; if (root) write(outunit,100) 'ocean%s_surf ', chks + chks = field_chksum(ocn%u_surf ) ; if (root) write(outunit,100) 'ocean%u_surf ', chks + chks = field_chksum(ocn%v_surf ) ; if (root) write(outunit,100) 'ocean%v_surf ', chks + chks = field_chksum(ocn%sea_lev) ; if (root) write(outunit,100) 'ocean%sea_lev ', chks + chks = field_chksum(ocn%frazil ) ; if (root) write(outunit,100) 'ocean%frazil ', chks + chks = field_chksum(ocn%melt_potential) ; if (root) write(outunit,100) 'ocean%melt_potential ', chks call coupler_type_write_chksums(ocn%fields, outunit, 'ocean%') 100 FORMAT(" CHECKSUM::",A20," = ",Z20) From ee0152f2699a1f38b9ca95005c3b9287535e6c57 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 18 Mar 2021 17:16:41 -0400 Subject: [PATCH 018/112] +Separate MOM_interp_infra axistype from MOM_io Use axistype for MOM_interp_infra directly from mpp_io_mod and add a copy of get_axis_data to both copies of infra/FMS[12]/MOM_interp_infra.F90, and then use these in framework/MOM_horizontal_regridding.F90, to permit the MOM6 I/O calls to use the FMS2 interfaces without simultaneously requiring changes to the horizontal interpolation code. All answers are bitwise identical, but there are changes to the interfaces offered by a public module. --- config_src/infra/FMS1/MOM_interp_infra.F90 | 13 +++++++++++-- config_src/infra/FMS2/MOM_interp_infra.F90 | 13 +++++++++++-- src/framework/MOM_horizontal_regridding.F90 | 4 ++-- src/framework/MOM_interpolate.F90 | 1 - 4 files changed, 24 insertions(+), 7 deletions(-) diff --git a/config_src/infra/FMS1/MOM_interp_infra.F90 b/config_src/infra/FMS1/MOM_interp_infra.F90 index ca5b2b8516..170573f7ec 100644 --- a/config_src/infra/FMS1/MOM_interp_infra.F90 +++ b/config_src/infra/FMS1/MOM_interp_infra.F90 @@ -4,9 +4,9 @@ module MOM_interp_infra ! This file is part of MOM6. See LICENSE.md for the license. use MOM_domain_infra, only : MOM_domain_type, domain2d -use MOM_io_infra, only : axistype use MOM_time_manager, only : time_type use horiz_interp_mod, only : horiz_interp_new, horiz_interp, horiz_interp_init, horiz_interp_type +use mpp_io_mod, only : axistype, mpp_get_axis_data use time_interp_external_mod, only : time_interp_external use time_interp_external_mod, only : init_external_field, time_interp_external_init use time_interp_external_mod, only : get_external_field_size @@ -16,7 +16,7 @@ module MOM_interp_infra public :: horiz_interp_type, horiz_interp_init public :: time_interp_extern, init_extern_field, time_interp_external_init -public :: get_external_field_info +public :: get_external_field_info, axistype, get_axis_data public :: run_horiz_interp, build_horiz_interp_weights !> Read a field based on model time, and rotate to the model domain. @@ -114,6 +114,15 @@ subroutine build_horiz_interp_weights_2d_to_2d(Interp, lon_in, lat_in, lon_out, end subroutine build_horiz_interp_weights_2d_to_2d +!> Extracts and returns the axis data stored in an axistype. +subroutine get_axis_data( axis, dat ) + type(axistype), intent(in) :: axis !< An axis type + real, dimension(:), intent(out) :: dat !< The data in the axis variable + + call mpp_get_axis_data( axis, dat ) +end subroutine get_axis_data + + !> get size of an external field from field index function get_extern_field_size(index) diff --git a/config_src/infra/FMS2/MOM_interp_infra.F90 b/config_src/infra/FMS2/MOM_interp_infra.F90 index ca5b2b8516..170573f7ec 100644 --- a/config_src/infra/FMS2/MOM_interp_infra.F90 +++ b/config_src/infra/FMS2/MOM_interp_infra.F90 @@ -4,9 +4,9 @@ module MOM_interp_infra ! This file is part of MOM6. See LICENSE.md for the license. use MOM_domain_infra, only : MOM_domain_type, domain2d -use MOM_io_infra, only : axistype use MOM_time_manager, only : time_type use horiz_interp_mod, only : horiz_interp_new, horiz_interp, horiz_interp_init, horiz_interp_type +use mpp_io_mod, only : axistype, mpp_get_axis_data use time_interp_external_mod, only : time_interp_external use time_interp_external_mod, only : init_external_field, time_interp_external_init use time_interp_external_mod, only : get_external_field_size @@ -16,7 +16,7 @@ module MOM_interp_infra public :: horiz_interp_type, horiz_interp_init public :: time_interp_extern, init_extern_field, time_interp_external_init -public :: get_external_field_info +public :: get_external_field_info, axistype, get_axis_data public :: run_horiz_interp, build_horiz_interp_weights !> Read a field based on model time, and rotate to the model domain. @@ -114,6 +114,15 @@ subroutine build_horiz_interp_weights_2d_to_2d(Interp, lon_in, lat_in, lon_out, end subroutine build_horiz_interp_weights_2d_to_2d +!> Extracts and returns the axis data stored in an axistype. +subroutine get_axis_data( axis, dat ) + type(axistype), intent(in) :: axis !< An axis type + real, dimension(:), intent(out) :: dat !< The data in the axis variable + + call mpp_get_axis_data( axis, dat ) +end subroutine get_axis_data + + !> get size of an external field from field index function get_extern_field_size(index) diff --git a/src/framework/MOM_horizontal_regridding.F90 b/src/framework/MOM_horizontal_regridding.F90 index 8d02dfdf3f..73fb1f0a41 100644 --- a/src/framework/MOM_horizontal_regridding.F90 +++ b/src/framework/MOM_horizontal_regridding.F90 @@ -11,9 +11,9 @@ module MOM_horizontal_regridding use MOM_error_handler, only : callTree_enter, callTree_leave, callTree_waypoint use MOM_file_parser, only : get_param, log_param, log_version, param_file_type use MOM_grid, only : ocean_grid_type -use MOM_interpolate, only : time_interp_external, get_external_field_info, horiz_interp_init +use MOM_interpolate, only : time_interp_external, horiz_interp_init use MOM_interpolate, only : build_horiz_interp_weights, run_horiz_interp, horiz_interp_type -use MOM_io_infra, only : axistype, get_axis_data +use MOM_interp_infra, only : axistype, get_external_field_info, get_axis_data use MOM_time_manager, only : time_type use netcdf, only : NF90_OPEN, NF90_NOWRITE, NF90_GET_ATT, NF90_GET_VAR diff --git a/src/framework/MOM_interpolate.F90 b/src/framework/MOM_interpolate.F90 index f282d03ff6..4a931d0bf3 100644 --- a/src/framework/MOM_interpolate.F90 +++ b/src/framework/MOM_interpolate.F90 @@ -9,7 +9,6 @@ module MOM_interpolate use MOM_interp_infra, only : time_interp_external_init, get_external_field_info use MOM_interp_infra, only : horiz_interp_type, horiz_interp_init use MOM_interp_infra, only : run_horiz_interp, build_horiz_interp_weights -use MOM_io_infra, only : axistype use MOM_time_manager, only : time_type implicit none ; private From f89ddeaa80113e0806cb8b3441e39bfde33e7a4a Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 18 Mar 2021 18:21:19 -0400 Subject: [PATCH 019/112] +Add edge_axis argument to write_metadata_axis Added a new optional logical argument to write_metadata_axis to indicate when an axis is staggered at the edges of the tracer grid, and changed calls to get_file_info to stop requesting the number of global attributes. Also eliminated some unused optional arguments to the FMS1 version of write_metadata field. All answers are bitwise identical, but there are minor changes to some I/O related interfaces. --- config_src/infra/FMS1/MOM_io_infra.F90 | 33 +++++++++++--------------- config_src/infra/FMS2/MOM_io_infra.F90 | 14 ++++++----- src/framework/MOM_io.F90 | 18 +++++++------- 3 files changed, 31 insertions(+), 34 deletions(-) diff --git a/config_src/infra/FMS1/MOM_io_infra.F90 b/config_src/infra/FMS1/MOM_io_infra.F90 index 3ea201235a..0d4cc0deb5 100644 --- a/config_src/infra/FMS1/MOM_io_infra.F90 +++ b/config_src/infra/FMS1/MOM_io_infra.F90 @@ -312,13 +312,12 @@ subroutine get_filename_suffix(suffix) end subroutine get_filename_suffix -!> Get information about the number of dimensions, variables, global attributes and time levels +!> Get information about the number of dimensions, variables and time levels !! in the file associated with an open file unit -subroutine get_file_info(IO_handle, ndim, nvar, natt, ntime) +subroutine get_file_info(IO_handle, ndim, nvar, ntime) type(file_type), intent(in) :: IO_handle !< Handle for a file that is open for I/O integer, optional, intent(out) :: ndim !< The number of dimensions in the file integer, optional, intent(out) :: nvar !< The number of variables in the file - integer, optional, intent(out) :: natt !< The number of global attributes in the file integer, optional, intent(out) :: ntime !< The number of time levels in the file ! Local variables @@ -328,7 +327,6 @@ subroutine get_file_info(IO_handle, ndim, nvar, natt, ntime) if (present(ndim)) ndim = ndims if (present(nvar)) nvar = nvars - if (present(natt)) natt = natts if (present(ntime)) ntime = ntimes end subroutine get_file_info @@ -683,7 +681,7 @@ subroutine write_field_4d(IO_handle, field_md, MOM_domain, field, tstamp, tile_c type(fieldtype), intent(in) :: field_md !< Field type with metadata type(MOM_domain_type), intent(in) :: MOM_domain !< The MOM_Domain that describes the decomposition real, dimension(:,:,:,:), intent(inout) :: field !< Field to write - real, optional, intent(in) :: tstamp !< Model timestamp + real, optional, intent(in) :: tstamp !< Model time of this field integer, optional, intent(in) :: tile_count !< PEs per tile (default: 1) real, optional, intent(in) :: fill_value !< Missing data fill value @@ -697,7 +695,7 @@ subroutine write_field_3d(IO_handle, field_md, MOM_domain, field, tstamp, tile_c type(fieldtype), intent(in) :: field_md !< Field type with metadata type(MOM_domain_type), intent(in) :: MOM_domain !< The MOM_Domain that describes the decomposition real, dimension(:,:,:), intent(inout) :: field !< Field to write - real, optional, intent(in) :: tstamp !< Model timestamp + real, optional, intent(in) :: tstamp !< Model time of this field integer, optional, intent(in) :: tile_count !< PEs per tile (default: 1) real, optional, intent(in) :: fill_value !< Missing data fill value @@ -711,7 +709,7 @@ subroutine write_field_2d(IO_handle, field_md, MOM_domain, field, tstamp, tile_c type(fieldtype), intent(in) :: field_md !< Field type with metadata type(MOM_domain_type), intent(in) :: MOM_domain !< The MOM_Domain that describes the decomposition real, dimension(:,:), intent(inout) :: field !< Field to write - real, optional, intent(in) :: tstamp !< Model timestamp + real, optional, intent(in) :: tstamp !< Model time of this field integer, optional, intent(in) :: tile_count !< PEs per tile (default: 1) real, optional, intent(in) :: fill_value !< Missing data fill value @@ -724,7 +722,7 @@ subroutine write_field_1d(IO_handle, field_md, field, tstamp) type(file_type), intent(in) :: IO_handle !< Handle for a file that is open for writing type(fieldtype), intent(in) :: field_md !< Field type with metadata real, dimension(:), intent(in) :: field !< Field to write - real, optional, intent(in) :: tstamp !< Model timestamp + real, optional, intent(in) :: tstamp !< Model time of this field call mpp_write(IO_handle%unit, field_md, field, tstamp=tstamp) end subroutine write_field_1d @@ -734,7 +732,7 @@ subroutine write_field_0d(IO_handle, field_md, field, tstamp) type(file_type), intent(in) :: IO_handle !< Handle for a file that is open for writing type(fieldtype), intent(in) :: field_md !< Field type with metadata real, intent(in) :: field !< Field to write - real, optional, intent(in) :: tstamp !< Model timestamp + real, optional, intent(in) :: tstamp !< Model time of this field call mpp_write(IO_handle%unit, field_md, field, tstamp=tstamp) end subroutine write_field_0d @@ -750,7 +748,8 @@ end subroutine MOM_write_axis !> Store information about an axis in a previously defined axistype and write this !! information to the file indicated by unit. -subroutine write_metadata_axis(IO_handle, axis, name, units, longname, cartesian, sense, domain, data, calendar) +subroutine write_metadata_axis(IO_handle, axis, name, units, longname, cartesian, sense, domain, & + data, edge_axis, calendar) type(file_type), intent(in) :: IO_handle !< Handle for a file that is open for writing type(axistype), intent(inout) :: axis !< The axistype where this information is stored. character(len=*), intent(in) :: name !< The name in the file of this axis @@ -763,6 +762,7 @@ subroutine write_metadata_axis(IO_handle, axis, name, units, longname, cartesian !! -1 if they increase downward. type(domain1D), optional, intent(in) :: domain !< The domain decomposion for this axis real, dimension(:), optional, intent(in) :: data !< The coordinate values of the points on this axis + logical, optional, intent(in) :: edge_axis !< If true, this axis marks an edge of the tracer cells character(len=*), optional, intent(in) :: calendar !< The name of the calendar used with a time axis call mpp_write_meta(IO_handle%unit, axis, name, units, longname, cartesian=cartesian, sense=sense, & @@ -772,19 +772,13 @@ end subroutine write_metadata_axis !> Store information about an output variable in a previously defined fieldtype and write this !! information to the file indicated by unit. subroutine write_metadata_field(IO_handle, field, axes, name, units, longname, & - min, max, fill, scale, add, pack, standard_name, checksum) + pack, standard_name, checksum) type(file_type), intent(in) :: IO_handle !< Handle for a file that is open for writing type(fieldtype), intent(inout) :: field !< The fieldtype where this information is stored type(axistype), dimension(:), intent(in) :: axes !< Handles for the axis used for this variable character(len=*), intent(in) :: name !< The name in the file of this variable character(len=*), intent(in) :: units !< The units of this variable character(len=*), intent(in) :: longname !< The long description of this variable - real, optional, intent(in) :: min !< The minimum valid value for this variable - real, optional, intent(in) :: max !< The maximum valid value for this variable - real, optional, intent(in) :: fill !< Missing data fill value - real, optional, intent(in) :: scale !< An multiplicative factor by which to scale - !! the variable before output - real, optional, intent(in) :: add !< An offset to add to the variable before output integer, optional, intent(in) :: pack !< A precision reduction factor with which the !! variable. The default, 1, has no reduction, !! but 2 is not uncommon. @@ -793,8 +787,9 @@ subroutine write_metadata_field(IO_handle, field, axes, name, units, longname, & optional, intent(in) :: checksum !< Checksum values that can be used to verify reads. - call mpp_write_meta(IO_handle%unit, field, axes, name, units, longname, min=min, max=max, & - fill=fill, scale=scale, add=add, pack=pack, standard_name=standard_name, checksum=checksum) + call mpp_write_meta(IO_handle%unit, field, axes, name, units, longname, & + pack=pack, standard_name=standard_name, checksum=checksum) + ! unused opt. args: min=min, max=max, fill=fill, scale=scale, add=add, & end subroutine write_metadata_field diff --git a/config_src/infra/FMS2/MOM_io_infra.F90 b/config_src/infra/FMS2/MOM_io_infra.F90 index 22548218d1..8115d4acfa 100644 --- a/config_src/infra/FMS2/MOM_io_infra.F90 +++ b/config_src/infra/FMS2/MOM_io_infra.F90 @@ -879,7 +879,7 @@ subroutine write_field_4d(IO_handle, field_md, MOM_domain, field, tstamp, tile_c type(fieldtype), intent(in) :: field_md !< Field type with metadata type(MOM_domain_type), intent(in) :: MOM_domain !< The MOM_Domain that describes the decomposition real, dimension(:,:,:,:), intent(inout) :: field !< Field to write - real, optional, intent(in) :: tstamp !< Model timestamp + real, optional, intent(in) :: tstamp !< Model time of this field integer, optional, intent(in) :: tile_count !< PEs per tile (default: 1) real, optional, intent(in) :: fill_value !< Missing data fill value @@ -893,7 +893,7 @@ subroutine write_field_3d(IO_handle, field_md, MOM_domain, field, tstamp, tile_c type(fieldtype), intent(in) :: field_md !< Field type with metadata type(MOM_domain_type), intent(in) :: MOM_domain !< The MOM_Domain that describes the decomposition real, dimension(:,:,:), intent(inout) :: field !< Field to write - real, optional, intent(in) :: tstamp !< Model timestamp + real, optional, intent(in) :: tstamp !< Model time of this field integer, optional, intent(in) :: tile_count !< PEs per tile (default: 1) real, optional, intent(in) :: fill_value !< Missing data fill value @@ -907,7 +907,7 @@ subroutine write_field_2d(IO_handle, field_md, MOM_domain, field, tstamp, tile_c type(fieldtype), intent(in) :: field_md !< Field type with metadata type(MOM_domain_type), intent(in) :: MOM_domain !< The MOM_Domain that describes the decomposition real, dimension(:,:), intent(inout) :: field !< Field to write - real, optional, intent(in) :: tstamp !< Model timestamp + real, optional, intent(in) :: tstamp !< Model time of this field integer, optional, intent(in) :: tile_count !< PEs per tile (default: 1) real, optional, intent(in) :: fill_value !< Missing data fill value @@ -920,7 +920,7 @@ subroutine write_field_1d(IO_handle, field_md, field, tstamp) type(file_type), intent(in) :: IO_handle !< Handle for a file that is open for writing type(fieldtype), intent(in) :: field_md !< Field type with metadata real, dimension(:), intent(in) :: field !< Field to write - real, optional, intent(in) :: tstamp !< Model timestamp + real, optional, intent(in) :: tstamp !< Model time of this field call mpp_write(IO_handle%unit, field_md, field, tstamp=tstamp) end subroutine write_field_1d @@ -930,7 +930,7 @@ subroutine write_field_0d(IO_handle, field_md, field, tstamp) type(file_type), intent(in) :: IO_handle !< Handle for a file that is open for writing type(fieldtype), intent(in) :: field_md !< Field type with metadata real, intent(in) :: field !< Field to write - real, optional, intent(in) :: tstamp !< Model timestamp + real, optional, intent(in) :: tstamp !< Model time of this field call mpp_write(IO_handle%unit, field_md, field, tstamp=tstamp) end subroutine write_field_0d @@ -946,7 +946,8 @@ end subroutine MOM_write_axis !> Store information about an axis in a previously defined axistype and write this !! information to the file indicated by unit. -subroutine write_metadata_axis(IO_handle, axis, name, units, longname, cartesian, sense, domain, data, calendar) +subroutine write_metadata_axis(IO_handle, axis, name, units, longname, cartesian, sense, domain, data, & + edge_axis, calendar) type(file_type), intent(in) :: IO_handle !< Handle for a file that is open for writing type(axistype), intent(inout) :: axis !< The axistype where this information is stored. character(len=*), intent(in) :: name !< The name in the file of this axis @@ -959,6 +960,7 @@ subroutine write_metadata_axis(IO_handle, axis, name, units, longname, cartesian !! -1 if they increase downward. type(domain1D), optional, intent(in) :: domain !< The domain decomposion for this axis real, dimension(:), optional, intent(in) :: data !< The coordinate values of the points on this axis + logical, optional, intent(in) :: edge_axis !< If true, this axis marks an edge of the tracer cells character(len=*), optional, intent(in) :: calendar !< The name of the calendar used with a time axis call mpp_write_meta(IO_handle%unit, axis, name, units, longname, cartesian=cartesian, sense=sense, & diff --git a/src/framework/MOM_io.F90 b/src/framework/MOM_io.F90 index 1159ac87e1..247a0a9678 100644 --- a/src/framework/MOM_io.F90 +++ b/src/framework/MOM_io.F90 @@ -254,11 +254,11 @@ subroutine create_file(IO_handle, filename, vars, novars, fields, threading, tim if (use_latq) & call write_metadata(IO_handle, axis_latq, name="latq", units=y_axis_units, longname="Latitude", & - cartesian='Y', domain=y_domain, data=gridLatB(JsgB:JegB)) + cartesian='Y', domain=y_domain, data=gridLatB(JsgB:JegB), edge_axis=.true.) if (use_lonq) & call write_metadata(IO_handle, axis_lonq, name="lonq", units=x_axis_units, longname="Longitude", & - cartesian='X', domain=x_domain, data=gridLonB(IsgB:IegB)) + cartesian='X', domain=x_domain, data=gridLonB(IsgB:IegB), edge_axis=.true.) if (use_layer) & call write_metadata(IO_handle, axis_layer, name="Layer", units=trim(GV%zAxisUnits), & @@ -383,7 +383,7 @@ subroutine reopen_file(IO_handle, filename, vars, novars, fields, threading, tim type(MOM_domain_type), pointer :: Domain => NULL() character(len=200) :: check_name, mesg - integer :: length, ndim, nvar, natt, ntime, thread + integer :: length, nvar, thread logical :: exists, one_file, domain_set thread = SINGLE_FILE @@ -418,7 +418,7 @@ subroutine reopen_file(IO_handle, filename, vars, novars, fields, threading, tim endif if (.not.file_is_open(IO_handle)) return - call get_file_info(IO_handle, ndim, nvar, natt, ntime) + call get_file_info(IO_handle, nvar=nvar) if (nvar == -1) then write (mesg,*) "Reopening file ",trim(filename)," apparently had ",nvar,& @@ -1343,7 +1343,7 @@ end subroutine query_vardesc !> Write a 4d field to an output file, potentially with rotation subroutine MOM_write_field_4d(IO_handle, field_md, MOM_domain, field, tstamp, tile_count, & fill_value, turns, scale) - type(file_type), intent(in) :: IO_handle !< Handle for a file that is open for writing + type(file_type), intent(inout) :: IO_handle !< Handle for a file that is open for writing type(fieldtype), intent(in) :: field_md !< Field type with metadata type(MOM_domain_type), intent(in) :: MOM_domain !< The MOM_Domain that describes the decomposition real, dimension(:,:,:,:), intent(inout) :: field !< Unrotated field to write @@ -1378,7 +1378,7 @@ end subroutine MOM_write_field_4d !> Write a 3d field to an output file, potentially with rotation subroutine MOM_write_field_3d(IO_handle, field_md, MOM_domain, field, tstamp, tile_count, & fill_value, turns, scale) - type(file_type), intent(in) :: IO_handle !< Handle for a file that is open for writing + type(file_type), intent(inout) :: IO_handle !< Handle for a file that is open for writing type(fieldtype), intent(in) :: field_md !< Field type with metadata type(MOM_domain_type), intent(in) :: MOM_domain !< The MOM_Domain that describes the decomposition real, dimension(:,:,:), intent(inout) :: field !< Unrotated field to write @@ -1413,7 +1413,7 @@ end subroutine MOM_write_field_3d !> Write a 2d field to an output file, potentially with rotation subroutine MOM_write_field_2d(IO_handle, field_md, MOM_domain, field, tstamp, tile_count, & fill_value, turns, scale) - type(file_type), intent(in) :: IO_handle !< Handle for a file that is open for writing + type(file_type), intent(inout) :: IO_handle !< Handle for a file that is open for writing type(fieldtype), intent(in) :: field_md !< Field type with metadata type(MOM_domain_type), intent(in) :: MOM_domain !< The MOM_Domain that describes the decomposition real, dimension(:,:), intent(inout) :: field !< Unrotated field to write @@ -1447,7 +1447,7 @@ end subroutine MOM_write_field_2d !> Write a 1d field to an output file subroutine MOM_write_field_1d(IO_handle, field_md, field, tstamp, fill_value, scale) - type(file_type), intent(in) :: IO_handle !< Handle for a file that is open for writing + type(file_type), intent(inout) :: IO_handle !< Handle for a file that is open for writing type(fieldtype), intent(in) :: field_md !< Field type with metadata real, dimension(:), intent(in) :: field !< Field to write real, optional, intent(in) :: tstamp !< Model timestamp @@ -1476,7 +1476,7 @@ end subroutine MOM_write_field_1d !> Write a 0d field to an output file subroutine MOM_write_field_0d(IO_handle, field_md, field, tstamp, fill_value, scale) - type(file_type), intent(in) :: IO_handle !< Handle for a file that is open for writing + type(file_type), intent(inout) :: IO_handle !< Handle for a file that is open for writing type(fieldtype), intent(in) :: field_md !< Field type with metadata real, intent(in) :: field !< Field to write real, optional, intent(in) :: tstamp !< Model timestamp From 0fdc5c43816c716509a97b2ecaa9506375fffcca Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 18 Mar 2021 18:27:08 -0400 Subject: [PATCH 020/112] Correct warnings from categorize_axis Corrected the logic of a warning message in categorize_axis by adding parentheses. All answers are bitwise identical, and spurious warnings are no longer being issued. --- config_src/infra/FMS2/MOM_read_data_fms2.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/config_src/infra/FMS2/MOM_read_data_fms2.F90 b/config_src/infra/FMS2/MOM_read_data_fms2.F90 index 83a10e7e30..4732c019f4 100644 --- a/config_src/infra/FMS2/MOM_read_data_fms2.F90 +++ b/config_src/infra/FMS2/MOM_read_data_fms2.F90 @@ -233,7 +233,7 @@ subroutine categorize_axes(fileObj, filename, ndims, dim_names, is_x, is_y, is_t endif ; enddo endif - if (.not.(x_found .and. y_found) .and. (ndims>2) .or. ((ndims==2) .and. .not.is_t(ndims))) then + if (.not.(x_found .and. y_found) .and. ((ndims>2) .or. ((ndims==2) .and. .not.is_t(ndims)))) then ! This is a case where one would expect to find x-and y-dimensions, but none have been found. if (is_root_pe()) then dim_list = trim(dim_names(1))//", "//trim(dim_names(2)) From 255233ba3b1de88cc772887062bd6666fb1b5ddf Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 18 Mar 2021 18:44:25 -0400 Subject: [PATCH 021/112] Added code to write via FMS2 interfaces Added a large number of calls to handle all of the writes via the FMS2 interfaces to infra/FMS2/MOM_io_infra.F90. There are newly defined private types in MOM_io_infra to wrap the axistype and fieldtype that had previously been offered from mpp_io_mod. All answers are bitwise identical and it has been verified that output files do not change and the restarts are still working. --- config_src/infra/FMS2/MOM_io_infra.F90 | 520 +++++++++++++++++++++---- 1 file changed, 452 insertions(+), 68 deletions(-) diff --git a/config_src/infra/FMS2/MOM_io_infra.F90 b/config_src/infra/FMS2/MOM_io_infra.F90 index 8115d4acfa..d4fe0b5387 100644 --- a/config_src/infra/FMS2/MOM_io_infra.F90 +++ b/config_src/infra/FMS2/MOM_io_infra.F90 @@ -8,8 +8,13 @@ module MOM_io_infra use MOM_error_infra, only : MOM_error=>MOM_err, NOTE, FATAL, WARNING use MOM_read_data_fms2, only : prepare_to_read_var -use fms2_io_mod, only : fms2_open_file => open_file, fms2_close_file => close_file -use fms2_io_mod, only : FmsNetcdfDomainFile_t, fms2_read_data => read_data, check_if_open +use fms2_io_mod, only : fms2_open_file => open_file, check_if_open, fms2_close_file => close_file +use fms2_io_mod, only : FmsNetcdfDomainFile_t, FmsNetcdfFile_t, fms2_read_data => read_data +use fms2_io_mod, only : get_unlimited_dimension_name, get_num_dimensions, get_num_variables +use fms2_io_mod, only : get_variable_names, variable_exists, get_variable_size +use fms2_io_mod, only : register_field, write_data, register_variable_attribute +use fms2_io_mod, only : variable_att_exists, get_variable_attribute, get_variable_num_dimensions +use fms2_io_mod, only : get_dimension_size, is_dimension_registered, register_axis, unlimited use fms_mod, only : write_version_number, open_namelist_file, check_nml_error use fms_io_mod, only : file_exist, field_exist, field_size, read_data @@ -17,8 +22,8 @@ module MOM_io_infra use mpp_io_mod, only : mpp_open, mpp_close, mpp_flush use mpp_io_mod, only : mpp_write_meta, mpp_write use mpp_io_mod, only : mpp_get_atts, mpp_attribute_exist -use mpp_io_mod, only : mpp_get_axes, axistype, mpp_get_axis_data -use mpp_io_mod, only : mpp_get_fields, fieldtype +use mpp_io_mod, only : mpp_get_axes, mpp_axistype=>axistype, mpp_get_axis_data +use mpp_io_mod, only : mpp_get_fields, mpp_fieldtype=>fieldtype use mpp_io_mod, only : mpp_get_info, mpp_get_times use mpp_io_mod, only : mpp_io_init ! These are encoding constants. @@ -38,7 +43,7 @@ module MOM_io_infra public :: io_infra_init, io_infra_end, MOM_namelist_file, check_namelist_error, write_version ! These types are inherited from underlying infrastructure code, to act as containers for ! information about fields and axes, respectively, and are opaque to this module. -public :: fieldtype, axistype +! public :: file_type, fieldtype, axistype ! These are encoding constant parmeters. public :: ASCII_FILE, NETCDF_FILE, SINGLE_FILE, MULTIPLE public :: APPEND_FILE, READONLY_FILE, OVERWRITE_FILE, WRITEONLY_FILE @@ -99,13 +104,37 @@ module MOM_io_infra !> Type for holding a handle to an open file and related information type, public :: file_type ; private integer :: unit = -1 !< The framework identfier or netCDF unit number of an output file + type(FmsNetcdfDomainFile_t), pointer :: fileobj => NULL() !< A domain-decomposed + !! file object that is open for writing character(len=:), allocatable :: filename !< The path to this file, if it is open logical :: open_to_read = .false. !< If true, this file or fileset can be read logical :: open_to_write = .false. !< If true, this file or fileset can be written to + integer :: num_times !< The number of time levels in this file + real :: file_time !< The time of the latest entry in the file. + logical :: FMS2_file !< If true, this file-type is to be used with FMS2 interfaces. end type file_type +!> This type is a container for information about a variable in a file. +type, public :: fieldtype ; private + character(len=256) :: name !< The name of this field in the files. + type(mpp_fieldtype) :: FT !< The FMS1 field-type that this type wraps + character(len=:), allocatable :: longname !< The long name for this field + character(len=:), allocatable :: units !< The units for this field + integer(kind=int64) :: chksum_read !< A checksum that has been read from a file + logical :: valid_chksum !< If true, this field has a valid checksum value. + logical :: FMS2_field !< If true, this field-type should be used with FMS2 interfaces. +end type fieldtype + +!> This type is a container for information about an axis in a file. +type, public :: axistype ; private + character(len=256) :: name !< The name of this axis in the files. + type(mpp_axistype) :: AT !< The FMS1 axis-type that this type wraps + real, allocatable, dimension(:) :: ax_data !< The values of the data on the axis. +end type axistype + !> For now, this is hard-coded to exercise the new FMS2 interfaces. logical :: FMS2_reads = .true. +logical :: FMS2_writes = .true. contains @@ -115,17 +144,11 @@ subroutine read_field_chksum(field, chksum, valid_chksum) type(fieldtype), intent(in) :: field !< The field whose checksum attribute is to be read. integer(kind=int64), intent(out) :: chksum !< The checksum for the field. logical, intent(out) :: valid_chksum !< If true, chksum has been successfully read. - ! Local variables - integer(kind=int64), dimension(3) :: checksum_file - checksum_file(:) = -1 - valid_chksum = mpp_attribute_exist(field, "checksum") - if (valid_chksum) then - call get_field_atts(field, checksum=checksum_file) - chksum = checksum_file(1) - else - chksum = -1 - endif + chksum = -1 + valid_chksum = field%valid_chksum + if (valid_chksum) chksum = field%chksum_read + end subroutine read_field_chksum !> Returns true if the named file or its domain-decomposed variant exists. @@ -156,7 +179,7 @@ end function FMS_file_exists logical function file_is_open(IO_handle) type(file_type), intent(in) :: IO_handle !< Handle to a file to inquire about - file_is_open = (IO_handle%unit >= 0) + file_is_open = ((IO_handle%unit >= 0) .or. associated(IO_handle%fileobj)) end function file_is_open !> closes a file (or fileset). If the file handle does not point to an open file, @@ -164,9 +187,16 @@ end function file_is_open subroutine close_file_type(IO_handle) type(file_type), intent(inout) :: IO_handle !< The I/O handle for the file to be closed - call mpp_close(IO_handle%unit) + if (associated(IO_handle%fileobj)) then + call fms2_close_file(IO_handle%fileobj) + deallocate(IO_handle%fileobj) + else + call mpp_close(IO_handle%unit) + endif if (allocated(IO_handle%filename)) deallocate(IO_handle%filename) IO_handle%open_to_read = .false. ; IO_handle%open_to_write = .false. + IO_handle%num_times = 0 ; IO_handle%file_time = 0.0 + IO_handle%FMS2_file = .false. end subroutine close_file_type !> closes a file. If the unit does not point to an open file, @@ -178,10 +208,14 @@ subroutine close_file_unit(unit) end subroutine close_file_unit !> Ensure that the output stream associated with a file handle is fully sent to disk. -subroutine flush_file_type(file) - type(file_type), intent(in) :: file !< The I/O handle for the file to flush +subroutine flush_file_type(IO_handle) + type(file_type), intent(in) :: IO_handle !< The I/O handle for the file to flush - call mpp_flush(file%unit) + if (associated(IO_handle%fileobj)) then + ! There does not appear to be an fms2 flush call. + else + call mpp_flush(IO_handle%unit) + endif end subroutine flush_file_type !> Ensure that the output stream associated with a unit is fully sent to disk. @@ -272,20 +306,70 @@ subroutine open_file_type(IO_handle, filename, action, MOM_domain, threading, fi !! to threading=MULTIPLE write to the same file (SINGLE_FILE) !! or to one file per PE (MULTIPLE, the default). - if (present(MOM_Domain)) then - call mpp_open(IO_handle%unit, filename, action=action, form=NETCDF_FILE, threading=threading, & + ! Local variables + type(FmsNetcdfDomainFile_t) :: fileobj_read ! A handle to a domain-decomposed file for obtaining information + ! about the exiting time axis entries in append mode. + logical :: success ! If true, the file was opened successfully + integer :: file_mode ! An integer that encodes whether the file is to be opened for + ! reading, writing or appending + character(len=40) :: mode ! A character string that encodes whether the file is to be opened for + ! reading, writing or appending + character(len=256) :: dim_unlim_name ! name of the unlimited dimension in the file + + if (IO_handle%open_to_write) then + call MOM_error(WARNING, "open_file_type called for file "//trim(filename)//& + " with an IO_handle that is already open to to write.") + return + endif + if (IO_handle%open_to_read) then + call MOM_error(FATAL, "open_file_type called for file "//trim(filename)//& + " with an IO_handle that is already open to to read.") + endif + + file_mode = WRITEONLY_FILE ; if (present(action)) file_mode = action + + if (FMS2_writes .and. present(MOM_Domain)) then + if (.not.associated(IO_handle%fileobj)) allocate (IO_handle%fileobj) + + if (file_mode == WRITEONLY_FILE) then ; mode = "write" + elseif (file_mode == APPEND_FILE) then ; mode = "append" + elseif (file_mode == OVERWRITE_FILE) then ; mode = "overwrite" + elseif (file_mode == READONLY_FILE) then ; mode = "read" + else + call MOM_error(FATAL, "open_file_type called with unrecognized action.") + endif + + IO_handle%num_times = 0 + IO_handle%file_time = 0.0 + if ((file_mode == APPEND_FILE) .and. file_exists(filename, MOM_Domain)) then + ! Determine the latest file time and number of records so far. + success = fms2_open_file(fileObj_read, trim(filename), "read", MOM_domain%mpp_domain) + call get_unlimited_dimension_name(fileObj_read, dim_unlim_name) + if (len_trim(dim_unlim_name) > 0) & + call get_dimension_size(fileObj_read, trim(dim_unlim_name), IO_handle%num_times) + if (IO_handle%num_times > 0) & + call fms2_read_data(fileObj_read, trim(dim_unlim_name), IO_handle%file_time, & + unlim_dim_level=IO_handle%num_times) + call fms2_close_file(fileObj_read) + endif + + success = fms2_open_file(IO_handle%fileobj, trim(filename), trim(mode), & + MOM_domain%mpp_domain, is_restart=.false.) + if (.not.success) call MOM_error(FATAL, "Unable to open file "//trim(filename)) + IO_handle%FMS2_file = .true. + elseif (present(MOM_Domain)) then + call mpp_open(IO_handle%unit, filename, action=file_mode, form=NETCDF_FILE, threading=threading, & fileset=fileset, domain=MOM_Domain%mpp_domain) + IO_handle%FMS2_file = .false. else - call mpp_open(IO_handle%unit, filename, action=action, form=NETCDF_FILE, threading=threading, & + call mpp_open(IO_handle%unit, filename, action=file_mode, form=NETCDF_FILE, threading=threading, & fileset=fileset) + IO_handle%FMS2_file = .false. endif IO_handle%filename = trim(filename) - if (present(action)) then - if (action == READONLY_FILE) then - IO_handle%open_to_read = .true. ; IO_handle%open_to_write = .false. - else - IO_handle%open_to_read = .false. ; IO_handle%open_to_write = .true. - endif + + if (file_mode == READONLY_FILE) then + IO_handle%open_to_read = .true. ; IO_handle%open_to_write = .false. else IO_handle%open_to_read = .false. ; IO_handle%open_to_write = .true. endif @@ -319,43 +403,59 @@ subroutine get_filename_suffix(suffix) end subroutine get_filename_suffix -!> Get information about the number of dimensions, variables, global attributes and time levels +!> Get information about the number of dimensions, variables and time levels !! in the file associated with an open file unit -subroutine get_file_info(IO_handle, ndim, nvar, natt, ntime) +subroutine get_file_info(IO_handle, ndim, nvar, ntime) type(file_type), intent(in) :: IO_handle !< Handle for a file that is open for I/O integer, optional, intent(out) :: ndim !< The number of dimensions in the file integer, optional, intent(out) :: nvar !< The number of variables in the file - integer, optional, intent(out) :: natt !< The number of global attributes in the file integer, optional, intent(out) :: ntime !< The number of time levels in the file ! Local variables + character(len=256) :: dim_unlim_name ! name of the unlimited dimension in the file integer :: ndims, nvars, natts, ntimes - call mpp_get_info(IO_handle%unit, ndims, nvars, natts, ntimes ) + if (IO_handle%FMS2_file) then + if (present(ndim)) ndim = get_num_dimensions(IO_handle%fileobj) + if (present(nvar)) nvar = get_num_variables(IO_handle%fileobj) + if (present(ntime)) then + ntime = 0 + call get_unlimited_dimension_name(IO_handle%fileobj, dim_unlim_name) + if (len_trim(dim_unlim_name) > 0) & + call get_dimension_size(IO_handle%fileobj, trim(dim_unlim_name), ntime) + endif + else + call mpp_get_info(IO_handle%unit, ndims, nvars, natts, ntimes ) - if (present(ndim)) ndim = ndims - if (present(nvar)) nvar = nvars - if (present(natt)) natt = natts - if (present(ntime)) ntime = ntimes + if (present(ndim)) ndim = ndims + if (present(nvar)) nvar = nvars + if (present(ntime)) ntime = ntimes + endif end subroutine get_file_info !> Get the times of records from a file - !### Modify this to also convert to time_type, using information about the dimensions? subroutine get_file_times(IO_handle, time_values, ntime) type(file_type), intent(in) :: IO_handle !< Handle for a file that is open for I/O real, allocatable, dimension(:), intent(inout) :: time_values !< The real times for the records in file. integer, optional, intent(out) :: ntime !< The number of time levels in the file + character(len=256) :: dim_unlim_name ! name of the unlimited dimension in the file integer :: ntimes + !### Modify this routine to optionally convert to time_type, using information about the dimensions? if (allocated(time_values)) deallocate(time_values) call get_file_info(IO_handle, ntime=ntimes) if (present(ntime)) ntime = ntimes if (ntimes > 0) then allocate(time_values(ntimes)) - call mpp_get_times(IO_handle%unit, time_values) + if (IO_handle%FMS2_file) then + call get_unlimited_dimension_name(IO_handle%fileobj, dim_unlim_name) + call fms2_read_data(IO_handle%fileobj, trim(dim_unlim_name), time_values) + else + call mpp_get_times(IO_handle%unit, time_values) + endif endif end subroutine get_file_times @@ -365,7 +465,45 @@ subroutine get_file_fields(IO_handle, fields) type(file_type), intent(in) :: IO_handle !< Handle for a file that is open for I/O type(fieldtype), dimension(:), intent(inout) :: fields !< Field-type descriptions of all of !! the variables in a file. - call mpp_get_fields(IO_handle%unit, fields) + type(mpp_fieldtype), dimension(size(fields)) :: mpp_fields + character(len=256), dimension(size(fields)) :: var_names + character(len=256) :: units + character(len=2048) :: longname + integer(kind=int64), dimension(3) :: checksum_file + integer :: i, nvar + + nvar = size(fields) + ! Local variables + if (IO_handle%FMS2_file) then + call get_variable_names(IO_handle%fileobj, var_names) + do i=1,nvar + fields(i)%name = trim(var_names(i)) + longname = "" + call get_variable_attribute(IO_handle%fileobj, var_names(i), 'long_name', longname) + fields(i)%longname = trim(longname) + units = "" + call get_variable_attribute(IO_handle%fileobj, var_names(i), 'units', units) + fields(i)%units = trim(units) + + fields(i)%valid_chksum = variable_att_exists(IO_handle%fileobj, var_names(i), "checksum") + if (fields(i)%valid_chksum) then + call get_variable_attribute(IO_handle%fileobj, var_names(i), 'checksum', checksum_file) + fields(i)%chksum_read = checksum_file(1) + endif + enddo + else + call mpp_get_fields(IO_handle%unit, mpp_fields) + do i=1,nvar + fields(i)%FT = mpp_fields(i) + call mpp_get_atts(fields(i)%FT, name=fields(i)%name, units=units, longname=longname, & + checksum=checksum_file) + fields(i)%longname = trim(longname) + fields(i)%units = trim(units) + fields(i)%valid_chksum = mpp_attribute_exist(fields(i)%FT, "checksum") + if (fields(i)%valid_chksum) fields(i)%chksum_read = checksum_file(1) + enddo + endif + end subroutine get_file_fields !> Extract information from a field type, as stored or as found in a file @@ -376,7 +514,12 @@ subroutine get_field_atts(field, name, units, longname, checksum) character(len=*), optional, intent(out) :: longname !< The long name of the variable integer(kind=int64), dimension(:), & optional, intent(out) :: checksum !< The checksums of the variable in a file - call mpp_get_atts(field, name=name, units=units, longname=longname, checksum=checksum) + + if (present(name)) name = trim(field%name) + if (present(units)) units = trim(field%units) + if (present(longname)) longname = trim(field%longname) + if (present(checksum)) checksum = field%chksum_read + end subroutine get_field_atts !> Field_exists returns true if the field indicated by field_name is present in the @@ -389,7 +532,44 @@ function field_exists(filename, field_name, domain, no_domain, MOM_domain) type(MOM_domain_type), optional, intent(in) :: MOM_Domain !< A MOM_Domain that describes the decomposition logical :: field_exists !< True if filename exists and field_name is in filename - if (present(MOM_domain)) then + ! Local variables + type(FmsNetcdfDomainFile_t) :: fileObj_dd ! A handle to a domain-decomposed file for obtaining information + ! about the exiting time axis entries in append mode. + type(FmsNetcdfFile_t) :: fileObj_simple ! A handle to a non-domain-decomposed file for obtaining information + ! about the exiting time axis entries in append mode. + logical :: success ! If true, the file was opened successfully + logical :: domainless ! If true, this file does not use a domain-decomposed file. + + domainless = .not.(present(MOM_domain) .or. present(domain)) + if (present(no_domain)) then + if (domainless .and. .not.no_domain) call MOM_error(FATAL, & + "field_exists: When no_domain is present and false, a domain must be supplied in query about "//& + trim(field_name)//" in file "//trim(filename)) + domainless = no_domain + endif + + if (FMS2_reads) then + field_exists = .false. + if (file_exists(filename)) then + if (domainless) then + success = fms2_open_file(fileObj_simple, trim(filename), "read") + if (success) then + field_exists = variable_exists(fileObj_simple, field_name) + call fms2_close_file(fileObj_simple) + endif + else + if (present(MOM_domain)) then + success = fms2_open_file(fileObj_dd, trim(filename), "read", MOM_domain%mpp_domain) + else + success = fms2_open_file(fileObj_dd, trim(filename), "read", domain) + endif + if (success) then + field_exists = variable_exists(fileobj_dd, field_name) + call fms2_close_file(fileObj_dd) + endif + endif + endif + elseif (present(MOM_domain)) then field_exists = field_exist(filename, field_name, domain=MOM_domain%mpp_domain, no_domain=no_domain) else field_exists = field_exist(filename, field_name, domain=domain, no_domain=no_domain) @@ -408,7 +588,32 @@ subroutine get_field_size(filename, fieldname, sizes, field_found, no_domain) logical, optional, intent(in) :: no_domain !< If present and true, do not check for file !! names with an appended tile number - call field_size(filename, fieldname, sizes, field_found=field_found, no_domain=no_domain) + ! Local variables + type(FmsNetcdfFile_t) :: fileobj_read ! A handle to a non-domain-decomposed file for obtaining information + ! about the exiting time axis entries in append mode. + logical :: success ! If true, the file was opened successfully + logical :: field_exists ! True if filename exists and field_name is in filename + integer :: i, ndims + + if (FMS2_reads) then + field_exists = .false. + if (file_exists(filename)) then + success = fms2_open_file(fileObj_read, trim(filename), "read") + if (success) then + field_exists = variable_exists(fileobj_read, fieldname) + if (field_exists) then + ndims = get_variable_num_dimensions(fileobj_read, fieldname) + if (ndims > size(sizes)) call MOM_error(FATAL, & + "get_field_size called with too few sizes for "//trim(fieldname)//" in "//trim(filename)) + call get_variable_size(fileobj_read, fieldname, sizes(1:ndims)) + do i=ndims+1,size(sizes) ; sizes(i) = 0 ; enddo + endif + endif + endif + if (present(field_found)) field_found = field_exists + else + call field_size(filename, fieldname, sizes, field_found=field_found, no_domain=no_domain) + endif end subroutine get_field_size @@ -417,7 +622,16 @@ subroutine get_axis_data( axis, dat ) type(axistype), intent(in) :: axis !< An axis type real, dimension(:), intent(out) :: dat !< The data in the axis variable - call mpp_get_axis_data( axis, dat ) + integer :: i + + if (allocated(axis%ax_data)) then + if (size(axis%ax_data) > size(dat)) call MOM_error(FATAL, & + "get_axis_data called with too small of an output data array for "//trim(axis%name)) + do i=1,size(axis%ax_data) ; dat(i) = axis%ax_data(i) ; enddo + elseif (.not.FMS2_writes) then + call mpp_get_axis_data( axis%AT, dat ) + endif + end subroutine get_axis_data !> This routine uses the fms_io subroutine read_data to read a scalar named @@ -587,7 +801,7 @@ subroutine MOM_read_data_2d_region(filename, fieldname, data, start, nread, MOM_ real, optional, intent(in) :: scale !< A scaling factor that the field is multiplied !! by before it is returned. - ! This subroutine does not have an FMS-2 variant yet. + !### This subroutine does not have an FMS-2 variant yet. if (present(MOM_Domain)) then call read_data(filename, fieldname, data, start, nread, domain=MOM_Domain%mpp_domain, & @@ -716,6 +930,7 @@ subroutine MOM_read_data_0d_int(filename, fieldname, data, timelevel) integer, intent(inout) :: data !< The 1-dimensional array into which the data integer, optional, intent(in) :: timelevel !< The time level in the file to read + !### This needs an FMS2 variant, eventually. call read_data(filename, fieldname, data, timelevel=timelevel, no_domain=.true.) end subroutine MOM_read_data_0d_int @@ -728,6 +943,7 @@ subroutine MOM_read_data_1d_int(filename, fieldname, data, timelevel) integer, dimension(:), intent(inout) :: data !< The 1-dimensional array into which the data integer, optional, intent(in) :: timelevel !< The time level in the file to read + !### This needs an FMS2 variant, eventually. call read_data(filename, fieldname, data, timelevel=timelevel, no_domain=.true.) end subroutine MOM_read_data_1d_int @@ -875,7 +1091,7 @@ end subroutine MOM_read_vector_3d !> Write a 4d field to an output file. subroutine write_field_4d(IO_handle, field_md, MOM_domain, field, tstamp, tile_count, fill_value) - type(file_type), intent(in) :: IO_handle !< Handle for a file that is open for writing + type(file_type), intent(inout) :: IO_handle !< Handle for a file that is open for writing type(fieldtype), intent(in) :: field_md !< Field type with metadata type(MOM_domain_type), intent(in) :: MOM_domain !< The MOM_Domain that describes the decomposition real, dimension(:,:,:,:), intent(inout) :: field !< Field to write @@ -883,13 +1099,24 @@ subroutine write_field_4d(IO_handle, field_md, MOM_domain, field, tstamp, tile_c integer, optional, intent(in) :: tile_count !< PEs per tile (default: 1) real, optional, intent(in) :: fill_value !< Missing data fill value - call mpp_write(IO_handle%unit, field_md, MOM_domain%mpp_domain, field, tstamp=tstamp, & - tile_count=tile_count, default_data=fill_value) + + ! Local variables + integer :: time_index + + if (IO_handle%FMS2_file .and. present(tstamp)) then + time_index = write_time_if_later(IO_handle, tstamp) + call write_data(IO_handle%fileobj, trim(field_md%name), field, unlim_dim_level=time_index) + elseif (IO_handle%FMS2_file) then + call write_data(IO_handle%fileobj, trim(field_md%name), field) + else + call mpp_write(IO_handle%unit, field_md%FT, MOM_domain%mpp_domain, field, tstamp=tstamp, & + tile_count=tile_count, default_data=fill_value) + endif end subroutine write_field_4d !> Write a 3d field to an output file. subroutine write_field_3d(IO_handle, field_md, MOM_domain, field, tstamp, tile_count, fill_value) - type(file_type), intent(in) :: IO_handle !< Handle for a file that is open for writing + type(file_type), intent(inout) :: IO_handle !< Handle for a file that is open for writing type(fieldtype), intent(in) :: field_md !< Field type with metadata type(MOM_domain_type), intent(in) :: MOM_domain !< The MOM_Domain that describes the decomposition real, dimension(:,:,:), intent(inout) :: field !< Field to write @@ -897,13 +1124,23 @@ subroutine write_field_3d(IO_handle, field_md, MOM_domain, field, tstamp, tile_c integer, optional, intent(in) :: tile_count !< PEs per tile (default: 1) real, optional, intent(in) :: fill_value !< Missing data fill value - call mpp_write(IO_handle%unit, field_md, MOM_domain%mpp_domain, field, tstamp=tstamp, & + ! Local variables + integer :: time_index + + if (IO_handle%FMS2_file .and. present(tstamp)) then + time_index = write_time_if_later(IO_handle, tstamp) + call write_data(IO_handle%fileobj, trim(field_md%name), field, unlim_dim_level=time_index) + elseif (IO_handle%FMS2_file) then + call write_data(IO_handle%fileobj, trim(field_md%name), field) + else + call mpp_write(IO_handle%unit, field_md%FT, MOM_domain%mpp_domain, field, tstamp=tstamp, & tile_count=tile_count, default_data=fill_value) + endif end subroutine write_field_3d !> Write a 2d field to an output file. subroutine write_field_2d(IO_handle, field_md, MOM_domain, field, tstamp, tile_count, fill_value) - type(file_type), intent(in) :: IO_handle !< Handle for a file that is open for writing + type(file_type), intent(inout) :: IO_handle !< Handle for a file that is open for writing type(fieldtype), intent(in) :: field_md !< Field type with metadata type(MOM_domain_type), intent(in) :: MOM_domain !< The MOM_Domain that describes the decomposition real, dimension(:,:), intent(inout) :: field !< Field to write @@ -911,36 +1148,92 @@ subroutine write_field_2d(IO_handle, field_md, MOM_domain, field, tstamp, tile_c integer, optional, intent(in) :: tile_count !< PEs per tile (default: 1) real, optional, intent(in) :: fill_value !< Missing data fill value - call mpp_write(IO_handle%unit, field_md, MOM_domain%mpp_domain, field, tstamp=tstamp, & + ! Local variables + integer :: time_index + + if (IO_handle%FMS2_file .and. present(tstamp)) then + time_index = write_time_if_later(IO_handle, tstamp) + call write_data(IO_handle%fileobj, trim(field_md%name), field, unlim_dim_level=time_index) + elseif (IO_handle%FMS2_file) then + call write_data(IO_handle%fileobj, trim(field_md%name), field) + else + call mpp_write(IO_handle%unit, field_md%FT, MOM_domain%mpp_domain, field, tstamp=tstamp, & tile_count=tile_count, default_data=fill_value) + endif end subroutine write_field_2d !> Write a 1d field to an output file. subroutine write_field_1d(IO_handle, field_md, field, tstamp) - type(file_type), intent(in) :: IO_handle !< Handle for a file that is open for writing + type(file_type), intent(inout) :: IO_handle !< Handle for a file that is open for writing type(fieldtype), intent(in) :: field_md !< Field type with metadata real, dimension(:), intent(in) :: field !< Field to write real, optional, intent(in) :: tstamp !< Model time of this field - call mpp_write(IO_handle%unit, field_md, field, tstamp=tstamp) + ! Local variables + integer :: time_index + + if (IO_handle%FMS2_file .and. present(tstamp)) then + time_index = write_time_if_later(IO_handle, tstamp) + call write_data(IO_handle%fileobj, trim(field_md%name), field, unlim_dim_level=time_index) + elseif (IO_handle%FMS2_file) then + call write_data(IO_handle%fileobj, trim(field_md%name), field) + else + call mpp_write(IO_handle%unit, field_md%FT, field, tstamp=tstamp) + endif end subroutine write_field_1d !> Write a 0d field to an output file. subroutine write_field_0d(IO_handle, field_md, field, tstamp) - type(file_type), intent(in) :: IO_handle !< Handle for a file that is open for writing + type(file_type), intent(inout) :: IO_handle !< Handle for a file that is open for writing type(fieldtype), intent(in) :: field_md !< Field type with metadata real, intent(in) :: field !< Field to write real, optional, intent(in) :: tstamp !< Model time of this field - call mpp_write(IO_handle%unit, field_md, field, tstamp=tstamp) + ! Local variables + integer :: time_index + + if (IO_handle%FMS2_file .and. present(tstamp)) then + time_index = write_time_if_later(IO_handle, tstamp) + call write_data(IO_handle%fileobj, trim(field_md%name), field, unlim_dim_level=time_index) + elseif (IO_handle%FMS2_file) then + call write_data(IO_handle%fileobj, trim(field_md%name), field) + else + call mpp_write(IO_handle%unit, field_md%FT, field, tstamp=tstamp) + endif end subroutine write_field_0d +!> Returns the integer time index for a write in this file, also writing the time variable to +!! the file if this time is later than what is already in the file. +integer function write_time_if_later(IO_handle, field_time) + type(file_type), intent(inout) :: IO_handle !< Handle for a file that is open for writing + real, intent(in) :: field_time !< Model time of this field + + ! Local variables + character(len=256) :: dim_unlim_name ! name of the unlimited dimension in the file + + if ((field_time > IO_handle%file_time) .or. (IO_handle%num_times == 0)) then + IO_handle%file_time = field_time + IO_handle%num_times = IO_handle%num_times + 1 + if (IO_handle%FMS2_file) then + call get_unlimited_dimension_name(IO_handle%fileobj, dim_unlim_name) + call write_data(IO_handle%fileobj, trim(dim_unlim_name), (/field_time/), & + corner=(/IO_handle%num_times/), edge_lengths=(/1/)) + endif + endif + + write_time_if_later = IO_handle%num_times +end function write_time_if_later + !> Write the data for an axis subroutine MOM_write_axis(IO_handle, axis) type(file_type), intent(in) :: IO_handle !< Handle for a file that is open for writing type(axistype), intent(in) :: axis !< An axis type variable with information to write - call mpp_write(IO_handle%unit, axis) + if (IO_handle%FMS2_file) then + call write_data(IO_handle%fileobj, trim(axis%name), axis%ax_data) + else + call mpp_write(IO_handle%unit, axis%AT) + endif end subroutine MOM_write_axis @@ -963,26 +1256,80 @@ subroutine write_metadata_axis(IO_handle, axis, name, units, longname, cartesian logical, optional, intent(in) :: edge_axis !< If true, this axis marks an edge of the tracer cells character(len=*), optional, intent(in) :: calendar !< The name of the calendar used with a time axis - call mpp_write_meta(IO_handle%unit, axis, name, units, longname, cartesian=cartesian, sense=sense, & - domain=domain, data=data, calendar=calendar) + character(len=:), allocatable :: cart ! A left-adjusted and trimmed copy of cartesian + logical :: is_x, is_y, is_t ! If true, this is a domain-decomposed axis in one of the directions. + integer :: position ! A flag indicating the axis staggering position. + + if (IO_handle%FMS2_file) then + if (is_dimension_registered(IO_handle%fileobj, trim(name))) then + call MOM_error(FATAL, "write_metadata_axis was called more than once for axis "//trim(name)//& + " in file "//trim(IO_handle%filename)) + return + endif + endif + + axis%name = trim(name) + if (present(data)) then + if (allocated(axis%ax_data)) call MOM_error(FATAL, & + "Data is already allocated in a call to write_metadata_axis for axis "//& + trim(name)//" in file "//trim(IO_handle%filename)) + allocate(axis%ax_data(size(data))) ; axis%ax_data(:) = data(:) + endif + + if (IO_handle%FMS2_file) then + is_x = .false. ; is_y = .false. ; is_t = .false. + position = CENTER + if (present(cartesian)) then + cart = trim(adjustl(cartesian)) + if ((index(cart, "X") == 1) .or. (index(cart, "x") == 1)) is_x = .true. + if ((index(cart, "Y") == 1) .or. (index(cart, "y") == 1)) is_y = .true. + if ((index(cart, "T") == 1) .or. (index(cart, "t") == 1)) is_t = .true. + endif + + if (is_x) then + if (present(edge_axis)) then ; if (edge_axis) position = EAST_FACE ; endif + call register_axis(IO_handle%fileobj, trim(name), 'x', domain_position=position) + elseif (is_y) then + if (present(edge_axis)) then ; if (edge_axis) position = NORTH_FACE ; endif + call register_axis(IO_handle%fileobj, trim(name), 'y', domain_position=position) + elseif (is_t .and. .not.present(data)) then + ! This is the unlimited (time) dimension. + call register_axis(IO_handle%fileobj, trim(name), unlimited) + else + if (.not.present(data)) call MOM_error(FATAL,"MOM_io:register_diagnostic_axis: "//& + "An axis_length argument is required to register the axis "//trim(name)) + call register_axis(IO_handle%fileobj, trim(name), size(data)) + endif + + ! Now create the variable that describes this axis. + call register_field(IO_handle%fileobj, trim(name), "double", dimensions=(/name/)) + if (len_trim(units) > 0) & + call register_variable_attribute(IO_handle%fileobj, trim(name), 'units', & + trim(units), len_trim(units)) + if (len_trim(longname) > 0) & + call register_variable_attribute(IO_handle%fileobj, trim(name), 'long_name', & + trim(longname), len_trim(longname)) + if (present(cartesian)) & + call register_variable_attribute(IO_handle%fileobj, trim(name), 'cartesian_axis', & + trim(cartesian), len_trim(cartesian)) + if (present(sense)) & + call register_variable_attribute(IO_handle%fileobj, trim(name), 'sense', sense) + else + call mpp_write_meta(IO_handle%unit, axis%AT, name, units, longname, cartesian=cartesian, sense=sense, & + domain=domain, data=data, calendar=calendar) + endif end subroutine write_metadata_axis !> Store information about an output variable in a previously defined fieldtype and write this !! information to the file indicated by unit. subroutine write_metadata_field(IO_handle, field, axes, name, units, longname, & - min, max, fill, scale, add, pack, standard_name, checksum) + pack, standard_name, checksum) type(file_type), intent(in) :: IO_handle !< Handle for a file that is open for writing type(fieldtype), intent(inout) :: field !< The fieldtype where this information is stored type(axistype), dimension(:), intent(in) :: axes !< Handles for the axis used for this variable character(len=*), intent(in) :: name !< The name in the file of this variable character(len=*), intent(in) :: units !< The units of this variable character(len=*), intent(in) :: longname !< The long description of this variable - real, optional, intent(in) :: min !< The minimum valid value for this variable - real, optional, intent(in) :: max !< The maximum valid value for this variable - real, optional, intent(in) :: fill !< Missing data fill value - real, optional, intent(in) :: scale !< An multiplicative factor by which to scale - !! the variable before output - real, optional, intent(in) :: add !< An offset to add to the variable before output integer, optional, intent(in) :: pack !< A precision reduction factor with which the !! variable. The default, 1, has no reduction, !! but 2 is not uncommon. @@ -990,9 +1337,46 @@ subroutine write_metadata_field(IO_handle, field, axes, name, units, longname, & integer(kind=int64), dimension(:), & optional, intent(in) :: checksum !< Checksum values that can be used to verify reads. + ! Local variables + character(len=256), dimension(size(axes)) :: dim_names ! The names of the dimensions + type(mpp_axistype), dimension(size(axes)) :: mpp_axes ! The array of mpp_axistypes for this variable + character(len=16) :: prec_string ! A string specifying the precision with which to save this variable + character(len=64) :: checksum_string ! checksum character array created from checksum argument + integer :: i, ndims + + ndims = size(axes) + if (IO_handle%FMS2_file) then + do i=1,ndims ; dim_names(i) = trim(axes(i)%name) ; enddo + prec_string = "double" ; if (present(pack)) then ; if (pack > 1) prec_string = "float" ; endif + call register_field(IO_handle%fileobj, trim(name), trim(prec_string), dimensions=dim_names) + if (len_trim(units) > 0) & + call register_variable_attribute(IO_handle%fileobj, trim(name), 'units', & + trim(units), len_trim(units)) + if (len_trim(longname) > 0) & + call register_variable_attribute(IO_handle%fileobj, trim(name), 'long_name', & + trim(longname), len_trim(longname)) + if (present(standard_name)) & + call register_variable_attribute(IO_handle%fileobj, trim(name), 'standard_name', & + trim(standard_name), len_trim(standard_name)) + if (present(checksum)) then + write (checksum_string,'(Z16)') checksum(1) ! Z16 is the hexadecimal format code + call register_variable_attribute(IO_handle%fileobj, trim(name), "checksum", & + trim(checksum_string), len_trim(checksum_string)) + endif + !### Add more attributes if they are present; remove attributes that are never used. + else + do i=1,ndims ; mpp_axes(i) = axes(i)%AT ; enddo + call mpp_write_meta(IO_handle%unit, field%FT, mpp_axes, name, units, longname, & + pack=pack, standard_name=standard_name, checksum=checksum) + ! unused opt. args: min=min, max=max, fill=fill, scale=scale, add=add, & + endif - call mpp_write_meta(IO_handle%unit, field, axes, name, units, longname, min=min, max=max, & - fill=fill, scale=scale, add=add, pack=pack, standard_name=standard_name, checksum=checksum) + ! Store information in the field-type, regardless of which interfaces are used. + field%name = trim(name) + field%longname = trim(longname) + field%units = trim(units) + field%chksum_read = -1 + field%valid_chksum = .false. end subroutine write_metadata_field From 03e174e1434b139c72ce53b6b53585953cb8d3aa Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 18 Mar 2021 18:52:15 -0400 Subject: [PATCH 022/112] Removed FMS2 MOM_axis and MOM_write_field_fms2 Deleted the unused MOM_axis.F90 and MOM_write_field_fms2.F90 modules, now that MOM_io_infra.F90 has been updated to be able to use FMS2 interfaces for both reading and writing to files. As these modules had never been used, they do not change any answers. --- config_src/infra/FMS2/MOM_axis.F90 | 616 ------- .../infra/FMS2/MOM_write_field_fms2.F90 | 1503 ----------------- 2 files changed, 2119 deletions(-) delete mode 100644 config_src/infra/FMS2/MOM_axis.F90 delete mode 100644 config_src/infra/FMS2/MOM_write_field_fms2.F90 diff --git a/config_src/infra/FMS2/MOM_axis.F90 b/config_src/infra/FMS2/MOM_axis.F90 deleted file mode 100644 index b5d2b3ed88..0000000000 --- a/config_src/infra/FMS2/MOM_axis.F90 +++ /dev/null @@ -1,616 +0,0 @@ -!> 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, position) - 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, optional, intent(in) :: position !< A flag indicating where this data is discretized - - ! Local variables - 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 :: pos ! Discrete variable position. 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.") - - ! 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) - - ! Get the lengths of the global indicies, using the discrete position of this variable - pos = CORNER ; if (present(position)) pos = position - 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, position) - 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, optional, intent(in) :: position !< A flag indicating where this data is discretized - - ! Local variables - 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(position)) then - if ((position == CORNER) .or. (position == EAST_FACE)) xpos = EAST_FACE - if ((position == CORNER) .or. (position == NORTH_FACE)) ypos = NORTH_FACE - endif - - ! 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/config_src/infra/FMS2/MOM_write_field_fms2.F90 b/config_src/infra/FMS2/MOM_write_field_fms2.F90 deleted file mode 100644 index 24ba5ebb50..0000000000 --- a/config_src/infra/FMS2/MOM_write_field_fms2.F90 +++ /dev/null @@ -1,1503 +0,0 @@ -!> 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_coms_infra, only : PE_here, root_PE, num_PEs -use MOM_domain_infra, only : MOM_domain_type -use MOM_domain_infra, only : domain2d, CENTER, CORNER, NORTH_FACE, EAST_FACE -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, append_substring -use MOM_verticalGrid, only : verticalGrid_type - -use netcdf, only : nf90_max_name -! 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 - -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, & - 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. - 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. - 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 - - 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") - ! 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, corner=start, edge_lengths=nwrite, & - unlim_dim_level=write_field_time_index) - else - call write_data(fileobj_write_field_dd, trim(fieldname), data, 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 - -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, & - 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. - 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. - 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 - - 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") - ! 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, corner=start, edge_lengths=nwrite, & - unlim_dim_level=write_field_time_index) - else - call write_data(fileobj_write_field_dd, trim(fieldname), data, 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 - -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, & - 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. - 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. - 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 - - ! 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") - ! 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, corner=start, edge_lengths=nwrite, & - unlim_dim_level=write_field_time_index) - else - call write_data(fileobj_write_field_dd, trim(fieldname), data, 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 - - -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, & - 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. - 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 :: 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 - - ! 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") - ! 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, corner=start, edge_lengths=nwrite, & - unlim_dim_level=write_field_time_index) - else - call write_data(fileobj_write_field_dd, trim(fieldname), data, 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 - -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(num_PEs())) - 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, & - 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. - 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 - 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 - - 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(num_PEs())) - 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, corner=start, edge_lengths=nwrite, & - unlim_dim_level=write_field_time_index) - else - call write_data(fileobj_write_field, trim(fieldname), data, 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 - - -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, & - 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. - 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. - 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 - - 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(num_PEs())) - 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, corner=start, edge_lengths=nwrite, & - unlim_dim_level=write_field_time_index) - else - call write_data(fileobj_write_field, trim(fieldname), data, 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 - -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, & - 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. - 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. - 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 - - ! 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(num_PEs())) - 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, corner=start, edge_lengths=nwrite, & - unlim_dim_level=write_field_time_index) - else - call write_data(fileobj_write_field, trim(fieldname), data, 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 - -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, & - 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. - 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. - 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 - - ! 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(num_PEs())) - 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, corner=start, edge_lengths=nwrite, & - unlim_dim_level=write_field_time_index) - else - call write_data(fileobj_write_field, trim(fieldname), data, 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 -end subroutine write_field_4d_nodd - -end module MOM_write_field_fms2 From 84d5e217653047eab320fce54a02ad6afcfc260a Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 19 Mar 2021 12:43:03 -0400 Subject: [PATCH 023/112] +FMS2 reads for ints & MOM_read_data_fms2 cleanup Added variants of MOM_read_data_0d, MOM_read_data_0d_int, MOM_read_data_1d, MOM_read_data_1d_int, and MOM_read_data_2d_region that use the FMS2 interfaces to read data. Also altered prepare_to_read_var so that it does not open a file (which had been an option before); one argument to prepare_to_read_var was no longer needed and so it was removed. Also added a public interface to find_varname_in_file that does the same as prepare_to_read_var but works on the other FMS2 file type without domain decomposition. Several unused and now redundant routines were removed from MOM_read_data_fms2.F90. Comments describing a number of variables were also added. All of these changes are confined to config_src/infra/FMS2, and all answers are bitwise identical. --- config_src/infra/FMS2/MOM_io_infra.F90 | 227 ++++++++++--- config_src/infra/FMS2/MOM_read_data_fms2.F90 | 335 +++++-------------- 2 files changed, 254 insertions(+), 308 deletions(-) diff --git a/config_src/infra/FMS2/MOM_io_infra.F90 b/config_src/infra/FMS2/MOM_io_infra.F90 index d4fe0b5387..c545462ad8 100644 --- a/config_src/infra/FMS2/MOM_io_infra.F90 +++ b/config_src/infra/FMS2/MOM_io_infra.F90 @@ -6,8 +6,8 @@ module MOM_io_infra use MOM_domain_infra, only : MOM_domain_type, rescale_comp_data, AGRID, BGRID_NE, CGRID_NE use MOM_domain_infra, only : domain2d, domain1d, CENTER, CORNER, NORTH_FACE, EAST_FACE use MOM_error_infra, only : MOM_error=>MOM_err, NOTE, FATAL, WARNING +use MOM_read_data_fms2, only : prepare_to_read_var, find_varname_in_file -use MOM_read_data_fms2, only : prepare_to_read_var use fms2_io_mod, only : fms2_open_file => open_file, check_if_open, fms2_close_file => close_file use fms2_io_mod, only : FmsNetcdfDomainFile_t, FmsNetcdfFile_t, fms2_read_data => read_data use fms2_io_mod, only : get_unlimited_dimension_name, get_num_dimensions, get_num_variables @@ -41,9 +41,9 @@ module MOM_io_infra public :: MOM_read_data, MOM_read_vector, write_metadata, write_field public :: field_exists, get_field_atts, get_field_size, get_axis_data, read_field_chksum public :: io_infra_init, io_infra_end, MOM_namelist_file, check_namelist_error, write_version -! These types are inherited from underlying infrastructure code, to act as containers for -! information about fields and axes, respectively, and are opaque to this module. -! public :: file_type, fieldtype, axistype +! These types act as containers for information about files, fields and axes, respectively, +! and may also wrap opaque types from the underlying infrastructure. +public :: file_type, fieldtype, axistype ! These are encoding constant parmeters. public :: ASCII_FILE, NETCDF_FILE, SINGLE_FILE, MULTIPLE public :: APPEND_FILE, READONLY_FILE, OVERWRITE_FILE, WRITEONLY_FILE @@ -102,7 +102,7 @@ module MOM_io_infra end interface flush_file !> Type for holding a handle to an open file and related information -type, public :: file_type ; private +type :: file_type ; private integer :: unit = -1 !< The framework identfier or netCDF unit number of an output file type(FmsNetcdfDomainFile_t), pointer :: fileobj => NULL() !< A domain-decomposed !! file object that is open for writing @@ -115,7 +115,7 @@ module MOM_io_infra end type file_type !> This type is a container for information about a variable in a file. -type, public :: fieldtype ; private +type :: fieldtype ; private character(len=256) :: name !< The name of this field in the files. type(mpp_fieldtype) :: FT !< The FMS1 field-type that this type wraps character(len=:), allocatable :: longname !< The long name for this field @@ -126,14 +126,14 @@ module MOM_io_infra end type fieldtype !> This type is a container for information about an axis in a file. -type, public :: axistype ; private +type :: axistype ; private character(len=256) :: name !< The name of this axis in the files. type(mpp_axistype) :: AT !< The FMS1 axis-type that this type wraps real, allocatable, dimension(:) :: ax_data !< The values of the data on the axis. end type axistype -!> For now, this is hard-coded to exercise the new FMS2 interfaces. -logical :: FMS2_reads = .true. +!> For now, these module-variables are hard-coded to exercise the new FMS2 interfaces. +logical :: FMS2_reads = .true. logical :: FMS2_writes = .true. contains @@ -353,8 +353,7 @@ subroutine open_file_type(IO_handle, filename, action, MOM_domain, threading, fi call fms2_close_file(fileObj_read) endif - success = fms2_open_file(IO_handle%fileobj, trim(filename), trim(mode), & - MOM_domain%mpp_domain, is_restart=.false.) + success = fms2_open_file(IO_handle%fileobj, trim(filename), trim(mode), MOM_domain%mpp_domain) if (.not.success) call MOM_error(FATAL, "Unable to open file "//trim(filename)) IO_handle%FMS2_file = .true. elseif (present(MOM_Domain)) then @@ -442,7 +441,8 @@ subroutine get_file_times(IO_handle, time_values, ntime) integer, optional, intent(out) :: ntime !< The number of time levels in the file character(len=256) :: dim_unlim_name ! name of the unlimited dimension in the file - integer :: ntimes + integer :: ntimes ! The number of time levels in the file + !### Modify this routine to optionally convert to time_type, using information about the dimensions? if (allocated(time_values)) deallocate(time_values) @@ -465,12 +465,13 @@ subroutine get_file_fields(IO_handle, fields) type(file_type), intent(in) :: IO_handle !< Handle for a file that is open for I/O type(fieldtype), dimension(:), intent(inout) :: fields !< Field-type descriptions of all of !! the variables in a file. - type(mpp_fieldtype), dimension(size(fields)) :: mpp_fields - character(len=256), dimension(size(fields)) :: var_names - character(len=256) :: units - character(len=2048) :: longname - integer(kind=int64), dimension(3) :: checksum_file - integer :: i, nvar + type(mpp_fieldtype), dimension(size(fields)) :: mpp_fields ! Fieldtype structures for the variables + character(len=256), dimension(size(fields)) :: var_names ! The names of all variables + character(len=256) :: units ! The units of a variable as recorded in the file + character(len=2048) :: longname ! The long-name of a variable as recorded in the file + integer(kind=int64), dimension(3) :: checksum_file ! The checksums for a variable in the file + integer :: nvar ! The number of variables in the file + integer :: i nvar = size(fields) ! Local variables @@ -647,20 +648,40 @@ subroutine MOM_read_data_0d(filename, fieldname, data, timelevel, scale, MOM_Dom optional, intent(in) :: MOM_Domain !< The MOM_Domain that describes the decomposition ! Local variables - type(FmsNetcdfDomainFile_t) :: fileobj ! A handle to a domain-decomposed file object - logical :: has_time_dim ! True if the variable has an unlimited time axis. + type(FmsNetcdfFile_t) :: fileObj ! A handle to a non-domain-decomposed file + type(FmsNetcdfDomainFile_t) :: fileobj_DD ! A handle to a domain-decomposed file object character(len=96) :: var_to_read ! Name of variable to read from the netcdf file - logical :: success ! True if the file was successfully opened + logical :: has_time_dim ! True if the variable has an unlimited time axis. + logical :: success ! True if the file was successfully opened if (present(MOM_Domain) .and. FMS2_reads) then ! Open the FMS2 file-set. - success = fms2_open_file(fileobj, filename, "read", MOM_domain%mpp_domain, is_restart=.false.) + success = fms2_open_file(fileobj_DD, filename, "read", MOM_domain%mpp_domain) if (.not.success) call MOM_error(FATAL, "Failed to open "//trim(filename)) ! Find the matching case-insensitive variable name in the file and prepare to read it. - call prepare_to_read_var(fileobj, fieldname, MOM_domain, "MOM_read_data_1d: ", filename, & + call prepare_to_read_var(fileobj_DD, fieldname, "MOM_read_data_0d: ", filename, & var_to_read, has_time_dim, timelevel) + ! Read the data. + if (present(timelevel) .and. has_time_dim) then + call fms2_read_data(fileobj_DD, var_to_read, data, unlim_dim_level=timelevel) + else + call fms2_read_data(fileobj_DD, var_to_read, data) + endif + + ! Close the file-set. + if (check_if_open(fileobj_DD)) call fms2_close_file(fileobj_DD) + elseif (FMS2_reads) then + ! Open the FMS2 file-set. + success = fms2_open_file(fileObj, trim(filename), "read") + if (.not.success) call MOM_error(FATAL, "Failed to open "//trim(filename)) + + ! Find the matching case-insensitive variable name in the file, and determine whether it + ! has a time dimension. + call find_varname_in_file(fileObj, fieldname, "MOM_read_data_0d: ", filename, & + var_to_read, has_time_dim, timelevel) + ! Read the data. if (present(timelevel) .and. has_time_dim) then call fms2_read_data(fileobj, var_to_read, data, unlim_dim_level=timelevel) @@ -695,20 +716,40 @@ subroutine MOM_read_data_1d(filename, fieldname, data, timelevel, scale, MOM_Dom optional, intent(in) :: MOM_Domain !< The MOM_Domain that describes the decomposition ! Local variables - type(FmsNetcdfDomainFile_t) :: fileobj ! A handle to a domain-decomposed file object - logical :: has_time_dim ! True if the variable has an unlimited time axis. + type(FmsNetcdfFile_t) :: fileObj ! A handle to a non-domain-decomposed file + type(FmsNetcdfDomainFile_t) :: fileobj_DD ! A handle to a domain-decomposed file object character(len=96) :: var_to_read ! Name of variable to read from the netcdf file - logical :: success ! True if the file was successfully opened + logical :: has_time_dim ! True if the variable has an unlimited time axis. + logical :: success ! True if the file was successfully opened if (present(MOM_Domain) .and. FMS2_reads) then ! Open the FMS2 file-set. - success = fms2_open_file(fileobj, filename, "read", MOM_domain%mpp_domain, is_restart=.false.) + success = fms2_open_file(fileobj_DD, filename, "read", MOM_domain%mpp_domain) if (.not.success) call MOM_error(FATAL, "Failed to open "//trim(filename)) ! Find the matching case-insensitive variable name in the file and prepare to read it. - call prepare_to_read_var(fileobj, fieldname, MOM_domain, "MOM_read_data_1d: ", filename, & + call prepare_to_read_var(fileobj_DD, fieldname, "MOM_read_data_1d: ", filename, & var_to_read, has_time_dim, timelevel) + ! Read the data. + if (present(timelevel) .and. has_time_dim) then + call fms2_read_data(fileobj_DD, var_to_read, data, unlim_dim_level=timelevel) + else + call fms2_read_data(fileobj_DD, var_to_read, data) + endif + + ! Close the file-set. + if (check_if_open(fileobj_DD)) call fms2_close_file(fileobj_DD) + elseif (FMS2_reads) then + ! Open the FMS2 file-set. + success = fms2_open_file(fileObj, trim(filename), "read") + if (.not.success) call MOM_error(FATAL, "Failed to open "//trim(filename)) + + ! Find the matching case-insensitive variable name in the file, and determine whether it + ! has a time dimension. + call find_varname_in_file(fileObj, fieldname, "MOM_read_data_1d: ", filename, & + var_to_read, has_time_dim, timelevel) + ! Read the data. if (present(timelevel) .and. has_time_dim) then call fms2_read_data(fileobj, var_to_read, data, unlim_dim_level=timelevel) @@ -747,17 +788,17 @@ subroutine MOM_read_data_2d(filename, fieldname, data, MOM_Domain, & ! Local variables type(FmsNetcdfDomainFile_t) :: fileobj ! A handle to a domain-decomposed file object - logical :: has_time_dim ! True if the variable has an unlimited time axis. character(len=96) :: var_to_read ! Name of variable to read from the netcdf file - logical :: success ! True if the file was successfully opened + logical :: has_time_dim ! True if the variable has an unlimited time axis. + logical :: success ! True if the file was successfully opened if (FMS2_reads) then ! Open the FMS2 file-set. - success = fms2_open_file(fileobj, filename, "read", MOM_domain%mpp_domain, is_restart=.false.) + success = fms2_open_file(fileobj, filename, "read", MOM_domain%mpp_domain) if (.not.success) call MOM_error(FATAL, "Failed to open "//trim(filename)) ! Find the matching case-insensitive variable name in the file and prepare to read it. - call prepare_to_read_var(fileobj, fieldname, MOM_domain, "MOM_read_data_2d: ", filename, & + call prepare_to_read_var(fileobj, fieldname, "MOM_read_data_2d: ", filename, & var_to_read, has_time_dim, timelevel, position) ! Read the data. @@ -801,9 +842,41 @@ subroutine MOM_read_data_2d_region(filename, fieldname, data, start, nread, MOM_ real, optional, intent(in) :: scale !< A scaling factor that the field is multiplied !! by before it is returned. - !### This subroutine does not have an FMS-2 variant yet. + ! Local variables + type(FmsNetcdfFile_t) :: fileObj ! A handle to a non-domain-decomposed file + type(FmsNetcdfDomainFile_t) :: fileobj_DD ! A handle to a domain-decomposed file object + character(len=96) :: var_to_read ! Name of variable to read from the netcdf file + logical :: success ! True if the file was successfully opened - if (present(MOM_Domain)) then + if (present(MOM_Domain) .and. FMS2_reads) then + ! Open the FMS2 file-set. + success = fms2_open_file(fileobj_DD, filename, "read", MOM_domain%mpp_domain) + if (.not.success) call MOM_error(FATAL, "Failed to open "//trim(filename)) + + ! Find the matching case-insensitive variable name in the file and prepare to read it. + call prepare_to_read_var(fileobj_DD, fieldname, "MOM_read_data_2d_region: ", & + filename, var_to_read) + + ! Read the data. + call fms2_read_data(fileobj_DD, var_to_read, data, corner=start(1:2), edge_lengths=nread(1:2)) + + ! Close the file-set. + if (check_if_open(fileobj_DD)) call fms2_close_file(fileobj_DD) + elseif (FMS2_reads) then + ! Open the FMS2 file-set. + success = fms2_open_file(fileObj, trim(filename), "read") + if (.not.success) call MOM_error(FATAL, "Failed to open "//trim(filename)) + + ! Find the matching case-insensitive variable name in the file, and determine whether it + ! has a time dimension. + call find_varname_in_file(fileObj, fieldname, "MOM_read_data_2d_region: ", filename, var_to_read) + + ! Read the data. + call fms2_read_data(fileobj, var_to_read, data, corner=start(1:2), edge_lengths=nread(1:2)) + + ! Close the file-set. + if (check_if_open(fileobj)) call fms2_close_file(fileobj) + elseif (present(MOM_Domain)) then ! Read the variable using the FMS-1 interface. call read_data(filename, fieldname, data, start, nread, domain=MOM_Domain%mpp_domain, & no_domain=no_domain) else @@ -838,17 +911,17 @@ subroutine MOM_read_data_3d(filename, fieldname, data, MOM_Domain, & ! Local variables type(FmsNetcdfDomainFile_t) :: fileobj ! A handle to a domain-decomposed file object - logical :: has_time_dim ! True if the variable has an unlimited time axis. character(len=96) :: var_to_read ! Name of variable to read from the netcdf file - logical :: success ! True if the file was successfully opened + logical :: has_time_dim ! True if the variable has an unlimited time axis. + logical :: success ! True if the file was successfully opened if (FMS2_reads) then ! Open the FMS2 file-set. - success = fms2_open_file(fileobj, filename, "read", MOM_domain%mpp_domain, is_restart=.false.) + success = fms2_open_file(fileobj, filename, "read", MOM_domain%mpp_domain) if (.not.success) call MOM_error(FATAL, "Failed to open "//trim(filename)) ! Find the matching case-insensitive variable name in the file and prepare to read it. - call prepare_to_read_var(fileobj, fieldname, MOM_domain, "MOM_read_data_3d: ", filename, & + call prepare_to_read_var(fileobj, fieldname, "MOM_read_data_3d: ", filename, & var_to_read, has_time_dim, timelevel, position) ! Read the data. @@ -895,11 +968,11 @@ subroutine MOM_read_data_4d(filename, fieldname, data, MOM_Domain, & if (FMS2_reads) then ! Open the FMS2 file-set. - success = fms2_open_file(fileobj, filename, "read", MOM_domain%mpp_domain, is_restart=.false.) + success = fms2_open_file(fileobj, filename, "read", MOM_domain%mpp_domain) if (.not.success) call MOM_error(FATAL, "Failed to open "//trim(filename)) ! Find the matching case-insensitive variable name in the file and prepare to read it. - call prepare_to_read_var(fileobj, fieldname, MOM_domain, "MOM_read_data_4d: ", filename, & + call prepare_to_read_var(fileobj, fieldname, "MOM_read_data_4d: ", filename, & var_to_read, has_time_dim, timelevel, position) ! Read the data. @@ -930,8 +1003,34 @@ subroutine MOM_read_data_0d_int(filename, fieldname, data, timelevel) integer, intent(inout) :: data !< The 1-dimensional array into which the data integer, optional, intent(in) :: timelevel !< The time level in the file to read - !### This needs an FMS2 variant, eventually. - call read_data(filename, fieldname, data, timelevel=timelevel, no_domain=.true.) + ! Local variables + type(FmsNetcdfFile_t) :: fileObj ! A handle to a non-domain-decomposed file + logical :: has_time_dim ! True if the variable has an unlimited time axis. + character(len=96) :: var_to_read ! Name of variable to read from the netcdf file + logical :: success ! If true, the file was opened successfully + + if (FMS2_reads) then + ! Open the FMS2 file-set. + success = fms2_open_file(fileObj, trim(filename), "read") + if (.not.success) call MOM_error(FATAL, "Failed to open "//trim(filename)) + + ! Find the matching case-insensitive variable name in the file, and determine whether it + ! has a time dimension. + call find_varname_in_file(fileObj, fieldname, "MOM_read_data_0d_int: ", filename, & + var_to_read, has_time_dim, timelevel) + + ! Read the data. + if (present(timelevel) .and. has_time_dim) then + call fms2_read_data(fileobj, var_to_read, data, unlim_dim_level=timelevel) + else + call fms2_read_data(fileobj, var_to_read, data) + endif + + ! Close the file-set. + if (check_if_open(fileobj)) call fms2_close_file(fileobj) + else + call read_data(filename, fieldname, data, timelevel=timelevel, no_domain=.true.) + endif end subroutine MOM_read_data_0d_int @@ -943,8 +1042,35 @@ subroutine MOM_read_data_1d_int(filename, fieldname, data, timelevel) integer, dimension(:), intent(inout) :: data !< The 1-dimensional array into which the data integer, optional, intent(in) :: timelevel !< The time level in the file to read - !### This needs an FMS2 variant, eventually. - call read_data(filename, fieldname, data, timelevel=timelevel, no_domain=.true.) + ! Local variables + type(FmsNetcdfFile_t) :: fileObj ! A handle to a non-domain-decomposed file for obtaining information + ! about the exiting time axis entries in append mode. + logical :: has_time_dim ! True if the variable has an unlimited time axis. + character(len=96) :: var_to_read ! Name of variable to read from the netcdf file + logical :: success ! If true, the file was opened successfully + + if (FMS2_reads) then + ! Open the FMS2 file-set. + success = fms2_open_file(fileObj, trim(filename), "read") + if (.not.success) call MOM_error(FATAL, "Failed to open "//trim(filename)) + + ! Find the matching case-insensitive variable name in the file, and determine whether it + ! has a time dimension. + call find_varname_in_file(fileObj, fieldname, "MOM_read_data_1d_int: ", filename, & + var_to_read, has_time_dim, timelevel) + + ! Read the data. + if (present(timelevel) .and. has_time_dim) then + call fms2_read_data(fileobj, var_to_read, data, unlim_dim_level=timelevel) + else + call fms2_read_data(fileobj, var_to_read, data) + endif + + ! Close the file-set. + if (check_if_open(fileobj)) call fms2_close_file(fileobj) + else + call read_data(filename, fieldname, data, timelevel=timelevel, no_domain=.true.) + endif end subroutine MOM_read_data_1d_int @@ -983,13 +1109,13 @@ subroutine MOM_read_vector_2d(filename, u_fieldname, v_fieldname, u_data, v_data if (FMS2_reads) then ! Open the FMS2 file-set. - success = fms2_open_file(fileobj, filename, "read", MOM_domain%mpp_domain, is_restart=.false.) + success = fms2_open_file(fileobj, filename, "read", MOM_domain%mpp_domain) if (.not.success) call MOM_error(FATAL, "Failed to open "//trim(filename)) ! Find the matching case-insensitive u- and v-variable names in the file and prepare to read them. - call prepare_to_read_var(fileobj, u_fieldname, MOM_domain, "MOM_read_vector_2d: ", filename, & + call prepare_to_read_var(fileobj, u_fieldname, "MOM_read_vector_2d: ", filename, & u_var, has_time_dim, timelevel, position=u_pos) - call prepare_to_read_var(fileobj, v_fieldname, MOM_domain, "MOM_read_vector_2d: ", filename, & + call prepare_to_read_var(fileobj, v_fieldname, "MOM_read_vector_2d: ", filename, & v_var, has_time_dim, timelevel, position=v_pos) ! Read the u-data and v-data. There would already been an error message for one @@ -1053,13 +1179,13 @@ subroutine MOM_read_vector_3d(filename, u_fieldname, v_fieldname, u_data, v_data if (FMS2_reads) then ! Open the FMS2 file-set. - success = fms2_open_file(fileobj, filename, "read", MOM_domain%mpp_domain, is_restart=.false.) + success = fms2_open_file(fileobj, filename, "read", MOM_domain%mpp_domain) if (.not.success) call MOM_error(FATAL, "Failed to open "//trim(filename)) ! Find the matching case-insensitive u- and v-variable names in the file and prepare to read them. - call prepare_to_read_var(fileobj, u_fieldname, MOM_domain, "MOM_read_vector_3d: ", filename, & + call prepare_to_read_var(fileobj, u_fieldname, "MOM_read_vector_3d: ", filename, & u_var, has_time_dim, timelevel, position=u_pos) - call prepare_to_read_var(fileobj, v_fieldname, MOM_domain, "MOM_read_vector_3d: ", filename, & + call prepare_to_read_var(fileobj, v_fieldname, "MOM_read_vector_3d: ", filename, & v_var, has_time_dim, timelevel, position=v_pos) ! Read the u-data and v-data, dangerously assuming either both or neither have time dimensions. @@ -1363,7 +1489,6 @@ subroutine write_metadata_field(IO_handle, field, axes, name, units, longname, & call register_variable_attribute(IO_handle%fileobj, trim(name), "checksum", & trim(checksum_string), len_trim(checksum_string)) endif - !### Add more attributes if they are present; remove attributes that are never used. else do i=1,ndims ; mpp_axes(i) = axes(i)%AT ; enddo call mpp_write_meta(IO_handle%unit, field%FT, mpp_axes, name, units, longname, & diff --git a/config_src/infra/FMS2/MOM_read_data_fms2.F90 b/config_src/infra/FMS2/MOM_read_data_fms2.F90 index 4732c019f4..c632e95177 100644 --- a/config_src/infra/FMS2/MOM_read_data_fms2.F90 +++ b/config_src/infra/FMS2/MOM_read_data_fms2.F90 @@ -1,36 +1,31 @@ -!> This module contains routines that wrap the fms2 read_data calls +!> This module contains routines that encapsulate common preparatory work for FMS2 read_data calls module MOM_read_data_fms2 ! This file is part of MOM6. See LICENSE.md for the license. use MOM_error_infra, only : MOM_error=>MOM_err, NOTE, FATAL, WARNING, is_root_PE -use MOM_domain_infra, only : MOM_domain_type, AGRID, BGRID_NE, CGRID_NE -use MOM_domain_infra, only : domain2d, CENTER, CORNER, NORTH_FACE, EAST_FACE +use MOM_domain_infra, only : CENTER, CORNER, NORTH_FACE, EAST_FACE use MOM_string_functions, only : lowercase -use fms2_io_mod, only : FmsNetcdfDomainFile_t, FmsNetcdfFile_t -use fms2_io_mod, only : fms2_open_file => open_file, fms2_close_file => close_file -use fms2_io_mod, only : get_num_variables, get_variable_names, check_if_open -use fms2_io_mod, only : read_data, variable_exists, get_variable_size, get_variable_units -use fms2_io_mod, only : get_variable_attribute, attribute_exists => variable_att_exists +use fms2_io_mod, only : FmsNetcdfDomainFile_t, FmsNetcdfFile_t, check_if_open +use fms2_io_mod, only : variable_exists, get_num_variables, get_variable_names +use fms2_io_mod, only : get_variable_size, get_variable_units +use fms2_io_mod, only : get_variable_attribute, variable_att_exists use fms2_io_mod, only : get_variable_num_dimensions, get_variable_dimension_names use fms2_io_mod, only : is_dimension_unlimited, get_dimension_size use fms2_io_mod, only : is_dimension_registered, register_axis implicit none ; private -public prepare_to_read_var -! public MOM_read_data_scalar, MOM_read_data_2d_noDD, MOM_read_data_1d_noDD +public prepare_to_read_var, find_varname_in_file contains -!> Find the case-insensitive name match with a variable in a domain-decomposed file-set -!! opening the file(s) as necessary, prepare FMS2 to read this variable, and return some -!! information needed to call read_data correctly for this variable and file. -subroutine prepare_to_read_var(fileobj, fieldname, domain, err_header, filename, var_to_read, & +!> Find the case-insensitive name match with a variable in an open domain-decomposed file-set, +!! prepare FMS2 to read this variable, and return some information needed to call fms2_read_data +!! correctly for this variable and file. +subroutine prepare_to_read_var(fileobj, fieldname, err_header, filename, var_to_read, & has_time_dim, timelevel, position) - type(FmsNetcdfDomainFile_t), intent(inout) :: fileobj !< A handle to an FMS2 file object, that - !! will be opened if necessary + type(FmsNetcdfDomainFile_t), intent(inout) :: fileobj !< An FMS2 handle to an open domain-decomposed file character(len=*), intent(in) :: fieldname !< The variable name to seek in the file - type(MOM_domain_type), intent(in) :: domain !< MOM domain attribute with the mpp_domain decomposition character(len=*), intent(in) :: err_header !< A descriptive prefix for error messages character(len=*), intent(in) :: filename !< The name of the file to read character(len=*), intent(out) :: var_to_read !< The variable name to read from the file @@ -39,33 +34,30 @@ subroutine prepare_to_read_var(fileobj, fieldname, domain, err_header, filename, integer, optional, intent(in) :: position !< A flag indicating where this variable is discretized ! Local variables - logical :: file_open_success !.true. if call to open_file is successful logical :: variable_found ! Is a case-insensitive version of the variable found in the netCDF file? - character(len=96), allocatable, dimension(:) :: var_names !< array for names of variables in a netCDF - !! file opened to read - character(len=96), allocatable :: dim_names(:) ! variable dimension names - integer :: nvars ! The number of variables in the file. - integer :: i, dim_unlim_size, num_var_dims, time_dim + character(len=256), allocatable, dimension(:) :: var_names ! The names of all the variables in the netCDF file + character(len=256), allocatable :: dim_names(:) ! The names of a variable's dimensions + integer :: nvars ! The number of variables in the file. + integer :: dim_unlim_size ! The current size of the unlimited (time) dimension in the file. + integer :: num_var_dims ! The number of dimensions a variable has in the file. + integer :: time_dim ! The position of the unlimited (time) dimension for a variable, or -1 + ! if it has no unlimited dimension. + integer :: i ! Open the file if necessary - if (.not.(check_if_open(fileobj))) then - file_open_success = fms2_open_file(fileobj, filename, "read", domain%mpp_domain, is_restart=.false.) - if (.not.file_open_success) call MOM_error(FATAL, trim(err_header)//" failed to open "//trim(filename)) - endif + if (.not.check_if_open(fileobj)) & + call MOM_error(FATAL, trim(err_header)//trim(filename)//" was not open in call to prepare_to_read_var.") ! Search for the variable in the file, looking for the case-sensitive name first. if (variable_exists(fileobj, trim(fieldname))) then var_to_read = trim(fieldname) - variable_found = .true. else ! Look for case-insensitive variable name matches. - var_to_read = "" - variable_found = .false. - nvars = get_num_variables(fileobj) if (nvars < 1) call MOM_error(FATAL, "nvars is less than 1 for file "//trim(filename)) allocate(var_names(nvars)) call get_variable_names(fileobj, var_names) + variable_found = .false. do i=1,nvars if (lowercase(trim(var_names(i))) == lowercase(trim(fieldname))) then variable_found = .true. @@ -116,8 +108,6 @@ subroutine prepare_to_read_var(fileobj, fieldname, domain, err_header, filename, end subroutine prepare_to_read_var !> 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(fileObj, variableName, filename, position) type(FmsNetcdfDomainFile_t), intent(inout) :: fileObj !< Handle to an open FMS2 netCDF file object character(len=*), intent(in) :: variableName !< name of the variable @@ -125,19 +115,15 @@ subroutine MOM_register_variable_axes(fileObj, variableName, filename, position) integer, optional, intent(in) :: position !< A flag indicating where this data is discretized ! Local variables - character(len=40) :: units ! units corresponding to a specific variable dimension - character(len=40), allocatable, dimension(:) :: dim_names ! variable dimension names + character(len=256), allocatable, dimension(:) :: dim_names ! variable dimension names integer, allocatable, dimension(:) :: dimSizes ! variable dimension sizes logical, allocatable, dimension(:) :: is_x ! Is this a (likely domain-decomposed) x-axis logical, allocatable, dimension(:) :: is_y ! Is this a (likely domain-decomposed) y-axis logical, allocatable, dimension(:) :: is_t ! Is this a time axis or another unlimited axis integer :: ndims ! number of dimensions + integer :: xPos, yPos ! Discrete positions for x and y axes. Default is CENTER integer :: i - integer :: xPos, yPos ! domain positions for x and y axes. Default is CENTER - 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(position)) then if ((position == CORNER) .or. (position == EAST_FACE)) xPos = EAST_FACE @@ -168,9 +154,7 @@ subroutine MOM_register_variable_axes(fileObj, variableName, filename, position) endif enddo - deallocate(dimSizes) - deallocate(dim_names) - deallocate(is_x, is_y, is_t) + deallocate(dimSizes, dim_names, is_x, is_y, is_t) end subroutine MOM_register_variable_axes !> Determine whether a variable's axes are associated with x-, y- or time-dimensions. Other @@ -184,11 +168,12 @@ subroutine categorize_axes(fileObj, filename, ndims, dim_names, is_x, is_y, is_t logical, dimension(ndims), intent(out) :: is_y !< Indicates if each dimension a (likely decomposed) y-axis logical, dimension(ndims), intent(out) :: is_t !< Indicates if each dimension unlimited (usually time) axis - integer :: i - character(len=256) :: cartesian ! A flag indicating a Cartesian direction - usually a single character. + ! Local variables + character(len=128) :: cartesian ! A flag indicating a Cartesian direction - usually a single character. character(len=512) :: dim_list ! A concatenated list of dimension names. - character(len=40) :: units ! units corresponding to a specific variable dimension + character(len=128) :: units ! units corresponding to a specific variable dimension logical :: x_found, y_found ! Indicate whether an x- or y- dimension have been found. + integer :: i x_found = .false. ; y_found = .false. is_x(:) = .false. ; is_y(:) = .false. @@ -197,16 +182,12 @@ subroutine categorize_axes(fileObj, filename, ndims, dim_names, is_x, is_y, is_t ! First look for indicative variable attributes if (.not.is_t(i)) then if (variable_exists(fileobj, trim(dim_names(i)))) then - if (attribute_exists(fileobj, trim(dim_names(i)), "cartesian_axis")) then + if (variable_att_exists(fileobj, trim(dim_names(i)), "cartesian_axis")) then call get_variable_attribute(fileobj, trim(dim_names(i)), "cartesian_axis", cartesian) cartesian = adjustl(cartesian) if ((index(cartesian, "X") == 1) .or. (index(cartesian, "x") == 1)) is_x(i) = .true. if ((index(cartesian, "Y") == 1) .or. (index(cartesian, "y") == 1)) is_y(i) = .true. if ((index(cartesian, "T") == 1) .or. (index(cartesian, "t") == 1)) is_t(i) = .true. - ! if (is_root_pe() .and. is_x(i)) & - ! call MOM_error(NOTE, "X-dimension determined from cartesian_axis for "//trim(dim_names(i))) - ! if (is_root_pe() .and. is_y(i)) & - ! call MOM_error(NOTE, "Y-dimension determined from cartesian_axis for "//trim(dim_names(i))) endif endif endif @@ -308,199 +289,44 @@ subroutine categorize_axis_from_name(dimname, is_x, is_y) end subroutine categorize_axis_from_name -!===== Everything below this pertains to reading non-decomposed variables ===! -!===== using FMS2 interfaces will probably be discarded eventually. =========! - -!!> 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, 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, intent(inout) :: data !< The variable to read from read_data - 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 variables - type(FmsNetcdfFile_t) :: fileobj ! A handle to a simple netCDF file - logical :: close_the_file ! indicates whether to close the file after read_data is called. - character(len=96) :: var_to_read ! variable to read from the netcdf file - character(len=48) :: err_header ! A preamble for error messages - - err_header = "MOM_read_data_fms2:MOM_read_data_scalar: " - - ! Find the matching variable name in the file, opening it and reading metadata if necessary. - call find_varname_in_file(fileobj, fieldname, err_header, filename, var_to_read) - - ! read the data - if (present(timelevel)) then - call read_data(fileobj, trim(var_to_read), data, unlim_dim_level=timelevel) - else - call read_data(fileobj, trim(var_to_read), data) - endif - - ! Close the file, if necessary - close_the_file = .true. ; if (present(leave_file_open)) close_the_file = .not.(leave_file_open) - if (close_the_file .and. check_if_open(fileobj)) call fms2_close_file(fileobj) - - ! Rescale the data that was read if necessary. - if (present(scale)) then ; if (scale /= 1.0) then - data = scale*data - endif ; 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, 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 - 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 variables - type(FmsNetcdfFile_t) :: fileobj ! A handle to a simple netCDF file - logical :: close_the_file ! indicates whether to close the file after read_data is called. - integer :: time_dim ! The dimension position of a variables unlimited time axis, or -1 if it has none. - integer, parameter :: ndim = 1 ! The dimensionality of the array being read - integer, dimension(ndim) :: start, nread ! indices for first data value and number of values to read - character(len=96) :: var_to_read ! variable to read from the netcdf file - character(len=48) :: err_header ! A preamble for error messages - - err_header = "MOM_read_data_fms2:MOM_read_data_1d_noDD: " - - ! Find the matching case-insensitive variable name in the file, opening the file if necessary. - call find_varname_in_file(fileobj, fieldname, err_header, filename, var_to_read) - - ! 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(:) - nread(:) = shape(data) ; if (present(edge_lengths)) nread(:) = edge_lengths(:) - - time_dim = -1 - if (present(timelevel)) then - time_dim = get_time_dim(fileobj, var_to_read, err_header, filename, timelevel) - if (time_dim == ndim) then ; nread(ndim) = 1 ; start(ndim) = timelevel ; endif - endif - - ! read the data - if (time_dim > 0) then - call read_data(fileobj, trim(var_to_read), data, corner=start, edge_lengths=nread, & - unlim_dim_level=timelevel) - else - call read_data(fileobj, trim(var_to_read), data, corner=start, edge_lengths=nread) - endif - - ! Close the file, if necessary - close_the_file = .true. ; if (present(leave_file_open)) close_the_file = .not.(leave_file_open) - if (close_the_file .and. check_if_open(fileobj)) call fms2_close_file(fileobj) - - ! Rescale the data that was read if necessary. - if (present(scale)) then ; if (scale /= 1.0) then - data(:) = scale*data(:) - endif ; endif - -end subroutine MOM_read_data_1d_noDD - -!> This routine calls the fms_io read_data subroutine to read a 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, start_index, & - edge_lengths, timelevel, position, 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 - 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 - integer, optional, intent(in) :: position !< A flag indicating where this data is located - 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 variables - type(FmsNetcdfFile_t) :: fileobj ! A handle to a simple netCDF file - logical :: close_the_file ! indicates whether to close the file after read_data is called. - integer :: time_dim ! The dimension position of a variables unlimited time axis, or -1 if it has none. - integer, parameter :: ndim = 2 ! The dimensionality of the array being read - integer, dimension(ndim) :: start, nread ! indices for first data value and number of values to read - character(len=96) :: var_to_read ! variable to read from the netcdf file - character(len=48) :: err_header ! A preamble for error messages - - err_header = "MOM_read_data_fms2:MOM_read_data_2d_DD: " - - ! Find the matching case-insensitive variable name in the file, opening the file if necessary. - call find_varname_in_file(fileobj, fieldname, err_header, filename, var_to_read) - - ! 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(:) - nread(:) = shape(data) ; if (present(edge_lengths)) nread(:) = edge_lengths(:) - - time_dim = -1 - if (present(timelevel)) then - time_dim = get_time_dim(fileobj, var_to_read, err_header, filename, timelevel) - if (time_dim == ndim) then ; nread(ndim) = 1 ; start(ndim) = timelevel ; endif - endif - - ! read the data - if (time_dim > 0) then - call read_data(fileobj, trim(var_to_read), data, corner=start, edge_lengths=nread, & - unlim_dim_level=timelevel) - else - call read_data(fileobj, trim(var_to_read), data, corner=start, edge_lengths=nread) - endif - - ! Close the file, if necessary - close_the_file = .true. ; if (present(leave_file_open)) close_the_file = .not.(leave_file_open) - if (close_the_file .and. check_if_open(fileobj)) call fms2_close_file(fileobj) - - ! Rescale the data that was read if necessary. - if (present(scale)) then ; if (scale /= 1.0) then - data(:,:) = scale*data(:,:) - endif ; endif - -end subroutine MOM_read_data_2d_noDD - !> Find the case-sensitive name of the variable in a netCDF file with a case-insensitive name match. -subroutine find_varname_in_file(fileobj, fieldname, err_header, filename, var_to_read) - type(FmsNetcdfFile_t), intent(inout) :: fileobj !< A handle to a file object, that - !! will be opened if necessary +!! Optionally also determine whether this variable has an unlimited time dimension. +subroutine find_varname_in_file(fileobj, fieldname, err_header, filename, var_to_read, has_time_dim, timelevel) + type(FmsNetcdfFile_t), intent(inout) :: fileobj !< An FMS2 handle to an open NetCDF file character(len=*), intent(in) :: fieldname !< The variable name to seek in the file character(len=*), intent(in) :: err_header !< A descriptive prefix for error messages character(len=*), intent(in) :: filename !< The name of the file to read character(len=*), intent(out) :: var_to_read !< The variable name to read from the file + logical, optional, intent(out) :: has_time_dim !< Indicates whether fieldname has a time dimension + integer, optional, intent(in) :: timelevel !< A time level to read ! Local variables - logical :: file_open_success !.true. if call to open_file is successful logical :: variable_found ! Is a case-insensitive version of the variable found in the netCDF file? - character(len=96), allocatable, dimension(:) :: var_names !< array for names of variables in a netCDF - !! file opened to read - integer :: nvars ! The number of variables in the file. + character(len=256), allocatable, dimension(:) :: var_names ! The names of all the variables in the netCDF file + character(len=256), allocatable :: dim_names(:) ! The names of a variable's dimensions + integer :: nvars ! The number of variables in the file + integer :: dim_unlim_size ! The current size of the unlimited (time) dimension in the file. + integer :: num_var_dims ! The number of dimensions a variable has in the file. + integer :: time_dim ! The position of the unlimited (time) dimension for a variable, or -1 + ! if it has no unlimited dimension. integer :: i - var_to_read = "" - ! Open the file if necessary - if (.not.(check_if_open(fileobj))) then - file_open_success = fms2_open_file(fileobj, filename, "read", is_restart=.false.) - if (.not.file_open_success) call MOM_error(FATAL, trim(err_header)//" failed to open "//trim(filename)) - endif + if (.not.check_if_open(fileobj)) & + call MOM_error(FATAL, trim(err_header)//trim(filename)//" was not open in call to find_varname_in_file.") - if (variable_exists(fileobj, fieldname)) then - var_to_read = fieldname - else - variable_found = .false. + ! Search for the variable in the file, looking for the case-sensitive name first. + if (variable_exists(fileobj, trim(fieldname))) then + var_to_read = trim(fieldname) + else ! Look for case-insensitive variable name matches. nvars = get_num_variables(fileobj) if (nvars < 1) call MOM_error(FATAL, "nvars is less than 1 for file "//trim(filename)) allocate(var_names(nvars)) call get_variable_names(fileobj, var_names) ! search for the variable in the file + variable_found = .false. do i=1,nvars if (lowercase(trim(var_names(i))) == lowercase(trim(fieldname))) then variable_found = .true. @@ -513,43 +339,38 @@ subroutine find_varname_in_file(fileobj, fieldname, err_header, filename, var_to deallocate(var_names) endif -end subroutine find_varname_in_file + ! FMS2 can not handle a timelevel argument if the variable does not have one in the file, + ! so some error checking and logic are required. + if (present(has_time_dim) .or. present(timelevel)) then + time_dim = -1 -!> Return the number of the time dimension for a variable in an open non-domain-decomposed file, -!! or -1 if it has no time (or other unlimited) dimension. -integer function get_time_dim(fileobj, var_to_read, err_header, filename, timelevel) - type(FmsNetcdfFile_t), intent(in) :: fileobj !< A handle to an open file object - character(len=*), intent(in) :: var_to_read !< The variable name to read from the file - character(len=*), intent(in) :: err_header !< A descriptive prefix for error messages - character(len=*), intent(in) :: filename !< The name of the file to read - integer, optional, intent(in) :: timelevel !< A time level to read + num_var_dims = get_variable_num_dimensions(fileobj, trim(var_to_read)) + allocate(dim_names(num_var_dims)) ; dim_names(:) = "" + call get_variable_dimension_names(fileobj, trim(var_to_read), dim_names) - ! Local variables - integer :: i, dim_unlim_size, num_var_dims - character(len=96), allocatable :: dim_names(:) ! variable dimension names - - num_var_dims = get_variable_num_dimensions(fileobj, trim(var_to_read)) - allocate(dim_names(num_var_dims)) ; dim_names(:) = "" - call get_variable_dimension_names(fileobj, trim(var_to_read), dim_names) - - get_time_dim = -1 - do i=1,num_var_dims - if (is_dimension_unlimited(fileobj, dim_names(i))) then - get_time_dim = i - if (present(timelevel)) then - call get_dimension_size(fileobj, dim_names(i), dim_unlim_size) - if (timelevel > dim_unlim_size) call MOM_error(FATAL, trim(err_header)//& - "Attempting to read a time level of "//trim(var_to_read)//& - " that exceeds the size of "//trim(filename)) + do i=1,num_var_dims + if (is_dimension_unlimited(fileobj, dim_names(i))) then + time_dim = i + if (present(timelevel)) then + call get_dimension_size(fileobj, dim_names(i), dim_unlim_size) + if ((timelevel > dim_unlim_size) .and. is_root_PE()) call MOM_error(FATAL, & + trim(err_header)//"Attempting to read a time level of "//trim(var_to_read)//& + " that exceeds the size of the time dimension in "//trim(filename)) + endif + exit endif - exit - endif - enddo - if (get_time_dim < 0) & - call MOM_error(WARNING, trim(err_header)//"time level specified, but the variable "//& + enddo + deallocate(dim_names) + + if (present(timelevel) .and. (time_dim < 0) .and. is_root_PE()) & + call MOM_error(WARNING, trim(err_header)//"time level specified, but the variable "//& trim(var_to_read)//" does not have an unlimited dimension in "//trim(filename)) - deallocate(dim_names) + if ((.not.present(timelevel)) .and. (time_dim > 0) .and. is_root_PE()) & + call MOM_error(WARNING, trim(err_header)//"The variable "//trim(var_to_read)//& + " has an unlimited dimension in "//trim(filename)//" but no time level is specified.") + if (present(has_time_dim)) has_time_dim = (time_dim > 0) + endif -end function get_time_dim +end subroutine find_varname_in_file end module MOM_read_data_fms2 From 66ac81057a202d4ee9ce800f3806cced555f8627 Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Mon, 22 Mar 2021 13:48:00 -0600 Subject: [PATCH 024/112] Only write checksums from root PE MCT/NUOPC caps --- .../drivers/mct_cap/mom_ocean_model_mct.F90 | 28 ++++---- .../mct_cap/mom_surface_forcing_mct.F90 | 65 ++++++++++-------- .../nuopc_cap/mom_ocean_model_nuopc.F90 | 29 ++++---- .../nuopc_cap/mom_surface_forcing_nuopc.F90 | 68 +++++++++++-------- 4 files changed, 108 insertions(+), 82 deletions(-) diff --git a/config_src/drivers/mct_cap/mom_ocean_model_mct.F90 b/config_src/drivers/mct_cap/mom_ocean_model_mct.F90 index 5a04739971..bd6c7fe66e 100644 --- a/config_src/drivers/mct_cap/mom_ocean_model_mct.F90 +++ b/config_src/drivers/mct_cap/mom_ocean_model_mct.F90 @@ -15,6 +15,7 @@ module MOM_ocean_model_mct use MOM, only : extract_surface_state, allocate_surface_state, finish_MOM_initialization use MOM, only : get_MOM_state_elements, MOM_state_is_synchronized use MOM, only : get_ocean_stocks, step_offline +use MOM_coms, only : field_chksum use MOM_constants, only : CELSIUS_KELVIN_OFFSET, hlf use MOM_diag_mediator, only : diag_ctrl, enable_averaging, disable_averaging use MOM_diag_mediator, only : diag_mediator_close_registration, diag_mediator_end @@ -65,6 +66,7 @@ module MOM_ocean_model_mct ! MCT specfic routines use MOM_domains, only : MOM_infra_end +use iso_fortran_env, only : int64 #include @@ -1042,24 +1044,26 @@ subroutine Ocean_stock_pe(OS, index, value, time_index) end subroutine Ocean_stock_pe -!> Write out FMS-format checsums on fields from the ocean surface state +!> Write out checksums for fields from the ocean surface state subroutine ocean_public_type_chksum(id, timestep, ocn) character(len=*), intent(in) :: id !< An identifying string for this call integer, intent(in) :: timestep !< The number of elapsed timesteps type(ocean_public_type), intent(in) :: ocn !< A structure containing various publicly !! visible ocean surface fields. - integer :: n, m - - write(stdout,*) "BEGIN CHECKSUM(ocean_type):: ", id, timestep - write(stdout,100) 'ocean%t_surf ',mpp_chksum(ocn%t_surf ) - write(stdout,100) 'ocean%s_surf ',mpp_chksum(ocn%s_surf ) - write(stdout,100) 'ocean%u_surf ',mpp_chksum(ocn%u_surf ) - write(stdout,100) 'ocean%v_surf ',mpp_chksum(ocn%v_surf ) - write(stdout,100) 'ocean%sea_lev ',mpp_chksum(ocn%sea_lev) - write(stdout,100) 'ocean%frazil ',mpp_chksum(ocn%frazil ) - write(stdout,100) 'ocean%melt_potential ',mpp_chksum(ocn%melt_potential) - + ! Local variables + integer(kind=int64) :: chks ! A checksum for the field + logical :: root ! True only on the root PE + integer :: outunit ! The output unit to write to + + if (root) write(outunit,*) "BEGIN CHECKSUM(ocean_type):: ", id, timestep + chks = field_chksum(ocn%t_surf ) ; if (root) write(outunit,100) 'ocean%t_surf ', chks + chks = field_chksum(ocn%s_surf ) ; if (root) write(outunit,100) 'ocean%s_surf ', chks + chks = field_chksum(ocn%u_surf ) ; if (root) write(outunit,100) 'ocean%u_surf ', chks + chks = field_chksum(ocn%v_surf ) ; if (root) write(outunit,100) 'ocean%v_surf ', chks + chks = field_chksum(ocn%sea_lev) ; if (root) write(outunit,100) 'ocean%sea_lev ', chks + chks = field_chksum(ocn%frazil ) ; if (root) write(outunit,100) 'ocean%frazil ', chks + chks = field_chksum(ocn%melt_potential) ; if (root) write(outunit,100) 'ocean%melt_potential ', chks call coupler_type_write_chksums(ocn%fields, stdout, 'ocean%') 100 FORMAT(" CHECKSUM::",A20," = ",Z20) diff --git a/config_src/drivers/mct_cap/mom_surface_forcing_mct.F90 b/config_src/drivers/mct_cap/mom_surface_forcing_mct.F90 index 82105e040e..34cb737981 100644 --- a/config_src/drivers/mct_cap/mom_surface_forcing_mct.F90 +++ b/config_src/drivers/mct_cap/mom_surface_forcing_mct.F90 @@ -2,7 +2,7 @@ module MOM_surface_forcing_mct ! This file is part of MOM6. See LICENSE.md for the license. -use MOM_coms, only : reproducing_sum +use MOM_coms, only : reproducing_sum, field_chksum use MOM_constants, only : hlv, hlf use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end use MOM_cpu_clock, only : CLOCK_SUBCOMPONENT @@ -37,7 +37,8 @@ module MOM_surface_forcing_mct use mpp_mod, only : mpp_chksum use time_interp_external_mod, only : init_external_field, time_interp_external use time_interp_external_mod, only : time_interp_external_init -use MOM_io, only: stdout +use MOM_io, only : stdout +use iso_fortran_env, only : int64 implicit none ; private @@ -1361,32 +1362,40 @@ subroutine ice_ocn_bnd_type_chksum(id, timestep, iobt) !! ocean in a coupled model whose checksums are reported ! local variables - integer :: n,m - - write(stdout,*) "BEGIN CHECKSUM(ice_ocean_boundary_type):: ", id, timestep - write(stdout,100) 'iobt%u_flux ' , mpp_chksum( iobt%u_flux ) - write(stdout,100) 'iobt%v_flux ' , mpp_chksum( iobt%v_flux ) - write(stdout,100) 'iobt%t_flux ' , mpp_chksum( iobt%t_flux ) - write(stdout,100) 'iobt%q_flux ' , mpp_chksum( iobt%q_flux ) - write(stdout,100) 'iobt%salt_flux ' , mpp_chksum( iobt%salt_flux ) - write(stdout,100) 'iobt%seaice_melt_heat' , mpp_chksum( iobt%seaice_melt_heat) - write(stdout,100) 'iobt%seaice_melt ' , mpp_chksum( iobt%seaice_melt ) - write(stdout,100) 'iobt%lw_flux ' , mpp_chksum( iobt%lw_flux ) - write(stdout,100) 'iobt%sw_flux_vis_dir' , mpp_chksum( iobt%sw_flux_vis_dir) - write(stdout,100) 'iobt%sw_flux_vis_dif' , mpp_chksum( iobt%sw_flux_vis_dif) - write(stdout,100) 'iobt%sw_flux_nir_dir' , mpp_chksum( iobt%sw_flux_nir_dir) - write(stdout,100) 'iobt%sw_flux_nir_dif' , mpp_chksum( iobt%sw_flux_nir_dif) - write(stdout,100) 'iobt%lprec ' , mpp_chksum( iobt%lprec ) - write(stdout,100) 'iobt%fprec ' , mpp_chksum( iobt%fprec ) - write(stdout,100) 'iobt%runoff ' , mpp_chksum( iobt%runoff ) - write(stdout,100) 'iobt%calving ' , mpp_chksum( iobt%calving ) - write(stdout,100) 'iobt%p ' , mpp_chksum( iobt%p ) - if (associated(iobt%ustar_berg)) & - write(stdout,100) 'iobt%ustar_berg ' , mpp_chksum( iobt%ustar_berg ) - if (associated(iobt%area_berg)) & - write(stdout,100) 'iobt%area_berg ' , mpp_chksum( iobt%area_berg ) - if (associated(iobt%mass_berg)) & - write(stdout,100) 'iobt%mass_berg ' , mpp_chksum( iobt%mass_berg ) + integer(kind=int64) :: chks ! A checksum for the field + logical :: root ! True only on the root PE + integer :: outunit ! The output unit to write to + + outunit = stdout + root = is_root_pe() + + if (root) write(outunit,*) "BEGIN CHECKSUM(ice_ocean_boundary_type):: ", id, timestep + chks = field_chksum( iobt%u_flux ) ; if (root) write(outunit,100) 'iobt%u_flux ', chks + chks = field_chksum( iobt%v_flux ) ; if (root) write(outunit,100) 'iobt%v_flux ', chks + chks = field_chksum( iobt%t_flux ) ; if (root) write(outunit,100) 'iobt%t_flux ', chks + chks = field_chksum( iobt%q_flux ) ; if (root) write(outunit,100) 'iobt%q_flux ', chks + chks = field_chksum( iobt%seaice_melt_heat); if (root) write(outunit,100) 'iobt%seaice_melt_heat', chks + chks = field_chksum( iobt%seaice_melt) ; if (root) write(outunit,100) 'iobt%seaice_melt ', chks + chks = field_chksum( iobt%salt_flux ) ; if (root) write(outunit,100) 'iobt%salt_flux ', chks + chks = field_chksum( iobt%lw_flux ) ; if (root) write(outunit,100) 'iobt%lw_flux ', chks + chks = field_chksum( iobt%sw_flux_vis_dir) ; if (root) write(outunit,100) 'iobt%sw_flux_vis_dir', chks + chks = field_chksum( iobt%sw_flux_vis_dif) ; if (root) write(outunit,100) 'iobt%sw_flux_vis_dif', chks + chks = field_chksum( iobt%sw_flux_nir_dir) ; if (root) write(outunit,100) 'iobt%sw_flux_nir_dir', chks + chks = field_chksum( iobt%sw_flux_nir_dif) ; if (root) write(outunit,100) 'iobt%sw_flux_nir_dif', chks + chks = field_chksum( iobt%lprec ) ; if (root) write(outunit,100) 'iobt%lprec ', chks + chks = field_chksum( iobt%fprec ) ; if (root) write(outunit,100) 'iobt%fprec ', chks + chks = field_chksum( iobt%rofl_flux ) ; if (root) write(outunit,100) 'rofl_flux ', chks + chks = field_chksum( iobt%rofi_flux ) ; if (root) write(outunit,100) 'rofi_flux ', chks + chks = field_chksum( iobt%p ) ; if (root) write(outunit,100) 'iobt%p ', chks + if (associated(iobt%ustar_berg)) then + chks = field_chksum( iobt%ustar_berg ) ; if (root) write(outunit,100) 'iobt%ustar_berg ', chks + endif + if (associated(iobt%area_berg)) then + chks = field_chksum( iobt%area_berg ) ; if (root) write(outunit,100) 'iobt%area_berg ', chks + endif + if (associated(iobt%mass_berg)) then + chks = field_chksum( iobt%mass_berg ) ; if (root) write(outunit,100) 'iobt%mass_berg ', chks + endif 100 FORMAT(" CHECKSUM::",A20," = ",Z20) call coupler_type_write_chksums(iobt%fluxes, stdout, 'iobt%') diff --git a/config_src/drivers/nuopc_cap/mom_ocean_model_nuopc.F90 b/config_src/drivers/nuopc_cap/mom_ocean_model_nuopc.F90 index 493762f4bc..b8bcf8ff87 100644 --- a/config_src/drivers/nuopc_cap/mom_ocean_model_nuopc.F90 +++ b/config_src/drivers/nuopc_cap/mom_ocean_model_nuopc.F90 @@ -15,6 +15,7 @@ module MOM_ocean_model_nuopc use MOM, only : extract_surface_state, allocate_surface_state, finish_MOM_initialization use MOM, only : get_MOM_state_elements, MOM_state_is_synchronized use MOM, only : get_ocean_stocks, step_offline +use MOM_coms, only : field_chksum use MOM_constants, only : CELSIUS_KELVIN_OFFSET, hlf use MOM_diag_mediator, only : diag_ctrl, enable_averaging, disable_averaging use MOM_diag_mediator, only : diag_mediator_close_registration, diag_mediator_end @@ -62,6 +63,7 @@ module MOM_ocean_model_nuopc use MOM_surface_forcing_nuopc, only : convert_IOB_to_forces, ice_ocn_bnd_type_chksum use MOM_surface_forcing_nuopc, only : ice_ocean_boundary_type, surface_forcing_CS use MOM_surface_forcing_nuopc, only : forcing_save_restart +use iso_fortran_env, only : int64 #include @@ -1045,26 +1047,29 @@ subroutine Ocean_stock_pe(OS, index, value, time_index) end subroutine Ocean_stock_pe -!> Write out FMS-format checsums on fields from the ocean surface state +!> Write out checksums for fields from the ocean surface state subroutine ocean_public_type_chksum(id, timestep, ocn) character(len=*), intent(in) :: id !< An identifying string for this call integer, intent(in) :: timestep !< The number of elapsed timesteps type(ocean_public_type), intent(in) :: ocn !< A structure containing various publicly !! visible ocean surface fields. - integer :: n, m, outunit + ! Local variables + integer(kind=int64) :: chks ! A checksum for the field + logical :: root ! True only on the root PE + integer :: outunit ! The output unit to write to outunit = stdout() - - write(outunit,*) "BEGIN CHECKSUM(ocean_type):: ", id, timestep - write(outunit,100) 'ocean%t_surf ',mpp_chksum(ocn%t_surf ) - write(outunit,100) 'ocean%s_surf ',mpp_chksum(ocn%s_surf ) - write(outunit,100) 'ocean%u_surf ',mpp_chksum(ocn%u_surf ) - write(outunit,100) 'ocean%v_surf ',mpp_chksum(ocn%v_surf ) - write(outunit,100) 'ocean%sea_lev ',mpp_chksum(ocn%sea_lev) - write(outunit,100) 'ocean%frazil ',mpp_chksum(ocn%frazil ) - write(outunit,100) 'ocean%melt_potential ',mpp_chksum(ocn%melt_potential) - + root = is_root_pe() + + if (root) write(outunit,*) "BEGIN CHECKSUM(ocean_type):: ", id, timestep + chks = field_chksum(ocn%t_surf ) ; if (root) write(outunit,100) 'ocean%t_surf ', chks + chks = field_chksum(ocn%s_surf ) ; if (root) write(outunit,100) 'ocean%s_surf ', chks + chks = field_chksum(ocn%u_surf ) ; if (root) write(outunit,100) 'ocean%u_surf ', chks + chks = field_chksum(ocn%v_surf ) ; if (root) write(outunit,100) 'ocean%v_surf ', chks + chks = field_chksum(ocn%sea_lev) ; if (root) write(outunit,100) 'ocean%sea_lev ', chks + chks = field_chksum(ocn%frazil ) ; if (root) write(outunit,100) 'ocean%frazil ', chks + chks = field_chksum(ocn%melt_potential) ; if (root) write(outunit,100) 'ocean%melt_potential ', chks call coupler_type_write_chksums(ocn%fields, outunit, 'ocean%') 100 FORMAT(" CHECKSUM::",A20," = ",Z20) diff --git a/config_src/drivers/nuopc_cap/mom_surface_forcing_nuopc.F90 b/config_src/drivers/nuopc_cap/mom_surface_forcing_nuopc.F90 index 689a9f0f4a..8c304dc600 100644 --- a/config_src/drivers/nuopc_cap/mom_surface_forcing_nuopc.F90 +++ b/config_src/drivers/nuopc_cap/mom_surface_forcing_nuopc.F90 @@ -3,7 +3,7 @@ module MOM_surface_forcing_nuopc ! This file is part of MOM6. See LICENSE.md for the license. -use MOM_coms, only : reproducing_sum +use MOM_coms, only : reproducing_sum, field_chksum use MOM_constants, only : hlv, hlf use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end use MOM_cpu_clock, only : CLOCK_SUBCOMPONENT @@ -22,6 +22,7 @@ module MOM_surface_forcing_nuopc use MOM_get_input, only : Get_MOM_Input, directories use MOM_grid, only : ocean_grid_type use MOM_io, only : slasher, write_version_number, MOM_read_data +use MOM_io, only : stdout use MOM_restart, only : register_restart_field, restart_init, MOM_restart_CS use MOM_restart, only : restart_init_end, save_restart, restore_state use MOM_string_functions, only : uppercase @@ -35,10 +36,10 @@ module MOM_surface_forcing_nuopc use coupler_types_mod, only : coupler_type_initialized, coupler_type_spawn use coupler_types_mod, only : coupler_type_copy_data use data_override_mod, only : data_override_init, data_override -use fms_mod, only : stdout use mpp_mod, only : mpp_chksum use time_interp_external_mod, only : init_external_field, time_interp_external use time_interp_external_mod, only : time_interp_external_init +use iso_fortran_env, only : int64 implicit none ; private @@ -1400,34 +1401,41 @@ subroutine ice_ocn_bnd_type_chksum(id, timestep, iobt) !! ocean in a coupled model whose checksums are reported ! local variables - integer :: n,m, outunit - - outunit = stdout() - - write(outunit,*) "BEGIN CHECKSUM(ice_ocean_boundary_type):: ", id, timestep - write(outunit,100) 'iobt%u_flux ' , mpp_chksum( iobt%u_flux ) - write(outunit,100) 'iobt%v_flux ' , mpp_chksum( iobt%v_flux ) - write(outunit,100) 'iobt%t_flux ' , mpp_chksum( iobt%t_flux ) - write(outunit,100) 'iobt%q_flux ' , mpp_chksum( iobt%q_flux ) - write(outunit,100) 'iobt%salt_flux ' , mpp_chksum( iobt%salt_flux ) - write(outunit,100) 'iobt%seaice_melt_heat' , mpp_chksum( iobt%seaice_melt_heat) - write(outunit,100) 'iobt%seaice_melt ' , mpp_chksum( iobt%seaice_melt ) - write(outunit,100) 'iobt%lw_flux ' , mpp_chksum( iobt%lw_flux ) - write(outunit,100) 'iobt%sw_flux_vis_dir' , mpp_chksum( iobt%sw_flux_vis_dir) - write(outunit,100) 'iobt%sw_flux_vis_dif' , mpp_chksum( iobt%sw_flux_vis_dif) - write(outunit,100) 'iobt%sw_flux_nir_dir' , mpp_chksum( iobt%sw_flux_nir_dir) - write(outunit,100) 'iobt%sw_flux_nir_dif' , mpp_chksum( iobt%sw_flux_nir_dif) - write(outunit,100) 'iobt%lprec ' , mpp_chksum( iobt%lprec ) - write(outunit,100) 'iobt%fprec ' , mpp_chksum( iobt%fprec ) - write(outunit,100) 'iobt%lrunoff ' , mpp_chksum( iobt%lrunoff ) - write(outunit,100) 'iobt%frunoff ' , mpp_chksum( iobt%frunoff ) - write(outunit,100) 'iobt%p ' , mpp_chksum( iobt%p ) - if (associated(iobt%ustar_berg)) & - write(outunit,100) 'iobt%ustar_berg ' , mpp_chksum( iobt%ustar_berg ) - if (associated(iobt%area_berg)) & - write(outunit,100) 'iobt%area_berg ' , mpp_chksum( iobt%area_berg ) - if (associated(iobt%mass_berg)) & - write(outunit,100) 'iobt%mass_berg ' , mpp_chksum( iobt%mass_berg ) + ! Local variables + integer(kind=int64) :: chks ! A checksum for the field + logical :: root ! True only on the root PE + integer :: outunit ! The output unit to write to + + outunit = stdout + root = is_root_pe() + + if (root) write(outunit,*) "BEGIN CHECKSUM(ice_ocean_boundary_type):: ", id, timestep + chks = field_chksum( iobt%u_flux ) ; if (root) write(outunit,100) 'iobt%u_flux ', chks + chks = field_chksum( iobt%v_flux ) ; if (root) write(outunit,100) 'iobt%v_flux ', chks + chks = field_chksum( iobt%t_flux ) ; if (root) write(outunit,100) 'iobt%t_flux ', chks + chks = field_chksum( iobt%q_flux ) ; if (root) write(outunit,100) 'iobt%q_flux ', chks + chks = field_chksum( iobt%seaice_melt_heat); if (root) write(outunit,100) 'iobt%seaice_melt_heat', chks + chks = field_chksum( iobt%seaice_melt) ; if (root) write(outunit,100) 'iobt%seaice_melt ', chks + chks = field_chksum( iobt%salt_flux ) ; if (root) write(outunit,100) 'iobt%salt_flux ', chks + chks = field_chksum( iobt%lw_flux ) ; if (root) write(outunit,100) 'iobt%lw_flux ', chks + chks = field_chksum( iobt%sw_flux_vis_dir) ; if (root) write(outunit,100) 'iobt%sw_flux_vis_dir', chks + chks = field_chksum( iobt%sw_flux_vis_dif) ; if (root) write(outunit,100) 'iobt%sw_flux_vis_dif', chks + chks = field_chksum( iobt%sw_flux_nir_dir) ; if (root) write(outunit,100) 'iobt%sw_flux_nir_dir', chks + chks = field_chksum( iobt%sw_flux_nir_dif) ; if (root) write(outunit,100) 'iobt%sw_flux_nir_dif', chks + chks = field_chksum( iobt%lprec ) ; if (root) write(outunit,100) 'iobt%lprec ', chks + chks = field_chksum( iobt%fprec ) ; if (root) write(outunit,100) 'iobt%fprec ', chks + chks = field_chksum( iobt%lrunoff ) ; if (root) write(outunit,100) 'iobt%lrunoff ', chks + chks = field_chksum( iobt%frunoff ) ; if (root) write(outunit,100) 'iobt%frunoff ', chks + chks = field_chksum( iobt%p ) ; if (root) write(outunit,100) 'iobt%p ', chks + if (associated(iobt%ustar_berg)) then + chks = field_chksum( iobt%ustar_berg ) ; if (root) write(outunit,100) 'iobt%ustar_berg ', chks + endif + if (associated(iobt%area_berg)) then + chks = field_chksum( iobt%area_berg ) ; if (root) write(outunit,100) 'iobt%area_berg ', chks + endif + if (associated(iobt%mass_berg)) then + chks = field_chksum( iobt%mass_berg ) ; if (root) write(outunit,100) 'iobt%mass_berg ', chks + endif 100 FORMAT(" CHECKSUM::",A20," = ",Z20) call coupler_type_write_chksums(iobt%fluxes, outunit, 'iobt%') From 3fe07d4c66918249e91fa192fae76e4572655d00 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 23 Mar 2021 05:55:12 -0400 Subject: [PATCH 025/112] +Move FMS2 read helper routines into MOM_io_infra Moved the routines prepare_to_read_var and find_varname_in_file, along with four other routines that prepare_to_read_var calls from MOM_read_data_fms2 to MOM_io_infra, and eliminated the file MOM_read_data_fms2.F90. All answers are bitwise identical, but this rearrangement of identical code does eliminate one public module, so that the file structure of infra/FMS2 is identical to that of infra/FMS1. --- config_src/infra/FMS2/MOM_io_infra.F90 | 364 +++++++++++++++++- config_src/infra/FMS2/MOM_read_data_fms2.F90 | 376 ------------------- 2 files changed, 360 insertions(+), 380 deletions(-) delete mode 100644 config_src/infra/FMS2/MOM_read_data_fms2.F90 diff --git a/config_src/infra/FMS2/MOM_io_infra.F90 b/config_src/infra/FMS2/MOM_io_infra.F90 index c545462ad8..07a7c798d6 100644 --- a/config_src/infra/FMS2/MOM_io_infra.F90 +++ b/config_src/infra/FMS2/MOM_io_infra.F90 @@ -5,16 +5,17 @@ module MOM_io_infra use MOM_domain_infra, only : MOM_domain_type, rescale_comp_data, AGRID, BGRID_NE, CGRID_NE use MOM_domain_infra, only : domain2d, domain1d, CENTER, CORNER, NORTH_FACE, EAST_FACE -use MOM_error_infra, only : MOM_error=>MOM_err, NOTE, FATAL, WARNING -use MOM_read_data_fms2, only : prepare_to_read_var, find_varname_in_file +use MOM_error_infra, only : MOM_error=>MOM_err, NOTE, FATAL, WARNING, is_root_PE +use MOM_string_functions, only : lowercase use fms2_io_mod, only : fms2_open_file => open_file, check_if_open, fms2_close_file => close_file use fms2_io_mod, only : FmsNetcdfDomainFile_t, FmsNetcdfFile_t, fms2_read_data => read_data use fms2_io_mod, only : get_unlimited_dimension_name, get_num_dimensions, get_num_variables -use fms2_io_mod, only : get_variable_names, variable_exists, get_variable_size +use fms2_io_mod, only : get_variable_names, variable_exists, get_variable_size, get_variable_units use fms2_io_mod, only : register_field, write_data, register_variable_attribute use fms2_io_mod, only : variable_att_exists, get_variable_attribute, get_variable_num_dimensions -use fms2_io_mod, only : get_dimension_size, is_dimension_registered, register_axis, unlimited +use fms2_io_mod, only : get_variable_dimension_names, is_dimension_registered, get_dimension_size +use fms2_io_mod, only : is_dimension_unlimited, register_axis, unlimited use fms_mod, only : write_version_number, open_namelist_file, check_nml_error use fms_io_mod, only : file_exist, field_exist, field_size, read_data @@ -1215,6 +1216,361 @@ subroutine MOM_read_vector_3d(filename, u_fieldname, v_fieldname, u_data, v_data end subroutine MOM_read_vector_3d +!> Find the case-sensitive name of the variable in a netCDF file with a case-insensitive name match. +!! Optionally also determine whether this variable has an unlimited time dimension. +subroutine find_varname_in_file(fileobj, fieldname, err_header, filename, var_to_read, has_time_dim, timelevel) + type(FmsNetcdfFile_t), intent(inout) :: fileobj !< An FMS2 handle to an open NetCDF file + character(len=*), intent(in) :: fieldname !< The variable name to seek in the file + character(len=*), intent(in) :: err_header !< A descriptive prefix for error messages + character(len=*), intent(in) :: filename !< The name of the file to read + character(len=*), intent(out) :: var_to_read !< The variable name to read from the file + logical, optional, intent(out) :: has_time_dim !< Indicates whether fieldname has a time dimension + integer, optional, intent(in) :: timelevel !< A time level to read + + ! Local variables + logical :: variable_found ! Is a case-insensitive version of the variable found in the netCDF file? + character(len=256), allocatable, dimension(:) :: var_names ! The names of all the variables in the netCDF file + character(len=256), allocatable :: dim_names(:) ! The names of a variable's dimensions + integer :: nvars ! The number of variables in the file + integer :: dim_unlim_size ! The current size of the unlimited (time) dimension in the file. + integer :: num_var_dims ! The number of dimensions a variable has in the file. + integer :: time_dim ! The position of the unlimited (time) dimension for a variable, or -1 + ! if it has no unlimited dimension. + integer :: i + + ! Open the file if necessary + if (.not.check_if_open(fileobj)) & + call MOM_error(FATAL, trim(err_header)//trim(filename)//" was not open in call to find_varname_in_file.") + + ! Search for the variable in the file, looking for the case-sensitive name first. + if (variable_exists(fileobj, trim(fieldname))) then + var_to_read = trim(fieldname) + else ! Look for case-insensitive variable name matches. + nvars = get_num_variables(fileobj) + if (nvars < 1) call MOM_error(FATAL, "nvars is less than 1 for file "//trim(filename)) + allocate(var_names(nvars)) + call get_variable_names(fileobj, var_names) + + ! search for the variable in the file + variable_found = .false. + do i=1,nvars + if (lowercase(trim(var_names(i))) == lowercase(trim(fieldname))) then + variable_found = .true. + var_to_read = trim(var_names(i)) + exit + endif + enddo + if (.not.(variable_found)) & + call MOM_error(FATAL, trim(err_header)//trim(fieldname)//" not found in "//trim(filename)) + deallocate(var_names) + endif + + ! FMS2 can not handle a timelevel argument if the variable does not have one in the file, + ! so some error checking and logic are required. + if (present(has_time_dim) .or. present(timelevel)) then + time_dim = -1 + + num_var_dims = get_variable_num_dimensions(fileobj, trim(var_to_read)) + allocate(dim_names(num_var_dims)) ; dim_names(:) = "" + call get_variable_dimension_names(fileobj, trim(var_to_read), dim_names) + + do i=1,num_var_dims + if (is_dimension_unlimited(fileobj, dim_names(i))) then + time_dim = i + if (present(timelevel)) then + call get_dimension_size(fileobj, dim_names(i), dim_unlim_size) + if ((timelevel > dim_unlim_size) .and. is_root_PE()) call MOM_error(FATAL, & + trim(err_header)//"Attempting to read a time level of "//trim(var_to_read)//& + " that exceeds the size of the time dimension in "//trim(filename)) + endif + exit + endif + enddo + deallocate(dim_names) + + if (present(timelevel) .and. (time_dim < 0) .and. is_root_PE()) & + call MOM_error(WARNING, trim(err_header)//"time level specified, but the variable "//& + trim(var_to_read)//" does not have an unlimited dimension in "//trim(filename)) + if ((.not.present(timelevel)) .and. (time_dim > 0) .and. is_root_PE()) & + call MOM_error(WARNING, trim(err_header)//"The variable "//trim(var_to_read)//& + " has an unlimited dimension in "//trim(filename)//" but no time level is specified.") + if (present(has_time_dim)) has_time_dim = (time_dim > 0) + endif + +end subroutine find_varname_in_file + + +!> Find the case-insensitive name match with a variable in an open domain-decomposed file-set, +!! prepare FMS2 to read this variable, and return some information needed to call fms2_read_data +!! correctly for this variable and file. +subroutine prepare_to_read_var(fileobj, fieldname, err_header, filename, var_to_read, & + has_time_dim, timelevel, position) + type(FmsNetcdfDomainFile_t), intent(inout) :: fileobj !< An FMS2 handle to an open domain-decomposed file + character(len=*), intent(in) :: fieldname !< The variable name to seek in the file + character(len=*), intent(in) :: err_header !< A descriptive prefix for error messages + character(len=*), intent(in) :: filename !< The name of the file to read + character(len=*), intent(out) :: var_to_read !< The variable name to read from the file + logical, optional, intent(out) :: has_time_dim !< Indicates whether fieldname has a time dimension + integer, optional, intent(in) :: timelevel !< A time level to read + integer, optional, intent(in) :: position !< A flag indicating where this variable is discretized + + ! Local variables + logical :: variable_found ! Is a case-insensitive version of the variable found in the netCDF file? + character(len=256), allocatable, dimension(:) :: var_names ! The names of all the variables in the netCDF file + character(len=256), allocatable :: dim_names(:) ! The names of a variable's dimensions + integer :: nvars ! The number of variables in the file. + integer :: dim_unlim_size ! The current size of the unlimited (time) dimension in the file. + integer :: num_var_dims ! The number of dimensions a variable has in the file. + integer :: time_dim ! The position of the unlimited (time) dimension for a variable, or -1 + ! if it has no unlimited dimension. + integer :: i + + ! Open the file if necessary + if (.not.check_if_open(fileobj)) & + call MOM_error(FATAL, trim(err_header)//trim(filename)//" was not open in call to prepare_to_read_var.") + + ! Search for the variable in the file, looking for the case-sensitive name first. + if (variable_exists(fileobj, trim(fieldname))) then + var_to_read = trim(fieldname) + else ! Look for case-insensitive variable name matches. + nvars = get_num_variables(fileobj) + if (nvars < 1) call MOM_error(FATAL, "nvars is less than 1 for file "//trim(filename)) + allocate(var_names(nvars)) + call get_variable_names(fileobj, var_names) + + variable_found = .false. + do i=1,nvars + if (lowercase(trim(var_names(i))) == lowercase(trim(fieldname))) then + variable_found = .true. + var_to_read = trim(var_names(i)) + exit + endif + enddo + if (.not.(variable_found)) & + call MOM_error(FATAL, trim(err_header)//trim(fieldname)//" not found in "//trim(filename)) + deallocate(var_names) + endif + + ! FMS2 can not handle a timelevel argument if the variable does not have one in the file, + ! so some error checking and logic are required. + if (present(has_time_dim) .or. present(timelevel)) then + time_dim = -1 + + num_var_dims = get_variable_num_dimensions(fileobj, trim(var_to_read)) + allocate(dim_names(num_var_dims)) ; dim_names(:) = "" + call get_variable_dimension_names(fileobj, trim(var_to_read), dim_names) + + do i=1,num_var_dims + if (is_dimension_unlimited(fileobj, dim_names(i))) then + time_dim = i + if (present(timelevel)) then + call get_dimension_size(fileobj, dim_names(i), dim_unlim_size) + if ((timelevel > dim_unlim_size) .and. is_root_PE()) call MOM_error(FATAL, & + trim(err_header)//"Attempting to read a time level of "//trim(var_to_read)//& + " that exceeds the size of the time dimension in "//trim(filename)) + endif + exit + endif + enddo + deallocate(dim_names) + + if (present(timelevel) .and. (time_dim < 0) .and. is_root_PE()) & + call MOM_error(WARNING, trim(err_header)//"time level specified, but the variable "//& + trim(var_to_read)//" does not have an unlimited dimension in "//trim(filename)) + if ((.not.present(timelevel)) .and. (time_dim > 0) .and. is_root_PE()) & + call MOM_error(WARNING, trim(err_header)//"The variable "//trim(var_to_read)//& + " has an unlimited dimension in "//trim(filename)//" but no time level is specified.") + if (present(has_time_dim)) has_time_dim = (time_dim > 0) + endif + + ! Registering the variable axes essentially just specifies the discrete position of this variable. + call MOM_register_variable_axes(fileobj, var_to_read, filename, position) + +end subroutine prepare_to_read_var + +!> register axes associated with a variable from a domain-decomposed netCDF file +subroutine MOM_register_variable_axes(fileObj, variableName, filename, position) + type(FmsNetcdfDomainFile_t), intent(inout) :: fileObj !< Handle to an open FMS2 netCDF file object + character(len=*), intent(in) :: variableName !< name of the variable + character(len=*), intent(in) :: filename !< The name of the file to read + integer, optional, intent(in) :: position !< A flag indicating where this data is discretized + + ! Local variables + character(len=256), allocatable, dimension(:) :: dim_names ! variable dimension names + integer, allocatable, dimension(:) :: dimSizes ! variable dimension sizes + logical, allocatable, dimension(:) :: is_x ! Is this a (likely domain-decomposed) x-axis + logical, allocatable, dimension(:) :: is_y ! Is this a (likely domain-decomposed) y-axis + logical, allocatable, dimension(:) :: is_t ! Is this a time axis or another unlimited axis + integer :: ndims ! number of dimensions + integer :: xPos, yPos ! Discrete positions for x and y axes. Default is CENTER + integer :: i + + xPos = CENTER ; yPos = CENTER + if (present(position)) then + if ((position == CORNER) .or. (position == EAST_FACE)) xPos = EAST_FACE + if ((position == CORNER) .or. (position == NORTH_FACE)) yPos = NORTH_FACE + endif + + ! get variable dimension names and lengths + ndims = get_variable_num_dimensions(fileObj, trim(variableName)) + allocate(dimSizes(ndims)) + allocate(dim_names(ndims)) + allocate(is_x(ndims)) ; is_x(:) = .false. + allocate(is_y(ndims)) ; is_y(:) = .false. + allocate(is_t(ndims)) ; is_t(:) = .false. + call get_variable_size(fileObj, trim(variableName), dimSizes) + call get_variable_dimension_names(fileObj, trim(variableName), dim_names) + call categorize_axes(fileObj, filename, ndims, dim_names, is_x, is_y, is_t) + + ! register the axes + do i=1,ndims + if ( .not.is_dimension_registered(fileobj, trim(dim_names(i))) ) then + if (is_x(i)) then + call register_axis(fileObj, trim(dim_names(i)), "x", domain_position=xPos) + elseif (is_y(i)) then + call register_axis(fileObj, trim(dim_names(i)), "y", domain_position=yPos) + else + call register_axis(fileObj, trim(dim_names(i)), dimSizes(i)) + endif + endif + enddo + + deallocate(dimSizes, dim_names, is_x, is_y, is_t) +end subroutine MOM_register_variable_axes + +!> Determine whether a variable's axes are associated with x-, y- or time-dimensions. Other +!! unlimited dimensions are also labeled as time axes for these purposes. +subroutine categorize_axes(fileObj, filename, ndims, dim_names, is_x, is_y, is_t) + type(FmsNetcdfDomainFile_t), intent(in) :: fileObj !< Handle to an open FMS2 netCDF file object + character(len=*), intent(in) :: filename !< The name of the file to read + integer, intent(in) :: ndims !< The number of dimensions associated with a variable + character(len=*), dimension(ndims), intent(in) :: dim_names !< Names of the dimensions associated with a variable + logical, dimension(ndims), intent(out) :: is_x !< Indicates if each dimension a (likely decomposed) x-axis + logical, dimension(ndims), intent(out) :: is_y !< Indicates if each dimension a (likely decomposed) y-axis + logical, dimension(ndims), intent(out) :: is_t !< Indicates if each dimension unlimited (usually time) axis + + ! Local variables + character(len=128) :: cartesian ! A flag indicating a Cartesian direction - usually a single character. + character(len=512) :: dim_list ! A concatenated list of dimension names. + character(len=128) :: units ! units corresponding to a specific variable dimension + logical :: x_found, y_found ! Indicate whether an x- or y- dimension have been found. + integer :: i + + x_found = .false. ; y_found = .false. + is_x(:) = .false. ; is_y(:) = .false. + do i=1,ndims + is_t(i) = is_dimension_unlimited(fileObj, trim(dim_names(i))) + ! First look for indicative variable attributes + if (.not.is_t(i)) then + if (variable_exists(fileobj, trim(dim_names(i)))) then + if (variable_att_exists(fileobj, trim(dim_names(i)), "cartesian_axis")) then + call get_variable_attribute(fileobj, trim(dim_names(i)), "cartesian_axis", cartesian) + cartesian = adjustl(cartesian) + if ((index(cartesian, "X") == 1) .or. (index(cartesian, "x") == 1)) is_x(i) = .true. + if ((index(cartesian, "Y") == 1) .or. (index(cartesian, "y") == 1)) is_y(i) = .true. + if ((index(cartesian, "T") == 1) .or. (index(cartesian, "t") == 1)) is_t(i) = .true. + endif + endif + endif + if (is_x(i)) x_found = .true. + if (is_y(i)) y_found = .true. + enddo + + if (.not.(x_found .and. y_found)) then + ! Next look for hints from axis names for uncharacterized axes + do i=1,ndims ; if (.not.(is_x(i) .or. is_y(i) .or. is_t(i))) then + call categorize_axis_from_name(dim_names(i), is_x(i), is_y(i)) + if (is_x(i)) x_found = .true. + if (is_y(i)) y_found = .true. + endif ; enddo + endif + + if (.not.(x_found .and. y_found)) then + ! Look for hints from CF-compliant axis units for uncharacterized axes + do i=1,ndims ; if (.not.(is_x(i) .or. is_y(i) .or. is_t(i))) then + call get_variable_units(fileobj, trim(dim_names(i)), units) + call categorize_axis_from_units(units, is_x(i), is_y(i)) + if (is_x(i)) x_found = .true. + if (is_y(i)) y_found = .true. + endif ; enddo + endif + + if (.not.(x_found .and. y_found) .and. ((ndims>2) .or. ((ndims==2) .and. .not.is_t(ndims)))) then + ! This is a case where one would expect to find x-and y-dimensions, but none have been found. + if (is_root_pe()) then + dim_list = trim(dim_names(1))//", "//trim(dim_names(2)) + do i=3,ndims ; dim_list = trim(dim_list)//", "//trim(dim_names(i)) ; enddo + call MOM_error(WARNING, "categorize_axes: Failed to identify x- and y- axes in the axis list ("//& + trim(dim_list)//") of a variable being read from "//trim(filename)) + endif + endif + +end subroutine categorize_axes + +!> Determine whether an axis is associated with the x- or y-directions based on a comparison of +!! its units with CF-compliant variants of latitude or longitude units. +subroutine categorize_axis_from_units(unit_string, is_x, is_y) + character(len=*), intent(in) :: unit_string !< string of units + logical, intent(out) :: is_x !< Indicates if the axis units are associated with an x-direction axis + logical, intent(out) :: is_y !< Indicates if the axis units are associated with an y-direction axis + + is_x = .false. ; is_y = .false. + select case (lowercase(trim(unit_string))) + case ("degrees_north"); is_y = .true. + case ("degree_north") ; is_y = .true. + case ("degrees_n") ; is_y = .true. + case ("degree_n") ; is_y = .true. + case ("degreen") ; is_y = .true. + case ("degreesn") ; is_y = .true. + case ("degrees_east") ; is_x = .true. + case ("degree_east") ; is_x = .true. + case ("degreese") ; is_x = .true. + case ("degreee") ; is_x = .true. + case ("degree_e") ; is_x = .true. + case ("degrees_e") ; is_x = .true. + case default ; is_x = .false. ; is_y = .false. + end select + +end subroutine categorize_axis_from_units + +!> Tries to determine whether the axis name is commonly associated with an x- or y- axis. This +!! approach is fragile and unreliable, but it a backup to reading a CARTESIAN file attribute. +subroutine categorize_axis_from_name(dimname, is_x, is_y) + character(len=*), intent(in) :: dimname !< A dimension name + logical, intent(out) :: is_x !< Indicates if the axis name is associated with an x-direction axis + logical, intent(out) :: is_y !< Indicates if the axis name is associated with an y-direction axis + + is_x = .false. ; is_y = .false. + select case(trim(lowercase(dimname))) + case ("grid_x_t") ; is_x = .true. + case ("nx") ; is_x = .true. + case ("nxp") ; is_x = .true. + case ("longitude") ; is_x = .true. + case ("long") ; is_x = .true. + case ("lon") ; is_x = .true. + case ("lonh") ; is_x = .true. + case ("lonq") ; is_x = .true. + case ("xh") ; is_x = .true. + case ("xq") ; is_x = .true. + case ("i") ; is_x = .true. + + case ("grid_y_t") ; is_y = .true. + case ("ny") ; is_y = .true. + case ("nyp") ; is_y = .true. + case ("latitude") ; is_y = .true. + case ("lat") ; is_y = .true. + case ("lath") ; is_y = .true. + case ("latq") ; is_y = .true. + case ("yh") ; is_y = .true. + case ("yq") ; is_y = .true. + case ("j") ; is_y = .true. + + case default ; is_x = .false. ; is_y = .false. + end select + +end subroutine categorize_axis_from_name + + !> Write a 4d field to an output file. subroutine write_field_4d(IO_handle, field_md, MOM_domain, field, tstamp, tile_count, fill_value) type(file_type), intent(inout) :: IO_handle !< Handle for a file that is open for writing diff --git a/config_src/infra/FMS2/MOM_read_data_fms2.F90 b/config_src/infra/FMS2/MOM_read_data_fms2.F90 deleted file mode 100644 index c632e95177..0000000000 --- a/config_src/infra/FMS2/MOM_read_data_fms2.F90 +++ /dev/null @@ -1,376 +0,0 @@ -!> This module contains routines that encapsulate common preparatory work for FMS2 read_data calls -module MOM_read_data_fms2 - -! This file is part of MOM6. See LICENSE.md for the license. -use MOM_error_infra, only : MOM_error=>MOM_err, NOTE, FATAL, WARNING, is_root_PE -use MOM_domain_infra, only : CENTER, CORNER, NORTH_FACE, EAST_FACE -use MOM_string_functions, only : lowercase -use fms2_io_mod, only : FmsNetcdfDomainFile_t, FmsNetcdfFile_t, check_if_open -use fms2_io_mod, only : variable_exists, get_num_variables, get_variable_names -use fms2_io_mod, only : get_variable_size, get_variable_units -use fms2_io_mod, only : get_variable_attribute, variable_att_exists -use fms2_io_mod, only : get_variable_num_dimensions, get_variable_dimension_names -use fms2_io_mod, only : is_dimension_unlimited, get_dimension_size -use fms2_io_mod, only : is_dimension_registered, register_axis - -implicit none ; private - -public prepare_to_read_var, find_varname_in_file - -contains - -!> Find the case-insensitive name match with a variable in an open domain-decomposed file-set, -!! prepare FMS2 to read this variable, and return some information needed to call fms2_read_data -!! correctly for this variable and file. -subroutine prepare_to_read_var(fileobj, fieldname, err_header, filename, var_to_read, & - has_time_dim, timelevel, position) - type(FmsNetcdfDomainFile_t), intent(inout) :: fileobj !< An FMS2 handle to an open domain-decomposed file - character(len=*), intent(in) :: fieldname !< The variable name to seek in the file - character(len=*), intent(in) :: err_header !< A descriptive prefix for error messages - character(len=*), intent(in) :: filename !< The name of the file to read - character(len=*), intent(out) :: var_to_read !< The variable name to read from the file - logical, optional, intent(out) :: has_time_dim !< Indicates whether fieldname has a time dimension - integer, optional, intent(in) :: timelevel !< A time level to read - integer, optional, intent(in) :: position !< A flag indicating where this variable is discretized - - ! Local variables - logical :: variable_found ! Is a case-insensitive version of the variable found in the netCDF file? - character(len=256), allocatable, dimension(:) :: var_names ! The names of all the variables in the netCDF file - character(len=256), allocatable :: dim_names(:) ! The names of a variable's dimensions - integer :: nvars ! The number of variables in the file. - integer :: dim_unlim_size ! The current size of the unlimited (time) dimension in the file. - integer :: num_var_dims ! The number of dimensions a variable has in the file. - integer :: time_dim ! The position of the unlimited (time) dimension for a variable, or -1 - ! if it has no unlimited dimension. - integer :: i - - ! Open the file if necessary - if (.not.check_if_open(fileobj)) & - call MOM_error(FATAL, trim(err_header)//trim(filename)//" was not open in call to prepare_to_read_var.") - - ! Search for the variable in the file, looking for the case-sensitive name first. - if (variable_exists(fileobj, trim(fieldname))) then - var_to_read = trim(fieldname) - else ! Look for case-insensitive variable name matches. - nvars = get_num_variables(fileobj) - if (nvars < 1) call MOM_error(FATAL, "nvars is less than 1 for file "//trim(filename)) - allocate(var_names(nvars)) - call get_variable_names(fileobj, var_names) - - variable_found = .false. - do i=1,nvars - if (lowercase(trim(var_names(i))) == lowercase(trim(fieldname))) then - variable_found = .true. - var_to_read = trim(var_names(i)) - exit - endif - enddo - if (.not.(variable_found)) & - call MOM_error(FATAL, trim(err_header)//trim(fieldname)//" not found in "//trim(filename)) - deallocate(var_names) - endif - - ! FMS2 can not handle a timelevel argument if the variable does not have one in the file, - ! so some error checking and logic are required. - if (present(has_time_dim) .or. present(timelevel)) then - time_dim = -1 - - num_var_dims = get_variable_num_dimensions(fileobj, trim(var_to_read)) - allocate(dim_names(num_var_dims)) ; dim_names(:) = "" - call get_variable_dimension_names(fileobj, trim(var_to_read), dim_names) - - do i=1,num_var_dims - if (is_dimension_unlimited(fileobj, dim_names(i))) then - time_dim = i - if (present(timelevel)) then - call get_dimension_size(fileobj, dim_names(i), dim_unlim_size) - if ((timelevel > dim_unlim_size) .and. is_root_PE()) call MOM_error(FATAL, & - trim(err_header)//"Attempting to read a time level of "//trim(var_to_read)//& - " that exceeds the size of the time dimension in "//trim(filename)) - endif - exit - endif - enddo - deallocate(dim_names) - - if (present(timelevel) .and. (time_dim < 0) .and. is_root_PE()) & - call MOM_error(WARNING, trim(err_header)//"time level specified, but the variable "//& - trim(var_to_read)//" does not have an unlimited dimension in "//trim(filename)) - if ((.not.present(timelevel)) .and. (time_dim > 0) .and. is_root_PE()) & - call MOM_error(WARNING, trim(err_header)//"The variable "//trim(var_to_read)//& - " has an unlimited dimension in "//trim(filename)//" but no time level is specified.") - if (present(has_time_dim)) has_time_dim = (time_dim > 0) - endif - - ! Registering the variable axes essentially just specifies the discrete position of this variable. - call MOM_register_variable_axes(fileobj, var_to_read, filename, position) - -end subroutine prepare_to_read_var - -!> register axes associated with a variable from a domain-decomposed netCDF file -subroutine MOM_register_variable_axes(fileObj, variableName, filename, position) - type(FmsNetcdfDomainFile_t), intent(inout) :: fileObj !< Handle to an open FMS2 netCDF file object - character(len=*), intent(in) :: variableName !< name of the variable - character(len=*), intent(in) :: filename !< The name of the file to read - integer, optional, intent(in) :: position !< A flag indicating where this data is discretized - - ! Local variables - character(len=256), allocatable, dimension(:) :: dim_names ! variable dimension names - integer, allocatable, dimension(:) :: dimSizes ! variable dimension sizes - logical, allocatable, dimension(:) :: is_x ! Is this a (likely domain-decomposed) x-axis - logical, allocatable, dimension(:) :: is_y ! Is this a (likely domain-decomposed) y-axis - logical, allocatable, dimension(:) :: is_t ! Is this a time axis or another unlimited axis - integer :: ndims ! number of dimensions - integer :: xPos, yPos ! Discrete positions for x and y axes. Default is CENTER - integer :: i - - xPos = CENTER ; yPos = CENTER - if (present(position)) then - if ((position == CORNER) .or. (position == EAST_FACE)) xPos = EAST_FACE - if ((position == CORNER) .or. (position == NORTH_FACE)) yPos = NORTH_FACE - endif - - ! get variable dimension names and lengths - ndims = get_variable_num_dimensions(fileObj, trim(variableName)) - allocate(dimSizes(ndims)) - allocate(dim_names(ndims)) - allocate(is_x(ndims)) ; is_x(:) = .false. - allocate(is_y(ndims)) ; is_y(:) = .false. - allocate(is_t(ndims)) ; is_t(:) = .false. - call get_variable_size(fileObj, trim(variableName), dimSizes) - call get_variable_dimension_names(fileObj, trim(variableName), dim_names) - call categorize_axes(fileObj, filename, ndims, dim_names, is_x, is_y, is_t) - - ! register the axes - do i=1,ndims - if ( .not.is_dimension_registered(fileobj, trim(dim_names(i))) ) then - if (is_x(i)) then - call register_axis(fileObj, trim(dim_names(i)), "x", domain_position=xPos) - elseif (is_y(i)) then - call register_axis(fileObj, trim(dim_names(i)), "y", domain_position=yPos) - else - call register_axis(fileObj, trim(dim_names(i)), dimSizes(i)) - endif - endif - enddo - - deallocate(dimSizes, dim_names, is_x, is_y, is_t) -end subroutine MOM_register_variable_axes - -!> Determine whether a variable's axes are associated with x-, y- or time-dimensions. Other -!! unlimited dimensions are also labeled as time axes for these purposes. -subroutine categorize_axes(fileObj, filename, ndims, dim_names, is_x, is_y, is_t) - type(FmsNetcdfDomainFile_t), intent(in) :: fileObj !< Handle to an open FMS2 netCDF file object - character(len=*), intent(in) :: filename !< The name of the file to read - integer, intent(in) :: ndims !< The number of dimensions associated with a variable - character(len=*), dimension(ndims), intent(in) :: dim_names !< Names of the dimensions associated with a variable - logical, dimension(ndims), intent(out) :: is_x !< Indicates if each dimension a (likely decomposed) x-axis - logical, dimension(ndims), intent(out) :: is_y !< Indicates if each dimension a (likely decomposed) y-axis - logical, dimension(ndims), intent(out) :: is_t !< Indicates if each dimension unlimited (usually time) axis - - ! Local variables - character(len=128) :: cartesian ! A flag indicating a Cartesian direction - usually a single character. - character(len=512) :: dim_list ! A concatenated list of dimension names. - character(len=128) :: units ! units corresponding to a specific variable dimension - logical :: x_found, y_found ! Indicate whether an x- or y- dimension have been found. - integer :: i - - x_found = .false. ; y_found = .false. - is_x(:) = .false. ; is_y(:) = .false. - do i=1,ndims - is_t(i) = is_dimension_unlimited(fileObj, trim(dim_names(i))) - ! First look for indicative variable attributes - if (.not.is_t(i)) then - if (variable_exists(fileobj, trim(dim_names(i)))) then - if (variable_att_exists(fileobj, trim(dim_names(i)), "cartesian_axis")) then - call get_variable_attribute(fileobj, trim(dim_names(i)), "cartesian_axis", cartesian) - cartesian = adjustl(cartesian) - if ((index(cartesian, "X") == 1) .or. (index(cartesian, "x") == 1)) is_x(i) = .true. - if ((index(cartesian, "Y") == 1) .or. (index(cartesian, "y") == 1)) is_y(i) = .true. - if ((index(cartesian, "T") == 1) .or. (index(cartesian, "t") == 1)) is_t(i) = .true. - endif - endif - endif - if (is_x(i)) x_found = .true. - if (is_y(i)) y_found = .true. - enddo - - if (.not.(x_found .and. y_found)) then - ! Next look for hints from axis names for uncharacterized axes - do i=1,ndims ; if (.not.(is_x(i) .or. is_y(i) .or. is_t(i))) then - call categorize_axis_from_name(dim_names(i), is_x(i), is_y(i)) - if (is_x(i)) x_found = .true. - if (is_y(i)) y_found = .true. - endif ; enddo - endif - - if (.not.(x_found .and. y_found)) then - ! Look for hints from CF-compliant axis units for uncharacterized axes - do i=1,ndims ; if (.not.(is_x(i) .or. is_y(i) .or. is_t(i))) then - call get_variable_units(fileobj, trim(dim_names(i)), units) - call categorize_axis_from_units(units, is_x(i), is_y(i)) - if (is_x(i)) x_found = .true. - if (is_y(i)) y_found = .true. - endif ; enddo - endif - - if (.not.(x_found .and. y_found) .and. ((ndims>2) .or. ((ndims==2) .and. .not.is_t(ndims)))) then - ! This is a case where one would expect to find x-and y-dimensions, but none have been found. - if (is_root_pe()) then - dim_list = trim(dim_names(1))//", "//trim(dim_names(2)) - do i=3,ndims ; dim_list = trim(dim_list)//", "//trim(dim_names(i)) ; enddo - call MOM_error(WARNING, "categorize_axes: Failed to identify x- and y- axes in the axis list ("//& - trim(dim_list)//") of a variable being read from "//trim(filename)) - endif - endif - -end subroutine categorize_axes - -!> Determine whether an axis is associated with the x- or y-directions based on a comparison of -!! its units with CF-compliant variants of latitude or longitude units. -subroutine categorize_axis_from_units(unit_string, is_x, is_y) - character(len=*), intent(in) :: unit_string !< string of units - logical, intent(out) :: is_x !< Indicates if the axis units are associated with an x-direction axis - logical, intent(out) :: is_y !< Indicates if the axis units are associated with an y-direction axis - - is_x = .false. ; is_y = .false. - select case (lowercase(trim(unit_string))) - case ("degrees_north"); is_y = .true. - case ("degree_north") ; is_y = .true. - case ("degrees_n") ; is_y = .true. - case ("degree_n") ; is_y = .true. - case ("degreen") ; is_y = .true. - case ("degreesn") ; is_y = .true. - case ("degrees_east") ; is_x = .true. - case ("degree_east") ; is_x = .true. - case ("degreese") ; is_x = .true. - case ("degreee") ; is_x = .true. - case ("degree_e") ; is_x = .true. - case ("degrees_e") ; is_x = .true. - case default ; is_x = .false. ; is_y = .false. - end select - -end subroutine categorize_axis_from_units - -!> Tries to determine whether the axis name is commonly associated with an x- or y- axis. This -!! approach is fragile and unreliable, but it a backup to reading a CARTESIAN file attribute. -subroutine categorize_axis_from_name(dimname, is_x, is_y) - character(len=*), intent(in) :: dimname !< A dimension name - logical, intent(out) :: is_x !< Indicates if the axis name is associated with an x-direction axis - logical, intent(out) :: is_y !< Indicates if the axis name is associated with an y-direction axis - - is_x = .false. ; is_y = .false. - select case(trim(lowercase(dimname))) - case ("grid_x_t") ; is_x = .true. - case ("nx") ; is_x = .true. - case ("nxp") ; is_x = .true. - case ("longitude") ; is_x = .true. - case ("long") ; is_x = .true. - case ("lon") ; is_x = .true. - case ("lonh") ; is_x = .true. - case ("lonq") ; is_x = .true. - case ("xh") ; is_x = .true. - case ("xq") ; is_x = .true. - case ("i") ; is_x = .true. - - case ("grid_y_t") ; is_y = .true. - case ("ny") ; is_y = .true. - case ("nyp") ; is_y = .true. - case ("latitude") ; is_y = .true. - case ("lat") ; is_y = .true. - case ("lath") ; is_y = .true. - case ("latq") ; is_y = .true. - case ("yh") ; is_y = .true. - case ("yq") ; is_y = .true. - case ("j") ; is_y = .true. - - case default ; is_x = .false. ; is_y = .false. - end select - -end subroutine categorize_axis_from_name - - -!> Find the case-sensitive name of the variable in a netCDF file with a case-insensitive name match. -!! Optionally also determine whether this variable has an unlimited time dimension. -subroutine find_varname_in_file(fileobj, fieldname, err_header, filename, var_to_read, has_time_dim, timelevel) - type(FmsNetcdfFile_t), intent(inout) :: fileobj !< An FMS2 handle to an open NetCDF file - character(len=*), intent(in) :: fieldname !< The variable name to seek in the file - character(len=*), intent(in) :: err_header !< A descriptive prefix for error messages - character(len=*), intent(in) :: filename !< The name of the file to read - character(len=*), intent(out) :: var_to_read !< The variable name to read from the file - logical, optional, intent(out) :: has_time_dim !< Indicates whether fieldname has a time dimension - integer, optional, intent(in) :: timelevel !< A time level to read - - ! Local variables - logical :: variable_found ! Is a case-insensitive version of the variable found in the netCDF file? - character(len=256), allocatable, dimension(:) :: var_names ! The names of all the variables in the netCDF file - character(len=256), allocatable :: dim_names(:) ! The names of a variable's dimensions - integer :: nvars ! The number of variables in the file - integer :: dim_unlim_size ! The current size of the unlimited (time) dimension in the file. - integer :: num_var_dims ! The number of dimensions a variable has in the file. - integer :: time_dim ! The position of the unlimited (time) dimension for a variable, or -1 - ! if it has no unlimited dimension. - integer :: i - - ! Open the file if necessary - if (.not.check_if_open(fileobj)) & - call MOM_error(FATAL, trim(err_header)//trim(filename)//" was not open in call to find_varname_in_file.") - - ! Search for the variable in the file, looking for the case-sensitive name first. - if (variable_exists(fileobj, trim(fieldname))) then - var_to_read = trim(fieldname) - else ! Look for case-insensitive variable name matches. - nvars = get_num_variables(fileobj) - if (nvars < 1) call MOM_error(FATAL, "nvars is less than 1 for file "//trim(filename)) - allocate(var_names(nvars)) - call get_variable_names(fileobj, var_names) - - ! search for the variable in the file - variable_found = .false. - do i=1,nvars - if (lowercase(trim(var_names(i))) == lowercase(trim(fieldname))) then - variable_found = .true. - var_to_read = trim(var_names(i)) - exit - endif - enddo - if (.not.(variable_found)) & - call MOM_error(FATAL, trim(err_header)//trim(fieldname)//" not found in "//trim(filename)) - deallocate(var_names) - endif - - ! FMS2 can not handle a timelevel argument if the variable does not have one in the file, - ! so some error checking and logic are required. - if (present(has_time_dim) .or. present(timelevel)) then - time_dim = -1 - - num_var_dims = get_variable_num_dimensions(fileobj, trim(var_to_read)) - allocate(dim_names(num_var_dims)) ; dim_names(:) = "" - call get_variable_dimension_names(fileobj, trim(var_to_read), dim_names) - - do i=1,num_var_dims - if (is_dimension_unlimited(fileobj, dim_names(i))) then - time_dim = i - if (present(timelevel)) then - call get_dimension_size(fileobj, dim_names(i), dim_unlim_size) - if ((timelevel > dim_unlim_size) .and. is_root_PE()) call MOM_error(FATAL, & - trim(err_header)//"Attempting to read a time level of "//trim(var_to_read)//& - " that exceeds the size of the time dimension in "//trim(filename)) - endif - exit - endif - enddo - deallocate(dim_names) - - if (present(timelevel) .and. (time_dim < 0) .and. is_root_PE()) & - call MOM_error(WARNING, trim(err_header)//"time level specified, but the variable "//& - trim(var_to_read)//" does not have an unlimited dimension in "//trim(filename)) - if ((.not.present(timelevel)) .and. (time_dim > 0) .and. is_root_PE()) & - call MOM_error(WARNING, trim(err_header)//"The variable "//trim(var_to_read)//& - " has an unlimited dimension in "//trim(filename)//" but no time level is specified.") - if (present(has_time_dim)) has_time_dim = (time_dim > 0) - endif - -end subroutine find_varname_in_file - -end module MOM_read_data_fms2 From 17afc2b5e32c1ad2ee1f9e379a29a3cb7a7d7e36 Mon Sep 17 00:00:00 2001 From: sanAkel Date: Tue, 23 Mar 2021 14:41:28 -0400 Subject: [PATCH 026/112] A call to pass_vector(...) is needed to correctly do a halo exchange before getting currents in A- or B-grid staggering. Now added. --- config_src/drivers/FMS_cap/ocean_model_MOM.F90 | 2 ++ 1 file changed, 2 insertions(+) diff --git a/config_src/drivers/FMS_cap/ocean_model_MOM.F90 b/config_src/drivers/FMS_cap/ocean_model_MOM.F90 index f635e886a5..b7f8c2a84e 100644 --- a/config_src/drivers/FMS_cap/ocean_model_MOM.F90 +++ b/config_src/drivers/FMS_cap/ocean_model_MOM.F90 @@ -1162,6 +1162,8 @@ subroutine ocean_model_get_UV_surf(OS, Ocean, name, array2D, isc, jsc) sfc_state => OS%sfc_state + call pass_vector(sfc_state%u, sfc_state%v, G%Domain) + select case(name) case('ua') do j=jsc_bnd,jec_bnd ; do i=isc_bnd,iec_bnd From 7bdecbc62be1c636fd49071f4d7830a76ffa79af Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 23 Mar 2021 20:19:56 -0400 Subject: [PATCH 027/112] Add missing ".nc" to FMS2 output filenames Add a missing ".nc" suffix to the output filename with FMS2_io, while also issuing a warning, following the practice of FMS1. Also reordered the calls to add the longname and axis attributes to FMS2 files, to follow the order used in MOM6 calls to FMS1. All answers are bitwise identical, but there are some changes to output filenames and orders of attributes in files (to revert to traditional behavior). --- config_src/infra/FMS2/MOM_io_infra.F90 | 71 +++++++++++++++++++++----- 1 file changed, 57 insertions(+), 14 deletions(-) diff --git a/config_src/infra/FMS2/MOM_io_infra.F90 b/config_src/infra/FMS2/MOM_io_infra.F90 index 07a7c798d6..009050985d 100644 --- a/config_src/infra/FMS2/MOM_io_infra.F90 +++ b/config_src/infra/FMS2/MOM_io_infra.F90 @@ -20,6 +20,7 @@ module MOM_io_infra use fms_mod, only : write_version_number, open_namelist_file, check_nml_error use fms_io_mod, only : file_exist, field_exist, field_size, read_data use fms_io_mod, only : fms_io_exit, get_filename_appendix +use mpp_domains_mod, only : mpp_get_compute_domain, mpp_get_global_domain use mpp_io_mod, only : mpp_open, mpp_close, mpp_flush use mpp_io_mod, only : mpp_write_meta, mpp_write use mpp_io_mod, only : mpp_get_atts, mpp_attribute_exist @@ -315,7 +316,9 @@ subroutine open_file_type(IO_handle, filename, action, MOM_domain, threading, fi ! reading, writing or appending character(len=40) :: mode ! A character string that encodes whether the file is to be opened for ! reading, writing or appending + character(len=:), allocatable :: filename_tmp ! A copy of filename with .nc appended if necessary. character(len=256) :: dim_unlim_name ! name of the unlimited dimension in the file + integer :: index_nc if (IO_handle%open_to_write) then call MOM_error(WARNING, "open_file_type called for file "//trim(filename)//& @@ -332,6 +335,15 @@ subroutine open_file_type(IO_handle, filename, action, MOM_domain, threading, fi if (FMS2_writes .and. present(MOM_Domain)) then if (.not.associated(IO_handle%fileobj)) allocate (IO_handle%fileobj) + ! The FMS1 interface automatically appends .nc if necessary, but FMS2 interface does not. + index_nc = index(trim(filename), ".nc") + if (index_nc > 0) then + filename_tmp = trim(filename) + else + filename_tmp = trim(filename)//".nc" + if (is_root_PE()) call MOM_error(WARNING, "Open_file is appending .nc to the filename "//trim(filename)) + endif + if (file_mode == WRITEONLY_FILE) then ; mode = "write" elseif (file_mode == APPEND_FILE) then ; mode = "append" elseif (file_mode == OVERWRITE_FILE) then ; mode = "overwrite" @@ -342,9 +354,9 @@ subroutine open_file_type(IO_handle, filename, action, MOM_domain, threading, fi IO_handle%num_times = 0 IO_handle%file_time = 0.0 - if ((file_mode == APPEND_FILE) .and. file_exists(filename, MOM_Domain)) then + if ((file_mode == APPEND_FILE) .and. file_exists(filename_tmp, MOM_Domain)) then ! Determine the latest file time and number of records so far. - success = fms2_open_file(fileObj_read, trim(filename), "read", MOM_domain%mpp_domain) + success = fms2_open_file(fileObj_read, trim(filename_tmp), "read", MOM_domain%mpp_domain) call get_unlimited_dimension_name(fileObj_read, dim_unlim_name) if (len_trim(dim_unlim_name) > 0) & call get_dimension_size(fileObj_read, trim(dim_unlim_name), IO_handle%num_times) @@ -354,8 +366,8 @@ subroutine open_file_type(IO_handle, filename, action, MOM_domain, threading, fi call fms2_close_file(fileObj_read) endif - success = fms2_open_file(IO_handle%fileobj, trim(filename), trim(mode), MOM_domain%mpp_domain) - if (.not.success) call MOM_error(FATAL, "Unable to open file "//trim(filename)) + success = fms2_open_file(IO_handle%fileobj, trim(filename_tmp), trim(mode), MOM_domain%mpp_domain) + if (.not.success) call MOM_error(FATAL, "Unable to open file "//trim(filename_tmp)) IO_handle%FMS2_file = .true. elseif (present(MOM_Domain)) then call mpp_open(IO_handle%unit, filename, action=file_mode, form=NETCDF_FILE, threading=threading, & @@ -626,6 +638,7 @@ subroutine get_axis_data( axis, dat ) integer :: i + ! This routine might not be needed for MOM6. if (allocated(axis%ax_data)) then if (size(axis%ax_data) > size(dat)) call MOM_error(FATAL, & "get_axis_data called with too small of an output data array for "//trim(axis%name)) @@ -1010,6 +1023,7 @@ subroutine MOM_read_data_0d_int(filename, fieldname, data, timelevel) character(len=96) :: var_to_read ! Name of variable to read from the netcdf file logical :: success ! If true, the file was opened successfully + ! This routine might not be needed for MOM6. if (FMS2_reads) then ! Open the FMS2 file-set. success = fms2_open_file(fileObj, trim(filename), "read") @@ -1050,6 +1064,7 @@ subroutine MOM_read_data_1d_int(filename, fieldname, data, timelevel) character(len=96) :: var_to_read ! Name of variable to read from the netcdf file logical :: success ! If true, the file was opened successfully + ! This routine might not be needed for MOM6. if (FMS2_reads) then ! Open the FMS2 file-set. success = fms2_open_file(fileObj, trim(filename), "read") @@ -1741,6 +1756,7 @@ subroutine write_metadata_axis(IO_handle, axis, name, units, longname, cartesian character(len=:), allocatable :: cart ! A left-adjusted and trimmed copy of cartesian logical :: is_x, is_y, is_t ! If true, this is a domain-decomposed axis in one of the directions. integer :: position ! A flag indicating the axis staggering position. + integer :: i, isc, iec, global_size if (IO_handle%FMS2_file) then if (is_dimension_registered(IO_handle%fileobj, trim(name))) then @@ -1751,12 +1767,9 @@ subroutine write_metadata_axis(IO_handle, axis, name, units, longname, cartesian endif axis%name = trim(name) - if (present(data)) then - if (allocated(axis%ax_data)) call MOM_error(FATAL, & + if (present(data) .and. allocated(axis%ax_data)) call MOM_error(FATAL, & "Data is already allocated in a call to write_metadata_axis for axis "//& trim(name)//" in file "//trim(IO_handle%filename)) - allocate(axis%ax_data(size(data))) ; axis%ax_data(:) = data(:) - endif if (IO_handle%FMS2_file) then is_x = .false. ; is_y = .false. ; is_t = .false. @@ -1783,20 +1796,50 @@ subroutine write_metadata_axis(IO_handle, axis, name, units, longname, cartesian call register_axis(IO_handle%fileobj, trim(name), size(data)) endif + if (present(data)) then + ! With FMS2, the data for the axis labels has to match the computational domain on this PE. + if (present(domain)) then + ! The commented-out code on the next ~11 lines runs but there is missing data in the output file + ! call mpp_get_compute_domain(domain, isc, iec) + ! call mpp_get_global_domain(domain, size=global_size) + ! if (size(data) == global_size) then + ! allocate(axis%ax_data(iec+1-isc)) ; axis%ax_data(:) = data(isc:iec) + ! ! A simpler set of labels: do i=1,iec-isc ; axis%ax_data(i) = real(isc + i) - 1.0 ; enddo + ! elseif (size(data) == global_size+1) then + ! ! This is an edge axis. Note the effective SW indexing convention here. + ! allocate(axis%ax_data(iec+2-isc)) ; axis%ax_data(:) = data(isc:iec+1) + ! ! A simpler set of labels: do i=1,iec+1-isc ; axis%ax_data(i) = real(isc + i) - 1.5 ; enddo + ! else + ! call MOM_error(FATAL, "Unexpected size of data for "//trim(name)//" in write_metadata_axis.") + ! endif + + ! This works for a simple 1x1 IO layout, but gives errors for nontrivial IO layouts + allocate(axis%ax_data(size(data))) ; axis%ax_data(:) = data(:) + + else ! Store the entire array of axis labels. + allocate(axis%ax_data(size(data))) ; axis%ax_data(:) = data(:) + endif + endif + + ! Now create the variable that describes this axis. call register_field(IO_handle%fileobj, trim(name), "double", dimensions=(/name/)) - if (len_trim(units) > 0) & - call register_variable_attribute(IO_handle%fileobj, trim(name), 'units', & - trim(units), len_trim(units)) if (len_trim(longname) > 0) & call register_variable_attribute(IO_handle%fileobj, trim(name), 'long_name', & trim(longname), len_trim(longname)) + if (len_trim(units) > 0) & + call register_variable_attribute(IO_handle%fileobj, trim(name), 'units', & + trim(units), len_trim(units)) if (present(cartesian)) & call register_variable_attribute(IO_handle%fileobj, trim(name), 'cartesian_axis', & trim(cartesian), len_trim(cartesian)) if (present(sense)) & call register_variable_attribute(IO_handle%fileobj, trim(name), 'sense', sense) else + if (present(data)) then + allocate(axis%ax_data(size(data))) ; axis%ax_data(:) = data(:) + endif + call mpp_write_meta(IO_handle%unit, axis%AT, name, units, longname, cartesian=cartesian, sense=sense, & domain=domain, data=data, calendar=calendar) endif @@ -1831,12 +1874,12 @@ subroutine write_metadata_field(IO_handle, field, axes, name, units, longname, & do i=1,ndims ; dim_names(i) = trim(axes(i)%name) ; enddo prec_string = "double" ; if (present(pack)) then ; if (pack > 1) prec_string = "float" ; endif call register_field(IO_handle%fileobj, trim(name), trim(prec_string), dimensions=dim_names) - if (len_trim(units) > 0) & - call register_variable_attribute(IO_handle%fileobj, trim(name), 'units', & - trim(units), len_trim(units)) if (len_trim(longname) > 0) & call register_variable_attribute(IO_handle%fileobj, trim(name), 'long_name', & trim(longname), len_trim(longname)) + if (len_trim(units) > 0) & + call register_variable_attribute(IO_handle%fileobj, trim(name), 'units', & + trim(units), len_trim(units)) if (present(standard_name)) & call register_variable_attribute(IO_handle%fileobj, trim(name), 'standard_name', & trim(standard_name), len_trim(standard_name)) From 3f3283347cce9a3f5dce74f4126222f1904fea1c Mon Sep 17 00:00:00 2001 From: Olga Sergienko Date: Thu, 25 Mar 2021 10:21:09 -0400 Subject: [PATCH 028/112] Read from file ice flow --- src/ice_shelf/MOM_ice_shelf.F90 | 2 +- src/ice_shelf/MOM_ice_shelf_dynamics.F90 | 5 +++++ 2 files changed, 6 insertions(+), 1 deletion(-) diff --git a/src/ice_shelf/MOM_ice_shelf.F90 b/src/ice_shelf/MOM_ice_shelf.F90 index b2cb9f9c29..29a5ab5f84 100644 --- a/src/ice_shelf/MOM_ice_shelf.F90 +++ b/src/ice_shelf/MOM_ice_shelf.F90 @@ -1767,7 +1767,7 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces_in, endif endif - call register_restart_field(ISS%h_shelf, "_shelf", .true., CS%restart_CSp, & + call register_restart_field(ISS%h_shelf, "h_shelf", .true., CS%restart_CSp, & "ice sheet/shelf thickness", "m") call register_restart_field(US%m_to_Z_restart, "m_to_Z", .false., CS%restart_CSp, & "Height unit conversion factor", "Z meter-1") diff --git a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 index 8360530f21..9d86997ea9 100644 --- a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 +++ b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 @@ -538,6 +538,11 @@ subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_ call pass_var(CS%u_face_mask_bdry, G%domain) call pass_var(CS%v_face_mask_bdry, G%domain) !call init_boundary_values(CS, G, time, ISS%hmask, CS%input_flux, CS%input_thickness, new_sim) + call initialize_ice_flow_from_file(CS%u_shelf, CS%v_shelf,CS%ice_visc,CS%ground_frac, ISS%hmask,ISS%h_shelf, & + G, US, param_file) !spacially variable viscosity from a file for debugging + call pass_var(CS%ice_visc, G%domain) + call pass_var(CS%u_shelf, G%domain) + call pass_var(CS%v_shelf, G%domain) call update_velocity_masks(CS, G, ISS%hmask, CS%umask, CS%vmask, CS%u_face_mask, CS%v_face_mask) ! Register diagnostics. From ba643bde228221d07623c9a3dd3f4b71b7758854 Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Thu, 25 Mar 2021 16:19:33 -0400 Subject: [PATCH 029/112] Explicit domain decomposition of horizontal axes FMS2 restart routines expect axes to be domain-decomposed. However, the domain_write_1d function does not apply this decomposition and instead routes this operation to compressed_write_1d. In order to accommodate this, we explicitly slice the 1d arrays of any axes into its domain-decomposed segment before passing to write_data. We have also introduced a control flag to MOM's FMS2 axistype to direct MOM_write_axis when this needs to be applied. We currently apply the domain decomposition flag to all horizontal axes regardless of circumstances. For now this is probably sufficient, but may need further testing (e.g. cube sphere). --- config_src/infra/FMS2/MOM_io_infra.F90 | 16 +++++++++++++++- 1 file changed, 15 insertions(+), 1 deletion(-) diff --git a/config_src/infra/FMS2/MOM_io_infra.F90 b/config_src/infra/FMS2/MOM_io_infra.F90 index 009050985d..ddc85da570 100644 --- a/config_src/infra/FMS2/MOM_io_infra.F90 +++ b/config_src/infra/FMS2/MOM_io_infra.F90 @@ -16,6 +16,7 @@ module MOM_io_infra use fms2_io_mod, only : variable_att_exists, get_variable_attribute, get_variable_num_dimensions use fms2_io_mod, only : get_variable_dimension_names, is_dimension_registered, get_dimension_size use fms2_io_mod, only : is_dimension_unlimited, register_axis, unlimited +use fms2_io_mod, only : get_global_io_domain_indices use fms_mod, only : write_version_number, open_namelist_file, check_nml_error use fms_io_mod, only : file_exist, field_exist, field_size, read_data @@ -132,6 +133,7 @@ module MOM_io_infra character(len=256) :: name !< The name of this axis in the files. type(mpp_axistype) :: AT !< The FMS1 axis-type that this type wraps real, allocatable, dimension(:) :: ax_data !< The values of the data on the axis. + logical :: domain_decomposed = .false. !< True if axis is domain-decomposed end type axistype !> For now, these module-variables are hard-coded to exercise the new FMS2 interfaces. @@ -1726,8 +1728,16 @@ subroutine MOM_write_axis(IO_handle, axis) type(file_type), intent(in) :: IO_handle !< Handle for a file that is open for writing type(axistype), intent(in) :: axis !< An axis type variable with information to write + integer :: is, ie + if (IO_handle%FMS2_file) then - call write_data(IO_handle%fileobj, trim(axis%name), axis%ax_data) + if (axis%domain_decomposed) then + ! FMS2 does not domain-decompose 1d arrays, so we explicitly slice it + call get_global_io_domain_indices(IO_handle%fileobj, trim(axis%name), is, ie) + call write_data(IO_handle%fileobj, trim(axis%name), axis%ax_data(is:ie)) + else + call write_data(IO_handle%fileobj, trim(axis%name), axis%ax_data) + endif else call mpp_write(IO_handle%unit, axis%AT) endif @@ -1781,6 +1791,10 @@ subroutine write_metadata_axis(IO_handle, axis, name, units, longname, cartesian if ((index(cart, "T") == 1) .or. (index(cart, "t") == 1)) is_t = .true. endif + ! For now, we assume that all horizontal axes are domain-decomposed. + if (is_x .or. is_y) & + axis%domain_decomposed = .true. + if (is_x) then if (present(edge_axis)) then ; if (edge_axis) position = EAST_FACE ; endif call register_axis(IO_handle%fileobj, trim(name), 'x', domain_position=position) From 95ad9372b312476d2f741b5de38e8bf4f0cbb43e Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 26 Mar 2021 07:34:11 -0400 Subject: [PATCH 030/112] Fix distributed reads of checksums using FMS2_io Corrects reads of hexadecimal checksum attributes from distributed files when using the FMS2 IO interfaces. All answers are bitwise identical, and reads and writes of distributed sets of restart files are now working with the FMS2 IO interfaces. --- config_src/infra/FMS2/MOM_io_infra.F90 | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/config_src/infra/FMS2/MOM_io_infra.F90 b/config_src/infra/FMS2/MOM_io_infra.F90 index ddc85da570..df9d6dc7ca 100644 --- a/config_src/infra/FMS2/MOM_io_infra.F90 +++ b/config_src/infra/FMS2/MOM_io_infra.F90 @@ -484,6 +484,7 @@ subroutine get_file_fields(IO_handle, fields) character(len=256), dimension(size(fields)) :: var_names ! The names of all variables character(len=256) :: units ! The units of a variable as recorded in the file character(len=2048) :: longname ! The long-name of a variable as recorded in the file + character(len=64) :: checksum_char ! The hexadecimal checksum read from the file integer(kind=int64), dimension(3) :: checksum_file ! The checksums for a variable in the file integer :: nvar ! The number of variables in the file integer :: i @@ -503,8 +504,9 @@ subroutine get_file_fields(IO_handle, fields) fields(i)%valid_chksum = variable_att_exists(IO_handle%fileobj, var_names(i), "checksum") if (fields(i)%valid_chksum) then - call get_variable_attribute(IO_handle%fileobj, var_names(i), 'checksum', checksum_file) - fields(i)%chksum_read = checksum_file(1) + call get_variable_attribute(IO_handle%fileobj, var_names(i), 'checksum', checksum_char) + ! If there are problems, there might need to be code added to handle commas. + read (checksum_char(1:16), '(Z16)') fields(i)%chksum_read endif enddo else From c62d51f9dcbbbc2c74e48952d513b98eb62500c2 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sun, 28 Mar 2021 14:52:23 -0400 Subject: [PATCH 031/112] Remove inappropriate timelevel arguments Remove timelevel arguments from MOM_read_data calls for variables that should never have multiple time-levels. All answers are bitwise identical, and this will eliminate some warning messages in output. --- .../lateral/MOM_internal_tides.F90 | 19 +++++++++---------- .../vertical/MOM_internal_tide_input.F90 | 4 ++-- .../vertical/MOM_set_viscosity.F90 | 2 +- .../vertical/MOM_tidal_mixing.F90 | 4 ++-- 4 files changed, 14 insertions(+), 15 deletions(-) diff --git a/src/parameterizations/lateral/MOM_internal_tides.F90 b/src/parameterizations/lateral/MOM_internal_tides.F90 index 80543d5968..a862dd373d 100644 --- a/src/parameterizations/lateral/MOM_internal_tides.F90 +++ b/src/parameterizations/lateral/MOM_internal_tides.F90 @@ -2317,7 +2317,7 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) fail_if_missing=.true.) filename = trim(CS%inputdir) // trim(h2_file) call log_param(param_file, mdl, "INPUTDIR/H2_FILE", filename) - call MOM_read_data(filename, 'h2', h2, G%domain, timelevel=1, scale=US%m_to_Z) + call MOM_read_data(filename, 'h2', h2, G%domain, scale=US%m_to_Z) do j=G%jsc,G%jec ; do i=G%isc,G%iec ! Restrict rms topo to 10 percent of column depth. h2(i,j) = min(0.01*(G%bathyT(i,j))**2, h2(i,j)) @@ -2337,8 +2337,7 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) allocate(CS%refl_angle(isd:ied,jsd:jed)) ; CS%refl_angle(:,:) = CS%nullangle if (file_exists(filename, G%domain)) then call log_param(param_file, mdl, "INPUTDIR/REFL_ANGLE_FILE", filename) - call MOM_read_data(filename, 'refl_angle', CS%refl_angle, & - G%domain, timelevel=1) + call MOM_read_data(filename, 'refl_angle', CS%refl_angle, G%domain) else if (trim(refl_angle_file) /= '' ) call MOM_error(FATAL, & "REFL_ANGLE_FILE: "//trim(filename)//" not found") @@ -2357,7 +2356,7 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) allocate(CS%refl_pref(isd:ied,jsd:jed)) ; CS%refl_pref(:,:) = 1.0 if (file_exists(filename, G%domain)) then call log_param(param_file, mdl, "INPUTDIR/REFL_PREF_FILE", filename) - call MOM_read_data(filename, 'refl_pref', CS%refl_pref, G%domain, timelevel=1) + call MOM_read_data(filename, 'refl_pref', CS%refl_pref, G%domain) else if (trim(refl_pref_file) /= '' ) call MOM_error(FATAL, & "REFL_PREF_FILE: "//trim(filename)//" not found") @@ -2385,7 +2384,7 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) allocate(ridge_temp(isd:ied,jsd:jed)) ; ridge_temp(:,:) = 0.0 if (file_exists(filename, G%domain)) then call log_param(param_file, mdl, "INPUTDIR/REFL_DBL_FILE", filename) - call MOM_read_data(filename, 'refl_dbl', ridge_temp, G%domain, timelevel=1) + call MOM_read_data(filename, 'refl_dbl', ridge_temp, G%domain) else if (trim(refl_dbl_file) /= '' ) call MOM_error(FATAL, & "REFL_DBL_FILE: "//trim(filename)//" not found") @@ -2406,9 +2405,9 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) !filename = trim(CS%inputdir) // trim(land_mask_file) !call log_param(param_file, mdl, "INPUTDIR/LAND_MASK_FILE", filename) !G%mask2dCu(:,:) = 1 ; G%mask2dCv(:,:) = 1 ; G%mask2dT(:,:) = 1 - !call MOM_read_data(filename, 'land_mask', G%mask2dCu, G%domain, timelevel=1) - !call MOM_read_data(filename, 'land_mask', G%mask2dCv, G%domain, timelevel=1) - !call MOM_read_data(filename, 'land_mask', G%mask2dT, G%domain, timelevel=1) + !call MOM_read_data(filename, 'land_mask', G%mask2dCu, G%domain) + !call MOM_read_data(filename, 'land_mask', G%mask2dCv, G%domain) + !call MOM_read_data(filename, 'land_mask', G%mask2dT, G%domain) !call pass_vector(G%mask2dCu, G%mask2dCv, G%domain, To_All+Scalar_Pair, CGRID_NE) !call pass_var(G%mask2dT,G%domain) @@ -2419,7 +2418,7 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) !filename = trim(CS%inputdir) // trim(dy_Cu_file) !call log_param(param_file, mdl, "INPUTDIR/dy_Cu_FILE", filename) !G%dy_Cu(:,:) = 0.0 - !call MOM_read_data(filename, 'dy_Cu', G%dy_Cu, G%domain, timelevel=1, scale=US%m_to_L) + !call MOM_read_data(filename, 'dy_Cu', G%dy_Cu, G%domain, scale=US%m_to_L) ! Read in prescribed partial north face blockages from file (if overwriting -BDM) !call get_param(param_file, mdl, "dx_Cv_FILE", dx_Cv_file, & @@ -2428,7 +2427,7 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) !filename = trim(CS%inputdir) // trim(dx_Cv_file) !call log_param(param_file, mdl, "INPUTDIR/dx_Cv_FILE", filename) !G%dx_Cv(:,:) = 0.0 - !call MOM_read_data(filename, 'dx_Cv', G%dx_Cv, G%domain, timelevel=1, scale=US%m_to_L) + !call MOM_read_data(filename, 'dx_Cv', G%dx_Cv, G%domain, scale=US%m_to_L) !call pass_vector(G%dy_Cu, G%dx_Cv, G%domain, To_All+Scalar_Pair, CGRID_NE) ! Register maps of reflection parameters diff --git a/src/parameterizations/vertical/MOM_internal_tide_input.F90 b/src/parameterizations/vertical/MOM_internal_tide_input.F90 index 7aca829db6..0ede511eb7 100644 --- a/src/parameterizations/vertical/MOM_internal_tide_input.F90 +++ b/src/parameterizations/vertical/MOM_internal_tide_input.F90 @@ -368,7 +368,7 @@ subroutine int_tide_input_init(Time, G, GV, US, param_file, diag, CS, itide) "tidal amplitudes with INT_TIDE_DISSIPATION.", default="tideamp.nc") filename = trim(CS%inputdir) // trim(tideamp_file) call log_param(param_file, mdl, "INPUTDIR/TIDEAMP_FILE", filename) - call MOM_read_data(filename, 'tideamp', itide%tideamp, G%domain, timelevel=1, scale=US%m_s_to_L_T) + call MOM_read_data(filename, 'tideamp', itide%tideamp, G%domain, scale=US%m_s_to_L_T) endif call get_param(param_file, mdl, "H2_FILE", h2_file, & @@ -377,7 +377,7 @@ subroutine int_tide_input_init(Time, G, GV, US, param_file, diag, CS, itide) fail_if_missing=.true.) filename = trim(CS%inputdir) // trim(h2_file) call log_param(param_file, mdl, "INPUTDIR/H2_FILE", filename) - call MOM_read_data(filename, 'h2', itide%h2, G%domain, timelevel=1, scale=US%m_to_Z**2) + call MOM_read_data(filename, 'h2', itide%h2, G%domain, scale=US%m_to_Z**2) call get_param(param_file, mdl, "FRACTIONAL_ROUGHNESS_MAX", max_frac_rough, & "The maximum topographic roughness amplitude as a fraction of the mean depth, "//& diff --git a/src/parameterizations/vertical/MOM_set_viscosity.F90 b/src/parameterizations/vertical/MOM_set_viscosity.F90 index 6ff8faf2f0..99bd91d8f8 100644 --- a/src/parameterizations/vertical/MOM_set_viscosity.F90 +++ b/src/parameterizations/vertical/MOM_set_viscosity.F90 @@ -2246,7 +2246,7 @@ subroutine set_visc_init(Time, G, GV, US, param_file, diag, visc, CS, restart_CS allocate(CS%tideamp(isd:ied,jsd:jed)) ; CS%tideamp(:,:) = 0.0 filename = trim(CS%inputdir) // trim(tideamp_file) call log_param(param_file, mdl, "INPUTDIR/TIDEAMP_FILE", filename) - call MOM_read_data(filename, 'tideamp', CS%tideamp, G%domain, timelevel=1, scale=US%m_to_Z*US%T_to_s) + call MOM_read_data(filename, 'tideamp', CS%tideamp, G%domain, scale=US%m_to_Z*US%T_to_s) call pass_var(CS%tideamp,G%domain) endif endif diff --git a/src/parameterizations/vertical/MOM_tidal_mixing.F90 b/src/parameterizations/vertical/MOM_tidal_mixing.F90 index 512179445b..21eb52ebe9 100644 --- a/src/parameterizations/vertical/MOM_tidal_mixing.F90 +++ b/src/parameterizations/vertical/MOM_tidal_mixing.F90 @@ -460,7 +460,7 @@ logical function tidal_mixing_init(Time, G, GV, US, param_file, diag, CS) "tidal amplitudes with INT_TIDE_DISSIPATION.", default="tideamp.nc") filename = trim(CS%inputdir) // trim(tideamp_file) call log_param(param_file, mdl, "INPUTDIR/TIDEAMP_FILE", filename) - call MOM_read_data(filename, 'tideamp', CS%tideamp, G%domain, timelevel=1, scale=US%m_to_Z*US%T_to_s) + call MOM_read_data(filename, 'tideamp', CS%tideamp, G%domain, scale=US%m_to_Z*US%T_to_s) endif call get_param(param_file, mdl, "H2_FILE", h2_file, & @@ -469,7 +469,7 @@ logical function tidal_mixing_init(Time, G, GV, US, param_file, diag, CS) fail_if_missing=(.not.CS%use_CVMix_tidal)) filename = trim(CS%inputdir) // trim(h2_file) call log_param(param_file, mdl, "INPUTDIR/H2_FILE", filename) - call MOM_read_data(filename, 'h2', CS%h2, G%domain, timelevel=1, scale=US%m_to_Z**2) + call MOM_read_data(filename, 'h2', CS%h2, G%domain, scale=US%m_to_Z**2) call get_param(param_file, mdl, "FRACTIONAL_ROUGHNESS_MAX", max_frac_rough, & "The maximum topographic roughness amplitude as a fraction of the mean depth, "//& From 2ffea27befc617367b205d03a14d335f78250314 Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Mon, 29 Mar 2021 16:50:41 -0400 Subject: [PATCH 032/112] MOM_hor_visc: Variables moved to stack New diagnostics to horizontal_viscosity were causing issues with stack memory on some platforms, causing the runtime to more than double. Two of the diagnostics were allocatables and the other two were local variables. By redefining the two allocatables as locals (and presumably moving to stack), the faster performance was restored. While the underlying cause is unclear, this is almost certainly due to stack spill in this function, which happens to have a large number of local arrays - including many 3d arrays used to gather diagnostics - and any new variable is going to have volatile consequences. This should be seen as a short term fix. In the future, we need better tools to detect this problem and better guidance on how to responsibly use stack. Also note that two variables were removed: `max_diss_rate_[qh]`. Neither variable was used in the function. --- .../lateral/MOM_hor_visc.F90 | 80 ++++++++++--------- 1 file changed, 41 insertions(+), 39 deletions(-) diff --git a/src/parameterizations/lateral/MOM_hor_visc.F90 b/src/parameterizations/lateral/MOM_hor_visc.F90 index 5bbc495e93..661fb715e7 100644 --- a/src/parameterizations/lateral/MOM_hor_visc.F90 +++ b/src/parameterizations/lateral/MOM_hor_visc.F90 @@ -277,10 +277,6 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, grad_d2vel_mag_h, & ! Magnitude of the Laplacian of the velocity vector, squared [L-2 T-2 ~> m-2 s-2] boundary_mask_h ! A mask that zeroes out cells with at least one land edge [nondim] - real, allocatable, dimension(:,:) :: hf_diffu_2d, hf_diffv_2d ! Depth sum of hf_diffu, hf_diffv [L T-2 ~> m s-2] - real, dimension(SZIB_(G),SZJ_(G)) :: intz_diffu_2d ! Depth-integral of diffu [L2 T-2 ~> m2 s-2] - real, dimension(SZI_(G),SZJB_(G)) :: intz_diffv_2d ! Depth-integral of diffv [L2 T-2 ~> m2 s-2] - real, dimension(SZIB_(G),SZJB_(G)) :: & dvdx, dudy, & ! components in the shearing strain [T-1 ~> s-1] dDel2vdx, dDel2udy, & ! Components in the biharmonic equivalent of the shearing strain [L-2 T-1 ~> m-2 s-1] @@ -309,7 +305,6 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, vort_xy_q, & ! vertical vorticity at corner points [T-1 ~> s-1] sh_xy_q, & ! horizontal shearing strain at corner points [T-1 ~> s-1] GME_coeff_q, & !< GME coeff. at q-points [L2 T-1 ~> m2 s-1] - max_diss_rate_q, & ! maximum possible energy dissipated by lateral friction [L2 T-3 ~> m2 s-3] ShSt ! A diagnostic array of shear stress [T-1 ~> s-1]. real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1) :: & KH_u_GME !< interface height diffusivities in u-columns [L2 T-1 ~> m2 s-1] @@ -318,7 +313,6 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: & Ah_h, & ! biharmonic viscosity at thickness points [L4 T-1 ~> m4 s-1] Kh_h, & ! Laplacian viscosity at thickness points [L2 T-1 ~> m2 s-1] - max_diss_rate_h, & ! maximum possible energy dissipated by lateral friction [L2 T-3 ~> m2 s-3] FrictWork, & ! work done by MKE dissipation mechanisms [R L2 T-3 ~> W m-2] FrictWork_GME, & ! work done by GME [R L2 T-3 ~> W m-2] div_xx_h, & ! horizontal divergence [T-1 ~> s-1] @@ -389,6 +383,14 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, hrat_min, & ! h_min divided by the thickness at the stress point (h or q) [nondim] visc_bound_rem ! fraction of overall viscous bounds that remain to be applied [nondim] + real, dimension(SZIB_(G),SZJ_(G)) :: & + hf_diffu_2d, & ! Depth sum of hf_diffu, hf_diffv [L T-2 ~> m s-2] + intz_diffu_2d ! Depth-integral of diffu [L2 T-2 ~> m2 s-2] + + real, dimension(SZI_(G),SZJB_(G)) :: & + hf_diffv_2d, & ! Depth sum of hf_diffu, hf_diffv [L T-2 ~> m s-2] + intz_diffv_2d ! Depth-integral of diffv [L2 T-2 ~> m2 s-2] + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB @@ -505,8 +507,7 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, !$OMP use_MEKE_Ku, use_MEKE_Au, boundary_mask_h, boundary_mask_q, & !$OMP backscat_subround, GME_coeff_limiter, & !$OMP h_neglect, h_neglect3, FWfrac, inv_PI3, inv_PI6, H0_GME, & - !$OMP diffu, diffv, max_diss_rate_h, max_diss_rate_q, & - !$OMP Kh_h, Kh_q, Ah_h, Ah_q, FrictWork, FrictWork_GME, & + !$OMP diffu, diffv, Kh_h, Kh_q, Ah_h, Ah_q, FrictWork, FrictWork_GME, & !$OMP div_xx_h, sh_xx_h, vort_xy_q, sh_xy_q, GME_coeff_h, GME_coeff_q, & !$OMP TD, KH_u_GME, KH_v_GME, grid_Re_Kh, grid_Re_Ah, NoSt, ShSt & !$OMP ) & @@ -1645,38 +1646,39 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, ! enddo ; enddo ; enddo ! call post_data(CS%id_hf_diffv, CS%hf_diffv, CS%diag) !endif - if (present(ADp) .and. (CS%id_hf_diffu_2d > 0)) then - allocate(hf_diffu_2d(G%IsdB:G%IedB,G%jsd:G%jed)) - hf_diffu_2d(:,:) = 0.0 - do k=1,nz ; do j=js,je ; do I=Isq,Ieq - hf_diffu_2d(I,j) = hf_diffu_2d(I,j) + diffu(I,j,k) * ADp%diag_hfrac_u(I,j,k) - enddo ; enddo ; enddo - call post_data(CS%id_hf_diffu_2d, hf_diffu_2d, CS%diag) - deallocate(hf_diffu_2d) - endif - if (present(ADp) .and. (CS%id_hf_diffv_2d > 0)) then - allocate(hf_diffv_2d(G%isd:G%ied,G%JsdB:G%JedB)) - hf_diffv_2d(:,:) = 0.0 - do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie - hf_diffv_2d(i,J) = hf_diffv_2d(i,J) + diffv(i,J,k) * ADp%diag_hfrac_v(i,J,k) - enddo ; enddo ; enddo - call post_data(CS%id_hf_diffv_2d, hf_diffv_2d, CS%diag) - deallocate(hf_diffv_2d) - endif - if (present(ADp) .and. (CS%id_intz_diffu_2d > 0)) then - intz_diffu_2d(:,:) = 0.0 - do k=1,nz ; do j=js,je ; do I=Isq,Ieq - intz_diffu_2d(I,j) = intz_diffu_2d(I,j) + diffu(I,j,k) * ADp%diag_hu(I,j,k) - enddo ; enddo ; enddo - call post_data(CS%id_intz_diffu_2d, intz_diffu_2d, CS%diag) - endif - if (present(ADp) .and. (CS%id_intz_diffv_2d > 0)) then - intz_diffv_2d(:,:) = 0.0 - do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie - intz_diffv_2d(i,J) = intz_diffv_2d(i,J) + diffv(i,J,k) * ADp%diag_hv(i,J,k) - enddo ; enddo ; enddo - call post_data(CS%id_intz_diffv_2d, intz_diffv_2d, CS%diag) + if (present(ADp)) then + if (CS%id_hf_diffu_2d > 0) then + hf_diffu_2d(:,:) = 0.0 + do k=1,nz ; do j=js,je ; do I=Isq,Ieq + hf_diffu_2d(I,j) = hf_diffu_2d(I,j) + diffu(I,j,k) * ADp%diag_hfrac_u(I,j,k) + enddo ; enddo ; enddo + call post_data(CS%id_hf_diffu_2d, hf_diffu_2d, CS%diag) + endif + + if (CS%id_hf_diffv_2d > 0) then + hf_diffv_2d(:,:) = 0.0 + do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie + hf_diffv_2d(i,J) = hf_diffv_2d(i,J) + diffv(i,J,k) * ADp%diag_hfrac_v(i,J,k) + enddo ; enddo ; enddo + call post_data(CS%id_hf_diffv_2d, hf_diffv_2d, CS%diag) + endif + + if (CS%id_intz_diffu_2d > 0) then + intz_diffu_2d(:,:) = 0.0 + do k=1,nz ; do j=js,je ; do I=Isq,Ieq + intz_diffu_2d(I,j) = intz_diffu_2d(I,j) + diffu(I,j,k) * ADp%diag_hu(I,j,k) + enddo ; enddo ; enddo + call post_data(CS%id_intz_diffu_2d, intz_diffu_2d, CS%diag) + endif + + if (CS%id_intz_diffv_2d > 0) then + intz_diffv_2d(:,:) = 0.0 + do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie + intz_diffv_2d(i,J) = intz_diffv_2d(i,J) + diffv(i,J,k) * ADp%diag_hv(i,J,k) + enddo ; enddo ; enddo + call post_data(CS%id_intz_diffv_2d, intz_diffv_2d, CS%diag) + endif endif end subroutine horizontal_viscosity From cfa59aab1e3f51ec0cfa204eb79869fc9d361f96 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 31 Mar 2021 18:27:28 -0400 Subject: [PATCH 033/112] +Add coupler_types interfaces needed by SIS2 Added additional wrappers to the MOM6 framework and MOM_couplertype_infra for coupler_types routines and types that are needed by SIS2. These include support for the use of a coupler_3d_bc_type, including as overloads to the existing coupler_type_spawn, coupler_type_copy_data, coupler_type_increment_data, coupler_type_initialized and coupler_type_write_chksums. There are also new overloaded wrappers in all three files for coupler_type_redistribute_data, coupler_type_data_override, coupler_type_rescale_data. All answers are bitwise identical. --- .../infra/FMS1/MOM_couplertype_infra.F90 | 291 ++++++++++++++++-- .../infra/FMS2/MOM_couplertype_infra.F90 | 291 ++++++++++++++++-- src/framework/MOM_coupler_types.F90 | 289 ++++++++++++++++- 3 files changed, 818 insertions(+), 53 deletions(-) diff --git a/config_src/infra/FMS1/MOM_couplertype_infra.F90 b/config_src/infra/FMS1/MOM_couplertype_infra.F90 index fd947691ca..2d6698b640 100644 --- a/config_src/infra/FMS1/MOM_couplertype_infra.F90 +++ b/config_src/infra/FMS1/MOM_couplertype_infra.F90 @@ -4,33 +4,36 @@ module MOM_couplertype_infra ! This file is part of MOM6. See LICENSE.md for the license. use coupler_types_mod, only : coupler_type_spawn, coupler_type_initialized, coupler_type_destructor -use coupler_types_mod, only : coupler_type_set_diags, coupler_type_send_data -use coupler_types_mod, only : coupler_type_write_chksums -use coupler_types_mod, only : coupler_type_copy_data, coupler_type_increment_data +use coupler_types_mod, only : coupler_type_set_diags, coupler_type_send_data, coupler_type_copy_data +use coupler_types_mod, only : coupler_type_write_chksums, coupler_type_redistribute_data +use coupler_types_mod, only : coupler_type_increment_data, coupler_type_rescale_data use coupler_types_mod, only : coupler_type_extract_data, coupler_type_set_data +use coupler_types_mod, only : coupler_type_data_override use coupler_types_mod, only : ind_flux, ind_alpha, ind_csurf -use coupler_types_mod, only : coupler_1d_bc_type, coupler_2d_bc_type +use coupler_types_mod, only : coupler_1d_bc_type, coupler_2d_bc_type, coupler_3d_bc_type use atmos_ocean_fluxes_mod, only : aof_set_coupler_flux +use MOM_domain_infra, only : domain2D use MOM_time_manager, only : time_type implicit none ; private public :: CT_spawn, CT_initialized, CT_destructor -public :: CT_set_diags, CT_send_data, CT_write_chksums -public :: CT_set_data, CT_increment_data -public :: CT_copy_data, CT_extract_data +public :: CT_set_diags, CT_send_data, CT_data_override, CT_write_chksums +public :: CT_set_data, CT_increment_data, CT_rescale_data +public :: CT_copy_data, CT_extract_data, CT_redistribute_data public :: atmos_ocn_coupler_flux public :: ind_flux, ind_alpha, ind_csurf -public :: coupler_1d_bc_type, coupler_2d_bc_type +public :: coupler_1d_bc_type, coupler_2d_bc_type, coupler_3d_bc_type !> This is the interface to spawn one coupler_bc_type into another. interface CT_spawn - module procedure CT_spawn_1d_2d, CT_spawn_2d_2d + module procedure CT_spawn_1d_2d, CT_spawn_1d_3d, CT_spawn_2d_2d, CT_spawn_2d_3d + module procedure CT_spawn_3d_2d, CT_spawn_3d_3d end interface CT_spawn !> This function interface indicates whether a coupler_bc_type has been initialized. interface CT_initialized - module procedure CT_initialized_1d, CT_initialized_2d + module procedure CT_initialized_1d, CT_initialized_2d, CT_initialized_3d end interface CT_initialized !> This is the interface to deallocate any data associated with a coupler_bc_type. @@ -38,6 +41,35 @@ module MOM_couplertype_infra module procedure CT_destructor_1d, CT_destructor_2d end interface CT_destructor +!> Copy all elements of the data in of one coupler_2d_bc_type or coupler_3d_bc_type +!! into another. Both must have the same array sizes in common dimensions. +interface CT_copy_data + module procedure CT_copy_data_2d, CT_copy_data_3d, CT_copy_data_2d_3d +end interface CT_copy_data + +!> Increment data in all elements of one coupler_2d_bc_type or coupler_3d_bc_type with +!! the data from another. Both must have the same array sizes and rank. +interface CT_increment_data + module procedure CT_increment_data_2d, CT_increment_data_3d, CT_increment_data_2d_3d +end interface CT_increment_data + +!> Rescales the fields in the elements of a coupler_2d_bc_type by multiplying by a factor scale. +!! If scale is 0, this is a direct assignment to 0, so that NaNs will not persist. +interface CT_rescale_data + module procedure CT_rescale_data_2d, CT_rescale_data_3d +end interface CT_rescale_data + +!> Redistribute the data in all elements of one coupler_2d_bc_type or coupler_3d_bc_type into +!! another, which may be on different processors with a different decomposition. +interface CT_redistribute_data + module procedure CT_redistribute_data_2d, CT_redistribute_data_3d +end interface CT_redistribute_data + +!> Write out checksums for the elements of a coupler_2d_bc_type or coupler_3d_bc_type +interface CT_write_chksums + module procedure CT_write_chksums_2d, CT_write_chksums_3d +end interface CT_write_chksums + contains !> This subroutine sets many of the parameters for calculating an atmosphere-ocean tracer flux @@ -83,6 +115,24 @@ subroutine CT_spawn_1d_2d(var_in, var, idim, jdim, suffix, as_needed) end subroutine CT_spawn_1d_2d +!> Generate a 3-D coupler type using a 1-D coupler type as a template. +subroutine CT_spawn_1d_3d(var_in, var, idim, jdim, kdim, suffix, as_needed) + type(coupler_1d_bc_type), intent(in) :: var_in !< structure from which to copy information + type(coupler_3d_bc_type), intent(inout) :: var !< structure into which to copy information + integer, dimension(4), intent(in) :: idim !< The data and computational domain extents of + !! the first dimension in a non-decreasing list + integer, dimension(4), intent(in) :: jdim !< The data and computational domain extents of + !! the second dimension in a non-decreasing list + integer, dimension(2), intent(in) :: kdim !< The array extents of the third dimension in + !! a non-decreasing list + character(len=*), optional, intent(in) :: suffix !< optional suffix to make the name identifier unique + logical, optional, intent(in) :: as_needed !< Only do the spawn if the target type (var) + !! is not set and the parent type (var_in) is set. + + call coupler_type_spawn(var_in, var, idim, jdim, kdim, suffix=suffix, as_needed=as_needed) + +end subroutine CT_spawn_1d_3d + !> Generate one 2-D coupler type using another 2-D coupler type as a template. subroutine CT_spawn_2d_2d(var_in, var, idim, jdim, suffix, as_needed) type(coupler_2d_bc_type), intent(in) :: var_in !< structure from which to copy information @@ -99,8 +149,60 @@ subroutine CT_spawn_2d_2d(var_in, var, idim, jdim, suffix, as_needed) end subroutine CT_spawn_2d_2d +!> Generate a 3-D coupler type using a 2-D coupler type as a template. +subroutine CT_spawn_2d_3d(var_in, var, idim, jdim, kdim, suffix, as_needed) + type(coupler_2d_bc_type), intent(in) :: var_in !< structure from which to copy information + type(coupler_3d_bc_type), intent(inout) :: var !< structure into which to copy information + integer, dimension(4), intent(in) :: idim !< The data and computational domain extents of + !! the first dimension in a non-decreasing list + integer, dimension(4), intent(in) :: jdim !< The data and computational domain extents of + !! the second dimension in a non-decreasing list + integer, dimension(2), intent(in) :: kdim !< The array extents of the third dimension in + !! a non-decreasing list + character(len=*), optional, intent(in) :: suffix !< optional suffix to make the name identifier unique + logical, optional, intent(in) :: as_needed !< Only do the spawn if the target type (var) + !! is not set and the parent type (var_in) is set. + + call coupler_type_spawn(var_in, var, idim, jdim, kdim, suffix=suffix, as_needed=as_needed) + +end subroutine CT_spawn_2d_3d + +!> Generate a 2-D coupler type using a 3-D coupler type as a template. +subroutine CT_spawn_3d_2d(var_in, var, idim, jdim, suffix, as_needed) + type(coupler_3d_bc_type), intent(in) :: var_in !< structure from which to copy information + type(coupler_2d_bc_type), intent(inout) :: var !< structure into which to copy information + integer, dimension(4), intent(in) :: idim !< The data and computational domain extents of + !! the first dimension in a non-decreasing list + integer, dimension(4), intent(in) :: jdim !< The data and computational domain extents of + !! the second dimension in a non-decreasing list + character(len=*), optional, intent(in) :: suffix !< optional suffix to make the name identifier unique + logical, optional, intent(in) :: as_needed !< Only do the spawn if the target type (var) + !! is not set and the parent type (var_in) is set. + + call coupler_type_spawn(var_in, var, idim, jdim, suffix=suffix, as_needed=as_needed) + +end subroutine CT_spawn_3d_2d + +!> Generate a 3-D coupler type using another 3-D coupler type as a template. +subroutine CT_spawn_3d_3d(var_in, var, idim, jdim, kdim, suffix, as_needed) + type(coupler_3d_bc_type), intent(in) :: var_in !< structure from which to copy information + type(coupler_3d_bc_type), intent(inout) :: var !< structure into which to copy information + integer, dimension(4), intent(in) :: idim !< The data and computational domain extents of + !! the first dimension in a non-decreasing list + integer, dimension(4), intent(in) :: jdim !< The data and computational domain extents of + !! the second dimension in a non-decreasing list + integer, dimension(2), intent(in) :: kdim !< The array extents of the third dimension in + !! a non-decreasing list + character(len=*), optional, intent(in) :: suffix !< optional suffix to make the name identifier unique + logical, optional, intent(in) :: as_needed !< Only do the spawn if the target type (var) + !! is not set and the parent type (var_in) is set. + + call coupler_type_spawn(var_in, var, idim, jdim, kdim, suffix=suffix, as_needed=as_needed) + +end subroutine CT_spawn_3d_3d + !> Copy all elements of the data in of one coupler_2d_bc_type into another. Both must have the same array sizes. -subroutine CT_copy_data(var_in, var, halo_size, bc_index, field_index, & +subroutine CT_copy_data_2d(var_in, var, halo_size, bc_index, field_index, & exclude_flux_type, only_flux_type, pass_through_ice) type(coupler_2d_bc_type), intent(in) :: var_in !< BC_type structure with the data to copy type(coupler_2d_bc_type), intent(inout) :: var !< The recipient BC_type structure @@ -118,11 +220,59 @@ subroutine CT_copy_data(var_in, var, halo_size, bc_index, field_index, & call coupler_type_copy_data(var_in, var, halo_size, bc_index, field_index, & exclude_flux_type, only_flux_type, pass_through_ice) -end subroutine CT_copy_data +end subroutine CT_copy_data_2d + +!> Copy all elements of the data in of one coupler_3d_bc_type into another. Both must have the same array sizes. +subroutine CT_copy_data_3d(var_in, var, halo_size, bc_index, field_index, & + exclude_flux_type, only_flux_type, pass_through_ice) + type(coupler_3d_bc_type), intent(in) :: var_in !< BC_type structure with the data to copy + type(coupler_3d_bc_type), intent(inout) :: var !< The recipient BC_type structure + integer, optional, intent(in) :: halo_size !< The extent of the halo to copy; 0 by default + integer, optional, intent(in) :: bc_index !< The index of the boundary condition + !! that is being copied + integer, optional, intent(in) :: field_index !< The index of the field in the + !! boundary condition that is being copied + character(len=*), optional, intent(in) :: exclude_flux_type !< A string describing which types of fluxes + !! to exclude from this copy. + character(len=*), optional, intent(in) :: only_flux_type !< A string describing which types of fluxes + !! to include from this copy. + logical, optional, intent(in) :: pass_through_ice !< If true, only copy BCs whose + !! value of pass_through ice matches this + + call coupler_type_copy_data(var_in, var, halo_size, bc_index, field_index, & + exclude_flux_type, only_flux_type, pass_through_ice) +end subroutine CT_copy_data_3d + +!> Copy all elements of the data in a coupler_2d_bc_type into a coupler_3d_bc_type. +!! Both must have the same array sizes for the first two dimensions, while the extent +!! of the 3rd dimension that is being filled may be specified via optional arguments. +subroutine CT_copy_data_2d_3d(var_in, var, halo_size, bc_index, field_index, & + exclude_flux_type, only_flux_type, pass_through_ice, ind3_start, ind3_end) + type(coupler_2d_bc_type), intent(in) :: var_in !< BC_type structure with the data to copy + type(coupler_3d_bc_type), intent(inout) :: var !< The recipient BC_type structure + integer, optional, intent(in) :: halo_size !< The extent of the halo to copy; 0 by default + integer, optional, intent(in) :: bc_index !< The index of the boundary condition + !! that is being copied + integer, optional, intent(in) :: field_index !< The index of the field in the + !! boundary condition that is being copied + character(len=*), optional, intent(in) :: exclude_flux_type !< A string describing which types of fluxes + !! to exclude from this copy. + character(len=*), optional, intent(in) :: only_flux_type !< A string describing which types of fluxes + !! to include from this copy. + logical, optional, intent(in) :: pass_through_ice !< If true, only copy BCs whose + !! value of pass_through ice matches this + integer, optional, intent(in) :: ind3_start !< The starting value of the 3rd + !! index of the 3d type to fill in. + integer, optional, intent(in) :: ind3_end !< The ending value of the 3rd + !! index of the 3d type to fill in. + + call coupler_type_copy_data(var_in, var, halo_size, bc_index, field_index, & + exclude_flux_type, only_flux_type, pass_through_ice, ind3_start, ind3_end) +end subroutine CT_copy_data_2d_3d !> Increment data in all elements of one coupler_2d_bc_type with the data from another. Both !! must have the same array sizes. -subroutine CT_increment_data(var_in, var, halo_size, scale_factor, scale_prev) +subroutine CT_increment_data_2d(var_in, var, halo_size, scale_factor, scale_prev) type(coupler_2d_bc_type), intent(in) :: var_in !< coupler_type structure with the data to add to the other type type(coupler_2d_bc_type), intent(inout) :: var !< The coupler_type structure whose fields are being incremented integer, optional, intent(in) :: halo_size !< The extent of the halo to increment; 0 by default @@ -132,11 +282,90 @@ subroutine CT_increment_data(var_in, var, halo_size, scale_factor, scale_prev) call coupler_type_increment_data(var_in, var, halo_size=halo_size, scale_factor=scale_factor, & scale_prev=scale_prev) -end subroutine CT_increment_data +end subroutine CT_increment_data_2d + +!> Increment data in all elements of one coupler_3d_bc_type with the data from another. Both +!! must have the same array sizes. +subroutine CT_increment_data_3d(var_in, var, halo_size, scale_factor, scale_prev, exclude_flux_type, only_flux_type) + type(coupler_3d_bc_type), intent(in) :: var_in !< coupler_type structure with the data to add to the other type + type(coupler_3d_bc_type), intent(inout) :: var !< The coupler_type structure whose fields are being incremented + integer, optional, intent(in) :: halo_size !< The extent of the halo to increment; 0 by default + real, optional, intent(in) :: scale_factor !< A scaling factor for the data that is being added + real, optional, intent(in) :: scale_prev !< A scaling factor for the data that is already here + character(len=*), optional, intent(in) :: exclude_flux_type !< A string describing which types + !! of fluxes to exclude from this increment. + character(len=*), optional, intent(in) :: only_flux_type !< A string describing which types + !! of fluxes to include from this increment. + + call coupler_type_increment_data(var_in, var, halo_size=halo_size, scale_factor=scale_factor, & + scale_prev=scale_prev, exclude_flux_type=exclude_flux_type, & + only_flux_type=only_flux_type) + +end subroutine CT_increment_data_3d + +!> Rescales the fields in the elements of a coupler_2d_bc_type by multiplying by a factor scale. +!! If scale is 0, this is a direct assignment to 0, so that NaNs will not persist. +subroutine CT_rescale_data_2d(var, scale) + type(coupler_2d_bc_type), intent(inout) :: var !< The BC_type structure whose fields are being rescaled + real, intent(in) :: scale !< A scaling factor to multiply fields by + + call coupler_type_rescale_data(var, scale) + +end subroutine CT_rescale_data_2d + +!> Rescales the fields in the elements of a coupler_3d_bc_type by multiplying by a factor scale. +!! If scale is 0, this is a direct assignment to 0, so that NaNs will not persist. +subroutine CT_rescale_data_3d(var, scale) + type(coupler_3d_bc_type), intent(inout) :: var !< The BC_type structure whose fields are being rescaled + real, intent(in) :: scale !< A scaling factor to multiply fields by + + call coupler_type_rescale_data(var, scale) + +end subroutine CT_rescale_data_3d + +!> Increment data in the elements of a coupler_2d_bc_type with weighted averages of elements of a +!! coupler_3d_bc_type +subroutine CT_increment_data_2d_3d(var_in, weights, var, halo_size) + type(coupler_3d_bc_type), intent(in) :: var_in !< coupler_type structure with the data to add to the other type + real, dimension(:,:,:), intent(in) :: weights !< An array of normalized weights for the 3d-data to + !! increment the 2d-data. There is no renormalization, + !! so if the weights do not sum to 1 in the 3rd dimension + !! there may be adverse consequences! + type(coupler_2d_bc_type), intent(inout) :: var !< The coupler_type structure whose fields are being incremented + integer, optional, intent(in) :: halo_size !< The extent of the halo to increment; 0 by default + + call coupler_type_increment_data(var_in, weights, var, halo_size=halo_size) + +end subroutine CT_increment_data_2d_3d + + +!> Redistribute the data in all elements of one coupler_2d_bc_type into another, which may be on +!! different processors with a different decomposition. +subroutine CT_redistribute_data_2d(var_in, domain_in, var_out, domain_out, complete) + type(coupler_2d_bc_type), intent(in) :: var_in !< BC_type structure with the data to copy + type(domain2D), intent(in) :: domain_in !< The FMS domain for the input structure + type(coupler_2d_bc_type), intent(inout) :: var_out !< The recipient BC_type structure (data intent out) + type(domain2D), intent(in) :: domain_out !< The FMS domain for the output structure + logical, optional, intent(in) :: complete !< If true, complete the updates + + call coupler_type_redistribute_data(var_in, domain_in, var_out, domain_out, complete) +end subroutine CT_redistribute_data_2d + +!> Redistribute the data in all elements of one coupler_3d_bc_type into another, which may be on +!! different processors with a different decomposition. +subroutine CT_redistribute_data_3d(var_in, domain_in, var_out, domain_out, complete) + type(coupler_3d_bc_type), intent(in) :: var_in !< BC_type structure with the data to copy + type(domain2D), intent(in) :: domain_in !< The FMS domain for the input structure + type(coupler_3d_bc_type), intent(inout) :: var_out !< The recipient BC_type structure (data intent out) + type(domain2D), intent(in) :: domain_out !< The FMS domain for the output structure + logical, optional, intent(in) :: complete !< If true, complete the updates + + call coupler_type_redistribute_data(var_in, domain_in, var_out, domain_out, complete) +end subroutine CT_redistribute_data_3d !> Extract a 2d field from a coupler_2d_bc_type into a two-dimensional array. subroutine CT_extract_data(var_in, bc_index, field_index, array_out, & - scale_factor, halo_size, idim, jdim) + scale_factor, halo_size, idim, jdim) type(coupler_2d_bc_type), intent(in) :: var_in !< BC_type structure with the data to extract integer, intent(in) :: bc_index !< The index of the boundary condition !! that is being copied @@ -160,7 +389,7 @@ end subroutine CT_extract_data !> Set single 2d field in coupler_2d_bc_type from a two-dimensional array. subroutine CT_set_data(array_in, bc_index, field_index, var, & - scale_factor, halo_size, idim, jdim) + scale_factor, halo_size, idim, jdim) real, dimension(1:,1:), intent(in) :: array_in !< The source array for the field; its size !! must match the size of the data being copied !! unless idim and jdim are supplied. @@ -185,6 +414,15 @@ subroutine CT_set_data(array_in, bc_index, field_index, var, & end subroutine CT_set_data +!> Potentially override the values in a coupler_2d_bc_type +subroutine CT_data_override(gridname, var, time) + character(len=3), intent(in) :: gridname !< 3-character long model grid ID + type(coupler_2d_bc_type), intent(inout) :: var !< BC_type structure to override + type(time_type), intent(in) :: time !< The current model time + + call coupler_type_data_override(gridname, var, time) +end subroutine CT_data_override + !> Register the diagnostics of a coupler_2d_bc_type subroutine CT_set_diags(var, diag_name, axes, time) type(coupler_2d_bc_type), intent(inout) :: var !< BC_type structure for which to register diagnostics @@ -205,14 +443,24 @@ subroutine CT_send_data(var, Time) end subroutine CT_send_data !> Write out checksums for the elements of a coupler_2d_bc_type -subroutine CT_write_chksums(var, outunit, name_lead) +subroutine CT_write_chksums_2d(var, outunit, name_lead) type(coupler_2d_bc_type), intent(in) :: var !< BC_type structure for which to register diagnostics integer, intent(in) :: outunit !< The index of a open output file character(len=*), optional, intent(in) :: name_lead !< An optional prefix for the variable names call coupler_type_write_chksums(var, outunit, name_lead) -end subroutine CT_write_chksums +end subroutine CT_write_chksums_2d + +!> Write out checksums for the elements of a coupler_3d_bc_type +subroutine CT_write_chksums_3d(var, outunit, name_lead) + type(coupler_3d_bc_type), intent(in) :: var !< BC_type structure for which to register diagnostics + integer, intent(in) :: outunit !< The index of a open output file + character(len=*), optional, intent(in) :: name_lead !< An optional prefix for the variable names + + call coupler_type_write_chksums(var, outunit, name_lead) + +end subroutine CT_write_chksums_3d !> Indicate whether a coupler_1d_bc_type has been initialized. logical function CT_initialized_1d(var) @@ -228,6 +476,13 @@ logical function CT_initialized_2d(var) CT_initialized_2d = coupler_type_initialized(var) end function CT_initialized_2d +!> Indicate whether a coupler_3d_bc_type has been initialized. +logical function CT_initialized_3d(var) + type(coupler_3d_bc_type), intent(in) :: var !< BC_type structure to be deconstructed + + CT_initialized_3d = coupler_type_initialized(var) +end function CT_initialized_3d + !> Deallocate all data associated with a coupler_1d_bc_type subroutine CT_destructor_1d(var) type(coupler_1d_bc_type), intent(inout) :: var !< BC_type structure to be deconstructed diff --git a/config_src/infra/FMS2/MOM_couplertype_infra.F90 b/config_src/infra/FMS2/MOM_couplertype_infra.F90 index fd947691ca..2d6698b640 100644 --- a/config_src/infra/FMS2/MOM_couplertype_infra.F90 +++ b/config_src/infra/FMS2/MOM_couplertype_infra.F90 @@ -4,33 +4,36 @@ module MOM_couplertype_infra ! This file is part of MOM6. See LICENSE.md for the license. use coupler_types_mod, only : coupler_type_spawn, coupler_type_initialized, coupler_type_destructor -use coupler_types_mod, only : coupler_type_set_diags, coupler_type_send_data -use coupler_types_mod, only : coupler_type_write_chksums -use coupler_types_mod, only : coupler_type_copy_data, coupler_type_increment_data +use coupler_types_mod, only : coupler_type_set_diags, coupler_type_send_data, coupler_type_copy_data +use coupler_types_mod, only : coupler_type_write_chksums, coupler_type_redistribute_data +use coupler_types_mod, only : coupler_type_increment_data, coupler_type_rescale_data use coupler_types_mod, only : coupler_type_extract_data, coupler_type_set_data +use coupler_types_mod, only : coupler_type_data_override use coupler_types_mod, only : ind_flux, ind_alpha, ind_csurf -use coupler_types_mod, only : coupler_1d_bc_type, coupler_2d_bc_type +use coupler_types_mod, only : coupler_1d_bc_type, coupler_2d_bc_type, coupler_3d_bc_type use atmos_ocean_fluxes_mod, only : aof_set_coupler_flux +use MOM_domain_infra, only : domain2D use MOM_time_manager, only : time_type implicit none ; private public :: CT_spawn, CT_initialized, CT_destructor -public :: CT_set_diags, CT_send_data, CT_write_chksums -public :: CT_set_data, CT_increment_data -public :: CT_copy_data, CT_extract_data +public :: CT_set_diags, CT_send_data, CT_data_override, CT_write_chksums +public :: CT_set_data, CT_increment_data, CT_rescale_data +public :: CT_copy_data, CT_extract_data, CT_redistribute_data public :: atmos_ocn_coupler_flux public :: ind_flux, ind_alpha, ind_csurf -public :: coupler_1d_bc_type, coupler_2d_bc_type +public :: coupler_1d_bc_type, coupler_2d_bc_type, coupler_3d_bc_type !> This is the interface to spawn one coupler_bc_type into another. interface CT_spawn - module procedure CT_spawn_1d_2d, CT_spawn_2d_2d + module procedure CT_spawn_1d_2d, CT_spawn_1d_3d, CT_spawn_2d_2d, CT_spawn_2d_3d + module procedure CT_spawn_3d_2d, CT_spawn_3d_3d end interface CT_spawn !> This function interface indicates whether a coupler_bc_type has been initialized. interface CT_initialized - module procedure CT_initialized_1d, CT_initialized_2d + module procedure CT_initialized_1d, CT_initialized_2d, CT_initialized_3d end interface CT_initialized !> This is the interface to deallocate any data associated with a coupler_bc_type. @@ -38,6 +41,35 @@ module MOM_couplertype_infra module procedure CT_destructor_1d, CT_destructor_2d end interface CT_destructor +!> Copy all elements of the data in of one coupler_2d_bc_type or coupler_3d_bc_type +!! into another. Both must have the same array sizes in common dimensions. +interface CT_copy_data + module procedure CT_copy_data_2d, CT_copy_data_3d, CT_copy_data_2d_3d +end interface CT_copy_data + +!> Increment data in all elements of one coupler_2d_bc_type or coupler_3d_bc_type with +!! the data from another. Both must have the same array sizes and rank. +interface CT_increment_data + module procedure CT_increment_data_2d, CT_increment_data_3d, CT_increment_data_2d_3d +end interface CT_increment_data + +!> Rescales the fields in the elements of a coupler_2d_bc_type by multiplying by a factor scale. +!! If scale is 0, this is a direct assignment to 0, so that NaNs will not persist. +interface CT_rescale_data + module procedure CT_rescale_data_2d, CT_rescale_data_3d +end interface CT_rescale_data + +!> Redistribute the data in all elements of one coupler_2d_bc_type or coupler_3d_bc_type into +!! another, which may be on different processors with a different decomposition. +interface CT_redistribute_data + module procedure CT_redistribute_data_2d, CT_redistribute_data_3d +end interface CT_redistribute_data + +!> Write out checksums for the elements of a coupler_2d_bc_type or coupler_3d_bc_type +interface CT_write_chksums + module procedure CT_write_chksums_2d, CT_write_chksums_3d +end interface CT_write_chksums + contains !> This subroutine sets many of the parameters for calculating an atmosphere-ocean tracer flux @@ -83,6 +115,24 @@ subroutine CT_spawn_1d_2d(var_in, var, idim, jdim, suffix, as_needed) end subroutine CT_spawn_1d_2d +!> Generate a 3-D coupler type using a 1-D coupler type as a template. +subroutine CT_spawn_1d_3d(var_in, var, idim, jdim, kdim, suffix, as_needed) + type(coupler_1d_bc_type), intent(in) :: var_in !< structure from which to copy information + type(coupler_3d_bc_type), intent(inout) :: var !< structure into which to copy information + integer, dimension(4), intent(in) :: idim !< The data and computational domain extents of + !! the first dimension in a non-decreasing list + integer, dimension(4), intent(in) :: jdim !< The data and computational domain extents of + !! the second dimension in a non-decreasing list + integer, dimension(2), intent(in) :: kdim !< The array extents of the third dimension in + !! a non-decreasing list + character(len=*), optional, intent(in) :: suffix !< optional suffix to make the name identifier unique + logical, optional, intent(in) :: as_needed !< Only do the spawn if the target type (var) + !! is not set and the parent type (var_in) is set. + + call coupler_type_spawn(var_in, var, idim, jdim, kdim, suffix=suffix, as_needed=as_needed) + +end subroutine CT_spawn_1d_3d + !> Generate one 2-D coupler type using another 2-D coupler type as a template. subroutine CT_spawn_2d_2d(var_in, var, idim, jdim, suffix, as_needed) type(coupler_2d_bc_type), intent(in) :: var_in !< structure from which to copy information @@ -99,8 +149,60 @@ subroutine CT_spawn_2d_2d(var_in, var, idim, jdim, suffix, as_needed) end subroutine CT_spawn_2d_2d +!> Generate a 3-D coupler type using a 2-D coupler type as a template. +subroutine CT_spawn_2d_3d(var_in, var, idim, jdim, kdim, suffix, as_needed) + type(coupler_2d_bc_type), intent(in) :: var_in !< structure from which to copy information + type(coupler_3d_bc_type), intent(inout) :: var !< structure into which to copy information + integer, dimension(4), intent(in) :: idim !< The data and computational domain extents of + !! the first dimension in a non-decreasing list + integer, dimension(4), intent(in) :: jdim !< The data and computational domain extents of + !! the second dimension in a non-decreasing list + integer, dimension(2), intent(in) :: kdim !< The array extents of the third dimension in + !! a non-decreasing list + character(len=*), optional, intent(in) :: suffix !< optional suffix to make the name identifier unique + logical, optional, intent(in) :: as_needed !< Only do the spawn if the target type (var) + !! is not set and the parent type (var_in) is set. + + call coupler_type_spawn(var_in, var, idim, jdim, kdim, suffix=suffix, as_needed=as_needed) + +end subroutine CT_spawn_2d_3d + +!> Generate a 2-D coupler type using a 3-D coupler type as a template. +subroutine CT_spawn_3d_2d(var_in, var, idim, jdim, suffix, as_needed) + type(coupler_3d_bc_type), intent(in) :: var_in !< structure from which to copy information + type(coupler_2d_bc_type), intent(inout) :: var !< structure into which to copy information + integer, dimension(4), intent(in) :: idim !< The data and computational domain extents of + !! the first dimension in a non-decreasing list + integer, dimension(4), intent(in) :: jdim !< The data and computational domain extents of + !! the second dimension in a non-decreasing list + character(len=*), optional, intent(in) :: suffix !< optional suffix to make the name identifier unique + logical, optional, intent(in) :: as_needed !< Only do the spawn if the target type (var) + !! is not set and the parent type (var_in) is set. + + call coupler_type_spawn(var_in, var, idim, jdim, suffix=suffix, as_needed=as_needed) + +end subroutine CT_spawn_3d_2d + +!> Generate a 3-D coupler type using another 3-D coupler type as a template. +subroutine CT_spawn_3d_3d(var_in, var, idim, jdim, kdim, suffix, as_needed) + type(coupler_3d_bc_type), intent(in) :: var_in !< structure from which to copy information + type(coupler_3d_bc_type), intent(inout) :: var !< structure into which to copy information + integer, dimension(4), intent(in) :: idim !< The data and computational domain extents of + !! the first dimension in a non-decreasing list + integer, dimension(4), intent(in) :: jdim !< The data and computational domain extents of + !! the second dimension in a non-decreasing list + integer, dimension(2), intent(in) :: kdim !< The array extents of the third dimension in + !! a non-decreasing list + character(len=*), optional, intent(in) :: suffix !< optional suffix to make the name identifier unique + logical, optional, intent(in) :: as_needed !< Only do the spawn if the target type (var) + !! is not set and the parent type (var_in) is set. + + call coupler_type_spawn(var_in, var, idim, jdim, kdim, suffix=suffix, as_needed=as_needed) + +end subroutine CT_spawn_3d_3d + !> Copy all elements of the data in of one coupler_2d_bc_type into another. Both must have the same array sizes. -subroutine CT_copy_data(var_in, var, halo_size, bc_index, field_index, & +subroutine CT_copy_data_2d(var_in, var, halo_size, bc_index, field_index, & exclude_flux_type, only_flux_type, pass_through_ice) type(coupler_2d_bc_type), intent(in) :: var_in !< BC_type structure with the data to copy type(coupler_2d_bc_type), intent(inout) :: var !< The recipient BC_type structure @@ -118,11 +220,59 @@ subroutine CT_copy_data(var_in, var, halo_size, bc_index, field_index, & call coupler_type_copy_data(var_in, var, halo_size, bc_index, field_index, & exclude_flux_type, only_flux_type, pass_through_ice) -end subroutine CT_copy_data +end subroutine CT_copy_data_2d + +!> Copy all elements of the data in of one coupler_3d_bc_type into another. Both must have the same array sizes. +subroutine CT_copy_data_3d(var_in, var, halo_size, bc_index, field_index, & + exclude_flux_type, only_flux_type, pass_through_ice) + type(coupler_3d_bc_type), intent(in) :: var_in !< BC_type structure with the data to copy + type(coupler_3d_bc_type), intent(inout) :: var !< The recipient BC_type structure + integer, optional, intent(in) :: halo_size !< The extent of the halo to copy; 0 by default + integer, optional, intent(in) :: bc_index !< The index of the boundary condition + !! that is being copied + integer, optional, intent(in) :: field_index !< The index of the field in the + !! boundary condition that is being copied + character(len=*), optional, intent(in) :: exclude_flux_type !< A string describing which types of fluxes + !! to exclude from this copy. + character(len=*), optional, intent(in) :: only_flux_type !< A string describing which types of fluxes + !! to include from this copy. + logical, optional, intent(in) :: pass_through_ice !< If true, only copy BCs whose + !! value of pass_through ice matches this + + call coupler_type_copy_data(var_in, var, halo_size, bc_index, field_index, & + exclude_flux_type, only_flux_type, pass_through_ice) +end subroutine CT_copy_data_3d + +!> Copy all elements of the data in a coupler_2d_bc_type into a coupler_3d_bc_type. +!! Both must have the same array sizes for the first two dimensions, while the extent +!! of the 3rd dimension that is being filled may be specified via optional arguments. +subroutine CT_copy_data_2d_3d(var_in, var, halo_size, bc_index, field_index, & + exclude_flux_type, only_flux_type, pass_through_ice, ind3_start, ind3_end) + type(coupler_2d_bc_type), intent(in) :: var_in !< BC_type structure with the data to copy + type(coupler_3d_bc_type), intent(inout) :: var !< The recipient BC_type structure + integer, optional, intent(in) :: halo_size !< The extent of the halo to copy; 0 by default + integer, optional, intent(in) :: bc_index !< The index of the boundary condition + !! that is being copied + integer, optional, intent(in) :: field_index !< The index of the field in the + !! boundary condition that is being copied + character(len=*), optional, intent(in) :: exclude_flux_type !< A string describing which types of fluxes + !! to exclude from this copy. + character(len=*), optional, intent(in) :: only_flux_type !< A string describing which types of fluxes + !! to include from this copy. + logical, optional, intent(in) :: pass_through_ice !< If true, only copy BCs whose + !! value of pass_through ice matches this + integer, optional, intent(in) :: ind3_start !< The starting value of the 3rd + !! index of the 3d type to fill in. + integer, optional, intent(in) :: ind3_end !< The ending value of the 3rd + !! index of the 3d type to fill in. + + call coupler_type_copy_data(var_in, var, halo_size, bc_index, field_index, & + exclude_flux_type, only_flux_type, pass_through_ice, ind3_start, ind3_end) +end subroutine CT_copy_data_2d_3d !> Increment data in all elements of one coupler_2d_bc_type with the data from another. Both !! must have the same array sizes. -subroutine CT_increment_data(var_in, var, halo_size, scale_factor, scale_prev) +subroutine CT_increment_data_2d(var_in, var, halo_size, scale_factor, scale_prev) type(coupler_2d_bc_type), intent(in) :: var_in !< coupler_type structure with the data to add to the other type type(coupler_2d_bc_type), intent(inout) :: var !< The coupler_type structure whose fields are being incremented integer, optional, intent(in) :: halo_size !< The extent of the halo to increment; 0 by default @@ -132,11 +282,90 @@ subroutine CT_increment_data(var_in, var, halo_size, scale_factor, scale_prev) call coupler_type_increment_data(var_in, var, halo_size=halo_size, scale_factor=scale_factor, & scale_prev=scale_prev) -end subroutine CT_increment_data +end subroutine CT_increment_data_2d + +!> Increment data in all elements of one coupler_3d_bc_type with the data from another. Both +!! must have the same array sizes. +subroutine CT_increment_data_3d(var_in, var, halo_size, scale_factor, scale_prev, exclude_flux_type, only_flux_type) + type(coupler_3d_bc_type), intent(in) :: var_in !< coupler_type structure with the data to add to the other type + type(coupler_3d_bc_type), intent(inout) :: var !< The coupler_type structure whose fields are being incremented + integer, optional, intent(in) :: halo_size !< The extent of the halo to increment; 0 by default + real, optional, intent(in) :: scale_factor !< A scaling factor for the data that is being added + real, optional, intent(in) :: scale_prev !< A scaling factor for the data that is already here + character(len=*), optional, intent(in) :: exclude_flux_type !< A string describing which types + !! of fluxes to exclude from this increment. + character(len=*), optional, intent(in) :: only_flux_type !< A string describing which types + !! of fluxes to include from this increment. + + call coupler_type_increment_data(var_in, var, halo_size=halo_size, scale_factor=scale_factor, & + scale_prev=scale_prev, exclude_flux_type=exclude_flux_type, & + only_flux_type=only_flux_type) + +end subroutine CT_increment_data_3d + +!> Rescales the fields in the elements of a coupler_2d_bc_type by multiplying by a factor scale. +!! If scale is 0, this is a direct assignment to 0, so that NaNs will not persist. +subroutine CT_rescale_data_2d(var, scale) + type(coupler_2d_bc_type), intent(inout) :: var !< The BC_type structure whose fields are being rescaled + real, intent(in) :: scale !< A scaling factor to multiply fields by + + call coupler_type_rescale_data(var, scale) + +end subroutine CT_rescale_data_2d + +!> Rescales the fields in the elements of a coupler_3d_bc_type by multiplying by a factor scale. +!! If scale is 0, this is a direct assignment to 0, so that NaNs will not persist. +subroutine CT_rescale_data_3d(var, scale) + type(coupler_3d_bc_type), intent(inout) :: var !< The BC_type structure whose fields are being rescaled + real, intent(in) :: scale !< A scaling factor to multiply fields by + + call coupler_type_rescale_data(var, scale) + +end subroutine CT_rescale_data_3d + +!> Increment data in the elements of a coupler_2d_bc_type with weighted averages of elements of a +!! coupler_3d_bc_type +subroutine CT_increment_data_2d_3d(var_in, weights, var, halo_size) + type(coupler_3d_bc_type), intent(in) :: var_in !< coupler_type structure with the data to add to the other type + real, dimension(:,:,:), intent(in) :: weights !< An array of normalized weights for the 3d-data to + !! increment the 2d-data. There is no renormalization, + !! so if the weights do not sum to 1 in the 3rd dimension + !! there may be adverse consequences! + type(coupler_2d_bc_type), intent(inout) :: var !< The coupler_type structure whose fields are being incremented + integer, optional, intent(in) :: halo_size !< The extent of the halo to increment; 0 by default + + call coupler_type_increment_data(var_in, weights, var, halo_size=halo_size) + +end subroutine CT_increment_data_2d_3d + + +!> Redistribute the data in all elements of one coupler_2d_bc_type into another, which may be on +!! different processors with a different decomposition. +subroutine CT_redistribute_data_2d(var_in, domain_in, var_out, domain_out, complete) + type(coupler_2d_bc_type), intent(in) :: var_in !< BC_type structure with the data to copy + type(domain2D), intent(in) :: domain_in !< The FMS domain for the input structure + type(coupler_2d_bc_type), intent(inout) :: var_out !< The recipient BC_type structure (data intent out) + type(domain2D), intent(in) :: domain_out !< The FMS domain for the output structure + logical, optional, intent(in) :: complete !< If true, complete the updates + + call coupler_type_redistribute_data(var_in, domain_in, var_out, domain_out, complete) +end subroutine CT_redistribute_data_2d + +!> Redistribute the data in all elements of one coupler_3d_bc_type into another, which may be on +!! different processors with a different decomposition. +subroutine CT_redistribute_data_3d(var_in, domain_in, var_out, domain_out, complete) + type(coupler_3d_bc_type), intent(in) :: var_in !< BC_type structure with the data to copy + type(domain2D), intent(in) :: domain_in !< The FMS domain for the input structure + type(coupler_3d_bc_type), intent(inout) :: var_out !< The recipient BC_type structure (data intent out) + type(domain2D), intent(in) :: domain_out !< The FMS domain for the output structure + logical, optional, intent(in) :: complete !< If true, complete the updates + + call coupler_type_redistribute_data(var_in, domain_in, var_out, domain_out, complete) +end subroutine CT_redistribute_data_3d !> Extract a 2d field from a coupler_2d_bc_type into a two-dimensional array. subroutine CT_extract_data(var_in, bc_index, field_index, array_out, & - scale_factor, halo_size, idim, jdim) + scale_factor, halo_size, idim, jdim) type(coupler_2d_bc_type), intent(in) :: var_in !< BC_type structure with the data to extract integer, intent(in) :: bc_index !< The index of the boundary condition !! that is being copied @@ -160,7 +389,7 @@ end subroutine CT_extract_data !> Set single 2d field in coupler_2d_bc_type from a two-dimensional array. subroutine CT_set_data(array_in, bc_index, field_index, var, & - scale_factor, halo_size, idim, jdim) + scale_factor, halo_size, idim, jdim) real, dimension(1:,1:), intent(in) :: array_in !< The source array for the field; its size !! must match the size of the data being copied !! unless idim and jdim are supplied. @@ -185,6 +414,15 @@ subroutine CT_set_data(array_in, bc_index, field_index, var, & end subroutine CT_set_data +!> Potentially override the values in a coupler_2d_bc_type +subroutine CT_data_override(gridname, var, time) + character(len=3), intent(in) :: gridname !< 3-character long model grid ID + type(coupler_2d_bc_type), intent(inout) :: var !< BC_type structure to override + type(time_type), intent(in) :: time !< The current model time + + call coupler_type_data_override(gridname, var, time) +end subroutine CT_data_override + !> Register the diagnostics of a coupler_2d_bc_type subroutine CT_set_diags(var, diag_name, axes, time) type(coupler_2d_bc_type), intent(inout) :: var !< BC_type structure for which to register diagnostics @@ -205,14 +443,24 @@ subroutine CT_send_data(var, Time) end subroutine CT_send_data !> Write out checksums for the elements of a coupler_2d_bc_type -subroutine CT_write_chksums(var, outunit, name_lead) +subroutine CT_write_chksums_2d(var, outunit, name_lead) type(coupler_2d_bc_type), intent(in) :: var !< BC_type structure for which to register diagnostics integer, intent(in) :: outunit !< The index of a open output file character(len=*), optional, intent(in) :: name_lead !< An optional prefix for the variable names call coupler_type_write_chksums(var, outunit, name_lead) -end subroutine CT_write_chksums +end subroutine CT_write_chksums_2d + +!> Write out checksums for the elements of a coupler_3d_bc_type +subroutine CT_write_chksums_3d(var, outunit, name_lead) + type(coupler_3d_bc_type), intent(in) :: var !< BC_type structure for which to register diagnostics + integer, intent(in) :: outunit !< The index of a open output file + character(len=*), optional, intent(in) :: name_lead !< An optional prefix for the variable names + + call coupler_type_write_chksums(var, outunit, name_lead) + +end subroutine CT_write_chksums_3d !> Indicate whether a coupler_1d_bc_type has been initialized. logical function CT_initialized_1d(var) @@ -228,6 +476,13 @@ logical function CT_initialized_2d(var) CT_initialized_2d = coupler_type_initialized(var) end function CT_initialized_2d +!> Indicate whether a coupler_3d_bc_type has been initialized. +logical function CT_initialized_3d(var) + type(coupler_3d_bc_type), intent(in) :: var !< BC_type structure to be deconstructed + + CT_initialized_3d = coupler_type_initialized(var) +end function CT_initialized_3d + !> Deallocate all data associated with a coupler_1d_bc_type subroutine CT_destructor_1d(var) type(coupler_1d_bc_type), intent(inout) :: var !< BC_type structure to be deconstructed diff --git a/src/framework/MOM_coupler_types.F90 b/src/framework/MOM_coupler_types.F90 index 94014d9a56..bb01755a84 100644 --- a/src/framework/MOM_coupler_types.F90 +++ b/src/framework/MOM_coupler_types.F90 @@ -4,31 +4,33 @@ module MOM_coupler_types ! This file is part of MOM6. See LICENSE.md for the license. use MOM_couplertype_infra, only : CT_spawn, CT_initialized, CT_destructor, atmos_ocn_coupler_flux -use MOM_couplertype_infra, only : CT_set_diags, CT_send_data, CT_write_chksums -use MOM_couplertype_infra, only : CT_copy_data, CT_increment_data, CT_set_data, CT_extract_data -use MOM_couplertype_infra, only : coupler_1d_bc_type, coupler_2d_bc_type +use MOM_couplertype_infra, only : CT_set_diags, CT_send_data, CT_write_chksums, CT_data_override +use MOM_couplertype_infra, only : CT_copy_data, CT_increment_data, CT_rescale_data +use MOM_couplertype_infra, only : CT_set_data, CT_extract_data, CT_redistribute_data +use MOM_couplertype_infra, only : coupler_1d_bc_type, coupler_2d_bc_type, coupler_3d_bc_type use MOM_couplertype_infra, only : ind_flux, ind_alpha, ind_csurf - -use MOM_time_manager, only : time_type +use MOM_domain_infra, only : domain2D +use MOM_time_manager, only : time_type implicit none ; private public :: coupler_type_spawn, coupler_type_destructor, coupler_type_initialized public :: coupler_type_set_diags, coupler_type_send_data, coupler_type_write_chksums -public :: set_coupler_type_data, extract_coupler_type_data -public :: coupler_type_copy_data, coupler_type_increment_data -public :: atmos_ocn_coupler_flux +public :: set_coupler_type_data, extract_coupler_type_data, coupler_type_redistribute_data +public :: coupler_type_copy_data, coupler_type_increment_data, coupler_type_rescale_data +public :: atmos_ocn_coupler_flux, coupler_type_data_override public :: ind_flux, ind_alpha, ind_csurf -public :: coupler_1d_bc_type, coupler_2d_bc_type +public :: coupler_1d_bc_type, coupler_2d_bc_type, coupler_3d_bc_type !> This is the interface to spawn one coupler_bc_type into another. interface coupler_type_spawn - module procedure CT_spawn_1d_2d, CT_spawn_2d_2d + module procedure CT_spawn_1d_2d, CT_spawn_1d_3d, CT_spawn_2d_2d, CT_spawn_2d_3d + module procedure CT_spawn_3d_2d, CT_spawn_3d_3d end interface coupler_type_spawn !> This function interface indicates whether a coupler_bc_type has been initialized. interface coupler_type_initialized - module procedure CT_initialized_1d, CT_initialized_2d + module procedure CT_initialized_1d, CT_initialized_2d, CT_initialized_3d end interface coupler_type_initialized !> This is the interface to deallocate any data associated with a coupler_bc_type. @@ -36,6 +38,35 @@ module MOM_coupler_types module procedure CT_destructor_1d, CT_destructor_2d end interface coupler_type_destructor +!> Copy all elements of the data in of one coupler_2d_bc_type or coupler_3d_bc_type +!! into another. Both must have the same array sizes in common dimensions. +interface coupler_type_copy_data + module procedure CT_copy_data_2d, CT_copy_data_3d, CT_copy_data_2d_3d +end interface coupler_type_copy_data + +!> Increment data in all elements of one coupler_2d_bc_type or coupler_3d_bc_type with +!! the data from another. Both must have the same array sizes and rank. +interface coupler_type_increment_data + module procedure CT_increment_data_2d, CT_increment_data_3d, CT_increment_data_2d_3d +end interface coupler_type_increment_data + +!> Rescale the fields in the elements of a coupler_2d_bc_type by multiplying by a factor scale. +!! If scale is 0, this is a direct assignment to 0, so that NaNs will not persist. +interface coupler_type_rescale_data + module procedure CT_rescale_data_2d, CT_rescale_data_3d +end interface coupler_type_rescale_data + +!> Redistribute the data in all elements of one coupler_2d_bc_type or coupler_3d_bc_type into +!! another, which may be on different processors with a different decomposition. +interface coupler_type_redistribute_data + module procedure CT_redistribute_data_2d, CT_redistribute_data_3d +end interface coupler_type_redistribute_data + +!> Write out checksums for the elements of a coupler_2d_bc_type or coupler_3d_bc_type +interface coupler_type_write_chksums + module procedure CT_write_chksums_2d, CT_write_chksums_3d +end interface coupler_type_write_chksums + contains !> Generate a 2-D coupler type using a 1-D coupler type as a template. @@ -54,6 +85,24 @@ subroutine CT_spawn_1d_2d(var_in, var, idim, jdim, suffix, as_needed) end subroutine CT_spawn_1d_2d +!> Generate a 3-D coupler type using a 1-D coupler type as a template. +subroutine CT_spawn_1d_3d(var_in, var, idim, jdim, kdim, suffix, as_needed) + type(coupler_1d_bc_type), intent(in) :: var_in !< structure from which to copy information + type(coupler_3d_bc_type), intent(inout) :: var !< structure into which to copy information + integer, dimension(4), intent(in) :: idim !< The data and computational domain extents of + !! the first dimension in a non-decreasing list + integer, dimension(4), intent(in) :: jdim !< The data and computational domain extents of + !! the second dimension in a non-decreasing list + integer, dimension(2), intent(in) :: kdim !< The array extents of the third dimension in + !! a non-decreasing list + character(len=*), optional, intent(in) :: suffix !< optional suffix to make the name identifier unique + logical, optional, intent(in) :: as_needed !< Only do the spawn if the target type (var) + !! is not set and the parent type (var_in) is set. + + call CT_spawn(var_in, var, idim, jdim, kdim, suffix=suffix, as_needed=as_needed) + +end subroutine CT_spawn_1d_3d + !> Generate one 2-D coupler type using another 2-D coupler type as a template. subroutine CT_spawn_2d_2d(var_in, var, idim, jdim, suffix, as_needed) type(coupler_2d_bc_type), intent(in) :: var_in !< structure from which to copy information @@ -70,8 +119,60 @@ subroutine CT_spawn_2d_2d(var_in, var, idim, jdim, suffix, as_needed) end subroutine CT_spawn_2d_2d +!> Generate a 3-D coupler type using a 2-D coupler type as a template. +subroutine CT_spawn_2d_3d(var_in, var, idim, jdim, kdim, suffix, as_needed) + type(coupler_2d_bc_type), intent(in) :: var_in !< structure from which to copy information + type(coupler_3d_bc_type), intent(inout) :: var !< structure into which to copy information + integer, dimension(4), intent(in) :: idim !< The data and computational domain extents of + !! the first dimension in a non-decreasing list + integer, dimension(4), intent(in) :: jdim !< The data and computational domain extents of + !! the second dimension in a non-decreasing list + integer, dimension(2), intent(in) :: kdim !< The array extents of the third dimension in + !! a non-decreasing list + character(len=*), optional, intent(in) :: suffix !< optional suffix to make the name identifier unique + logical, optional, intent(in) :: as_needed !< Only do the spawn if the target type (var) + !! is not set and the parent type (var_in) is set. + + call CT_spawn(var_in, var, idim, jdim, kdim, suffix=suffix, as_needed=as_needed) + +end subroutine CT_spawn_2d_3d + +!> Generate a 2-D coupler type using a 3-D coupler type as a template. +subroutine CT_spawn_3d_2d(var_in, var, idim, jdim, suffix, as_needed) + type(coupler_3d_bc_type), intent(in) :: var_in !< structure from which to copy information + type(coupler_2d_bc_type), intent(inout) :: var !< structure into which to copy information + integer, dimension(4), intent(in) :: idim !< The data and computational domain extents of + !! the first dimension in a non-decreasing list + integer, dimension(4), intent(in) :: jdim !< The data and computational domain extents of + !! the second dimension in a non-decreasing list + character(len=*), optional, intent(in) :: suffix !< optional suffix to make the name identifier unique + logical, optional, intent(in) :: as_needed !< Only do the spawn if the target type (var) + !! is not set and the parent type (var_in) is set. + + call CT_spawn(var_in, var, idim, jdim, suffix=suffix, as_needed=as_needed) + +end subroutine CT_spawn_3d_2d + +!> Generate a 3-D coupler type using another 3-D coupler type as a template. +subroutine CT_spawn_3d_3d(var_in, var, idim, jdim, kdim, suffix, as_needed) + type(coupler_3d_bc_type), intent(in) :: var_in !< structure from which to copy information + type(coupler_3d_bc_type), intent(inout) :: var !< structure into which to copy information + integer, dimension(4), intent(in) :: idim !< The data and computational domain extents of + !! the first dimension in a non-decreasing list + integer, dimension(4), intent(in) :: jdim !< The data and computational domain extents of + !! the second dimension in a non-decreasing list + integer, dimension(2), intent(in) :: kdim !< The array extents of the third dimension in + !! a non-decreasing list + character(len=*), optional, intent(in) :: suffix !< optional suffix to make the name identifier unique + logical, optional, intent(in) :: as_needed !< Only do the spawn if the target type (var) + !! is not set and the parent type (var_in) is set. + + call CT_spawn(var_in, var, idim, jdim, kdim, suffix=suffix, as_needed=as_needed) + +end subroutine CT_spawn_3d_3d + !> Copy all elements of the data in of one coupler_2d_bc_type into another. Both must have the same array sizes. -subroutine coupler_type_copy_data(var_in, var, halo_size, bc_index, field_index, & +subroutine CT_copy_data_2d(var_in, var, halo_size, bc_index, field_index, & exclude_flux_type, only_flux_type, pass_through_ice) type(coupler_2d_bc_type), intent(in) :: var_in !< BC_type structure with the data to copy type(coupler_2d_bc_type), intent(inout) :: var !< The recipient BC_type structure @@ -89,11 +190,59 @@ subroutine coupler_type_copy_data(var_in, var, halo_size, bc_index, field_index, call CT_copy_data(var_in, var, halo_size, bc_index, field_index, & exclude_flux_type, only_flux_type, pass_through_ice) -end subroutine coupler_type_copy_data +end subroutine CT_copy_data_2d + +!> Copy all elements of the data in of one coupler_3d_bc_type into another. Both must have the same array sizes. +subroutine CT_copy_data_3d(var_in, var, halo_size, bc_index, field_index, & + exclude_flux_type, only_flux_type, pass_through_ice) + type(coupler_3d_bc_type), intent(in) :: var_in !< BC_type structure with the data to copy + type(coupler_3d_bc_type), intent(inout) :: var !< The recipient BC_type structure + integer, optional, intent(in) :: halo_size !< The extent of the halo to copy; 0 by default + integer, optional, intent(in) :: bc_index !< The index of the boundary condition + !! that is being copied + integer, optional, intent(in) :: field_index !< The index of the field in the + !! boundary condition that is being copied + character(len=*), optional, intent(in) :: exclude_flux_type !< A string describing which types of fluxes + !! to exclude from this copy. + character(len=*), optional, intent(in) :: only_flux_type !< A string describing which types of fluxes + !! to include from this copy. + logical, optional, intent(in) :: pass_through_ice !< If true, only copy BCs whose + !! value of pass_through ice matches this + + call CT_copy_data(var_in, var, halo_size, bc_index, field_index, & + exclude_flux_type, only_flux_type, pass_through_ice) +end subroutine CT_copy_data_3d + +!> Copy all elements of the data in a coupler_2d_bc_type into a coupler_3d_bc_type. +!! Both must have the same array sizes for the first two dimensions, while the extent +!! of the 3rd dimension that is being filled may be specified via optional arguments. +subroutine CT_copy_data_2d_3d(var_in, var, halo_size, bc_index, field_index, & + exclude_flux_type, only_flux_type, pass_through_ice, ind3_start, ind3_end) + type(coupler_2d_bc_type), intent(in) :: var_in !< BC_type structure with the data to copy + type(coupler_3d_bc_type), intent(inout) :: var !< The recipient BC_type structure + integer, optional, intent(in) :: halo_size !< The extent of the halo to copy; 0 by default + integer, optional, intent(in) :: bc_index !< The index of the boundary condition + !! that is being copied + integer, optional, intent(in) :: field_index !< The index of the field in the + !! boundary condition that is being copied + character(len=*), optional, intent(in) :: exclude_flux_type !< A string describing which types of fluxes + !! to exclude from this copy. + character(len=*), optional, intent(in) :: only_flux_type !< A string describing which types of fluxes + !! to include from this copy. + logical, optional, intent(in) :: pass_through_ice !< If true, only copy BCs whose + !! value of pass_through ice matches this + integer, optional, intent(in) :: ind3_start !< The starting value of the 3rd + !! index of the 3d type to fill in. + integer, optional, intent(in) :: ind3_end !< The ending value of the 3rd + !! index of the 3d type to fill in. + + call CT_copy_data(var_in, var, halo_size, bc_index, field_index, & + exclude_flux_type, only_flux_type, pass_through_ice, ind3_start, ind3_end) +end subroutine CT_copy_data_2d_3d !> Increment data in all elements of one coupler_2d_bc_type with the data from another. Both !! must have the same array sizes. -subroutine coupler_type_increment_data(var_in, var, halo_size, scale_factor, scale_prev) +subroutine CT_increment_data_2d(var_in, var, halo_size, scale_factor, scale_prev) type(coupler_2d_bc_type), intent(in) :: var_in !< coupler_type structure with the data to add to the other type type(coupler_2d_bc_type), intent(inout) :: var !< The coupler_type structure whose fields are being incremented integer, optional, intent(in) :: halo_size !< The extent of the halo to increment; 0 by default @@ -103,7 +252,96 @@ subroutine coupler_type_increment_data(var_in, var, halo_size, scale_factor, sca call CT_increment_data(var_in, var, halo_size=halo_size, scale_factor=scale_factor, & scale_prev=scale_prev) -end subroutine coupler_type_increment_data +end subroutine CT_increment_data_2d + +!> Increment data in all elements of one coupler_3d_bc_type with the data from another. Both +!! must have the same array sizes. +subroutine CT_increment_data_3d(var_in, var, halo_size, scale_factor, scale_prev, exclude_flux_type, only_flux_type) + type(coupler_3d_bc_type), intent(in) :: var_in !< coupler_type structure with the data to add to the other type + type(coupler_3d_bc_type), intent(inout) :: var !< The coupler_type structure whose fields are being incremented + integer, optional, intent(in) :: halo_size !< The extent of the halo to increment; 0 by default + real, optional, intent(in) :: scale_factor !< A scaling factor for the data that is being added + real, optional, intent(in) :: scale_prev !< A scaling factor for the data that is already here + character(len=*), optional, intent(in) :: exclude_flux_type !< A string describing which types + !! of fluxes to exclude from this increment. + character(len=*), optional, intent(in) :: only_flux_type !< A string describing which types + !! of fluxes to include from this increment. + + call CT_increment_data(var_in, var, halo_size=halo_size, scale_factor=scale_factor, & + scale_prev=scale_prev, exclude_flux_type=exclude_flux_type, & + only_flux_type=only_flux_type) + +end subroutine CT_increment_data_3d + +!> Increment data in the elements of a coupler_2d_bc_type with weighted averages of elements of a +!! coupler_3d_bc_type +subroutine CT_increment_data_2d_3d(var_in, weights, var, halo_size) + type(coupler_3d_bc_type), intent(in) :: var_in !< coupler_type structure with the data to add to the other type + real, dimension(:,:,:), intent(in) :: weights !< An array of normalized weights for the 3d-data to + !! increment the 2d-data. There is no renormalization, + !! so if the weights do not sum to 1 in the 3rd dimension + !! there may be adverse consequences! + type(coupler_2d_bc_type), intent(inout) :: var !< The coupler_type structure whose fields are being incremented + integer, optional, intent(in) :: halo_size !< The extent of the halo to increment; 0 by default + + call CT_increment_data(var_in, weights, var, halo_size=halo_size) + +end subroutine CT_increment_data_2d_3d + +!> Rescales the fields in the elements of a coupler_2d_bc_type by multiplying by a factor scale. +!! If scale is 0, this is a direct assignment to 0, so that NaNs will not persist. +subroutine CT_rescale_data_2d(var, scale) + type(coupler_2d_bc_type), intent(inout) :: var !< The BC_type structure whose fields are being rescaled + real, intent(in) :: scale !< A scaling factor to multiply fields by + + call CT_rescale_data(var, scale) + +end subroutine CT_rescale_data_2d + +!> Rescales the fields in the elements of a coupler_3d_bc_type by multiplying by a factor scale. +!! If scale is 0, this is a direct assignment to 0, so that NaNs will not persist. +subroutine CT_rescale_data_3d(var, scale) + type(coupler_3d_bc_type), intent(inout) :: var !< The BC_type structure whose fields are being rescaled + real, intent(in) :: scale !< A scaling factor to multiply fields by + + call CT_rescale_data(var, scale) + +end subroutine CT_rescale_data_3d + +!> Redistribute the data in all elements of one coupler_2d_bc_type into another, which may be on +!! different processors with a different decomposition. +subroutine CT_redistribute_data_2d(var_in, domain_in, var_out, domain_out, complete) + type(coupler_2d_bc_type), intent(in) :: var_in !< BC_type structure with the data to copy + type(domain2D), intent(in) :: domain_in !< The FMS domain for the input structure + type(coupler_2d_bc_type), intent(inout) :: var_out !< The recipient BC_type structure (data intent out) + type(domain2D), intent(in) :: domain_out !< The FMS domain for the output structure + logical, optional, intent(in) :: complete !< If true, complete the updates + + call CT_redistribute_data(var_in, domain_in, var_out, domain_out, complete) +end subroutine CT_redistribute_data_2d + +!> Redistribute the data in all elements of one coupler_3d_bc_type into another, which may be on +!! different processors with a different decomposition. +subroutine CT_redistribute_data_3d(var_in, domain_in, var_out, domain_out, complete) + type(coupler_3d_bc_type), intent(in) :: var_in !< BC_type structure with the data to copy + type(domain2D), intent(in) :: domain_in !< The FMS domain for the input structure + type(coupler_3d_bc_type), intent(inout) :: var_out !< The recipient BC_type structure (data intent out) + type(domain2D), intent(in) :: domain_out !< The FMS domain for the output structure + logical, optional, intent(in) :: complete !< If true, complete the updates + + call CT_redistribute_data(var_in, domain_in, var_out, domain_out, complete) +end subroutine CT_redistribute_data_3d + + +!> Potentially override the values in a coupler_2d_bc_type +subroutine coupler_type_data_override(gridname, var, time) + character(len=3), intent(in) :: gridname !< 3-character long model grid ID + type(coupler_2d_bc_type), intent(inout) :: var !< BC_type structure to override + type(time_type), intent(in) :: time !< The current model time + + call CT_data_override(gridname, var, time) +end subroutine coupler_type_data_override + !> Extract a 2d field from a coupler_2d_bc_type into a two-dimensional array, using a !! MOM-specific interface. @@ -193,14 +431,24 @@ subroutine coupler_type_send_data(var, Time) end subroutine coupler_type_send_data !> Write out checksums for the elements of a coupler_2d_bc_type -subroutine coupler_type_write_chksums(var, outunit, name_lead) +subroutine CT_write_chksums_2d(var, outunit, name_lead) type(coupler_2d_bc_type), intent(in) :: var !< BC_type structure for which to register diagnostics integer, intent(in) :: outunit !< The index of a open output file character(len=*), optional, intent(in) :: name_lead !< An optional prefix for the variable names call CT_write_chksums(var, outunit, name_lead) -end subroutine coupler_type_write_chksums +end subroutine CT_write_chksums_2d + +!> Write out checksums for the elements of a coupler_3d_bc_type +subroutine CT_write_chksums_3d(var, outunit, name_lead) + type(coupler_3d_bc_type), intent(in) :: var !< BC_type structure for which to register diagnostics + integer, intent(in) :: outunit !< The index of a open output file + character(len=*), optional, intent(in) :: name_lead !< An optional prefix for the variable names + + call CT_write_chksums(var, outunit, name_lead) + +end subroutine CT_write_chksums_3d !> Indicate whether a coupler_1d_bc_type has been initialized. logical function CT_initialized_1d(var) @@ -216,6 +464,13 @@ logical function CT_initialized_2d(var) CT_initialized_2d = CT_initialized(var) end function CT_initialized_2d +!> Indicate whether a coupler_3d_bc_type has been initialized. +logical function CT_initialized_3d(var) + type(coupler_3d_bc_type), intent(in) :: var !< BC_type structure to be deconstructed + + CT_initialized_3d = CT_initialized(var) +end function CT_initialized_3d + !> Deallocate all data associated with a coupler_1d_bc_type subroutine CT_destructor_1d(var) type(coupler_1d_bc_type), intent(inout) :: var !< BC_type structure to be deconstructed From 3c1cb2efd6497bcf83b70efc7b4fd2c1752c73f7 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 31 Mar 2021 18:28:34 -0400 Subject: [PATCH 034/112] +Add MOM_domains interfaces needed by SIS2 Added additional domain routine interfaces that are needed by SIS2, including the new function same_domain, which tests whether two domains use the same layout and conforming computational domain sizes, and a new 4d-array variant of redistribute_array because SIS2 uses thickness categories as a 4th dimension. All answers are bitwise identical. --- config_src/infra/FMS1/MOM_domain_infra.F90 | 48 ++++++++++++++++++++-- config_src/infra/FMS2/MOM_domain_infra.F90 | 48 ++++++++++++++++++++-- src/framework/MOM_domains.F90 | 6 ++- 3 files changed, 94 insertions(+), 8 deletions(-) diff --git a/config_src/infra/FMS1/MOM_domain_infra.F90 b/config_src/infra/FMS1/MOM_domain_infra.F90 index fc39777a2f..029561946b 100644 --- a/config_src/infra/FMS1/MOM_domain_infra.F90 +++ b/config_src/infra/FMS1/MOM_domain_infra.F90 @@ -9,7 +9,7 @@ module MOM_domain_infra use mpp_domains_mod, only : domain2D, domain1D use mpp_domains_mod, only : mpp_define_io_domain, mpp_define_domains, mpp_deallocate_domain -use mpp_domains_mod, only : mpp_get_domain_components, mpp_get_domain_extents +use mpp_domains_mod, only : mpp_get_domain_components, mpp_get_domain_extents, mpp_get_layout use mpp_domains_mod, only : mpp_get_compute_domain, mpp_get_data_domain, mpp_get_global_domain use mpp_domains_mod, only : mpp_get_boundary, mpp_update_domains use mpp_domains_mod, only : mpp_start_update_domains, mpp_complete_update_domains @@ -42,7 +42,7 @@ module MOM_domain_infra public :: pass_var, pass_vector, fill_symmetric_edges, rescale_comp_data public :: pass_var_start, pass_var_complete, pass_vector_start, pass_vector_complete public :: create_group_pass, do_group_pass, start_group_pass, complete_group_pass -public :: redistribute_array, broadcast_domain, global_field +public :: redistribute_array, broadcast_domain, same_domain, global_field public :: get_simple_array_i_ind, get_simple_array_j_ind public :: MOM_thread_affinity_set, set_MOM_thread_affinity ! These are encoding constant parmeters. @@ -105,7 +105,7 @@ module MOM_domain_infra !> Pass an array from one MOM domain to another interface redistribute_array - module procedure redistribute_array_3d, redistribute_array_2d + module procedure redistribute_array_2d, redistribute_array_3d, redistribute_array_4d end interface redistribute_array !> Copy one MOM_domain_type into another @@ -1232,6 +1232,25 @@ subroutine redistribute_array_3d(Domain1, array1, Domain2, array2, complete) end subroutine redistribute_array_3d +!> Pass a 4-D array from one MOM domain to another +subroutine redistribute_array_4d(Domain1, array1, Domain2, array2, complete) + type(domain2d), & + intent(in) :: Domain1 !< The MOM domain from which to extract information. + real, dimension(:,:,:,:), intent(in) :: array1 !< The array from which to extract information. + type(domain2d), & + intent(in) :: Domain2 !< The MOM domain receiving information. + real, dimension(:,:,:,:), intent(out) :: array2 !< The array receiving information. + logical, optional, intent(in) :: complete !< If true, finish communication before proceeding. + + ! Local variables + logical :: do_complete + + do_complete=.true.;if (PRESENT(complete)) do_complete = complete + + call mpp_redistribute(Domain1, array1, Domain2, array2, do_complete) + +end subroutine redistribute_array_4d + !> Rescale the values of a 4-D array in its computational domain by a constant factor subroutine rescale_comp_data_4d(domain, array, scale) @@ -1923,6 +1942,29 @@ subroutine global_field(domain, local, global) call mpp_global_field(domain, local, global) end subroutine global_field +!> same_domain returns true if two domains use the same list of PEs and layouts and have the same +!! size computational domains, and false if the domains do not conform with each other. +!! Different halo sizes or indexing conventions do not alter the results. +logical function same_domain(domain_a, domain_b) + type(domain2D), intent(in) :: domain_a !< The first domain in the comparison + type(domain2D), intent(in) :: domain_b !< The second domain in the comparison + + ! Local variables + integer :: isc_a, iec_a, jsc_a, jec_a, isc_b, iec_b, jsc_b, jec_b + integer :: layout_a(2), layout_b(2) + + ! This routine currently does a few checks for consistent domains; more could be added. + call mpp_get_layout(domain_a, layout_a) + call mpp_get_layout(domain_b, layout_b) + + call get_domain_extent(domain_a, isc_a, iec_a, jsc_a, jec_a) + call get_domain_extent(domain_b, isc_b, iec_b, jsc_b, jec_b) + + same_domain = (layout_a(1) == layout_b(1)) .and. (layout_a(2) == layout_b(2)) .and. & + (iec_a - isc_a == iec_b - isc_b) .and. (jec_a - jsc_a == jec_b - jsc_b) + +end function same_domain + !> Returns arrays of the i- and j- sizes of the h-point computational domains for each !! element of the grid layout. Any input values in the extent arrays are discarded, so !! they are effectively intent out despite their declared intent of inout. diff --git a/config_src/infra/FMS2/MOM_domain_infra.F90 b/config_src/infra/FMS2/MOM_domain_infra.F90 index fc39777a2f..029561946b 100644 --- a/config_src/infra/FMS2/MOM_domain_infra.F90 +++ b/config_src/infra/FMS2/MOM_domain_infra.F90 @@ -9,7 +9,7 @@ module MOM_domain_infra use mpp_domains_mod, only : domain2D, domain1D use mpp_domains_mod, only : mpp_define_io_domain, mpp_define_domains, mpp_deallocate_domain -use mpp_domains_mod, only : mpp_get_domain_components, mpp_get_domain_extents +use mpp_domains_mod, only : mpp_get_domain_components, mpp_get_domain_extents, mpp_get_layout use mpp_domains_mod, only : mpp_get_compute_domain, mpp_get_data_domain, mpp_get_global_domain use mpp_domains_mod, only : mpp_get_boundary, mpp_update_domains use mpp_domains_mod, only : mpp_start_update_domains, mpp_complete_update_domains @@ -42,7 +42,7 @@ module MOM_domain_infra public :: pass_var, pass_vector, fill_symmetric_edges, rescale_comp_data public :: pass_var_start, pass_var_complete, pass_vector_start, pass_vector_complete public :: create_group_pass, do_group_pass, start_group_pass, complete_group_pass -public :: redistribute_array, broadcast_domain, global_field +public :: redistribute_array, broadcast_domain, same_domain, global_field public :: get_simple_array_i_ind, get_simple_array_j_ind public :: MOM_thread_affinity_set, set_MOM_thread_affinity ! These are encoding constant parmeters. @@ -105,7 +105,7 @@ module MOM_domain_infra !> Pass an array from one MOM domain to another interface redistribute_array - module procedure redistribute_array_3d, redistribute_array_2d + module procedure redistribute_array_2d, redistribute_array_3d, redistribute_array_4d end interface redistribute_array !> Copy one MOM_domain_type into another @@ -1232,6 +1232,25 @@ subroutine redistribute_array_3d(Domain1, array1, Domain2, array2, complete) end subroutine redistribute_array_3d +!> Pass a 4-D array from one MOM domain to another +subroutine redistribute_array_4d(Domain1, array1, Domain2, array2, complete) + type(domain2d), & + intent(in) :: Domain1 !< The MOM domain from which to extract information. + real, dimension(:,:,:,:), intent(in) :: array1 !< The array from which to extract information. + type(domain2d), & + intent(in) :: Domain2 !< The MOM domain receiving information. + real, dimension(:,:,:,:), intent(out) :: array2 !< The array receiving information. + logical, optional, intent(in) :: complete !< If true, finish communication before proceeding. + + ! Local variables + logical :: do_complete + + do_complete=.true.;if (PRESENT(complete)) do_complete = complete + + call mpp_redistribute(Domain1, array1, Domain2, array2, do_complete) + +end subroutine redistribute_array_4d + !> Rescale the values of a 4-D array in its computational domain by a constant factor subroutine rescale_comp_data_4d(domain, array, scale) @@ -1923,6 +1942,29 @@ subroutine global_field(domain, local, global) call mpp_global_field(domain, local, global) end subroutine global_field +!> same_domain returns true if two domains use the same list of PEs and layouts and have the same +!! size computational domains, and false if the domains do not conform with each other. +!! Different halo sizes or indexing conventions do not alter the results. +logical function same_domain(domain_a, domain_b) + type(domain2D), intent(in) :: domain_a !< The first domain in the comparison + type(domain2D), intent(in) :: domain_b !< The second domain in the comparison + + ! Local variables + integer :: isc_a, iec_a, jsc_a, jec_a, isc_b, iec_b, jsc_b, jec_b + integer :: layout_a(2), layout_b(2) + + ! This routine currently does a few checks for consistent domains; more could be added. + call mpp_get_layout(domain_a, layout_a) + call mpp_get_layout(domain_b, layout_b) + + call get_domain_extent(domain_a, isc_a, iec_a, jsc_a, jec_a) + call get_domain_extent(domain_b, isc_b, iec_b, jsc_b, jec_b) + + same_domain = (layout_a(1) == layout_b(1)) .and. (layout_a(2) == layout_b(2)) .and. & + (iec_a - isc_a == iec_b - isc_b) .and. (jec_a - jsc_a == jec_b - jsc_b) + +end function same_domain + !> Returns arrays of the i- and j- sizes of the h-point computational domains for each !! element of the grid layout. Any input values in the extent arrays are discarded, so !! they are effectively intent out despite their declared intent of inout. diff --git a/src/framework/MOM_domains.F90 b/src/framework/MOM_domains.F90 index b25a934b97..0cdcc455fc 100644 --- a/src/framework/MOM_domains.F90 +++ b/src/framework/MOM_domains.F90 @@ -8,7 +8,7 @@ module MOM_domains use MOM_coms_infra, only : sum_across_PEs, min_across_PEs, max_across_PEs use MOM_domain_infra, only : MOM_domain_type, domain2D, domain1D, group_pass_type use MOM_domain_infra, only : create_MOM_domain, clone_MOM_domain, deallocate_MOM_domain -use MOM_domain_infra, only : get_domain_extent, get_domain_components +use MOM_domain_infra, only : get_domain_extent, get_domain_components, same_domain use MOM_domain_infra, only : compute_block_extent, get_global_shape use MOM_domain_infra, only : pass_var, pass_vector, fill_symmetric_edges, global_field_sum use MOM_domain_infra, only : pass_var_start, pass_var_complete @@ -33,8 +33,10 @@ module MOM_domains public :: MOM_domains_init, create_MOM_domain, clone_MOM_domain, deallocate_MOM_domain public :: MOM_thread_affinity_set, set_MOM_thread_affinity ! Domain query routines -public :: get_domain_extent, get_domain_components, compute_block_extent, get_global_shape +public :: get_domain_extent, get_domain_components, get_global_shape, same_domain public :: PE_here, root_PE, num_PEs +! Blocks are not actively used in MOM6, so this routine could be deprecated. +public :: compute_block_extent ! Single call communication routines public :: pass_var, pass_vector, fill_symmetric_edges, broadcast ! Non-blocking communication routines From 9792b23465d78854044d0919ac6dad61216d8368 Mon Sep 17 00:00:00 2001 From: John Krasting Date: Thu, 1 Apr 2021 11:38:26 -0400 Subject: [PATCH 035/112] Fixed downsampling for x:sum y:point z:point diags - previous code had averaging instead of summation for SPP (x:sum,y:point,z:point) diagnostics - corrects an issue where these diagnostics were incorrect by approximately a factor of 2. - Orginially found when analyzing the depth-integrated temperature advection diagnostic (T_ady_2d) --- src/framework/MOM_diag_mediator.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/framework/MOM_diag_mediator.F90 b/src/framework/MOM_diag_mediator.F90 index b4cce081a0..4425a3374f 100644 --- a/src/framework/MOM_diag_mediator.F90 +++ b/src/framework/MOM_diag_mediator.F90 @@ -4181,7 +4181,7 @@ subroutine downsample_field_2d(field_in, field_out, dl, method, mask, diag_cs, d 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 !Masked Sum (total_weight=1) enddo ; enddo elseif (method == PMP) then do j=jsv_d,jev_d ; do i=isv_d,iev_d From d1dc6b5ba0abdce9705873d0a6abf4c4f3da2956 Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Thu, 1 Apr 2021 17:23:14 -0400 Subject: [PATCH 036/112] Coriolis: Improved coradcalc vectorization This patch restructures the CorAdCalc function so that the loops are more easily vectorized on a broader range of systems. The number of memory access has also been slightly reduced. We observed a 1.75x speedup on a modern consumer AMD processor (Ryzen 5 2600) and a 1.24x speedup on Gaea's Intel Xeons (E5-2697 v4). Description There are two major changes: - An if-block testing for `Area_q` was removed, and the `h_neglect * Area_q` term was replaced with a new `vol_neglect` term. This term is intended to prevent division by zero when the hArea_q is zero. Otherwise, it is meant to be below roundoff and have no impact on the calculation. Previously, a zero value of Area_q would force a division by zero. Using vol_neglect ensures that the denominator is always nonzero. The value is set to use `H_subroundoff` times an area of 0.1 mm2, suggested by Robert Hallberg as a hypothetical Kolmogorov scale. Numerical results are intended to be independent of this choice. - Two separated loops associated with the bounded Coriolis term were combined into a single loop, which reduced both the number of internal if-blocks and avoided redundant memory load/stores. Other if-blocks inside of do-loops were moved outside of the loops. I can provide two potential explanations for the difference in Intel and AMD performance: * Masking instructions have a lower latency on Intel CPUs, which permit limited vectorization of if-blocks. Similar vectorization is not possible on AMD CPUs. So Intel is less likely to benefit from if-block re-ordering. * Our Intel nodes on Gaea have a lower RAM bandwidth, and see a smaller benefit from vectorization, which must required greater bandwidth. This speedup may be greater on a more modern Intel platform. Although the code has been vectorized on both Intel and AMD platforms, there are still many memory accesses per operation, which is limiting performance. The changes below are not expected to change any answers, and none were detected. But since we are changing a core component, I'd suggest reviewing this carefully. Sample timings are provided below. Runtime measurements -------------------- AMD Before: (Ocean Coriolis & mom advection) 1.091571 (Ocean Coriolis & mom advection) 1.086183 (Ocean Coriolis & mom advection) 1.091197 (Ocean Coriolis & mom advection) 1.087709 (Ocean Coriolis & mom advection) 1.086990 AMD After: (Ocean Coriolis & mom advection) 0.619346 (Ocean Coriolis & mom advection) 0.624106 (Ocean Coriolis & mom advection) 0.625438 (Ocean Coriolis & mom advection) 0.630169 (Ocean Coriolis & mom advection) 0.621736 ---- Intel Before: (Ocean Coriolis & mom advection) 0.981367 (Ocean Coriolis & mom advection) 0.982316 (Ocean Coriolis & mom advection) 0.986633 (Ocean Coriolis & mom advection) 0.981260 (Ocean Coriolis & mom advection) 0.982810 Intel After: (Ocean Coriolis & mom advection) 0.788747 (Ocean Coriolis & mom advection) 0.797684 (Ocean Coriolis & mom advection) 0.786874 (Ocean Coriolis & mom advection) 0.792120 (Ocean Coriolis & mom advection) 0.795373 --- src/core/MOM_CoriolisAdv.F90 | 131 +++++++++++++++++++---------------- 1 file changed, 72 insertions(+), 59 deletions(-) diff --git a/src/core/MOM_CoriolisAdv.F90 b/src/core/MOM_CoriolisAdv.F90 index 7cbc1eb262..b12d3e37e7 100644 --- a/src/core/MOM_CoriolisAdv.F90 +++ b/src/core/MOM_CoriolisAdv.F90 @@ -170,6 +170,7 @@ subroutine CorAdCalc(u, v, h, uh, vh, CAu, CAv, OBC, AD, G, GV, US, CS) ! discretization [H-1 s-1 ~> m-1 s-1 or m2 kg-1 s-1]. real, dimension(SZIB_(G),SZJB_(G)) :: & dvdx, dudy, & ! Contributions to the circulation around q-points [L2 T-1 ~> m2 s-1] + rel_vort, & ! Relative vorticity at q-points [T-1 ~> s-1]. abs_vort, & ! Absolute vorticity at q-points [T-1 ~> s-1]. q2, & ! Relative vorticity over thickness [H-1 T-1 ~> m-1 s-1 or m2 kg-1 s-1]. max_fvq, & ! The maximum of the adjacent values of (-u) times absolute vorticity [L T-2 ~> m s-2]. @@ -179,7 +180,8 @@ subroutine CorAdCalc(u, v, h, uh, vh, CAu, CAv, OBC, AD, G, GV, US, CS) real, dimension(SZIB_(G),SZJB_(G),SZK_(GV)) :: & PV, & ! A diagnostic array of the potential vorticities [H-1 T-1 ~> m-1 s-1 or m2 kg-1 s-1]. RV ! A diagnostic array of the relative vorticities [T-1 ~> s-1]. - real :: fv1, fv2, fu1, fu2 ! (f+rv)*v or (f+rv)*u [L T-2 ~> m s-2]. + real :: fv1, fv2, fv3, fv4 ! (f+rv)*v [L T-2 ~> m s-2]. + real :: fu1, fu2, fu3, fu4 ! -(f+rv)*u [L T-2 ~> m s-2]. real :: max_fv, max_fu ! The maximum or minimum of the neighboring Coriolis real :: min_fv, min_fu ! accelerations [L T-2 ~> m s-2], i.e. max(min)_fu(v)q. @@ -191,8 +193,8 @@ subroutine CorAdCalc(u, v, h, uh, vh, CAu, CAv, OBC, AD, G, GV, US, CS) real :: max_Ihq, min_Ihq ! The maximum and minimum of the nearby Ihq [H-1 ~> m-1 or m2 kg-1]. real :: hArea_q ! The sum of area times thickness of the cells ! surrounding a q point [H L2 ~> m3 or kg]. - 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 :: vol_neglect ! A volume so small that is expected to be + ! lost in roundoff [H L2 ~> m3 or kg]. real :: temp1, temp2 ! Temporary variables [L2 T-2 ~> m2 s-2]. real :: eps_vel ! A tiny, positive velocity [L T-1 ~> m s-1]. @@ -241,7 +243,7 @@ subroutine CorAdCalc(u, v, h, uh, vh, CAu, CAv, OBC, AD, G, GV, US, CS) "MOM_CoriolisAdv: Module must be initialized before it is used.") is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB ; nz = GV%ke - h_neglect = GV%H_subroundoff + vol_neglect = GV%H_subroundoff * (1e-4 * US%m_to_L)**2 eps_vel = 1.0e-10*US%m_s_to_L_T h_tiny = GV%Angstrom_H ! Perhaps this should be set to h_neglect instead. @@ -277,7 +279,7 @@ subroutine CorAdCalc(u, v, h, uh, vh, CAu, CAv, OBC, AD, G, GV, US, CS) enddo ; enddo !$OMP parallel do default(private) shared(u,v,h,uh,vh,CAu,CAv,G,GV,CS,AD,Area_h,Area_q,& - !$OMP RV,PV,is,ie,js,je,Isq,Ieq,Jsq,Jeq,nz,h_neglect,h_tiny,OBC,eps_vel) + !$OMP RV,PV,is,ie,js,je,Isq,Ieq,Jsq,Jeq,nz,vol_neglect,h_tiny,OBC,eps_vel) do k=1,nz ! Here the second order accurate layer potential vorticities, q, @@ -295,6 +297,7 @@ subroutine CorAdCalc(u, v, h, uh, vh, CAu, CAv, OBC, AD, G, GV, US, CS) do j=Jsq-1,Jeq+2 ; do I=Isq-1,Ieq+1 hArea_u(I,j) = 0.5*(Area_h(i,j) * h(i,j,k) + Area_h(i+1,j) * h(i+1,j,k)) enddo ; enddo + if (CS%Coriolis_En_Dis) then do j=Jsq,Jeq+1 ; do I=is-1,ie uh_center(I,j) = 0.5 * (G%dy_Cu(I,j) * u(I,j,k)) * (h(i,j,k) + h(i+1,j,k)) @@ -428,45 +431,44 @@ subroutine CorAdCalc(u, v, h, uh, vh, CAu, CAv, OBC, AD, G, GV, US, CS) endif enddo ; endif + if (CS%no_slip) then + do J=Jsq-1,Jeq+1 ; do I=Isq-1,Ieq+1 + rel_vort(I,J) = (2.0 - G%mask2dBu(I,J)) * (dvdx(I,J) - dudy(I,J)) * G%IareaBu(I,J) + enddo ; enddo + else + do J=Jsq-1,Jeq+1 ; do I=Isq-1,Ieq+1 + rel_vort(I,J) = G%mask2dBu(I,J) * (dvdx(I,J) - dudy(I,J)) * G%IareaBu(I,J) + enddo ; enddo + endif + do J=Jsq-1,Jeq+1 ; do I=Isq-1,Ieq+1 - if (CS%no_slip ) then - relative_vorticity = (2.0-G%mask2dBu(I,J)) * (dvdx(I,J) - dudy(I,J)) * G%IareaBu(I,J) - else - relative_vorticity = G%mask2dBu(I,J) * (dvdx(I,J) - dudy(I,J)) * G%IareaBu(I,J) - endif - absolute_vorticity = G%CoriolisBu(I,J) + relative_vorticity - Ih = 0.0 - if (Area_q(i,j) > 0.0) then - hArea_q = (hArea_u(I,j) + hArea_u(I,j+1)) + (hArea_v(i,J) + hArea_v(i+1,J)) - Ih = Area_q(i,j) / (hArea_q + h_neglect*Area_q(i,j)) - endif - q(I,J) = absolute_vorticity * Ih - abs_vort(I,J) = absolute_vorticity - Ih_q(I,J) = Ih - - if (CS%bound_Coriolis) then - fv1 = absolute_vorticity * v(i+1,J,k) - fv2 = absolute_vorticity * v(i,J,k) - fu1 = -absolute_vorticity * u(I,j+1,k) - fu2 = -absolute_vorticity * u(I,j,k) - if (fv1 > fv2) then - max_fvq(I,J) = fv1 ; min_fvq(I,J) = fv2 - else - max_fvq(I,J) = fv2 ; min_fvq(I,J) = fv1 - endif - if (fu1 > fu2) then - max_fuq(I,J) = fu1 ; min_fuq(I,J) = fu2 - else - max_fuq(I,J) = fu2 ; min_fuq(I,J) = fu1 - endif - endif + abs_vort(I,J) = G%CoriolisBu(I,J) + rel_vort(I,J) + enddo ; enddo - if (CS%id_rv > 0) RV(I,J,k) = relative_vorticity - if (CS%id_PV > 0) PV(I,J,k) = q(I,J) - if (associated(AD%rv_x_v) .or. associated(AD%rv_x_u)) & - q2(I,J) = relative_vorticity * Ih + do J=Jsq-1,Jeq+1 ; do I=Isq-1,Ieq+1 + hArea_q = (hArea_u(I,j) + hArea_u(I,j+1)) + (hArea_v(i,J) + hArea_v(i+1,J)) + Ih_q(I,J) = Area_q(I,J) / (hArea_q + vol_neglect) + q(I,J) = abs_vort(I,J) * Ih_q(I,J) enddo ; enddo + if (CS%id_rv > 0) then + do J=Jsq-1,Jeq+1 ; do I=Isq-1,Ieq+1 + RV(I,J,k) = rel_vort(I,J) + enddo ; enddo + endif + + if (CS%id_PV > 0) then + do J=Jsq-1,Jeq+1 ; do I=Isq-1,Ieq+1 + PV(I,J,k) = q(I,J) + enddo ; enddo + endif + + if (associated(AD%rv_x_v) .or. associated(AD%rv_x_u)) then + do J=Jsq-1,Jeq+1 ; do I=Isq-1,Ieq+1 + q2(I,J) = rel_vort(I,J) * Ih_q(I,J) + enddo ; enddo + endif + ! a, b, c, and d are combinations of neighboring potential ! vorticities which form the Arakawa and Hsu vorticity advection ! scheme. All are defined at u grid points. @@ -671,27 +673,31 @@ subroutine CorAdCalc(u, v, h, uh, vh, CAu, CAv, OBC, AD, G, GV, US, CS) (ep_u(i,j)*uh(I-1,j,k) - ep_u(i+1,j)*uh(I+1,j,k)) * G%IdxCu(I,j) enddo ; enddo ; endif - if (CS%bound_Coriolis) then do j=js,je ; do I=Isq,Ieq - max_fv = MAX(max_fvq(I,J), max_fvq(I,J-1)) - min_fv = MIN(min_fvq(I,J), min_fvq(I,J-1)) - ! CAu(I,j,k) = min( CAu(I,j,k), max_fv ) - ! CAu(I,j,k) = max( CAu(I,j,k), min_fv ) - if (CAu(I,j,k) > max_fv) then - CAu(I,j,k) = max_fv - else - if (CAu(I,j,k) < min_fv) CAu(I,j,k) = min_fv - endif + fv1 = abs_vort(I,J) * v(i+1,J,k) + fv2 = abs_vort(I,J) * v(i,J,k) + fv3 = abs_vort(I,J-1) * v(i+1,J-1,k) + fv4 = abs_vort(I,J-1) * v(i,J-1,k) + + max_fv = max(fv1, fv2, fv3, fv4) + min_fv = min(fv1, fv2, fv3, fv4) + + CAu(I,j,k) = min(CAu(I,j,k), max_fv) + CAu(I,j,k) = max(CAu(I,j,k), min_fv) enddo ; enddo endif ! Term - d(KE)/dx. do j=js,je ; do I=Isq,Ieq CAu(I,j,k) = CAu(I,j,k) - KEx(I,j) - if (associated(AD%gradKEu)) AD%gradKEu(I,j,k) = -KEx(I,j) enddo ; enddo + if (associated(AD%gradKEu)) then + do j=js,je ; do I=Isq,Ieq + AD%gradKEu(I,j,k) = -KEx(I,j) + enddo ; enddo + endif ! Calculate the tendencies of meridional velocity due to the Coriolis ! force and momentum advection. On a Cartesian grid, this is @@ -782,21 +788,28 @@ subroutine CorAdCalc(u, v, h, uh, vh, CAu, CAv, OBC, AD, G, GV, US, CS) if (CS%bound_Coriolis) then do J=Jsq,Jeq ; do i=is,ie - max_fu = MAX(max_fuq(I,J),max_fuq(I-1,J)) - min_fu = MIN(min_fuq(I,J),min_fuq(I-1,J)) - if (CAv(i,J,k) > max_fu) then - CAv(i,J,k) = max_fu - else - if (CAv(i,J,k) < min_fu) CAv(i,J,k) = min_fu - endif + fu1 = -abs_vort(I,J) * u(I,j+1,k) + fu2 = -abs_vort(I,J) * u(I,j,k) + fu3 = -abs_vort(I-1,J) * u(I-1,j+1,k) + fu4 = -abs_vort(I-1,J) * u(I-1,j,k) + + max_fu = max(fu1, fu2, fu3, fu4) + min_fu = min(fu1, fu2, fu3, fu4) + + CAv(I,j,k) = min(CAv(I,j,k), max_fu) + CAv(I,j,k) = max(CAv(I,j,k), min_fu) enddo ; enddo endif ! Term - d(KE)/dy. do J=Jsq,Jeq ; do i=is,ie CAv(i,J,k) = CAv(i,J,k) - KEy(i,J) - if (associated(AD%gradKEv)) AD%gradKEv(i,J,k) = -KEy(i,J) enddo ; enddo + if (associated(AD%gradKEv)) then + do J=Jsq,Jeq ; do i=is,ie + AD%gradKEv(i,J,k) = -KEy(i,J) + enddo ; enddo + endif if (associated(AD%rv_x_u) .or. associated(AD%rv_x_v)) then ! Calculate the Coriolis-like acceleration due to relative vorticity. From 5f063044c7b845308b0599d7f5153099b1a8ffb6 Mon Sep 17 00:00:00 2001 From: John Krasting Date: Fri, 2 Apr 2021 10:04:59 -0400 Subject: [PATCH 037/112] Fixed downsampling summation for more diag types - Fixes for SSP (x:sum;y:sum,z:point) and PSP (x:point,y:sum,z:point) diagnostics - Removed unused `total_weight` arrays in these cases --- src/framework/MOM_diag_mediator.F90 | 10 ++-------- 1 file changed, 2 insertions(+), 8 deletions(-) diff --git a/src/framework/MOM_diag_mediator.F90 b/src/framework/MOM_diag_mediator.F90 index 4425a3374f..e9ad88c17e 100644 --- a/src/framework/MOM_diag_mediator.F90 +++ b/src/framework/MOM_diag_mediator.F90 @@ -4146,39 +4146,33 @@ subroutine downsample_field_2d(field_in, field_out, dl, method, mask, diag_cs, d i0 = isv_o+dl*(i-isv_d) j0 = jsv_o+dl*(j-jsv_d) ave = 0.0 - 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) - total_weight = total_weight + 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 !Masked Sum (total_weight=1) enddo ; enddo 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) ave = 0.0 - total_weight = 0.0 ii=i0 do jj=j0,j0+dl-1 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 + field_out(i,j) = ave !Masked Sum (total_weight=1) enddo ; enddo 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) ave = 0.0 - total_weight = 0.0 jj=j0 do ii=i0,i0+dl-1 weight = mask(ii,jj) - total_weight = total_weight +weight ave = ave+field_in(ii,jj)*weight enddo field_out(i,j) = ave !Masked Sum (total_weight=1) From 358da7cc44fdd0097008263a7ee21253da702b1b Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 6 Apr 2021 18:30:15 -0400 Subject: [PATCH 038/112] Corrected comments describing CT_copy_data Corrected comments describing the various CT_copy_data routines, following suggestions in a review by Keith Lindsay. All answers are bitwise identical. --- config_src/infra/FMS1/MOM_couplertype_infra.F90 | 9 +++++---- config_src/infra/FMS2/MOM_couplertype_infra.F90 | 9 +++++---- src/framework/MOM_coupler_types.F90 | 9 +++++---- 3 files changed, 15 insertions(+), 12 deletions(-) diff --git a/config_src/infra/FMS1/MOM_couplertype_infra.F90 b/config_src/infra/FMS1/MOM_couplertype_infra.F90 index 2d6698b640..3bcccc1dc7 100644 --- a/config_src/infra/FMS1/MOM_couplertype_infra.F90 +++ b/config_src/infra/FMS1/MOM_couplertype_infra.F90 @@ -41,8 +41,9 @@ module MOM_couplertype_infra module procedure CT_destructor_1d, CT_destructor_2d end interface CT_destructor -!> Copy all elements of the data in of one coupler_2d_bc_type or coupler_3d_bc_type -!! into another. Both must have the same array sizes in common dimensions. +!> Copy all elements of the data in either a coupler_2d_bc_type or a coupler_3d_bc_type into +!! another structure of the same or the other type. Both must have the same array sizes in common +!! dimensions, while the details of any expansion from 2d to 3d are controlled by arguments. interface CT_copy_data module procedure CT_copy_data_2d, CT_copy_data_3d, CT_copy_data_2d_3d end interface CT_copy_data @@ -201,7 +202,7 @@ subroutine CT_spawn_3d_3d(var_in, var, idim, jdim, kdim, suffix, as_needed) end subroutine CT_spawn_3d_3d -!> Copy all elements of the data in of one coupler_2d_bc_type into another. Both must have the same array sizes. +!> Copy all elements of the data in a coupler_2d_bc_type into another. Both must have the same array sizes. subroutine CT_copy_data_2d(var_in, var, halo_size, bc_index, field_index, & exclude_flux_type, only_flux_type, pass_through_ice) type(coupler_2d_bc_type), intent(in) :: var_in !< BC_type structure with the data to copy @@ -222,7 +223,7 @@ subroutine CT_copy_data_2d(var_in, var, halo_size, bc_index, field_index, & exclude_flux_type, only_flux_type, pass_through_ice) end subroutine CT_copy_data_2d -!> Copy all elements of the data in of one coupler_3d_bc_type into another. Both must have the same array sizes. +!> Copy all elements of the data in a coupler_3d_bc_type into another. Both must have the same array sizes. subroutine CT_copy_data_3d(var_in, var, halo_size, bc_index, field_index, & exclude_flux_type, only_flux_type, pass_through_ice) type(coupler_3d_bc_type), intent(in) :: var_in !< BC_type structure with the data to copy diff --git a/config_src/infra/FMS2/MOM_couplertype_infra.F90 b/config_src/infra/FMS2/MOM_couplertype_infra.F90 index 2d6698b640..3bcccc1dc7 100644 --- a/config_src/infra/FMS2/MOM_couplertype_infra.F90 +++ b/config_src/infra/FMS2/MOM_couplertype_infra.F90 @@ -41,8 +41,9 @@ module MOM_couplertype_infra module procedure CT_destructor_1d, CT_destructor_2d end interface CT_destructor -!> Copy all elements of the data in of one coupler_2d_bc_type or coupler_3d_bc_type -!! into another. Both must have the same array sizes in common dimensions. +!> Copy all elements of the data in either a coupler_2d_bc_type or a coupler_3d_bc_type into +!! another structure of the same or the other type. Both must have the same array sizes in common +!! dimensions, while the details of any expansion from 2d to 3d are controlled by arguments. interface CT_copy_data module procedure CT_copy_data_2d, CT_copy_data_3d, CT_copy_data_2d_3d end interface CT_copy_data @@ -201,7 +202,7 @@ subroutine CT_spawn_3d_3d(var_in, var, idim, jdim, kdim, suffix, as_needed) end subroutine CT_spawn_3d_3d -!> Copy all elements of the data in of one coupler_2d_bc_type into another. Both must have the same array sizes. +!> Copy all elements of the data in a coupler_2d_bc_type into another. Both must have the same array sizes. subroutine CT_copy_data_2d(var_in, var, halo_size, bc_index, field_index, & exclude_flux_type, only_flux_type, pass_through_ice) type(coupler_2d_bc_type), intent(in) :: var_in !< BC_type structure with the data to copy @@ -222,7 +223,7 @@ subroutine CT_copy_data_2d(var_in, var, halo_size, bc_index, field_index, & exclude_flux_type, only_flux_type, pass_through_ice) end subroutine CT_copy_data_2d -!> Copy all elements of the data in of one coupler_3d_bc_type into another. Both must have the same array sizes. +!> Copy all elements of the data in a coupler_3d_bc_type into another. Both must have the same array sizes. subroutine CT_copy_data_3d(var_in, var, halo_size, bc_index, field_index, & exclude_flux_type, only_flux_type, pass_through_ice) type(coupler_3d_bc_type), intent(in) :: var_in !< BC_type structure with the data to copy diff --git a/src/framework/MOM_coupler_types.F90 b/src/framework/MOM_coupler_types.F90 index bb01755a84..73304f7fe8 100644 --- a/src/framework/MOM_coupler_types.F90 +++ b/src/framework/MOM_coupler_types.F90 @@ -38,8 +38,9 @@ module MOM_coupler_types module procedure CT_destructor_1d, CT_destructor_2d end interface coupler_type_destructor -!> Copy all elements of the data in of one coupler_2d_bc_type or coupler_3d_bc_type -!! into another. Both must have the same array sizes in common dimensions. +!> Copy all elements of the data in either a coupler_2d_bc_type or a coupler_3d_bc_type into +!! another structure of the same or the other type. Both must have the same array sizes in common +!! dimensions, while the details of any expansion from 2d to 3d are controlled by arguments. interface coupler_type_copy_data module procedure CT_copy_data_2d, CT_copy_data_3d, CT_copy_data_2d_3d end interface coupler_type_copy_data @@ -171,7 +172,7 @@ subroutine CT_spawn_3d_3d(var_in, var, idim, jdim, kdim, suffix, as_needed) end subroutine CT_spawn_3d_3d -!> Copy all elements of the data in of one coupler_2d_bc_type into another. Both must have the same array sizes. +!> Copy all elements of the data in a coupler_2d_bc_type into another. Both must have the same array sizes. subroutine CT_copy_data_2d(var_in, var, halo_size, bc_index, field_index, & exclude_flux_type, only_flux_type, pass_through_ice) type(coupler_2d_bc_type), intent(in) :: var_in !< BC_type structure with the data to copy @@ -192,7 +193,7 @@ subroutine CT_copy_data_2d(var_in, var, halo_size, bc_index, field_index, & exclude_flux_type, only_flux_type, pass_through_ice) end subroutine CT_copy_data_2d -!> Copy all elements of the data in of one coupler_3d_bc_type into another. Both must have the same array sizes. +!> Copy all elements of the data in a coupler_3d_bc_type into another. Both must have the same array sizes. subroutine CT_copy_data_3d(var_in, var, halo_size, bc_index, field_index, & exclude_flux_type, only_flux_type, pass_through_ice) type(coupler_3d_bc_type), intent(in) :: var_in !< BC_type structure with the data to copy From dc13c2211b4e5e5a107be54bf3b9431455c9b8b1 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Wed, 17 Mar 2021 18:35:19 -0400 Subject: [PATCH 039/112] Fixed documented units for N2 - The perils of cherry-picking commits to try and create clean PRs: these units were in the first draft of the #1351 but were lost in the "clean up". --- src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 b/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 index 7d95c43b98..e42055c3b2 100644 --- a/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 +++ b/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 @@ -445,8 +445,8 @@ subroutine calc_slope_functions(h, tv, dt, G, GV, US, CS, OBC) ! Local variables real, dimension(SZI_(G), SZJ_(G),SZK_(GV)+1) :: & e ! The interface heights relative to mean sea level [Z ~> m]. - real, dimension(SZIB_(G), SZJ_(G),SZK_(GV)+1) :: N2_u ! Square of Brunt-Vaisala freq at u-points [T-2 ~> s-2] - real, dimension(SZI_(G), SZJB_(G),SZK_(GV)+1) :: N2_v ! Square of Brunt-Vaisala freq at v-points [T-2 ~> s-2] + real, dimension(SZIB_(G), SZJ_(G),SZK_(GV)+1) :: N2_u ! Square of Brunt-Vaisala freq at u-points [L2 Z-2 T-2 ~> s-2] + real, dimension(SZI_(G), SZJB_(G),SZK_(GV)+1) :: N2_v ! Square of Brunt-Vaisala freq at v-points [L2 Z-2 T-2 ~> s-2] if (.not. associated(CS)) call MOM_error(FATAL, "MOM_lateral_mixing_coeffs.F90, calc_slope_functions:"//& "Module must be initialized before it is used.") From db41c302162013ff6c861f3e58ee757b59ba4255 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Wed, 17 Mar 2021 18:13:13 -0400 Subject: [PATCH 040/112] Use local "slope" variable in calc_isoneutral_slopes() - We had an unused scalar variable that used to hold the value of slope within the various logic branches. Not sure why it was changed but I am about to add a re-use of that scalar variable so am bringing it back to life in this commit. --- src/core/MOM_isopycnal_slopes.F90 | 30 ++++++++++++++++-------------- 1 file changed, 16 insertions(+), 14 deletions(-) diff --git a/src/core/MOM_isopycnal_slopes.F90 b/src/core/MOM_isopycnal_slopes.F90 index 98b5b10998..4e8d8f5c8c 100644 --- a/src/core/MOM_isopycnal_slopes.F90 +++ b/src/core/MOM_isopycnal_slopes.F90 @@ -84,8 +84,8 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, & real :: wtA, wtB, wtL, wtR ! Unscaled weights, with various units. real :: drdx, drdy ! Zonal and meridional density gradients [R L-1 ~> kg m-4]. real :: drdz ! Vertical density gradient [R Z-1 ~> kg m-4]. - real :: Slope ! The slope of density surfaces, calculated in a way - ! that is always between -1 and 1. + real :: slope ! The slope of density surfaces, calculated in a way + ! that is always between -1 and 1. [Z L-1 ~> nondim] real :: mag_grad2 ! The squared magnitude of the 3-d density gradient [R2 Z-2 ~> kg2 m-8]. real :: slope2_Ratio ! The ratio of the slope squared to slope_max squared. real :: h_neglect ! A thickness that is so small it is usually lost @@ -184,7 +184,7 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, & !$OMP private(drdiA,drdiB,drdkL,drdkR,pres_u,T_u,S_u, & !$OMP drho_dT_u,drho_dS_u,hg2A,hg2B,hg2L,hg2R,haA, & !$OMP haB,haL,haR,dzaL,dzaR,wtA,wtB,wtL,wtR,drdz, & - !$OMP drdx,mag_grad2,Slope,slope2_Ratio,l_seg) + !$OMP drdx,mag_grad2,slope,slope2_Ratio,l_seg) do j=js,je ; do K=nz,2,-1 if (.not.(use_EOS)) then drdiA = 0.0 ; drdiB = 0.0 @@ -250,21 +250,21 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, & ! to be between -1 and 1. mag_grad2 = (Z_to_L*drdx)**2 + drdz**2 if (mag_grad2 > 0.0) then - slope_x(I,j,K) = drdx / sqrt(mag_grad2) + slope = drdx / sqrt(mag_grad2) else ! Just in case mag_grad2 = 0 ever. - slope_x(I,j,K) = 0.0 + slope = 0.0 endif if (present_N2_u) N2_u(I,j,k) = G_Rho0 * drdz * G%mask2dCu(I,j) ! Square of buoyancy freq. [L2 Z-2 T-2 ~> s-2] else ! With .not.use_EOS, the layers are constant density. - slope_x(I,j,K) = (e(i,j,K)-e(i+1,j,K)) * G%IdxCu(I,j) + slope = (e(i,j,K)-e(i+1,j,K)) * G%IdxCu(I,j) endif if (local_open_u_BC) then l_seg = OBC%segnum_u(I,j) if (l_seg /= OBC_NONE) then if (OBC%segment(l_seg)%open) then - slope_x(I,j,K) = 0. + slope = 0. ! This and/or the masking code below is to make slopes match inside ! land mask. Might not be necessary except for DEBUG output. ! if (OBC%segment(OBC%segnum_u(I,j))%direction == OBC_DIRECTION_E) then @@ -274,8 +274,9 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, & ! endif endif endif - slope_x(I,j,K) = slope_x(I,j,k) * max(g%mask2dT(i,j),g%mask2dT(i+1,j)) + slope = slope * max(g%mask2dT(i,j),g%mask2dT(i+1,j)) endif + slope_x(I,j,K) = slope enddo ! I enddo ; enddo ! end of j-loop @@ -290,7 +291,7 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, & !$OMP private(drdjA,drdjB,drdkL,drdkR,pres_v,T_v,S_v, & !$OMP drho_dT_v,drho_dS_v,hg2A,hg2B,hg2L,hg2R,haA, & !$OMP haB,haL,haR,dzaL,dzaR,wtA,wtB,wtL,wtR,drdz, & - !$OMP drdy,mag_grad2,Slope,slope2_Ratio,l_seg) + !$OMP drdy,mag_grad2,slope,slope2_Ratio,l_seg) do j=js-1,je ; do K=nz,2,-1 if (.not.(use_EOS)) then drdjA = 0.0 ; drdjB = 0.0 @@ -353,21 +354,21 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, & ! to be between -1 and 1. mag_grad2 = (Z_to_L*drdy)**2 + drdz**2 if (mag_grad2 > 0.0) then - slope_y(i,J,K) = drdy / sqrt(mag_grad2) + slope = drdy / sqrt(mag_grad2) else ! Just in case mag_grad2 = 0 ever. - slope_y(i,J,K) = 0.0 + slope = 0.0 endif if (present_N2_v) N2_v(i,J,k) = G_Rho0 * drdz * G%mask2dCv(i,J) ! Square of buoyancy freq. [L2 Z-2 T-2 ~> s-2] else ! With .not.use_EOS, the layers are constant density. - slope_y(i,J,K) = (e(i,j,K)-e(i,j+1,K)) * G%IdyCv(i,J) + slope = (e(i,j,K)-e(i,j+1,K)) * G%IdyCv(i,J) endif if (local_open_v_BC) then l_seg = OBC%segnum_v(i,J) if (l_seg /= OBC_NONE) then if (OBC%segment(l_seg)%open) then - slope_y(i,J,K) = 0. + slope = 0. ! This and/or the masking code below is to make slopes match inside ! land mask. Might not be necessary except for DEBUG output. ! if (OBC%segment(OBC%segnum_v(i,J))%direction == OBC_DIRECTION_N) then @@ -377,8 +378,9 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, & ! endif endif endif - slope_y(i,J,K) = slope_y(i,J,k) * max(g%mask2dT(i,j),g%mask2dT(i,j+1)) + slope = slope * max(g%mask2dT(i,j),g%mask2dT(i,j+1)) endif + slope_y(i,J,K) = slope enddo ! i enddo ; enddo ! end of j-loop From e64be564bd0fa5e8ca40c9babd61228b744273d0 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Thu, 18 Mar 2021 16:59:30 -0400 Subject: [PATCH 041/112] Return dz*g'*S2 from calc_iso_neutral_slopes() - The Viscbeck scheme needs a vertical average of S*N, the Eady growth rate. N can become infinite for vanished layers but since dz * S * N = dz * sqrt(S^2 N^2) = sqrt(S^2 N^2 dz^2) = sqrt(S^2 g' dz) it will be more robust to vertically sum the last expression rather than use the first in an integral. --- src/core/MOM_isopycnal_slopes.F90 | 137 +++++++++++------- .../lateral/MOM_lateral_mixing_coeffs.F90 | 13 +- 2 files changed, 93 insertions(+), 57 deletions(-) diff --git a/src/core/MOM_isopycnal_slopes.F90 b/src/core/MOM_isopycnal_slopes.F90 index 4e8d8f5c8c..454ad277ae 100644 --- a/src/core/MOM_isopycnal_slopes.F90 +++ b/src/core/MOM_isopycnal_slopes.F90 @@ -24,9 +24,10 @@ module MOM_isopycnal_slopes contains -!> Calculate isopycnal slopes, and optionally return N2 used in calculation. +!> Calculate isopycnal slopes, and optionally return other stratification dependent functions such as N^2 +!! and dz*S^2*g-prime used, or calculable from factors used, during the calculation. subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, & - slope_x, slope_y, N2_u, N2_v, halo, OBC) !, eta_to_m) + slope_x, slope_y, N2_u, N2_v, dzSx2N2, dzSy2N2, halo, OBC) !, eta_to_m) 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 @@ -45,6 +46,14 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, & real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1), & optional, intent(inout) :: N2_v !< Brunt-Vaisala frequency squared at !! interfaces between v-points [L2 Z-2 T-2 ~> s-2] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1), & + optional, intent(inout) :: dzSx2N2 !< Z-thickness times zonal slope contribution + !! to the square of Eady growth rate at u-points. + !! Equivalent to dz*S^2*g-prime. [Z T-2 -> m s-2] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1), & + optional, intent(inout) :: dzSy2N2 !< Z-thickness times meridional slope contrib. + !! to the square of Eady growth rate at v-points. + !! Equivalent to dz*S^2*g-prime. [Z T-2 -> m s-2] integer, optional, intent(in) :: halo !< Halo width over which to compute type(ocean_OBC_type), optional, pointer :: OBC !< Open boundaries control structure. @@ -147,6 +156,18 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, & N2_v(i,J,nz+1) = 0. enddo ; enddo endif + if (present(dzSx2N2)) then + do j=js,je ; do I=is-1,ie + dzSx2N2(I,j,1) = 0. + dzSx2N2(I,j,nz+1) = 0. + enddo ; enddo + endif + if (present(dzSy2N2)) then + do J=js-1,je ; do i=is,ie + dzSy2N2(i,J,1) = 0. + dzSy2N2(i,J,nz+1) = 0. + enddo ; enddo + endif if (use_EOS) then if (present(halo)) then @@ -179,7 +200,7 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, & !$OMP parallel do default(none) shared(nz,is,ie,js,je,IsdB,use_EOS,G,GV,US,pres,T,S,tv,h,e, & !$OMP h_neglect,dz_neglect,Z_to_L,L_to_Z,H_to_Z,h_neglect2, & - !$OMP present_N2_u,G_Rho0,N2_u,slope_x,EOSdom_u,local_open_u_BC, & + !$OMP present_N2_u,G_Rho0,N2_u,slope_x,dzSx2N2,EOSdom_u,local_open_u_BC, & !$OMP OBC) & !$OMP private(drdiA,drdiB,drdkL,drdkR,pres_u,T_u,S_u, & !$OMP drho_dT_u,drho_dS_u,hg2A,hg2B,hg2L,hg2R,haA, & @@ -218,31 +239,33 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, & endif + hg2A = h(i,j,k-1)*h(i+1,j,k-1) + h_neglect2 + hg2B = h(i,j,k)*h(i+1,j,k) + h_neglect2 + hg2L = h(i,j,k-1)*h(i,j,k) + h_neglect2 + hg2R = h(i+1,j,k-1)*h(i+1,j,k) + h_neglect2 + haA = 0.5*(h(i,j,k-1) + h(i+1,j,k-1)) + haB = 0.5*(h(i,j,k) + h(i+1,j,k)) + h_neglect + haL = 0.5*(h(i,j,k-1) + h(i,j,k)) + h_neglect + haR = 0.5*(h(i+1,j,k-1) + h(i+1,j,k)) + h_neglect + if (GV%Boussinesq) then + dzaL = haL * H_to_Z ; dzaR = haR * H_to_Z + else + dzaL = 0.5*(e(i,j,K-1) - e(i,j,K+1)) + dz_neglect + dzaR = 0.5*(e(i+1,j,K-1) - e(i+1,j,K+1)) + dz_neglect + endif + ! Use the harmonic mean thicknesses to weight the horizontal gradients. + ! These unnormalized weights have been rearranged to minimize divisions. + wtA = hg2A*haB ; wtB = hg2B*haA + wtL = hg2L*(haR*dzaR) ; wtR = hg2R*(haL*dzaL) + + drdz = (wtL * drdkL + wtR * drdkR) / (dzaL*wtL + dzaR*wtR) + ! The expression for drdz above is mathematically equivalent to: + ! drdz = ((hg2L/haL) * drdkL/dzaL + (hg2R/haR) * drdkR/dzaR) / & + ! ((hg2L/haL) + (hg2R/haR)) + ! This is the gradient of density along geopotentials. + if (present_N2_u) N2_u(I,j,K) = G_Rho0 * drdz * G%mask2dCu(I,j) ! Square of buoyancy freq. [L2 Z-2 T-2 ~> s-2] + if (use_EOS) then - hg2A = h(i,j,k-1)*h(i+1,j,k-1) + h_neglect2 - hg2B = h(i,j,k)*h(i+1,j,k) + h_neglect2 - hg2L = h(i,j,k-1)*h(i,j,k) + h_neglect2 - hg2R = h(i+1,j,k-1)*h(i+1,j,k) + h_neglect2 - haA = 0.5*(h(i,j,k-1) + h(i+1,j,k-1)) - haB = 0.5*(h(i,j,k) + h(i+1,j,k)) + h_neglect - haL = 0.5*(h(i,j,k-1) + h(i,j,k)) + h_neglect - haR = 0.5*(h(i+1,j,k-1) + h(i+1,j,k)) + h_neglect - if (GV%Boussinesq) then - dzaL = haL * H_to_Z ; dzaR = haR * H_to_Z - else - dzaL = 0.5*(e(i,j,K-1) - e(i,j,K+1)) + dz_neglect - dzaR = 0.5*(e(i+1,j,K-1) - e(i+1,j,K+1)) + dz_neglect - endif - ! Use the harmonic mean thicknesses to weight the horizontal gradients. - ! These unnormalized weights have been rearranged to minimize divisions. - wtA = hg2A*haB ; wtB = hg2B*haA - wtL = hg2L*(haR*dzaR) ; wtR = hg2R*(haL*dzaL) - - drdz = (wtL * drdkL + wtR * drdkR) / (dzaL*wtL + dzaR*wtR) - ! The expression for drdz above is mathematically equivalent to: - ! drdz = ((hg2L/haL) * drdkL/dzaL + (hg2R/haR) * drdkR/dzaR) / & - ! ((hg2L/haL) + (hg2R/haR)) - ! This is the gradient of density along geopotentials. drdx = ((wtA * drdiA + wtB * drdiB) / (wtA + wtB) - & drdz * (e(i,j,K)-e(i+1,j,K))) * G%IdxCu(I,j) @@ -254,9 +277,6 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, & else ! Just in case mag_grad2 = 0 ever. slope = 0.0 endif - - if (present_N2_u) N2_u(I,j,k) = G_Rho0 * drdz * G%mask2dCu(I,j) ! Square of buoyancy freq. [L2 Z-2 T-2 ~> s-2] - else ! With .not.use_EOS, the layers are constant density. slope = (e(i,j,K)-e(i+1,j,K)) * G%IdxCu(I,j) endif @@ -277,6 +297,8 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, & slope = slope * max(g%mask2dT(i,j),g%mask2dT(i+1,j)) endif slope_x(I,j,K) = slope + if (present(dzSx2N2)) dzSx2N2(I,j,K) = ( G_Rho0 * (wtL * drdkL + wtR * drdkR) / (wtL + wtR) ) & ! dz * N^2 + * ( slope**2 ) * G%mask2dCu(I,j) ! x-direction contribution to S^2 enddo ! I enddo ; enddo ! end of j-loop @@ -286,7 +308,7 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, & ! Calculate the meridional isopycnal slope. !$OMP parallel do default(none) shared(nz,is,ie,js,je,IsdB,use_EOS,G,GV,US,pres,T,S,tv, & !$OMP h,h_neglect,e,dz_neglect,Z_to_L,L_to_Z,H_to_Z, & - !$OMP h_neglect2,present_N2_v,G_Rho0,N2_v,slope_y,EOSdom_v, & + !$OMP h_neglect2,present_N2_v,G_Rho0,N2_v,slope_y,dzSy2N2,EOSdom_v, & !$OMP local_open_v_BC,OBC) & !$OMP private(drdjA,drdjB,drdkL,drdkR,pres_v,T_v,S_v, & !$OMP drho_dT_v,drho_dS_v,hg2A,hg2B,hg2L,hg2R,haA, & @@ -322,31 +344,33 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, & drho_dS_v(i) * (S(i,j+1,k)-S(i,j+1,k-1))) endif + hg2A = h(i,j,k-1)*h(i,j+1,k-1) + h_neglect2 + hg2B = h(i,j,k)*h(i,j+1,k) + h_neglect2 + hg2L = h(i,j,k-1)*h(i,j,k) + h_neglect2 + hg2R = h(i,j+1,k-1)*h(i,j+1,k) + h_neglect2 + haA = 0.5*(h(i,j,k-1) + h(i,j+1,k-1)) + h_neglect + haB = 0.5*(h(i,j,k) + h(i,j+1,k)) + h_neglect + haL = 0.5*(h(i,j,k-1) + h(i,j,k)) + h_neglect + haR = 0.5*(h(i,j+1,k-1) + h(i,j+1,k)) + h_neglect + if (GV%Boussinesq) then + dzaL = haL * H_to_Z ; dzaR = haR * H_to_Z + else + dzaL = 0.5*(e(i,j,K-1) - e(i,j,K+1)) + dz_neglect + dzaR = 0.5*(e(i,j+1,K-1) - e(i,j+1,K+1)) + dz_neglect + endif + ! Use the harmonic mean thicknesses to weight the horizontal gradients. + ! These unnormalized weights have been rearranged to minimize divisions. + wtA = hg2A*haB ; wtB = hg2B*haA + wtL = hg2L*(haR*dzaR) ; wtR = hg2R*(haL*dzaL) + + drdz = (wtL * drdkL + wtR * drdkR) / (dzaL*wtL + dzaR*wtR) + ! The expression for drdz above is mathematically equivalent to: + ! drdz = ((hg2L/haL) * drdkL/dzaL + (hg2R/haR) * drdkR/dzaR) / & + ! ((hg2L/haL) + (hg2R/haR)) + ! This is the gradient of density along geopotentials. + if (present_N2_v) N2_v(i,J,K) = G_Rho0 * drdz * G%mask2dCv(i,J) ! Square of buoyancy freq. [L2 Z-2 T-2 ~> s-2] + if (use_EOS) then - hg2A = h(i,j,k-1)*h(i,j+1,k-1) + h_neglect2 - hg2B = h(i,j,k)*h(i,j+1,k) + h_neglect2 - hg2L = h(i,j,k-1)*h(i,j,k) + h_neglect2 - hg2R = h(i,j+1,k-1)*h(i,j+1,k) + h_neglect2 - haA = 0.5*(h(i,j,k-1) + h(i,j+1,k-1)) + h_neglect - haB = 0.5*(h(i,j,k) + h(i,j+1,k)) + h_neglect - haL = 0.5*(h(i,j,k-1) + h(i,j,k)) + h_neglect - haR = 0.5*(h(i,j+1,k-1) + h(i,j+1,k)) + h_neglect - if (GV%Boussinesq) then - dzaL = haL * H_to_Z ; dzaR = haR * H_to_Z - else - dzaL = 0.5*(e(i,j,K-1) - e(i,j,K+1)) + dz_neglect - dzaR = 0.5*(e(i,j+1,K-1) - e(i,j+1,K+1)) + dz_neglect - endif - ! Use the harmonic mean thicknesses to weight the horizontal gradients. - ! These unnormalized weights have been rearranged to minimize divisions. - wtA = hg2A*haB ; wtB = hg2B*haA - wtL = hg2L*(haR*dzaR) ; wtR = hg2R*(haL*dzaL) - - drdz = (wtL * drdkL + wtR * drdkR) / (dzaL*wtL + dzaR*wtR) - ! The expression for drdz above is mathematically equivalent to: - ! drdz = ((hg2L/haL) * drdkL/dzaL + (hg2R/haR) * drdkR/dzaR) / & - ! ((hg2L/haL) + (hg2R/haR)) - ! This is the gradient of density along geopotentials. drdy = ((wtA * drdjA + wtB * drdjB) / (wtA + wtB) - & drdz * (e(i,j,K)-e(i,j+1,K))) * G%IdyCv(i,J) @@ -359,7 +383,6 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, & slope = 0.0 endif - if (present_N2_v) N2_v(i,J,k) = G_Rho0 * drdz * G%mask2dCv(i,J) ! Square of buoyancy freq. [L2 Z-2 T-2 ~> s-2] else ! With .not.use_EOS, the layers are constant density. slope = (e(i,j,K)-e(i,j+1,K)) * G%IdyCv(i,J) @@ -381,6 +404,8 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, & slope = slope * max(g%mask2dT(i,j),g%mask2dT(i,j+1)) endif slope_y(i,J,K) = slope + if (present(dzsy2N2)) dzSy2N2(i,J,K) = ( G_Rho0 * (wtL * drdkL + wtR * drdkR) / (wtL + wtR) ) & ! dz * N^2 + * ( slope**2 ) * G%mask2dCv(i,J) ! y-direction contribution to S^2 enddo ! i enddo ; enddo ! end of j-loop diff --git a/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 b/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 index e42055c3b2..6cc9bfb4bb 100644 --- a/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 +++ b/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 @@ -137,6 +137,7 @@ module MOM_lateral_mixing_coeffs !! Diagnostic identifier integer :: id_SN_u=-1, id_SN_v=-1, id_L2u=-1, id_L2v=-1, id_Res_fn = -1 integer :: id_N2_u=-1, id_N2_v=-1, id_S2_u=-1, id_S2_v=-1 + integer :: id_dzSx2N2=-1, id_dzSy2N2=-1 integer :: id_Rd_dx=-1, id_KH_u_QG = -1, id_KH_v_QG = -1 type(diag_ctrl), pointer :: diag !< A structure that is used to regulate the !! timing of diagnostic output. @@ -447,6 +448,8 @@ subroutine calc_slope_functions(h, tv, dt, G, GV, US, CS, OBC) e ! The interface heights relative to mean sea level [Z ~> m]. real, dimension(SZIB_(G), SZJ_(G),SZK_(GV)+1) :: N2_u ! Square of Brunt-Vaisala freq at u-points [L2 Z-2 T-2 ~> s-2] real, dimension(SZI_(G), SZJB_(G),SZK_(GV)+1) :: N2_v ! Square of Brunt-Vaisala freq at v-points [L2 Z-2 T-2 ~> s-2] + real, dimension(SZIB_(G), SZJ_(G),SZK_(GV)+1) :: dzSx2N2 ! Sx^2 N^2 times dz at u-points [Z T-2 ~> m s-2] + real, dimension(SZI_(G), SZJB_(G),SZK_(GV)+1) :: dzSy2N2 ! Sy^2 N^2 times dz at v-points [Z T-2 ~> m s-2] if (.not. associated(CS)) call MOM_error(FATAL, "MOM_lateral_mixing_coeffs.F90, calc_slope_functions:"//& "Module must be initialized before it is used.") @@ -455,7 +458,7 @@ subroutine calc_slope_functions(h, tv, dt, G, GV, US, CS, OBC) call find_eta(h, tv, G, GV, US, e, halo_size=2) if (CS%use_stored_slopes) then call calc_isoneutral_slopes(G, GV, US, h, e, tv, dt*CS%kappa_smooth, & - CS%slope_x, CS%slope_y, N2_u, N2_v, 1, OBC=OBC) + CS%slope_x, CS%slope_y, N2_u, N2_v, dzSx2N2, dzSy2N2, 1, OBC=OBC) call calc_Visbeck_coeffs(h, CS%slope_x, CS%slope_y, N2_u, N2_v, G, GV, US, CS, OBC=OBC) ! call calc_slope_functions_using_just_e(h, G, CS, e, .false.) else @@ -472,6 +475,8 @@ subroutine calc_slope_functions(h, tv, dt, G, GV, US, CS, OBC) if (CS%calculate_Eady_growth_rate .and. CS%use_stored_slopes) then if (CS%id_N2_u > 0) call post_data(CS%id_N2_u, N2_u, CS%diag) if (CS%id_N2_v > 0) call post_data(CS%id_N2_v, N2_v, CS%diag) + if (CS%id_dzSx2N2 > 0) call post_data(CS%id_dzSx2N2, dzSx2N2, CS%diag) + if (CS%id_dzSy2N2 > 0) call post_data(CS%id_dzSy2N2, dzSy2N2, CS%diag) endif endif @@ -1129,6 +1134,12 @@ subroutine VarMix_init(Time, G, GV, US, param_file, diag, CS) 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', conversion=(US%L_to_Z*US%s_to_T)**2) + CS%id_dzSx2N2 = register_diag_field('ocean_model', 'dzSx2N2', diag%axesCui, Time, & + 'dz * slope_x^2 * N2, or Sx^2 * g-prime, used in calculating Eady growth rate in '//& + 'Visbeck et al..', 'm s-2', conversion=US%Z_to_m*US%s_to_T**2) + CS%id_dzSy2N2 = register_diag_field('ocean_model', 'dzSy2N2', diag%axesCvi, Time, & + 'dz * slope_y^2 * N2, or Sy^2 * g-prime, used in calculating Eady growth rate in '//& + 'Visbeck et al..', 'm s-2', conversion=US%Z_to_m*US%s_to_T**2) endif if (CS%use_stored_slopes) then CS%id_S2_u = register_diag_field('ocean_model', 'S2_u', diag%axesCu1, Time, & From cd25729204f69bfa89689159c4369ebc1e07a1b6 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Fri, 19 Mar 2021 10:15:44 -0400 Subject: [PATCH 042/112] Return dz at u- v-points from calc_iso_neutral_slopes() - The dz, rather than h, at u- and v-points is needed in the Visbeck calclation of Eady growth rate. Since dz can be expensive in the non-Boussinesq mode, and it is already available where the slopes are bein calculated, it makes sense to store them, even though using "h" in Boussinesq mode --- src/core/MOM_isopycnal_slopes.F90 | 24 ++++++++++++++++--- .../lateral/MOM_lateral_mixing_coeffs.F90 | 14 +++++++++-- 2 files changed, 33 insertions(+), 5 deletions(-) diff --git a/src/core/MOM_isopycnal_slopes.F90 b/src/core/MOM_isopycnal_slopes.F90 index 454ad277ae..43f966e58c 100644 --- a/src/core/MOM_isopycnal_slopes.F90 +++ b/src/core/MOM_isopycnal_slopes.F90 @@ -27,7 +27,7 @@ module MOM_isopycnal_slopes !> Calculate isopycnal slopes, and optionally return other stratification dependent functions such as N^2 !! and dz*S^2*g-prime used, or calculable from factors used, during the calculation. subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, & - slope_x, slope_y, N2_u, N2_v, dzSx2N2, dzSy2N2, halo, OBC) !, eta_to_m) + slope_x, slope_y, N2_u, N2_v, dzu, dzv, dzSx2N2, dzSy2N2, halo, OBC) !, eta_to_m) 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 @@ -46,6 +46,10 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, & real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1), & optional, intent(inout) :: N2_v !< Brunt-Vaisala frequency squared at !! interfaces between v-points [L2 Z-2 T-2 ~> s-2] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1), & + optional, intent(inout) :: dzu !< Z-thickness at u-points [Z ~> m] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1), & + optional, intent(inout) :: dzv !< Z-thickness at v-points [Z ~> m] real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1), & optional, intent(inout) :: dzSx2N2 !< Z-thickness times zonal slope contribution !! to the square of Eady growth rate at u-points. @@ -156,6 +160,18 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, & N2_v(i,J,nz+1) = 0. enddo ; enddo endif + if (present(dzu)) then + do j=js,je ; do I=is-1,ie + dzu(I,j,1) = 0. + dzu(I,j,nz+1) = 0. + enddo ; enddo + endif + if (present(dzv)) then + do J=js-1,je ; do i=is,ie + dzv(i,J,1) = 0. + dzv(i,J,nz+1) = 0. + enddo ; enddo + endif if (present(dzSx2N2)) then do j=js,je ; do I=is-1,ie dzSx2N2(I,j,1) = 0. @@ -201,7 +217,7 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, & !$OMP parallel do default(none) shared(nz,is,ie,js,je,IsdB,use_EOS,G,GV,US,pres,T,S,tv,h,e, & !$OMP h_neglect,dz_neglect,Z_to_L,L_to_Z,H_to_Z,h_neglect2, & !$OMP present_N2_u,G_Rho0,N2_u,slope_x,dzSx2N2,EOSdom_u,local_open_u_BC, & - !$OMP OBC) & + !$OMP dzu,OBC) & !$OMP private(drdiA,drdiB,drdkL,drdkR,pres_u,T_u,S_u, & !$OMP drho_dT_u,drho_dS_u,hg2A,hg2B,hg2L,hg2R,haA, & !$OMP haB,haL,haR,dzaL,dzaR,wtA,wtB,wtL,wtR,drdz, & @@ -253,6 +269,7 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, & dzaL = 0.5*(e(i,j,K-1) - e(i,j,K+1)) + dz_neglect dzaR = 0.5*(e(i+1,j,K-1) - e(i+1,j,K+1)) + dz_neglect endif + if (present(dzu)) dzu(I,j,K) = 0.5*( dzaL + dzaR ) ! Use the harmonic mean thicknesses to weight the horizontal gradients. ! These unnormalized weights have been rearranged to minimize divisions. wtA = hg2A*haB ; wtB = hg2B*haA @@ -309,7 +326,7 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, & !$OMP parallel do default(none) shared(nz,is,ie,js,je,IsdB,use_EOS,G,GV,US,pres,T,S,tv, & !$OMP h,h_neglect,e,dz_neglect,Z_to_L,L_to_Z,H_to_Z, & !$OMP h_neglect2,present_N2_v,G_Rho0,N2_v,slope_y,dzSy2N2,EOSdom_v, & - !$OMP local_open_v_BC,OBC) & + !$OMP dzv,local_open_v_BC,OBC) & !$OMP private(drdjA,drdjB,drdkL,drdkR,pres_v,T_v,S_v, & !$OMP drho_dT_v,drho_dS_v,hg2A,hg2B,hg2L,hg2R,haA, & !$OMP haB,haL,haR,dzaL,dzaR,wtA,wtB,wtL,wtR,drdz, & @@ -358,6 +375,7 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, & dzaL = 0.5*(e(i,j,K-1) - e(i,j,K+1)) + dz_neglect dzaR = 0.5*(e(i,j+1,K-1) - e(i,j+1,K+1)) + dz_neglect endif + if (present(dzv)) dzv(i,J,K) = 0.5*( dzaL + dzaR ) ! Use the harmonic mean thicknesses to weight the horizontal gradients. ! These unnormalized weights have been rearranged to minimize divisions. wtA = hg2A*haB ; wtB = hg2B*haA diff --git a/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 b/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 index 6cc9bfb4bb..4cc62f9291 100644 --- a/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 +++ b/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 @@ -137,7 +137,7 @@ module MOM_lateral_mixing_coeffs !! Diagnostic identifier integer :: id_SN_u=-1, id_SN_v=-1, id_L2u=-1, id_L2v=-1, id_Res_fn = -1 integer :: id_N2_u=-1, id_N2_v=-1, id_S2_u=-1, id_S2_v=-1 - integer :: id_dzSx2N2=-1, id_dzSy2N2=-1 + integer :: id_dzu=-1, id_dzv=-1, id_dzSx2N2=-1, id_dzSy2N2=-1 integer :: id_Rd_dx=-1, id_KH_u_QG = -1, id_KH_v_QG = -1 type(diag_ctrl), pointer :: diag !< A structure that is used to regulate the !! timing of diagnostic output. @@ -448,6 +448,8 @@ subroutine calc_slope_functions(h, tv, dt, G, GV, US, CS, OBC) e ! The interface heights relative to mean sea level [Z ~> m]. real, dimension(SZIB_(G), SZJ_(G),SZK_(GV)+1) :: N2_u ! Square of Brunt-Vaisala freq at u-points [L2 Z-2 T-2 ~> s-2] real, dimension(SZI_(G), SZJB_(G),SZK_(GV)+1) :: N2_v ! Square of Brunt-Vaisala freq at v-points [L2 Z-2 T-2 ~> s-2] + real, dimension(SZIB_(G), SZJ_(G),SZK_(GV)+1) :: dzu ! Z-thickness at u-points [Z ~> m] + real, dimension(SZI_(G), SZJB_(G),SZK_(GV)+1) :: dzv ! Z-thickness at v-points [Z ~> m] real, dimension(SZIB_(G), SZJ_(G),SZK_(GV)+1) :: dzSx2N2 ! Sx^2 N^2 times dz at u-points [Z T-2 ~> m s-2] real, dimension(SZI_(G), SZJB_(G),SZK_(GV)+1) :: dzSy2N2 ! Sy^2 N^2 times dz at v-points [Z T-2 ~> m s-2] @@ -458,7 +460,7 @@ subroutine calc_slope_functions(h, tv, dt, G, GV, US, CS, OBC) call find_eta(h, tv, G, GV, US, e, halo_size=2) if (CS%use_stored_slopes) then call calc_isoneutral_slopes(G, GV, US, h, e, tv, dt*CS%kappa_smooth, & - CS%slope_x, CS%slope_y, N2_u, N2_v, dzSx2N2, dzSy2N2, 1, OBC=OBC) + CS%slope_x, CS%slope_y, N2_u, N2_v, dzu, dzv, dzSx2N2, dzSy2N2, 1, OBC=OBC) call calc_Visbeck_coeffs(h, CS%slope_x, CS%slope_y, N2_u, N2_v, G, GV, US, CS, OBC=OBC) ! call calc_slope_functions_using_just_e(h, G, CS, e, .false.) else @@ -475,6 +477,8 @@ subroutine calc_slope_functions(h, tv, dt, G, GV, US, CS, OBC) if (CS%calculate_Eady_growth_rate .and. CS%use_stored_slopes) then if (CS%id_N2_u > 0) call post_data(CS%id_N2_u, N2_u, CS%diag) if (CS%id_N2_v > 0) call post_data(CS%id_N2_v, N2_v, CS%diag) + if (CS%id_dzu > 0) call post_data(CS%id_dzu, dzu, CS%diag) + if (CS%id_dzv > 0) call post_data(CS%id_dzv, dzv, CS%diag) if (CS%id_dzSx2N2 > 0) call post_data(CS%id_dzSx2N2, dzSx2N2, CS%diag) if (CS%id_dzSy2N2 > 0) call post_data(CS%id_dzSy2N2, dzSy2N2, CS%diag) endif @@ -1134,6 +1138,12 @@ subroutine VarMix_init(Time, G, GV, US, param_file, diag, CS) 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', conversion=(US%L_to_Z*US%s_to_T)**2) + CS%id_dzu = register_diag_field('ocean_model', 'dzu_Visbeck', diag%axesCui, Time, & + 'dz at u-points, used in calculating Eady growth rate in Visbeck et al..', & + 'm', conversion=US%Z_to_m) + CS%id_dzv = register_diag_field('ocean_model', 'dzv_Visbeck', diag%axesCvi, Time, & + 'dz at v-points, used in calculating Eady growth rate in Visbeck et al..', & + 'm', conversion=US%Z_to_m) CS%id_dzSx2N2 = register_diag_field('ocean_model', 'dzSx2N2', diag%axesCui, Time, & 'dz * slope_x^2 * N2, or Sx^2 * g-prime, used in calculating Eady growth rate in '//& 'Visbeck et al..', 'm s-2', conversion=US%Z_to_m*US%s_to_T**2) From 54e5f387c218dde7660e0d8c10d17e534c11d0a9 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Fri, 9 Apr 2021 12:32:10 -0400 Subject: [PATCH 043/112] Switch Eady Grth rate auxillary var from hS2N2 to hSN - Rather than take a sqrt() of dz^2 S^2 N^2 while summing dz*Sx*N, it's easier, and proves to be less troublesome, to pass dz*Sx*N between calc_isoneutral_sloeps() and Visbeck. - Added new s/r to calculate the Eady Growth rate using the dz*Sx*N array rather than from S^2 and N^2 separate arrays. - Added run-time parameter "USE_NEW_EADY_GROWTH_RATE" to use new method. --- src/core/MOM_isopycnal_slopes.F90 | 38 +-- .../lateral/MOM_lateral_mixing_coeffs.F90 | 289 +++++++++++++++--- 2 files changed, 271 insertions(+), 56 deletions(-) diff --git a/src/core/MOM_isopycnal_slopes.F90 b/src/core/MOM_isopycnal_slopes.F90 index 43f966e58c..2ac0dd945b 100644 --- a/src/core/MOM_isopycnal_slopes.F90 +++ b/src/core/MOM_isopycnal_slopes.F90 @@ -27,7 +27,7 @@ module MOM_isopycnal_slopes !> Calculate isopycnal slopes, and optionally return other stratification dependent functions such as N^2 !! and dz*S^2*g-prime used, or calculable from factors used, during the calculation. subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, & - slope_x, slope_y, N2_u, N2_v, dzu, dzv, dzSx2N2, dzSy2N2, halo, OBC) !, eta_to_m) + slope_x, slope_y, N2_u, N2_v, dzu, dzv, dzSxN, dzSyN, halo, OBC) !, eta_to_m) 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 @@ -51,13 +51,11 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, & real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1), & optional, intent(inout) :: dzv !< Z-thickness at v-points [Z ~> m] real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1), & - optional, intent(inout) :: dzSx2N2 !< Z-thickness times zonal slope contribution - !! to the square of Eady growth rate at u-points. - !! Equivalent to dz*S^2*g-prime. [Z T-2 -> m s-2] + optional, intent(inout) :: dzSxN !< Z-thickness times zonal slope contribution + !! to Eady growth rate at u-pints. [Z T-1 -> m s-1] real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1), & - optional, intent(inout) :: dzSy2N2 !< Z-thickness times meridional slope contrib. - !! to the square of Eady growth rate at v-points. - !! Equivalent to dz*S^2*g-prime. [Z T-2 -> m s-2] + optional, intent(inout) :: dzSyN !< Z-thickness times meridional slope contrib. + !! to Eady growth rate at v-pints. [Z T-1 -> m s-1] integer, optional, intent(in) :: halo !< Halo width over which to compute type(ocean_OBC_type), optional, pointer :: OBC !< Open boundaries control structure. @@ -172,16 +170,16 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, & dzv(i,J,nz+1) = 0. enddo ; enddo endif - if (present(dzSx2N2)) then + if (present(dzSxN)) then do j=js,je ; do I=is-1,ie - dzSx2N2(I,j,1) = 0. - dzSx2N2(I,j,nz+1) = 0. + dzSxN(I,j,1) = 0. + dzSxN(I,j,nz+1) = 0. enddo ; enddo endif - if (present(dzSy2N2)) then + if (present(dzSyN)) then do J=js-1,je ; do i=is,ie - dzSy2N2(i,J,1) = 0. - dzSy2N2(i,J,nz+1) = 0. + dzSyN(i,J,1) = 0. + dzSyN(i,J,nz+1) = 0. enddo ; enddo endif @@ -216,7 +214,7 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, & !$OMP parallel do default(none) shared(nz,is,ie,js,je,IsdB,use_EOS,G,GV,US,pres,T,S,tv,h,e, & !$OMP h_neglect,dz_neglect,Z_to_L,L_to_Z,H_to_Z,h_neglect2, & - !$OMP present_N2_u,G_Rho0,N2_u,slope_x,dzSx2N2,EOSdom_u,local_open_u_BC, & + !$OMP present_N2_u,G_Rho0,N2_u,slope_x,dzSxN,EOSdom_u,local_open_u_BC, & !$OMP dzu,OBC) & !$OMP private(drdiA,drdiB,drdkL,drdkR,pres_u,T_u,S_u, & !$OMP drho_dT_u,drho_dS_u,hg2A,hg2B,hg2L,hg2R,haA, & @@ -314,8 +312,9 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, & slope = slope * max(g%mask2dT(i,j),g%mask2dT(i+1,j)) endif slope_x(I,j,K) = slope - if (present(dzSx2N2)) dzSx2N2(I,j,K) = ( G_Rho0 * (wtL * drdkL + wtR * drdkR) / (wtL + wtR) ) & ! dz * N^2 - * ( slope**2 ) * G%mask2dCu(I,j) ! x-direction contribution to S^2 + if (present(dzSxN)) dzSxN(I,j,K) = sqrt( G_Rho0 * max(0., wtL * ( dzaL * drdkL ) & + + wtR * ( dzaR * drdkR )) / (wtL + wtR) ) & ! dz * N + * abs(slope) * G%mask2dCu(I,j) ! x-direction contribution to S^2 enddo ! I enddo ; enddo ! end of j-loop @@ -325,7 +324,7 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, & ! Calculate the meridional isopycnal slope. !$OMP parallel do default(none) shared(nz,is,ie,js,je,IsdB,use_EOS,G,GV,US,pres,T,S,tv, & !$OMP h,h_neglect,e,dz_neglect,Z_to_L,L_to_Z,H_to_Z, & - !$OMP h_neglect2,present_N2_v,G_Rho0,N2_v,slope_y,dzSy2N2,EOSdom_v, & + !$OMP h_neglect2,present_N2_v,G_Rho0,N2_v,slope_y,dzSyN,EOSdom_v, & !$OMP dzv,local_open_v_BC,OBC) & !$OMP private(drdjA,drdjB,drdkL,drdkR,pres_v,T_v,S_v, & !$OMP drho_dT_v,drho_dS_v,hg2A,hg2B,hg2L,hg2R,haA, & @@ -422,8 +421,9 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, & slope = slope * max(g%mask2dT(i,j),g%mask2dT(i,j+1)) endif slope_y(i,J,K) = slope - if (present(dzsy2N2)) dzSy2N2(i,J,K) = ( G_Rho0 * (wtL * drdkL + wtR * drdkR) / (wtL + wtR) ) & ! dz * N^2 - * ( slope**2 ) * G%mask2dCv(i,J) ! y-direction contribution to S^2 + if (present(dzSyN)) dzSyN(i,J,K) = sqrt( G_Rho0 * max(0., wtL * ( dzaL * drdkL ) & + + wtR * ( dzaR * drdkR )) / (wtL + wtR) ) & ! dz * N + * abs(slope) * G%mask2dCv(i,J) ! x-direction contribution to S^2 enddo ! i enddo ; enddo ! end of j-loop diff --git a/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 b/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 index 4cc62f9291..37c995c0e4 100644 --- a/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 +++ b/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 @@ -55,6 +55,11 @@ module MOM_lateral_mixing_coeffs !! This parameter is set depending on other parameters. logical :: calculate_Eady_growth_rate !< If true, calculate all the Eady growth rate. !! This parameter is set depending on other parameters. + logical :: use_new_Eady_growth_rate !< If true, use a simpler method to calculate the + !! Eady growth rate that avoids division by layer thickness. + !! This parameter is set depending on other parameters. + real :: cropping_distance !< Distance from surface or bottom to filter out outcropped or + !! incropped interfaces for the Eady growth rate calc [Z ~> m] real, dimension(:,:), pointer :: & SN_u => NULL(), & !< S*N at u-points [T-1 ~> s-1] SN_v => NULL(), & !< S*N at v-points [T-1 ~> s-1] @@ -111,6 +116,7 @@ module MOM_lateral_mixing_coeffs logical :: use_Visbeck !< Use Visbeck formulation for thickness diffusivity integer :: VarMix_Ktop !< Top layer to start downward integrals real :: Visbeck_L_scale !< Fixed length scale in Visbeck formula + real :: Eady_GR_D_scale !< Depth over which to average SN [Z ~> m] real :: Res_coef_khth !< A non-dimensional number that determines the function !! of resolution, used for thickness and tracer mixing, as: !! F = 1 / (1 + (Res_coef_khth*Ld/dx)^Res_fn_power) @@ -137,7 +143,7 @@ module MOM_lateral_mixing_coeffs !! Diagnostic identifier integer :: id_SN_u=-1, id_SN_v=-1, id_L2u=-1, id_L2v=-1, id_Res_fn = -1 integer :: id_N2_u=-1, id_N2_v=-1, id_S2_u=-1, id_S2_v=-1 - integer :: id_dzu=-1, id_dzv=-1, id_dzSx2N2=-1, id_dzSy2N2=-1 + integer :: id_dzu=-1, id_dzv=-1, id_dzSxN=-1, id_dzSyN=-1 integer :: id_Rd_dx=-1, id_KH_u_QG = -1, id_KH_v_QG = -1 type(diag_ctrl), pointer :: diag !< A structure that is used to regulate the !! timing of diagnostic output. @@ -450,44 +456,51 @@ subroutine calc_slope_functions(h, tv, dt, G, GV, US, CS, OBC) real, dimension(SZI_(G), SZJB_(G),SZK_(GV)+1) :: N2_v ! Square of Brunt-Vaisala freq at v-points [L2 Z-2 T-2 ~> s-2] real, dimension(SZIB_(G), SZJ_(G),SZK_(GV)+1) :: dzu ! Z-thickness at u-points [Z ~> m] real, dimension(SZI_(G), SZJB_(G),SZK_(GV)+1) :: dzv ! Z-thickness at v-points [Z ~> m] - real, dimension(SZIB_(G), SZJ_(G),SZK_(GV)+1) :: dzSx2N2 ! Sx^2 N^2 times dz at u-points [Z T-2 ~> m s-2] - real, dimension(SZI_(G), SZJB_(G),SZK_(GV)+1) :: dzSy2N2 ! Sy^2 N^2 times dz at v-points [Z T-2 ~> m s-2] + real, dimension(SZIB_(G), SZJ_(G),SZK_(GV)+1) :: dzSxN ! |Sx| N times dz at u-points [Z T-1 ~> m s-1] + real, dimension(SZI_(G), SZJB_(G),SZK_(GV)+1) :: dzSyN ! |Sy| N times dz at v-points [Z T-1 ~> m s-1] if (.not. associated(CS)) call MOM_error(FATAL, "MOM_lateral_mixing_coeffs.F90, calc_slope_functions:"//& "Module must be initialized before it is used.") if (CS%calculate_Eady_growth_rate) then - call find_eta(h, tv, G, GV, US, e, halo_size=2) - if (CS%use_stored_slopes) then + if (CS%use_new_Eady_growth_rate) then + call find_eta(h, tv, G, GV, US, e, halo_size=2) call calc_isoneutral_slopes(G, GV, US, h, e, tv, dt*CS%kappa_smooth, & - CS%slope_x, CS%slope_y, N2_u, N2_v, dzu, dzv, dzSx2N2, dzSy2N2, 1, OBC=OBC) - call calc_Visbeck_coeffs(h, CS%slope_x, CS%slope_y, N2_u, N2_v, G, GV, US, CS, OBC=OBC) -! call calc_slope_functions_using_just_e(h, G, CS, e, .false.) + CS%slope_x, CS%slope_y, N2_u=N2_u, N2_v=N2_v, dzu=dzu, dzv=dzv, & + dzSxN=dzSxN, dzSyN=dzSyN, halo=1, OBC=OBC) + call calc_Eady_growth_rate_2D(CS, G, GV, US, OBC, h, e, dzu, dzv, dzSxN, dzSyN, CS%SN_u, CS%SN_v) else - !call calc_isoneutral_slopes(G, GV, h, e, tv, dt*CS%kappa_smooth, CS%slope_x, CS%slope_y) - call calc_slope_functions_using_just_e(h, G, GV, US, CS, e, .true., OBC=OBC) + call find_eta(h, tv, G, GV, US, e, halo_size=2) + if (CS%use_stored_slopes) then + call calc_isoneutral_slopes(G, GV, US, h, e, tv, dt*CS%kappa_smooth, & + CS%slope_x, CS%slope_y, N2_u=N2_u, N2_v=N2_v, halo=1, OBC=OBC) + call calc_Visbeck_coeffs_old(h, CS%slope_x, CS%slope_y, N2_u, N2_v, G, GV, US, CS, OBC=OBC) + else + !call calc_isoneutral_slopes(G, GV, h, e, tv, dt*CS%kappa_smooth, CS%slope_x, CS%slope_y) + call calc_slope_functions_using_just_e(h, G, GV, US, CS, e, .true., OBC=OBC) + endif endif endif if (query_averaging_enabled(CS%diag)) then + if (CS%id_dzu > 0) call post_data(CS%id_dzu, dzu, CS%diag) + if (CS%id_dzv > 0) call post_data(CS%id_dzv, dzv, CS%diag) + if (CS%id_dzSxN > 0) call post_data(CS%id_dzSxN, dzSxN, CS%diag) + if (CS%id_dzSyN > 0) call post_data(CS%id_dzSyN, dzSyN, CS%diag) if (CS%id_SN_u > 0) call post_data(CS%id_SN_u, CS%SN_u, CS%diag) if (CS%id_SN_v > 0) call post_data(CS%id_SN_v, CS%SN_v, CS%diag) if (CS%id_L2u > 0) call post_data(CS%id_L2u, CS%L2u, CS%diag) if (CS%id_L2v > 0) call post_data(CS%id_L2v, CS%L2v, CS%diag) - if (CS%calculate_Eady_growth_rate .and. CS%use_stored_slopes) then - if (CS%id_N2_u > 0) call post_data(CS%id_N2_u, N2_u, CS%diag) - if (CS%id_N2_v > 0) call post_data(CS%id_N2_v, N2_v, CS%diag) - if (CS%id_dzu > 0) call post_data(CS%id_dzu, dzu, CS%diag) - if (CS%id_dzv > 0) call post_data(CS%id_dzv, dzv, CS%diag) - if (CS%id_dzSx2N2 > 0) call post_data(CS%id_dzSx2N2, dzSx2N2, CS%diag) - if (CS%id_dzSy2N2 > 0) call post_data(CS%id_dzSy2N2, dzSy2N2, CS%diag) - endif + if (CS%id_N2_u > 0) call post_data(CS%id_N2_u, N2_u, CS%diag) + if (CS%id_N2_v > 0) call post_data(CS%id_N2_v, N2_v, CS%diag) endif end subroutine calc_slope_functions -!> Calculates factors used when setting diffusivity coefficients similar to Visbeck et al. -subroutine calc_Visbeck_coeffs(h, slope_x, slope_y, N2_u, N2_v, G, GV, US, CS, OBC) +!> Calculates factors used when setting diffusivity coefficients similar to Visbeck et al., 1997. +!! This is on older implementation that is susceptible to large values of Eady growth rate +!! for incropping layers. +subroutine calc_Visbeck_coeffs_old(h, slope_x, slope_y, N2_u, N2_v, G, GV, US, CS, OBC) type(ocean_grid_type), intent(inout) :: G !< Ocean grid structure type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thickness [H ~> m or kg m-2] @@ -641,14 +654,195 @@ subroutine calc_Visbeck_coeffs(h, slope_x, slope_y, N2_u, N2_v, G, GV, US, CS, O endif if (CS%debug) then - call uvchksum("calc_Visbeck_coeffs slope_[xy]", slope_x, slope_y, G%HI, haloshift=1) - call uvchksum("calc_Visbeck_coeffs N2_u, N2_v", N2_u, N2_v, G%HI, & + call uvchksum("calc_Visbeck_coeffs_old slope_[xy]", slope_x, slope_y, G%HI, haloshift=1) + call uvchksum("calc_Visbeck_coeffs_old N2_u, N2_v", N2_u, N2_v, G%HI, & scale=US%s_to_T**2, scalar_pair=.true.) - call uvchksum("calc_Visbeck_coeffs SN_[uv]", CS%SN_u, CS%SN_v, G%HI, & + call uvchksum("calc_Visbeck_coeffs_old SN_[uv]", CS%SN_u, CS%SN_v, G%HI, & + scale=US%s_to_T, scalar_pair=.true.) + endif + +end subroutine calc_Visbeck_coeffs_old + +!> Calculates the Eady growth rate (2D fields) for use in MEKE and the Visbeck schemes +subroutine calc_Eady_growth_rate_2D(CS, G, GV, US, OBC, h, e, dzu, dzv, dzSxN, dzSyN, SN_u, SN_v) + type(VarMix_CS), intent(in) :: CS !< Variable mixing coefficients + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(ocean_OBC_type), pointer, intent(in) :: OBC !< Open boundaries control structure. +real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Interface height [Z ~> m] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), intent(in) :: e !< Interface height [Z ~> m] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1), intent(in) :: dzu !< dz at u-points [Z ~> m] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1), intent(in) :: dzv !< dz at v-points [Z ~> m] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1), intent(in) :: dzSxN !< dz Sx N at u-points [Z T-1 ~> m s-1] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1), intent(in) :: dzSyN !< dz Sy N at v-points [Z T-1 ~> m s-1] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1), intent(inout) :: SN_u !< SN at u-points [T-1 ~> s-1] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1), intent(inout) :: SN_v !< SN at v-points [T-1 ~> s-1] + ! Local variables + real :: D_scale ! The depth over which to average SN [Z ~> m] + real :: dnew ! Depth of bottom of layer [Z ~> m] + real :: dz ! Limited thickness of this layer [Z ~> m] + real :: weight ! Fraction of this layer that contributes to integral [nondim] + real :: sum_dz(SZI_(G)) ! Cumulative sum of z-thicknesses [Z ~> m] + real :: vint_SN(SZIB_(G)) ! Cumulative integral of SN [Z T-1 ~> m s-1] + real, dimension(SZIB_(G),SZJ_(G)) :: SN_cpy !< SN at u-points [T-1 ~> s-1] + real :: dz_neglect ! An incy wincy distance to avoid division by zero [Z ~> m] + real :: r_crp_dist ! The inverse of the distance over which to scale the cropping [Z-1 ~. m-1] + real :: dB, dT ! Elevation variables used when cropping [Z ~> m] + integer :: i, j, k, l_seg + logical :: local_open_u_BC, local_open_v_BC, crop + + dz_neglect = GV%H_subroundoff * GV%H_to_Z + D_scale = CS%Eady_GR_D_scale + if (D_scale<=0.) D_scale = 64.*GV%max_depth ! 0 means use full depth so choose something big + r_crp_dist = 1. / max( dz_neglect, CS%cropping_distance ) + crop = CS%cropping_distance>=0. ! Only filter out in-/out-cropped interface is parameter if non-negative + + local_open_u_BC = .false. + local_open_v_BC = .false. + if (associated(OBC)) then + local_open_u_BC = OBC%open_u_BCs_exist_globally + local_open_v_BC = OBC%open_v_BCs_exist_globally + endif + + if (CS%debug) then + call uvchksum("calc_Eady_growth_rate_2D dz[uv]", dzu, dzv, G%HI, scale=US%Z_to_m, scalar_pair=.true.) + call uvchksum("calc_Eady_growth_rate_2D dzS2N2[uv]", dzSxN, dzSyN, G%HI, & + scale=US%Z_to_m*US%s_to_T, scalar_pair=.true.) + endif + + !$OMP parallel do default(shared) + do j=G%jsc-1,G%jec+1 ; do i=G%isc-1,G%iec+1 + CS%SN_u(i,j) = 0.0 + CS%SN_v(i,j) = 0.0 + enddo ; enddo + + !$OMP parallel do default(shared) private(dnew,dz,weight,l_seg,vint_SN,sum_dz) + do j = G%jsc-1,G%jec+1 + do I=G%isc-1,G%iec + vint_SN(I) = 0. + sum_dz(I) = dz_neglect + enddo + if (crop) then + do K=2,GV%ke ; do I=G%isc-1,G%iec + dnew = sum_dz(I) + dzu(I,j,K) ! This is where the bottom of the layer is + dnew = min(dnew, D_scale) ! This limits the depth to D_scale + dz = max(0., dnew - sum_dz(I)) ! This is the part of the layer to be included in the integral. + ! When D_scale>dnew, dz=dzu (+roundoff error). + ! When sum_dzdnew, dz=dzu (+roundoff error). + ! When sum_dzdnew, dz=dzu (+roundoff error). + ! When sum_dzdnew, dz=dzu (+roundoff error). + ! When sum_dz The original calc_slope_function() that calculated slopes using !! interface positions only, not accounting for density variations. @@ -989,7 +1183,7 @@ subroutine VarMix_init(Time, G, GV, US, param_file, diag, CS) CS%calculate_cg1 = .false. CS%calculate_Rd_dx = .false. CS%calculate_res_fns = .false. - CS%calculate_Eady_growth_rate = .false. + CS%use_new_Eady_growth_rate = .false. CS%calculate_depth_fns = .false. ! Read all relevant parameters and write them to the model log. call log_version(param_file, mdl, version, "") @@ -1051,7 +1245,10 @@ subroutine VarMix_init(Time, G, GV, US, param_file, diag, CS) call get_param(param_file, mdl, "USE_MEKE", use_MEKE, & default=.false., do_not_log=.true.) CS%calculate_Rd_dx = CS%calculate_Rd_dx .or. use_MEKE - CS%calculate_Eady_growth_rate = CS%calculate_Eady_growth_rate .or. use_MEKE + ! Indicate whether to calculate the Eady growth rate + CS%calculate_Eady_growth_rate = use_MEKE & + .or. (KhTr_Slope_Cff>0.) & + .or. (KhTh_Slope_Cff>0.) call get_param(param_file, mdl, "KHTR_PASSIVITY_COEFF", KhTr_passivity_coeff, & default=0., do_not_log=.true.) CS%calculate_Rd_dx = CS%calculate_Rd_dx .or. (KhTr_passivity_coeff>0.) @@ -1072,7 +1269,6 @@ subroutine VarMix_init(Time, G, GV, US, param_file, diag, CS) endif if (KhTr_Slope_Cff>0. .or. KhTh_Slope_Cff>0.) then - CS%calculate_Eady_growth_rate = .true. call get_param(param_file, mdl, "VISBECK_MAX_SLOPE", CS%Visbeck_S_max, & "If non-zero, is an upper bound on slopes used in the "//& "Visbeck formula for diffusivity. This does not affect the "//& @@ -1098,10 +1294,27 @@ subroutine VarMix_init(Time, G, GV, US, param_file, diag, CS) 'Inverse eddy time-scale, S*N, at u-points', 's-1', conversion=US%s_to_T) CS%id_SN_v = register_diag_field('ocean_model', 'SN_v', diag%axesCv1, Time, & 'Inverse eddy time-scale, S*N, at v-points', 's-1', conversion=US%s_to_T) - call get_param(param_file, mdl, "VARMIX_KTOP", CS%VarMix_Ktop, & - "The layer number at which to start vertical integration "//& - "of S*N for purposes of finding the Eady growth rate.", & - units="nondim", default=2) + call get_param(param_file, mdl, "USE_NEW_EADY_GROWTH_RATE", CS%use_new_Eady_growth_rate, & + "If true, use a simpler method to calculate the Eady growth rate "//& + "that avoids division by layer thickness. Recommended.", default=.false.) + if (CS%use_new_Eady_growth_rate) then + if (.not. CS%use_stored_slopes) call MOM_error(FATAL, & + "MOM_lateral_mixing_coeffs.F90, VarMix_init:"//& + "When USE_NEW_EADY_GROWTH_RATE=True, USE_STORED_SLOPES must also be True.") + call get_param(param_file, mdl, "EADY_GROWTH_RATE_D_SCALE", CS%Eady_GR_D_scale, & + "The depth from surface over which to average SN when calculating "//& + "a 2D Eady growth rate. Zero mean use full depth.", & + units="m", default=0., scale=US%m_to_Z) + call get_param(param_file, mdl, "EADY_GROWTH_RATE_CROPPING_DISTANCE", CS%cropping_distance, & + "Distance from surface or bottom to filter out outcropped or "//& + "incropped interfaces for the Eady growth rate calc. "//& + "Negative values disables cropping.", units="m", default=0., scale=US%m_to_Z) + else + call get_param(param_file, mdl, "VARMIX_KTOP", CS%VarMix_Ktop, & + "The layer number at which to start vertical integration "//& + "of S*N for purposes of finding the Eady growth rate.", & + units="nondim", default=2) + endif endif if (KhTr_Slope_Cff>0. .or. KhTh_Slope_Cff>0.) then @@ -1138,18 +1351,20 @@ subroutine VarMix_init(Time, G, GV, US, param_file, diag, CS) 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', conversion=(US%L_to_Z*US%s_to_T)**2) + endif + if (CS%use_new_Eady_growth_rate) then CS%id_dzu = register_diag_field('ocean_model', 'dzu_Visbeck', diag%axesCui, Time, & 'dz at u-points, used in calculating Eady growth rate in Visbeck et al..', & 'm', conversion=US%Z_to_m) CS%id_dzv = register_diag_field('ocean_model', 'dzv_Visbeck', diag%axesCvi, Time, & 'dz at v-points, used in calculating Eady growth rate in Visbeck et al..', & 'm', conversion=US%Z_to_m) - CS%id_dzSx2N2 = register_diag_field('ocean_model', 'dzSx2N2', diag%axesCui, Time, & - 'dz * slope_x^2 * N2, or Sx^2 * g-prime, used in calculating Eady growth rate in '//& - 'Visbeck et al..', 'm s-2', conversion=US%Z_to_m*US%s_to_T**2) - CS%id_dzSy2N2 = register_diag_field('ocean_model', 'dzSy2N2', diag%axesCvi, Time, & - 'dz * slope_y^2 * N2, or Sy^2 * g-prime, used in calculating Eady growth rate in '//& - 'Visbeck et al..', 'm s-2', conversion=US%Z_to_m*US%s_to_T**2) + CS%id_dzSxN = register_diag_field('ocean_model', 'dzSxN', diag%axesCui, Time, & + 'dz * |slope_x| * N, used in calculating Eady growth rate in '//& + 'Visbeck et al..', 'm s-1', conversion=US%Z_to_m*US%s_to_T) + CS%id_dzSyN = register_diag_field('ocean_model', 'dzSyN', diag%axesCvi, Time, & + 'dz * |slope_y| * N, used in calculating Eady growth rate in '//& + 'Visbeck et al..', 'm s-1', conversion=US%Z_to_m*US%s_to_T) endif if (CS%use_stored_slopes) then CS%id_S2_u = register_diag_field('ocean_model', 'S2_u', diag%axesCu1, Time, & From 03b997b889102abaa98595c43603334bb4a5722b Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 9 Apr 2021 18:03:09 -0400 Subject: [PATCH 044/112] +Enhanced support for novel axes in MOM_io Added support for new IO capabilities that are needed by SIS2 to use the MOM6 framework and infrastructure code, but should also be useful within MOM6 itself. These new capabilities include writing global attributes to files, using create_file named axes that are not derived from a MOM6 grid type, and new options and elements in the vardesc type to support a wider array of axes and to provide the position of the grid staggering via an integer position variable instead of the short character strings that had been used. As a part of this commit, there are the new opaques type axis_info and attribute_info, and the new routines set_axis_info, delete_axis_info, set_attribute_info and delete_attribute_info to facilitate these new capabilities, as well as the publicly visible function position_from_horgrid to translate the vardesc%hor_grid character strings into the integer position flag used elsewhere in the MOM6 and FMS codes. Within the MOM_io_infra, there is a new variant of the overloaded interface write_meta to handle writing global attributes. There are also two new optional arguments to create_file and reopen_file, and two new optional arguments to var_desc, modify_vardesc, and query_vardesc. All answers and output are bitwise identical. --- config_src/infra/FMS1/MOM_io_infra.F90 | 11 +- config_src/infra/FMS2/MOM_io_infra.F90 | 20 +- src/framework/MOM_io.F90 | 409 ++++++++++++++++++++----- 3 files changed, 366 insertions(+), 74 deletions(-) diff --git a/config_src/infra/FMS1/MOM_io_infra.F90 b/config_src/infra/FMS1/MOM_io_infra.F90 index 0d4cc0deb5..14e0732c8a 100644 --- a/config_src/infra/FMS1/MOM_io_infra.F90 +++ b/config_src/infra/FMS1/MOM_io_infra.F90 @@ -78,7 +78,7 @@ module MOM_io_infra !> Write metadata about a variable or axis to a file and store it for later reuse interface write_metadata - module procedure write_metadata_axis, write_metadata_field + module procedure write_metadata_axis, write_metadata_field, write_metadata_global end interface write_metadata !> Close a file (or fileset). If the file handle does not point to an open file, @@ -793,4 +793,13 @@ subroutine write_metadata_field(IO_handle, field, axes, name, units, longname, & end subroutine write_metadata_field +!> Write a global text attribute to a file. +subroutine write_metadata_global(IO_handle, name, attribute) + type(file_type), intent(in) :: IO_handle !< Handle for a file that is open for writing + character(len=*), intent(in) :: name !< The name in the file of this global attribute + character(len=*), intent(in) :: attribute !< The value of this attribute + + call mpp_write_meta(IO_handle%unit, name, cval=attribute) +end subroutine write_metadata_global + end module MOM_io_infra diff --git a/config_src/infra/FMS2/MOM_io_infra.F90 b/config_src/infra/FMS2/MOM_io_infra.F90 index df9d6dc7ca..4833c37e3a 100644 --- a/config_src/infra/FMS2/MOM_io_infra.F90 +++ b/config_src/infra/FMS2/MOM_io_infra.F90 @@ -12,7 +12,7 @@ module MOM_io_infra use fms2_io_mod, only : FmsNetcdfDomainFile_t, FmsNetcdfFile_t, fms2_read_data => read_data use fms2_io_mod, only : get_unlimited_dimension_name, get_num_dimensions, get_num_variables use fms2_io_mod, only : get_variable_names, variable_exists, get_variable_size, get_variable_units -use fms2_io_mod, only : register_field, write_data, register_variable_attribute +use fms2_io_mod, only : register_field, write_data, register_variable_attribute, register_global_attribute use fms2_io_mod, only : variable_att_exists, get_variable_attribute, get_variable_num_dimensions use fms2_io_mod, only : get_variable_dimension_names, is_dimension_registered, get_dimension_size use fms2_io_mod, only : is_dimension_unlimited, register_axis, unlimited @@ -90,7 +90,7 @@ module MOM_io_infra !> Write metadata about a variable or axis to a file and store it for later reuse interface write_metadata - module procedure write_metadata_axis, write_metadata_field + module procedure write_metadata_axis, write_metadata_field, write_metadata_global end interface write_metadata !> Close a file (or fileset). If the file handle does not point to an open file, @@ -1779,7 +1779,7 @@ subroutine write_metadata_axis(IO_handle, axis, name, units, longname, cartesian endif axis%name = trim(name) - if (present(data) .and. allocated(axis%ax_data)) call MOM_error(FATAL, & + if (present(data) .and. allocated(axis%ax_data)) call MOM_error(FATAL, & "Data is already allocated in a call to write_metadata_axis for axis "//& trim(name)//" in file "//trim(IO_handle%filename)) @@ -1920,4 +1920,18 @@ subroutine write_metadata_field(IO_handle, field, axes, name, units, longname, & end subroutine write_metadata_field +!> Write a global text attribute to a file. +subroutine write_metadata_global(IO_handle, name, attribute) + type(file_type), intent(in) :: IO_handle !< Handle for a file that is open for writing + character(len=*), intent(in) :: name !< The name in the file of this global attribute + character(len=*), intent(in) :: attribute !< The value of this attribute + + if (IO_handle%FMS2_file) then + call register_global_attribute(IO_handle%fileobj, name, attribute, len_trim(attribute)) + else + call mpp_write_meta(IO_handle%unit, name, cval=attribute) + endif + +end subroutine write_metadata_global + end module MOM_io_infra diff --git a/src/framework/MOM_io.F90 b/src/framework/MOM_io.F90 index 247a0a9678..fb1c6b74f1 100644 --- a/src/framework/MOM_io.F90 +++ b/src/framework/MOM_io.F90 @@ -35,7 +35,7 @@ module MOM_io ! These interfaces are actually implemented in this file. public :: create_file, reopen_file, cmor_long_std, ensembler, MOM_io_init -public :: MOM_write_field, var_desc, modify_vardesc, query_vardesc +public :: MOM_write_field, var_desc, modify_vardesc, query_vardesc, position_from_horgrid public :: open_namelist_file, check_namelist_error, check_nml_error public :: get_var_sizes, verify_variable_units, num_timelevels, read_variable, read_attribute public :: open_file_to_read, close_file_to_read @@ -47,6 +47,10 @@ module MOM_io public :: MOM_read_data, MOM_read_vector, read_field_chksum public :: slasher, write_field, write_version_number public :: io_infra_init, io_infra_end +! This is used to set up information descibing non-domain-decomposed axes. +public :: axis_info, set_axis_info, delete_axis_info +! This is used to set up global file attributes +public :: attribute_info, set_attribute_info, delete_attribute_info ! This API is here just to support potential use by non-FMS drivers, and should not persist. public :: read_data !> These encoding constants are used to indicate the file format @@ -94,8 +98,32 @@ module MOM_io character(len=240) :: cmor_longname !< CMOR long name of the variable real :: conversion !< for unit conversions, such as needed to !! convert from intensive to extensive + character(len=32) :: dim_names(5) !< The names in the file of the axes for this variable + integer :: position = -1 !< An integer encoding the horizontal position, it may + !! CENTER, CORNER, EAST_FACE, NORTH_FACE, or 0. end type vardesc +!> Type that stores information that can be used to create a non-decomposed axis. +type :: axis_info ; private + character(len=32) :: name = "" !< The name of this axis for use in files + character(len=256) :: longname = "" !< A longer name describing this axis + character(len=48) :: units = "" !< The units of the axis labels + character(len=8) :: cartesian = "N" !< A variable indicating which direction + !! this axis corresponds with. Valid values + !! include 'X', 'Y', 'Z', 'T', and 'N' for none. + integer :: sense = 0 !< This is 1 for axes whose values increase upward, or -1 + !! if they increase downward. The default, 0, is ignored. + integer :: ax_size = 0 !< The number of elements in this axis + real, allocatable, dimension(:) :: ax_data !< The values of the data on the axis. +end type axis_info + +!> Type that stores for a global file attribute +type :: attribute_info ; private + character(len=:), allocatable :: name !< The name of this attribute + character(len=:), allocatable :: att_val !< The values of this attribute +end type attribute_info + + integer, public :: stdout = stdout_iso !< standard output unit integer, public :: stderr = stderr_iso !< standard output unit @@ -104,8 +132,9 @@ module MOM_io !> Routine creates a new NetCDF file. It also sets up fieldtype !! structures that describe this file and variables that will !! later be written to this file. -subroutine create_file(IO_handle, filename, vars, novars, fields, threading, timeunit, G, dG, GV, checksums) - type(file_type), intent(inout) :: IO_handle !< Handle for a file or fileset that is to be +subroutine create_file(IO_handle, filename, vars, novars, fields, threading, timeunit, & + G, dG, GV, checksums, extra_axes, global_atts) + type(file_type), intent(inout) :: IO_handle !< Handle for a files or fileset that is to be !! opened or reopened for writing character(len=*), intent(in) :: filename !< full path to the file to create type(vardesc), intent(in) :: vars(:) !< structures describing fields written to filename @@ -123,31 +152,47 @@ subroutine create_file(IO_handle, filename, vars, novars, fields, threading, tim 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=int64), optional, intent(in) :: checksums(:,:) !< checksums of vars + integer(kind=int64), optional, intent(in) :: checksums(:,:) !< checksums of vars + type(axis_info), optional, intent(in) :: extra_axes(:) !< Types with information about + !! some axes that might be used in this file + type(attribute_info), optional, intent(in) :: global_atts(:) !< Global attributes to + !! write to this file logical :: use_lath, use_lonh, use_latq, use_lonq, use_time logical :: use_layer, use_int, use_periodic - logical :: one_file, domain_set + logical :: one_file, domain_set, dim_found + logical, dimension(:), allocatable :: use_extra_axis type(axistype) :: axis_lath, axis_latq, axis_lonh, axis_lonq type(axistype) :: axis_layer, axis_int, axis_time, axis_periodic - type(axistype) :: axes(4) + type(axistype), dimension(:), allocatable :: more_axes ! Axes generated from extra_axes + type(axistype) :: axes(5) ! The axes of a variable type(MOM_domain_type), pointer :: Domain => NULL() type(domain1d) :: x_domain, y_domain - integer :: numaxes, pack, thread, k + integer :: position, numaxes, pack, thread, k, n, m + integer :: num_extra_dims ! The number of extra possible dimensions from extra_axes integer :: isg, ieg, jsg, jeg, IsgB, IegB, JsgB, JegB integer :: var_periods, num_periods=0 - real, dimension(:), allocatable :: period_val + real, dimension(:), allocatable :: axis_val 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() character(len=40) :: time_units, x_axis_units, y_axis_units character(len=8) :: t_grid, t_grid_read + character(len=64) :: ax_name(5) ! The axis names of a variable use_lath = .false. ; use_lonh = .false. use_latq = .false. ; use_lonq = .false. use_time = .false. ; use_periodic = .false. use_layer = .false. ; use_int = .false. + num_extra_dims = 0 + if (present(extra_axes)) then + num_extra_dims = size(extra_axes) + if (num_extra_dims > 0) then + allocate(use_extra_axis(num_extra_dims)) ; use_extra_axis = .false. + allocate(more_axes(num_extra_dims)) + endif + endif thread = SINGLE_FILE if (PRESENT(threading)) thread = threading @@ -180,19 +225,16 @@ subroutine create_file(IO_handle, filename, vars, novars, fields, threading, tim ! Define the coordinates. do k=1,novars - select case (vars(k)%hor_grid) - case ('h') ; use_lath = .true. ; use_lonh = .true. - case ('q') ; use_latq = .true. ; use_lonq = .true. - case ('u') ; use_lath = .true. ; use_lonq = .true. - case ('v') ; use_latq = .true. ; use_lonh = .true. - case ('T') ; use_lath = .true. ; use_lonh = .true. - case ('Bu') ; use_latq = .true. ; use_lonq = .true. - case ('Cu') ; use_lath = .true. ; use_lonq = .true. - case ('Cv') ; use_latq = .true. ; use_lonh = .true. - case ('1') ! Do nothing. + position = vars(k)%position + if (position == -1) position = position_from_horgrid(vars(k)%hor_grid) + select case (position) + case (CENTER) ; use_lath = .true. ; use_lonh = .true. + case (CORNER) ; use_latq = .true. ; use_lonq = .true. + case (EAST_FACE) ; use_lath = .true. ; use_lonq = .true. + case (NORTH_FACE) ; use_latq = .true. ; use_lonh = .true. + case (0) ! Do nothing. case default - call MOM_error(WARNING, "MOM_io create_file: "//trim(vars(k)%name)//& - " has unrecognized hor_grid "//trim(vars(k)%hor_grid)) + call MOM_error(WARNING, "MOM_io create_file: "//trim(vars(k)%name)//" has an unrecognized value of postion") end select select case (vars(k)%z_grid) case ('L') ; use_layer = .true. @@ -233,6 +275,19 @@ subroutine create_file(IO_handle, filename, vars, novars, fields, threading, tim call MOM_error(WARNING, "MOM_io create_file: "//trim(vars(k)%name)//& " has unrecognized t_grid "//trim(vars(k)%t_grid)) end select + + do n=1,5 ; if (len_trim(vars(k)%dim_names(n)) > 0) then + dim_found = .false. + do m=1,num_extra_dims + if (lowercase(trim(vars(k)%dim_names(n))) == lowercase(trim(extra_axes(m)%name))) then + use_extra_axis(m) = .true. + dim_found = .true. + exit + endif + enddo + if (.not.dim_found) call MOM_error(FATAL, "Unable to find a match for dimension "//& + trim(vars(k)%dim_names(n))//" for variable "//trim(vars(k)%name)//" in file "//trim(filename)) + endif ; enddo enddo if ((use_lath .or. use_lonh .or. use_latq .or. use_lonq)) then @@ -288,44 +343,82 @@ subroutine create_file(IO_handle, filename, vars, novars, fields, threading, tim call write_metadata(IO_handle, axis_time, name="Time", units=time_units, longname="Time", cartesian='T') else - call write_metadata(IO_handle, axis_time, name="Time", units="days", longname="Time", cartesian= 'T') + call write_metadata(IO_handle, axis_time, name="Time", units="days", longname="Time", cartesian='T') endif ; endif if (use_periodic) then if (num_periods <= 1) call MOM_error(FATAL, "MOM_io create_file: "//& "num_periods for file "//trim(filename)//" must be at least 1.") ! Define a periodic axis with unit labels. - allocate(period_val(num_periods)) - do k=1,num_periods ; period_val(k) = real(k) ; enddo + allocate(axis_val(num_periods)) + do k=1,num_periods ; axis_val(k) = real(k) ; enddo call write_metadata(IO_handle, axis_periodic, name="Period", units="nondimensional", & - longname="Periods for cyclical varaiables", cartesian='T', data=period_val) - deallocate(period_val) + longname="Periods for cyclical variables", cartesian='T', data=axis_val) + deallocate(axis_val) endif + do m=1,num_extra_dims ; if (use_extra_axis(m)) then + if (allocated(extra_axes(m)%ax_data)) then + call write_metadata(IO_handle, more_axes(m), name=extra_axes(m)%name, units=extra_axes(m)%units, & + longname=extra_axes(m)%longname, cartesian=extra_axes(m)%cartesian, & + sense=extra_axes(m)%sense, data=extra_axes(m)%ax_data) + elseif (trim(extra_axes(m)%cartesian) == "T") then + call write_metadata(IO_handle, more_axes(m), name=extra_axes(m)%name, units=extra_axes(m)%units, & + longname=extra_axes(m)%longname, cartesian=extra_axes(m)%cartesian) + else + ! FMS requires that non-time axes have variables that label their values, even if they are trivial. + allocate (axis_val(extra_axes(m)%ax_size)) + do k=1,extra_axes(m)%ax_size ; axis_val(k) = real(k) ; enddo + call write_metadata(IO_handle, more_axes(m), name=extra_axes(m)%name, units=extra_axes(m)%units, & + longname=extra_axes(m)%longname, cartesian=extra_axes(m)%cartesian, & + sense=extra_axes(m)%sense, data=axis_val) + deallocate(axis_val) + endif + endif ; enddo + do k=1,novars numaxes = 0 - select case (vars(k)%hor_grid) - case ('h') ; numaxes = 2 ; axes(1) = axis_lonh ; axes(2) = axis_lath - case ('q') ; numaxes = 2 ; axes(1) = axis_lonq ; axes(2) = axis_latq - case ('u') ; numaxes = 2 ; axes(1) = axis_lonq ; axes(2) = axis_lath - case ('v') ; numaxes = 2 ; axes(1) = axis_lonh ; axes(2) = axis_latq - case ('T') ; numaxes = 2 ; axes(1) = axis_lonh ; axes(2) = axis_lath - case ('Bu') ; numaxes = 2 ; axes(1) = axis_lonq ; axes(2) = axis_latq - case ('Cu') ; numaxes = 2 ; axes(1) = axis_lonq ; axes(2) = axis_lath - case ('Cv') ; numaxes = 2 ; axes(1) = axis_lonh ; axes(2) = axis_latq - case ('1') ! Do nothing. + position = vars(k)%position + if (position == -1) position = position_from_horgrid(vars(k)%hor_grid) + select case (position) + case (CENTER) + numaxes = 2 ; axes(1) = axis_lonh ; axes(2) = axis_lath ; ax_name(1) = "lonh" ; ax_name(2) = "lath" + case (CORNER) + numaxes = 2 ; axes(1) = axis_lonq ; axes(2) = axis_latq ; ax_name(1) = "lonq" ; ax_name(2) = "latq" + case (EAST_FACE) + numaxes = 2 ; axes(1) = axis_lonq ; axes(2) = axis_lath ; ax_name(1) = "lonq" ; ax_name(2) = "lath" + case (NORTH_FACE) + numaxes = 2 ; axes(1) = axis_lonh ; axes(2) = axis_latq ; ax_name(1) = "lonh" ; ax_name(2) = "latq" + case (0) ! Do nothing. case default call MOM_error(WARNING, "MOM_io create_file: "//trim(vars(k)%name)//& - " has unrecognized hor_grid "//trim(vars(k)%hor_grid)) + " has unrecognized position, hor_grid = "//trim(vars(k)%hor_grid)) end select select case (vars(k)%z_grid) - case ('L') ; numaxes = numaxes+1 ; axes(numaxes) = axis_layer - case ('i') ; numaxes = numaxes+1 ; axes(numaxes) = axis_int + case ('L') ; numaxes = numaxes+1 ; axes(numaxes) = axis_layer ; ax_name(numaxes) = "Layer" + case ('i') ; numaxes = numaxes+1 ; axes(numaxes) = axis_int ; ax_name(numaxes) = "Interface" case ('1') ! Do nothing. case default call MOM_error(FATAL, "MOM_io create_file: "//trim(vars(k)%name)//& " has unrecognized z_grid "//trim(vars(k)%z_grid)) end select + + do n=1,numaxes + if ( (len_trim(vars(k)%dim_names(n)) > 0) .and. (trim(ax_name(n)) /= trim(vars(k)%dim_names(n))) ) & + call MOM_error(WARNING, "MOM_io create_file: dimension "//trim(ax_name(n))//& + " of variable "//trim(vars(k)%name)//" in "//trim(filename)//& + " is being set inconsistently as "//trim(vars(k)%dim_names(n))) + enddo + do n=numaxes+1,5 ; if (len_trim(vars(k)%dim_names(n)) > 0) then + dim_found = .false. + do m=1,num_extra_dims + if (lowercase(trim(vars(k)%dim_names(n))) == lowercase(trim(extra_axes(m)%name))) then + numaxes = numaxes+1 ; axes(numaxes) = more_axes(m) + exit + endif + enddo + endif ; enddo + t_grid = adjustl(vars(k)%t_grid) select case (t_grid(1:1)) case ('s', 'a', 'm') ; numaxes = numaxes+1 ; axes(numaxes) = axis_time @@ -346,6 +439,14 @@ subroutine create_file(IO_handle, filename, vars, novars, fields, threading, tim endif enddo + if (present(global_atts)) then + do n=1,size(global_atts) + if (allocated(global_atts(n)%name) .and. allocated(global_atts(n)%att_val)) & + call write_metadata(IO_handle, global_atts(n)%name, global_atts(n)%att_val) + enddo + endif + + ! Now actualy write the variables with the axis label values if (use_lath) call write_field(IO_handle, axis_lath) if (use_latq) call write_field(IO_handle, axis_latq) if (use_lonh) call write_field(IO_handle, axis_lonh) @@ -353,6 +454,13 @@ subroutine create_file(IO_handle, filename, vars, novars, fields, threading, tim if (use_layer) call write_field(IO_handle, axis_layer) if (use_int) call write_field(IO_handle, axis_int) if (use_periodic) call write_field(IO_handle, axis_periodic) + do m=1,num_extra_dims ; if (use_extra_axis(m)) then + call write_field(IO_handle, more_axes(m)) + endif ; enddo + + if (num_extra_dims > 0) then + deallocate(use_extra_axis, more_axes) + endif end subroutine create_file @@ -361,7 +469,8 @@ end subroutine create_file !! does not find the file, a new file is created. It also sets up !! structures that describe this file and the variables that will !! later be written to this file. -subroutine reopen_file(IO_handle, filename, vars, novars, fields, threading, timeunit, G, dG, GV) +subroutine reopen_file(IO_handle, filename, vars, novars, fields, threading, timeunit, & + G, dG, GV, extra_axes, global_atts) type(file_type), intent(inout) :: IO_handle !< Handle for a file or fileset that is to be !! opened or reopened for writing character(len=*), intent(in) :: filename !< full path to the file to create @@ -380,6 +489,10 @@ subroutine reopen_file(IO_handle, filename, vars, novars, fields, threading, tim type(verticalGrid_type), optional, intent(in) :: GV !< ocean vertical grid structure, which is !! required if a new file uses any !! vertical grid axes. + type(axis_info), optional, intent(in) :: extra_axes(:) !< Types with information about + !! some axes that might be used in this file + type(attribute_info), optional, intent(in) :: global_atts(:) !< Global attributes to + !! write to this file type(MOM_domain_type), pointer :: Domain => NULL() character(len=200) :: check_name, mesg @@ -398,7 +511,7 @@ subroutine reopen_file(IO_handle, filename, vars, novars, fields, threading, tim if (.not.exists) then call create_file(IO_handle, filename, vars, novars, fields, threading, timeunit, & - G=G, dG=dG, GV=GV) + G=G, dG=dG, GV=GV, extra_axes=extra_axes, global_atts=global_atts) else domain_set = .false. @@ -424,7 +537,8 @@ subroutine reopen_file(IO_handle, filename, vars, novars, fields, threading, tim write (mesg,*) "Reopening file ",trim(filename)," apparently had ",nvar,& " variables. Clobbering and creating file with ",novars," instead." call MOM_error(WARNING,"MOM_io: "//mesg) - call create_file(IO_handle, filename, vars, novars, fields, threading, timeunit, G=G, GV=GV) + call create_file(IO_handle, filename, vars, novars, fields, threading, timeunit, & + G=G, dG=dG, GV=GV, extra_axes=extra_axes, global_atts=global_atts) elseif (nvar /= novars) then write (mesg,*) "Reopening file ",trim(filename)," with ",novars,& " variables instead of ",nvar,"." @@ -1197,21 +1311,29 @@ end subroutine verify_variable_units !! fields. The argument name is required, while the others are optional and !! have default values that are empty strings or are appropriate for a 3-d !! tracer field at the tracer cell centers. -function var_desc(name, units, longname, hor_grid, z_grid, t_grid, & - cmor_field_name, cmor_units, cmor_longname, conversion, caller) result(vd) - character(len=*), intent(in) :: name !< variable name - character(len=*), optional, intent(in) :: units !< variable units - character(len=*), optional, intent(in) :: longname !< variable long name - character(len=*), optional, intent(in) :: hor_grid !< variable horizontal staggering - character(len=*), optional, intent(in) :: z_grid !< variable vertical staggering - character(len=*), optional, intent(in) :: t_grid !< time description: s, p, or 1 - character(len=*), optional, intent(in) :: cmor_field_name !< CMOR name - character(len=*), optional, intent(in) :: cmor_units !< CMOR physical dimensions of variable - character(len=*), optional, intent(in) :: cmor_longname !< CMOR long name - real , optional, intent(in) :: conversion !< for unit conversions, such as needed to - !! convert from intensive to extensive - character(len=*), optional, intent(in) :: caller !< calling routine? - type(vardesc) :: vd !< vardesc type that is created +function var_desc(name, units, longname, hor_grid, z_grid, t_grid, cmor_field_name, & + cmor_units, cmor_longname, conversion, caller, position, dim_names, fixed) result(vd) + character(len=*), intent(in) :: name !< variable name + character(len=*), optional, intent(in) :: units !< variable units + character(len=*), optional, intent(in) :: longname !< variable long name + character(len=*), optional, intent(in) :: hor_grid !< A character string indicating the horizontal + !! position of this variable + character(len=*), optional, intent(in) :: z_grid !< variable vertical staggering + character(len=*), optional, intent(in) :: t_grid !< time description: s, p, or 1 + character(len=*), optional, intent(in) :: cmor_field_name !< CMOR name + character(len=*), optional, intent(in) :: cmor_units !< CMOR physical dimensions of variable + character(len=*), optional, intent(in) :: cmor_longname !< CMOR long name + real , optional, intent(in) :: conversion !< for unit conversions, such as needed to + !! convert from intensive to extensive + character(len=*), optional, intent(in) :: caller !< The calling routine for error messages + integer, optional, intent(in) :: position !< A coded integer indicating the horizontal position + !! of this variable if it has such dimensions. + !! Valid values include CORNER, CENTER, EAST_FACE + !! NORTH_FACE, and 0 for no horizontal dimensions. + character(len=*), dimension(:), & + optional, intent(in) :: dim_names !< The names of the dimensions of this variable + logical, optional, intent(in) :: fixed !< If true, this does not evolve with time + type(vardesc) :: vd !< vardesc type that is created character(len=120) :: cllr cllr = "var_desc" @@ -1220,15 +1342,18 @@ function var_desc(name, units, longname, hor_grid, z_grid, t_grid, & call safe_string_copy(name, vd%name, "vd%name", cllr) vd%longname = "" ; vd%units = "" - vd%hor_grid = 'h' ; vd%z_grid = 'L' ; vd%t_grid = 's' + vd%hor_grid = 'h' ; vd%position = CENTER ; vd%z_grid = 'L' ; vd%t_grid = 's' + if (present(dim_names)) vd%z_grid = '1' ! In this case the names are used to set the non-horizontal axes + if (present(fixed)) then ; if (fixed) vd%t_grid = '1' ; endif vd%cmor_field_name = "" vd%cmor_units = "" vd%cmor_longname = "" vd%conversion = 1.0 + vd%dim_names(:) = "" call modify_vardesc(vd, units=units, longname=longname, hor_grid=hor_grid, & - z_grid=z_grid, t_grid=t_grid, & + z_grid=z_grid, t_grid=t_grid, position=position, dim_names=dim_names, & cmor_field_name=cmor_field_name, cmor_units=cmor_units, & cmor_longname=cmor_longname, conversion=conversion, caller=cllr) @@ -1238,7 +1363,7 @@ end function var_desc !> This routine modifies the named elements of a vardesc type. !! All arguments are optional, except the vardesc type to be modified. subroutine modify_vardesc(vd, name, units, longname, hor_grid, z_grid, t_grid, & - cmor_field_name, cmor_units, cmor_longname, conversion, caller) + cmor_field_name, cmor_units, cmor_longname, conversion, caller, position, dim_names) type(vardesc), intent(inout) :: vd !< vardesc type that is modified character(len=*), optional, intent(in) :: name !< name of variable character(len=*), optional, intent(in) :: units !< units of variable @@ -1249,13 +1374,21 @@ subroutine modify_vardesc(vd, name, units, longname, hor_grid, z_grid, t_grid, & character(len=*), optional, intent(in) :: cmor_field_name !< CMOR name character(len=*), optional, intent(in) :: cmor_units !< CMOR physical dimensions of variable character(len=*), optional, intent(in) :: cmor_longname !< CMOR long name - real , optional, intent(in) :: conversion !< for unit conversions, such as needed - !! to convert from intensive to extensive - character(len=*), optional, intent(in) :: caller !< calling routine? + real , optional, intent(in) :: conversion !< A multiplicative factor for unit conversions, + !! such as needed to convert from intensive to + !! extensive or dimensional consistency testing + character(len=*), optional, intent(in) :: caller !< The calling routine for error messages + integer, optional, intent(in) :: position !< A coded integer indicating the horizontal position + !! of this variable if it has such dimensions. + !! Valid values include CORNER, CENTER, EAST_FACE + !! NORTH_FACE, and 0 for no horizontal dimensions. + character(len=*), dimension(:), & + optional, intent(in) :: dim_names !< The names of the dimensions of this variable character(len=120) :: cllr - cllr = "mod_vardesc" - if (present(caller)) cllr = trim(caller) + integer :: n + + cllr = "mod_vardesc" ; if (present(caller)) cllr = trim(caller) if (present(name)) call safe_string_copy(name, vd%name, "vd%name", cllr) @@ -1263,8 +1396,28 @@ subroutine modify_vardesc(vd, name, units, longname, hor_grid, z_grid, t_grid, & "vd%longname of "//trim(vd%name), cllr) if (present(units)) call safe_string_copy(units, vd%units, & "vd%units of "//trim(vd%name), cllr) - if (present(hor_grid)) call safe_string_copy(hor_grid, vd%hor_grid, & - "vd%hor_grid of "//trim(vd%name), cllr) + if (present(position)) then + vd%position = position + select case (position) + case (CENTER) ; vd%hor_grid = 'T' + case (CORNER) ; vd%hor_grid = 'Bu' + case (EAST_FACE) ; vd%hor_grid = 'Cu' + case (NORTH_FACE) ; vd%hor_grid = 'Cv' + case (0) ; vd%hor_grid = '1' + case default + call MOM_error(FATAL, "modify_vardesc: "//trim(vd%name)//" has unrecognized position argument") + end select + endif + if (present(hor_grid)) then + call safe_string_copy(hor_grid, vd%hor_grid, "vd%hor_grid of "//trim(vd%name), cllr) + vd%position = position_from_horgrid(vd%hor_grid) + if (present(caller) .and. (vd%position == -1)) then + call MOM_error(FATAL, "modify_vardesc called by "//trim(caller)//": "//trim(vd%name)//& + " has an unrecognized hor_grid argument "//trim(vd%hor_grid)) + elseif (vd%position == -1) then + call MOM_error(FATAL, "modify_vardesc called with bad hor_grid argument "//trim(vd%hor_grid)) + endif + endif if (present(z_grid)) call safe_string_copy(z_grid, vd%z_grid, & "vd%z_grid of "//trim(vd%name), cllr) if (present(t_grid)) call safe_string_copy(t_grid, vd%t_grid, & @@ -1277,8 +1430,110 @@ subroutine modify_vardesc(vd, name, units, longname, hor_grid, z_grid, t_grid, & if (present(cmor_longname)) call safe_string_copy(cmor_longname, vd%cmor_longname, & "vd%cmor_longname of "//trim(vd%name), cllr) + if (present(dim_names)) then + do n=1,min(5,size(dim_names)) ; if (len_trim(dim_names(n)) > 0) then + call safe_string_copy(dim_names(n), vd%dim_names(n), "vd%dim_names of "//trim(vd%name), cllr) + endif ; enddo + endif + end subroutine modify_vardesc +integer function position_from_horgrid(hor_grid) + character(len=*), intent(in) :: hor_grid !< horizontal staggering of variable + + select case (trim(hor_grid)) + case ('h') ; position_from_horgrid = CENTER + case ('q') ; position_from_horgrid = CORNER + case ('u') ; position_from_horgrid = EAST_FACE + case ('v') ; position_from_horgrid = NORTH_FACE + case ('T') ; position_from_horgrid = CENTER + case ('Bu') ; position_from_horgrid = CORNER + case ('Cu') ; position_from_horgrid = EAST_FACE + case ('Cv') ; position_from_horgrid = NORTH_FACE + case ('1') ; position_from_horgrid = 0 + case default ; position_from_horgrid = -1 ! This is a bad-value flag. + end select +end function position_from_horgrid + +!> Store information that can be used to create an axis in a subsequent call to create_file. +subroutine set_axis_info(axis, name, units, longname, ax_size, ax_data, cartesian, sense) + type(axis_info), intent(inout) :: axis !< A type with information about a named axis + character(len=*), intent(in) :: name !< The name of this axis for use in files + character(len=*), optional, intent(in) :: units !< The units of the axis labels + character(len=*), optional, intent(in) :: longname !< Long name of the axis variable + integer, optional, intent(in) :: ax_size !< The number of elements in this axis + real, dimension(:), optional, intent(in) :: ax_data !< The values of the data on the axis + character(len=*), optional, intent(in) :: cartesian !< A variable indicating which direction this axis + !! axis corresponds with. Valid values + !! include 'X', 'Y', 'Z', 'T', and 'N' (the default) for none. + integer, optional, intent(in) :: sense !< This is 1 for axes whose values increase upward, or -1 + !! if they increase downward. The default, 0, is ignored. + + call safe_string_copy(name, axis%name, "axis%name of "//trim(name), "set_axis_info") + ! Set the default values. + axis%longname = trim(axis%name) ; axis%units = "" ; axis%cartesian = "N" ; axis%sense = 0 + + if (present(longname)) call safe_string_copy(longname, axis%longname, & + "axis%longname of "//trim(name), "set_axis_info") + if (present(units)) call safe_string_copy(units, axis%units, & + "axis%units of "//trim(name), "set_axis_info") + if (present(cartesian)) call safe_string_copy(cartesian, axis%cartesian, & + "axis%cartesian of "//trim(name), "set_axis_info") + if (present(sense)) axis%sense = sense + + if (.not.(present(ax_size) .or. present(ax_data)) ) then + call MOM_error(FATAL, "set_axis_info called for "//trim(name)//& + "without either an ax_size or an ax_data argument.") + elseif (present(ax_size) .and. present(ax_data)) then + if (size(ax_data) /= ax_size) call MOM_error(FATAL, "set_axis_info called for "//trim(name)//& + "with an inconsistent value of ax_size and size of ax_data.") + endif + + if (present(ax_size)) then + axis%ax_size = ax_size + else + axis%ax_size = size(ax_data) + endif + if (present(ax_data)) then + allocate(axis%ax_data(axis%ax_size)) ; axis%ax_data(:) = ax_data(:) + endif + +end subroutine set_axis_info + +!> Delete the information in an array of axis_info types and deallocate memory in them. +subroutine delete_axis_info(axes) + type(axis_info), dimension(:), intent(inout) :: axes !< An array with information about named axes + + integer :: n + do n=1,size(axes) + axes(n)%name = "" ; axes(n)%longname = "" ; axes(n)%units = "" ; axes(n)%cartesian = "N" + axes(n)%sense = 0 ; axes(n)%ax_size = 0 + if (allocated(axes(n)%ax_data)) deallocate(axes(n)%ax_data) + enddo +end subroutine delete_axis_info + +!> Store information that can be used to create an attribute in a subsequent call to create_file. +subroutine set_attribute_info(attribute, name, str_value) + type(attribute_info), intent(inout) :: attribute !< A type with information about a named attribute + character(len=*), intent(in) :: name !< The name of this attribute for use in files + character(len=*), intent(in) :: str_value !< The value of this attribute + + attribute%name = trim(name) + attribute%att_val = trim(str_value) +end subroutine set_attribute_info + +!> Delete the information in an array of attribute_info types and deallocate memory in them. +subroutine delete_attribute_info(atts) + type(attribute_info), dimension(:), intent(inout) :: atts !< An array of global attributes + + integer :: n + do n=1,size(atts) + if (allocated(atts(n)%name)) deallocate(atts(n)%name) + if (allocated(atts(n)%att_val)) deallocate(atts(n)%att_val) + enddo +end subroutine delete_attribute_info + + !> This function returns the CMOR standard name given a CMOR longname, based on !! the standard pattern of character conversions. function cmor_long_std(longname) result(std_name) @@ -1297,7 +1552,8 @@ end function cmor_long_std !> This routine queries vardesc subroutine query_vardesc(vd, name, units, longname, hor_grid, z_grid, t_grid, & - cmor_field_name, cmor_units, cmor_longname, conversion, caller) + cmor_field_name, cmor_units, cmor_longname, conversion, caller, & + position, dim_names) type(vardesc), intent(in) :: vd !< vardesc type that is queried character(len=*), optional, intent(out) :: name !< name of variable character(len=*), optional, intent(out) :: units !< units of variable @@ -1311,8 +1567,14 @@ subroutine query_vardesc(vd, name, units, longname, hor_grid, z_grid, t_grid, & real , optional, intent(out) :: conversion !< for unit conversions, such as needed to !! convert from intensive to extensive character(len=*), optional, intent(in) :: caller !< calling routine? + integer, optional, intent(out) :: position !< A coded integer indicating the horizontal position + !! of this variable if it has such dimensions. + !! Valid values include CORNER, CENTER, EAST_FACE + !! NORTH_FACE, and 0 for no horizontal dimensions. + character(len=*), dimension(:), & + optional, intent(out) :: dim_names !< The names of the dimensions of this variable - + integer :: n character(len=120) :: cllr cllr = "mod_vardesc" if (present(caller)) cllr = trim(caller) @@ -1336,6 +1598,15 @@ subroutine query_vardesc(vd, name, units, longname, hor_grid, z_grid, t_grid, & "vd%cmor_units of "//trim(vd%name), cllr) if (present(cmor_longname)) call safe_string_copy(vd%cmor_longname, cmor_longname, & "vd%cmor_longname of "//trim(vd%name), cllr) + if (present(position)) then + position = vd%position + if (position == -1) position = position_from_horgrid(vd%hor_grid) + endif + if (present(dim_names)) then + do n=1,min(5,size(dim_names)) + call safe_string_copy(vd%dim_names(n), dim_names(n), "vd%dim_names of "//trim(vd%name), cllr) + enddo + endif end subroutine query_vardesc @@ -1672,6 +1943,4 @@ end subroutine MOM_io_init !! !! * handle_error: write an error code and quit. - - end module MOM_io From 0eb47b25abf668a03809b26861fc3a954eca380b Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sat, 10 Apr 2021 08:39:42 -0400 Subject: [PATCH 045/112] +More consistent treatment of input_filename = 'F' Restructured the code slightly so that the output files that are generated when input_filename = 'F' is exactly the same as if it is 'n' if there are no restart files in the restart_input_dir, or as if it is 'r' if the restart files are there. Previously, the solutions with 'F' worked this way, but no ocean_geometry.nc or Vertical_grid.nc files were written when WRITE_GEOM=1, regardless of the presence or absence of the restart files, and the MOM_parameter_doc.all files differed slightly between the 'n' and 'F' or 'r' cases. As a part of these changes, the determination of whether this is a new run is moved earlier in the algorithm, and now sits outside of MOM_initialize_state. All solutions are bitwise identical, but there are changes in the position of the PARALLEL_RESTARTFILES and REFERENCE_HEIGHT entries in most MOM_parameter_doc.all files. --- src/core/MOM.F90 | 44 +++++++++---------- .../MOM_state_initialization.F90 | 4 +- 2 files changed, 24 insertions(+), 24 deletions(-) diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index 4e1853375a..9ccb8eb8c6 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -41,7 +41,7 @@ module MOM use MOM_obsolete_params, only : find_obsolete_params use MOM_restart, only : register_restart_field, register_restart_pair use MOM_restart, only : query_initialized, save_restart -use MOM_restart, only : restart_init, is_new_run, MOM_restart_CS +use MOM_restart, only : restart_init, is_new_run, determine_is_new_run, MOM_restart_CS use MOM_spatial_means, only : global_mass_integral use MOM_time_manager, only : time_type, real_to_time, time_type_to_real, operator(+) use MOM_time_manager, only : operator(-), operator(>), operator(*), operator(/) @@ -97,6 +97,7 @@ module MOM use MOM_open_boundary, only : rotate_OBC_config, rotate_OBC_init use MOM_set_visc, only : set_viscous_BBL, set_viscous_ML, set_visc_init use MOM_set_visc, only : set_visc_register_restarts, set_visc_CS +use MOM_shared_initialization, only : write_ocean_geometry_file use MOM_sponge, only : init_sponge_diags, sponge_CS use MOM_state_initialization, only : MOM_initialize_state use MOM_sum_output, only : write_energy, accumulate_net_input @@ -1677,7 +1678,7 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & real :: default_val ! default value for a parameter logical :: write_geom_files ! If true, write out the grid geometry files. logical :: ensemble_ocean ! If true, perform an ensemble gather at the end of step_MOM - logical :: new_sim + logical :: new_sim ! If true, this has been determined to be a new simulation logical :: use_geothermal ! If true, apply geothermal heating. logical :: use_EOS ! If true, density calculated from T & S using an equation of state. logical :: symmetric ! If true, use symmetric memory allocation. @@ -2034,11 +2035,6 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & "vertical grid files. Other values are invalid.", default=1) if (write_geom<0 .or. write_geom>2) call MOM_error(FATAL,"MOM: "//& "WRITE_GEOM must be equal to 0, 1 or 2.") - write_geom_files = ((write_geom==2) .or. ((write_geom==1) .and. & - ((dirs%input_filename(1:1)=='n') .and. (LEN_TRIM(dirs%input_filename)==1)))) -! If the restart file type had been initialized, this could become: -! write_geom_files = ((write_geom==2) .or. & -! ((write_geom==1) .and. is_new_run(restart_CSp))) ! Check for inconsistent parameter settings. if (CS%use_ALE_algorithm .and. bulkmixedlayer) call MOM_error(FATAL, & @@ -2136,8 +2132,7 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & call clone_MOM_domain(G_in%Domain, dG_in%Domain) ! Allocate initialize time-invariant MOM variables. - call MOM_initialize_fixed(dG_in, US, OBC_in, param_file, write_geom_files, & - dirs%output_directory) + call MOM_initialize_fixed(dG_in, US, OBC_in, param_file, .false., dirs%output_directory) call callTree_waypoint("returned from MOM_initialize_fixed() (initialize_MOM)") @@ -2341,17 +2336,6 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & call callTree_waypoint("restart registration complete (initialize_MOM)") - ! Initialize dynamically evolving fields, perhaps from restart files. - call cpu_clock_begin(id_clock_MOM_init) - call MOM_initialize_coord(GV, US, param_file, write_geom_files, & - dirs%output_directory, CS%tv, dG%max_depth) - call callTree_waypoint("returned from MOM_initialize_coord() (initialize_MOM)") - - if (CS%use_ALE_algorithm) then - call ALE_init(param_file, GV, US, dG%max_depth, CS%ALE_CSp) - call callTree_waypoint("returned from ALE_init() (initialize_MOM)") - endif - ! Shift from using the temporary dynamic grid type to using the final ! (potentially static) ocean-specific grid type. ! The next line would be needed if G%Domain had not already been init'd above: @@ -2366,10 +2350,26 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & endif call MOM_grid_init(G_in, param_file, US, HI_in, bathymetry_at_vel=bathy_at_vel) call copy_dyngrid_to_MOM_grid(dG_in, G_in, US) + if (.not. CS%rotate_index) G => G_in + + new_sim = determine_is_new_run(dirs%input_filename, dirs%restart_input_dir, G_in, restart_CSp) + write_geom_files = ((write_geom==2) .or. ((write_geom==1) .and. new_sim)) + + ! Write out all of the grid data used by this run. + if (write_geom_files) call write_ocean_geometry_file(dG_in, param_file, dirs%output_directory, US=US) + call destroy_dyn_horgrid(dG_in) - if (.not. CS%rotate_index) & - G => G_in + ! Initialize dynamically evolving fields, perhaps from restart files. + call cpu_clock_begin(id_clock_MOM_init) + call MOM_initialize_coord(GV, US, param_file, write_geom_files, & + dirs%output_directory, CS%tv, G%max_depth) + call callTree_waypoint("returned from MOM_initialize_coord() (initialize_MOM)") + + if (CS%use_ALE_algorithm) then + call ALE_init(param_file, GV, US, G%max_depth, CS%ALE_CSp) + call callTree_waypoint("returned from ALE_init() (initialize_MOM)") + endif ! Set a few remaining fields that are specific to the ocean grid type. call set_first_direction(G, first_direction) diff --git a/src/initialization/MOM_state_initialization.F90 b/src/initialization/MOM_state_initialization.F90 index 5050b6fce3..b017f9d2df 100644 --- a/src/initialization/MOM_state_initialization.F90 +++ b/src/initialization/MOM_state_initialization.F90 @@ -28,7 +28,7 @@ module MOM_state_initialization use MOM_open_boundary, only : update_OBC_segment_data !use MOM_open_boundary, only : set_3D_OBC_data use MOM_grid_initialize, only : initialize_masks, set_grid_metrics -use MOM_restart, only : restore_state, determine_is_new_run, MOM_restart_CS +use MOM_restart, only : restore_state, is_new_run, MOM_restart_CS use MOM_sponge, only : set_up_sponge_field, set_up_sponge_ML_density use MOM_sponge, only : initialize_sponge, sponge_CS use MOM_ALE_sponge, only : set_up_ALE_sponge_field, set_up_ALE_sponge_vel_field @@ -190,7 +190,7 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, US, PF, dirs, & call get_param(PF, mdl, "DEBUG", debug, default=.false.) call get_param(PF, mdl, "DEBUG_OBC", debug_obc, default=.false.) - new_sim = determine_is_new_run(dirs%input_filename, dirs%restart_input_dir, G, restart_CS) + new_sim = is_new_run(restart_CS) just_read = .not.new_sim call get_param(PF, mdl, "INPUTDIR", inputdir, & From 1be9584c2c3b6ada3d7120ee7475201b0995d3c6 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Mon, 12 Apr 2021 19:54:22 -0400 Subject: [PATCH 046/112] (*)Write full checksums to restarts Change the types returned from the 5 rotated_field_chksum from integer to integer(kind=int64), so that the full 64-byte checksums are returned. Without this change, the checksums that are written to MOM6 restart files or interpreted from them are truncated to the latter half of their length. This changes the checksums that are written to the restart files, but both before and after this change the values that are written are the same as those that are generated after reading the restart with the same version of the code. The code can run across this change by setting RESTART_CHECKSUMS_REQUIRED = False for the run segment where the transition occurs. The solutions themselves are bitwise identical. --- src/framework/MOM_checksums.F90 | 24 ++++++++++++------------ 1 file changed, 12 insertions(+), 12 deletions(-) diff --git a/src/framework/MOM_checksums.F90 b/src/framework/MOM_checksums.F90 index 5c503836f0..7b073e8a0b 100644 --- a/src/framework/MOM_checksums.F90 +++ b/src/framework/MOM_checksums.F90 @@ -5,14 +5,14 @@ module MOM_checksums use MOM_array_transform, only : rotate_array, rotate_array_pair, rotate_vector use MOM_array_transform, only : allocate_rotated_array -use MOM_coms, only : PE_here, root_PE, num_PEs, sum_across_PEs -use MOM_coms, only : min_across_PEs, max_across_PEs -use MOM_coms, only : reproducing_sum, field_chksum -use MOM_error_handler, only : MOM_error, FATAL, is_root_pe -use MOM_file_parser, only : log_version, param_file_type -use MOM_hor_index, only : hor_index_type, rotate_hor_index +use MOM_coms, only : PE_here, root_PE, num_PEs, sum_across_PEs +use MOM_coms, only : min_across_PEs, max_across_PEs +use MOM_coms, only : reproducing_sum, field_chksum +use MOM_error_handler, only : MOM_error, FATAL, is_root_pe +use MOM_file_parser, only : log_version, param_file_type +use MOM_hor_index, only : hor_index_type, rotate_hor_index -use iso_fortran_env, only: error_unit +use iso_fortran_env, only : error_unit, int32, int64 implicit none ; private @@ -2092,7 +2092,7 @@ function rotated_field_chksum_real_0d(field, pelist, mask_val, turns) & integer, optional, intent(in) :: pelist(:) !< PE list of ranks to checksum real, optional, intent(in) :: mask_val !< FMS mask value integer, optional, intent(in) :: turns !< Number of quarter turns - integer :: chksum !< checksum of scalar + integer(kind=int64) :: chksum !< checksum of scalar if (present(turns)) call MOM_error(FATAL, "Rotation not supported for 0d fields.") @@ -2107,7 +2107,7 @@ function rotated_field_chksum_real_1d(field, pelist, mask_val, turns) & integer, optional, intent(in) :: pelist(:) !< PE list of ranks to checksum real, optional, intent(in) :: mask_val !< FMS mask value integer, optional, intent(in) :: turns !< Number of quarter turns - integer :: chksum !< checksum of array + integer(kind=int64) :: chksum !< checksum of array if (present(turns)) call MOM_error(FATAL, "Rotation not supported for 1d fields.") @@ -2122,7 +2122,7 @@ function rotated_field_chksum_real_2d(field, pelist, mask_val, turns) & integer, optional, intent(in) :: pelist(:) !< PE list of ranks to checksum real, optional, intent(in) :: mask_val !< FMS mask value integer, optional, intent(in) :: turns !< Number of quarter turns - integer :: chksum !< checksum of array + integer(kind=int64) :: chksum !< checksum of array ! Local variables real, allocatable :: field_rot(:,:) ! A rotated version of field, with the same units @@ -2149,7 +2149,7 @@ function rotated_field_chksum_real_3d(field, pelist, mask_val, turns) & integer, optional, intent(in) :: pelist(:) !< PE list of ranks to checksum real, optional, intent(in) :: mask_val !< FMS mask value integer, optional, intent(in) :: turns !< Number of quarter turns - integer :: chksum !< checksum of array + integer(kind=int64) :: chksum !< checksum of array ! Local variables real, allocatable :: field_rot(:,:,:) ! A rotated version of field, with the same units @@ -2176,7 +2176,7 @@ function rotated_field_chksum_real_4d(field, pelist, mask_val, turns) & integer, optional, intent(in) :: pelist(:) !< PE list of ranks to checksum real, optional, intent(in) :: mask_val !< FMS mask value integer, optional, intent(in) :: turns !< Number of quarter turns - integer :: chksum !< checksum of array + integer(kind=int64) :: chksum !< checksum of array ! Local variables real, allocatable :: field_rot(:,:,:,:) ! A rotated version of field, with the same units From 96f1d1e89283839d6263b4ddb118061256c9c328 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 14 Apr 2021 06:53:20 -0400 Subject: [PATCH 047/112] Use allocatable types in write_ocean_geometry_files Changed the declarations of the vardesc and fields arrays to allocatable in write_ocean_geometry_files, primarily to get one of the TC test cases to run properly with the gcc compiler by shifting the memory for these arrays from stack to heap. The reason why this change works is not clear. Some comments describing these variables were also added. All answers are bitwise identical. --- .../MOM_shared_initialization.F90 | 34 ++++++++++++------- 1 file changed, 21 insertions(+), 13 deletions(-) diff --git a/src/initialization/MOM_shared_initialization.F90 b/src/initialization/MOM_shared_initialization.F90 index ee80bbdace..f12a388897 100644 --- a/src/initialization/MOM_shared_initialization.F90 +++ b/src/initialization/MOM_shared_initialization.F90 @@ -1194,17 +1194,18 @@ subroutine write_ocean_geometry_file(G, param_file, directory, geom_file, US) type(unit_scale_type), optional, intent(in) :: US !< A dimensional unit scaling type ! Local variables. - character(len=240) :: filepath + character(len=240) :: filepath ! The full path to the file to write character(len=40) :: mdl = "write_ocean_geometry_file" - integer, parameter :: nFlds=23 - type(vardesc) :: vars(nFlds) - type(fieldtype) :: fields(nFlds) + type(vardesc), dimension(:), allocatable :: & + vars ! Types with metadata about the variables and their staggering + type(fieldtype), dimension(:), allocatable :: & + fields ! Opaque types used by MOM_io to store variable metadata information real :: Z_to_m_scale ! A unit conversion factor from Z to m real :: s_to_T_scale ! A unit conversion factor from T-1 to s-1 real :: L_to_m_scale ! A unit conversion factor from L to m type(file_type) :: IO_handle ! The I/O handle of the fileset + integer :: nFlds ! The number of variables in this file integer :: file_threading - integer :: nFlds_used logical :: multiple_files call callTree_enter('write_ocean_geometry_file()') @@ -1213,6 +1214,12 @@ subroutine write_ocean_geometry_file(G, param_file, directory, geom_file, US) s_to_T_scale = 1.0 ; if (present(US)) s_to_T_scale = US%s_to_T L_to_m_scale = 1.0 ; if (present(US)) L_to_m_scale = US%L_to_m + + nFlds = 19 ; if (G%bathymetry_at_vel) nFlds = 23 + + allocate(vars(nFlds)) + allocate(fields(nFlds)) + ! var_desc populates a type defined in MOM_io.F90. The arguments, in order, are: ! (1) the variable name for the NetCDF file ! (2) the units of the variable when output @@ -1244,13 +1251,12 @@ subroutine write_ocean_geometry_file(G, param_file, directory, geom_file, US) vars(18)= var_desc("dyCuo","m","Open meridional grid spacing at u points",'u','1','1') vars(19)= var_desc("wet", "nondim", "land or ocean?", 'h','1','1') - vars(20) = var_desc("Dblock_u","m","Blocked depth at u points",'u','1','1') - vars(21) = var_desc("Dopen_u","m","Open depth at u points",'u','1','1') - vars(22) = var_desc("Dblock_v","m","Blocked depth at v points",'v','1','1') - vars(23) = var_desc("Dopen_v","m","Open depth at v points",'v','1','1') - - - nFlds_used = 19 ; if (G%bathymetry_at_vel) nFlds_used = 23 + if (G%bathymetry_at_vel) then + vars(20) = var_desc("Dblock_u","m","Blocked depth at u points",'u','1','1') + vars(21) = var_desc("Dopen_u","m","Open depth at u points",'u','1','1') + vars(22) = var_desc("Dblock_v","m","Blocked depth at v points",'v','1','1') + vars(23) = var_desc("Dopen_v","m","Open depth at v points",'v','1','1') + endif if (present(geom_file)) then filepath = trim(directory) // trim(geom_file) @@ -1265,7 +1271,7 @@ subroutine write_ocean_geometry_file(G, param_file, directory, geom_file, US) file_threading = SINGLE_FILE if (multiple_files) file_threading = MULTIPLE - call create_file(IO_handle, trim(filepath), vars, nFlds_used, fields, file_threading, dG=G) + call create_file(IO_handle, trim(filepath), vars, nFlds, fields, file_threading, dG=G) call MOM_write_field(IO_handle, fields(1), G%Domain, G%geoLatBu) call MOM_write_field(IO_handle, fields(2), G%Domain, G%geoLonBu) @@ -1300,6 +1306,8 @@ subroutine write_ocean_geometry_file(G, param_file, directory, geom_file, US) call close_file(IO_handle) + deallocate(vars, fields) + call callTree_leave('write_ocean_geometry_file()') end subroutine write_ocean_geometry_file From 883fa07eb6b6f0666c85da0f388bb4285b473781 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 14 Apr 2021 19:29:39 -0400 Subject: [PATCH 048/112] +Make MOM_read_data work when 4-d arrays exist Added internal branches of the infra/FMS1 version of MOM_read_data that work when there are 4-d arrays with a fifth time dimension in the file that is being read, which was previously failing even if the variable that is being read has fewer dimensions, due to code limitations within the fms_io read_data routines. These new branches are selected via the new optional argument file_may_be_4d. The infra/FMS2 versions also have the same new optional argument, although in that case it does nothing. All answers are bitwise identical in the cases that worked previously, but SIS2 restart files can now be read via the MOM6 infrastructure interfaces. --- config_src/infra/FMS1/MOM_io_infra.F90 | 169 +++++++++++++++++++++++-- config_src/infra/FMS2/MOM_io_infra.F90 | 16 ++- 2 files changed, 168 insertions(+), 17 deletions(-) diff --git a/config_src/infra/FMS1/MOM_io_infra.F90 b/config_src/infra/FMS1/MOM_io_infra.F90 index 14e0732c8a..cca42c94c9 100644 --- a/config_src/infra/FMS1/MOM_io_infra.F90 +++ b/config_src/infra/FMS1/MOM_io_infra.F90 @@ -11,7 +11,7 @@ module MOM_io_infra use fms_io_mod, only : file_exist, field_exist, field_size, read_data use fms_io_mod, only : fms_io_exit, get_filename_appendix use mpp_io_mod, only : mpp_open, mpp_close, mpp_flush -use mpp_io_mod, only : mpp_write_meta, mpp_write +use mpp_io_mod, only : mpp_write_meta, mpp_write, mpp_read use mpp_io_mod, only : mpp_get_atts, mpp_attribute_exist use mpp_io_mod, only : mpp_get_axes, axistype, mpp_get_axis_data use mpp_io_mod, only : mpp_get_fields, fieldtype @@ -22,6 +22,7 @@ module MOM_io_infra use mpp_io_mod, only : OVERWRITE_FILE=>MPP_OVERWR, READONLY_FILE=>MPP_RDONLY use mpp_io_mod, only : NETCDF_FILE=>MPP_NETCDF, ASCII_FILE=>MPP_ASCII use mpp_io_mod, only : MULTIPLE=>MPP_MULTI, SINGLE_FILE=>MPP_SINGLE +use mpp_mod, only : lowercase use iso_fortran_env, only : int64 implicit none ; private @@ -413,7 +414,7 @@ end subroutine get_axis_data !> This routine uses the fms_io subroutine read_data to read a scalar named !! "fieldname" from a single or domain-decomposed file "filename". -subroutine MOM_read_data_0d(filename, fieldname, data, timelevel, scale, MOM_Domain) +subroutine MOM_read_data_0d(filename, fieldname, data, timelevel, scale, MOM_Domain, file_may_be_4d) 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 !< The 1-dimensional array into which the data @@ -422,8 +423,36 @@ subroutine MOM_read_data_0d(filename, fieldname, data, timelevel, scale, MOM_Dom !! by before it is returned. type(MOM_domain_type), & optional, intent(in) :: MOM_Domain !< The MOM_Domain that describes the decomposition + logical, optional, intent(in) :: file_may_be_4d !< If true, this file may have 4-d arrays, + !! in which case a more elaborate set of calls + !! is needed to read it due to FMS limitations. - if (present(MOM_Domain)) then + ! Local variables + character(len=80) :: varname ! The name of a variable in the file + type(fieldtype), allocatable :: fields(:) ! An array of types describing all the variables in the file + logical :: use_fms_read_data + integer :: n, unit, ndim, nvar, natt, ntime + + use_fms_read_data = .true. ; if (present(file_may_be_4d)) use_fms_read_data = .not.file_may_be_4d + + if (.not.use_fms_read_data) then + call mpp_open(unit, trim(filename), form=NETCDF_FILE, action=READONLY_FILE, & + threading=MULTIPLE, fileset=SINGLE_FILE) !, domain=MOM_Domain%mpp_domain ) + call mpp_get_info(unit, ndim, nvar, natt, ntime) + allocate(fields(nvar)) + call mpp_get_fields(unit, fields(1:nvar)) + do n=1, nvar + call mpp_get_atts(fields(n), name=varname) + if (lowercase(trim(varname)) == lowercase(trim(fieldname))) then + ! Maybe something should be done depending on the value of ntime. + call mpp_read(unit, fields(n), data, timelevel) + exit + endif + enddo + + deallocate(fields) + call mpp_close(unit) + elseif (present(MOM_Domain)) then call read_data(filename, fieldname, data, MOM_Domain%mpp_domain, timelevel=timelevel) else call read_data(filename, fieldname, data, timelevel=timelevel, no_domain=.true.) @@ -437,7 +466,7 @@ end subroutine MOM_read_data_0d !> This routine uses the fms_io subroutine read_data to read a 1-D data field named !! "fieldname" from a single or domain-decomposed file "filename". -subroutine MOM_read_data_1d(filename, fieldname, data, timelevel, scale, MOM_Domain) +subroutine MOM_read_data_1d(filename, fieldname, data, timelevel, scale, MOM_Domain, file_may_be_4d) 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 array into which the data @@ -446,8 +475,36 @@ subroutine MOM_read_data_1d(filename, fieldname, data, timelevel, scale, MOM_Dom !! by before they are returned. type(MOM_domain_type), & optional, intent(in) :: MOM_Domain !< The MOM_Domain that describes the decomposition + logical, optional, intent(in) :: file_may_be_4d !< If true, this file may have 4-d arrays, + !! in which case a more elaborate set of calls + !! is needed to read it due to FMS limitations. - if (present(MOM_Domain)) then + ! Local variables + character(len=80) :: varname ! The name of a variable in the file + type(fieldtype), allocatable :: fields(:) ! An array of types describing all the variables in the file + logical :: use_fms_read_data + integer :: n, unit, ndim, nvar, natt, ntime + + use_fms_read_data = .true. ; if (present(file_may_be_4d)) use_fms_read_data = .not.file_may_be_4d + + if (.not.use_fms_read_data) then + call mpp_open(unit, trim(filename), form=NETCDF_FILE, action=READONLY_FILE, & + threading=MULTIPLE, fileset=SINGLE_FILE) !, domain=MOM_Domain%mpp_domain ) + call mpp_get_info(unit, ndim, nvar, natt, ntime) + allocate(fields(nvar)) + call mpp_get_fields(unit, fields(1:nvar)) + do n=1, nvar + call mpp_get_atts(fields(n), name=varname) + if (lowercase(trim(varname)) == lowercase(trim(fieldname))) then + ! Maybe something should be done depending on the value of ntime. + call mpp_read(unit, fields(n), data, timelevel) + exit + endif + enddo + + deallocate(fields) + call mpp_close(unit) + elseif (present(MOM_Domain)) then call read_data(filename, fieldname, data, MOM_Domain%mpp_domain, timelevel=timelevel) else call read_data(filename, fieldname, data, timelevel=timelevel, no_domain=.true.) @@ -463,7 +520,7 @@ end subroutine MOM_read_data_1d !! 2-D data field named "fieldname" from file "filename". Valid values for !! "position" include CORNER, CENTER, EAST_FACE and NORTH_FACE. subroutine MOM_read_data_2d(filename, fieldname, data, MOM_Domain, & - timelevel, position, scale) + timelevel, position, scale, file_may_be_4d) 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 array into which the data @@ -473,9 +530,39 @@ subroutine MOM_read_data_2d(filename, fieldname, data, MOM_Domain, & integer, optional, intent(in) :: position !< A flag indicating where this data is located real, optional, intent(in) :: scale !< A scaling factor that the field is multiplied !! by before it is returned. + logical, optional, intent(in) :: file_may_be_4d !< If true, this file may have 4-d arrays, + !! in which case a more elaborate set of calls + !! is needed to read it due to FMS limitations. - call read_data(filename, fieldname, data, MOM_Domain%mpp_domain, & - timelevel=timelevel, position=position) + ! Local variables + character(len=80) :: varname ! The name of a variable in the file + type(fieldtype), allocatable :: fields(:) ! An array of types describing all the variables in the file + logical :: use_fms_read_data + integer :: n, unit, ndim, nvar, natt, ntime + + use_fms_read_data = .true. ; if (present(file_may_be_4d)) use_fms_read_data = .not.file_may_be_4d + + if (use_fms_read_data) then + call read_data(filename, fieldname, data, MOM_Domain%mpp_domain, & + timelevel=timelevel, position=position) + else + call mpp_open(unit, trim(filename), form=NETCDF_FILE, action=READONLY_FILE, & + threading=MULTIPLE, fileset=SINGLE_FILE) !, domain=MOM_Domain%mpp_domain ) + call mpp_get_info(unit, ndim, nvar, natt, ntime) + allocate(fields(nvar)) + call mpp_get_fields(unit, fields(1:nvar)) + do n=1, nvar + call mpp_get_atts(fields(n), name=varname) + if (lowercase(trim(varname)) == lowercase(trim(fieldname))) then + ! Maybe something should be done depending on the value of ntime. + call mpp_read(unit, fields(n), MOM_Domain%mpp_domain, data, timelevel) + exit + endif + enddo + + deallocate(fields) + call mpp_close(unit) + endif if (present(scale)) then ; if (scale /= 1.0) then call rescale_comp_data(MOM_Domain, data, scale) @@ -526,7 +613,7 @@ end subroutine MOM_read_data_2d_region !! 3-D data field named "fieldname" from file "filename". Valid values for !! "position" include CORNER, CENTER, EAST_FACE and NORTH_FACE. subroutine MOM_read_data_3d(filename, fieldname, data, MOM_Domain, & - timelevel, position, scale) + timelevel, position, scale, file_may_be_4d) 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 array into which the data @@ -536,9 +623,39 @@ subroutine MOM_read_data_3d(filename, fieldname, data, MOM_Domain, & integer, optional, intent(in) :: position !< A flag indicating where this data is located real, optional, intent(in) :: scale !< A scaling factor that the field is multiplied !! by before it is returned. + logical, optional, intent(in) :: file_may_be_4d !< If true, this file may have 4-d arrays, + !! in which case a more elaborate set of calls + !! is needed to read it due to FMS limitations. + + ! Local variables + character(len=80) :: varname ! The name of a variable in the file + type(fieldtype), allocatable :: fields(:) ! An array of types describing all the variables in the file + logical :: use_fms_read_data + integer :: n, unit, ndim, nvar, natt, ntime - call read_data(filename, fieldname, data, MOM_Domain%mpp_domain, & - timelevel=timelevel, position=position) + use_fms_read_data = .true. ; if (present(file_may_be_4d)) use_fms_read_data = .not.file_may_be_4d + + if (use_fms_read_data) then + call read_data(filename, fieldname, data, MOM_Domain%mpp_domain, & + timelevel=timelevel, position=position) + else + call mpp_open(unit, trim(filename), form=NETCDF_FILE, action=READONLY_FILE, & + threading=MULTIPLE, fileset=SINGLE_FILE) !, domain=MOM_Domain%mpp_domain ) + call mpp_get_info(unit, ndim, nvar, natt, ntime) + allocate(fields(nvar)) + call mpp_get_fields(unit, fields(1:nvar)) + do n=1, nvar + call mpp_get_atts(fields(n), name=varname) + if (lowercase(trim(varname)) == lowercase(trim(fieldname))) then + ! Maybe something should be done depending on the value of ntime. + call mpp_read(unit, fields(n), MOM_Domain%mpp_domain, data, timelevel) + exit + endif + enddo + + deallocate(fields) + call mpp_close(unit) + endif if (present(scale)) then ; if (scale /= 1.0) then call rescale_comp_data(MOM_Domain, data, scale) @@ -561,8 +678,34 @@ subroutine MOM_read_data_4d(filename, fieldname, data, MOM_Domain, & real, optional, intent(in) :: scale !< A scaling factor that the field is multiplied !! by before it is returned. - call read_data(filename, fieldname, data, MOM_Domain%mpp_domain, & - timelevel=timelevel, position=position) + ! Local variables + character(len=80) :: varname ! The name of a variable in the file + type(fieldtype), allocatable :: fields(:) ! An array of types describing all the variables in the file + logical :: use_fms_read_data + integer :: n, unit, ndim, nvar, natt, ntime + integer :: is, ie, js, je + + ! This single call does not work for a 4-d array due to FMS limitations, so multiple calls are + ! needed. + ! call read_data(filename, fieldname, data, MOM_Domain%mpp_domain, & + ! timelevel=timelevel, position=position) + + call mpp_open(unit, trim(filename), form=NETCDF_FILE, action=READONLY_FILE, & + threading=MULTIPLE, fileset=SINGLE_FILE) !, domain=MOM_Domain%mpp_domain ) + call mpp_get_info(unit, ndim, nvar, natt, ntime) + allocate(fields(nvar)) + call mpp_get_fields(unit, fields(1:nvar)) + do n=1, nvar + call mpp_get_atts(fields(n), name=varname) + if (lowercase(trim(varname)) == lowercase(trim(fieldname))) then + ! Maybe something should be done depending on the value of ntime. + call mpp_read(unit, fields(n), MOM_Domain%mpp_domain, data, timelevel) + exit + endif + enddo + + deallocate(fields) + call mpp_close(unit) if (present(scale)) then ; if (scale /= 1.0) then call rescale_comp_data(MOM_Domain, data, scale) diff --git a/config_src/infra/FMS2/MOM_io_infra.F90 b/config_src/infra/FMS2/MOM_io_infra.F90 index 4833c37e3a..7a887e3ebc 100644 --- a/config_src/infra/FMS2/MOM_io_infra.F90 +++ b/config_src/infra/FMS2/MOM_io_infra.F90 @@ -655,7 +655,7 @@ end subroutine get_axis_data !> This routine uses the fms_io subroutine read_data to read a scalar named !! "fieldname" from a single or domain-decomposed file "filename". -subroutine MOM_read_data_0d(filename, fieldname, data, timelevel, scale, MOM_Domain) +subroutine MOM_read_data_0d(filename, fieldname, data, timelevel, scale, MOM_Domain, file_may_be_4d) 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 !< The 1-dimensional array into which the data @@ -664,6 +664,8 @@ subroutine MOM_read_data_0d(filename, fieldname, data, timelevel, scale, MOM_Dom !! by before it is returned. type(MOM_domain_type), & optional, intent(in) :: MOM_Domain !< The MOM_Domain that describes the decomposition + logical, optional, intent(in) :: file_may_be_4d !< If true, this file may have 4-d arrays, but + !! with the FMS2 I/O interfaces this does not matter. ! Local variables type(FmsNetcdfFile_t) :: fileObj ! A handle to a non-domain-decomposed file @@ -723,7 +725,7 @@ end subroutine MOM_read_data_0d !> This routine uses the fms_io subroutine read_data to read a 1-D data field named !! "fieldname" from a single or domain-decomposed file "filename". -subroutine MOM_read_data_1d(filename, fieldname, data, timelevel, scale, MOM_Domain) +subroutine MOM_read_data_1d(filename, fieldname, data, timelevel, scale, MOM_Domain, file_may_be_4d) 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 array into which the data @@ -732,6 +734,8 @@ subroutine MOM_read_data_1d(filename, fieldname, data, timelevel, scale, MOM_Dom !! by before they are returned. type(MOM_domain_type), & optional, intent(in) :: MOM_Domain !< The MOM_Domain that describes the decomposition + logical, optional, intent(in) :: file_may_be_4d !< If true, this file may have 4-d arrays, but + !! with the FMS2 I/O interfaces this does not matter. ! Local variables type(FmsNetcdfFile_t) :: fileObj ! A handle to a non-domain-decomposed file @@ -793,7 +797,7 @@ end subroutine MOM_read_data_1d !! 2-D data field named "fieldname" from file "filename". Valid values for !! "position" include CORNER, CENTER, EAST_FACE and NORTH_FACE. subroutine MOM_read_data_2d(filename, fieldname, data, MOM_Domain, & - timelevel, position, scale) + timelevel, position, scale, file_may_be_4d) 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 array into which the data @@ -803,6 +807,8 @@ subroutine MOM_read_data_2d(filename, fieldname, data, MOM_Domain, & integer, optional, intent(in) :: position !< A flag indicating where this data is located real, optional, intent(in) :: scale !< A scaling factor that the field is multiplied !! by before it is returned. + logical, optional, intent(in) :: file_may_be_4d !< If true, this file may have 4-d arrays, but + !! with the FMS2 I/O interfaces this does not matter. ! Local variables type(FmsNetcdfDomainFile_t) :: fileobj ! A handle to a domain-decomposed file object @@ -916,7 +922,7 @@ end subroutine MOM_read_data_2d_region !! 3-D data field named "fieldname" from file "filename". Valid values for !! "position" include CORNER, CENTER, EAST_FACE and NORTH_FACE. subroutine MOM_read_data_3d(filename, fieldname, data, MOM_Domain, & - timelevel, position, scale) + timelevel, position, scale, file_may_be_4d) 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 array into which the data @@ -926,6 +932,8 @@ subroutine MOM_read_data_3d(filename, fieldname, data, MOM_Domain, & integer, optional, intent(in) :: position !< A flag indicating where this data is located real, optional, intent(in) :: scale !< A scaling factor that the field is multiplied !! by before it is returned. + logical, optional, intent(in) :: file_may_be_4d !< If true, this file may have 4-d arrays, but + !! with the FMS2 I/O interfaces this does not matter. ! Local variables type(FmsNetcdfDomainFile_t) :: fileobj ! A handle to a domain-decomposed file object From 443da5b4622d2ebe4a545cb12dbe1d4320cf86cf Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Fri, 16 Apr 2021 18:52:38 -0400 Subject: [PATCH 049/112] Display hash of submodules in gitlab pipeline - We found it hard to figure out the exact state of the pipeline because it updates to the latest of MOM6-examples at the time of running, and that might change between the run and when you examine the logs. - This adds a few git commands to show the hash of every submodule we care about. --- .gitlab-ci.yml | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index befac14642..5d84c0c176 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -38,6 +38,10 @@ setup: - test -d MOM6-examples/src/LM3 || make -f MRS/Makefile.clone clone_gfdl -s - make -f MRS/Makefile.clone MOM6-examples/.datasets -s - env > gitlab_session.log + # Show hashes for final setup + - git show --oneline + - git submodule status + - (cd MOM6-examples && git submodule status --recursive src) # Cache everything under tests to unpack for each subsequent stage - cd ../ ; time tar zcf $CACHE_DIR/tests_$CI_PIPELINE_ID.tgz tests From 9ecab91e6c2859303ac1321dfbbfcd54be4bb4c3 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Mon, 19 Apr 2021 09:17:05 -0400 Subject: [PATCH 050/112] +Add optional global_file argument to MOM_read_data Added the optional argument global_file to all of the overloaded MOM_read_data routines, to indicate whether the file being read is global or is domain- decomposed using the IO-layout. With FMS2, this change does nothing, but with FMS1 it is needed to correctly read from decomposed files that might include 4-d arrays. With this change there are versions of SIS2 that reproduce across restarts without using the FMS1 restart routines. All answers are bitwise identical, but there are new optional arguments. --- config_src/infra/FMS1/MOM_io_infra.F90 | 90 ++++++++++++++++++++------ config_src/infra/FMS2/MOM_io_infra.F90 | 17 +++-- 2 files changed, 82 insertions(+), 25 deletions(-) diff --git a/config_src/infra/FMS1/MOM_io_infra.F90 b/config_src/infra/FMS1/MOM_io_infra.F90 index cca42c94c9..ea3dbd15b7 100644 --- a/config_src/infra/FMS1/MOM_io_infra.F90 +++ b/config_src/infra/FMS1/MOM_io_infra.F90 @@ -414,7 +414,8 @@ end subroutine get_axis_data !> This routine uses the fms_io subroutine read_data to read a scalar named !! "fieldname" from a single or domain-decomposed file "filename". -subroutine MOM_read_data_0d(filename, fieldname, data, timelevel, scale, MOM_Domain, file_may_be_4d) +subroutine MOM_read_data_0d(filename, fieldname, data, timelevel, scale, MOM_Domain, & + global_file, file_may_be_4d) 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 !< The 1-dimensional array into which the data @@ -423,6 +424,7 @@ subroutine MOM_read_data_0d(filename, fieldname, data, timelevel, scale, MOM_Dom !! by before it is returned. type(MOM_domain_type), & optional, intent(in) :: MOM_Domain !< The MOM_Domain that describes the decomposition + logical, optional, intent(in) :: global_file !< If true, read from a single global file logical, optional, intent(in) :: file_may_be_4d !< If true, this file may have 4-d arrays, !! in which case a more elaborate set of calls !! is needed to read it due to FMS limitations. @@ -430,14 +432,20 @@ subroutine MOM_read_data_0d(filename, fieldname, data, timelevel, scale, MOM_Dom ! Local variables character(len=80) :: varname ! The name of a variable in the file type(fieldtype), allocatable :: fields(:) ! An array of types describing all the variables in the file - logical :: use_fms_read_data + logical :: use_fms_read_data, file_is_global integer :: n, unit, ndim, nvar, natt, ntime use_fms_read_data = .true. ; if (present(file_may_be_4d)) use_fms_read_data = .not.file_may_be_4d + file_is_global = .true. ; if (present(global_file)) file_is_global = global_file if (.not.use_fms_read_data) then - call mpp_open(unit, trim(filename), form=NETCDF_FILE, action=READONLY_FILE, & - threading=MULTIPLE, fileset=SINGLE_FILE) !, domain=MOM_Domain%mpp_domain ) + if (file_is_global) then + call mpp_open(unit, trim(filename), form=NETCDF_FILE, action=READONLY_FILE, & + threading=MULTIPLE, fileset=SINGLE_FILE) !, domain=MOM_Domain%mpp_domain ) + else + call mpp_open(unit, trim(filename), form=NETCDF_FILE, action=READONLY_FILE, & + threading=MULTIPLE, fileset=MULTIPLE, domain=MOM_Domain%mpp_domain ) + endif call mpp_get_info(unit, ndim, nvar, natt, ntime) allocate(fields(nvar)) call mpp_get_fields(unit, fields(1:nvar)) @@ -466,7 +474,8 @@ end subroutine MOM_read_data_0d !> This routine uses the fms_io subroutine read_data to read a 1-D data field named !! "fieldname" from a single or domain-decomposed file "filename". -subroutine MOM_read_data_1d(filename, fieldname, data, timelevel, scale, MOM_Domain, file_may_be_4d) +subroutine MOM_read_data_1d(filename, fieldname, data, timelevel, scale, MOM_Domain, & + global_file, file_may_be_4d) 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 array into which the data @@ -475,6 +484,7 @@ subroutine MOM_read_data_1d(filename, fieldname, data, timelevel, scale, MOM_Dom !! by before they are returned. type(MOM_domain_type), & optional, intent(in) :: MOM_Domain !< The MOM_Domain that describes the decomposition + logical, optional, intent(in) :: global_file !< If true, read from a single global file logical, optional, intent(in) :: file_may_be_4d !< If true, this file may have 4-d arrays, !! in which case a more elaborate set of calls !! is needed to read it due to FMS limitations. @@ -482,25 +492,34 @@ subroutine MOM_read_data_1d(filename, fieldname, data, timelevel, scale, MOM_Dom ! Local variables character(len=80) :: varname ! The name of a variable in the file type(fieldtype), allocatable :: fields(:) ! An array of types describing all the variables in the file - logical :: use_fms_read_data + logical :: use_fms_read_data, file_is_global integer :: n, unit, ndim, nvar, natt, ntime use_fms_read_data = .true. ; if (present(file_may_be_4d)) use_fms_read_data = .not.file_may_be_4d + file_is_global = .true. ; if (present(global_file)) file_is_global = global_file if (.not.use_fms_read_data) then - call mpp_open(unit, trim(filename), form=NETCDF_FILE, action=READONLY_FILE, & - threading=MULTIPLE, fileset=SINGLE_FILE) !, domain=MOM_Domain%mpp_domain ) + if (file_is_global) then + call mpp_open(unit, trim(filename), form=NETCDF_FILE, action=READONLY_FILE, & + threading=MULTIPLE, fileset=SINGLE_FILE) !, domain=MOM_Domain%mpp_domain ) + else + call mpp_open(unit, trim(filename), form=NETCDF_FILE, action=READONLY_FILE, & + threading=MULTIPLE, fileset=MULTIPLE, domain=MOM_Domain%mpp_domain ) + endif call mpp_get_info(unit, ndim, nvar, natt, ntime) allocate(fields(nvar)) call mpp_get_fields(unit, fields(1:nvar)) do n=1, nvar call mpp_get_atts(fields(n), name=varname) if (lowercase(trim(varname)) == lowercase(trim(fieldname))) then + call MOM_error(NOTE, "Reading 1-d variable "//trim(fieldname)//" from file "//trim(filename)) ! Maybe something should be done depending on the value of ntime. call mpp_read(unit, fields(n), data, timelevel) exit endif enddo + if ((n == nvar+1) .or. (nvar < 1)) call MOM_error(WARNING, & + "MOM_read_data apparently did not find 1-d variable "//trim(fieldname)//" in file "//trim(filename)) deallocate(fields) call mpp_close(unit) @@ -520,7 +539,7 @@ end subroutine MOM_read_data_1d !! 2-D data field named "fieldname" from file "filename". Valid values for !! "position" include CORNER, CENTER, EAST_FACE and NORTH_FACE. subroutine MOM_read_data_2d(filename, fieldname, data, MOM_Domain, & - timelevel, position, scale, file_may_be_4d) + timelevel, position, scale, global_file, file_may_be_4d) 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 array into which the data @@ -530,6 +549,7 @@ subroutine MOM_read_data_2d(filename, fieldname, data, MOM_Domain, & integer, optional, intent(in) :: position !< A flag indicating where this data is located real, optional, intent(in) :: scale !< A scaling factor that the field is multiplied !! by before it is returned. + logical, optional, intent(in) :: global_file !< If true, read from a single global file logical, optional, intent(in) :: file_may_be_4d !< If true, this file may have 4-d arrays, !! in which case a more elaborate set of calls !! is needed to read it due to FMS limitations. @@ -537,28 +557,37 @@ subroutine MOM_read_data_2d(filename, fieldname, data, MOM_Domain, & ! Local variables character(len=80) :: varname ! The name of a variable in the file type(fieldtype), allocatable :: fields(:) ! An array of types describing all the variables in the file - logical :: use_fms_read_data + logical :: use_fms_read_data, file_is_global integer :: n, unit, ndim, nvar, natt, ntime use_fms_read_data = .true. ; if (present(file_may_be_4d)) use_fms_read_data = .not.file_may_be_4d + file_is_global = .true. ; if (present(global_file)) file_is_global = global_file if (use_fms_read_data) then call read_data(filename, fieldname, data, MOM_Domain%mpp_domain, & timelevel=timelevel, position=position) else - call mpp_open(unit, trim(filename), form=NETCDF_FILE, action=READONLY_FILE, & - threading=MULTIPLE, fileset=SINGLE_FILE) !, domain=MOM_Domain%mpp_domain ) + if (file_is_global) then + call mpp_open(unit, trim(filename), form=NETCDF_FILE, action=READONLY_FILE, & + threading=MULTIPLE, fileset=SINGLE_FILE) !, domain=MOM_Domain%mpp_domain ) + else + call mpp_open(unit, trim(filename), form=NETCDF_FILE, action=READONLY_FILE, & + threading=MULTIPLE, fileset=MULTIPLE, domain=MOM_Domain%mpp_domain ) + endif call mpp_get_info(unit, ndim, nvar, natt, ntime) allocate(fields(nvar)) call mpp_get_fields(unit, fields(1:nvar)) do n=1, nvar call mpp_get_atts(fields(n), name=varname) if (lowercase(trim(varname)) == lowercase(trim(fieldname))) then + call MOM_error(NOTE, "Reading 2-d variable "//trim(fieldname)//" from file "//trim(filename)) ! Maybe something should be done depending on the value of ntime. call mpp_read(unit, fields(n), MOM_Domain%mpp_domain, data, timelevel) exit endif enddo + if ((n == nvar+1) .or. (nvar < 1)) call MOM_error(WARNING, & + "MOM_read_data apparently did not find 2-d variable "//trim(fieldname)//" in file "//trim(filename)) deallocate(fields) call mpp_close(unit) @@ -613,7 +642,7 @@ end subroutine MOM_read_data_2d_region !! 3-D data field named "fieldname" from file "filename". Valid values for !! "position" include CORNER, CENTER, EAST_FACE and NORTH_FACE. subroutine MOM_read_data_3d(filename, fieldname, data, MOM_Domain, & - timelevel, position, scale, file_may_be_4d) + timelevel, position, scale, global_file, file_may_be_4d) 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 array into which the data @@ -623,6 +652,7 @@ subroutine MOM_read_data_3d(filename, fieldname, data, MOM_Domain, & integer, optional, intent(in) :: position !< A flag indicating where this data is located real, optional, intent(in) :: scale !< A scaling factor that the field is multiplied !! by before it is returned. + logical, optional, intent(in) :: global_file !< If true, read from a single global file logical, optional, intent(in) :: file_may_be_4d !< If true, this file may have 4-d arrays, !! in which case a more elaborate set of calls !! is needed to read it due to FMS limitations. @@ -630,28 +660,37 @@ subroutine MOM_read_data_3d(filename, fieldname, data, MOM_Domain, & ! Local variables character(len=80) :: varname ! The name of a variable in the file type(fieldtype), allocatable :: fields(:) ! An array of types describing all the variables in the file - logical :: use_fms_read_data + logical :: use_fms_read_data, file_is_global integer :: n, unit, ndim, nvar, natt, ntime use_fms_read_data = .true. ; if (present(file_may_be_4d)) use_fms_read_data = .not.file_may_be_4d + file_is_global = .true. ; if (present(global_file)) file_is_global = global_file if (use_fms_read_data) then call read_data(filename, fieldname, data, MOM_Domain%mpp_domain, & timelevel=timelevel, position=position) else - call mpp_open(unit, trim(filename), form=NETCDF_FILE, action=READONLY_FILE, & - threading=MULTIPLE, fileset=SINGLE_FILE) !, domain=MOM_Domain%mpp_domain ) + if (file_is_global) then + call mpp_open(unit, trim(filename), form=NETCDF_FILE, action=READONLY_FILE, & + threading=MULTIPLE, fileset=SINGLE_FILE) !, domain=MOM_Domain%mpp_domain ) + else + call mpp_open(unit, trim(filename), form=NETCDF_FILE, action=READONLY_FILE, & + threading=MULTIPLE, fileset=MULTIPLE, domain=MOM_Domain%mpp_domain ) + endif call mpp_get_info(unit, ndim, nvar, natt, ntime) allocate(fields(nvar)) call mpp_get_fields(unit, fields(1:nvar)) do n=1, nvar call mpp_get_atts(fields(n), name=varname) if (lowercase(trim(varname)) == lowercase(trim(fieldname))) then + call MOM_error(NOTE, "Reading 3-d variable "//trim(fieldname)//" from file "//trim(filename)) ! Maybe something should be done depending on the value of ntime. call mpp_read(unit, fields(n), MOM_Domain%mpp_domain, data, timelevel) exit endif enddo + if ((n == nvar+1) .or. (nvar < 1)) call MOM_error(WARNING, & + "MOM_read_data apparently did not find 3-d variable "//trim(fieldname)//" in file "//trim(filename)) deallocate(fields) call mpp_close(unit) @@ -667,7 +706,7 @@ end subroutine MOM_read_data_3d !! 4-D data field named "fieldname" from file "filename". Valid values for !! "position" include CORNER, CENTER, EAST_FACE and NORTH_FACE. subroutine MOM_read_data_4d(filename, fieldname, data, MOM_Domain, & - timelevel, position, scale) + timelevel, position, scale, global_file) 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 array into which the data @@ -677,11 +716,12 @@ subroutine MOM_read_data_4d(filename, fieldname, data, MOM_Domain, & integer, optional, intent(in) :: position !< A flag indicating where this data is located real, optional, intent(in) :: scale !< A scaling factor that the field is multiplied !! by before it is returned. + logical, optional, intent(in) :: global_file !< If true, read from a single global file ! Local variables character(len=80) :: varname ! The name of a variable in the file type(fieldtype), allocatable :: fields(:) ! An array of types describing all the variables in the file - logical :: use_fms_read_data + logical :: use_fms_read_data, file_is_global integer :: n, unit, ndim, nvar, natt, ntime integer :: is, ie, js, je @@ -690,19 +730,29 @@ subroutine MOM_read_data_4d(filename, fieldname, data, MOM_Domain, & ! call read_data(filename, fieldname, data, MOM_Domain%mpp_domain, & ! timelevel=timelevel, position=position) - call mpp_open(unit, trim(filename), form=NETCDF_FILE, action=READONLY_FILE, & - threading=MULTIPLE, fileset=SINGLE_FILE) !, domain=MOM_Domain%mpp_domain ) + file_is_global = .true. ; if (present(global_file)) file_is_global = global_file + + if (file_is_global) then + call mpp_open(unit, trim(filename), form=NETCDF_FILE, action=READONLY_FILE, & + threading=MULTIPLE, fileset=SINGLE_FILE) !, domain=MOM_Domain%mpp_domain ) + else + call mpp_open(unit, trim(filename), form=NETCDF_FILE, action=READONLY_FILE, & + threading=MULTIPLE, fileset=MULTIPLE, domain=MOM_Domain%mpp_domain ) + endif call mpp_get_info(unit, ndim, nvar, natt, ntime) allocate(fields(nvar)) call mpp_get_fields(unit, fields(1:nvar)) do n=1, nvar call mpp_get_atts(fields(n), name=varname) if (lowercase(trim(varname)) == lowercase(trim(fieldname))) then + call MOM_error(NOTE, "Reading 4-d variable "//trim(fieldname)//" from file "//trim(filename)) ! Maybe something should be done depending on the value of ntime. call mpp_read(unit, fields(n), MOM_Domain%mpp_domain, data, timelevel) exit endif enddo + if ((n == nvar+1) .or. (nvar < 1)) call MOM_error(WARNING, & + "MOM_read_data apparently did not find 4-d variable "//trim(fieldname)//" in file "//trim(filename)) deallocate(fields) call mpp_close(unit) diff --git a/config_src/infra/FMS2/MOM_io_infra.F90 b/config_src/infra/FMS2/MOM_io_infra.F90 index 7a887e3ebc..9f03d8fd12 100644 --- a/config_src/infra/FMS2/MOM_io_infra.F90 +++ b/config_src/infra/FMS2/MOM_io_infra.F90 @@ -655,7 +655,8 @@ end subroutine get_axis_data !> This routine uses the fms_io subroutine read_data to read a scalar named !! "fieldname" from a single or domain-decomposed file "filename". -subroutine MOM_read_data_0d(filename, fieldname, data, timelevel, scale, MOM_Domain, file_may_be_4d) +subroutine MOM_read_data_0d(filename, fieldname, data, timelevel, scale, MOM_Domain, & + global_file, file_may_be_4d) 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 !< The 1-dimensional array into which the data @@ -664,6 +665,7 @@ subroutine MOM_read_data_0d(filename, fieldname, data, timelevel, scale, MOM_Dom !! by before it is returned. type(MOM_domain_type), & optional, intent(in) :: MOM_Domain !< The MOM_Domain that describes the decomposition + logical, optional, intent(in) :: global_file !< If true, read from a single global file logical, optional, intent(in) :: file_may_be_4d !< If true, this file may have 4-d arrays, but !! with the FMS2 I/O interfaces this does not matter. @@ -725,7 +727,8 @@ end subroutine MOM_read_data_0d !> This routine uses the fms_io subroutine read_data to read a 1-D data field named !! "fieldname" from a single or domain-decomposed file "filename". -subroutine MOM_read_data_1d(filename, fieldname, data, timelevel, scale, MOM_Domain, file_may_be_4d) +subroutine MOM_read_data_1d(filename, fieldname, data, timelevel, scale, MOM_Domain, & + global_file, file_may_be_4d) 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 array into which the data @@ -734,6 +737,7 @@ subroutine MOM_read_data_1d(filename, fieldname, data, timelevel, scale, MOM_Dom !! by before they are returned. type(MOM_domain_type), & optional, intent(in) :: MOM_Domain !< The MOM_Domain that describes the decomposition + logical, optional, intent(in) :: global_file !< If true, read from a single global file logical, optional, intent(in) :: file_may_be_4d !< If true, this file may have 4-d arrays, but !! with the FMS2 I/O interfaces this does not matter. @@ -797,7 +801,7 @@ end subroutine MOM_read_data_1d !! 2-D data field named "fieldname" from file "filename". Valid values for !! "position" include CORNER, CENTER, EAST_FACE and NORTH_FACE. subroutine MOM_read_data_2d(filename, fieldname, data, MOM_Domain, & - timelevel, position, scale, file_may_be_4d) + timelevel, position, scale, global_file, file_may_be_4d) 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 array into which the data @@ -807,6 +811,7 @@ subroutine MOM_read_data_2d(filename, fieldname, data, MOM_Domain, & integer, optional, intent(in) :: position !< A flag indicating where this data is located real, optional, intent(in) :: scale !< A scaling factor that the field is multiplied !! by before it is returned. + logical, optional, intent(in) :: global_file !< If true, read from a single global file logical, optional, intent(in) :: file_may_be_4d !< If true, this file may have 4-d arrays, but !! with the FMS2 I/O interfaces this does not matter. @@ -922,7 +927,7 @@ end subroutine MOM_read_data_2d_region !! 3-D data field named "fieldname" from file "filename". Valid values for !! "position" include CORNER, CENTER, EAST_FACE and NORTH_FACE. subroutine MOM_read_data_3d(filename, fieldname, data, MOM_Domain, & - timelevel, position, scale, file_may_be_4d) + timelevel, position, scale, global_file, file_may_be_4d) 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 array into which the data @@ -932,6 +937,7 @@ subroutine MOM_read_data_3d(filename, fieldname, data, MOM_Domain, & integer, optional, intent(in) :: position !< A flag indicating where this data is located real, optional, intent(in) :: scale !< A scaling factor that the field is multiplied !! by before it is returned. + logical, optional, intent(in) :: global_file !< If true, read from a single global file logical, optional, intent(in) :: file_may_be_4d !< If true, this file may have 4-d arrays, but !! with the FMS2 I/O interfaces this does not matter. @@ -974,7 +980,7 @@ end subroutine MOM_read_data_3d !! 4-D data field named "fieldname" from file "filename". Valid values for !! "position" include CORNER, CENTER, EAST_FACE and NORTH_FACE. subroutine MOM_read_data_4d(filename, fieldname, data, MOM_Domain, & - timelevel, position, scale) + timelevel, position, scale, global_file) 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 array into which the data @@ -984,6 +990,7 @@ subroutine MOM_read_data_4d(filename, fieldname, data, MOM_Domain, & integer, optional, intent(in) :: position !< A flag indicating where this data is located real, optional, intent(in) :: scale !< A scaling factor that the field is multiplied !! by before it is returned. + logical, optional, intent(in) :: global_file !< If true, read from a single global file ! Local variables From e8e200994f04ce92c93900378d7f8878a3c3339c Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Mon, 19 Apr 2021 09:20:13 -0400 Subject: [PATCH 051/112] Fix comment: replaced pints with points - @Hallberg-NOAA suspected I'd had a few too many. Give that US pint glasses don't hold a real pint I can assure hom that the total volume most suredly would not have been too much, if any fake pints had been involved at all, which I deny. --- src/core/MOM_isopycnal_slopes.F90 | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/core/MOM_isopycnal_slopes.F90 b/src/core/MOM_isopycnal_slopes.F90 index 2ac0dd945b..40777c8227 100644 --- a/src/core/MOM_isopycnal_slopes.F90 +++ b/src/core/MOM_isopycnal_slopes.F90 @@ -51,11 +51,11 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, & real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1), & optional, intent(inout) :: dzv !< Z-thickness at v-points [Z ~> m] real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1), & - optional, intent(inout) :: dzSxN !< Z-thickness times zonal slope contribution - !! to Eady growth rate at u-pints. [Z T-1 -> m s-1] + optional, intent(inout) :: dzSxN !< Z-thickness times zonal slope contribution to + !! Eady growth rate at u-points. [Z T-1 ~> m s-1] real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1), & - optional, intent(inout) :: dzSyN !< Z-thickness times meridional slope contrib. - !! to Eady growth rate at v-pints. [Z T-1 -> m s-1] + optional, intent(inout) :: dzSyN !< Z-thickness times meridional slope contrib. to + !! Eady growth rate at v-points. [Z T-1 ~> m s-1] integer, optional, intent(in) :: halo !< Halo width over which to compute type(ocean_OBC_type), optional, pointer :: OBC !< Open boundaries control structure. From d21d21acc78308143836df2ddaf22f99e6485a52 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Mon, 19 Apr 2021 09:37:59 -0400 Subject: [PATCH 052/112] Changed parameter name to USE_SIMPLR_EADY_GROWTH_RATE - Following @Hallberg-NOAA's suggestion, changed runtime parameter name from USE_NEW_EADY_GROWTH_RATE to USE_SIMPLER_EADY_GROWTH_RATE. --- .../lateral/MOM_lateral_mixing_coeffs.F90 | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 b/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 index 37c995c0e4..729e961974 100644 --- a/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 +++ b/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 @@ -55,7 +55,7 @@ module MOM_lateral_mixing_coeffs !! This parameter is set depending on other parameters. logical :: calculate_Eady_growth_rate !< If true, calculate all the Eady growth rate. !! This parameter is set depending on other parameters. - logical :: use_new_Eady_growth_rate !< If true, use a simpler method to calculate the + logical :: use_simpler_Eady_growth_rate !< If true, use a simpler method to calculate the !! Eady growth rate that avoids division by layer thickness. !! This parameter is set depending on other parameters. real :: cropping_distance !< Distance from surface or bottom to filter out outcropped or @@ -463,7 +463,7 @@ subroutine calc_slope_functions(h, tv, dt, G, GV, US, CS, OBC) "Module must be initialized before it is used.") if (CS%calculate_Eady_growth_rate) then - if (CS%use_new_Eady_growth_rate) then + if (CS%use_simpler_Eady_growth_rate) then call find_eta(h, tv, G, GV, US, e, halo_size=2) call calc_isoneutral_slopes(G, GV, US, h, e, tv, dt*CS%kappa_smooth, & CS%slope_x, CS%slope_y, N2_u=N2_u, N2_v=N2_v, dzu=dzu, dzv=dzv, & @@ -1183,7 +1183,7 @@ subroutine VarMix_init(Time, G, GV, US, param_file, diag, CS) CS%calculate_cg1 = .false. CS%calculate_Rd_dx = .false. CS%calculate_res_fns = .false. - CS%use_new_Eady_growth_rate = .false. + CS%use_simpler_Eady_growth_rate = .false. CS%calculate_depth_fns = .false. ! Read all relevant parameters and write them to the model log. call log_version(param_file, mdl, version, "") @@ -1294,13 +1294,13 @@ subroutine VarMix_init(Time, G, GV, US, param_file, diag, CS) 'Inverse eddy time-scale, S*N, at u-points', 's-1', conversion=US%s_to_T) CS%id_SN_v = register_diag_field('ocean_model', 'SN_v', diag%axesCv1, Time, & 'Inverse eddy time-scale, S*N, at v-points', 's-1', conversion=US%s_to_T) - call get_param(param_file, mdl, "USE_NEW_EADY_GROWTH_RATE", CS%use_new_Eady_growth_rate, & + call get_param(param_file, mdl, "USE_SIMPLER_EADY_GROWTH_RATE", CS%use_simpler_Eady_growth_rate, & "If true, use a simpler method to calculate the Eady growth rate "//& "that avoids division by layer thickness. Recommended.", default=.false.) - if (CS%use_new_Eady_growth_rate) then + if (CS%use_simpler_Eady_growth_rate) then if (.not. CS%use_stored_slopes) call MOM_error(FATAL, & "MOM_lateral_mixing_coeffs.F90, VarMix_init:"//& - "When USE_NEW_EADY_GROWTH_RATE=True, USE_STORED_SLOPES must also be True.") + "When USE_SIMPLER_EADY_GROWTH_RATE=True, USE_STORED_SLOPES must also be True.") call get_param(param_file, mdl, "EADY_GROWTH_RATE_D_SCALE", CS%Eady_GR_D_scale, & "The depth from surface over which to average SN when calculating "//& "a 2D Eady growth rate. Zero mean use full depth.", & @@ -1352,7 +1352,7 @@ subroutine VarMix_init(Time, G, GV, US, param_file, diag, CS) 'Square of Brunt-Vaisala frequency, N^2, at v-points, as used in Visbeck et al.', & 's-2', conversion=(US%L_to_Z*US%s_to_T)**2) endif - if (CS%use_new_Eady_growth_rate) then + if (CS%use_simpler_Eady_growth_rate) then CS%id_dzu = register_diag_field('ocean_model', 'dzu_Visbeck', diag%axesCui, Time, & 'dz at u-points, used in calculating Eady growth rate in Visbeck et al..', & 'm', conversion=US%Z_to_m) From 91b94654029555e973483992251598f08df93d28 Mon Sep 17 00:00:00 2001 From: Michael Levy Date: Tue, 20 Apr 2021 10:53:01 -0600 Subject: [PATCH 053/112] read_attribute_str returns cleanly when found=F Updates read_attribute_str() so that if the optional argument found is provided and the attribute is not defined, then the function returns with found=.false. instead of calling MOM_error(FATAL). I did a little bit of testing, and it looks like read_attribute_real and read_attribute_int (not sure if the default is int32 or int64) already behave correctly when found is present so they do not need a similar update --- src/framework/MOM_io.F90 | 29 +++++++++++++++++------------ 1 file changed, 17 insertions(+), 12 deletions(-) diff --git a/src/framework/MOM_io.F90 b/src/framework/MOM_io.F90 index fb1c6b74f1..029689285e 100644 --- a/src/framework/MOM_io.F90 +++ b/src/framework/MOM_io.F90 @@ -906,18 +906,20 @@ subroutine read_attribute_str(filename, attname, att_val, varname, found, all_re endif if ((varid > 0) .or. (varid == NF90_GLOBAL)) then ! The named variable does exist, and found would be true. rc = NF90_inquire_attribute(ncid, varid, attname, xtype=att_type, len=att_len) - if ((rc /= NF90_NOERR) .and. (rc /= NF90_ENOTATT)) & - call MOM_error(FATAL, trim(hdr) // trim(NF90_STRERROR(rc)) //" Error getting info for "//trim(att_str)) - if (att_type /= NF90_CHAR) & - call MOM_error(FATAL, trim(hdr)//": Attribute data type is not a char for "//trim(att_str)) -! if (att_len > len(att_val)) & -! call MOM_error(FATAL, trim(hdr)//": Insufficiently long string passed in to read "//trim(att_str)) - allocate(character(att_len) :: att_val) - - if (rc == NF90_NOERR) then - rc = NF90_get_att(ncid, varid, attname, att_val) + if ((.not. present(found)) .or. (rc /= NF90_ENOTATT)) then if ((rc /= NF90_NOERR) .and. (rc /= NF90_ENOTATT)) & - call MOM_error(FATAL, trim(hdr) // trim(NF90_STRERROR(rc)) //" Difficulties reading "//trim(att_str)) + call MOM_error(FATAL, trim(hdr) // trim(NF90_STRERROR(rc)) //" Error getting info for "//trim(att_str)) + if (att_type /= NF90_CHAR) & + call MOM_error(FATAL, trim(hdr)//": Attribute data type is not a char for "//trim(att_str)) + ! if (att_len > len(att_val)) & + ! call MOM_error(FATAL, trim(hdr)//": Insufficiently long string passed in to read "//trim(att_str)) + allocate(character(att_len) :: att_val) + + if (rc == NF90_NOERR) then + rc = NF90_get_att(ncid, varid, attname, att_val) + if ((rc /= NF90_NOERR) .and. (rc /= NF90_ENOTATT)) & + call MOM_error(FATAL, trim(hdr) // trim(NF90_STRERROR(rc)) //" Difficulties reading "//trim(att_str)) + endif endif endif if (present(found)) found = (rc == NF90_NOERR) @@ -929,6 +931,10 @@ subroutine read_attribute_str(filename, attname, att_val, varname, found, all_re ! Communicate the string length info(1) = att_len ; info(2) = 0 ; if (do_read .and. found) info(2) = 1 call broadcast(info, 2, blocking=.true.) + if (present(found)) then + found = (info(2) /= 0) + if (.not. found) return + endif att_len = info(1) if (att_len > 0) then @@ -938,7 +944,6 @@ subroutine read_attribute_str(filename, attname, att_val, varname, found, all_re if (do_read) tmp_str(1) = att_val call broadcast(tmp_str, att_len, blocking=.true.) att_val = tmp_str(1) - if (present(found)) found = (info(2) /= 0) elseif (.not.allocated(att_val)) then allocate(character(4) :: att_val) ; att_val = '' endif From 400e344ef2a7fe0c7d4f13dd6115a3132f1f4764 Mon Sep 17 00:00:00 2001 From: Olga Sergienko Date: Thu, 22 Apr 2021 13:05:15 -0400 Subject: [PATCH 054/112] The ice-shelf velocities are moved to C-grid as the original code written for that grid. --- src/ice_shelf/MOM_ice_shelf_dynamics.F90 | 462 ++++++++++++++------- src/ice_shelf/MOM_ice_shelf_initialize.F90 | 123 +++++- 2 files changed, 425 insertions(+), 160 deletions(-) diff --git a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 index 7d49ecc103..846cf04007 100644 --- a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 +++ b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 @@ -25,7 +25,7 @@ module MOM_ice_shelf_dynamics use MOM_coms, only : reproducing_sum, sum_across_PEs, max_across_PEs, min_across_PEs use MOM_checksums, only : hchksum, qchksum use MOM_ice_shelf_initialize, only : initialize_ice_shelf_boundary_channel,initialize_ice_flow_from_file - +use MOM_ice_shelf_initialize, only : initialize_ice_shelf_boundary_from_file implicit none ; private #include @@ -162,7 +162,7 @@ module MOM_ice_shelf_dynamics integer :: id_u_shelf = -1, id_v_shelf = -1, id_t_shelf = -1, & id_taudx_shelf = -1, id_taudy_shelf = -1, id_bed_elev = -1, & id_ground_frac = -1, id_col_thick = -1, id_OD_av = -1, & - id_u_mask = -1, id_v_mask = -1, id_t_mask = -1 + id_u_mask = -1, id_v_mask = -1, id_ufb_mask =-1, id_vfb_mask = -1,id_t_mask = -1 !>@} ! ids for outputting intermediate thickness in advection subroutine (debugging) !>@{ Diagnostic handles for debugging @@ -232,8 +232,8 @@ subroutine register_ice_shelf_dyn_restarts(G, param_file, CS, restart_CS) integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed - IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB - +! IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB + IsdB = G%Isd ; IedB = G%Ied ; JsdB = G%Jsd ; JedB = G%Jed if (associated(CS)) then call MOM_error(FATAL, "MOM_ice_shelf_dyn.F90, register_ice_shelf_dyn_restarts: "// & "called with an associated control structure.") @@ -253,8 +253,8 @@ subroutine register_ice_shelf_dyn_restarts(G, param_file, CS, restart_CS) endif if (active_shelf_dynamics) then - allocate( CS%u_shelf(IsdB:IedB,JsdB:JedB) ) ; CS%u_shelf(:,:) = 0.0 - allocate( CS%v_shelf(IsdB:IedB,JsdB:JedB) ) ; CS%v_shelf(:,:) = 0.0 + allocate( CS%u_shelf(Isd:Ied,Jsd:Jed) ) ; CS%u_shelf(:,:) = 0.0 + allocate( CS%v_shelf(Isd:Ied,Jsd:Jed) ) ; CS%v_shelf(:,:) = 0.0 allocate( CS%t_shelf(isd:ied,jsd:jed) ) ; CS%t_shelf(:,:) = -10.0 allocate( CS%ice_visc(isd:ied,jsd:jed) ) ; CS%ice_visc(:,:) = 0.0 allocate( CS%basal_traction(isd:ied,jsd:jed) ) ; CS%basal_traction(:,:) = 0.0 @@ -265,15 +265,15 @@ subroutine register_ice_shelf_dyn_restarts(G, param_file, CS, restart_CS) allocate( CS%bed_elev(isd:ied,jsd:jed) ) ; CS%bed_elev(:,:)=G%bathyT(:,:)!CS%bed_elev(:,:) = 0.0 ! additional restarts for ice shelf state call register_restart_field(CS%u_shelf, "u_shelf", .false., restart_CS, & - "ice sheet/shelf u-velocity", "m s-1", hor_grid='Bu') + "ice sheet/shelf u-velocity", "m s-1")!, hor_grid='Bu') call register_restart_field(CS%v_shelf, "v_shelf", .false., restart_CS, & - "ice sheet/shelf v-velocity", "m s-1", hor_grid='Bu') + "ice sheet/shelf v-velocity", "m s-1")!, hor_grid='Bu') call register_restart_field(CS%t_shelf, "t_shelf", .true., restart_CS, & "ice sheet/shelf vertically averaged temperature", "deg C") - call register_restart_field(CS%taudx_shelf, "taudx_shelf", .true., restart_CS, & - "ice sheet/shelf taudx-driving stress", "kPa") - call register_restart_field(CS%taudy_shelf, "taudy_shelf", .true., restart_CS, & - "ice sheet/shelf taudy-driving stress", "kPa") + ! call register_restart_field(CS%taudx_shelf, "taudx_shelf", .true., restart_CS, & + ! "ice sheet/shelf taudx-driving stress", "kPa") + ! call register_restart_field(CS%taudy_shelf, "taudy_shelf", .true., restart_CS, & + ! "ice sheet/shelf taudy-driving stress", "kPa") call register_restart_field(CS%OD_av, "OD_av", .true., restart_CS, & "Average open ocean depth in a cell","m") call register_restart_field(CS%ground_frac, "ground_frac", .true., restart_CS, & @@ -317,7 +317,8 @@ subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_ logical :: debug integer :: i, j, is, ie, js, je, isd, ied, jsd, jed, Isdq, Iedq, Jsdq, Jedq, iters - Isdq = G%isdB ; Iedq = G%iedB ; Jsdq = G%jsdB ; Jedq = G%jedB +! Isdq = G%isdB ; Iedq = G%iedB ; Jsdq = G%jsdB ; Jedq = G%jedB + Isdq = G%isd ; Iedq = G%ied ; Jsdq = G%jsd ; Jedq = G%jed isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed if (.not.associated(CS)) then @@ -430,19 +431,19 @@ subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_ ! previously allocated for registration for restarts. if (active_shelf_dynamics) then - allocate( CS%u_bdry_val(Isdq:Iedq,Jsdq:Jedq) ) ; CS%u_bdry_val(:,:) = 0.0 - allocate( CS%v_bdry_val(Isdq:Iedq,Jsdq:Jedq) ) ; CS%v_bdry_val(:,:) = 0.0 + allocate( CS%u_bdry_val(Isd:Ied,Jsd:Jed) ) ; CS%u_bdry_val(:,:) = 0.0 + allocate( CS%v_bdry_val(Isd:Ied,Jsd:Jed) ) ; CS%v_bdry_val(:,:) = 0.0 allocate( CS%t_bdry_val(isd:ied,jsd:jed) ) ; CS%t_bdry_val(:,:) = -15.0 allocate( CS%h_bdry_val(isd:ied,jsd:jed) ) ; CS%h_bdry_val(:,:) = 0.0 allocate( CS%thickness_bdry_val(isd:ied,jsd:jed) ) ; CS%thickness_bdry_val(:,:) = 0.0 - allocate( CS%u_face_mask(Isdq:Iedq,jsd:jed) ) ; CS%u_face_mask(:,:) = 0.0 - allocate( CS%v_face_mask(isd:ied,Jsdq:Jedq) ) ; CS%v_face_mask(:,:) = 0.0 + allocate( CS%u_face_mask(Isd:Ied,jsd:jed) ) ; CS%u_face_mask(:,:) = 0.0 + allocate( CS%v_face_mask(isd:ied,Jsd:Jed) ) ; CS%v_face_mask(:,:) = 0.0 allocate( CS%u_face_mask_bdry(Isdq:Iedq,jsd:jed) ) ; CS%u_face_mask_bdry(:,:) = -2.0 - allocate( CS%v_face_mask_bdry(isd:ied,Jsdq:Jedq) ) ; CS%v_face_mask_bdry(:,:) = -2.0 - allocate( CS%u_flux_bdry_val(Isdq:Iedq,jsd:jed) ) ; CS%u_flux_bdry_val(:,:) = 0.0 + allocate( CS%v_face_mask_bdry(isd:ied,Jsd:Jed) ) ; CS%v_face_mask_bdry(:,:) = -2.0 + allocate( CS%u_flux_bdry_val(Isd:Ied,jsd:jed) ) ; CS%u_flux_bdry_val(:,:) = 0.0 allocate( CS%v_flux_bdry_val(isd:ied,Jsdq:Jedq) ) ; CS%v_flux_bdry_val(:,:) = 0.0 - allocate( CS%umask(Isdq:Iedq,Jsdq:Jedq) ) ; CS%umask(:,:) = -1.0 - allocate( CS%vmask(Isdq:Iedq,Jsdq:Jedq) ) ; CS%vmask(:,:) = -1.0 + allocate( CS%umask(Isd:Ied,Jsd:Jed) ) ; CS%umask(:,:) = -1.0 + allocate( CS%vmask(Isd:Ied,Jsd:Jed) ) ; CS%vmask(:,:) = -1.0 allocate( CS%tmask(Isdq:Iedq,Jsdq:Jedq) ) ; CS%tmask(:,:) = -1.0 CS%OD_rt_counter = 0 @@ -481,7 +482,7 @@ subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_ ! viscosity is not calculated correctly. ! This has to occur after init_boundary_values or some of the arrays on the ! right hand side have not been set up yet. - if (.not. G%symmetric) then +! if (.not. G%symmetric) then do j=G%jsd,G%jed ; do i=G%isd,G%ied if (((i+G%idg_offset) == (G%domain%nihalo+1)).and.(CS%u_face_mask(I-1,j) == 3)) then CS%u_shelf(I-1,J-1) = CS%u_bdry_val(I-1,J-1) @@ -496,13 +497,16 @@ subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_ CS%v_shelf(I,J-1) = CS%v_bdry_val(I,J-1) endif enddo ; enddo - endif +! endif call pass_var(CS%OD_av,G%domain) call pass_var(CS%ground_frac,G%domain) call pass_var(CS%ice_visc,G%domain) call pass_var(CS%basal_traction, G%domain) - call pass_vector(CS%u_shelf, CS%v_shelf, G%domain, TO_ALL, BGRID_NE) +! call pass_vector(CS%u_shelf, CS%v_shelf, G%domain, TO_ALL, BGRID_NE) +! call pass_vector(CS%u_shelf, CS%v_shelf, G%domain)!, TO_ALL, CGRID_NE) + call pass_var(CS%u_shelf, G%domain) + call pass_var(CS%v_shelf, G%domain) endif if (active_shelf_dynamics) then @@ -530,22 +534,14 @@ subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_ enddo ; enddo call pass_var(CS%calve_mask,G%domain) endif -! call MOM_mesg(" MOM_ice_shelf.F90, initialize_ice_shelf: reading bed elevation") - -! call get_param(param_file, mdl, "INPUTDIR", inputdir, default=".") -! inputdir = slasher(inputdir) -! call get_param(param_file, mdl, "TOPO_FILE", IC_file, & -! "The file from which the bed topography is read.", & -! default="ice_shelf_h.nc") -! call get_param(param_file, mdl, "BED_TOPO_VARNAME", var_name, & -! "The variable to use for the bed topography.", & -! default="depth") -! call MOM_read_data(filename,trim(var_name),CS%bed_elev,G%Domain, scale=US%m_to_Z) - call initialize_ice_shelf_boundary_channel(CS%u_face_mask_bdry, CS%v_face_mask_bdry, & - CS%u_flux_bdry_val, CS%v_flux_bdry_val, CS%u_bdry_val, CS%v_bdry_val, CS%u_shelf, CS%v_shelf,& - CS%h_bdry_val, & - CS%thickness_bdry_val, ISS%hmask, ISS%h_shelf, G, & - US, param_file ) +! call initialize_ice_shelf_boundary_channel(CS%u_face_mask_bdry, CS%v_face_mask_bdry, & +! CS%u_flux_bdry_val, CS%v_flux_bdry_val, CS%u_bdry_val, CS%v_bdry_val, CS%u_shelf, CS%v_shelf,& +! CS%h_bdry_val, & +! CS%thickness_bdry_val, ISS%hmask, ISS%h_shelf, G, & +! US, param_file ) + call initialize_ice_shelf_boundary_from_file(CS%u_face_mask_bdry, CS%v_face_mask_bdry, & + CS%u_bdry_val, CS%v_bdry_val, CS%umask, CS%vmask, CS%h_bdry_val, & + CS%thickness_bdry_val, ISS%hmask, ISS%h_shelf, G, US, param_file ) call pass_var(ISS%hmask, G%domain) call pass_var(CS%h_bdry_val, G%domain) call pass_var(CS%thickness_bdry_val, G%domain) @@ -554,6 +550,8 @@ subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_ call pass_var(CS%u_face_mask_bdry, G%domain) call pass_var(CS%v_face_mask_bdry, G%domain) call pass_var(CS%bed_elev, G%domain) + call pass_var(CS%umask, G%domain) + call pass_var(CS%vmask, G%domain) !call init_boundary_values(CS, G, time, ISS%hmask, CS%input_flux, CS%input_thickness, new_sim) call initialize_ice_flow_from_file(CS%bed_elev,CS%u_shelf, CS%v_shelf,CS%ice_visc,CS%ground_frac, ISS%hmask,ISS%h_shelf, & G, US, param_file) !spacially variable viscosity from a file for debugging @@ -565,9 +563,13 @@ subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_ call update_velocity_masks(CS, G, ISS%hmask, CS%umask, CS%vmask, CS%u_face_mask, CS%v_face_mask) ! Register diagnostics. - CS%id_u_shelf = register_diag_field('ice_shelf_model','u_shelf',CS%diag%axesCu1, Time, & +! CS%id_u_shelf = register_diag_field('ice_shelf_model','u_shelf',CS%diag%axesCu1, Time, & +! 'x-velocity of ice', 'm yr-1', conversion=365.0*86400.0*US%L_T_to_m_s) +! CS%id_v_shelf = register_diag_field('ice_shelf_model','v_shelf',CS%diag%axesCv1, Time, & +! 'y-velocity of ice', 'm yr-1', conversion=365.0*86400.0*US%L_T_to_m_s) + CS%id_u_shelf = register_diag_field('ice_shelf_model','u_shelf',CS%diag%axesT1, Time, & 'x-velocity of ice', 'm yr-1', conversion=365.0*86400.0*US%L_T_to_m_s) - CS%id_v_shelf = register_diag_field('ice_shelf_model','v_shelf',CS%diag%axesCv1, Time, & + CS%id_v_shelf = register_diag_field('ice_shelf_model','v_shelf',CS%diag%axesT1, Time, & 'y-velocity of ice', 'm yr-1', conversion=365.0*86400.0*US%L_T_to_m_s) CS%id_taudx_shelf = register_diag_field('ice_shelf_model','taudx_shelf',CS%diag%axesT1, Time, & 'x-driving stress of ice', 'kPa', conversion=1.e-9*US%L_T_to_m_s) @@ -592,6 +594,10 @@ subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_ 'thickness after v flux ', 'none') CS%id_h_after_adv = register_diag_field('ice_shelf_model','h_after_adv',CS%diag%axesT1, Time, & 'thickness after front adv ', 'none') + CS%id_ufb_mask = register_diag_field('ice_shelf_model','u_fb_mask',CS%diag%axesCu1, Time, & + 'mask for u-nodes', 'none') + CS%id_vfb_mask = register_diag_field('ice_shelf_model','v_fb_mask',CS%diag%axesCv1, Time, & + 'mask for v-nodes', 'none') if (new_sim) then call MOM_mesg("MOM_ice_shelf.F90, initialize_ice_shelf: initialize ice velocity.") call update_OD_ffrac_uncoupled(CS, G, ISS%h_shelf(:,:)) @@ -731,9 +737,11 @@ subroutine update_ice_shelf(CS, ISS, G, US, time_step, Time, ocean_mass, coupled if (CS%id_OD_av >0) call post_data(CS%id_OD_av, CS%OD_av,CS%diag) if (CS%id_visc_shelf > 0) call post_data(CS%id_visc_shelf, CS%ice_visc,CS%diag) + if (CS%id_ufb_mask > 0) call post_data(CS%id_ufb_mask,CS%u_face_mask_bdry,CS%diag) + if (CS%id_vfb_mask > 0) call post_data(CS%id_vfb_mask,CS%v_face_mask_bdry,CS%diag) + if (CS%id_t_mask > 0) call post_data(CS%id_t_mask,CS%tmask,CS%diag) if (CS%id_u_mask > 0) call post_data(CS%id_u_mask,CS%umask,CS%diag) if (CS%id_v_mask > 0) call post_data(CS%id_v_mask,CS%vmask,CS%diag) - if (CS%id_t_mask > 0) call post_data(CS%id_t_mask,CS%tmask,CS%diag) call disable_averaging(CS%diag) @@ -764,8 +772,10 @@ subroutine ice_shelf_advect(CS, ISS, G, time_step, Time) ! into partial cells real, dimension(SZDI_(G),SZDJ_(G)) :: h_after_uflux, h_after_vflux ! Ice thicknesses [Z ~> m]. - real, dimension(SZDIB_(G),SZDJ_(G)) :: uh_ice ! The accumulated zonal ice volume flux [Z L2 ~> m3] - real, dimension(SZDI_(G),SZDJB_(G)) :: vh_ice ! The accumulated meridional ice volume flux [Z L2 ~> m3] +! real, dimension(SZDIB_(G),SZDJ_(G)) :: uh_ice ! The accumulated zonal ice volume flux [Z L2 ~> m3] +! real, dimension(SZDI_(G),SZDJB_(G)) :: vh_ice ! The accumulated meridional ice volume flux [Z L2 ~> m3] + real, dimension(SZDI_(G),SZDJ_(G)) :: uh_ice ! The accumulated zonal ice volume flux [Z L2 ~> m3] + real, dimension(SZDI_(G),SZDJ_(G)) :: vh_ice ! The accumulated meridional ice volume flux [Z L2 ~> m3] type(loop_bounds_type) :: LB integer :: isd, ied, jsd, jed, i, j, isc, iec, jsc, jec, stencil @@ -838,23 +848,34 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf,taudx,taudy, ite !! the ice-shelf state type(ocean_grid_type), intent(inout) :: G !< The grid structure used by the ice shelf. type(unit_scale_type), intent(in) :: US !< A structure containing unit conversion factors - real, dimension(SZDIB_(G),SZDJB_(G)), & +! real, dimension(SZDIB_(G),SZDJB_(G)), & + real, dimension(SZDI_(G),SZDJ_(G)), & intent(inout) :: u_shlf !< The zonal ice shelf velocity at vertices [L T-1 ~> m s-1] - real, dimension(SZDIB_(G),SZDJB_(G)), & +! real, dimension(SZDIB_(G),SZDJB_(G)), & + real, dimension(SZDI_(G),SZDJ_(G)), & intent(inout) :: v_shlf !< The meridional ice shelf velocity at vertices [L T-1 ~> m s-1] integer, intent(out) :: iters !< The number of iterations used in the solver. type(time_type), intent(in) :: Time !< The current model time - real, dimension(SZDIB_(G),SZDJB_(G)), & +! real, dimension(SZDIB_(G),SZDJB_(G)), & + real, dimension(SZDI_(G),SZDJ_(G)), & intent(out) :: taudx !< Driving x-stress at q-points [R L3 Z T-2 ~> kg m s-2] - real, dimension(SZDIB_(G),SZDJB_(G)), & +! real, dimension(SZDIB_(G),SZDJB_(G)), & + real, dimension(SZDI_(G),SZDJ_(G)), & intent(out) :: taudy !< Driving y-stress at q-points [R L3 Z T-2 ~> kg m s-2] - real, dimension(SZDIB_(G),SZDJB_(G)) :: u_bdry_cont ! Boundary u-stress contribution [R L3 Z T-2 ~> kg m s-2] - real, dimension(SZDIB_(G),SZDJB_(G)) :: v_bdry_cont ! Boundary v-stress contribution [R L3 Z T-2 ~> kg m s-2] - real, dimension(SZDIB_(G),SZDJB_(G)) :: Au, Av ! The retarding lateral stress contributions [R L3 Z T-2 ~> kg m s-2] - real, dimension(SZDIB_(G),SZDJB_(G)) :: err_u, err_v - real, dimension(SZDIB_(G),SZDJB_(G)) :: u_last, v_last ! Previous velocities [L T-1 ~> m s-1] - real, dimension(SZDIB_(G),SZDJB_(G)) :: H_node ! Ice shelf thickness at corners [Z ~> m]. +! real, dimension(SZDIB_(G),SZDJB_(G)) :: u_bdry_cont ! Boundary u-stress contribution [R L3 Z T-2 ~> kg m s-2] +! real, dimension(SZDIB_(G),SZDJB_(G)) :: v_bdry_cont ! Boundary v-stress contribution [R L3 Z T-2 ~> kg m s-2] +! real, dimension(SZDIB_(G),SZDJB_(G)) :: Au, Av ! The retarding lateral stress contributions [R L3 Z T-2 ~> kg m s-2] +! real, dimension(SZDIB_(G),SZDJB_(G)) :: err_u, err_v +! real, dimension(SZDIB_(G),SZDJB_(G)) :: u_last, v_last ! Previous velocities [L T-1 ~> m s-1] +! real, dimension(SZDIB_(G),SZDJB_(G)) :: H_node ! Ice shelf thick)), & +! intent(out) :: taudy !< Driving y-stress at q-points [R L3 Z T-2 ~> kg m s-2]ness at corners [Z ~> m]. + real, dimension(SZDI_(G),SZDJ_(G)) :: u_bdry_cont ! Boundary u-stress contribution [R L3 Z T-2 ~> kg m s-2] + real, dimension(SZDI_(G),SZDJ_(G)) :: v_bdry_cont ! Boundary v-stress contribution [R L3 Z T-2 ~> kg m s-2] + real, dimension(SZDI_(G),SZDJ_(G)) :: Au, Av ! The retarding lateral stress contributions [R L3 Z T-2 ~> kg m s-2] + real, dimension(SZDI_(G),SZDJ_(G)) :: err_u, err_v + real, dimension(SZDI_(G),SZDJ_(G)) :: u_last, v_last ! Previous velocities [L T-1 ~> m s-1] + real, dimension(SZDI_(G),SZDJ_(G)) :: H_node ! Ice shelf thick)), & real, dimension(SZDI_(G),SZDJ_(G)) :: float_cond ! An array indicating where the ice ! shelf is floating: 0 if floating, 1 if not. character(len=160) :: mesg ! The text of an error message @@ -872,7 +893,8 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf,taudx,taudy, ite ! for GL interpolation nsub = CS%n_sub_regularize - isdq = G%isdB ; iedq = G%iedB ; jsdq = G%jsdB ; jedq = G%jedB +! isdq = G%isdB ; iedq = G%iedB ; jsdq = G%jsdB ; jedq = G%jedB + isdq = G%isd ; iedq = G%ied ; jsd = G%jsd ; jed = G%jed isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed rhoi_rhow = CS%density_ice / CS%density_ocean_avg @@ -895,7 +917,9 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf,taudx,taudy, ite enddo call calc_shelf_driving_stress(CS, ISS, G, US, taudx, taudy, CS%OD_av) - call pass_vector(taudx, taudy, G%domain, TO_ALL, BGRID_NE) +! call pass_vector(taudx, taudy, G%domain, TO_ALL, BGRID_NE) +! call pass_var(taudx, G%domain) +! call pass_var(taudy, G%domain) ! This is to determine which cells contain the grounding line, the criterion being that the cell ! is ice-covered, with some nodes floating and some grounded flotation condition is estimated by ! assuming topography is cellwise constant and H is bilinear in a cell; floating where @@ -937,9 +961,10 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf,taudx,taudy, ite call calc_shelf_visc(CS, ISS, G, US, u_shlf, v_shlf) call pass_var(CS%ice_visc, G%domain) + call calc_shelf_taub(CS, ISS, G, US, u_shlf, v_shlf) call pass_var(CS%basal_traction, G%domain) - +! call pass_vector(CS%ice_visc, CS%basal_traction, G%domain, TO_ALL, CGRID_NE) ! This makes sure basal stress is only applied when it is supposed to be do j=G%jsd,G%jed ; do i=G%isd,G%ied CS%basal_traction(i,j) = CS%basal_traction(i,j) * CS%ground_frac(i,j) @@ -953,7 +978,9 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf,taudx,taudy, ite call CG_action(Au, Av, u_shlf, v_shlf, Phi, Phisub, CS%umask, CS%vmask, ISS%hmask, H_node, & CS%ice_visc, float_cond, G%bathyT, CS%basal_traction, & G, US, G%isc-1, G%iec+1, G%jsc-1, G%jec+1, rhoi_rhow) - call pass_vector(Au,Av,G%domain) +! call pass_vector(Au,Av,G%domain) + call pass_var(Au,G%domain) + call pass_var(Av,G%domain) if (CS%nonlin_solve_err_mode == 1) then err_init = 0 ; err_tempu = 0 ; err_tempv = 0 do J=G%IscB,G%JecB ; do I=G%IscB,G%IecB @@ -1012,7 +1039,8 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf,taudx,taudy, ite if (CS%nonlin_solve_err_mode == 1) then - do J=G%jscB,G%jecB ; do I=G%jscB,G%iecB +! do J=G%jscB,G%jecB ; do I=G%jscB,G%iecB + do J=G%jsc,G%jec ; do I=G%jsc,G%iec if (CS%umask(I,J) == 1) then err_tempu = ABS(Au(I,J) + u_bdry_cont(I,J) - taudx(I,J)) if (err_tempu >= err_max) err_max = err_tempu @@ -1028,7 +1056,8 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf,taudx,taudy, ite elseif (CS%nonlin_solve_err_mode == 2) then max_vel = 0 ; tempu = 0 ; tempv = 0 - do J=G%jscB,G%jecB ; do I=G%iscB,G%iecB +! do J=G%jscB,G%jecB ; do I=G%iscB,G%iecB + do J=G%jsc,G%jec ; do I=G%isc,G%iec if (CS%umask(I,J) == 1) then err_tempu = ABS(u_last(I,J)-u_shlf(I,J)) if (err_tempu >= err_max) err_max = err_tempu @@ -1078,17 +1107,27 @@ subroutine ice_shelf_solve_inner(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, H !! the ice-shelf state type(ocean_grid_type), intent(inout) :: G !< The grid structure used by the ice shelf. type(unit_scale_type), intent(in) :: US !< A structure containing unit conversion factors - real, dimension(SZDIB_(G),SZDJB_(G)), & +! real, dimension(SZDIB_(G),SZDJB_(G)), & +! intent(inout) :: u_shlf !< The zonal ice shelf velocity at vertices [L T-1 ~> m s-1] +! real, dimension(SZDIB_(G),SZDJB_(G)), & +! intent(inout) :: v_shlf !< The meridional ice shelf velocity at vertices [L T-1 ~> m s-1] +! real, dimension(SZDIB_(G),SZDJB_(G)), & +! intent(in) :: taudx !< The x-direction driving stress [R L3 Z T-2 ~> kg m s-2] +! real, dimension(SZDIB_(G),SZDJB_(G)), & +! intent(in) :: taudy !< The y-direction driving stress [R L3 Z T-2 ~> kg m s-2] +! real, dimension(SZDIB_(G),SZDJB_(G)), & +! intent(in) :: H_node !< The ice shelf thickness at nodal (corner) + real, dimension(SZDI_(G),SZDJ_(G)), & intent(inout) :: u_shlf !< The zonal ice shelf velocity at vertices [L T-1 ~> m s-1] - real, dimension(SZDIB_(G),SZDJB_(G)), & + real, dimension(SZDI_(G),SZDJ_(G)), & intent(inout) :: v_shlf !< The meridional ice shelf velocity at vertices [L T-1 ~> m s-1] - real, dimension(SZDIB_(G),SZDJB_(G)), & + real, dimension(SZDI_(G),SZDJ_(G)), & intent(in) :: taudx !< The x-direction driving stress [R L3 Z T-2 ~> kg m s-2] - real, dimension(SZDIB_(G),SZDJB_(G)), & + real, dimension(SZDI_(G),SZDJ_(G)), & intent(in) :: taudy !< The y-direction driving stress [R L3 Z T-2 ~> kg m s-2] - real, dimension(SZDIB_(G),SZDJB_(G)), & + real, dimension(SZDI_(G),SZDJ_(G)), & intent(in) :: H_node !< The ice shelf thickness at nodal (corner) - !! points [Z ~> m]. + !! points [Z ~> m]. !! points [Z ~> m]. real, dimension(SZDI_(G),SZDJ_(G)), & intent(in) :: float_cond !< An array indicating where the ice !! shelf is floating: 0 if floating, 1 if not. @@ -1114,7 +1153,8 @@ subroutine ice_shelf_solve_inner(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, H ! assumed - u, v, taud, visc, basal_traction are valid on the halo - real, dimension(SZDIB_(G),SZDJB_(G)) :: & +! real, dimension(SZDIB_(G),SZDJB_(G)) :: & + real, dimension(SZDI_(G),SZDJ_(G)) :: & Ru, Rv, & ! Residuals in the stress calculations [R L3 Z T-2 ~> m kg s-2] Ru_old, Rv_old, & ! Previous values of Ru and Rv [R L3 Z T-2 ~> m kg s-2] Zu, Zv, & ! Contributions to velocity changes [L T-1 ~> m s-1] @@ -1137,8 +1177,10 @@ subroutine ice_shelf_solve_inner(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, H integer :: Is_sum, Js_sum, Ie_sum, Je_sum ! Loop bounds for global sums or arrays starting at 1. integer :: isdq, iedq, jsdq, jedq, iscq, iecq, jscq, jecq, nx_halo, ny_halo - isdq = G%isdB ; iedq = G%iedB ; jsdq = G%jsdB ; jedq = G%jedB - iscq = G%iscB ; iecq = G%iecB ; jscq = G%jscB ; jecq = G%jecB +! isdq = G%isdB ; iedq = G%iedB ; jsdq = G%jsdB ; jedq = G%jedB +! iscq = G%iscB ; iecq = G%iecB ; jscq = G%jscB ; jecq = G%jecB + isdq = G%isd ; iedq = G%ied ; jsdq = G%jsd ; jedq = G%jed + iscq = G%isc ; iecq = G%iec ; jscq = G%jsc ; jecq = G%jec ny_halo = G%domain%njhalo ; nx_halo = G%domain%nihalo isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed isc = G%isc ; iec = G%iec ; jsc = G%jsc ; jec = G%jec @@ -1151,35 +1193,50 @@ subroutine ice_shelf_solve_inner(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, H dot_p1 = 0 ! Determine the loop limits for sums, bearing in mind that the arrays will be starting at 1. - Is_sum = G%isc + (1-G%IsdB) - Ie_sum = G%iecB + (1-G%IsdB) - ! Include the edge if tile is at the western bdry; Should add a test to avoid this if reentrant. - if (G%isc+G%idg_offset==G%isg) Is_sum = G%IscB + (1-G%IsdB) - - Js_sum = G%jsc + (1-G%JsdB) - Je_sum = G%jecB + (1-G%JsdB) +! Is_sum = G%isc + (1-G%IsdB) +! Ie_sum = G%iecB + (1-G%IsdB) + Is_sum = G%isc + (1-G%Isd) + Ie_sum = G%iec + (1-G%Isd) + ! Include the edge if tile is at the western bdry; Should add a test to avoid this if reentrant. +! if (G%isc+G%idg_offset==G%isg) Is_sum = G%IscB + (1-G%IsdB) + if (G%isc+G%idg_offset==G%isg) Is_sum = G%Isc + (1-G%Isd) +! Js_sum = G%jsc + (1-G%JsdB) +! Je_sum = G%jecB + (1-G%JsdB) + Js_sum = G%jsc + (1-G%Jsd) + Je_sum = G%jec + (1-G%Jsd) ! Include the edge if tile is at the southern bdry; Should add a test to avoid this if reentrant. - if (G%jsc+G%jdg_offset==G%jsg) Js_sum = G%JscB + (1-G%JsdB) - +! if (G%jsc+G%jdg_offset==G%jsg) Js_sum = G%JscB + (1-G%JsdB) + if (G%jsc+G%jdg_offset==G%jsg) Js_sum = G%Jsc + (1-G%Jsd) call apply_boundary_values(CS, ISS, G, US, time, Phisub, H_node, CS%ice_visc, & CS%basal_traction, float_cond, rhoi_rhow, ubd, vbd) RHSu(:,:) = taudx(:,:) - ubd(:,:) RHSv(:,:) = taudy(:,:) - vbd(:,:) - call pass_vector(RHSu, RHSv, G%domain, TO_ALL, BGRID_NE) +! call pass_vector(RHSu, RHSv, G%domain, TO_ALL, BGRID_NE) +! call pass_vector(RHSu, RHSv, G%domain, TO_ALL, CGRID_NE) +! call pass_vector(RHSu, RHSv, G%domain) + call pass_var(RHSu,G%domain) + call pass_var(RHSv, G%domain) call matrix_diagonal(CS, G, US, float_cond, H_node, CS%ice_visc, CS%basal_traction, & hmask, rhoi_rhow, Phisub, DIAGu, DIAGv) - call pass_vector(DIAGu, DIAGv, G%domain, TO_ALL, BGRID_NE) +! call pass_vector(DIAGu, DIAGv, G%domain, TO_ALL, BGRID_NE) +! call pass_vector(DIAGu, DIAGv, G%domain, TO_ALL, CGRID_NE) +! call pass_vector(DIAGu, DIAGv, G%domain) + call pass_var(DIAGu, G%domain) + call pass_var(DIAGv, G%domain) call CG_action(Au, Av, u_shlf, v_shlf, Phi, Phisub, CS%umask, CS%vmask, hmask, & H_node, CS%ice_visc, float_cond, G%bathyT, CS%basal_traction, & G, US, isc-1, iec+1, jsc-1, jec+1, rhoi_rhow) - call pass_vector(Au, Av, G%domain, TO_ALL, BGRID_NE) - +! call pass_vector(Au, Av, G%domain, TO_ALL, BGRID_NE) +! call pass_vector(Au, Av, G%domain, TO_ALL, CGRID_NE) +! call pass_vector(Au, Av, G%domain) + call pass_var(Au, G%domain) + call pass_var(Av, G%domain) Ru(:,:) = (RHSu(:,:) - Au(:,:)) Rv(:,:) = (RHSv(:,:) - Av(:,:)) @@ -1234,7 +1291,11 @@ subroutine ice_shelf_solve_inner(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, H ! Au, Av valid region moves in by 1 - call pass_vector(Au,Av,G%domain, TO_ALL, BGRID_NE) +! call pass_vector(Au,Av,G%domain, TO_ALL, BGRID_NE) +! call pass_vector(Au,Av,G%domain, TO_ALL, CGRID_NE) +! call pass_vector(Au,Av,G%domain) + call pass_var(Au,G%domain) + call pass_var(Av,G%domain) sum_vec(:,:) = 0.0 ; sum_vec_2(:,:) = 0.0 do j=jscq,jecq ; do i=iscq,iecq @@ -1337,11 +1398,21 @@ subroutine ice_shelf_solve_inner(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, H if (cg_halo == 0) then ! pass vectors - call pass_vector(Du, Dv, G%domain, TO_ALL, BGRID_NE) - call pass_vector(u_shlf, v_shlf, G%domain, TO_ALL, BGRID_NE) +! call pass_vector(Du, Dv, G%domain, TO_ALL, CGRID_NE) +! call pass_vector(u_shlf, v_shlf, G%domain, TO_ALL, CGRID_NE) +! call pass_vector(Du, Dv, G%domain, TO_ALL, BGRID_NE) +! call pass_vector(u_shlf, v_shlf, G%domain, TO_ALL, BGRID_NE) +! call pass_vector(Du, Dv, G%domain) + call pass_var(Du, G%domain) + call pass_var(Dv, G%domain) +! call pass_vector(u_shlf, v_shlf, G%domain) call pass_var(u_shlf, G%domain) call pass_var(v_shlf, G%domain) - call pass_vector(Ru, Rv, G%domain, TO_ALL, BGRID_NE) +! call pass_vector(Ru, Rv, G%domain, TO_ALL, BGRID_NE) +! call pass_vector(Ru, Rv, G%domain, TO_ALL, CGRID_NE) +! call pass_vector(Ru, Rv, G%domain) + call pass_var(Ru, G%domain) + call pass_var(Rv, G%domain) cg_halo = 3 endif @@ -1363,8 +1434,11 @@ subroutine ice_shelf_solve_inner(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, H enddo enddo - call pass_vector(u_shlf, v_shlf, G%domain, TO_ALL, BGRID_NE) - +! call pass_vector(u_shlf, v_shlf, G%domain, TO_ALL, CGRID_NE) +! call pass_vector(u_shlf, v_shlf, G%domain, TO_ALL, BGRID_NE) +! call pass_vector(u_shlf, v_shlf, G%domain, TO_ALL) + call pass_var(u_shlf, G%domain) + call pass_var(v_shlf, G%domain) if (conv_flag == 0) then iters = CS%cg_max_iterations endif @@ -1384,7 +1458,8 @@ subroutine ice_shelf_advect_thickness_x(CS, G, LB, time_step, hmask, h0, h_after real, dimension(SZDI_(G),SZDJ_(G)), & intent(inout) :: h_after_uflux !< The ice shelf thicknesses after !! the zonal mass fluxes [Z ~> m]. - real, dimension(SZDIB_(G),SZDJ_(G)), & +! real, dimension(SZDIB_(G),SZDJ_(G)), & + real, dimension(SZDI_(G),SZDJ_(G)), & intent(inout) :: uh_ice !< The accumulated zonal ice volume flux [Z L2 ~> m3] ! use will be made of ISS%hmask here - its value at the boundary will be zero, just like uncovered cells @@ -1467,7 +1542,9 @@ subroutine ice_shelf_advect_thickness_y(CS, G, LB, time_step, hmask, h0, h_after real, dimension(SZDI_(G),SZDJ_(G)), & intent(inout) :: h_after_vflux !< The ice shelf thicknesses after !! the meridional mass fluxes [Z ~> m]. - real, dimension(SZDI_(G),SZDJB_(G)), & +! real, dimension(SZDI_(G),SZDJB_(G)), & +! intent(inout) :: vh_ice !< The accumulated meridional ice volume flux [Z L2 ~> m3] + real, dimension(SZDI_(G),SZDJ_(G)), & intent(inout) :: vh_ice !< The accumulated meridional ice volume flux [Z L2 ~> m3] ! use will be made of ISS%hmask here - its value at the boundary will be zero, just like uncovered cells @@ -1542,11 +1619,14 @@ subroutine shelf_advance_front(CS, ISS, G, hmask, uh_ice, vh_ice) real, dimension(SZDI_(G),SZDJ_(G)), & intent(inout) :: hmask !< A mask indicating which tracer points are !! partly or fully covered by an ice-shelf - real, dimension(SZDIB_(G),SZDJ_(G)), & +! real, dimension(SZDIB_(G),SZDJ_(G)), & +! intent(inout) :: uh_ice !< The accumulated zonal ice volume flux [Z L2 ~> m3] +! real, dimension(SZDI_(G),SZDJB_(G)), & +! intent(inout) :: vh_ice !< The accumulated meridional ice volume flux [Z L2 ~> m3] + real, dimension(SZDI_(G),SZDJ_(G)), & intent(inout) :: uh_ice !< The accumulated zonal ice volume flux [Z L2 ~> m3] - real, dimension(SZDI_(G),SZDJB_(G)), & + real, dimension(SZDI_(G),SZDJ_(G)), & intent(inout) :: vh_ice !< The accumulated meridional ice volume flux [Z L2 ~> m3] - ! in this subroutine we go through the computational cells only and, if they are empty or partial cells, ! we find the reference thickness and update the shelf mass and partial area fraction and the hmask if necessary @@ -1786,9 +1866,11 @@ subroutine calc_shelf_driving_stress(CS, ISS, G, US, taudx, taudy, OD) type(unit_scale_type), intent(in) :: US !< A structure containing unit conversion factors real, dimension(SZDI_(G),SZDJ_(G)), & intent(in) :: OD !< ocean floor depth at tracer points [Z ~> m]. - real, dimension(SZDIB_(G),SZDJB_(G)), & +! real, dimension(SZDIB_(G),SZDJB_(G)), & + real, dimension(SZDI_(G),SZDJ_(G)), & intent(inout) :: taudx !< X-direction driving stress at q-points [kg L s-2 ~> kg m s-2] - real, dimension(SZDIB_(G),SZDJB_(G)), & +! real, dimension(SZDIB_(G),SZDJB_(G)), & + real, dimension(SZDI_(G),SZDJ_(G)), & intent(inout) :: taudy !< Y-direction driving stress at q-points [kg L s-2 ~> kg m s-2] ! This will become [R L3 Z T-2 ~> kg m s-2] @@ -1818,9 +1900,11 @@ subroutine calc_shelf_driving_stress(CS, ISS, G, US, taudx, taudy, OD) integer :: i_off, j_off isc = G%isc ; jsc = G%jsc ; iec = G%iec ; jec = G%jec - iscq = G%iscB ; iecq = G%iecB ; jscq = G%jscB ; jecq = G%jecB +! iscq = G%iscB ; iecq = G%iecB ; jscq = G%jscB ; jecq = G%jecB + iscq = G%isc ; iecq = G%iec ; jscq = G%jsc ; jecq = G%jec isd = G%isd ; jsd = G%jsd - iegq = G%iegB ; jegq = G%jegB +! iegq = G%iegB ; jegq = G%jegB + iegq = G%ieg ; jegq = G%jeg ! gisc = G%domain%nihalo+1 ; gjsc = G%domain%njhalo+1 gisc = 1 ; gjsc = 1 ! giec = G%domain%niglobal+G%domain%nihalo ; gjec = G%domain%njglobal+G%domain%njhalo @@ -2042,7 +2126,7 @@ subroutine init_boundary_values(CS, G, time, hmask, input_flux, input_thick, new endif if (.not.(new_sim)) then - if (.not. G%symmetric) then +! if (.not. G%symmetric) then if (((i+i_off) == (G%domain%nihalo+1)).and.(CS%u_face_mask(I-1,j) == 3)) then CS%u_shelf(I-1,J-1) = CS%u_bdry_val(I-1,J-1) CS%u_shelf(I-1,J) = CS%u_bdry_val(I-1,J) @@ -2055,7 +2139,7 @@ subroutine init_boundary_values(CS, G, time, hmask, input_flux, input_thick, new CS%v_shelf(I-1,J-1) = CS%v_bdry_val(I-1,J-1) CS%v_shelf(I,J-1) = CS%v_bdry_val(I,J-1) endif - endif + ! endif endif enddo enddo @@ -2067,9 +2151,13 @@ subroutine CG_action(uret, vret, u_shlf, v_shlf, Phi, Phisub, umask, vmask, hmas ice_visc, float_cond, bathyT, basal_trac, G, US, is, ie, js, je, dens_ratio) type(ocean_grid_type), intent(in) :: G !< The grid structure used by the ice shelf. - real, dimension(G%IsdB:G%IedB,G%JsdB:G%JedB), & +! real, dimension(G%IsdB:G%IedB,G%JsdB:G%JedB), & +! intent(inout) :: uret !< The retarding stresses working at u-points [R L3 Z T-2 ~> kg m s-2]. +! real, dimension(G%IsdB:G%IedB,G%JsdB:G%JedB), & +! intent(inout) :: vret !< The retarding stresses working at v-points [R L3 Z T-2 ~> kg m s-2]. + real, dimension(SZDI_(G),SZDJ_(G)), & intent(inout) :: uret !< The retarding stresses working at u-points [R L3 Z T-2 ~> kg m s-2]. - real, dimension(G%IsdB:G%IedB,G%JsdB:G%JedB), & + real, dimension(SZDI_(G),SZDJ_(G)), & intent(inout) :: vret !< The retarding stresses working at v-points [R L3 Z T-2 ~> kg m s-2]. real, dimension(8,4,SZDI_(G),SZDJ_(G)), & intent(in) :: Phi !< The gradients of bilinear basis elements at Gaussian @@ -2077,23 +2165,36 @@ subroutine CG_action(uret, vret, u_shlf, v_shlf, Phi, Phisub, umask, vmask, hmas real, dimension(:,:,:,:,:,:), & intent(in) :: Phisub !< Quadrature structure weights at subgridscale !! locations for finite element calculations [nondim] - real, dimension(SZDIB_(G),SZDJB_(G)), & +! real, dimension(SZDIB_(G),SZDJB_(G)), & +! intent(in) :: u_shlf !< The zonal ice shelf velocity at vertices [L T-1 ~> m s-1] +! real, dimension(SZDIB_(G),SZDJB_(G)), & +! intent(in) :: v_shlf !< The meridional ice shelf velocity at vertices [L T-1 ~> m s-1] +! real, dimension(SZDIB_(G),SZDJB_(G)), & +! intent(in) :: umask !< A coded mask indicating the nature of the + !! zonal flow at the corner point +! real, dimension(SZDIB_(G),SZDJB_(G)), & +! intent(in) :: vmask !< A coded mask indicating the nature of the + !! meridional flow at the corner point +! real, dimension(SZDIB_(G),SZDJB_(G)), & +! intent(in) :: H_node !< The ice shelf thickness at nodal (corner) + !! points [Z ~> m]. + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(in) :: hmask !< A mask indicating which tracer points are + real, dimension(SZDI_(G),SZDJ_(G)), & intent(in) :: u_shlf !< The zonal ice shelf velocity at vertices [L T-1 ~> m s-1] - real, dimension(SZDIB_(G),SZDJB_(G)), & + real, dimension(SZDI_(G),SZDJ_(G)), & intent(in) :: v_shlf !< The meridional ice shelf velocity at vertices [L T-1 ~> m s-1] - real, dimension(SZDIB_(G),SZDJB_(G)), & + real, dimension(SZDI_(G),SZDJ_(G)), & intent(in) :: umask !< A coded mask indicating the nature of the !! zonal flow at the corner point - real, dimension(SZDIB_(G),SZDJB_(G)), & + real, dimension(SZDI_(G),SZDJ_(G)), & intent(in) :: vmask !< A coded mask indicating the nature of the !! meridional flow at the corner point - real, dimension(SZDIB_(G),SZDJB_(G)), & + real, dimension(SZDI_(G),SZDJ_(G)), & intent(in) :: H_node !< The ice shelf thickness at nodal (corner) - !! points [Z ~> m]. + !! points [Z ~> m]. !! partly or fully covered by an ice-shelf +! real, dimension(SZDIB_(G),SZDJB_(G)), & real, dimension(SZDI_(G),SZDJ_(G)), & - intent(in) :: hmask !< A mask indicating which tracer points are - !! partly or fully covered by an ice-shelf - real, dimension(SZDIB_(G),SZDJB_(G)), & intent(in) :: ice_visc !< A field related to the ice viscosity from Glen's !! flow law [R L4 Z T-1 ~> kg m2 s-1]. The exact form !! and units depend on the basal law exponent. @@ -2102,7 +2203,8 @@ subroutine CG_action(uret, vret, u_shlf, v_shlf, Phi, Phisub, umask, vmask, hmas !! shelf is floating: 0 if floating, 1 if not. real, dimension(SZDI_(G),SZDJ_(G)), & intent(in) :: bathyT !< The depth of ocean bathymetry at tracer points [Z ~> m]. - real, dimension(SZDIB_(G),SZDJB_(G)), & + !real, dimension(SZDIB_(G),SZDJB_(G)), & + real, dimension(SZDI_(G),SZDJ_(G)), & intent(in) :: basal_trac !< A field related to the nonlinear part of the !! "linearized" basal stress [R Z T-1 ~> kg m-2 s-1]. ! and/or whether flow is "hybridized" @@ -2264,15 +2366,18 @@ subroutine matrix_diagonal(CS, G, US, float_cond, H_node, ice_visc, basal_trac, real, dimension(SZDI_(G),SZDJ_(G)), & intent(in) :: float_cond !< An array indicating where the ice !! shelf is floating: 0 if floating, 1 if not. - real, dimension(SZDIB_(G),SZDJB_(G)), & +! real, dimension(SZDIB_(G),SZDJB_(G)), & + real, dimension(SZDI_(G),SZDJ_(G)), & intent(in) :: H_node !< The ice shelf thickness at nodal !! (corner) points [Z ~> m]. - real, dimension(SZDIB_(G),SZDJB_(G)), & +! real, dimension(SZDIB_(G),SZDJB_(G)), & + real, dimension(SZDI_(G),SZDJ_(G)), & intent(in) :: ice_visc !< A field related to the ice viscosity from Glen's !! flow law [R L4 Z T-1 ~> kg m2 s-1]. The exact form !! and units depend on the basal law exponent. - real, dimension(SZDIB_(G),SZDJB_(G)), & - intent(in) :: basal_trac !< A field related to the nonlinear part of the + !real, dimension(SZDIB_(G),SZDJB_(G)), & + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(in) :: basal_trac !< A field related to the nonlinear part of the !! "linearized" basal stress [R Z T-1 ~> kg m-2 s-1]. real, dimension(SZDI_(G),SZDJ_(G)), & intent(in) :: hmask !< A mask indicating which tracer points are @@ -2281,14 +2386,19 @@ subroutine matrix_diagonal(CS, G, US, float_cond, H_node, ice_visc, basal_trac, !! of seawater [nondim] real, dimension(:,:,:,:,:,:), intent(in) :: Phisub !< Quadrature structure weights at subgridscale !! locations for finite element calculations [nondim] - real, dimension(SZDIB_(G),SZDJB_(G)), & +! real, dimension(SZDIB_(G),SZDJB_(G)), & +! intent(inout) :: u_diagonal !< The diagonal elements of the u-velocity + !! matrix from the left-hand side of the solver [R L2 Z T-1 ~> kg s-1] +! real, dimension(SZDIB_(G),SZDJB_(G)), & +! intent(inout) :: v_diagonal !< The diagonal elements of the v-velocity + !! matrix from the left-hand side of the solver [R L2 Z T-1 ~> kg s-1] + real, dimension(SZDI_(G),SZDJ_(G)), & intent(inout) :: u_diagonal !< The diagonal elements of the u-velocity !! matrix from the left-hand side of the solver [R L2 Z T-1 ~> kg s-1] - real, dimension(SZDIB_(G),SZDJB_(G)), & + real, dimension(SZDI_(G),SZDJ_(G)), & intent(inout) :: v_diagonal !< The diagonal elements of the v-velocity !! matrix from the left-hand side of the solver [R L2 Z T-1 ~> kg s-1] - ! returns the diagonal entries of the matrix for a Jacobi preconditioning real :: ux, uy, vx, vy ! Interpolated weight gradients [L-1 ~> m-1] @@ -2322,7 +2432,7 @@ subroutine matrix_diagonal(CS, G, US, float_cond, H_node, ice_visc, basal_trac, u_diagonal(Itgt,Jtgt) = u_diagonal(Itgt,Jtgt) + & 0.25 * ice_visc(i,j) * ((4*ux+2*vy) * Phi(2*(2*(jphi-1)+iphi)-1,2*(jq-1)+iq) + & - (uy+vy) * Phi(2*(2*(jphi-1)+iphi),2*(jq-1)+iq)) + (uy+vx) * Phi(2*(2*(jphi-1)+iphi),2*(jq-1)+iq)) if (float_cond(i,j) == 0) then uq = xquad(ilq) * xquad(jlq) @@ -2412,14 +2522,21 @@ subroutine apply_boundary_values(CS, ISS, G, US, time, Phisub, H_node, ice_visc, real, dimension(:,:,:,:,:,:), & intent(in) :: Phisub !< Quadrature structure weights at subgridscale !! locations for finite element calculations [nondim] - real, dimension(SZDIB_(G),SZDJB_(G)), & +! real, dimension(SZDIB_(G),SZDJB_(G)), & +! intent(in) :: H_node !< The ice shelf thickness at nodal +! !! (corner) points [Z ~> m]. + real, dimension(SZDI_(G),SZDJ_(G)), & intent(in) :: H_node !< The ice shelf thickness at nodal !! (corner) points [Z ~> m]. - real, dimension(SZDIB_(G),SZDJB_(G)), & +! real, dimension(SZDIB_(G),SZDJB_(G)), & + real, dimension(SZDI_(G),SZDJ_(G)), & intent(in) :: ice_visc !< A field related to the ice viscosity from Glen's !! flow law. The exact form and units depend on the !! basal law exponent. [R L4 Z T-1 ~> kg m2 s-1]. - real, dimension(SZDIB_(G),SZDJB_(G)), & +! real, dimension(SZDIB_(G),SZDJB_(G)), & +! intent(in) :: basal_trac !< A field related to the nonlinear part of the +! !! "linearized" basal stress [R Z T-1 ~> kg m-2 s-1]. + real, dimension(SZDI_(G),SZDJ_(G)), & intent(in) :: basal_trac !< A field related to the nonlinear part of the !! "linearized" basal stress [R Z T-1 ~> kg m-2 s-1]. real, dimension(SZDI_(G),SZDJ_(G)), & @@ -2427,13 +2544,18 @@ subroutine apply_boundary_values(CS, ISS, G, US, time, Phisub, H_node, ice_visc, !! shelf is floating: 0 if floating, 1 if not. real, intent(in) :: dens_ratio !< The density of ice divided by the density !! of seawater, nondimensional - real, dimension(SZDIB_(G),SZDJB_(G)), & +! real, dimension(SZDIB_(G),SZDJB_(G)), & +! intent(inout) :: u_bdry_contr !< Zonal force contributions due to the + !! open boundaries [R L3 Z T-2 ~> kg m s-2] +! real, dimension(SZDIB_(G),SZDJB_(G)), & +! intent(inout) :: v_bdry_contr !< Meridional force contributions due to the +! !! open boundaries [R L3 Z T-2 ~> kg m s-2] + real, dimension(SZDI_(G),SZDJ_(G)), & intent(inout) :: u_bdry_contr !< Zonal force contributions due to the !! open boundaries [R L3 Z T-2 ~> kg m s-2] - real, dimension(SZDIB_(G),SZDJB_(G)), & + real, dimension(SZDI_(G),SZDJ_(G)), & intent(inout) :: v_bdry_contr !< Meridional force contributions due to the !! open boundaries [R L3 Z T-2 ~> kg m s-2] - ! this will be a per-setup function. the boundary values of thickness and velocity ! (and possibly other variables) will be updated in this function @@ -2541,8 +2663,11 @@ subroutine apply_boundary_values(CS, ISS, G, US, time, Phisub, H_node, ice_visc, endif endif ; enddo ; enddo - call pass_vector(u_bdry_contr, v_bdry_contr, G%domain, TO_ALL, BGRID_NE) - +! call pass_vector(u_bdry_contr, v_bdry_contr, G%domain, TO_ALL, CGRID_NE) +! call pass_vector(u_bdry_contr, v_bdry_contr, G%domain, TO_ALL, BGRID_NE) +! call pass_vector(u_bdry_contr, v_bdry_contr, G%domain, TO_ALL) + call pass_var(u_bdry_contr, G%domain) + call pass_var(v_bdry_contr, G%domain) end subroutine apply_boundary_values !> Update depth integrated viscosity, based on horizontal strain rates, and also update the @@ -2553,9 +2678,13 @@ subroutine calc_shelf_visc(CS, ISS, G, US, u_shlf, v_shlf) !! the ice-shelf state type(ocean_grid_type), intent(in) :: G !< The grid structure used by the ice shelf. type(unit_scale_type), intent(in) :: US !< A structure containing unit conversion factors - real, dimension(G%IsdB:G%IedB,G%JsdB:G%JedB), & +! real, dimension(G%IsdB:G%IedB,G%JsdB:G%JedB), & +! intent(inout) :: u_shlf !< The zonal ice shelf velocity [L T-1 ~> m s-1]. +! real, dimension(G%IsdB:G%IedB,G%JsdB:G%JedB), & +! intent(inout) :: v_shlf !< The meridional ice shelf velocity [L T-1 ~> m s-1]. + real, dimension(G%Isd:G%Ied,G%Jsd:G%Jed), & intent(inout) :: u_shlf !< The zonal ice shelf velocity [L T-1 ~> m s-1]. - real, dimension(G%IsdB:G%IedB,G%JsdB:G%JedB), & + real, dimension(G%Isd:G%Ied,G%Jsd:G%Jed), & intent(inout) :: v_shlf !< The meridional ice shelf velocity [L T-1 ~> m s-1]. ! update DEPTH_INTEGRATED viscosity, based on horizontal strain rates - this is for bilinear FEM solve @@ -2575,9 +2704,11 @@ subroutine calc_shelf_visc(CS, ISS, G, US, u_shlf, v_shlf) ! real :: umid, vmid, unorm ! Velocities [L T-1 ~> m s-1] isc = G%isc ; jsc = G%jsc ; iec = G%iec ; jec = G%jec - iscq = G%iscB ; iecq = G%iecB ; jscq = G%jscB ; jecq = G%jecB +! iscq = G%iscB ; iecq = G%iecB ; jscq = G%jscB ; jecq = G%jecB + iscq = G%isc ; iecq = G%iec ; jscq = G%jsc ; jecq = G%jec isd = G%isd ; jsd = G%jsd ; ied = G%ied ; jed = G%jed - iegq = G%iegB ; jegq = G%jegB +! iegq = G%iegB ; jegq = G%jegB + iegq = G%ieg ; jegq = G%jeg gisc = G%domain%nihalo+1 ; gjsc = G%domain%njhalo+1 giec = G%domain%niglobal+gisc ; gjec = G%domain%njglobal+gjsc is = iscq - 1; js = jscq - 1 @@ -2598,6 +2729,7 @@ subroutine calc_shelf_visc(CS, ISS, G, US, u_shlf, v_shlf) (u_shlf(I,J-1) + (u_shlf(I-1,J-1) + u_shlf(I+1,J-1)))) / (3*G%dyT(i,j)) vy = ((v_shlf(I,J) + (v_shlf(I-1,J)+ v_shlf(I+1,J))) - & (v_shlf(I,J-1) + (v_shlf(I-1,J-1)+ v_shlf(I+1,J-1)))) / (3*G%dyT(i,j)) +! CS%ice_visc(i,j) =1e14*(G%areaT(i,j) * ISS%h_shelf(i,j)) ! constant viscocity for debugging CS%ice_visc(i,j) = 0.5 * Visc_coef * (G%areaT(i,j) * ISS%h_shelf(i,j)) * & (US%s_to_T**2 * (ux**2 + vy**2 + ux*vy + 0.25*(uy+vx)**2 + eps_min**2))**((1.-n_g)/(2.*n_g)) endif @@ -2612,9 +2744,13 @@ subroutine calc_shelf_taub(CS, ISS, G, US, u_shlf, v_shlf) !! the ice-shelf state type(ocean_grid_type), intent(in) :: G !< The grid structure used by the ice shelf. type(unit_scale_type), intent(in) :: US !< A structure containing unit conversion factors - real, dimension(G%IsdB:G%IedB,G%JsdB:G%JedB), & +! real, dimension(G%IsdB:G%IedB,G%JsdB:G%JedB), & +! intent(inout) :: u_shlf !< The zonal ice shelf velocity [L T-1 ~> m s-1]. +! real, dimension(G%IsdB:G%IedB,G%JsdB:G%JedB), & +! intent(inout) :: v_shlf !< The meridional ice shelf velocity [L T-1 ~> m s-1]. + real, dimension(G%Isd:G%Ied,G%Jsd:G%Jed), & intent(inout) :: u_shlf !< The zonal ice shelf velocity [L T-1 ~> m s-1]. - real, dimension(G%IsdB:G%IedB,G%JsdB:G%JedB), & + real, dimension(G%Isd:G%Ied,G%Jsd:G%Jed), & intent(inout) :: v_shlf !< The meridional ice shelf velocity [L T-1 ~> m s-1]. ! also this subroutine updates the nonlinear part of the basal traction @@ -2626,9 +2762,11 @@ subroutine calc_shelf_taub(CS, ISS, G, US, u_shlf, v_shlf) real :: umid, vmid, unorm, eps_min ! Velocities [L T-1 ~> m s-1] isc = G%isc ; jsc = G%jsc ; iec = G%iec ; jec = G%jec - iscq = G%iscB ; iecq = G%iecB ; jscq = G%jscB ; jecq = G%jecB +! iscq = G%iscB ; iecq = G%iecB ; jscq = G%jscB ; jecq = G%jecB + iscq = G%isc ; iecq = G%iec ; jscq = G%jsc ; jecq = G%jec isd = G%isd ; jsd = G%jsd ; ied = G%ied ; jed = G%jed - iegq = G%iegB ; jegq = G%jegB +! iegq = G%iegB ; jegq = G%jegB + iegq = G%ieg ; jegq = G%jeg gisc = G%domain%nihalo+1 ; gjsc = G%domain%njhalo+1 giec = G%domain%niglobal+gisc ; gjec = G%domain%njglobal+gjsc is = iscq - 1; js = jscq - 1 @@ -2910,15 +3048,25 @@ subroutine update_velocity_masks(CS, G, hmask, umask, vmask, u_face_mask, v_face real, dimension(SZDI_(G),SZDJ_(G)), & intent(in) :: hmask !< A mask indicating which tracer points are !! partly or fully covered by an ice-shelf - real, dimension(SZDIB_(G),SZDJB_(G)), & +! real, dimension(SZDIB_(G),SZDJB_(G)), & +! intent(out) :: umask !< A coded mask indicating the nature of the +! !! zonal flow at the corner point +! real, dimension(SZDIB_(G),SZDJB_(G)), & +! intent(out) :: vmask !< A coded mask indicating the nature of the +! !! meridional flow at the corner point + real, dimension(SZDI_(G),SZDJ_(G)), & intent(out) :: umask !< A coded mask indicating the nature of the !! zonal flow at the corner point - real, dimension(SZDIB_(G),SZDJB_(G)), & + real, dimension(SZDI_(G),SZDJ_(G)), & intent(out) :: vmask !< A coded mask indicating the nature of the !! meridional flow at the corner point - real, dimension(SZDIB_(G),SZDJ_(G)), & +! real, dimension(SZDIB_(G),SZDJ_(G)), & +! intent(out) :: u_face_mask !< A coded mask for velocities at the C-grid u-face +! real, dimension(SZDI_(G),SZDJB_(G)), & +! intent(out) :: v_face_mask !< A coded mask for velocities at the C-grid v-face + real, dimension(SZDI_(G),SZDJ_(G)), & intent(out) :: u_face_mask !< A coded mask for velocities at the C-grid u-face - real, dimension(SZDI_(G),SZDJB_(G)), & + real, dimension(SZDI_(G),SZDJ_(G)), & intent(out) :: v_face_mask !< A coded mask for velocities at the C-grid v-face ! sets masks for velocity solve ! ignores the fact that their might be ice-free cells - this only considers the computational boundary @@ -2930,21 +3078,23 @@ subroutine update_velocity_masks(CS, G, hmask, umask, vmask, u_face_mask, v_face integer :: i_off, j_off isc = G%isc ; jsc = G%jsc ; iec = G%iec ; jec = G%jec - iscq = G%iscB ; iecq = G%iecB ; jscq = G%jscB ; jecq = G%jecB +! iscq = G%iscB ; iecq = G%iecB ; jscq = G%jscB ; jecq = G%jecB + iscq = G%isc ; iecq = G%iec ; jscq = G%jsc ; jecq = G%jec i_off = G%idg_offset ; j_off = G%jdg_offset isd = G%isd ; jsd = G%jsd - iegq = G%iegB ; jegq = G%jegB +! iegq = G%iegB ; jegq = G%jegB + iegq = G%ieg ; jegq = G%jeg gisc = G%Domain%nihalo ; gjsc = G%Domain%njhalo giec = G%Domain%niglobal+gisc ; gjec = G%Domain%njglobal+gjsc umask(:,:) = 0 ; vmask(:,:) = 0 u_face_mask(:,:) = 0 ; v_face_mask(:,:) = 0 - if (G%symmetric) then - is = isd ; js = jsd - else + ! if (G%symmetric) then + ! is = isd ; js = jsd + ! else is = isd+1 ; js = jsd+1 - endif + ! endif do j=js,G%jed do i=is,G%ied @@ -3042,9 +3192,15 @@ subroutine update_velocity_masks(CS, G, hmask, umask, vmask, u_face_mask, v_face ! note: if the grid is nonsymmetric, there is a part that will not be transferred with a halo update ! so this subroutine must update its own symmetric part of the halo - call pass_vector(u_face_mask, v_face_mask, G%domain, TO_ALL, CGRID_NE) - call pass_vector(umask, vmask, G%domain, TO_ALL, BGRID_NE) - +! call pass_vector(u_face_mask, v_face_mask, G%domain, TO_ALL, CGRID_NE) +! call pass_vector(u_face_mask, v_face_mask, G%domain) + call pass_var(u_face_mask, G%domain) + call pass_var(v_face_mask, G%domain) +! call pass_vector(umask, vmask, G%domain, TO_ALL, CGRID_NE) +! call pass_vector(umask, vmask, G%domain, TO_ALL, BGRID_NE) +! call pass_vector(umask, vmask, G%domain) + call pass_var(umask, G%domain) + call pass_var(vmask, G%domain) end subroutine update_velocity_masks !> Interpolate the ice shelf thickness from tracer point to nodal points, @@ -3056,10 +3212,12 @@ subroutine interpolate_H_to_B(G, h_shelf, hmask, H_node) real, dimension(SZDI_(G),SZDJ_(G)), & intent(in) :: hmask !< A mask indicating which tracer points are !! partly or fully covered by an ice-shelf - real, dimension(SZDIB_(G),SZDJB_(G)), & +! real, dimension(SZDIB_(G),SZDJB_(G)), & +! intent(inout) :: H_node !< The ice shelf thickness at nodal (corner) +! !! points [Z ~> m]. + real, dimension(SZDI_(G),SZDJ_(G)), & intent(inout) :: H_node !< The ice shelf thickness at nodal (corner) !! points [Z ~> m]. - integer :: i, j, isc, iec, jsc, jec, num_h, k, l real :: summ @@ -3088,7 +3246,7 @@ subroutine interpolate_H_to_B(G, h_shelf, hmask, H_node) enddo enddo - call pass_var(H_node, G%domain, position=CORNER) + call pass_var(H_node, G%domain)!, position=CORNER) end subroutine interpolate_H_to_B diff --git a/src/ice_shelf/MOM_ice_shelf_initialize.F90 b/src/ice_shelf/MOM_ice_shelf_initialize.F90 index e178b4e61b..157cd21e19 100644 --- a/src/ice_shelf/MOM_ice_shelf_initialize.F90 +++ b/src/ice_shelf/MOM_ice_shelf_initialize.F90 @@ -19,6 +19,7 @@ module MOM_ice_shelf_initialize public initialize_ice_thickness public initialize_ice_shelf_boundary_channel public initialize_ice_flow_from_file +public initialize_ice_shelf_boundary_from_file ! A note on unit descriptions in comments: MOM6 uses units that can be rescaled for dimensional ! consistency testing. These are noted in comments with units like Z, H, L, and T, along with @@ -261,24 +262,24 @@ subroutine initialize_ice_shelf_boundary_channel(u_face_mask_bdry, v_face_mask_b US, PF ) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - real, dimension(SZIB_(G),SZJ_(G)), & + real, dimension(SZDI_(G),SZDJ_(G)), & intent(inout) :: u_face_mask_bdry !< A boundary-type mask at C-grid u faces - real, dimension(SZIB_(G),SZJ_(G)), & + real, dimension(SZDI_(G),SZDJ_(G)), & intent(inout) :: u_flux_bdry_val !< The boundary thickness flux through !! C-grid u faces [L Z T-1 ~> m2 s-1]. - real, dimension(SZI_(G),SZJB_(G)), & + real, dimension(SZDI_(G),SZDJ_(G)), & intent(inout) :: v_face_mask_bdry !< A boundary-type mask at C-grid v faces - real, dimension(SZI_(G),SZJB_(G)), & + real, dimension(SZDI_(G),SZDJ_(G)), & intent(inout) :: v_flux_bdry_val !< The boundary thickness flux through !! C-grid v faces [L Z T-1 ~> m2 s-1]. - real, dimension(SZIB_(G),SZJB_(G)), & + real, dimension(SZDI_(G),SZDJ_(G)), & intent(inout) :: u_bdry_val !< The zonal ice shelf velocity at open !! boundary vertices [L T-1 ~> m s-1]. - real, dimension(SZIB_(G),SZJB_(G)), & + real, dimension(SZDI_(G),SZDJ_(G)), & intent(inout) :: v_bdry_val !< The meridional ice shelf velocity at open - real, dimension(SZIB_(G),SZJB_(G)), & + real, dimension(SZDI_(G),SZDJ_(G)), & intent(inout) :: u_shelf !< The zonal ice shelf velocity [L T-1 ~> m s-1]. - real, dimension(SZIB_(G),SZJB_(G)), & + real, dimension(SZDI_(G),SZDJ_(G)), & intent(inout) :: v_shelf !< The meridional ice shelf velocity [L T-1 ~> m s-1]. real, dimension(SZDI_(G),SZDJ_(G)), & intent(inout) :: thickness_bdry_val !< The ice shelf thickness at open boundaries [Z ~> m] @@ -458,4 +459,110 @@ subroutine initialize_ice_flow_from_file(bed_elev,u_shelf, v_shelf,ice_visc,floa enddo end subroutine initialize_ice_flow_from_file + +subroutine initialize_ice_shelf_boundary_from_file(u_face_mask_bdry, v_face_mask_bdry, & + u_bdry_val, v_bdry_val, umask, vmask, h_bdry_val, thickness_bdry_val, & + hmask, h_shelf, G, US, PF ) + + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(inout) :: u_face_mask_bdry !< A boundary-type mask at C-grid u faces + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(inout) :: v_face_mask_bdry !< A boundary-type mask at C-grid v faces + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(inout) :: u_bdry_val !< The zonal ice shelf velocity at open + !! boundary vertices [L T-1 ~> m s-1]. + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(inout) :: v_bdry_val !< The meridional ice shelf velocity at open + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(inout) :: umask !< A mask foor ice shelf velocity + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(inout) :: vmask !< A mask foor ice shelf velocity + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(inout) :: thickness_bdry_val !< The ice shelf thickness at open boundaries [Z ~> m] + !! boundary vertices [L T-1 ~> m s-1]. + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(inout) :: h_bdry_val !< The ice shelf thickness at open boundaries [Z ~> m] + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(inout) :: hmask !< A mask indicating which tracer points are + !! partly or fully covered by an ice-shelf + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(inout) :: h_shelf !< Ice-shelf thickness + type(unit_scale_type), intent(in) :: US !< A structure containing unit conversion factors + type(param_file_type), intent(in) :: PF !< A structure to parse for run-time parameters + + character(len=200) :: filename, bc_file, inputdir, icethick_file ! Strings for file/path + character(len=200) :: ufcmskbdry_varname, vfcmskbdry_varname, & + ubdryv_varname, vbdryv_varname, umask_varname, vmask_varname, & + h_varname,hmsk_varname ! Variable name in file + character(len=40) :: mdl = "initialize_ice_shelf_boundary_from_file" ! This subroutine's name. + + integer :: i, j, isc, jsc, iec, jec + + h_bdry_val(:,:) = 0. + thickness_bdry_val(:,:) = 0. + + call MOM_mesg(" MOM_ice_shelf_init_profile.F90, initialize_velocity_from_file: reading velocity") + + call get_param(PF, mdl, "INPUTDIR", inputdir, default=".") + inputdir = slasher(inputdir) + call get_param(PF, mdl, "ICE_SHELF_BC_FILE", bc_file, & + "The file from which the boundary condiions are read.", & + default="ice_shelf_bc.nc") + call get_param(PF, mdl, "ICE_THICKNESS_FILE", icethick_file, & + "The file from which the ice-shelf thickness is read.", & + default="ice_shelf_thick.nc") + call get_param(PF, mdl, "ICE_THICKNESS_VARNAME", h_varname, & + "The name of the thickness variable in ICE_THICKNESS_FILE.", & + default="h_shelf") + call get_param(PF, mdl, "ICE_THICKNESS_MASK_VARNAME", hmsk_varname, & + "The name of the icethickness mask variable in ICE_THICKNESS_FILE.", & + default="h_mask") + + filename = trim(inputdir)//trim(bc_file) + call log_param(PF, mdl, "INPUTDIR/ICE_SHELF_BC_FILE", filename) + call get_param(PF, mdl, "ICE_UBDRYMSK_VARNAME", ufcmskbdry_varname, & + "The name of the ice-shelf ubdrymask variable in ICE_SHELF_BC_FILE.", & + default="ufacemask") + call get_param(PF, mdl, "ICE_VBDRYMSK_VARNAME", vfcmskbdry_varname, & + "The name of the ice-shelf vbdrymask variable in ICE_SHELF_BC_FILE.", & + default="vfacemask") + call get_param(PF, mdl, "ICE_UMASK_VARNAME", umask_varname, & + "The name of the ice-shelf ubdrymask variable in ICE_SHELF_BC_FILE.", & + default="umask") + call get_param(PF, mdl, "ICE_VMASK_VARNAME", vmask_varname, & + "The name of the ice-shelf vbdrymask variable in ICE_SHELF_BC_FILE.", & + default="vmask") + call get_param(PF, mdl, "ICE_UBDRYVAL_VARNAME", ubdryv_varname, & + "The name of the ice-shelf ice_shelf ubdry variable in ICE_SHELF_BC_FILE.", & + default="ubdry_val") + call get_param(PF, mdl, "ICE_VBDRYVAL_VARNAME", vbdryv_varname, & + "The name of the ice-shelf ice_shelf vbdry variable in ICE_SHELF_BC_FILE.", & + default="vbdry_val") + if (.not.file_exists(filename, G%Domain)) call MOM_error(FATAL, & + " initialize_ice_shelf_velocity_from_file: Unable to open "//trim(filename)) + + + call MOM_read_data(filename, trim(ufcmskbdry_varname),u_face_mask_bdry, G%Domain, scale=1.0) + call MOM_read_data(filename,trim(vfcmskbdry_varname), v_face_mask_bdry, G%Domain, scale=1.0) + call MOM_read_data(filename,trim(ubdryv_varname), u_bdry_val, G%Domain, scale=1.0) + call MOM_read_data(filename,trim(vbdryv_varname), v_bdry_val, G%Domain, scale=1.) + call MOM_read_data(filename,trim(umask_varname), umask, G%Domain, scale=1.) + call MOM_read_data(filename,trim(vmask_varname), vmask, G%Domain, scale=1.) + filename = trim(inputdir)//trim(icethick_file) + + call MOM_read_data(filename, trim(h_varname), h_shelf, G%Domain, scale=US%m_to_Z) + call MOM_read_data(filename,trim(hmsk_varname), hmask, G%Domain, scale=1.) + isc = G%isc ; jsc = G%jsc ; iec = G%iec ; jec = G%jec + + do j=jsc,jec + do i=isc,iec + if (hmask(i,j) == 3.) then + thickness_bdry_val(i,j) = h_shelf(i,j) + h_bdry_val(i,j) = h_shelf(i,j) + endif + enddo + enddo + +end subroutine initialize_ice_shelf_boundary_from_file end module MOM_ice_shelf_initialize From 1ab65ab57f1a7e6da536669705505b488498ac1d Mon Sep 17 00:00:00 2001 From: Olga Sergienko Date: Thu, 22 Apr 2021 15:45:50 -0400 Subject: [PATCH 055/112] corrected doxygen errors --- src/ice_shelf/MOM_ice_shelf_dynamics.F90 | 16 ++++++++++------ 1 file changed, 10 insertions(+), 6 deletions(-) diff --git a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 index 846cf04007..056ee3c17b 100644 --- a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 +++ b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 @@ -553,8 +553,8 @@ subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_ call pass_var(CS%umask, G%domain) call pass_var(CS%vmask, G%domain) !call init_boundary_values(CS, G, time, ISS%hmask, CS%input_flux, CS%input_thickness, new_sim) - call initialize_ice_flow_from_file(CS%bed_elev,CS%u_shelf, CS%v_shelf,CS%ice_visc,CS%ground_frac, ISS%hmask,ISS%h_shelf, & - G, US, param_file) !spacially variable viscosity from a file for debugging + call initialize_ice_flow_from_file(CS%bed_elev,CS%u_shelf, CS%v_shelf,CS%ice_visc,& + CS%ground_frac, ISS%hmask,ISS%h_shelf, G, US, param_file) call pass_var(CS%ice_visc, G%domain) call pass_var(CS%u_shelf, G%domain) call pass_var(CS%v_shelf, G%domain) @@ -869,7 +869,8 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf,taudx,taudy, ite ! real, dimension(SZDIB_(G),SZDJB_(G)) :: err_u, err_v ! real, dimension(SZDIB_(G),SZDJB_(G)) :: u_last, v_last ! Previous velocities [L T-1 ~> m s-1] ! real, dimension(SZDIB_(G),SZDJB_(G)) :: H_node ! Ice shelf thick)), & -! intent(out) :: taudy !< Driving y-stress at q-points [R L3 Z T-2 ~> kg m s-2]ness at corners [Z ~> m]. +! intent(out) :: taudy !< Driving y-stress at q-points + ![R L3 Z T-2 ~> kg m s-2]ness at corners [Z ~> m]. real, dimension(SZDI_(G),SZDJ_(G)) :: u_bdry_cont ! Boundary u-stress contribution [R L3 Z T-2 ~> kg m s-2] real, dimension(SZDI_(G),SZDJ_(G)) :: v_bdry_cont ! Boundary v-stress contribution [R L3 Z T-2 ~> kg m s-2] real, dimension(SZDI_(G),SZDJ_(G)) :: Au, Av ! The retarding lateral stress contributions [R L3 Z T-2 ~> kg m s-2] @@ -1127,7 +1128,8 @@ subroutine ice_shelf_solve_inner(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, H intent(in) :: taudy !< The y-direction driving stress [R L3 Z T-2 ~> kg m s-2] real, dimension(SZDI_(G),SZDJ_(G)), & intent(in) :: H_node !< The ice shelf thickness at nodal (corner) - !! points [Z ~> m]. !! points [Z ~> m]. + !! points [Z ~> m]. + real, dimension(SZDI_(G),SZDJ_(G)), & intent(in) :: float_cond !< An array indicating where the ice !! shelf is floating: 0 if floating, 1 if not. @@ -2183,7 +2185,8 @@ subroutine CG_action(uret, vret, u_shlf, v_shlf, Phi, Phisub, umask, vmask, hmas real, dimension(SZDI_(G),SZDJ_(G)), & intent(in) :: u_shlf !< The zonal ice shelf velocity at vertices [L T-1 ~> m s-1] real, dimension(SZDI_(G),SZDJ_(G)), & - intent(in) :: v_shlf !< The meridional ice shelf velocity at vertices [L T-1 ~> m s-1] + intent(in) :: v_shlf !< The meridional ice shelf velocity + !at vertices [L T-1 ~> m s-1] real, dimension(SZDI_(G),SZDJ_(G)), & intent(in) :: umask !< A coded mask indicating the nature of the !! zonal flow at the corner point @@ -2192,7 +2195,8 @@ subroutine CG_action(uret, vret, u_shlf, v_shlf, Phi, Phisub, umask, vmask, hmas !! meridional flow at the corner point real, dimension(SZDI_(G),SZDJ_(G)), & intent(in) :: H_node !< The ice shelf thickness at nodal (corner) - !! points [Z ~> m]. !! partly or fully covered by an ice-shelf + !! points [Z ~> m]. + !! partly or fully covered by an ice-shelf ! real, dimension(SZDIB_(G),SZDJB_(G)), & real, dimension(SZDI_(G),SZDJ_(G)), & intent(in) :: ice_visc !< A field related to the ice viscosity from Glen's From 9f5c885bf2fc0e9ca5e61af7669d589b995bd0a9 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Mon, 26 Apr 2021 07:46:57 -0400 Subject: [PATCH 056/112] +Correct the units of remap tendency diagnostics Corrected the units of the ..._h_tendency_vert_remap diagnostics and their 2-d counterparts to reflect the fact that they are integrated tendencies, addressing MOM6 issue #1017. This PR changes the units of several variables in the available_diags files and any output files with these diagnostics. Also eliminated the spacing around the equal sign in a number of optional argument declarations in this file to follow the MOM6 standards in the MOM6 style guide. Also changed some irregular continuation line indents for self-consistency in register_tracer_diagnostics. All answers are bitwise identical, but there are minor metadata changes in some output files. --- src/tracer/MOM_tracer_registry.F90 | 87 +++++++++++++++--------------- 1 file changed, 42 insertions(+), 45 deletions(-) diff --git a/src/tracer/MOM_tracer_registry.F90 b/src/tracer/MOM_tracer_registry.F90 index cfbdc6ecb0..d8a2cb52c6 100644 --- a/src/tracer/MOM_tracer_registry.F90 +++ b/src/tracer/MOM_tracer_registry.F90 @@ -307,10 +307,8 @@ subroutine register_tracer(tr_ptr, Reg, param_file, HI, GV, name, longname, unit if (present(df_x)) then ; if (associated(df_x)) Tr%df_x => df_x ; endif if (present(df_y)) then ; if (associated(df_y)) Tr%df_y => df_y ; endif ! if (present(OBC_inflow)) Tr%OBC_inflow_conc = OBC_inflow -! if (present(OBC_in_u)) then ; if (associated(OBC_in_u)) & -! Tr%OBC_in_u => OBC_in_u ; endif -! if (present(OBC_in_v)) then ; if (associated(OBC_in_v)) & -! Tr%OBC_in_v => OBC_in_v ; endif +! if (present(OBC_in_u)) then ; if (associated(OBC_in_u)) Tr%OBC_in_u => OBC_in_u ; endif +! if (present(OBC_in_v)) then ; if (associated(OBC_in_v)) Tr%OBC_in_v => OBC_in_v ; endif if (present(ad_2d_x)) then ; if (associated(ad_2d_x)) Tr%ad2d_x => ad_2d_x ; endif if (present(ad_2d_y)) then ; if (associated(ad_2d_y)) Tr%ad2d_y => ad_2d_y ; endif if (present(df_2d_x)) then ; if (associated(df_2d_x)) Tr%df2d_x => df_2d_x ; endif @@ -403,49 +401,49 @@ subroutine register_tracer_diagnostics(Reg, h, Time, diag, G, GV, US, use_ALE) if (len_trim(cmorname) == 0) then Tr%id_tr = register_diag_field("ocean_model", trim(name), diag%axesTL, & - Time, trim(longname), trim(units)) + Time, trim(longname), trim(units)) else Tr%id_tr = register_diag_field("ocean_model", trim(name), diag%axesTL, & - Time, trim(longname), trim(units), cmor_field_name=cmorname, & - cmor_long_name=cmor_longname, cmor_units=Tr%cmor_units, & - cmor_standard_name=cmor_long_std(cmor_longname)) + Time, trim(longname), trim(units), cmor_field_name=cmorname, & + cmor_long_name=cmor_longname, cmor_units=Tr%cmor_units, & + cmor_standard_name=cmor_long_std(cmor_longname)) endif - Tr%id_tr_post_horzn = register_diag_field("ocean_model", & - trim(name)//"_post_horzn", diag%axesTL, Time, & - trim(longname)//" after horizontal transport (advection/diffusion) "//& - "has occurred", trim(units)) + Tr%id_tr_post_horzn = register_diag_field("ocean_model", & + trim(name)//"_post_horzn", diag%axesTL, Time, & + trim(longname)//" after horizontal transport (advection/diffusion) has occurred", & + trim(units)) if (Tr%diag_form == 1) then 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', & + trim(flux_units), v_extensive=.true., y_cell_method='sum', & 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', & + trim(flux_units), v_extensive=.true., x_cell_method='sum', & 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', & + trim(flux_units), v_extensive=.true., y_cell_method='sum', & conversion=(US%L_to_m**2)*Tr%flux_scale*US%s_to_T) Tr%id_dfy = register_diag_field("ocean_model", trim(shortnm)//"_dfy", & diag%axesCvL, Time, trim(flux_longname)//" diffusive zonal flux" , & - trim(flux_units), v_extensive = .true., x_cell_method = 'sum', & + trim(flux_units), v_extensive=.true., x_cell_method='sum', & conversion=(US%L_to_m**2)*Tr%flux_scale*US%s_to_T) Tr%id_lbd_dfx = register_diag_field("ocean_model", trim(shortnm)//"_lbd_diffx", & diag%axesCuL, Time, trim(flux_longname)//" diffusive zonal flux from the lateral boundary diffusion "//& - "scheme", trim(flux_units), v_extensive = .true., y_cell_method = 'sum', & + "scheme", trim(flux_units), v_extensive=.true., y_cell_method='sum', & conversion=(US%L_to_m**2)*Tr%flux_scale*US%s_to_T) Tr%id_lbd_dfy = register_diag_field("ocean_model", trim(shortnm)//"_lbd_diffy", & diag%axesCvL, Time, trim(flux_longname)//" diffusive meridional flux from the lateral boundary diffusion "//& - "scheme", trim(flux_units), v_extensive = .true., x_cell_method = 'sum', & + "scheme", trim(flux_units), v_extensive=.true., x_cell_method='sum', & conversion=(US%L_to_m**2)*Tr%flux_scale*US%s_to_T) 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%L_to_m**2)*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%L_to_m**2)*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, & @@ -473,11 +471,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%L_to_m**2)*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%L_to_m**2)*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), & @@ -499,13 +497,13 @@ subroutine register_tracer_diagnostics(Reg, h, Time, diag, G, GV, US, use_ALE) flux_units, conversion=(US%L_to_m**2)*Tr%flux_scale*US%s_to_T, & x_cell_method='sum') Tr%id_lbd_dfx_2d = register_diag_field("ocean_model", trim(shortnm)//"_lbd_diffx_2d", & - diag%axesCu1, Time, "Vertically-integrated zonal diffusive flux from the lateral boundary diffusion "//& - "scheme for "//trim(flux_longname), flux_units, conversion=(US%L_to_m**2)*Tr%flux_scale*US%s_to_T, & - y_cell_method = 'sum') + diag%axesCu1, Time, "Vertically-integrated zonal diffusive flux from the lateral boundary diffusion "//& + "scheme for "//trim(flux_longname), flux_units, conversion=(US%L_to_m**2)*Tr%flux_scale*US%s_to_T, & + y_cell_method='sum') Tr%id_lbd_dfy_2d = register_diag_field("ocean_model", trim(shortnm)//"_lbd_diffy_2d", & - diag%axesCv1, Time, "Vertically-integrated meridional diffusive flux from the lateral boundary diffusion "//& - "scheme for "//trim(flux_longname), flux_units, conversion=(US%L_to_m**2)*Tr%flux_scale*US%s_to_T, & - x_cell_method = 'sum') + diag%axesCv1, Time, "Vertically-integrated meridional diffusive flux from the lateral boundary diffusion "//& + "scheme for "//trim(flux_longname), flux_units, conversion=(US%L_to_m**2)*Tr%flux_scale*US%s_to_T, & + x_cell_method='sum') if (Tr%id_adx_2d > 0) call safe_alloc_ptr(Tr%ad2d_x,IsdB,IedB,jsd,jed) if (Tr%id_ady_2d > 0) call safe_alloc_ptr(Tr%ad2d_y,isd,ied,JsdB,JedB) @@ -548,7 +546,7 @@ subroutine register_tracer_diagnostics(Reg, h, Time, diag, G, GV, US, use_ALE) Tr%id_dfxy_cont_2d = register_diag_field("ocean_model", trim(shortnm)//'_dfxy_cont_tendency_2d', & diag%axesT1, Time, "Depth integrated neutral diffusion tracer content "//& "tendency for "//trim(shortnm), conv_units, conversion=Tr%conv_scale*US%s_to_T, & - x_cell_method='sum', y_cell_method= 'sum') + x_cell_method='sum', y_cell_method='sum') Tr%id_lbdxy_cont = register_diag_field("ocean_model", trim(shortnm)//'_lbdxy_cont_tendency', & diag%axesTL, Time, "Lateral diffusion tracer content tendency for "//trim(shortnm), & @@ -557,16 +555,15 @@ subroutine register_tracer_diagnostics(Reg, h, Time, diag, G, GV, US, use_ALE) Tr%id_lbdxy_cont_2d = register_diag_field("ocean_model", trim(shortnm)//'_lbdxy_cont_tendency_2d', & diag%axesT1, Time, "Depth integrated lateral diffusion tracer content "//& "tendency for "//trim(shortnm), conv_units, conversion=Tr%conv_scale*US%s_to_T, & - x_cell_method='sum', y_cell_method= 'sum') + x_cell_method='sum', y_cell_method='sum') else - cmor_var_lname = 'Tendency of '//trim(lowercase(cmor_longname))//& - ' expressed as '//trim(lowercase(flux_longname))//& - ' content due to parameterized mesoscale neutral diffusion' + cmor_var_lname = 'Tendency of '//trim(lowercase(cmor_longname))//' expressed as '//& + trim(lowercase(flux_longname))//' content due to parameterized mesoscale neutral diffusion' Tr%id_dfxy_cont = register_diag_field("ocean_model", trim(shortnm)//'_dfxy_cont_tendency', & diag%axesTL, Time, "Neutral diffusion tracer content tendency for "//trim(shortnm), & - conv_units, conversion=Tr%conv_scale*US%s_to_T, cmor_field_name = trim(Tr%cmor_tendprefix)//'pmdiff', & - cmor_long_name = trim(cmor_var_lname), cmor_standard_name = trim(cmor_long_std(cmor_var_lname)), & - x_cell_method = 'sum', y_cell_method = 'sum', v_extensive = .true.) + conv_units, conversion=Tr%conv_scale*US%s_to_T, cmor_field_name=trim(Tr%cmor_tendprefix)//'pmdiff', & + cmor_long_name=trim(cmor_var_lname), cmor_standard_name=trim(cmor_long_std(cmor_var_lname)), & + x_cell_method='sum', y_cell_method='sum', v_extensive=.true.) cmor_var_lname = 'Tendency of '//trim(lowercase(cmor_longname))//' expressed as '//& trim(lowercase(flux_longname))//' content due to parameterized mesoscale neutral diffusion' @@ -580,7 +577,7 @@ subroutine register_tracer_diagnostics(Reg, h, Time, diag, G, GV, US, use_ALE) Tr%id_lbdxy_cont = register_diag_field("ocean_model", trim(shortnm)//'_lbdxy_cont_tendency', & diag%axesTL, Time, "Lateral diffusion tracer content tendency for "//trim(shortnm), & conv_units, conversion=Tr%conv_scale*US%s_to_T, & - x_cell_method = 'sum', y_cell_method = 'sum', v_extensive = .true.) + x_cell_method='sum', y_cell_method='sum', v_extensive=.true.) Tr%id_lbdxy_cont_2d = register_diag_field("ocean_model", trim(shortnm)//'_lbdxy_cont_tendency_2d', & diag%axesT1, Time, "Depth integrated lateral diffusion tracer "//& @@ -628,20 +625,20 @@ subroutine register_tracer_diagnostics(Reg, h, Time, diag, G, GV, US, use_ALE) ! Vertical regridding/remapping tendencies if (use_ALE .and. Tr%remap_tr) then 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', conversion=US%s_to_T) + 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', 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*US%s_to_T) + trim(Tr%flux_nameroot)//'h_tendency_vert_remap', & + diag%axesTL, Time, var_lname, conv_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*US%s_to_T) + trim(Tr%flux_nameroot)//'h_tendency_vert_remap_2d', & + diag%axesT1, Time, var_lname, conv_units, conversion=Tr%conv_scale*US%s_to_T) endif @@ -649,7 +646,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", conversion=US%s_to_T) + 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 From 3c19cbf4a00c50cce0eefef477a4e82b08cd9541 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Mon, 26 Apr 2021 14:21:59 -0400 Subject: [PATCH 057/112] Allow Phillips case to work in doubly periodic domain - If REENTRANT_Y is True (existing parameter that controls the periodicity) then the tanh() function used in the Phillips case forcing is replaced by sin(). The case is only makes sense if JET_WIDTH is a sensible fraction of LENLAT, e.g. 1. or 0.5, allowing the forcing to be smoothly periodic. - Does not change answers for existing cases. --- src/user/Phillips_initialization.F90 | 35 +++++++++++++++++++++++++++- 1 file changed, 34 insertions(+), 1 deletion(-) diff --git a/src/user/Phillips_initialization.F90 b/src/user/Phillips_initialization.F90 index 8f5c6d283e..dfa9c19460 100644 --- a/src/user/Phillips_initialization.F90 +++ b/src/user/Phillips_initialization.F90 @@ -55,8 +55,10 @@ subroutine Phillips_initialize_thickness(h, G, GV, US, param_file, just_read_par real :: half_strat ! The fractional depth where the stratification is centered [nondim] real :: half_depth ! The depth where the stratification is centered [Z ~> m] logical :: just_read ! If true, just read parameters but set nothing. + logical :: reentrant_y ! If true, model is re-entrant in the y direction character(len=40) :: mdl = "Phillips_initialize_thickness" ! This subroutine's name. integer :: i, j, k, is, ie, js, je, isd, ied, jsd, jed, nz + real :: pi ! The ratio of the circumference of a circle to its diameter [nondim] 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 @@ -76,6 +78,10 @@ subroutine Phillips_initialize_thickness(h, G, GV, US, param_file, just_read_par "The interface height scale associated with the "//& "zonal-mean jet.", units="m", scale=US%m_to_Z, & fail_if_missing=.not.just_read, do_not_log=just_read) + ! If re-entrant in the Y direction, we use a sine function instead of a + ! tanh. The ratio len_lat/jet_width should be an integer in this case. + call get_param(param_file, mdl, "REENTRANT_Y", reentrant_y, & + default=.false., do_not_log=.true.) if (just_read) return ! All run-time parameters have been read, so return. @@ -85,6 +91,7 @@ subroutine Phillips_initialize_thickness(h, G, GV, US, param_file, just_read_par do k=2+nz/2,nz+1 eta0(k) = -G%max_depth - 2.0*(G%max_depth-half_depth) * ((k-(nz+1))/real(nz)) enddo + pi = 4.0*atan(1.0) do j=js,je eta_im(j,1) = 0.0 ; eta_im(j,nz+1) = -G%max_depth @@ -93,6 +100,10 @@ subroutine Phillips_initialize_thickness(h, G, GV, US, param_file, just_read_par y_2 = G%geoLatT(is,j) - G%south_lat - 0.5*G%len_lat eta_im(j,K) = eta0(k) + jet_height * tanh(y_2 / jet_width) ! or ... + jet_height * atan(y_2 / jet_width) + if (reentrant_y) then + y_2 = 2.*pi*y_2 + eta_im(j,K) = eta0(k) + jet_height * sin(y_2 / jet_width) + endif if (eta_im(j,K) > 0.0) eta_im(j,K) = 0.0 if (eta_im(j,K) < -G%max_depth) eta_im(j,K) = -G%max_depth enddo ; enddo @@ -138,6 +149,7 @@ subroutine Phillips_initialize_velocity(u, v, G, GV, US, param_file, just_read_p real :: pi ! The ratio of the circumference of a circle to its diameter [nondim] integer :: i, j, k, is, ie, js, je, nz, m logical :: just_read ! If true, just read parameters but set nothing. + logical :: reentrant_y ! If true, model is re-entrant in the y direction character(len=40) :: mdl = "Phillips_initialize_velocity" ! This subroutine's name. is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke @@ -154,6 +166,10 @@ subroutine Phillips_initialize_velocity(u, v, G, GV, US, param_file, just_read_p "The interface height scale associated with the "//& "zonal-mean jet.", units="m", scale=US%m_to_Z, & fail_if_missing=.not.just_read, do_not_log=just_read) + ! If re-entrant in the Y direction, we use a sine function instead of a + ! tanh. The ratio len_lat/jet_width should be an integer in this case. + call get_param(param_file, mdl, "REENTRANT_Y", reentrant_y, & + default=.false., do_not_log=.true.) if (just_read) return ! All run-time parameters have been read, so return. @@ -165,14 +181,20 @@ subroutine Phillips_initialize_velocity(u, v, G, GV, US, param_file, just_read_p ! Use thermal wind shear to give a geostrophically balanced flow. do k=nz-1,1 ; do j=js,je ; do I=is-1,ie y_2 = G%geoLatCu(I,j) - G%south_lat - 0.5*G%len_lat + if (reentrant_y) then + y_2 = 2.*pi*y_2 + u(I,j,k) = u(I,j,k+1) + (1.e-3 * (jet_height / (US%m_to_L*jet_width)) * & + cos(y_2/jet_width) ) + else ! This uses d/d y_2 atan(y_2 / jet_width) ! u(I,j,k) = u(I,j,k+1) + ( jet_height / & ! (1.0e3*US%m_to_L*jet_width * (1.0 + (y_2 / jet_width)**2))) * & ! (2.0 * GV%g_prime(K+1) / (G%CoriolisBu(I,J) + G%CoriolisBu(I,J-1))) ! This uses d/d y_2 tanh(y_2 / jet_width) - u(I,j,k) = u(I,j,k+1) + (1e-3 * (jet_height / (US%m_to_L*jet_width)) * & + u(I,j,k) = u(I,j,k+1) + (1e-3 * (jet_height / (US%m_to_L*jet_width)) * & (sech(y_2 / jet_width))**2 ) * & (2.0 * GV%g_prime(K+1) / (G%CoriolisBu(I,J) + G%CoriolisBu(I,J-1))) + endif enddo ; enddo ; enddo do k=1,nz ; do j=js,je ; do I=is-1,ie @@ -228,6 +250,8 @@ subroutine Phillips_initialize_sponges(G, GV, US, tv, param_file, CSp, h) real :: y_2 ! The y-position relative to the channel center, in km. real :: half_strat ! The fractional depth where the straficiation is centered [nondim]. real :: half_depth ! The depth where the stratification is centered [Z ~> m]. + real :: pi ! The ratio of the circumference of a circle to its diameter [nondim] + logical :: reentrant_y ! If true, model is re-entrant in the y direction character(len=40) :: mdl = "Phillips_initialize_sponges" ! This subroutine's name. integer :: i, j, k, is, ie, js, je, isd, ied, jsd, jed, nz @@ -255,6 +279,10 @@ subroutine Phillips_initialize_sponges(G, GV, US, tv, param_file, CSp, h) "The interface height scale associated with the "//& "zonal-mean jet.", units="m", scale=US%m_to_Z, & fail_if_missing=.true.) + ! If re-entrant in the Y direction, we use a sine function instead of a + ! tanh. The ratio len_lat/jet_width should be an integer in this case. + call get_param(param_file, mdl, "REENTRANT_Y", reentrant_y, & + default=.false., do_not_log=.true.) half_depth = G%max_depth*half_strat eta0(1) = 0.0 ; eta0(nz+1) = -G%max_depth @@ -262,6 +290,7 @@ subroutine Phillips_initialize_sponges(G, GV, US, tv, param_file, CSp, h) do k=2+nz/2,nz+1 eta0(k) = -G%max_depth - 2.0*(G%max_depth-half_depth) * ((k-(nz+1))/real(nz)) enddo + pi = 4.0*atan(1.0) do j=js,je Idamp_im(j) = damp_rate @@ -271,6 +300,10 @@ subroutine Phillips_initialize_sponges(G, GV, US, tv, param_file, CSp, h) y_2 = G%geoLatT(is,j) - G%south_lat - 0.5*G%len_lat eta_im(j,K) = eta0(k) + jet_height * tanh(y_2 / jet_width) ! jet_height * atan(y_2 / jet_width) + if (reentrant_y) then + y_2 = 2.*pi*y_2 + eta_im(j,K) = eta0(k) + jet_height * sin(y_2 / jet_width) + endif if (eta_im(j,K) > 0.0) eta_im(j,K) = 0.0 if (eta_im(j,K) < -G%max_depth) eta_im(j,K) = -G%max_depth enddo ; enddo From 167f3d4df217b78c76d408810841c124f2b219d6 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 27 Apr 2021 17:24:11 -0400 Subject: [PATCH 058/112] (*)Correct inconsistent units in 17 diagnostics Corrects inconsistent units or unit conversion factors for 17 diagnostics plus all of the diagnostics for extra tracer fluxes where the scaling factor is not explicitly supplied (temperature and salinity are not impacted). In most cases the corrections are in obscure diagnostics that are probably not used much or only apply to non-Boussinesq cases. In addition, dimensional rescaling in time was applied to the diapycnal velocity diagnostic in layered mode. This commit addresses the specific problems noted in MOM6 issue #1384, but it does not uniformly change to the suggested code construct for register_diag_field arguments that would make these problems easier to detect in the future. All solutions are bitwise identical, but there are changes to the metadata of some diagnostics and there are changes to the available_diags files. --- src/ALE/MOM_ALE.F90 | 4 +-- src/core/MOM_barotropic.F90 | 19 +++++++------- src/core/MOM_variables.F90 | 2 +- src/diagnostics/MOM_diagnostics.F90 | 25 +++++++++---------- .../vertical/MOM_diabatic_driver.F90 | 4 +-- .../vertical/MOM_diapyc_energy_req.F90 | 2 +- .../vertical/MOM_geothermal.F90 | 2 +- .../vertical/MOM_vert_friction.F90 | 18 +++++++------ src/tracer/MOM_tracer_registry.F90 | 12 +++++---- 9 files changed, 45 insertions(+), 43 deletions(-) diff --git a/src/ALE/MOM_ALE.F90 b/src/ALE/MOM_ALE.F90 index 4523f029bf..158062fd06 100644 --- a/src/ALE/MOM_ALE.F90 +++ b/src/ALE/MOM_ALE.F90 @@ -279,8 +279,8 @@ subroutine ALE_register_diags(Time, G, GV, US, diag, CS) diag%axestl, time, 'layer thicknesses after ALE regridding and remapping', 'm', & 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*US%s_to_T, v_extensive = .true.) + 'Layer thicknesses tendency due to ALE regridding and remapping', & + 'm s-1', conversion=GV%H_to_m*US%s_to_T, v_extensive = .true.) end subroutine ALE_register_diags diff --git a/src/core/MOM_barotropic.F90 b/src/core/MOM_barotropic.F90 index 17e7ebee40..590366f32f 100644 --- a/src/core/MOM_barotropic.F90 +++ b/src/core/MOM_barotropic.F90 @@ -4797,13 +4797,13 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, 'Barotropic meridional acceleration', 'm s-2', conversion=US%L_T2_to_m_s2) CS%id_eta_bt = register_diag_field('ocean_model', 'eta_bt', diag%axesT1, Time, & - 'Barotropic end SSH', thickness_units, conversion=GV%H_to_m) + 'Barotropic end SSH', thickness_units, conversion=GV%H_to_MKS) CS%id_ubt = register_diag_field('ocean_model', 'ubt', diag%axesCu1, Time, & 'Barotropic end zonal velocity', 'm s-1', conversion=US%L_T_to_m_s) CS%id_vbt = register_diag_field('ocean_model', 'vbt', diag%axesCv1, Time, & 'Barotropic end meridional velocity', 'm s-1', conversion=US%L_T_to_m_s) CS%id_eta_st = register_diag_field('ocean_model', 'eta_st', diag%axesT1, Time, & - 'Barotropic start SSH', thickness_units, conversion=GV%H_to_m) + 'Barotropic start SSH', thickness_units, conversion=GV%H_to_MKS) CS%id_ubt_st = register_diag_field('ocean_model', 'ubt_st', diag%axesCu1, Time, & 'Barotropic start zonal velocity', 'm s-1', conversion=US%L_T_to_m_s) CS%id_vbt_st = register_diag_field('ocean_model', 'vbt_st', diag%axesCv1, Time, & @@ -4813,7 +4813,7 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, CS%id_vbtav = register_diag_field('ocean_model', 'vbtav', diag%axesCv1, Time, & 'Barotropic time-average meridional velocity', 'm s-1', conversion=US%L_T_to_m_s) CS%id_eta_cor = register_diag_field('ocean_model', 'eta_cor', diag%axesT1, Time, & - 'Corrective mass flux', 'm s-1', conversion=GV%H_to_m) + 'Corrective mass flux within a timestep', 'm', conversion=GV%H_to_m) CS%id_visc_rem_u = register_diag_field('ocean_model', 'visc_rem_u', diag%axesCuL, Time, & 'Viscous remnant at u', 'nondim') CS%id_visc_rem_v = register_diag_field('ocean_model', 'visc_rem_v', diag%axesCvL, Time, & @@ -4827,14 +4827,13 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, CS%id_gtotw = register_diag_field('ocean_model', 'gtot_w', diag%axesT1, Time, & 'gtot to West', 'm s-2', conversion=GV%m_to_H*(US%L_T_to_m_s**2)) CS%id_eta_hifreq = register_diag_field('ocean_model', 'eta_hifreq', diag%axesT1, Time, & - 'High Frequency Barotropic SSH', thickness_units, conversion=GV%H_to_m) + 'High Frequency Barotropic SSH', thickness_units, conversion=GV%H_to_MKS) CS%id_ubt_hifreq = register_diag_field('ocean_model', 'ubt_hifreq', diag%axesCu1, Time, & 'High Frequency Barotropic zonal velocity', 'm s-1', conversion=US%L_T_to_m_s) CS%id_vbt_hifreq = register_diag_field('ocean_model', 'vbt_hifreq', diag%axesCv1, Time, & 'High Frequency Barotropic meridional velocity', 'm s-1', conversion=US%L_T_to_m_s) CS%id_eta_pred_hifreq = register_diag_field('ocean_model', 'eta_pred_hifreq', diag%axesT1, Time, & - 'High Frequency Predictor Barotropic SSH', thickness_units, & - conversion=GV%H_to_m) + 'High Frequency Predictor Barotropic SSH', thickness_units, conversion=GV%H_to_MKS) CS%id_uhbt_hifreq = register_diag_field('ocean_model', 'uhbt_hifreq', diag%axesCu1, Time, & 'High Frequency Barotropic zonal transport', 'm3 s-1', & conversion=GV%H_to_m*US%L_to_m*US%L_T_to_m_s) @@ -4850,11 +4849,11 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, CS%id_frhatv1 = register_diag_field('ocean_model', 'frhatv1', diag%axesCvL, Time, & 'Predictor Fractional thickness of layers in v-columns', 'nondim') CS%id_uhbt = register_diag_field('ocean_model', 'uhbt', diag%axesCu1, Time, & - 'Barotropic zonal transport averaged over a baroclinic step', 'm3 s-1', & - conversion=GV%H_to_m*US%L_to_m*US%L_T_to_m_s) + 'Barotropic zonal transport averaged over a baroclinic step', & + 'm3 s-1', conversion=GV%H_to_m*US%L_to_m*US%L_T_to_m_s) CS%id_vhbt = register_diag_field('ocean_model', 'vhbt', diag%axesCv1, Time, & - 'Barotropic meridional transport averaged over a baroclinic step', 'm3 s-1', & - conversion=GV%H_to_m*US%L_to_m*US%L_T_to_m_s) + 'Barotropic meridional transport averaged over a baroclinic step', & + 'm3 s-1', conversion=GV%H_to_m*US%L_to_m*US%L_T_to_m_s) if (use_BT_cont_type) then CS%id_BTC_FA_u_EE = register_diag_field('ocean_model', 'BTC_FA_u_EE', diag%axesCu1, Time, & diff --git a/src/core/MOM_variables.F90 b/src/core/MOM_variables.F90 index 886ee77510..f966ab2ad2 100644 --- a/src/core/MOM_variables.F90 +++ b/src/core/MOM_variables.F90 @@ -204,7 +204,7 @@ module MOM_variables vhGM => NULL() !< Isopycnal height diffusion induced meridional volume fluxes [H L2 T-1 ~> m3 s-1 or kg s-1] ! Each of the following fields is found at nz+1 interfaces. - real, pointer :: diapyc_vel(:,:,:) => NULL() !< The net diapycnal velocity [H s-1 ~> m s-1 or kg m-2 s-1] + real, pointer :: diapyc_vel(:,:,:) => NULL() !< The net diapycnal velocity [H T-1 ~> m s-1 or kg m-2 s-1] end type cont_diag_ptrs diff --git a/src/diagnostics/MOM_diagnostics.F90 b/src/diagnostics/MOM_diagnostics.F90 index bb5243892d..5ac8777a19 100644 --- a/src/diagnostics/MOM_diagnostics.F90 +++ b/src/diagnostics/MOM_diagnostics.F90 @@ -1182,8 +1182,7 @@ subroutine calculate_energy_diagnostics(u, v, h, uh, vh, ADp, CDp, G, GV, US, CS KE_v(i,J) = vh(i,J,k) * G%dyCv(i,J) * ADp%dv_dt_dia(i,J,k) enddo ; enddo do j=js,je ; do i=is,ie - KE_h(i,j) = CS%KE(i,j,k) & - * (US%T_to_s * (CDp%diapyc_vel(i,j,k) - CDp%diapyc_vel(i,j,k+1))) + KE_h(i,j) = CS%KE(i,j,k) * (CDp%diapyc_vel(i,j,k) - CDp%diapyc_vel(i,j,k+1)) enddo ; enddo if (.not.G%symmetric) & call do_group_pass(CS%pass_KE_uv, G%domain) @@ -2000,8 +1999,8 @@ subroutine register_surface_diags(Time, G, US, IDs, diag, tv) endif IDs%id_salt_deficit = register_diag_field('ocean_model', 'salt_deficit', diag%axesT1, Time, & - 'Salt sink in ocean due to ice flux', & - 'psu m-2 s-1', conversion=US%RZ_T_to_kg_m2s) + 'Salt source in ocean required to supply excessive ice salt fluxes', & + 'ppt kg m-2 s-1', conversion=US%RZ_T_to_kg_m2s) IDs%id_Heat_PmE = register_diag_field('ocean_model', 'Heat_PmE', diag%axesT1, Time, & 'Heat flux into ocean from mass flux into ocean', & 'W m-2', conversion=US%QRZ_T_to_W_m2) @@ -2021,22 +2020,22 @@ subroutine register_transport_diags(Time, G, GV, US, IDs, diag) type(diag_ctrl), intent(inout) :: diag !< regulates diagnostic output real :: H_convert - character(len=48) :: thickness_units + character(len=48) :: thickness_units, accum_flux_units thickness_units = get_thickness_units(GV) if (GV%Boussinesq) then - H_convert = GV%H_to_m + H_convert = GV%H_to_m ; accum_flux_units = "m3" else - H_convert = GV%H_to_kg_m2 + H_convert = GV%H_to_kg_m2 ; accum_flux_units = "kg" endif ! Diagnostics related to tracer and mass transport IDs%id_uhtr = register_diag_field('ocean_model', 'uhtr', diag%axesCuL, Time, & - 'Accumulated zonal thickness fluxes to advect tracers', 'kg', & - y_cell_method='sum', v_extensive=.true., conversion=H_convert*US%L_to_m**2) + 'Accumulated zonal thickness fluxes to advect tracers', & + accum_flux_units, y_cell_method='sum', v_extensive=.true., conversion=H_convert*US%L_to_m**2) IDs%id_vhtr = register_diag_field('ocean_model', 'vhtr', diag%axesCvL, Time, & - 'Accumulated meridional thickness fluxes to advect tracers', 'kg', & - x_cell_method='sum', v_extensive=.true., conversion=H_convert*US%L_to_m**2) + 'Accumulated meridional thickness fluxes to advect tracers', & + accum_flux_units, x_cell_method='sum', v_extensive=.true., conversion=H_convert*US%L_to_m**2) IDs%id_umo = register_diag_field('ocean_model', 'umo', & diag%axesCuL, Time, 'Ocean Mass X Transport', & 'kg s-1', conversion=US%RZ_T_to_kg_m2s*US%L_to_m**2, & @@ -2054,8 +2053,8 @@ subroutine register_transport_diags(Time, G, GV, US, IDs, diag) 'kg s-1', conversion=US%RZ_T_to_kg_m2s*US%L_to_m**2, & standard_name='ocean_mass_y_transport_vertical_sum', x_cell_method='sum') IDs%id_dynamics_h = register_diag_field('ocean_model','dynamics_h', & - diag%axesTl, Time, 'Change in layer thicknesses due to horizontal dynamics', & - 'm s-1', v_extensive=.true., conversion=GV%H_to_m) + diag%axesTl, Time, 'Layer thicknesses prior to horizontal dynamics', & + 'm', v_extensive=.true., conversion=GV%H_to_m) IDs%id_dynamics_h_tendency = register_diag_field('ocean_model','dynamics_h_tendency', & diag%axesTl, Time, 'Change in layer thicknesses due to horizontal dynamics', & 'm s-1', v_extensive=.true., conversion=GV%H_to_m*US%s_to_T) diff --git a/src/parameterizations/vertical/MOM_diabatic_driver.F90 b/src/parameterizations/vertical/MOM_diabatic_driver.F90 index c96edb785c..1b27bc6904 100644 --- a/src/parameterizations/vertical/MOM_diabatic_driver.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_driver.F90 @@ -2272,7 +2272,7 @@ subroutine layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_e !$OMP parallel do default(shared) do j=js,je do K=2,nz ; do i=is,ie - CDp%diapyc_vel(i,j,K) = US%s_to_T*Idt * (ea(i,j,k) - eb(i,j,k-1)) + CDp%diapyc_vel(i,j,K) = Idt * (ea(i,j,k) - eb(i,j,k-1)) enddo ; enddo do i=is,ie CDp%diapyc_vel(i,j,1) = 0.0 @@ -2966,7 +2966,7 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di 'Layer entrainment from below per timestep', 'm', conversion=GV%H_to_m) if (.not.CS%useALEalgorithm) then CS%id_wd = register_diag_field('ocean_model', 'wd', diag%axesTi, Time, & - 'Diapycnal velocity', 'm s-1', conversion=GV%H_to_m) + 'Diapycnal velocity', 'm s-1', conversion=GV%H_to_m*US%s_to_T) if (CS%id_wd > 0) call safe_alloc_ptr(CDp%diapyc_vel,isd,ied,jsd,jed,nz+1) CS%id_dudt_dia = register_diag_field('ocean_model', 'dudt_dia', diag%axesCuL, Time, & diff --git a/src/parameterizations/vertical/MOM_diapyc_energy_req.F90 b/src/parameterizations/vertical/MOM_diapyc_energy_req.F90 index 0515f81725..23a73cb43e 100644 --- a/src/parameterizations/vertical/MOM_diapyc_energy_req.F90 +++ b/src/parameterizations/vertical/MOM_diapyc_energy_req.F90 @@ -1315,7 +1315,7 @@ subroutine diapyc_energy_req_init(Time, G, GV, US, param_file, diag, CS) CS%id_Kddt = register_diag_field('ocean_model', 'EnReqTest_Kddt', diag%axesZi, Time, & "Implicit diffusive coupling coefficient", "m", conversion=GV%H_to_m) CS%id_Kd = register_diag_field('ocean_model', 'EnReqTest_Kd', diag%axesZi, Time, & - "Diffusivity in test", "m2 s-1", conversion=US%Z_to_m**2) + "Diffusivity in test", "m2 s-1", conversion=US%Z2_T_to_m2_s) CS%id_h = register_diag_field('ocean_model', 'EnReqTest_h_lay', diag%axesZL, Time, & "Test column layer thicknesses", "m", conversion=GV%H_to_m) CS%id_zInt = register_diag_field('ocean_model', 'EnReqTest_z_int', diag%axesZi, Time, & diff --git a/src/parameterizations/vertical/MOM_geothermal.F90 b/src/parameterizations/vertical/MOM_geothermal.F90 index be390ef50f..9e8161441f 100644 --- a/src/parameterizations/vertical/MOM_geothermal.F90 +++ b/src/parameterizations/vertical/MOM_geothermal.F90 @@ -592,7 +592,7 @@ subroutine geothermal_init(Time, G, GV, US, param_file, diag, CS, useALEalgorith CS%id_internal_heat_h_tendency=register_diag_field('ocean_model', & 'internal_heat_h_tendency', diag%axesTL, Time, & 'Thickness tendency (in 3D) due to internal (geothermal) sources', & - trim(thickness_units), conversion=GV%H_to_MKS*US%s_to_T, v_extensive=.true.) + trim(thickness_units)//' s-1', conversion=GV%H_to_MKS*US%s_to_T, v_extensive=.true.) endif ; endif end subroutine geothermal_init diff --git a/src/parameterizations/vertical/MOM_vert_friction.F90 b/src/parameterizations/vertical/MOM_vert_friction.F90 index c7c9355f97..d448751137 100644 --- a/src/parameterizations/vertical/MOM_vert_friction.F90 +++ b/src/parameterizations/vertical/MOM_vert_friction.F90 @@ -1773,20 +1773,22 @@ subroutine vertvisc_init(MIS, Time, G, GV, US, param_file, diag, ADp, dirs, & 'Meridional Viscous Vertical Coupling Coefficient', 'm s-1', conversion=US%Z_to_m*US%s_to_T) CS%id_h_u = register_diag_field('ocean_model', 'Hu_visc', diag%axesCuL, Time, & - 'Thickness at Zonal Velocity Points for Viscosity', thickness_units, & - conversion=GV%H_to_m) + 'Thickness at Zonal Velocity Points for Viscosity', & + thickness_units, conversion=GV%H_to_MKS) + ! Alternately, to always give this variable in 'm' use the following line instead: + ! 'm', conversion=GV%H_to_m) CS%id_h_v = register_diag_field('ocean_model', 'Hv_visc', diag%axesCvL, Time, & - 'Thickness at Meridional Velocity Points for Viscosity', thickness_units, & - conversion=GV%H_to_m) + 'Thickness at Meridional Velocity Points for Viscosity', & + thickness_units, conversion=GV%H_to_MKS) CS%id_hML_u = register_diag_field('ocean_model', 'HMLu_visc', diag%axesCu1, Time, & - 'Mixed Layer Thickness at Zonal Velocity Points for Viscosity', thickness_units, & - conversion=GV%H_to_m) + 'Mixed Layer Thickness at Zonal Velocity Points for Viscosity', & + thickness_units, conversion=GV%H_to_MKS) CS%id_hML_v = register_diag_field('ocean_model', 'HMLv_visc', diag%axesCv1, Time, & - 'Mixed Layer Thickness at Meridional Velocity Points for Viscosity', thickness_units, & - conversion=GV%H_to_m) + 'Mixed Layer Thickness at Meridional Velocity Points for Viscosity', & + thickness_units, conversion=GV%H_to_MKS) CS%id_du_dt_visc = register_diag_field('ocean_model', 'du_dt_visc', diag%axesCuL, & Time, 'Zonal Acceleration from Vertical Viscosity', 'm s-2', conversion=US%L_T2_to_m_s2) diff --git a/src/tracer/MOM_tracer_registry.F90 b/src/tracer/MOM_tracer_registry.F90 index d8a2cb52c6..85913f8723 100644 --- a/src/tracer/MOM_tracer_registry.F90 +++ b/src/tracer/MOM_tracer_registry.F90 @@ -104,12 +104,14 @@ module MOM_tracer_registry !! names of flux diagnostics. character(len=64) :: flux_longname = "" !< A word or phrase used construct the long !! names of flux diagnostics. - real :: flux_scale= 1.0 !< A scaling factor used to convert the fluxes - !! of this tracer to its desired units. + real :: flux_scale = 1.0 !< A scaling factor used to convert the fluxes + !! of this tracer to its desired units, + !! including a factor compensating for H scaling. character(len=48) :: flux_units = "" !< The units for fluxes of this variable. character(len=48) :: conv_units = "" !< The units for the flux convergence of this tracer. real :: conv_scale = 1.0 !< A scaling factor used to convert the flux - !! convergence of this tracer to its desired units. + !! convergence of this tracer to its desired units, + !! including a factor compensating for H scaling. character(len=48) :: cmor_tendprefix = "" !< The CMOR variable prefix for tendencies of this !! tracer, required because CMOR does not follow any !! discernable pattern for these names. @@ -279,7 +281,7 @@ subroutine register_tracer(tr_ptr, Reg, param_file, HI, GV, name, longname, unit Tr%flux_units = "" if (present(flux_units)) Tr%flux_units = flux_units - Tr%flux_scale = 1.0 + Tr%flux_scale = GV%H_to_MKS if (present(flux_scale)) Tr%flux_scale = flux_scale Tr%conv_units = "" @@ -288,7 +290,7 @@ subroutine register_tracer(tr_ptr, Reg, param_file, HI, GV, name, longname, unit Tr%cmor_tendprefix = "" if (present(cmor_tendprefix)) Tr%cmor_tendprefix = cmor_tendprefix - Tr%conv_scale = 1.0 + Tr%conv_scale = GV%H_to_MKS if (present(convergence_scale)) then Tr%conv_scale = convergence_scale elseif (present(flux_scale)) then From 763177ccbf6f6aac444413d3cc349ac3aa968ccd Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Wed, 28 Apr 2021 12:21:01 -0400 Subject: [PATCH 059/112] .testing: Create python venv at compile time This patch shifts the creation of the python virtual environment to a compile-time operation. The .testing suite creates a Python virtual environment (venv) if the current environment does not include numpy and the Python netCDF4 modules. These are detected and set up at runtime rather than compile time, which can cause issues when run on compile nodes which do not have internet access since the packages need to be downloaded via Pip. This patch moves the detection and creation to compile time. Since internet access is expected for FMS and mkmf setup, it is consistent to assume internet access for pip installations. --- .testing/Makefile | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/.testing/Makefile b/.testing/Makefile index 02f6557c09..45d05cd23f 100644 --- a/.testing/Makefile +++ b/.testing/Makefile @@ -193,7 +193,7 @@ endif # Rules .PHONY: all build.regressions -all: $(foreach b,$(BUILDS),build/$(b)/MOM6) +all: $(foreach b,$(BUILDS),build/$(b)/MOM6) $(VENV_PATH) build.regressions: $(foreach b,symmetric target,build/$(b)/MOM6) # Executable @@ -361,6 +361,7 @@ check_mom6_api_mct: build/mct/mom_ocean_model_mct.o work/local-env: python3 -m venv $@ . $@/bin/activate \ + && python3 -m pip install --upgrade pip \ && pip3 install wheel \ && pip3 install cython \ && pip3 install numpy \ From def242d9a5438d48f2563862b40170cdf9c9e333 Mon Sep 17 00:00:00 2001 From: Olga Sergienko Date: Thu, 29 Apr 2021 14:59:00 -0400 Subject: [PATCH 060/112] cleaned version for symmetric memory --- src/ice_shelf/MOM_ice_shelf_dynamics.F90 | 205 +++------------------ src/ice_shelf/MOM_ice_shelf_initialize.F90 | 1 + 2 files changed, 23 insertions(+), 183 deletions(-) diff --git a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 index 056ee3c17b..d4d8c67d3c 100644 --- a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 +++ b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 @@ -42,13 +42,13 @@ module MOM_ice_shelf_dynamics !> The control structure for the ice shelf dynamics. type, public :: ice_shelf_dyn_CS ; private real, pointer, dimension(:,:) :: u_shelf => NULL() !< the zonal velocity of the ice shelf/sheet - !! on q-points (B grid) [L T-1 ~> m s-1] + !! on (C grid) [L T-1 ~> m s-1] real, pointer, dimension(:,:) :: v_shelf => NULL() !< the meridional velocity of the ice shelf/sheet - !! on q-points (B grid) [L T-1 ~> m s-1] + !! on (C grid) [L T-1 ~> m s-1] real, pointer, dimension(:,:) :: taudx_shelf => NULL() !< the driving stress of the ice shelf/sheet - !! on q-points (C grid) [Pa ~> Pa] + !! on (C grid) [Pa ~> Pa] real, pointer, dimension(:,:) :: taudy_shelf => NULL() !< the meridional stress of the ice shelf/sheet - !! on q-points (C grid) [Pa ~> Pa] + !! on (C grid) [Pa ~> Pa] real, pointer, dimension(:,:) :: u_face_mask => NULL() !< mask for velocity boundary conditions on the C-grid !! u-face - this is because the FEM cares about FACES THAT GET INTEGRATED OVER, !! not vertices. Will represent boundary conditions on computational boundary @@ -66,16 +66,16 @@ module MOM_ice_shelf_dynamics real, pointer, dimension(:,:) :: v_flux_bdry_val => NULL() !< The ice volume flux per unit face length into the cell !! through open boundary v-faces (where v_face_mask=4) [Z L T-1 ~> m2 s-1]?? ! needed where u_face_mask is equal to 4, similarly for v_face_mask - real, pointer, dimension(:,:) :: umask => NULL() !< u-mask on the actual degrees of freedom (B grid) + real, pointer, dimension(:,:) :: umask => NULL() !< u-mask on the actual degrees of freedom (C grid) !! 1=normal node, 3=inhomogeneous boundary node, !! 0 - no flow node (will also get ice-free nodes) - real, pointer, dimension(:,:) :: vmask => NULL() !< v-mask on the actual degrees of freedom (B grid) + real, pointer, dimension(:,:) :: vmask => NULL() !< v-mask on the actual degrees of freedom (C grid) !! 1=normal node, 3=inhomogeneous boundary node, !! 0 - no flow node (will also get ice-free nodes) real, pointer, dimension(:,:) :: calve_mask => NULL() !< a mask to prevent the ice shelf front from !! advancing past its initial position (but it may retreat) real, pointer, dimension(:,:) :: t_shelf => NULL() !< Vertically integrated temperature in the ice shelf/stream, - !! on corner-points (B grid) [degC] + !! on corner-points (C grid) [degC] real, pointer, dimension(:,:) :: tmask => NULL() !< A mask on tracer points that is 1 where there is ice. real, pointer, dimension(:,:) :: ice_visc => NULL() !< Glen's law ice viscosity, often in [R L4 Z T-1 ~> kg m2 s-1]. real, pointer, dimension(:,:) :: thickness_bdry_val => NULL() !< The ice thickness at an inflowing boundary [Z ~> m]. @@ -87,7 +87,7 @@ module MOM_ice_shelf_dynamics real, pointer, dimension(:,:) :: t_bdry_val => NULL() !< The ice temperature at inflowing boundaries [degC]. real, pointer, dimension(:,:) :: bed_elev => NULL() !< The bed elevation used for ice dynamics [Z ~> m]. - !! the same as bathyT, when below sea-level. + !! the same as bathyT, when below sea-level (C_grid). !!Sign convention: positive below sea-level, negative above. real, pointer, dimension(:,:) :: basal_traction => NULL() !< The area integrated nonlinear part of "linearized" @@ -232,7 +232,6 @@ subroutine register_ice_shelf_dyn_restarts(G, param_file, CS, restart_CS) integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed -! IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB IsdB = G%Isd ; IedB = G%Ied ; JsdB = G%Jsd ; JedB = G%Jed if (associated(CS)) then call MOM_error(FATAL, "MOM_ice_shelf_dyn.F90, register_ice_shelf_dyn_restarts: "// & @@ -270,10 +269,10 @@ subroutine register_ice_shelf_dyn_restarts(G, param_file, CS, restart_CS) "ice sheet/shelf v-velocity", "m s-1")!, hor_grid='Bu') call register_restart_field(CS%t_shelf, "t_shelf", .true., restart_CS, & "ice sheet/shelf vertically averaged temperature", "deg C") - ! call register_restart_field(CS%taudx_shelf, "taudx_shelf", .true., restart_CS, & - ! "ice sheet/shelf taudx-driving stress", "kPa") - ! call register_restart_field(CS%taudy_shelf, "taudy_shelf", .true., restart_CS, & - ! "ice sheet/shelf taudy-driving stress", "kPa") + call register_restart_field(CS%taudx_shelf, "taudx_shelf", .true., restart_CS, & + "ice sheet/shelf taudx-driving stress", "kPa") + call register_restart_field(CS%taudy_shelf, "taudy_shelf", .true., restart_CS, & + "ice sheet/shelf taudy-driving stress", "kPa") call register_restart_field(CS%OD_av, "OD_av", .true., restart_CS, & "Average open ocean depth in a cell","m") call register_restart_field(CS%ground_frac, "ground_frac", .true., restart_CS, & @@ -317,7 +316,6 @@ subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_ logical :: debug integer :: i, j, is, ie, js, je, isd, ied, jsd, jed, Isdq, Iedq, Jsdq, Jedq, iters -! Isdq = G%isdB ; Iedq = G%iedB ; Jsdq = G%jsdB ; Jedq = G%jedB Isdq = G%isd ; Iedq = G%ied ; Jsdq = G%jsd ; Jedq = G%jed isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed @@ -503,8 +501,6 @@ subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_ call pass_var(CS%ground_frac,G%domain) call pass_var(CS%ice_visc,G%domain) call pass_var(CS%basal_traction, G%domain) -! call pass_vector(CS%u_shelf, CS%v_shelf, G%domain, TO_ALL, BGRID_NE) -! call pass_vector(CS%u_shelf, CS%v_shelf, G%domain)!, TO_ALL, CGRID_NE) call pass_var(CS%u_shelf, G%domain) call pass_var(CS%v_shelf, G%domain) endif @@ -534,11 +530,6 @@ subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_ enddo ; enddo call pass_var(CS%calve_mask,G%domain) endif -! call initialize_ice_shelf_boundary_channel(CS%u_face_mask_bdry, CS%v_face_mask_bdry, & -! CS%u_flux_bdry_val, CS%v_flux_bdry_val, CS%u_bdry_val, CS%v_bdry_val, CS%u_shelf, CS%v_shelf,& -! CS%h_bdry_val, & -! CS%thickness_bdry_val, ISS%hmask, ISS%h_shelf, G, & -! US, param_file ) call initialize_ice_shelf_boundary_from_file(CS%u_face_mask_bdry, CS%v_face_mask_bdry, & CS%u_bdry_val, CS%v_bdry_val, CS%umask, CS%vmask, CS%h_bdry_val, & CS%thickness_bdry_val, ISS%hmask, ISS%h_shelf, G, US, param_file ) @@ -563,13 +554,9 @@ subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_ call update_velocity_masks(CS, G, ISS%hmask, CS%umask, CS%vmask, CS%u_face_mask, CS%v_face_mask) ! Register diagnostics. -! CS%id_u_shelf = register_diag_field('ice_shelf_model','u_shelf',CS%diag%axesCu1, Time, & -! 'x-velocity of ice', 'm yr-1', conversion=365.0*86400.0*US%L_T_to_m_s) -! CS%id_v_shelf = register_diag_field('ice_shelf_model','v_shelf',CS%diag%axesCv1, Time, & -! 'y-velocity of ice', 'm yr-1', conversion=365.0*86400.0*US%L_T_to_m_s) - CS%id_u_shelf = register_diag_field('ice_shelf_model','u_shelf',CS%diag%axesT1, Time, & + CS%id_u_shelf = register_diag_field('ice_shelf_model','u_shelf',CS%diag%axesCu1, Time, & 'x-velocity of ice', 'm yr-1', conversion=365.0*86400.0*US%L_T_to_m_s) - CS%id_v_shelf = register_diag_field('ice_shelf_model','v_shelf',CS%diag%axesT1, Time, & + CS%id_v_shelf = register_diag_field('ice_shelf_model','v_shelf',CS%diag%axesCv1, Time, & 'y-velocity of ice', 'm yr-1', conversion=365.0*86400.0*US%L_T_to_m_s) CS%id_taudx_shelf = register_diag_field('ice_shelf_model','taudx_shelf',CS%diag%axesT1, Time, & 'x-driving stress of ice', 'kPa', conversion=1.e-9*US%L_T_to_m_s) @@ -772,8 +759,6 @@ subroutine ice_shelf_advect(CS, ISS, G, time_step, Time) ! into partial cells real, dimension(SZDI_(G),SZDJ_(G)) :: h_after_uflux, h_after_vflux ! Ice thicknesses [Z ~> m]. -! real, dimension(SZDIB_(G),SZDJ_(G)) :: uh_ice ! The accumulated zonal ice volume flux [Z L2 ~> m3] -! real, dimension(SZDI_(G),SZDJB_(G)) :: vh_ice ! The accumulated meridional ice volume flux [Z L2 ~> m3] real, dimension(SZDI_(G),SZDJ_(G)) :: uh_ice ! The accumulated zonal ice volume flux [Z L2 ~> m3] real, dimension(SZDI_(G),SZDJ_(G)) :: vh_ice ! The accumulated meridional ice volume flux [Z L2 ~> m3] type(loop_bounds_type) :: LB @@ -848,29 +833,18 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf,taudx,taudy, ite !! the ice-shelf state type(ocean_grid_type), intent(inout) :: G !< The grid structure used by the ice shelf. type(unit_scale_type), intent(in) :: US !< A structure containing unit conversion factors -! real, dimension(SZDIB_(G),SZDJB_(G)), & real, dimension(SZDI_(G),SZDJ_(G)), & intent(inout) :: u_shlf !< The zonal ice shelf velocity at vertices [L T-1 ~> m s-1] -! real, dimension(SZDIB_(G),SZDJB_(G)), & real, dimension(SZDI_(G),SZDJ_(G)), & intent(inout) :: v_shlf !< The meridional ice shelf velocity at vertices [L T-1 ~> m s-1] integer, intent(out) :: iters !< The number of iterations used in the solver. type(time_type), intent(in) :: Time !< The current model time -! real, dimension(SZDIB_(G),SZDJB_(G)), & real, dimension(SZDI_(G),SZDJ_(G)), & intent(out) :: taudx !< Driving x-stress at q-points [R L3 Z T-2 ~> kg m s-2] -! real, dimension(SZDIB_(G),SZDJB_(G)), & real, dimension(SZDI_(G),SZDJ_(G)), & intent(out) :: taudy !< Driving y-stress at q-points [R L3 Z T-2 ~> kg m s-2] -! real, dimension(SZDIB_(G),SZDJB_(G)) :: u_bdry_cont ! Boundary u-stress contribution [R L3 Z T-2 ~> kg m s-2] -! real, dimension(SZDIB_(G),SZDJB_(G)) :: v_bdry_cont ! Boundary v-stress contribution [R L3 Z T-2 ~> kg m s-2] -! real, dimension(SZDIB_(G),SZDJB_(G)) :: Au, Av ! The retarding lateral stress contributions [R L3 Z T-2 ~> kg m s-2] -! real, dimension(SZDIB_(G),SZDJB_(G)) :: err_u, err_v -! real, dimension(SZDIB_(G),SZDJB_(G)) :: u_last, v_last ! Previous velocities [L T-1 ~> m s-1] -! real, dimension(SZDIB_(G),SZDJB_(G)) :: H_node ! Ice shelf thick)), & -! intent(out) :: taudy !< Driving y-stress at q-points - ![R L3 Z T-2 ~> kg m s-2]ness at corners [Z ~> m]. + ![R L3 Z T-2 ~> kg m s-2]ness at corners [Z ~> m]. real, dimension(SZDI_(G),SZDJ_(G)) :: u_bdry_cont ! Boundary u-stress contribution [R L3 Z T-2 ~> kg m s-2] real, dimension(SZDI_(G),SZDJ_(G)) :: v_bdry_cont ! Boundary v-stress contribution [R L3 Z T-2 ~> kg m s-2] real, dimension(SZDI_(G),SZDJ_(G)) :: Au, Av ! The retarding lateral stress contributions [R L3 Z T-2 ~> kg m s-2] @@ -918,9 +892,9 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf,taudx,taudy, ite enddo call calc_shelf_driving_stress(CS, ISS, G, US, taudx, taudy, CS%OD_av) -! call pass_vector(taudx, taudy, G%domain, TO_ALL, BGRID_NE) ! call pass_var(taudx, G%domain) ! call pass_var(taudy, G%domain) + ! This is to determine which cells contain the grounding line, the criterion being that the cell ! is ice-covered, with some nodes floating and some grounded flotation condition is estimated by ! assuming topography is cellwise constant and H is bilinear in a cell; floating where @@ -965,7 +939,6 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf,taudx,taudy, ite call calc_shelf_taub(CS, ISS, G, US, u_shlf, v_shlf) call pass_var(CS%basal_traction, G%domain) -! call pass_vector(CS%ice_visc, CS%basal_traction, G%domain, TO_ALL, CGRID_NE) ! This makes sure basal stress is only applied when it is supposed to be do j=G%jsd,G%jed ; do i=G%isd,G%ied CS%basal_traction(i,j) = CS%basal_traction(i,j) * CS%ground_frac(i,j) @@ -979,7 +952,6 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf,taudx,taudy, ite call CG_action(Au, Av, u_shlf, v_shlf, Phi, Phisub, CS%umask, CS%vmask, ISS%hmask, H_node, & CS%ice_visc, float_cond, G%bathyT, CS%basal_traction, & G, US, G%isc-1, G%iec+1, G%jsc-1, G%jec+1, rhoi_rhow) -! call pass_vector(Au,Av,G%domain) call pass_var(Au,G%domain) call pass_var(Av,G%domain) if (CS%nonlin_solve_err_mode == 1) then @@ -1057,7 +1029,6 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf,taudx,taudy, ite elseif (CS%nonlin_solve_err_mode == 2) then max_vel = 0 ; tempu = 0 ; tempv = 0 -! do J=G%jscB,G%jecB ; do I=G%iscB,G%iecB do J=G%jsc,G%jec ; do I=G%isc,G%iec if (CS%umask(I,J) == 1) then err_tempu = ABS(u_last(I,J)-u_shlf(I,J)) @@ -1108,16 +1079,6 @@ subroutine ice_shelf_solve_inner(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, H !! the ice-shelf state type(ocean_grid_type), intent(inout) :: G !< The grid structure used by the ice shelf. type(unit_scale_type), intent(in) :: US !< A structure containing unit conversion factors -! real, dimension(SZDIB_(G),SZDJB_(G)), & -! intent(inout) :: u_shlf !< The zonal ice shelf velocity at vertices [L T-1 ~> m s-1] -! real, dimension(SZDIB_(G),SZDJB_(G)), & -! intent(inout) :: v_shlf !< The meridional ice shelf velocity at vertices [L T-1 ~> m s-1] -! real, dimension(SZDIB_(G),SZDJB_(G)), & -! intent(in) :: taudx !< The x-direction driving stress [R L3 Z T-2 ~> kg m s-2] -! real, dimension(SZDIB_(G),SZDJB_(G)), & -! intent(in) :: taudy !< The y-direction driving stress [R L3 Z T-2 ~> kg m s-2] -! real, dimension(SZDIB_(G),SZDJB_(G)), & -! intent(in) :: H_node !< The ice shelf thickness at nodal (corner) real, dimension(SZDI_(G),SZDJ_(G)), & intent(inout) :: u_shlf !< The zonal ice shelf velocity at vertices [L T-1 ~> m s-1] real, dimension(SZDI_(G),SZDJ_(G)), & @@ -1155,7 +1116,6 @@ subroutine ice_shelf_solve_inner(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, H ! assumed - u, v, taud, visc, basal_traction are valid on the halo -! real, dimension(SZDIB_(G),SZDJB_(G)) :: & real, dimension(SZDI_(G),SZDJ_(G)) :: & Ru, Rv, & ! Residuals in the stress calculations [R L3 Z T-2 ~> m kg s-2] Ru_old, Rv_old, & ! Previous values of Ru and Rv [R L3 Z T-2 ~> m kg s-2] @@ -1179,8 +1139,6 @@ subroutine ice_shelf_solve_inner(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, H integer :: Is_sum, Js_sum, Ie_sum, Je_sum ! Loop bounds for global sums or arrays starting at 1. integer :: isdq, iedq, jsdq, jedq, iscq, iecq, jscq, jecq, nx_halo, ny_halo -! isdq = G%isdB ; iedq = G%iedB ; jsdq = G%jsdB ; jedq = G%jedB -! iscq = G%iscB ; iecq = G%iecB ; jscq = G%jscB ; jecq = G%jecB isdq = G%isd ; iedq = G%ied ; jsdq = G%jsd ; jedq = G%jed iscq = G%isc ; iecq = G%iec ; jscq = G%jsc ; jecq = G%jec ny_halo = G%domain%njhalo ; nx_halo = G%domain%nihalo @@ -1195,19 +1153,13 @@ subroutine ice_shelf_solve_inner(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, H dot_p1 = 0 ! Determine the loop limits for sums, bearing in mind that the arrays will be starting at 1. -! Is_sum = G%isc + (1-G%IsdB) -! Ie_sum = G%iecB + (1-G%IsdB) Is_sum = G%isc + (1-G%Isd) Ie_sum = G%iec + (1-G%Isd) ! Include the edge if tile is at the western bdry; Should add a test to avoid this if reentrant. -! if (G%isc+G%idg_offset==G%isg) Is_sum = G%IscB + (1-G%IsdB) if (G%isc+G%idg_offset==G%isg) Is_sum = G%Isc + (1-G%Isd) -! Js_sum = G%jsc + (1-G%JsdB) -! Je_sum = G%jecB + (1-G%JsdB) Js_sum = G%jsc + (1-G%Jsd) Je_sum = G%jec + (1-G%Jsd) ! Include the edge if tile is at the southern bdry; Should add a test to avoid this if reentrant. -! if (G%jsc+G%jdg_offset==G%jsg) Js_sum = G%JscB + (1-G%JsdB) if (G%jsc+G%jdg_offset==G%jsg) Js_sum = G%Jsc + (1-G%Jsd) call apply_boundary_values(CS, ISS, G, US, time, Phisub, H_node, CS%ice_visc, & CS%basal_traction, float_cond, rhoi_rhow, ubd, vbd) @@ -1215,32 +1167,23 @@ subroutine ice_shelf_solve_inner(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, H RHSu(:,:) = taudx(:,:) - ubd(:,:) RHSv(:,:) = taudy(:,:) - vbd(:,:) -! call pass_vector(RHSu, RHSv, G%domain, TO_ALL, BGRID_NE) -! call pass_vector(RHSu, RHSv, G%domain, TO_ALL, CGRID_NE) -! call pass_vector(RHSu, RHSv, G%domain) call pass_var(RHSu,G%domain) call pass_var(RHSv, G%domain) - call matrix_diagonal(CS, G, US, float_cond, H_node, CS%ice_visc, CS%basal_traction, & + call matrix_diagonal(CS, G, US, float_cond, H_node, CS%ice_visc, CS%basal_traction, & hmask, rhoi_rhow, Phisub, DIAGu, DIAGv) -! call pass_vector(DIAGu, DIAGv, G%domain, TO_ALL, BGRID_NE) -! call pass_vector(DIAGu, DIAGv, G%domain, TO_ALL, CGRID_NE) -! call pass_vector(DIAGu, DIAGv, G%domain) call pass_var(DIAGu, G%domain) call pass_var(DIAGv, G%domain) - call CG_action(Au, Av, u_shlf, v_shlf, Phi, Phisub, CS%umask, CS%vmask, hmask, & + call CG_action(Au, Av, u_shlf, v_shlf, Phi, Phisub, CS%umask, CS%vmask, hmask, & H_node, CS%ice_visc, float_cond, G%bathyT, CS%basal_traction, & G, US, isc-1, iec+1, jsc-1, jec+1, rhoi_rhow) -! call pass_vector(Au, Av, G%domain, TO_ALL, BGRID_NE) -! call pass_vector(Au, Av, G%domain, TO_ALL, CGRID_NE) -! call pass_vector(Au, Av, G%domain) call pass_var(Au, G%domain) call pass_var(Av, G%domain) - Ru(:,:) = (RHSu(:,:) - Au(:,:)) - Rv(:,:) = (RHSv(:,:) - Av(:,:)) + Ru(:,:) = (RHSu(:,:) - Au(:,:)) + Rv(:,:) = (RHSv(:,:) - Av(:,:)) resid_scale = US%L_to_m**2*US%s_to_T*US%RZ_to_kg_m2*US%L_T_to_m_s**2 resid2_scale = (US%RZ_to_kg_m2*US%L_to_m*US%L_T_to_m_s**2)**2 @@ -1293,9 +1236,6 @@ subroutine ice_shelf_solve_inner(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, H ! Au, Av valid region moves in by 1 -! call pass_vector(Au,Av,G%domain, TO_ALL, BGRID_NE) -! call pass_vector(Au,Av,G%domain, TO_ALL, CGRID_NE) -! call pass_vector(Au,Av,G%domain) call pass_var(Au,G%domain) call pass_var(Av,G%domain) sum_vec(:,:) = 0.0 ; sum_vec_2(:,:) = 0.0 @@ -1400,19 +1340,10 @@ subroutine ice_shelf_solve_inner(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, H if (cg_halo == 0) then ! pass vectors -! call pass_vector(Du, Dv, G%domain, TO_ALL, CGRID_NE) -! call pass_vector(u_shlf, v_shlf, G%domain, TO_ALL, CGRID_NE) -! call pass_vector(Du, Dv, G%domain, TO_ALL, BGRID_NE) -! call pass_vector(u_shlf, v_shlf, G%domain, TO_ALL, BGRID_NE) -! call pass_vector(Du, Dv, G%domain) call pass_var(Du, G%domain) call pass_var(Dv, G%domain) -! call pass_vector(u_shlf, v_shlf, G%domain) call pass_var(u_shlf, G%domain) call pass_var(v_shlf, G%domain) -! call pass_vector(Ru, Rv, G%domain, TO_ALL, BGRID_NE) -! call pass_vector(Ru, Rv, G%domain, TO_ALL, CGRID_NE) -! call pass_vector(Ru, Rv, G%domain) call pass_var(Ru, G%domain) call pass_var(Rv, G%domain) cg_halo = 3 @@ -1436,9 +1367,6 @@ subroutine ice_shelf_solve_inner(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, H enddo enddo -! call pass_vector(u_shlf, v_shlf, G%domain, TO_ALL, CGRID_NE) -! call pass_vector(u_shlf, v_shlf, G%domain, TO_ALL, BGRID_NE) -! call pass_vector(u_shlf, v_shlf, G%domain, TO_ALL) call pass_var(u_shlf, G%domain) call pass_var(v_shlf, G%domain) if (conv_flag == 0) then @@ -1460,7 +1388,6 @@ subroutine ice_shelf_advect_thickness_x(CS, G, LB, time_step, hmask, h0, h_after real, dimension(SZDI_(G),SZDJ_(G)), & intent(inout) :: h_after_uflux !< The ice shelf thicknesses after !! the zonal mass fluxes [Z ~> m]. -! real, dimension(SZDIB_(G),SZDJ_(G)), & real, dimension(SZDI_(G),SZDJ_(G)), & intent(inout) :: uh_ice !< The accumulated zonal ice volume flux [Z L2 ~> m3] @@ -1544,8 +1471,6 @@ subroutine ice_shelf_advect_thickness_y(CS, G, LB, time_step, hmask, h0, h_after real, dimension(SZDI_(G),SZDJ_(G)), & intent(inout) :: h_after_vflux !< The ice shelf thicknesses after !! the meridional mass fluxes [Z ~> m]. -! real, dimension(SZDI_(G),SZDJB_(G)), & -! intent(inout) :: vh_ice !< The accumulated meridional ice volume flux [Z L2 ~> m3] real, dimension(SZDI_(G),SZDJ_(G)), & intent(inout) :: vh_ice !< The accumulated meridional ice volume flux [Z L2 ~> m3] @@ -1621,10 +1546,6 @@ subroutine shelf_advance_front(CS, ISS, G, hmask, uh_ice, vh_ice) real, dimension(SZDI_(G),SZDJ_(G)), & intent(inout) :: hmask !< A mask indicating which tracer points are !! partly or fully covered by an ice-shelf -! real, dimension(SZDIB_(G),SZDJ_(G)), & -! intent(inout) :: uh_ice !< The accumulated zonal ice volume flux [Z L2 ~> m3] -! real, dimension(SZDI_(G),SZDJB_(G)), & -! intent(inout) :: vh_ice !< The accumulated meridional ice volume flux [Z L2 ~> m3] real, dimension(SZDI_(G),SZDJ_(G)), & intent(inout) :: uh_ice !< The accumulated zonal ice volume flux [Z L2 ~> m3] real, dimension(SZDI_(G),SZDJ_(G)), & @@ -1868,10 +1789,8 @@ subroutine calc_shelf_driving_stress(CS, ISS, G, US, taudx, taudy, OD) type(unit_scale_type), intent(in) :: US !< A structure containing unit conversion factors real, dimension(SZDI_(G),SZDJ_(G)), & intent(in) :: OD !< ocean floor depth at tracer points [Z ~> m]. -! real, dimension(SZDIB_(G),SZDJB_(G)), & real, dimension(SZDI_(G),SZDJ_(G)), & intent(inout) :: taudx !< X-direction driving stress at q-points [kg L s-2 ~> kg m s-2] -! real, dimension(SZDIB_(G),SZDJB_(G)), & real, dimension(SZDI_(G),SZDJ_(G)), & intent(inout) :: taudy !< Y-direction driving stress at q-points [kg L s-2 ~> kg m s-2] ! This will become [R L3 Z T-2 ~> kg m s-2] @@ -1902,14 +1821,10 @@ subroutine calc_shelf_driving_stress(CS, ISS, G, US, taudx, taudy, OD) integer :: i_off, j_off isc = G%isc ; jsc = G%jsc ; iec = G%iec ; jec = G%jec -! iscq = G%iscB ; iecq = G%iecB ; jscq = G%jscB ; jecq = G%jecB iscq = G%isc ; iecq = G%iec ; jscq = G%jsc ; jecq = G%jec isd = G%isd ; jsd = G%jsd -! iegq = G%iegB ; jegq = G%jegB iegq = G%ieg ; jegq = G%jeg -! gisc = G%domain%nihalo+1 ; gjsc = G%domain%njhalo+1 gisc = 1 ; gjsc = 1 -! giec = G%domain%niglobal+G%domain%nihalo ; gjec = G%domain%njglobal+G%domain%njhalo giec = G%domain%niglobal ; gjec = G%domain%njglobal is = iscq - 1; js = jscq - 1 i_off = G%idg_offset ; j_off = G%jdg_offset @@ -1921,7 +1836,6 @@ subroutine calc_shelf_driving_stress(CS, ISS, G, US, taudx, taudy, OD) ! prelim - go through and calculate S ! or is this faster? - !BASE(:,:) = -G%bathyT(:,:) + OD(:,:) BASE(:,:) = -CS%bed_elev(:,:) + OD(:,:) S(:,:) = BASE(:,:) + ISS%h_shelf(:,:) @@ -2153,10 +2067,6 @@ subroutine CG_action(uret, vret, u_shlf, v_shlf, Phi, Phisub, umask, vmask, hmas ice_visc, float_cond, bathyT, basal_trac, G, US, is, ie, js, je, dens_ratio) type(ocean_grid_type), intent(in) :: G !< The grid structure used by the ice shelf. -! real, dimension(G%IsdB:G%IedB,G%JsdB:G%JedB), & -! intent(inout) :: uret !< The retarding stresses working at u-points [R L3 Z T-2 ~> kg m s-2]. -! real, dimension(G%IsdB:G%IedB,G%JsdB:G%JedB), & -! intent(inout) :: vret !< The retarding stresses working at v-points [R L3 Z T-2 ~> kg m s-2]. real, dimension(SZDI_(G),SZDJ_(G)), & intent(inout) :: uret !< The retarding stresses working at u-points [R L3 Z T-2 ~> kg m s-2]. real, dimension(SZDI_(G),SZDJ_(G)), & @@ -2167,19 +2077,6 @@ subroutine CG_action(uret, vret, u_shlf, v_shlf, Phi, Phisub, umask, vmask, hmas real, dimension(:,:,:,:,:,:), & intent(in) :: Phisub !< Quadrature structure weights at subgridscale !! locations for finite element calculations [nondim] -! real, dimension(SZDIB_(G),SZDJB_(G)), & -! intent(in) :: u_shlf !< The zonal ice shelf velocity at vertices [L T-1 ~> m s-1] -! real, dimension(SZDIB_(G),SZDJB_(G)), & -! intent(in) :: v_shlf !< The meridional ice shelf velocity at vertices [L T-1 ~> m s-1] -! real, dimension(SZDIB_(G),SZDJB_(G)), & -! intent(in) :: umask !< A coded mask indicating the nature of the - !! zonal flow at the corner point -! real, dimension(SZDIB_(G),SZDJB_(G)), & -! intent(in) :: vmask !< A coded mask indicating the nature of the - !! meridional flow at the corner point -! real, dimension(SZDIB_(G),SZDJB_(G)), & -! intent(in) :: H_node !< The ice shelf thickness at nodal (corner) - !! points [Z ~> m]. real, dimension(SZDI_(G),SZDJ_(G)), & intent(in) :: hmask !< A mask indicating which tracer points are real, dimension(SZDI_(G),SZDJ_(G)), & @@ -2197,7 +2094,6 @@ subroutine CG_action(uret, vret, u_shlf, v_shlf, Phi, Phisub, umask, vmask, hmas intent(in) :: H_node !< The ice shelf thickness at nodal (corner) !! points [Z ~> m]. !! partly or fully covered by an ice-shelf -! real, dimension(SZDIB_(G),SZDJB_(G)), & real, dimension(SZDI_(G),SZDJ_(G)), & intent(in) :: ice_visc !< A field related to the ice viscosity from Glen's !! flow law [R L4 Z T-1 ~> kg m2 s-1]. The exact form @@ -2207,7 +2103,6 @@ subroutine CG_action(uret, vret, u_shlf, v_shlf, Phi, Phisub, umask, vmask, hmas !! shelf is floating: 0 if floating, 1 if not. real, dimension(SZDI_(G),SZDJ_(G)), & intent(in) :: bathyT !< The depth of ocean bathymetry at tracer points [Z ~> m]. - !real, dimension(SZDIB_(G),SZDJB_(G)), & real, dimension(SZDI_(G),SZDJ_(G)), & intent(in) :: basal_trac !< A field related to the nonlinear part of the !! "linearized" basal stress [R Z T-1 ~> kg m-2 s-1]. @@ -2370,16 +2265,13 @@ subroutine matrix_diagonal(CS, G, US, float_cond, H_node, ice_visc, basal_trac, real, dimension(SZDI_(G),SZDJ_(G)), & intent(in) :: float_cond !< An array indicating where the ice !! shelf is floating: 0 if floating, 1 if not. -! real, dimension(SZDIB_(G),SZDJB_(G)), & real, dimension(SZDI_(G),SZDJ_(G)), & intent(in) :: H_node !< The ice shelf thickness at nodal !! (corner) points [Z ~> m]. -! real, dimension(SZDIB_(G),SZDJB_(G)), & real, dimension(SZDI_(G),SZDJ_(G)), & intent(in) :: ice_visc !< A field related to the ice viscosity from Glen's !! flow law [R L4 Z T-1 ~> kg m2 s-1]. The exact form !! and units depend on the basal law exponent. - !real, dimension(SZDIB_(G),SZDJB_(G)), & real, dimension(SZDI_(G),SZDJ_(G)), & intent(in) :: basal_trac !< A field related to the nonlinear part of the !! "linearized" basal stress [R Z T-1 ~> kg m-2 s-1]. @@ -2390,11 +2282,6 @@ subroutine matrix_diagonal(CS, G, US, float_cond, H_node, ice_visc, basal_trac, !! of seawater [nondim] real, dimension(:,:,:,:,:,:), intent(in) :: Phisub !< Quadrature structure weights at subgridscale !! locations for finite element calculations [nondim] -! real, dimension(SZDIB_(G),SZDJB_(G)), & -! intent(inout) :: u_diagonal !< The diagonal elements of the u-velocity - !! matrix from the left-hand side of the solver [R L2 Z T-1 ~> kg s-1] -! real, dimension(SZDIB_(G),SZDJB_(G)), & -! intent(inout) :: v_diagonal !< The diagonal elements of the v-velocity !! matrix from the left-hand side of the solver [R L2 Z T-1 ~> kg s-1] real, dimension(SZDI_(G),SZDJ_(G)), & intent(inout) :: u_diagonal !< The diagonal elements of the u-velocity @@ -2526,20 +2413,13 @@ subroutine apply_boundary_values(CS, ISS, G, US, time, Phisub, H_node, ice_visc, real, dimension(:,:,:,:,:,:), & intent(in) :: Phisub !< Quadrature structure weights at subgridscale !! locations for finite element calculations [nondim] -! real, dimension(SZDIB_(G),SZDJB_(G)), & -! intent(in) :: H_node !< The ice shelf thickness at nodal -! !! (corner) points [Z ~> m]. real, dimension(SZDI_(G),SZDJ_(G)), & intent(in) :: H_node !< The ice shelf thickness at nodal !! (corner) points [Z ~> m]. -! real, dimension(SZDIB_(G),SZDJB_(G)), & real, dimension(SZDI_(G),SZDJ_(G)), & intent(in) :: ice_visc !< A field related to the ice viscosity from Glen's !! flow law. The exact form and units depend on the !! basal law exponent. [R L4 Z T-1 ~> kg m2 s-1]. -! real, dimension(SZDIB_(G),SZDJB_(G)), & -! intent(in) :: basal_trac !< A field related to the nonlinear part of the -! !! "linearized" basal stress [R Z T-1 ~> kg m-2 s-1]. real, dimension(SZDI_(G),SZDJ_(G)), & intent(in) :: basal_trac !< A field related to the nonlinear part of the !! "linearized" basal stress [R Z T-1 ~> kg m-2 s-1]. @@ -2548,12 +2428,6 @@ subroutine apply_boundary_values(CS, ISS, G, US, time, Phisub, H_node, ice_visc, !! shelf is floating: 0 if floating, 1 if not. real, intent(in) :: dens_ratio !< The density of ice divided by the density !! of seawater, nondimensional -! real, dimension(SZDIB_(G),SZDJB_(G)), & -! intent(inout) :: u_bdry_contr !< Zonal force contributions due to the - !! open boundaries [R L3 Z T-2 ~> kg m s-2] -! real, dimension(SZDIB_(G),SZDJB_(G)), & -! intent(inout) :: v_bdry_contr !< Meridional force contributions due to the -! !! open boundaries [R L3 Z T-2 ~> kg m s-2] real, dimension(SZDI_(G),SZDJ_(G)), & intent(inout) :: u_bdry_contr !< Zonal force contributions due to the !! open boundaries [R L3 Z T-2 ~> kg m s-2] @@ -2667,9 +2541,6 @@ subroutine apply_boundary_values(CS, ISS, G, US, time, Phisub, H_node, ice_visc, endif endif ; enddo ; enddo -! call pass_vector(u_bdry_contr, v_bdry_contr, G%domain, TO_ALL, CGRID_NE) -! call pass_vector(u_bdry_contr, v_bdry_contr, G%domain, TO_ALL, BGRID_NE) -! call pass_vector(u_bdry_contr, v_bdry_contr, G%domain, TO_ALL) call pass_var(u_bdry_contr, G%domain) call pass_var(v_bdry_contr, G%domain) end subroutine apply_boundary_values @@ -2682,10 +2553,7 @@ subroutine calc_shelf_visc(CS, ISS, G, US, u_shlf, v_shlf) !! the ice-shelf state type(ocean_grid_type), intent(in) :: G !< The grid structure used by the ice shelf. type(unit_scale_type), intent(in) :: US !< A structure containing unit conversion factors -! real, dimension(G%IsdB:G%IedB,G%JsdB:G%JedB), & -! intent(inout) :: u_shlf !< The zonal ice shelf velocity [L T-1 ~> m s-1]. -! real, dimension(G%IsdB:G%IedB,G%JsdB:G%JedB), & -! intent(inout) :: v_shlf !< The meridional ice shelf velocity [L T-1 ~> m s-1]. + real, dimension(G%Isd:G%Ied,G%Jsd:G%Jed), & intent(inout) :: u_shlf !< The zonal ice shelf velocity [L T-1 ~> m s-1]. real, dimension(G%Isd:G%Ied,G%Jsd:G%Jed), & @@ -2697,7 +2565,6 @@ subroutine calc_shelf_visc(CS, ISS, G, US, u_shlf, v_shlf) ! also this subroutine updates the nonlinear part of the basal traction ! this may be subject to change later... to make it "hybrid" -! real, dimension(SZDIB_(G),SZDJB_(G)) :: eII, ux, uy, vx, vy integer :: i, j, iscq, iecq, jscq, jecq, isd, jsd, ied, jed, iegq, jegq, iq, jq integer :: giec, gjec, gisc, gjsc, cnt, isc, jsc, iec, jec, is, js, i_off, j_off real :: Visc_coef, n_g @@ -2705,13 +2572,10 @@ subroutine calc_shelf_visc(CS, ISS, G, US, u_shlf, v_shlf) real :: eps_min, dxh, dyh ! Velocity shears [T-1 ~> s-1] real, dimension(8,4) :: Phi real, dimension(2) :: xquad -! real :: umid, vmid, unorm ! Velocities [L T-1 ~> m s-1] isc = G%isc ; jsc = G%jsc ; iec = G%iec ; jec = G%jec -! iscq = G%iscB ; iecq = G%iecB ; jscq = G%jscB ; jecq = G%jecB iscq = G%isc ; iecq = G%iec ; jscq = G%jsc ; jecq = G%jec isd = G%isd ; jsd = G%jsd ; ied = G%ied ; jed = G%jed -! iegq = G%iegB ; jegq = G%jegB iegq = G%ieg ; jegq = G%jeg gisc = G%domain%nihalo+1 ; gjsc = G%domain%njhalo+1 giec = G%domain%niglobal+gisc ; gjec = G%domain%njglobal+gjsc @@ -2748,10 +2612,7 @@ subroutine calc_shelf_taub(CS, ISS, G, US, u_shlf, v_shlf) !! the ice-shelf state type(ocean_grid_type), intent(in) :: G !< The grid structure used by the ice shelf. type(unit_scale_type), intent(in) :: US !< A structure containing unit conversion factors -! real, dimension(G%IsdB:G%IedB,G%JsdB:G%JedB), & -! intent(inout) :: u_shlf !< The zonal ice shelf velocity [L T-1 ~> m s-1]. -! real, dimension(G%IsdB:G%IedB,G%JsdB:G%JedB), & -! intent(inout) :: v_shlf !< The meridional ice shelf velocity [L T-1 ~> m s-1]. + real, dimension(G%Isd:G%Ied,G%Jsd:G%Jed), & intent(inout) :: u_shlf !< The zonal ice shelf velocity [L T-1 ~> m s-1]. real, dimension(G%Isd:G%Ied,G%Jsd:G%Jed), & @@ -2766,10 +2627,8 @@ subroutine calc_shelf_taub(CS, ISS, G, US, u_shlf, v_shlf) real :: umid, vmid, unorm, eps_min ! Velocities [L T-1 ~> m s-1] isc = G%isc ; jsc = G%jsc ; iec = G%iec ; jec = G%jec -! iscq = G%iscB ; iecq = G%iecB ; jscq = G%jscB ; jecq = G%jecB iscq = G%isc ; iecq = G%iec ; jscq = G%jsc ; jecq = G%jec isd = G%isd ; jsd = G%jsd ; ied = G%ied ; jed = G%jed -! iegq = G%iegB ; jegq = G%jegB iegq = G%ieg ; jegq = G%jeg gisc = G%domain%nihalo+1 ; gjsc = G%domain%njhalo+1 giec = G%domain%niglobal+gisc ; gjec = G%domain%njglobal+gjsc @@ -3052,22 +2911,12 @@ subroutine update_velocity_masks(CS, G, hmask, umask, vmask, u_face_mask, v_face real, dimension(SZDI_(G),SZDJ_(G)), & intent(in) :: hmask !< A mask indicating which tracer points are !! partly or fully covered by an ice-shelf -! real, dimension(SZDIB_(G),SZDJB_(G)), & -! intent(out) :: umask !< A coded mask indicating the nature of the -! !! zonal flow at the corner point -! real, dimension(SZDIB_(G),SZDJB_(G)), & -! intent(out) :: vmask !< A coded mask indicating the nature of the -! !! meridional flow at the corner point real, dimension(SZDI_(G),SZDJ_(G)), & intent(out) :: umask !< A coded mask indicating the nature of the !! zonal flow at the corner point real, dimension(SZDI_(G),SZDJ_(G)), & intent(out) :: vmask !< A coded mask indicating the nature of the !! meridional flow at the corner point -! real, dimension(SZDIB_(G),SZDJ_(G)), & -! intent(out) :: u_face_mask !< A coded mask for velocities at the C-grid u-face -! real, dimension(SZDI_(G),SZDJB_(G)), & -! intent(out) :: v_face_mask !< A coded mask for velocities at the C-grid v-face real, dimension(SZDI_(G),SZDJ_(G)), & intent(out) :: u_face_mask !< A coded mask for velocities at the C-grid u-face real, dimension(SZDI_(G),SZDJ_(G)), & @@ -3082,11 +2931,9 @@ subroutine update_velocity_masks(CS, G, hmask, umask, vmask, u_face_mask, v_face integer :: i_off, j_off isc = G%isc ; jsc = G%jsc ; iec = G%iec ; jec = G%jec -! iscq = G%iscB ; iecq = G%iecB ; jscq = G%jscB ; jecq = G%jecB iscq = G%isc ; iecq = G%iec ; jscq = G%jsc ; jecq = G%jec i_off = G%idg_offset ; j_off = G%jdg_offset isd = G%isd ; jsd = G%jsd -! iegq = G%iegB ; jegq = G%jegB iegq = G%ieg ; jegq = G%jeg gisc = G%Domain%nihalo ; gjsc = G%Domain%njhalo giec = G%Domain%niglobal+gisc ; gjec = G%Domain%njglobal+gjsc @@ -3196,13 +3043,8 @@ subroutine update_velocity_masks(CS, G, hmask, umask, vmask, u_face_mask, v_face ! note: if the grid is nonsymmetric, there is a part that will not be transferred with a halo update ! so this subroutine must update its own symmetric part of the halo -! call pass_vector(u_face_mask, v_face_mask, G%domain, TO_ALL, CGRID_NE) -! call pass_vector(u_face_mask, v_face_mask, G%domain) call pass_var(u_face_mask, G%domain) call pass_var(v_face_mask, G%domain) -! call pass_vector(umask, vmask, G%domain, TO_ALL, CGRID_NE) -! call pass_vector(umask, vmask, G%domain, TO_ALL, BGRID_NE) -! call pass_vector(umask, vmask, G%domain) call pass_var(umask, G%domain) call pass_var(vmask, G%domain) end subroutine update_velocity_masks @@ -3216,9 +3058,6 @@ subroutine interpolate_H_to_B(G, h_shelf, hmask, H_node) real, dimension(SZDI_(G),SZDJ_(G)), & intent(in) :: hmask !< A mask indicating which tracer points are !! partly or fully covered by an ice-shelf -! real, dimension(SZDIB_(G),SZDJB_(G)), & -! intent(inout) :: H_node !< The ice shelf thickness at nodal (corner) -! !! points [Z ~> m]. real, dimension(SZDI_(G),SZDJ_(G)), & intent(inout) :: H_node !< The ice shelf thickness at nodal (corner) !! points [Z ~> m]. diff --git a/src/ice_shelf/MOM_ice_shelf_initialize.F90 b/src/ice_shelf/MOM_ice_shelf_initialize.F90 index 157cd21e19..4c76c3364b 100644 --- a/src/ice_shelf/MOM_ice_shelf_initialize.F90 +++ b/src/ice_shelf/MOM_ice_shelf_initialize.F90 @@ -460,6 +460,7 @@ subroutine initialize_ice_flow_from_file(bed_elev,u_shelf, v_shelf,ice_visc,floa end subroutine initialize_ice_flow_from_file +!> Initialize ice shelf b.c.s from file subroutine initialize_ice_shelf_boundary_from_file(u_face_mask_bdry, v_face_mask_bdry, & u_bdry_val, v_bdry_val, umask, vmask, h_bdry_val, thickness_bdry_val, & hmask, h_shelf, G, US, PF ) From fc72b314d8ad915f1d4d2fae2f8cff764bd5277f Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 30 Apr 2021 08:56:40 -0400 Subject: [PATCH 061/112] Use MOM_io in Surface_Bands_by_data_override Revised Surface_Bands_by_data_override in MOM_wave_interface to use the interfaces from MOM_io instead of direct calls to NF90_ routines to read the coordinate frequency or wavenumber. This change will be more efficient by having only the root processor read the files and then broadcast the information to the other PEs, and it will be more robust by reusing common code used by other MOM6 routines. This commit partially addresses MOM6 issue #1312. All answers are bitwise identical. --- src/user/MOM_wave_interface.F90 | 151 ++++++++++---------------------- 1 file changed, 44 insertions(+), 107 deletions(-) diff --git a/src/user/MOM_wave_interface.F90 b/src/user/MOM_wave_interface.F90 index a8e3e207a6..082625f65e 100644 --- a/src/user/MOM_wave_interface.F90 +++ b/src/user/MOM_wave_interface.F90 @@ -12,15 +12,13 @@ module MOM_wave_interface use MOM_file_parser, only : get_param, log_version, param_file_type use MOM_forcing_type, only : mech_forcing use MOM_grid, only : ocean_grid_type +use MOM_io, only : file_exists, field_exists, get_var_sizes, read_variable use MOM_safe_alloc, only : safe_alloc_ptr use MOM_time_manager, only : time_type, operator(+), operator(/) use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : thermo_var_ptrs, surface use MOM_verticalgrid, only : verticalGrid_type -use netcdf, only : NF90_open, NF90_inq_varid, NF90_inquire_variable, NF90_get_var -use netcdf, only : NF90_inquire_dimension, NF90_close, NF90_NOWRITE, NF90_NOERR - implicit none ; private #include @@ -785,123 +783,62 @@ subroutine Surface_Bands_by_data_override(day_center, G, GV, US, CS) ! Local variables real :: temp_x(SZI_(G),SZJ_(G)) ! Pseudo-zonal Stokes drift of band at h-points [m s-1] real :: temp_y(SZI_(G),SZJ_(G)) ! Psuedo-meridional Stokes drift of band at h-points [m s-1] - real :: Top, MidPoint - integer :: b - integer :: i, j - integer, dimension(4) :: start, counter, dims, dim_id - character(len=12) :: dim_name(4) - character(20) :: varname, varread1, varread2 - integer :: rcode_fr, rcode_wn, ncid, varid_fr, varid_wn, id, ndims + integer, dimension(4) :: sizes ! The sizes of the various dimensions of the variable. + character(len=48) :: dim_name(4) ! The names of the dimensions of the variable. + character(len=20) :: varname ! The name of an input variable for data override. + integer :: ndims, b, i, j if (.not.dataOverrideIsInitialized) then call data_override_init(G%Domain) dataOverrideIsInitialized = .true. - ! Read in number of wavenumber bands in file to set number to be read in - ! Hardcoded filename/variables - varread1 = 'wavenumber' !Old method gives wavenumber - varread2 = 'frequency' !New method gives frequency - rcode_wn = NF90_OPEN(trim(SurfBandFileName), NF90_NOWRITE, ncid) - if (rcode_wn /= 0) then - call MOM_error(FATAL,"error opening file "//trim(SurfBandFileName)//& - " in MOM_wave_interface.") - endif - - ! Check if rcode_wn or rcode_fr is 0 (checks if input has wavenumber or frequency) - rcode_wn = NF90_INQ_VARID(ncid, varread1, varid_wn) - rcode_fr = NF90_INQ_VARID(ncid, varread2, varid_fr) - - if (rcode_wn /= 0 .and. rcode_fr /= 0) then - call MOM_error(FATAL,"error finding variable "//trim(varread1)//& - " or "//trim(varread2)//" in file "//trim(SurfBandFileName)//" in MOM_wave_interface.") + if (.not.file_exists(SurfBandFileName)) & + call MOM_error(FATAL, "MOM_wave_interface is unable to find file "//trim(SurfBandFileName)) - elseif (rcode_wn == 0) then - ! wavenumbers found: + ! Check if input has wavenumber or frequency variables. + if (field_exists(SurfBandFileName, 'wavenumber')) then + ! Wavenumbers found, so this file uses the old method: PartitionMode = 0 - rcode_wn = NF90_INQUIRE_VARIABLE(ncid, varid_wn, ndims=ndims, & - dimids=dims) - if (rcode_wn /= 0) then - call MOM_error(FATAL, & - 'error inquiring dimensions MOM_wave_interface.') - endif - rcode_wn = NF90_INQUIRE_DIMENSION(ncid, dims(1), dim_name(1), len=id) - if (rcode_wn /= 0) then - call MOM_error(FATAL,"error reading dimension 1 data for "// & - trim(varread1)//" in file "// trim(SurfBandFileName)// & - " in MOM_wave_interface.") - endif - rcode_wn = NF90_INQ_VARID(ncid, dim_name(1), dim_id(1)) - if (rcode_wn /= 0) then - call MOM_error(FATAL,"error finding variable "//trim(dim_name(1))//& - " in file "//trim(SurfBandFileName)//" in MOM_wave_interace.") - endif + ! Read in number of wavenumber bands in file to set number to be read in + call get_var_sizes(SurfBandFileName, 'wavenumber', ndims, sizes, dim_names=dim_name) + ! Allocating size of wavenumber bins - allocate( CS%WaveNum_Cen(1:id) ) - CS%WaveNum_Cen(:) = 0.0 - elseif (rcode_fr == 0) then - ! frequencies found: + CS%NUMBANDS = sizes(1) + allocate( CS%WaveNum_Cen(CS%NUMBANDS) ) ; CS%WaveNum_Cen(:) = 0.0 + + ! Reading wavenumber bins + call read_variable(SurfBandFileName, dim_name(1), CS%WaveNum_Cen, scale=US%Z_to_m) + + elseif (field_exists(SurfBandFileName, 'frequency')) then + ! Frequencies found, so this file uses the newer method: PartitionMode = 1 - rcode_fr = NF90_INQUIRE_VARIABLE(ncid, varid_fr, ndims=ndims, & - dimids=dims) - if (rcode_fr /= 0) then - call MOM_error(FATAL,& - 'error inquiring dimensions MOM_wave_interface.') - endif - rcode_fr = NF90_INQUIRE_DIMENSION(ncid, dims(1), dim_name(1), len=id) - if (rcode_fr /= 0) then - call MOM_error(FATAL,"error reading dimension 1 data for "// & - trim(varread2)//" in file "// trim(SurfBandFileName)// & - " in MOM_wave_interface.") - endif - rcode_fr = NF90_INQ_VARID(ncid, dim_name(1), dim_id(1)) - if (rcode_fr /= 0) then - call MOM_error(FATAL,"error finding variable "//trim(dim_name(1))//& - " in file "//trim(SurfBandFileName)//" in MOM_wave_interace.") - endif + ! Read in number of frequency bands in file to set number to be read in + call get_var_sizes(SurfBandFileName, 'frequency', ndims, sizes, dim_names=dim_name) + ! Allocating size of frequency bins - allocate( CS%Freq_Cen(1:id) ) - CS%Freq_Cen(:) = 0.0 + CS%NUMBANDS = sizes(1) + allocate( CS%Freq_Cen(CS%NUMBANDS) ) ; CS%Freq_Cen(:) = 0.0 ! Allocating size of wavenumber bins - allocate( CS%WaveNum_Cen(1:id) ) - CS%WaveNum_Cen(:) = 0.0 - allocate( CS%STKx0(G%isdB:G%iedB,G%jsd:G%jed,1:id)) - CS%STKx0(:,:,:) = 0.0 - allocate( CS%STKy0(G%isd:G%ied,G%jsdB:G%jedB,1:id)) - CS%STKy0(:,:,:) = 0.0 - endif + allocate( CS%WaveNum_Cen(CS%NUMBANDS) ) ; CS%WaveNum_Cen(:) = 0.0 + + ! Reading frequencies + call read_variable(SurfBandFileName, dim_name(1), CS%Freq_Cen) !, scale=US%T_to_s) - ! Reading wavenumber bins/Frequencies - start(:) = 1 ! Set all start to 1 - counter(:) = 1 ! Set all counter to 1 - counter(1) = id ! Set counter(1) to id (number of frequency bins) - if (PartitionMode==0) then - rcode_wn = NF90_GET_VAR(ncid, dim_id(1), CS%WaveNum_Cen, start, counter) - if (rcode_wn /= 0) then - call MOM_error(FATAL,& - "error reading dimension 1 values for var_name "// & - trim(varread1)//",dim_name "//trim(dim_name(1))// & - " in file "// trim(SurfBandFileName)//" in MOM_wave_interface") - endif - CS%NUMBANDS = ID - do B = 1,CS%NumBands ; CS%WaveNum_Cen(b) = US%Z_to_m*CS%WaveNum_Cen(b) ; enddo - elseif (PartitionMode==1) then - rcode_fr = NF90_GET_VAR(ncid, dim_id(1), CS%Freq_Cen, start, counter) - if (rcode_fr /= 0) then - call MOM_error(FATAL,& - "error reading dimension 1 values for var_name "// & - trim(varread2)//",dim_name "//trim(dim_name(1))// & - " in file "// trim(SurfBandFileName)//" in MOM_wave_interface") - endif - CS%NUMBANDS = ID do B = 1,CS%NumBands CS%WaveNum_Cen(b) = (2.*PI*CS%Freq_Cen(b)*US%T_to_s)**2 / (US%L_to_Z**2*GV%g_Earth) enddo - endif - rcode_wn = NF90_close(ncid) - if (rcode_wn /= 0) call MOM_error(WARNING, & - "Error closing file "//trim(SurfBandFileName)//" in MOM_wave_interface.") + else + call MOM_error(FATAL, "error finding variable 'wavenumber' or 'frequency' in file "//& + trim(SurfBandFileName)//" in MOM_wave_interface.") + endif + if (.not.allocated(CS%STKx0)) then + allocate( CS%STKx0(G%isdB:G%iedB,G%jsd:G%jed,CS%NUMBANDS) ) ; CS%STKx0(:,:,:) = 0.0 + endif + if (.not.allocated(CS%STKx0)) then + allocate( CS%STKy0(G%isd:G%ied,G%jsdB:G%jedB,CS%NUMBANDS) ) ; CS%STKy0(:,:,:) = 0.0 + endif endif do b = 1,CS%NumBands @@ -909,10 +846,10 @@ subroutine Surface_Bands_by_data_override(day_center, G, GV, US, CS) temp_y(:,:) = 0.0 varname = ' ' write(varname,"(A3,I0)")'Usx',b - call data_override('OCN',trim(varname), temp_x, day_center) + call data_override('OCN', trim(varname), temp_x, day_center) varname = ' ' write(varname,'(A3,I0)')'Usy',b - call data_override('OCN',trim(varname), temp_y, day_center) + call data_override('OCN', trim(varname), temp_y, day_center) ! Disperse into halo on h-grid call pass_vector(temp_x, temp_y, G%Domain, To_All, AGRID) !Filter land values @@ -937,8 +874,8 @@ subroutine Surface_Bands_by_data_override(day_center, G, GV, US, CS) CS%STKy0(i,J,b) = 0.5 * (temp_y(i,j) + temp_y(i,j+1)) enddo enddo - ! Disperse into halo on u/v grids - call pass_vector(CS%STKx0(:,:,b),CS%STKy0(:,:,b), G%Domain, To_ALL) + ! Disperse into halo on u/v grids (This would be faster if it were moved out of the b-loop.) + call pass_vector(CS%STKx0(:,:,b), CS%STKy0(:,:,b), G%Domain, To_ALL) enddo !Closes b-loop end subroutine Surface_Bands_by_data_override From 9b51e04e08ded2622b95c814acd8aff2e74dfe34 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 30 Apr 2021 09:00:31 -0400 Subject: [PATCH 062/112] Use MOM_io interfaces in write_depth_list Revised write_depth_list to use the interfaces from MOM_io instead of direct calls to NF90_ routines. The depth list files that are generated this way are interchangeable with those from previous versions, but they are larger because FMS insists on including an unnecessary axis variable with a simple list of integers for the list axis. This commit partially addresses MOM6 issue #1312. All answers are bitwise identical. --- src/diagnostics/MOM_sum_output.F90 | 145 ++++++++++------------------- 1 file changed, 50 insertions(+), 95 deletions(-) diff --git a/src/diagnostics/MOM_sum_output.F90 b/src/diagnostics/MOM_sum_output.F90 index b2e0275ea8..76dcd140a7 100644 --- a/src/diagnostics/MOM_sum_output.F90 +++ b/src/diagnostics/MOM_sum_output.F90 @@ -4,31 +4,30 @@ module MOM_sum_output ! This file is part of MOM6. See LICENSE.md for the license. use iso_fortran_env, only : int64 -use MOM_coms, only : sum_across_PEs, PE_here, root_PE, num_PEs, max_across_PEs, field_chksum -use MOM_coms, only : reproducing_sum, reproducing_sum_EFP, EFP_to_real, real_to_EFP -use MOM_coms, only : EFP_type, operator(+), operator(-), assignment(=), EFP_sum_across_PEs +use MOM_coms, only : sum_across_PEs, PE_here, root_PE, num_PEs, max_across_PEs, field_chksum +use MOM_coms, only : reproducing_sum, reproducing_sum_EFP, EFP_to_real, real_to_EFP +use MOM_coms, only : EFP_type, operator(+), operator(-), assignment(=), EFP_sum_across_PEs use MOM_error_handler, only : MOM_error, FATAL, WARNING, is_root_pe, MOM_mesg -use MOM_file_parser, only : get_param, log_param, log_version, param_file_type -use MOM_forcing_type, only : forcing -use MOM_grid, only : ocean_grid_type +use MOM_file_parser, only : get_param, log_param, log_version, param_file_type +use MOM_forcing_type, only : forcing +use MOM_grid, only : ocean_grid_type use MOM_interface_heights, only : find_eta -use MOM_io, only : create_file, file_type, fieldtype, flush_file, reopen_file -use MOM_io, only : file_exists, slasher, vardesc, var_desc, write_field, get_filename_appendix -use MOM_io, only : field_size, read_variable, read_attribute, open_ASCII_file, stdout -use MOM_io, only : APPEND_FILE, SINGLE_FILE, WRITEONLY_FILE +use MOM_io, only : create_file, file_type, fieldtype, flush_file, reopen_file, close_file +use MOM_io, only : file_exists, slasher, vardesc, var_desc, write_field, MOM_write_field +use MOM_io, only : field_size, read_variable, read_attribute, open_ASCII_file, stdout +use MOM_io, only : axis_info, set_axis_info, delete_axis_info, get_filename_appendix +use MOM_io, only : attribute_info, set_attribute_info, delete_attribute_info +use MOM_io, only : APPEND_FILE, SINGLE_FILE, WRITEONLY_FILE use MOM_open_boundary, only : ocean_OBC_type, OBC_segment_type use MOM_open_boundary, only : OBC_DIRECTION_E, OBC_DIRECTION_W, OBC_DIRECTION_N, OBC_DIRECTION_S -use MOM_time_manager, only : time_type, get_time, get_date, set_time, operator(>) -use MOM_time_manager, only : operator(+), operator(-), operator(*), operator(/) -use MOM_time_manager, only : operator(/=), operator(<=), operator(>=), operator(<) -use MOM_time_manager, only : get_calendar_type, time_type_to_real, NO_CALENDAR +use MOM_time_manager, only : time_type, get_time, get_date, set_time, operator(>) +use MOM_time_manager, only : operator(+), operator(-), operator(*), operator(/) +use MOM_time_manager, only : operator(/=), operator(<=), operator(>=), operator(<) +use MOM_time_manager, only : get_calendar_type, time_type_to_real, NO_CALENDAR use MOM_tracer_flow_control, only : tracer_flow_control_CS, call_tracer_stocks -use MOM_unit_scaling, only : unit_scale_type -use MOM_variables, only : surface, thermo_var_ptrs -use MOM_verticalGrid, only : verticalGrid_type - -use netcdf, only : NF90_create, NF90_def_dim, NF90_def_var, NF90_enddef, NF90_put_att, NF90_put_var -use netcdf, only : NF90_close, NF90_strerror, NF90_DOUBLE, NF90_NOERR, NF90_GLOBAL +use MOM_unit_scaling, only : unit_scale_type +use MOM_variables, only : surface, thermo_var_ptrs +use MOM_verticalGrid, only : verticalGrid_type implicit none ; private @@ -1265,8 +1264,15 @@ subroutine write_depth_list(G, US, DL, filename) character(len=*), intent(in) :: filename !< The path to the depth list file to write. ! Local variables - real, allocatable :: tmp(:) - integer :: ncid, dimid(1), Did, Aid, Vid, status, k + type(vardesc), dimension(:), allocatable :: & + vars ! Types that described the staggering and metadata for the fields + type(fieldtype), dimension(:), allocatable :: & + fields ! Types with metadata about the variables that will be written + type(axis_info), dimension(:), allocatable :: & + extra_axes ! Descriptors for extra axes that might be used + type(attribute_info), dimension(:), allocatable :: & + global_atts ! Global attributes and their values + type(file_type) :: IO_handle ! The I/O handle of the fileset character(len=16) :: depth_chksum, area_chksum ! All ranks are required to compute the global checksum @@ -1274,79 +1280,28 @@ subroutine write_depth_list(G, US, DL, filename) if (.not.is_root_pe()) return - allocate(tmp(DL%listsize)) ; tmp(:) = 0.0 - - status = NF90_CREATE(filename, 0, ncid) - if (status /= NF90_NOERR) then - call MOM_error(WARNING, trim(filename)//trim(NF90_STRERROR(status))) - return - endif - - status = NF90_DEF_DIM(ncid, "list", DL%listsize, dimid(1)) - if (status /= NF90_NOERR) call MOM_error(WARNING, & - trim(filename)//trim(NF90_STRERROR(status))) - - status = NF90_DEF_VAR(ncid, "depth", NF90_DOUBLE, dimid, Did) - if (status /= NF90_NOERR) call MOM_error(WARNING, & - trim(filename)//" depth "//trim(NF90_STRERROR(status))) - status = NF90_PUT_ATT(ncid, Did, "long_name", "Sorted depth") - if (status /= NF90_NOERR) call MOM_error(WARNING, & - trim(filename)//" depth "//trim(NF90_STRERROR(status))) - status = NF90_PUT_ATT(ncid, Did, "units", "m") - if (status /= NF90_NOERR) call MOM_error(WARNING, & - trim(filename)//" depth "//trim(NF90_STRERROR(status))) - - status = NF90_DEF_VAR(ncid, "area", NF90_DOUBLE, dimid, Aid) - if (status /= NF90_NOERR) call MOM_error(WARNING, & - trim(filename)//" area "//trim(NF90_STRERROR(status))) - status = NF90_PUT_ATT(ncid, Aid, "long_name", "Open area at depth") - if (status /= NF90_NOERR) call MOM_error(WARNING, & - trim(filename)//" area "//trim(NF90_STRERROR(status))) - status = NF90_PUT_ATT(ncid, Aid, "units", "m2") - if (status /= NF90_NOERR) call MOM_error(WARNING, & - trim(filename)//" area "//trim(NF90_STRERROR(status))) - - status = NF90_DEF_VAR(ncid, "vol_below", NF90_DOUBLE, dimid, Vid) - if (status /= NF90_NOERR) call MOM_error(WARNING, & - trim(filename)//" vol_below "//trim(NF90_STRERROR(status))) - status = NF90_PUT_ATT(ncid, Vid, "long_name", "Open volume below depth") - if (status /= NF90_NOERR) call MOM_error(WARNING, & - trim(filename)//" vol_below "//trim(NF90_STRERROR(status))) - status = NF90_PUT_ATT(ncid, Vid, "units", "m3") - if (status /= NF90_NOERR) call MOM_error(WARNING, & - trim(filename)//" vol_below "//trim(NF90_STRERROR(status))) - - ! Dependency checksums - status = NF90_PUT_ATT(ncid, NF90_GLOBAL, depth_chksum_attr, depth_chksum) - if (status /= NF90_NOERR) call MOM_error(WARNING, & - trim(filename)//" "//depth_chksum_attr//" "//trim(NF90_STRERROR(status))) - - status = NF90_PUT_ATT(ncid, NF90_GLOBAL, area_chksum_attr, area_chksum) - if (status /= NF90_NOERR) call MOM_error(WARNING, & - trim(filename)//" "//area_chksum_attr//" "//trim(NF90_STRERROR(status))) - - status = NF90_ENDDEF(ncid) - if (status /= NF90_NOERR) call MOM_error(WARNING, & - trim(filename)//trim(NF90_STRERROR(status))) - - do k=1,DL%listsize ; tmp(k) = US%Z_to_m*DL%depth(k) ; enddo - status = NF90_PUT_VAR(ncid, Did, tmp) - if (status /= NF90_NOERR) call MOM_error(WARNING, & - trim(filename)//" depth "//trim(NF90_STRERROR(status))) - - do k=1,DL%listsize ; tmp(k) = US%L_to_m**2*DL%area(k) ; enddo - status = NF90_PUT_VAR(ncid, Aid, tmp) - if (status /= NF90_NOERR) call MOM_error(WARNING, & - trim(filename)//" area "//trim(NF90_STRERROR(status))) - - do k=1,DL%listsize ; tmp(k) = US%Z_to_m*US%L_to_m**2*DL%vol_below(k) ; enddo - status = NF90_PUT_VAR(ncid, Vid, tmp) - if (status /= NF90_NOERR) call MOM_error(WARNING, & - trim(filename)//" vol_below "//trim(NF90_STRERROR(status))) - - status = NF90_CLOSE(ncid) - if (status /= NF90_NOERR) call MOM_error(WARNING, & - trim(filename)//trim(NF90_STRERROR(status))) + allocate(vars(3)) + allocate(fields(3)) + allocate(extra_axes(1)) + allocate(global_atts(2)) + + call set_axis_info(extra_axes(1), "list", ax_size=DL%listsize) + vars(1) = var_desc("depth", "m", "Sorted depth", '1', dim_names=(/"list"/), fixed=.true.) + vars(2) = var_desc("area", "m2", "Open area at depth", '1', dim_names=(/"list"/), fixed=.true.) + vars(3) = var_desc("vol_below", "m3", "Open volume below depth", '1', dim_names=(/"list"/), fixed=.true.) + call set_attribute_info(global_atts(1), depth_chksum_attr, depth_chksum) + call set_attribute_info(global_atts(2), area_chksum_attr, area_chksum) + + call create_file(IO_handle, filename, vars, 3, fields, SINGLE_FILE, extra_axes=extra_axes, & + global_atts=global_atts) + call MOM_write_field(IO_handle, fields(1), DL%depth, scale=US%Z_to_m) + call MOM_write_field(IO_handle, fields(2), DL%area, scale=US%L_to_m**2) + call MOM_write_field(IO_handle, fields(3), DL%vol_below, scale=US%Z_to_m*US%L_to_m**2) + + call delete_axis_info(extra_axes) + call delete_attribute_info(global_atts) + deallocate(vars, extra_axes, fields, global_atts) + call close_file(IO_handle) end subroutine write_depth_list From 48e24421aa16ab7085c39ea1baa87365e12b8af4 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Mon, 3 May 2021 13:47:09 -0400 Subject: [PATCH 063/112] Collocate units and conversion for register_diag Rearranged arguments in register_diag_field calls to facilitate the detection of inconsistent units and scaling factors using simple methods, by placing the unit and conversion arguments on the same line. At some point, we will develop more sophisticated methods for detecting such inconsistencies, at which these changes will lose their value but become benign. Also, made use of the scaling factor GV%H_to_MKS, which handles conversion of thickness units to m or kg m-2, depending on whether the code is being run in Boussinesq or non-Boussinesq mode, instead of having logic scattered in several places throughout the code to select GV%H_to_m or GV%H_to_kg_m2. This commit closes MOM6 issue #1384. All answers and output are bitwise identical, and these are mostly essentially whitespace changes. --- src/ALE/MOM_ALE.F90 | 11 +- src/core/MOM.F90 | 14 +-- src/core/MOM_barotropic.F90 | 8 +- src/core/MOM_dynamics_split_RK2.F90 | 118 +++++++++--------- src/core/MOM_dynamics_unsplit.F90 | 22 ++-- src/core/MOM_dynamics_unsplit_RK2.F90 | 10 +- src/diagnostics/MOM_diagnostics.F90 | 24 ++-- src/ice_shelf/MOM_ice_shelf.F90 | 2 +- src/ice_shelf/MOM_ice_shelf_dynamics.F90 | 3 +- .../lateral/MOM_hor_visc.F90 | 24 ++-- .../lateral/MOM_mixed_layer_restrat.F90 | 14 +-- .../vertical/MOM_diabatic_driver.F90 | 4 +- .../vertical/MOM_vert_friction.F90 | 24 ++-- src/tracer/MOM_tracer_registry.F90 | 31 +++-- 14 files changed, 146 insertions(+), 163 deletions(-) diff --git a/src/ALE/MOM_ALE.F90 b/src/ALE/MOM_ALE.F90 index 158062fd06..63f8193b33 100644 --- a/src/ALE/MOM_ALE.F90 +++ b/src/ALE/MOM_ALE.F90 @@ -263,8 +263,8 @@ subroutine ALE_register_diags(Time, G, GV, US, diag, CS) CS%id_v_preale = register_diag_field('ocean_model', 'v_preale', diag%axesCvL, Time, & 'Meridional velocity before remapping', 'm s-1', conversion=US%L_T_to_m_s) CS%id_h_preale = register_diag_field('ocean_model', 'h_preale', diag%axesTL, Time, & - 'Layer Thickness before remapping', get_thickness_units(GV), & - conversion=GV%H_to_MKS, v_extensive=.true.) + 'Layer Thickness before remapping', get_thickness_units(GV), conversion=GV%H_to_MKS, & + v_extensive=.true.) CS%id_T_preale = register_diag_field('ocean_model', 'T_preale', diag%axesTL, Time, & 'Temperature before remapping', 'degC') CS%id_S_preale = register_diag_field('ocean_model', 'S_preale', diag%axesTL, Time, & @@ -273,11 +273,10 @@ subroutine ALE_register_diags(Time, G, GV, US, diag, CS) 'Interface Heights before remapping', 'm', conversion=US%Z_to_m) CS%id_dzRegrid = register_diag_field('ocean_model','dzRegrid',diag%axesTi,Time, & - 'Change in interface height due to ALE regridding', 'm', & - conversion=GV%H_to_m) + 'Change in interface height due to ALE regridding', 'm', conversion=GV%H_to_m) cs%id_vert_remap_h = register_diag_field('ocean_model', 'vert_remap_h', & - diag%axestl, time, 'layer thicknesses after ALE regridding and remapping', 'm', & - conversion=GV%H_to_m, v_extensive=.true.) + diag%axestl, time, 'layer thicknesses after ALE regridding and remapping', & + 'm', 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 s-1', conversion=GV%H_to_m*US%s_to_T, v_extensive = .true.) diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index 9ccb8eb8c6..4659b685e5 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -2195,11 +2195,11 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & conversion=US%Q_to_J_kg*CS%tv%C_p) endif if (CS%tv%S_is_absS) then - vd_S = var_desc(name="abssalt",units="g kg-1",longname="Absolute Salinity", & + vd_S = var_desc(name="abssalt", units="g kg-1", longname="Absolute Salinity", & cmor_field_name="so", cmor_longname="Sea Water Salinity", & conversion=0.001) else - vd_S = var_desc(name="salt",units="psu",longname="Salinity", & + vd_S = var_desc(name="salt", units="psu", longname="Salinity", & cmor_field_name="so", cmor_longname="Sea Water Salinity", & conversion=0.001) endif @@ -2867,15 +2867,9 @@ subroutine register_diags(Time, G, GV, US, IDs, diag) type(MOM_diag_IDs), intent(inout) :: IDs !< A structure with the diagnostic IDs. type(diag_ctrl), intent(inout) :: diag !< regulates diagnostic output - real :: H_convert character(len=48) :: thickness_units thickness_units = get_thickness_units(GV) - if (GV%Boussinesq) then - H_convert = GV%H_to_m - else - H_convert = GV%H_to_kg_m2 - endif ! Diagnostics of the rapidly varying dynamic state IDs%id_u = register_diag_field('ocean_model', 'u_dyn', diag%axesCuL, Time, & @@ -2883,8 +2877,8 @@ subroutine register_diags(Time, G, GV, US, IDs, diag) IDs%id_v = register_diag_field('ocean_model', 'v_dyn', diag%axesCvL, Time, & 'Meridional velocity after the dynamics update', 'm s-1', conversion=US%L_T_to_m_s) IDs%id_h = register_diag_field('ocean_model', 'h_dyn', diag%axesTL, Time, & - 'Layer Thickness after the dynamics update', thickness_units, & - v_extensive=.true., conversion=H_convert) + 'Layer Thickness after the dynamics update', thickness_units, conversion=GV%H_to_MKS, & + v_extensive=.true.) IDs%id_ssh_inst = register_diag_field('ocean_model', 'SSH_inst', diag%axesT1, & Time, 'Instantaneous Sea Surface Height', 'm') end subroutine register_diags diff --git a/src/core/MOM_barotropic.F90 b/src/core/MOM_barotropic.F90 index 590366f32f..a8262608f8 100644 --- a/src/core/MOM_barotropic.F90 +++ b/src/core/MOM_barotropic.F90 @@ -4835,11 +4835,11 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, CS%id_eta_pred_hifreq = register_diag_field('ocean_model', 'eta_pred_hifreq', diag%axesT1, Time, & 'High Frequency Predictor Barotropic SSH', thickness_units, conversion=GV%H_to_MKS) CS%id_uhbt_hifreq = register_diag_field('ocean_model', 'uhbt_hifreq', diag%axesCu1, Time, & - 'High Frequency Barotropic zonal transport', 'm3 s-1', & - conversion=GV%H_to_m*US%L_to_m*US%L_T_to_m_s) + 'High Frequency Barotropic zonal transport', & + 'm3 s-1', conversion=GV%H_to_m*US%L_to_m*US%L_T_to_m_s) CS%id_vhbt_hifreq = register_diag_field('ocean_model', 'vhbt_hifreq', diag%axesCv1, Time, & - 'High Frequency Barotropic meridional transport', 'm3 s-1', & - conversion=GV%H_to_m*US%L_to_m*US%L_T_to_m_s) + 'High Frequency Barotropic meridional transport', & + 'm3 s-1', conversion=GV%H_to_m*US%L_to_m*US%L_T_to_m_s) CS%id_frhatu = register_diag_field('ocean_model', 'frhatu', diag%axesCuL, Time, & 'Fractional thickness of layers in u-columns', 'nondim') CS%id_frhatv = register_diag_field('ocean_model', 'frhatv', diag%axesCvL, Time, & diff --git a/src/core/MOM_dynamics_split_RK2.F90 b/src/core/MOM_dynamics_split_RK2.F90 index ef7da5c291..713d70e800 100644 --- a/src/core/MOM_dynamics_split_RK2.F90 +++ b/src/core/MOM_dynamics_split_RK2.F90 @@ -1185,7 +1185,6 @@ subroutine initialize_dyn_split_RK2(u, v, h, uh, vh, eta, Time, G, GV, US, param ! a restart file to the internal representation in this run. real :: accel_rescale ! A rescaling factor for accelerations from the representation in ! a restart file to the internal representation in this run. - real :: H_convert type(group_pass_type) :: pass_av_h_uvh logical :: use_tides, debug_truncations @@ -1395,13 +1394,12 @@ subroutine initialize_dyn_split_RK2(u, v, h, uh, vh, eta, Time, G, GV, US, param call cpu_clock_end(id_clock_pass_init) flux_units = get_flux_units(GV) - H_convert = GV%H_to_m ; if (.not.GV%Boussinesq) H_convert = GV%H_to_kg_m2 CS%id_uh = register_diag_field('ocean_model', 'uh', diag%axesCuL, Time, & - 'Zonal Thickness Flux', flux_units, y_cell_method='sum', v_extensive=.true., & - conversion=H_convert*US%L_to_m**2*US%s_to_T) + 'Zonal Thickness Flux', flux_units, conversion=GV%H_to_MKS*US%L_to_m**2*US%s_to_T, & + y_cell_method='sum', v_extensive=.true.) CS%id_vh = register_diag_field('ocean_model', 'vh', diag%axesCvL, Time, & - 'Meridional Thickness Flux', flux_units, x_cell_method='sum', v_extensive=.true., & - conversion=H_convert*US%L_to_m**2*US%s_to_T) + 'Meridional Thickness Flux', flux_units, conversion=GV%H_to_MKS*US%L_to_m**2*US%s_to_T, & + x_cell_method='sum', v_extensive=.true.) CS%id_CAu = register_diag_field('ocean_model', 'CAu', diag%axesCuL, Time, & 'Zonal Coriolis and Advective Acceleration', 'm s-2', conversion=US%L_T2_to_m_s2) @@ -1413,64 +1411,64 @@ subroutine initialize_dyn_split_RK2(u, v, h, uh, vh, eta, Time, G, GV, US, param 'Meridional Pressure Force Acceleration', 'm s-2', conversion=US%L_T2_to_m_s2) !CS%id_hf_PFu = register_diag_field('ocean_model', 'hf_PFu', diag%axesCuL, Time, & - ! 'Fractional Thickness-weighted Zonal Pressure Force Acceleration', 'm s-2', & - ! v_extensive=.true., conversion=US%L_T2_to_m_s2) - !if(CS%id_hf_PFu > 0) call safe_alloc_ptr(CS%ADp%diag_hfrac_u,IsdB,IedB,jsd,jed,nz) + ! 'Fractional Thickness-weighted Zonal Pressure Force Acceleration', & + ! 'm s-2', v_extensive=.true., conversion=US%L_T2_to_m_s2) + !if (CS%id_hf_PFu > 0) call safe_alloc_ptr(CS%ADp%diag_hfrac_u,IsdB,IedB,jsd,jed,nz) !CS%id_hf_PFv = register_diag_field('ocean_model', 'hf_PFv', diag%axesCvL, Time, & - ! 'Fractional Thickness-weighted Meridional Pressure Force Acceleration', 'm s-2', & - ! v_extensive=.true., conversion=US%L_T2_to_m_s2) - !if(CS%id_hf_PFv > 0) call safe_alloc_ptr(CS%ADp%diag_hfrac_v,isd,ied,JsdB,JedB,nz) + ! 'Fractional Thickness-weighted Meridional Pressure Force Acceleration', & + ! 'm s-2', v_extensive=.true., conversion=US%L_T2_to_m_s2) + !if (CS%id_hf_PFv > 0) call safe_alloc_ptr(CS%ADp%diag_hfrac_v,isd,ied,JsdB,JedB,nz) !CS%id_hf_CAu = register_diag_field('ocean_model', 'hf_CAu', diag%axesCuL, Time, & - ! 'Fractional Thickness-weighted Zonal Coriolis and Advective Acceleration', 'm s-2', & - ! v_extensive=.true., conversion=US%L_T2_to_m_s2) - !if(CS%id_hf_CAu > 0) call safe_alloc_ptr(CS%ADp%diag_hfrac_u,IsdB,IedB,jsd,jed,nz) + ! 'Fractional Thickness-weighted Zonal Coriolis and Advective Acceleration', & + ! 'm s-2', v_extensive=.true., conversion=US%L_T2_to_m_s2) + !if (CS%id_hf_CAu > 0) call safe_alloc_ptr(CS%ADp%diag_hfrac_u,IsdB,IedB,jsd,jed,nz) !CS%id_hf_CAv = register_diag_field('ocean_model', 'hf_CAv', diag%axesCvL, Time, & - ! 'Fractional Thickness-weighted Meridional Coriolis and Advective Acceleration', 'm s-2', & - ! v_extensive=.true., conversion=US%L_T2_to_m_s2) - !if(CS%id_hf_CAv > 0) call safe_alloc_ptr(CS%ADp%diag_hfrac_v,isd,ied,JsdB,JedB,nz) + ! 'Fractional Thickness-weighted Meridional Coriolis and Advective Acceleration', & + ! 'm s-2', v_extensive=.true., conversion=US%L_T2_to_m_s2) + !if (CS%id_hf_CAv > 0) call safe_alloc_ptr(CS%ADp%diag_hfrac_v,isd,ied,JsdB,JedB,nz) CS%id_hf_PFu_2d = register_diag_field('ocean_model', 'hf_PFu_2d', diag%axesCu1, Time, & - 'Depth-sum Fractional Thickness-weighted Zonal Pressure Force Acceleration', 'm s-2', & - conversion=US%L_T2_to_m_s2) - if(CS%id_hf_PFu_2d > 0) call safe_alloc_ptr(CS%ADp%diag_hfrac_u,IsdB,IedB,jsd,jed,nz) + 'Depth-sum Fractional Thickness-weighted Zonal Pressure Force Acceleration', & + 'm s-2', conversion=US%L_T2_to_m_s2) + if (CS%id_hf_PFu_2d > 0) call safe_alloc_ptr(CS%ADp%diag_hfrac_u,IsdB,IedB,jsd,jed,nz) CS%id_hf_PFv_2d = register_diag_field('ocean_model', 'hf_PFv_2d', diag%axesCv1, Time, & - 'Depth-sum Fractional Thickness-weighted Meridional Pressure Force Acceleration', 'm s-2', & - conversion=US%L_T2_to_m_s2) - if(CS%id_hf_PFv_2d > 0) call safe_alloc_ptr(CS%ADp%diag_hfrac_v,isd,ied,JsdB,JedB,nz) + 'Depth-sum Fractional Thickness-weighted Meridional Pressure Force Acceleration', & + 'm s-2', conversion=US%L_T2_to_m_s2) + if (CS%id_hf_PFv_2d > 0) call safe_alloc_ptr(CS%ADp%diag_hfrac_v,isd,ied,JsdB,JedB,nz) CS%id_intz_PFu_2d = register_diag_field('ocean_model', 'intz_PFu_2d', diag%axesCu1, Time, & - 'Depth-integral of Zonal Pressure Force Acceleration', 'm2 s-2', & - conversion=GV%H_to_m*US%L_T2_to_m_s2) - if(CS%id_intz_PFu_2d > 0) call safe_alloc_ptr(CS%ADp%diag_hu,IsdB,IedB,jsd,jed,nz) + 'Depth-integral of Zonal Pressure Force Acceleration', & + 'm2 s-2', conversion=GV%H_to_m*US%L_T2_to_m_s2) + if (CS%id_intz_PFu_2d > 0) call safe_alloc_ptr(CS%ADp%diag_hu,IsdB,IedB,jsd,jed,nz) CS%id_intz_PFv_2d = register_diag_field('ocean_model', 'intz_PFv_2d', diag%axesCv1, Time, & - 'Depth-integral of Meridional Pressure Force Acceleration', 'm2 s-2', & - conversion=GV%H_to_m*US%L_T2_to_m_s2) - if(CS%id_intz_PFv_2d > 0) call safe_alloc_ptr(CS%ADp%diag_hv,isd,ied,JsdB,JedB,nz) + 'Depth-integral of Meridional Pressure Force Acceleration', & + 'm2 s-2', conversion=GV%H_to_m*US%L_T2_to_m_s2) + if (CS%id_intz_PFv_2d > 0) call safe_alloc_ptr(CS%ADp%diag_hv,isd,ied,JsdB,JedB,nz) CS%id_hf_CAu_2d = register_diag_field('ocean_model', 'hf_CAu_2d', diag%axesCu1, Time, & - 'Depth-sum Fractional Thickness-weighted Zonal Coriolis and Advective Acceleration', 'm s-2', & - conversion=US%L_T2_to_m_s2) - if(CS%id_hf_CAu_2d > 0) call safe_alloc_ptr(CS%ADp%diag_hfrac_u,IsdB,IedB,jsd,jed,nz) + 'Depth-sum Fractional Thickness-weighted Zonal Coriolis and Advective Acceleration', & + 'm s-2', conversion=US%L_T2_to_m_s2) + if (CS%id_hf_CAu_2d > 0) call safe_alloc_ptr(CS%ADp%diag_hfrac_u,IsdB,IedB,jsd,jed,nz) CS%id_hf_CAv_2d = register_diag_field('ocean_model', 'hf_CAv_2d', diag%axesCv1, Time, & - 'Depth-sum Fractional Thickness-weighted Meridional Coriolis and Advective Acceleration', 'm s-2', & - conversion=US%L_T2_to_m_s2) - if(CS%id_hf_CAv_2d > 0) call safe_alloc_ptr(CS%ADp%diag_hfrac_v,isd,ied,JsdB,JedB,nz) + 'Depth-sum Fractional Thickness-weighted Meridional Coriolis and Advective Acceleration', & + 'm s-2', conversion=US%L_T2_to_m_s2) + if (CS%id_hf_CAv_2d > 0) call safe_alloc_ptr(CS%ADp%diag_hfrac_v,isd,ied,JsdB,JedB,nz) CS%id_intz_CAu_2d = register_diag_field('ocean_model', 'intz_CAu_2d', diag%axesCu1, Time, & - 'Depth-integral of Zonal Coriolis and Advective Acceleration', 'm2 s-2', & - conversion=GV%H_to_m*US%L_T2_to_m_s2) - if(CS%id_intz_CAu_2d > 0) call safe_alloc_ptr(CS%ADp%diag_hu,IsdB,IedB,jsd,jed,nz) + 'Depth-integral of Zonal Coriolis and Advective Acceleration', & + 'm2 s-2', conversion=GV%H_to_m*US%L_T2_to_m_s2) + if (CS%id_intz_CAu_2d > 0) call safe_alloc_ptr(CS%ADp%diag_hu,IsdB,IedB,jsd,jed,nz) CS%id_intz_CAv_2d = register_diag_field('ocean_model', 'intz_CAv_2d', diag%axesCv1, Time, & - 'Depth-integral of Meridional Coriolis and Advective Acceleration', 'm2 s-2', & - conversion=GV%H_to_m*US%L_T2_to_m_s2) - if(CS%id_intz_CAv_2d > 0) call safe_alloc_ptr(CS%ADp%diag_hv,isd,ied,JsdB,JedB,nz) + 'Depth-integral of Meridional Coriolis and Advective Acceleration', & + 'm2 s-2', conversion=GV%H_to_m*US%L_T2_to_m_s2) + if (CS%id_intz_CAv_2d > 0) call safe_alloc_ptr(CS%ADp%diag_hv,isd,ied,JsdB,JedB,nz) CS%id_uav = register_diag_field('ocean_model', 'uav', diag%axesCuL, Time, & 'Barotropic-step Averaged Zonal Velocity', 'm s-1', conversion=US%L_T_to_m_s) @@ -1483,34 +1481,34 @@ subroutine initialize_dyn_split_RK2(u, v, h, uh, vh, eta, Time, G, GV, US, param 'Barotropic Anomaly Meridional Acceleration', 'm s-2', conversion=US%L_T2_to_m_s2) !CS%id_hf_u_BT_accel = register_diag_field('ocean_model', 'hf_u_BT_accel', diag%axesCuL, Time, & - ! 'Fractional Thickness-weighted Barotropic Anomaly Zonal Acceleration', 'm s-2', & - ! v_extensive=.true., conversion=US%L_T2_to_m_s2) - !if(CS%id_hf_u_BT_accel > 0) call safe_alloc_ptr(CS%ADp%diag_hfrac_u,IsdB,IedB,jsd,jed,nz) + ! 'Fractional Thickness-weighted Barotropic Anomaly Zonal Acceleration', & + ! 'm s-2', v_extensive=.true., conversion=US%L_T2_to_m_s2) + !if (CS%id_hf_u_BT_accel > 0) call safe_alloc_ptr(CS%ADp%diag_hfrac_u,IsdB,IedB,jsd,jed,nz) !CS%id_hf_v_BT_accel = register_diag_field('ocean_model', 'hf_v_BT_accel', diag%axesCvL, Time, & - ! 'Fractional Thickness-weighted Barotropic Anomaly Meridional Acceleration', 'm s-2', & - ! v_extensive=.true., conversion=US%L_T2_to_m_s2) - !if(CS%id_hf_v_BT_accel > 0) call safe_alloc_ptr(CS%ADp%diag_hfrac_v,isd,ied,JsdB,JedB,nz) + ! 'Fractional Thickness-weighted Barotropic Anomaly Meridional Acceleration', & + ! 'm s-2', v_extensive=.true., conversion=US%L_T2_to_m_s2) + !if (CS%id_hf_v_BT_accel > 0) call safe_alloc_ptr(CS%ADp%diag_hfrac_v,isd,ied,JsdB,JedB,nz) CS%id_hf_u_BT_accel_2d = register_diag_field('ocean_model', 'hf_u_BT_accel_2d', diag%axesCu1, Time, & - 'Depth-sum Fractional Thickness-weighted Barotropic Anomaly Zonal Acceleration', 'm s-2', & - conversion=US%L_T2_to_m_s2) - if(CS%id_hf_u_BT_accel_2d > 0) call safe_alloc_ptr(CS%ADp%diag_hfrac_u,IsdB,IedB,jsd,jed,nz) + 'Depth-sum Fractional Thickness-weighted Barotropic Anomaly Zonal Acceleration', & + 'm s-2', conversion=US%L_T2_to_m_s2) + if (CS%id_hf_u_BT_accel_2d > 0) call safe_alloc_ptr(CS%ADp%diag_hfrac_u,IsdB,IedB,jsd,jed,nz) CS%id_hf_v_BT_accel_2d = register_diag_field('ocean_model', 'hf_v_BT_accel_2d', diag%axesCv1, Time, & - 'Depth-sum Fractional Thickness-weighted Barotropic Anomaly Meridional Acceleration', 'm s-2', & - conversion=US%L_T2_to_m_s2) - if(CS%id_hf_v_BT_accel_2d > 0) call safe_alloc_ptr(CS%ADp%diag_hfrac_v,isd,ied,JsdB,JedB,nz) + 'Depth-sum Fractional Thickness-weighted Barotropic Anomaly Meridional Acceleration', & + 'm s-2', conversion=US%L_T2_to_m_s2) + if (CS%id_hf_v_BT_accel_2d > 0) call safe_alloc_ptr(CS%ADp%diag_hfrac_v,isd,ied,JsdB,JedB,nz) CS%id_intz_u_BT_accel_2d = register_diag_field('ocean_model', 'intz_u_BT_accel_2d', diag%axesCu1, Time, & - 'Depth-integral of Barotropic Anomaly Zonal Acceleration', 'm2 s-2', & - conversion=GV%H_to_m*US%L_T2_to_m_s2) - if(CS%id_intz_u_BT_accel_2d > 0) call safe_alloc_ptr(CS%ADp%diag_hu,IsdB,IedB,jsd,jed,nz) + 'Depth-integral of Barotropic Anomaly Zonal Acceleration', & + 'm2 s-2', conversion=GV%H_to_m*US%L_T2_to_m_s2) + if (CS%id_intz_u_BT_accel_2d > 0) call safe_alloc_ptr(CS%ADp%diag_hu,IsdB,IedB,jsd,jed,nz) CS%id_intz_v_BT_accel_2d = register_diag_field('ocean_model', 'intz_v_BT_accel_2d', diag%axesCv1, Time, & - 'Depth-integral of Barotropic Anomaly Meridional Acceleration', 'm2 s-2', & - conversion=GV%H_to_m*US%L_T2_to_m_s2) - if(CS%id_intz_v_BT_accel_2d > 0) call safe_alloc_ptr(CS%ADp%diag_hv,isd,ied,JsdB,JedB,nz) + 'Depth-integral of Barotropic Anomaly Meridional Acceleration', & + 'm2 s-2', conversion=GV%H_to_m*US%L_T2_to_m_s2) + if (CS%id_intz_v_BT_accel_2d > 0) call safe_alloc_ptr(CS%ADp%diag_hv,isd,ied,JsdB,JedB,nz) id_clock_Cor = cpu_clock_id('(Ocean Coriolis & mom advection)', grain=CLOCK_MODULE) id_clock_continuity = cpu_clock_id('(Ocean continuity equation)', grain=CLOCK_MODULE) diff --git a/src/core/MOM_dynamics_unsplit.F90 b/src/core/MOM_dynamics_unsplit.F90 index 10b1f2e857..375f7e3ef1 100644 --- a/src/core/MOM_dynamics_unsplit.F90 +++ b/src/core/MOM_dynamics_unsplit.F90 @@ -612,7 +612,6 @@ subroutine initialize_dyn_unsplit(u, v, h, Time, G, GV, US, param_file, diag, CS character(len=48) :: thickness_units, flux_units ! This include declares and sets the variable "version". # include "version_variable.h" - real :: H_convert logical :: use_tides integer :: isd, ied, jsd, jed, nz, IsdB, IedB, JsdB, JedB isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed ; nz = GV%ke @@ -671,25 +670,20 @@ subroutine initialize_dyn_unsplit(u, v, h, Time, G, GV, US, param_file, diag, CS if (associated(update_OBC_CSp)) CS%update_OBC_CSp => update_OBC_CSp flux_units = get_flux_units(GV) - H_convert = GV%H_to_m ; if (.not.GV%Boussinesq) H_convert = GV%H_to_kg_m2 CS%id_uh = register_diag_field('ocean_model', 'uh', diag%axesCuL, Time, & - 'Zonal Thickness Flux', flux_units, y_cell_method='sum', v_extensive=.true., & - conversion=H_convert*US%L_to_m**2*US%s_to_T) + 'Zonal Thickness Flux', flux_units, conversion=GV%H_to_MKS*US%L_to_m**2*US%s_to_T, & + y_cell_method='sum', v_extensive=.true.) CS%id_vh = register_diag_field('ocean_model', 'vh', diag%axesCvL, Time, & - 'Meridional Thickness Flux', flux_units, x_cell_method='sum', v_extensive=.true., & - conversion=H_convert*US%L_to_m**2*US%s_to_T) + 'Meridional Thickness Flux', flux_units, conversion=GV%H_to_MKS*US%L_to_m**2*US%s_to_T, & + x_cell_method='sum', v_extensive=.true.) CS%id_CAu = register_diag_field('ocean_model', 'CAu', diag%axesCuL, Time, & - 'Zonal Coriolis and Advective Acceleration', 'm s-2', & - conversion=US%L_T2_to_m_s2) + 'Zonal Coriolis and Advective Acceleration', 'm s-2', conversion=US%L_T2_to_m_s2) CS%id_CAv = register_diag_field('ocean_model', 'CAv', diag%axesCvL, Time, & - 'Meridional Coriolis and Advective Acceleration', 'm s-2', & - conversion=US%L_T2_to_m_s2) + 'Meridional Coriolis and Advective Acceleration', 'm s-2', conversion=US%L_T2_to_m_s2) CS%id_PFu = register_diag_field('ocean_model', 'PFu', diag%axesCuL, Time, & - 'Zonal Pressure Force Acceleration', 'm s-2', & - conversion=US%L_T2_to_m_s2) + 'Zonal Pressure Force Acceleration', 'm s-2', conversion=US%L_T2_to_m_s2) CS%id_PFv = register_diag_field('ocean_model', 'PFv', diag%axesCvL, Time, & - 'Meridional Pressure Force Acceleration', 'm s-2', & - conversion=US%L_T2_to_m_s2) + 'Meridional Pressure Force Acceleration', 'm s-2', conversion=US%L_T2_to_m_s2) id_clock_Cor = cpu_clock_id('(Ocean Coriolis & mom advection)', grain=CLOCK_MODULE) id_clock_continuity = cpu_clock_id('(Ocean continuity equation)', grain=CLOCK_MODULE) diff --git a/src/core/MOM_dynamics_unsplit_RK2.F90 b/src/core/MOM_dynamics_unsplit_RK2.F90 index 8ca671d463..fea7f0d873 100644 --- a/src/core/MOM_dynamics_unsplit_RK2.F90 +++ b/src/core/MOM_dynamics_unsplit_RK2.F90 @@ -558,7 +558,6 @@ subroutine initialize_dyn_unsplit_RK2(u, v, h, Time, G, GV, US, param_file, diag character(len=48) :: thickness_units, flux_units ! This include declares and sets the variable "version". # include "version_variable.h" - real :: H_convert logical :: use_tides integer :: isd, ied, jsd, jed, nz, IsdB, IedB, JsdB, JedB isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed ; nz = GV%ke @@ -632,13 +631,12 @@ subroutine initialize_dyn_unsplit_RK2(u, v, h, Time, G, GV, US, param_file, diag if (associated(OBC)) CS%OBC => OBC flux_units = get_flux_units(GV) - H_convert = GV%H_to_m ; if (.not.GV%Boussinesq) H_convert = GV%H_to_kg_m2 CS%id_uh = register_diag_field('ocean_model', 'uh', diag%axesCuL, Time, & - 'Zonal Thickness Flux', flux_units, y_cell_method='sum', v_extensive=.true., & - conversion=H_convert*US%L_to_m**2*US%s_to_T) + 'Zonal Thickness Flux', flux_units, conversion=GV%H_to_MKS*US%L_to_m**2*US%s_to_T, & + y_cell_method='sum', v_extensive=.true.) CS%id_vh = register_diag_field('ocean_model', 'vh', diag%axesCvL, Time, & - 'Meridional Thickness Flux', flux_units, x_cell_method='sum', v_extensive=.true., & - conversion=H_convert*US%L_to_m**2*US%s_to_T) + 'Meridional Thickness Flux', flux_units, conversion=GV%H_to_MKS*US%L_to_m**2*US%s_to_T, & + x_cell_method='sum', v_extensive=.true.) CS%id_CAu = register_diag_field('ocean_model', 'CAu', diag%axesCuL, Time, & 'Zonal Coriolis and Advective Acceleration', 'meter second-2', conversion=US%L_T2_to_m_s2) CS%id_CAv = register_diag_field('ocean_model', 'CAv', diag%axesCvL, Time, & diff --git a/src/diagnostics/MOM_diagnostics.F90 b/src/diagnostics/MOM_diagnostics.F90 index 5ac8777a19..871d5c4a64 100644 --- a/src/diagnostics/MOM_diagnostics.F90 +++ b/src/diagnostics/MOM_diagnostics.F90 @@ -1497,7 +1497,7 @@ subroutine post_transport_diagnostics(G, GV, US, uhtr, vhtr, h, IDs, diag_pre_dy do k=1,nz ; do j=js,je ; do I=is-1,ie umo(I,j,k) = uhtr(I,j,k) * H_to_RZ_dt enddo ; enddo ; enddo - call post_data(IDs%id_umo, umo, diag, alt_h = diag_pre_dyn%h_state) + call post_data(IDs%id_umo, umo, diag, alt_h=diag_pre_dyn%h_state) endif if (IDs%id_vmo_2d > 0) then vmo2d(:,:) = 0.0 @@ -1511,20 +1511,20 @@ subroutine post_transport_diagnostics(G, GV, US, uhtr, vhtr, h, IDs, diag_pre_dy do k=1,nz ; do J=js-1,je ; do i=is,ie vmo(i,J,k) = vhtr(i,J,k) * H_to_RZ_dt enddo ; enddo ; enddo - call post_data(IDs%id_vmo, vmo, diag, alt_h = diag_pre_dyn%h_state) + call post_data(IDs%id_vmo, vmo, diag, alt_h=diag_pre_dyn%h_state) endif - if (IDs%id_uhtr > 0) call post_data(IDs%id_uhtr, uhtr, diag, alt_h = diag_pre_dyn%h_state) - if (IDs%id_vhtr > 0) call post_data(IDs%id_vhtr, vhtr, diag, alt_h = diag_pre_dyn%h_state) + if (IDs%id_uhtr > 0) call post_data(IDs%id_uhtr, uhtr, diag, alt_h=diag_pre_dyn%h_state) + if (IDs%id_vhtr > 0) call post_data(IDs%id_vhtr, vhtr, diag, alt_h=diag_pre_dyn%h_state) if (IDs%id_dynamics_h > 0) call post_data(IDs%id_dynamics_h, diag_pre_dyn%h_state, diag, & - alt_h = diag_pre_dyn%h_state) + alt_h=diag_pre_dyn%h_state) ! Post the change in thicknesses if (IDs%id_dynamics_h_tendency > 0) then h_tend(:,:,:) = 0. do k=1,nz ; do j=js,je ; do i=is,ie h_tend(i,j,k) = (h(i,j,k) - diag_pre_dyn%h_state(i,j,k))*Idt enddo ; enddo ; enddo - call post_data(IDs%id_dynamics_h_tendency, h_tend, diag, alt_h = diag_pre_dyn%h_state) + call post_data(IDs%id_dynamics_h_tendency, h_tend, diag, alt_h=diag_pre_dyn%h_state) endif call post_tracer_transport_diagnostics(G, GV, Reg, diag_pre_dyn%h_state, diag) @@ -1694,8 +1694,8 @@ subroutine MOM_diagnostics_init(MIS, ADp, CDp, Time, G, GV, US, param_file, diag CS%id_vsq = register_diag_field('ocean_model', 'vsq', diag%axesCvL, Time, & 'Meridional velocity squared', 'm2 s-2', conversion=US%L_T_to_m_s**2) CS%id_uv = register_diag_field('ocean_model', 'uv', diag%axesTL, Time, & - 'Product between zonal and meridional velocities at h-points', 'm2 s-2', & - conversion=US%L_T_to_m_s**2) + 'Product between zonal and meridional velocities at h-points', & + 'm2 s-2', conversion=US%L_T_to_m_s**2) CS%id_h = register_diag_field('ocean_model', 'h', diag%axesTL, Time, & 'Layer Thickness', thickness_units, v_extensive=.true., conversion=convert_H) @@ -1746,8 +1746,8 @@ subroutine MOM_diagnostics_init(MIS, ADp, CDp, Time, G, GV, US, param_file, diag endif !CS%id_hf_du_dt = register_diag_field('ocean_model', 'hf_dudt', diag%axesCuL, Time, & - ! 'Fractional Thickness-weighted Zonal Acceleration', 'm s-2', v_extensive=.true., & - ! conversion=US%L_T2_to_m_s2) + ! 'Fractional Thickness-weighted Zonal Acceleration', 'm s-2', conversion=US%L_T2_to_m_s2, & + ! v_extensive=.true.) !if (CS%id_hf_du_dt > 0) then ! call safe_alloc_ptr(CS%hf_du_dt,IsdB,IedB,jsd,jed,nz) ! if (.not.associated(CS%du_dt)) then @@ -1758,8 +1758,8 @@ subroutine MOM_diagnostics_init(MIS, ADp, CDp, Time, G, GV, US, param_file, diag !endif !CS%id_hf_dv_dt = register_diag_field('ocean_model', 'hf_dvdt', diag%axesCvL, Time, & - ! 'Fractional Thickness-weighted Meridional Acceleration', 'm s-2', v_extensive=.true., & - ! conversion=US%L_T2_to_m_s2) + ! 'Fractional Thickness-weighted Meridional Acceleration', 'm s-2', conversion=US%L_T2_to_m_s2, & + ! v_extensive=.true.) !if (CS%id_hf_dv_dt > 0) then ! call safe_alloc_ptr(CS%hf_dv_dt,isd,ied,JsdB,JedB,nz) ! if (.not.associated(CS%dv_dt)) then diff --git a/src/ice_shelf/MOM_ice_shelf.F90 b/src/ice_shelf/MOM_ice_shelf.F90 index 488269e974..fa38e928a0 100644 --- a/src/ice_shelf/MOM_ice_shelf.F90 +++ b/src/ice_shelf/MOM_ice_shelf.F90 @@ -1790,7 +1790,7 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces_in, meltrate_conversion = 86400.0*365.0*US%Z_to_m*US%s_to_T / CS%density_ice endif CS%id_melt = register_diag_field('ice_shelf_model', 'melt', CS%diag%axesT1, CS%Time, & - 'Ice Shelf Melt Rate', 'm yr-1', conversion= meltrate_conversion) + 'Ice Shelf Melt Rate', 'm yr-1', conversion=meltrate_conversion) CS%id_thermal_driving = register_diag_field('ice_shelf_model', 'thermal_driving', CS%diag%axesT1, CS%Time, & 'pot. temp. in the boundary layer minus freezing pot. temp. at the ice-ocean interface.', 'Celsius') CS%id_haline_driving = register_diag_field('ice_shelf_model', 'haline_driving', CS%diag%axesT1, CS%Time, & diff --git a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 index cf6845599b..ed47757840 100644 --- a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 +++ b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 @@ -546,10 +546,11 @@ subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_ 'x-velocity of ice', 'm yr-1', conversion=365.0*86400.0*US%L_T_to_m_s) CS%id_v_shelf = register_diag_field('ice_shelf_model','v_shelf',CS%diag%axesCv1, Time, & 'y-velocity of ice', 'm yr-1', conversion=365.0*86400.0*US%L_T_to_m_s) + ! I think that the conversion factors for the next two diagnostics are wrong. - RWH CS%id_taudx_shelf = register_diag_field('ice_shelf_model','taudx_shelf',CS%diag%axesT1, Time, & 'x-driving stress of ice', 'kPa', conversion=1.e-9*US%L_T_to_m_s) CS%id_taudy_shelf = register_diag_field('ice_shelf_model','taudy_shelf',CS%diag%axesT1, Time, & - 'x-driving stress of ice', 'kPa', conversion=1.e-9*US%L_T_to_m_s) + 'y-driving stress of ice', 'kPa', conversion=1.e-9*US%L_T_to_m_s) CS%id_u_mask = register_diag_field('ice_shelf_model','u_mask',CS%diag%axesCu1, Time, & 'mask for u-nodes', 'none') CS%id_v_mask = register_diag_field('ice_shelf_model','v_mask',CS%diag%axesCv1, Time, & diff --git a/src/parameterizations/lateral/MOM_hor_visc.F90 b/src/parameterizations/lateral/MOM_hor_visc.F90 index 661fb715e7..60e472f2de 100644 --- a/src/parameterizations/lateral/MOM_hor_visc.F90 +++ b/src/parameterizations/lateral/MOM_hor_visc.F90 @@ -2368,45 +2368,45 @@ subroutine hor_visc_init(Time, G, GV, US, param_file, diag, CS, MEKE, ADp) 'Meridional Acceleration from Horizontal Viscosity', 'm s-2', conversion=US%L_T2_to_m_s2) !CS%id_hf_diffu = register_diag_field('ocean_model', 'hf_diffu', diag%axesCuL, Time, & - ! 'Fractional Thickness-weighted Zonal Acceleration from Horizontal Viscosity', 'm s-2', & - ! v_extensive=.true., conversion=US%L_T2_to_m_s2) + ! 'Fractional Thickness-weighted Zonal Acceleration from Horizontal Viscosity', & + ! 'm s-2', v_extensive=.true., conversion=US%L_T2_to_m_s2) !if ((CS%id_hf_diffu > 0) .and. (present(ADp))) then ! call safe_alloc_ptr(CS%hf_diffu,G%IsdB,G%IedB,G%jsd,G%jed,GV%ke) ! call safe_alloc_ptr(ADp%diag_hfrac_u,G%IsdB,G%IedB,G%jsd,G%jed,GV%ke) !endif !CS%id_hf_diffv = register_diag_field('ocean_model', 'hf_diffv', diag%axesCvL, Time, & - ! 'Fractional Thickness-weighted Meridional Acceleration from Horizontal Viscosity', 'm s-2', & - ! v_extensive=.true., conversion=US%L_T2_to_m_s2) + ! 'Fractional Thickness-weighted Meridional Acceleration from Horizontal Viscosity', & + ! 'm s-2', v_extensive=.true., conversion=US%L_T2_to_m_s2) !if ((CS%id_hf_diffv > 0) .and. (present(ADp))) then ! call safe_alloc_ptr(CS%hf_diffv,G%isd,G%ied,G%JsdB,G%JedB,GV%ke) ! call safe_alloc_ptr(ADp%diag_hfrac_v,G%isd,G%ied,G%JsdB,G%JedB,GV%ke) !endif CS%id_hf_diffu_2d = register_diag_field('ocean_model', 'hf_diffu_2d', diag%axesCu1, Time, & - 'Depth-sum Fractional Thickness-weighted Zonal Acceleration from Horizontal Viscosity', 'm s-2', & - conversion=US%L_T2_to_m_s2) + 'Depth-sum Fractional Thickness-weighted Zonal Acceleration from Horizontal Viscosity', & + 'm s-2', conversion=US%L_T2_to_m_s2) if ((CS%id_hf_diffu_2d > 0) .and. (present(ADp))) then call safe_alloc_ptr(ADp%diag_hfrac_u,G%IsdB,G%IedB,G%jsd,G%jed,GV%ke) endif CS%id_hf_diffv_2d = register_diag_field('ocean_model', 'hf_diffv_2d', diag%axesCv1, Time, & - 'Depth-sum Fractional Thickness-weighted Meridional Acceleration from Horizontal Viscosity', 'm s-2', & - conversion=US%L_T2_to_m_s2) + 'Depth-sum Fractional Thickness-weighted Meridional Acceleration from Horizontal Viscosity', & + 'm s-2', conversion=US%L_T2_to_m_s2) if ((CS%id_hf_diffv_2d > 0) .and. (present(ADp))) then call safe_alloc_ptr(ADp%diag_hfrac_v,G%isd,G%ied,G%JsdB,G%JedB,GV%ke) endif CS%id_intz_diffu_2d = register_diag_field('ocean_model', 'intz_diffu_2d', diag%axesCu1, Time, & - 'Depth-integral of Zonal Acceleration from Horizontal Viscosity', 'm2 s-2', & - conversion=GV%H_to_m*US%L_T2_to_m_s2) + 'Depth-integral of Zonal Acceleration from Horizontal Viscosity', & + 'm2 s-2', conversion=GV%H_to_m*US%L_T2_to_m_s2) if ((CS%id_intz_diffu_2d > 0) .and. (present(ADp))) then call safe_alloc_ptr(ADp%diag_hu,G%IsdB,G%IedB,G%jsd,G%jed,GV%ke) endif CS%id_intz_diffv_2d = register_diag_field('ocean_model', 'intz_diffv_2d', diag%axesCv1, Time, & - 'Depth-integral of Meridional Acceleration from Horizontal Viscosity', 'm2 s-2', & - conversion=GV%H_to_m*US%L_T2_to_m_s2) + 'Depth-integral of Meridional Acceleration from Horizontal Viscosity', & + 'm2 s-2', conversion=GV%H_to_m*US%L_T2_to_m_s2) if ((CS%id_intz_diffv_2d > 0) .and. (present(ADp))) then call safe_alloc_ptr(ADp%diag_hv,G%isd,G%ied,G%JsdB,G%JedB,GV%ke) endif diff --git a/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 b/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 index b370332d90..9da72d9b2d 100644 --- a/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 +++ b/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 @@ -891,21 +891,21 @@ logical function mixedlayer_restrat_init(Time, G, GV, US, param_file, diag, CS, flux_to_kg_per_s = GV%H_to_kg_m2 * US%L_to_m**2 * US%s_to_T CS%id_uhml = register_diag_field('ocean_model', 'uhml', diag%axesCuL, Time, & - 'Zonal Thickness Flux to Restratify Mixed Layer', 'kg s-1', & - conversion=flux_to_kg_per_s, y_cell_method='sum', v_extensive=.true.) + 'Zonal Thickness Flux to Restratify Mixed Layer', & + 'kg s-1', conversion=flux_to_kg_per_s, y_cell_method='sum', v_extensive=.true.) CS%id_vhml = register_diag_field('ocean_model', 'vhml', diag%axesCvL, Time, & - 'Meridional Thickness Flux to Restratify Mixed Layer', 'kg s-1', & - conversion=flux_to_kg_per_s, x_cell_method='sum', v_extensive=.true.) + 'Meridional Thickness Flux to Restratify Mixed Layer', & + 'kg s-1', conversion=flux_to_kg_per_s, x_cell_method='sum', v_extensive=.true.) CS%id_urestrat_time = register_diag_field('ocean_model', 'MLu_restrat_time', diag%axesCu1, Time, & 'Mixed Layer Zonal Restratification Timescale', 's', conversion=US%T_to_s) CS%id_vrestrat_time = register_diag_field('ocean_model', 'MLv_restrat_time', diag%axesCv1, Time, & 'Mixed Layer Meridional Restratification Timescale', 's', conversion=US%T_to_s) CS%id_MLD = register_diag_field('ocean_model', 'MLD_restrat', diag%axesT1, Time, & - 'Mixed Layer Depth as used in the mixed-layer restratification parameterization', 'm', & - conversion=GV%H_to_m) + 'Mixed Layer Depth as used in the mixed-layer restratification parameterization', & + 'm', conversion=GV%H_to_m) CS%id_Rml = register_diag_field('ocean_model', 'ML_buoy_restrat', diag%axesT1, Time, & 'Mixed Layer Buoyancy as used in the mixed-layer restratification parameterization', & - 'm s2', conversion=US%m_to_Z*(US%L_to_m**2)*(US%s_to_T**2)) + 'm s2', conversion=US%m_to_Z*(US%L_T_to_m_s**2)) CS%id_uDml = register_diag_field('ocean_model', 'udml_restrat', diag%axesCu1, Time, & 'Transport stream function amplitude for zonal restratification of mixed layer', & 'm3 s-1', conversion=GV%H_to_m*(US%L_to_m**2)*US%s_to_T) diff --git a/src/parameterizations/vertical/MOM_diabatic_driver.F90 b/src/parameterizations/vertical/MOM_diabatic_driver.F90 index 1b27bc6904..9b33e68842 100644 --- a/src/parameterizations/vertical/MOM_diabatic_driver.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_driver.F90 @@ -3199,8 +3199,8 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di units='m', conversion=GV%H_to_m, v_extensive=.true.) CS%id_boundary_forcing_h_tendency = register_diag_field('ocean_model', & 'boundary_forcing_h_tendency', diag%axesTL, Time, & - 'Cell thickness tendency due to boundary forcing', 'm s-1', & - conversion=GV%H_to_m*US%s_to_T, v_extensive=.true.) + 'Cell thickness tendency due to boundary forcing', & + 'm s-1', conversion=GV%H_to_m*US%s_to_T, v_extensive=.true.) if (CS%id_boundary_forcing_h_tendency > 0) then CS%boundary_forcing_tendency_diag = .true. endif diff --git a/src/parameterizations/vertical/MOM_vert_friction.F90 b/src/parameterizations/vertical/MOM_vert_friction.F90 index d448751137..99450f87d9 100644 --- a/src/parameterizations/vertical/MOM_vert_friction.F90 +++ b/src/parameterizations/vertical/MOM_vert_friction.F90 @@ -1798,15 +1798,15 @@ subroutine vertvisc_init(MIS, Time, G, GV, US, param_file, diag, ADp, dirs, & if (CS%id_dv_dt_visc > 0) call safe_alloc_ptr(ADp%dv_dt_visc,isd,ied,JsdB,JedB,nz) CS%id_taux_bot = register_diag_field('ocean_model', 'taux_bot', diag%axesCu1, & - Time, 'Zonal Bottom Stress from Ocean to Earth', 'Pa', & - conversion=US%RZ_to_kg_m2*US%L_T2_to_m_s2) + Time, 'Zonal Bottom Stress from Ocean to Earth', & + 'Pa', conversion=US%RZ_to_kg_m2*US%L_T2_to_m_s2) CS%id_tauy_bot = register_diag_field('ocean_model', 'tauy_bot', diag%axesCv1, & - Time, 'Meridional Bottom Stress from Ocean to Earth', 'Pa', & - conversion=US%RZ_to_kg_m2*US%L_T2_to_m_s2) + Time, 'Meridional Bottom Stress from Ocean to Earth', & + 'Pa', conversion=US%RZ_to_kg_m2*US%L_T2_to_m_s2) !CS%id_hf_du_dt_visc = register_diag_field('ocean_model', 'hf_du_dt_visc', diag%axesCuL, Time, & - ! 'Fractional Thickness-weighted Zonal Acceleration from Vertical Viscosity', 'm s-2', & - ! v_extensive=.true., conversion=US%L_T2_to_m_s2) + ! 'Fractional Thickness-weighted Zonal Acceleration from Vertical Viscosity', & + ! 'm s-2', v_extensive=.true., conversion=US%L_T2_to_m_s2) !if (CS%id_hf_du_dt_visc > 0) then ! call safe_alloc_ptr(CS%hf_du_dt_visc,IsdB,IedB,jsd,jed,nz) ! call safe_alloc_ptr(ADp%du_dt_visc,IsdB,IedB,jsd,jed,nz) @@ -1814,8 +1814,8 @@ subroutine vertvisc_init(MIS, Time, G, GV, US, param_file, diag, ADp, dirs, & !endif !CS%id_hf_dv_dt_visc = register_diag_field('ocean_model', 'hf_dv_dt_visc', diag%axesCvL, Time, & - ! 'Fractional Thickness-weighted Meridional Acceleration from Vertical Viscosity', 'm s-2', & - ! v_extensive=.true., conversion=US%L_T2_to_m_s2) + ! 'Fractional Thickness-weighted Meridional Acceleration from Vertical Viscosity', & + ! 'm s-2', v_extensive=.true., conversion=US%L_T2_to_m_s2) !if (CS%id_hf_dv_dt_visc > 0) then ! call safe_alloc_ptr(CS%hf_dv_dt_visc,isd,ied,JsdB,JedB,nz) ! call safe_alloc_ptr(ADp%dv_dt_visc,isd,ied,JsdB,JedB,nz) @@ -1823,16 +1823,16 @@ subroutine vertvisc_init(MIS, Time, G, GV, US, param_file, diag, ADp, dirs, & !endif CS%id_hf_du_dt_visc_2d = register_diag_field('ocean_model', 'hf_du_dt_visc_2d', diag%axesCu1, Time, & - 'Depth-sum Fractional Thickness-weighted Zonal Acceleration from Vertical Viscosity', 'm s-2', & - conversion=US%L_T2_to_m_s2) + 'Depth-sum Fractional Thickness-weighted Zonal Acceleration from Vertical Viscosity', & + 'm s-2', conversion=US%L_T2_to_m_s2) if (CS%id_hf_du_dt_visc_2d > 0) then call safe_alloc_ptr(ADp%du_dt_visc,IsdB,IedB,jsd,jed,nz) call safe_alloc_ptr(ADp%diag_hfrac_u,IsdB,IedB,jsd,jed,nz) endif CS%id_hf_dv_dt_visc_2d = register_diag_field('ocean_model', 'hf_dv_dt_visc_2d', diag%axesCv1, Time, & - 'Depth-sum Fractional Thickness-weighted Meridional Acceleration from Vertical Viscosity', 'm s-2', & - conversion=US%L_T2_to_m_s2) + 'Depth-sum Fractional Thickness-weighted Meridional Acceleration from Vertical Viscosity', & + 'm s-2', conversion=US%L_T2_to_m_s2) if (CS%id_hf_dv_dt_visc_2d > 0) then call safe_alloc_ptr(ADp%dv_dt_visc,isd,ied,JsdB,JedB,nz) call safe_alloc_ptr(ADp%diag_hfrac_v,isd,ied,JsdB,JedB,nz) diff --git a/src/tracer/MOM_tracer_registry.F90 b/src/tracer/MOM_tracer_registry.F90 index 85913f8723..9977c26016 100644 --- a/src/tracer/MOM_tracer_registry.F90 +++ b/src/tracer/MOM_tracer_registry.F90 @@ -518,9 +518,8 @@ subroutine register_tracer_diagnostics(Reg, h, Time, diag, G, GV, US, use_ALE) Tr%id_adv_xy = register_diag_field('ocean_model', trim(shortnm)//"_advection_xy", & diag%axesTL, Time, & - 'Horizontal convergence of residual mean advective fluxes of '//& - trim(lowercase(flux_longname)), conv_units, v_extensive=.true., & - conversion=Tr%conv_scale*US%s_to_T) + 'Horizontal convergence of residual mean advective fluxes of '//trim(lowercase(flux_longname)), & + conv_units, v_extensive=.true., conversion=Tr%conv_scale*US%s_to_T) Tr%id_adv_xy_2d = register_diag_field('ocean_model', trim(shortnm)//"_advection_xy_2d", & diag%axesT1, Time, & 'Vertical sum of horizontal convergence of residual mean advective fluxes of '//& @@ -571,8 +570,8 @@ subroutine register_tracer_diagnostics(Reg, h, Time, diag, G, GV, US, use_ALE) trim(lowercase(flux_longname))//' content due to parameterized mesoscale neutral diffusion' Tr%id_dfxy_cont_2d = register_diag_field("ocean_model", trim(shortnm)//'_dfxy_cont_tendency_2d', & diag%axesT1, Time, "Depth integrated neutral diffusion tracer "//& - "content tendency for "//trim(shortnm), conv_units, & - conversion=Tr%conv_scale*US%s_to_T, cmor_field_name=trim(Tr%cmor_tendprefix)//'pmdiff_2d', & + "content tendency for "//trim(shortnm), conv_units, conversion=Tr%conv_scale*US%s_to_T, & + cmor_field_name=trim(Tr%cmor_tendprefix)//'pmdiff_2d', & cmor_long_name=trim(cmor_var_lname), cmor_standard_name=trim(cmor_long_std(cmor_var_lname)), & x_cell_method='sum', y_cell_method='sum') @@ -583,8 +582,8 @@ subroutine register_tracer_diagnostics(Reg, h, Time, diag, G, GV, US, use_ALE) Tr%id_lbdxy_cont_2d = register_diag_field("ocean_model", trim(shortnm)//'_lbdxy_cont_tendency_2d', & diag%axesT1, Time, "Depth integrated lateral diffusion tracer "//& - "content tendency for "//trim(shortnm), conv_units, & - conversion=Tr%conv_scale*US%s_to_T, x_cell_method='sum', y_cell_method='sum') + "content tendency for "//trim(shortnm), conv_units, conversion=Tr%conv_scale*US%s_to_T, & + x_cell_method='sum', y_cell_method='sum') endif Tr%id_dfxy_conc = register_diag_field("ocean_model", trim(shortnm)//'_dfxy_conc_tendency', & diag%axesTL, Time, "Neutral diffusion tracer concentration tendency for "//trim(shortnm), & @@ -597,25 +596,25 @@ subroutine register_tracer_diagnostics(Reg, h, Time, diag, G, GV, US, use_ALE) var_lname = "Net time tendency for "//lowercase(flux_longname) 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*US%s_to_T) + diag%axesTL, Time, var_lname, conv_units, conversion=Tr%conv_scale*US%s_to_T, & + v_extensive=.true.) 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*US%s_to_T) + diag%axesT1, Time, "Vertical sum of "//trim(lowercase(var_lname)), & + conv_units, conversion=Tr%conv_scale*US%s_to_T) else cmor_var_lname = "Tendency of "//trim(cmor_longname)//" Expressed as "//& trim(flux_longname)//" Content" Tr%id_trxh_tendency = register_diag_field('ocean_model', trim(shortnm)//'h_tendency', & - diag%axesTL, Time, var_lname, conv_units, & + diag%axesTL, Time, var_lname, conv_units, conversion=Tr%conv_scale*US%s_to_T, & 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*US%s_to_T) + v_extensive=.true.) 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, & + diag%axesT1, Time, "Vertical sum of "//trim(lowercase(var_lname)), & + conv_units, conversion=Tr%conv_scale*US%s_to_T, & 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*US%s_to_T) + cmor_standard_name=cmor_long_std(cmor_var_lname), cmor_long_name=cmor_var_lname) 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) From 3dc5cf7bee9678450a2a9b53eca9a408ccac83ca Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 4 May 2021 04:31:39 -0400 Subject: [PATCH 064/112] +Add dimensional rescaling of wave variables Added dimensional rescaling for all of the variables in the MOM_wave, including rescaling of the Stokes velocities, which are used in two modules outside of the MOM_wave_interface module. Also added comments describing numerous variables inside of the wave module, and removed the public declaration for most of the elements of the wave_parameters_CS. All answers are bitwise identical in tests, but the waves module is not as extensively tested as it should be. There are changes in the rescaled units in publicly visible variables. --- .../vertical/MOM_CVMix_KPP.F90 | 8 +- .../vertical/MOM_vert_friction.F90 | 8 +- src/user/MOM_wave_interface.F90 | 367 ++++++++++-------- 3 files changed, 210 insertions(+), 173 deletions(-) diff --git a/src/parameterizations/vertical/MOM_CVMix_KPP.F90 b/src/parameterizations/vertical/MOM_CVMix_KPP.F90 index 0dfa29931d..083f5ed000 100644 --- a/src/parameterizations/vertical/MOM_CVMix_KPP.F90 +++ b/src/parameterizations/vertical/MOM_CVMix_KPP.F90 @@ -1056,8 +1056,8 @@ subroutine KPP_compute_BLD(CS, G, GV, US, h, Temp, Salt, u, v, tv, uStar, buoyFl surfHu = surfHu + 0.5*US%L_T_to_m_s*(u(i,j,ktmp)+u(i-1,j,ktmp)) * delH surfHv = surfHv + 0.5*US%L_T_to_m_s*(v(i,j,ktmp)+v(i,j-1,ktmp)) * delH if (CS%Stokes_Mixing) then - surfHus = surfHus + 0.5*(WAVES%US_x(i,j,ktmp)+WAVES%US_x(i-1,j,ktmp)) * delH - surfHvs = surfHvs + 0.5*(WAVES%US_y(i,j,ktmp)+WAVES%US_y(i,j-1,ktmp)) * delH + surfHus = surfHus + 0.5*US%L_T_to_m_s*(WAVES%US_x(i,j,ktmp)+WAVES%US_x(i-1,j,ktmp)) * delH + surfHvs = surfHvs + 0.5*US%L_T_to_m_s*(WAVES%US_y(i,j,ktmp)+WAVES%US_y(i,j-1,ktmp)) * delH endif enddo @@ -1078,8 +1078,8 @@ subroutine KPP_compute_BLD(CS, G, GV, US, h, Temp, Salt, u, v, tv, uStar, buoyFl ! If momentum is mixed down the Stokes drift gradient, then ! the Stokes drift must be included in the bulk Richardson number ! calculation. - Uk = Uk + (0.5*(Waves%Us_x(i,j,k)+Waves%US_x(i-1,j,k)) -surfUs ) - Vk = Vk + (0.5*(Waves%Us_y(i,j,k)+Waves%Us_y(i,j-1,k)) -surfVs ) + Uk = Uk + (0.5*US%L_T_to_m_s*(Waves%Us_x(i,j,k)+Waves%US_x(i-1,j,k)) - surfUs ) + Vk = Vk + (0.5*US%L_T_to_m_s*(Waves%Us_y(i,j,k)+Waves%Us_y(i,j-1,k)) - surfVs ) endif deltaU2(k) = Uk**2 + Vk**2 diff --git a/src/parameterizations/vertical/MOM_vert_friction.F90 b/src/parameterizations/vertical/MOM_vert_friction.F90 index d448751137..740b8ff81d 100644 --- a/src/parameterizations/vertical/MOM_vert_friction.F90 +++ b/src/parameterizations/vertical/MOM_vert_friction.F90 @@ -254,7 +254,7 @@ subroutine vertvisc(u, v, h, forces, visc, dt, OBC, ADp, CDp, G, GV, US, CS, & ! When mixing down Eulerian current + Stokes drift add before calling solver if (DoStokesMixing) then ; do k=1,nz ; do I=Isq,Ieq - if (do_i(I)) u(I,j,k) = u(I,j,k) + US%m_s_to_L_T*Waves%Us_x(I,j,k) + if (do_i(I)) u(I,j,k) = u(I,j,k) + Waves%Us_x(I,j,k) enddo ; enddo ; endif if (associated(ADp%du_dt_visc)) then ; do k=1,nz ; do I=Isq,Ieq @@ -347,7 +347,7 @@ subroutine vertvisc(u, v, h, forces, visc, dt, OBC, ADp, CDp, G, GV, US, CS, & ! When mixing down Eulerian current + Stokes drift subtract after calling solver if (DoStokesMixing) then ; do k=1,nz ; do I=Isq,Ieq - if (do_i(I)) u(I,j,k) = u(I,j,k) - US%m_s_to_L_T*Waves%Us_x(I,j,k) + if (do_i(I)) u(I,j,k) = u(I,j,k) - Waves%Us_x(I,j,k) enddo ; enddo ; endif enddo ! end u-component j loop @@ -362,7 +362,7 @@ subroutine vertvisc(u, v, h, forces, visc, dt, OBC, ADp, CDp, G, GV, US, CS, & ! When mixing down Eulerian current + Stokes drift add before calling solver if (DoStokesMixing) then ; do k=1,nz ; do i=is,ie - if (do_i(i)) v(i,j,k) = v(i,j,k) + US%m_s_to_L_T*Waves%Us_y(i,j,k) + if (do_i(i)) v(i,j,k) = v(i,j,k) + Waves%Us_y(i,j,k) enddo ; enddo ; endif if (associated(ADp%dv_dt_visc)) then ; do k=1,nz ; do i=is,ie @@ -428,7 +428,7 @@ subroutine vertvisc(u, v, h, forces, visc, dt, OBC, ADp, CDp, G, GV, US, CS, & ! When mixing down Eulerian current + Stokes drift subtract after calling solver if (DoStokesMixing) then ; do k=1,nz ; do i=is,ie - if (do_i(i)) v(i,J,k) = v(i,J,k) - US%m_s_to_L_T*Waves%Us_y(i,J,k) + if (do_i(i)) v(i,J,k) = v(i,J,k) - Waves%Us_y(i,J,k) enddo ; enddo ; endif enddo ! end of v-component J loop diff --git a/src/user/MOM_wave_interface.F90 b/src/user/MOM_wave_interface.F90 index 082625f65e..c2a162c162 100644 --- a/src/user/MOM_wave_interface.F90 +++ b/src/user/MOM_wave_interface.F90 @@ -48,72 +48,77 @@ module MOM_wave_interface !> Container for all surface wave related parameters type, public :: wave_parameters_CS ; private - !Main surface wave options - logical, public :: UseWaves !< Flag to enable surface gravity wave feature - logical, public :: LagrangianMixing !< This feature is in development and not ready + ! Main surface wave options and publicly visible variables + logical, public :: UseWaves = .false. !< Flag to enable surface gravity wave feature + real, allocatable, dimension(:,:,:), public :: & + Us_x !< 3d zonal Stokes drift profile [L T-1 ~> m s-1] + !! Horizontal -> U points + !! Vertical -> Mid-points + real, allocatable, dimension(:,:,:), public :: & + Us_y !< 3d meridional Stokes drift profile [L T-1 ~> m s-1] + !! Horizontal -> V points + !! Vertical -> Mid-points + real, allocatable, dimension(:,:,:), public :: & + KvS !< Viscosity for Stokes Drift shear [Z2 T-1 ~> m2 s-1] + + ! The remainder of this control structure is private + logical :: LagrangianMixing !< This feature is in development and not ready !! True if Stokes drift is present and mixing !! should be applied to Lagrangian current !! (mean current + Stokes drift). !! See Reichl et al., 2016 KPP-LT approach - logical, public :: StokesMixing !< This feature is in development and not ready. + logical :: StokesMixing !< This feature is in development and not ready. !! True if vertical mixing of momentum !! should be applied directly to Stokes current !! (with separate mixing parameter for Eulerian !! mixing contribution). !! See Harcourt 2013, 2015 Second-Moment approach - logical, public :: CoriolisStokes !< This feature is in development and not ready. + logical :: CoriolisStokes !< This feature is in development and not ready. ! True if Coriolis-Stokes acceleration should be applied. - integer, public :: StkLevelMode=1 !< Sets if Stokes drift is defined at mid-points + integer :: StkLevelMode=1 !< Sets if Stokes drift is defined at mid-points !! or layer averaged. Set to 0 if mid-point and set to !! 1 if average value of Stokes drift over level. !! If advecting with Stokes transport, 1 is the correct !! approach. ! Surface Wave Dependent 1d/2d/3d vars - integer, public :: NumBands =0 !< Number of wavenumber/frequency partitions to receive + integer :: NumBands = 0 !< Number of wavenumber/frequency partitions to receive !! This needs to match the number of bands provided !! via either coupling or file. - real, allocatable, dimension(:), public :: & - WaveNum_Cen !< Wavenumber bands for read/coupled [m-1] - real, allocatable, dimension(:), public :: & - Freq_Cen !< Frequency bands for read/coupled [s-1] - real, allocatable, dimension(:), public :: & - PrescribedSurfStkX !< Surface Stokes drift if prescribed [m s-1] - real, allocatable, dimension(:), public :: & - PrescribedSurfStkY !< Surface Stokes drift if prescribed [m s-1] - real, allocatable, dimension(:,:,:), public :: & - Us_x !< 3d zonal Stokes drift profile [m s-1] - !! Horizontal -> U points - !! Vertical -> Mid-points - real, allocatable, dimension(:,:,:), public :: & - Us_y !< 3d meridional Stokes drift profile [m s-1] - !! Horizontal -> V points - !! Vertical -> Mid-points - real, allocatable, dimension(:,:), public :: & + real :: g_Earth !< The gravitational acceleration, equivalent to GV%g_Earth but with + !! different dimensional rescaling appropriate for deep-water gravity + !! waves [Z T-2 ~> m s-2] + real, allocatable, dimension(:) :: & + WaveNum_Cen !< Wavenumber bands for read/coupled [Z-1 ~> m-1] + real, allocatable, dimension(:) :: & + Freq_Cen !< Frequency bands for read/coupled [T-1 ~> s-1] + real, allocatable, dimension(:) :: & + PrescribedSurfStkX !< Surface Stokes drift if prescribed [L T-1 ~> m s-1] + real, allocatable, dimension(:) :: & + PrescribedSurfStkY !< Surface Stokes drift if prescribed [L T-1 ~> m s-1] + real, allocatable, dimension(:,:) :: & La_SL,& !< SL Langmuir number (directionality factored later) !! Horizontal -> H points - La_Turb !< Aligned Turbulent Langmuir number + La_Turb !< Aligned Turbulent Langmuir number [nondim] !! Horizontal -> H points - real, allocatable, dimension(:,:), public :: & - US0_x !< Surface Stokes Drift (zonal, m/s) + real, allocatable, dimension(:,:) :: & + US0_x !< Surface Stokes Drift (zonal) [L T-1 ~> m s-1] !! Horizontal -> U points - real, allocatable, dimension(:,:), public :: & - US0_y !< Surface Stokes Drift (meridional, m/s) + real, allocatable, dimension(:,:) :: & + US0_y !< Surface Stokes Drift (meridional) [L T-1 ~> m s-1] !! Horizontal -> V points - real, allocatable, dimension(:,:,:), public :: & - STKx0 !< Stokes Drift spectrum (zonal, m/s) + real, allocatable, dimension(:,:,:) :: & + STKx0 !< Stokes Drift spectrum (zonal) [L T-1 ~> m s-1] !! Horizontal -> U points !! 3rd dimension -> Freq/Wavenumber - real, allocatable, dimension(:,:,:), public :: & - STKy0 !< Stokes Drift spectrum (meridional, m/s) + real, allocatable, dimension(:,:,:) :: & + STKy0 !< Stokes Drift spectrum (meridional) [L T-1 ~> m s-1] !! Horizontal -> V points !! 3rd dimension -> Freq/Wavenumber - real, allocatable, dimension(:,:,:), public :: & - KvS !< Viscosity for Stokes Drift shear [Z2 T-1 ~> m2 s-1] ! Pointers to auxiliary fields - type(time_type), pointer, public :: Time !< A pointer to the ocean model's clock. - type(diag_ctrl), pointer, public :: diag !< A structure that is used to regulate the + type(time_type), pointer :: Time !< A pointer to the ocean model's clock. + type(diag_ctrl), pointer :: diag !< A structure that is used to regulate the !! timing of diagnostic output. !> An arbitrary lower-bound on the Langmuir number. Run-time parameter. @@ -124,9 +129,9 @@ module MOM_wave_interface real :: La_min = 0.05 !>@{ Diagnostic handles - integer, public :: id_surfacestokes_x = -1 , id_surfacestokes_y = -1 - integer, public :: id_3dstokes_x = -1 , id_3dstokes_y = -1 - integer, public :: id_La_turb = -1 + integer :: id_surfacestokes_x = -1 , id_surfacestokes_y = -1 + integer :: id_3dstokes_x = -1 , id_3dstokes_y = -1 + integer :: id_La_turb = -1 !>@} end type wave_parameters_CS @@ -143,7 +148,7 @@ module MOM_wave_interface !! \todo Module variable! Move into a control structure. ! Options if WaveMethod is Surface Stokes Drift Bands (1) -integer, public :: PartitionMode !< Method for partition mode (meant to check input) +integer :: PartitionMode !< Method for partition mode (meant to check input) !! 0 - wavenumbers !! 1 - frequencies !! \todo Module variable! Move into a control structure. @@ -180,10 +185,13 @@ module MOM_wave_interface DATAOVR = 1, COUPLER = 2, INPUT = 3 ! Options For Test Prof -Real :: TP_STKX0, TP_STKY0, TP_WVL +real :: TP_STKX0 ! Test profile x-stokes drift amplitude [L T-1 ~> m s-1] +real :: TP_STKY0 ! Test profile y-stokes drift amplitude [L T-1 ~> m s-1] +real :: TP_WVL ! Test profile wavelength [Z ~> m] logical :: WaveAgePeakFreq ! Flag to use W logical :: StaticWaves, DHH85_Is_Set -real :: WaveAge, WaveWind +real :: WaveAge +real :: WaveWind ! Wind speed for the test profile [L T-1 ~> m s-1] real :: PI !>@} @@ -228,7 +236,7 @@ subroutine MOM_wave_interface_init(time, G, GV, US, param_file, CS, diag ) dataOverrideIsInitialized = .false. ! The only way to get here is with UseWaves enabled. - CS%UseWaves=.true. + CS%UseWaves = .true. call log_version(param_file, mdl, version) @@ -255,6 +263,7 @@ subroutine MOM_wave_interface_init(time, G, GV, US, param_file, CS, diag ) ! Force Code Intervention call MOM_error(FATAL,"Should you be enabling Coriolis-Stokes? Code not ready.") endif + CS%g_Earth = US%L_to_Z**2*GV%g_Earth ! Get Wave Method and write to integer WaveMethod call get_param(param_file,mdl,"WAVE_METHOD",TMPSTRING1, & @@ -274,13 +283,14 @@ subroutine MOM_wave_interface_init(time, G, GV, US, param_file, CS, diag ) "WAVE_METHOD.") case (TESTPROF_STRING)! Test Profile WaveMethod = TESTPROF - call get_param(param_file,mdl,"TP_STKX_SURF",TP_STKX0,& + call get_param(param_file, mdl, "TP_STKX_SURF", TP_STKX0,& 'Surface Stokes (x) for test profile',& - units='m/s',default=0.1) - call get_param(param_file,mdl,"TP_STKY_SURF",TP_STKY0,& + units='m/s', default=0.1, scale=US%m_s_to_L_T) + call get_param(param_file, mdl, "TP_STKY_SURF", TP_STKY0,& 'Surface Stokes (y) for test profile',& - units='m/s',default=0.0) - call get_param(param_file,mdl,"TP_WVL",TP_WVL,& + units='m/s', default=0.0, scale=US%m_s_to_L_T) + call get_param(param_file,mdl, "TP_WVL", TP_WVL, & + 'Wavelength for test profile', & units='m', default=50.0, scale=US%m_to_Z) case (SURFBANDS_STRING)! Surface Stokes Drift Bands WaveMethod = SURFBANDS @@ -330,15 +340,15 @@ subroutine MOM_wave_interface_init(time, G, GV, US, param_file, CS, diag ) allocate( CS%STKy0(G%isd:G%ied,G%jsdB:G%jedB,1:CS%NumBands)) CS%STKy0(:,:,:) = 0.0 partitionmode=0 - call get_param(param_file,mdl,"SURFBAND_WAVENUMBERS",CS%WaveNum_Cen, & - "Central wavenumbers for surface Stokes drift bands.",units='rad/m', & - default=0.12566) - call get_param(param_file,mdl,"SURFBAND_STOKES_X",CS%PrescribedSurfStkX, & - "X-direction surface Stokes drift for bands.",units='m/s', & - default=0.15) - call get_param(param_file,mdl,"SURFBAND_STOKES_Y",CS%PrescribedSurfStkY, & - "Y-direction surface Stokes drift for bands.",units='m/s', & - default=0.0) + call get_param(param_file, mdl, "SURFBAND_WAVENUMBERS", CS%WaveNum_Cen, & + "Central wavenumbers for surface Stokes drift bands.", & + units='rad/m', default=0.12566, scale=US%Z_to_m) + call get_param(param_file, mdl, "SURFBAND_STOKES_X", CS%PrescribedSurfStkX, & + "X-direction surface Stokes drift for bands.", & + units='m/s', default=0.15, scale=US%m_s_to_L_T) + call get_param(param_file, mdl, "SURFBAND_STOKES_Y", CS%PrescribedSurfStkY, & + "Y-direction surface Stokes drift for bands.", & + units='m/s', default=0.0, scale=US%m_s_to_L_T) case default! No method provided call MOM_error(FATAL,'Check WAVE_METHOD.') end select @@ -353,9 +363,9 @@ subroutine MOM_wave_interface_init(time, G, GV, US, param_file, CS, diag ) call get_param(param_file,mdl,"DHH85_AGE",WaveAge, & "Wave Age for DHH85 spectrum.", & units='', default=1.2) - call get_param(param_file,mdl,"DHH85_WIND",WaveWind, & + call get_param(param_file,mdl,"DHH85_WIND", WaveWind, & "Wind speed for DHH85 spectrum.", & - units='', default=10.0) + units='m s-1', default=10.0, scale=US%m_s_to_L_T) call get_param(param_file,mdl,"STATIC_DHH85",StaticWaves, & "Flag to disable updating DHH85 Stokes drift.", & default=.false.) @@ -403,13 +413,13 @@ subroutine MOM_wave_interface_init(time, G, GV, US, param_file, CS, diag ) ! Initialize Wave related outputs CS%id_surfacestokes_y = register_diag_field('ocean_model','surface_stokes_y', & - CS%diag%axesCu1,Time,'Surface Stokes drift (y)','m s-1') + CS%diag%axesCu1,Time,'Surface Stokes drift (y)', 'm s-1', conversion=US%L_T_to_m_s) CS%id_surfacestokes_x = register_diag_field('ocean_model','surface_stokes_x', & - CS%diag%axesCv1,Time,'Surface Stokes drift (x)','m s-1') + CS%diag%axesCv1,Time,'Surface Stokes drift (x)', 'm s-1', conversion=US%L_T_to_m_s) CS%id_3dstokes_y = register_diag_field('ocean_model','3d_stokes_y', & - CS%diag%axesCvL,Time,'3d Stokes drift (y)','m s-1') + CS%diag%axesCvL,Time,'3d Stokes drift (y)', 'm s-1', conversion=US%L_T_to_m_s) CS%id_3dstokes_x = register_diag_field('ocean_model','3d_stokes_x', & - CS%diag%axesCuL,Time,'3d Stokes drift (y)','m s-1') + CS%diag%axesCuL,Time,'3d Stokes drift (y)', 'm s-1', conversion=US%L_T_to_m_s) CS%id_La_turb = register_diag_field('ocean_model','La_turbulent',& CS%diag%axesT1,Time,'Surface (turbulent) Langmuir number','nondim') @@ -472,23 +482,23 @@ subroutine Update_Surface_Waves(G, GV, US, Day, dt, CS, forces) "check the arguments in the subroutine call to Update_Surface_Waves, "//& "otherwise select another option for SURFBAND_SOURCE.") endif - if (size(CS%WaveNum_Cen).ne.size(forces%stk_wavenumbers)) then + if (size(CS%WaveNum_Cen) /= size(forces%stk_wavenumbers)) then call MOM_error(FATAL, "Number of wavenumber bands in WW3 does not match that in MOM6. "//& "Make sure that STK_BAND_COUPLER in MOM6 input is equal to the number of bands in "//& "ww3_grid.inp, and that your mod_def.ww3 is up to date.") endif do b=1,CS%NumBands - CS%WaveNum_Cen(b) = forces%stk_wavenumbers(b) + CS%WaveNum_Cen(b) = US%Z_to_m * forces%stk_wavenumbers(b) !Interpolate from a grid to c grid do jj=G%jsc,G%jec do II=G%iscB,G%iecB - CS%STKx0(II,jj,b) = 0.5*(forces%UStkb(ii,jj,b)+forces%UStkb(ii+1,jj,b)) + CS%STKx0(II,jj,b) = US%m_s_to_L_T*0.5*(forces%UStkb(ii,jj,b)+forces%UStkb(ii+1,jj,b)) enddo enddo do JJ=G%jscB, G%jecB do ii=G%isc,G%iec - CS%STKY0(ii,JJ,b) = 0.5*(forces%VStkb(ii,jj,b)+forces%VStkb(ii,jj+1,b)) + CS%STKY0(ii,JJ,b) = US%m_s_to_L_T*0.5*(forces%VStkb(ii,jj,b)+forces%VStkb(ii,jj+1,b)) enddo enddo call pass_vector(CS%STKx0(:,:,b),CS%STKy0(:,:,b), G%Domain) @@ -524,10 +534,15 @@ subroutine Update_Stokes_Drift(G, GV, US, CS, h, ustar) real, dimension(SZI_(G),SZJ_(G)), & intent(in) :: ustar !< Wind friction velocity [Z T-1 ~> m s-1]. ! Local Variables - real :: Top, MidPoint, Bottom, one_cm, level_thick, min_level_thick_avg - real :: DecayScale - real :: CMN_FAC, WN, UStokes - real :: La + real :: Top, MidPoint, Bottom ! Positions within the layer [Z ~> m] + real :: one_cm ! One centimeter in the units of wavelengths [Z ~> m] + real :: level_thick ! The thickness of each layer [Z ~> m] + real :: min_level_thick_avg ! A minimum layer thickness for inclusion in the average [Z ~> m] + real :: DecayScale ! A vertical decay scale in the test profile [Z ~> m] + real :: CMN_FAC ! A nondimensional factor [nondim] + real :: WN ! Model wavenumber [Z-1 ~> m-1] + real :: UStokes ! A Stokes drift velocity [L T-1 ~> m s-1] + real :: La ! The local Langmuir number [nondim] integer :: ii, jj, kk, b, iim1, jjm1 one_cm = 0.01*US%m_to_Z @@ -605,11 +620,11 @@ subroutine Update_Stokes_Drift(G, GV, US, CS, h, ustar) elseif (PartitionMode==1) then if (CS%StkLevelMode==0) then ! Take the value at the midpoint - CMN_FAC = exp(MidPoint*2.*(2.*PI*CS%Freq_Cen(b)*US%T_to_s)**2/(US%L_to_Z**2*GV%g_Earth)) + CMN_FAC = exp(MidPoint*2.*(2.*PI*CS%Freq_Cen(b))**2 / CS%g_Earth) elseif (CS%StkLevelMode==1) then ! Use a numerical integration and then ! divide by layer thickness - WN = (2.*PI*CS%Freq_Cen(b)*US%T_to_s)**2 / (US%L_to_Z**2*GV%g_Earth) !bgr bug-fix missing g + WN = (2.*PI*CS%Freq_Cen(b))**2 / CS%g_Earth !bgr bug-fix missing g CMN_FAC = (exp(2.*WN*Top)-exp(2.*WN*Bottom)) / (2.*WN*(Top-Bottom)) endif endif @@ -621,7 +636,7 @@ subroutine Update_Stokes_Drift(G, GV, US, CS, h, ustar) if (PartitionMode==0) then CMN_FAC = exp(MidPoint*2.*CS%WaveNum_Cen(b)) elseif (PartitionMode==1) then - CMN_FAC = exp(MidPoint*2.*(2.*PI*CS%Freq_Cen(b)*US%T_to_s)**2/(US%L_to_Z**2*GV%g_Earth)) + CMN_FAC = exp(MidPoint*2.*(2.*PI*CS%Freq_Cen(b))**2 / CS%g_Earth) endif CS%US_x(II,jj,kk) = CS%US_x(II,jj,kk) + CS%STKx0(II,jj,b)*CMN_FAC enddo @@ -662,11 +677,11 @@ subroutine Update_Stokes_Drift(G, GV, US, CS, h, ustar) elseif (PartitionMode==1) then if (CS%StkLevelMode==0) then ! Take the value at the midpoint - CMN_FAC = exp(MidPoint*2.*(2.*PI*CS%Freq_Cen(b)*US%T_to_s)**2/(US%L_to_Z**2*GV%g_Earth)) + CMN_FAC = exp(MidPoint*2.*(2.*PI*CS%Freq_Cen(b))**2 / CS%g_Earth) elseif (CS%StkLevelMode==1) then ! Use a numerical integration and then ! divide by layer thickness - WN = (2.*PI*CS%Freq_Cen(b)*US%T_to_s)**2 / (US%L_to_Z**2*GV%g_Earth) !bgr bug-fix missing g + WN = (2.*PI*CS%Freq_Cen(b))**2 / CS%g_Earth !bgr bug-fix missing g CMN_FAC = (exp(2.*WN*Top)-exp(2.*WN*Bottom)) / (2.*WN*(Top-Bottom)) endif endif @@ -678,7 +693,7 @@ subroutine Update_Stokes_Drift(G, GV, US, CS, h, ustar) if (PartitionMode==0) then CMN_FAC = exp(MidPoint*2.*CS%WaveNum_Cen(b)) elseif (PartitionMode==1) then - CMN_FAC = exp(MidPoint*2.*(2.*PI*CS%Freq_Cen(b)*US%T_to_s)**2/(US%L_to_Z**2*GV%g_Earth)) + CMN_FAC = exp(MidPoint*2.*(2.*PI*CS%Freq_Cen(b))**2 / CS%g_Earth) endif CS%US_y(ii,JJ,kk) = CS%US_y(ii,JJ,kk) + CS%STKy0(ii,JJ,b)*CMN_FAC enddo @@ -700,7 +715,7 @@ subroutine Update_Stokes_Drift(G, GV, US, CS, h, ustar) ! this code has only been previous used for uniform ! grid cases. This needs fixed if DHH85 is used for non ! uniform cases. - call DHH85_mid(GV, US, MidPoint, UStokes) + call DHH85_mid(GV, US, CS, MidPoint, UStokes) ! Putting into x-direction (no option for direction CS%US_x(II,jj,kk) = UStokes enddo @@ -718,7 +733,7 @@ subroutine Update_Stokes_Drift(G, GV, US, CS, h, ustar) ! this code has only been previous used for uniform ! grid cases. This needs fixed if DHH85 is used for non ! uniform cases. - ! call DHH85_mid(GV, US, Midpoint, UStokes) + ! call DHH85_mid(GV, US, CS, Midpoint, UStokes) ! Putting into x-direction, so setting y direction to 0 CS%US_y(ii,JJ,kk) = 0.0 ! For rotational symmetry there should be the option for this to become = UStokes @@ -822,10 +837,10 @@ subroutine Surface_Bands_by_data_override(day_center, G, GV, US, CS) allocate( CS%WaveNum_Cen(CS%NUMBANDS) ) ; CS%WaveNum_Cen(:) = 0.0 ! Reading frequencies - call read_variable(SurfBandFileName, dim_name(1), CS%Freq_Cen) !, scale=US%T_to_s) + call read_variable(SurfBandFileName, dim_name(1), CS%Freq_Cen, scale=US%T_to_s) do B = 1,CS%NumBands - CS%WaveNum_Cen(b) = (2.*PI*CS%Freq_Cen(b)*US%T_to_s)**2 / (US%L_to_Z**2*GV%g_Earth) + CS%WaveNum_Cen(b) = (2.*PI*CS%Freq_Cen(b))**2 / CS%g_Earth enddo else @@ -845,14 +860,14 @@ subroutine Surface_Bands_by_data_override(day_center, G, GV, US, CS) temp_x(:,:) = 0.0 temp_y(:,:) = 0.0 varname = ' ' - write(varname,"(A3,I0)")'Usx',b + write(varname, "(A3,I0)") 'Usx', b call data_override('OCN', trim(varname), temp_x, day_center) varname = ' ' - write(varname,'(A3,I0)')'Usy',b + write(varname, "(A3,I0)") 'Usy', b call data_override('OCN', trim(varname), temp_y, day_center) - ! Disperse into halo on h-grid + ! Update halo on h-grid call pass_vector(temp_x, temp_y, G%Domain, To_All, AGRID) - !Filter land values + ! Filter land values do j = G%jsd,G%jed do i = G%Isd,G%Ied if (abs(temp_x(i,j)) > 10. .or. abs(temp_y(i,j)) > 10.) then @@ -866,18 +881,19 @@ subroutine Surface_Bands_by_data_override(day_center, G, GV, US, CS) ! Interpolate to u/v grids do j = G%jsc,G%jec do I = G%IscB,G%IecB - CS%STKx0(I,j,b) = 0.5 * (temp_x(i,j) + temp_x(i+1,j)) + CS%STKx0(I,j,b) = 0.5 * US%m_s_to_L_T*(temp_x(i,j) + temp_x(i+1,j)) enddo enddo do J = G%JscB,G%JecB do i = G%isc,G%iec - CS%STKy0(i,J,b) = 0.5 * (temp_y(i,j) + temp_y(i,j+1)) + CS%STKy0(i,J,b) = 0.5 * US%m_s_to_L_T*(temp_y(i,j) + temp_y(i,j+1)) enddo enddo - ! Disperse into halo on u/v grids (This would be faster if it were moved out of the b-loop.) - call pass_vector(CS%STKx0(:,:,b), CS%STKy0(:,:,b), G%Domain, To_ALL) enddo !Closes b-loop + ! Update halo on u/v grids + call pass_vector(CS%STKx0(:,:,:), CS%STKy0(:,:,:), G%Domain, To_ALL) + end subroutine Surface_Bands_by_data_override !> Interface to get Langmuir number based on options stored in wave structure @@ -901,21 +917,23 @@ subroutine get_Langmuir_Number( LA, G, GV, US, HBL, ustar, i, j, & real, dimension(SZK_(GV)), optional, & intent(in) :: H !< Grid layer thickness [H ~> m or kg m-2] real, dimension(SZK_(GV)), optional, & - intent(in) :: U_H !< Zonal velocity at H point [m s-1] + intent(in) :: U_H !< Zonal velocity at H point [L T-1 ~> m s-1] or [m s-1] real, dimension(SZK_(GV)), optional, & - intent(in) :: V_H !< Meridional velocity at H point [m s-1] + intent(in) :: V_H !< Meridional velocity at H point [L T-1 ~> m s-1] or [m s-1] type(Wave_parameters_CS), & pointer :: Waves !< Surface wave control structure. - real, intent(out) :: LA !< Langmuir number + real, intent(out) :: LA !< Langmuir number [nondim] !Local Variables - real :: Top, bottom, midpoint - real :: Dpt_LASL, ShearDirection, WaveDirection - real :: LA_STKx, LA_STKy, LA_STK ! Stokes velocities in [m s-1] + real :: Top, bottom, midpoint ! Positions within each layer [Z ~> m] + real :: Dpt_LASL ! Averaging depth for Stokes drift [Z ~> m] + real :: ShearDirection ! Shear angular direction from atan2 [radians] + real :: WaveDirection ! Wave angular direction from atan2 [radians] + real :: LA_STKx, LA_STKy, LA_STK ! Stokes velocities in [L T-1 ~> m s-1] logical :: ContinueLoop, USE_MA - real, dimension(SZK_(GV)) :: US_H, VS_H - real, allocatable :: StkBand_X(:), StkBand_Y(:) + real, dimension(SZK_(GV)) :: US_H, VS_H ! Profiles of Stokes velocities [L T-1 ~> m s-1] + real, allocatable :: StkBand_X(:), StkBand_Y(:) ! Stokes drifts by band [L T-1 ~> m s-1] integer :: KK, BB @@ -971,7 +989,7 @@ subroutine get_Langmuir_Number( LA, G, GV, US, HBL, ustar, i, j, & call Get_SL_Average_Prof( GV, Dpt_LASL, H, VS_H, LA_STKy) LA_STK = sqrt(LA_STKX**2 + LA_STKY**2) elseif (WaveMethod==LF17) then - call get_StokesSL_LiFoxKemper(ustar, hbl*LA_FracHBL, GV, US, LA_STK, LA) + call get_StokesSL_LiFoxKemper(ustar, hbl*LA_FracHBL, GV, US, Waves, LA_STK, LA) elseif (WaveMethod==Null_WaveMethod) then call MOM_error(FATAL, "Get_Langmuir_number called without defining a WaveMethod. "//& "Suggest to make sure USE_LT is set/overridden to False or "//& @@ -986,7 +1004,7 @@ subroutine get_Langmuir_Number( LA, G, GV, US, HBL, ustar, i, j, & ! to prevent large enhancements in unconstrained parts of ! the curve fit parameterizations. ! Note the dimensional constant background Stokes velocity of 10^-10 m s-1. - LA = max(WAVES%La_min, sqrt(US%Z_to_m*US%s_to_T*ustar / (LA_STK+1.e-10))) + LA = max(WAVES%La_min, sqrt(US%Z_to_L*ustar / (LA_STK + 1.e-10*US%m_s_to_L_T))) endif if (Use_MA) then @@ -1013,44 +1031,51 @@ end subroutine get_Langmuir_Number !! - BGR change output to LA from Efactor !! - BGR remove u10 input !! - BGR note: fixed parameter values should be changed to "get_params" -subroutine get_StokesSL_LiFoxKemper(ustar, hbl, GV, US, UStokes_SL, LA) +subroutine get_StokesSL_LiFoxKemper(ustar, hbl, GV, US, CS, UStokes_SL, LA) real, intent(in) :: ustar !< water-side surface friction velocity [Z T-1 ~> m s-1]. real, intent(in) :: hbl !< boundary layer depth [Z ~> m]. type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - real, intent(out) :: UStokes_SL !< Surface layer averaged Stokes drift [m s-1] + type(wave_parameters_CS), pointer :: CS !< Wave parameter Control structure + real, intent(out) :: UStokes_SL !< Surface layer averaged Stokes drift [L T-1 ~> m s-1] real, intent(out) :: LA !< Langmuir number ! Local variables ! parameters real, parameter :: & - ! ratio of U19.5 to U10 (Holthuijsen, 2007) + ! ratio of U19.5 to U10 (Holthuijsen, 2007) [nondim] u19p5_to_u10 = 1.075, & ! ratio of mean frequency to peak frequency for - ! Pierson-Moskowitz spectrum (Webb, 2011) + ! Pierson-Moskowitz spectrum (Webb, 2011) [nondim] fm_into_fp = 1.296, & - ! ratio of surface Stokes drift to U10 + ! ratio of surface Stokes drift to U10 [nondim] us_to_u10 = 0.0162, & - ! loss ratio of Stokes transport + ! loss ratio of Stokes transport [nondim] r_loss = 0.667 - real :: UStokes, hm0, fm, fp, vstokes, kphil, kstar - real :: z0, z0i, r1, r2, r3, r4, tmp, lasl_sqr_i - real :: u10 + real :: UStokes ! The surface Stokes drift [L T-1 ~> m s-1] + real :: hm0 ! The significant wave height [Z ~> m] + real :: fm ! The mean wave frequency [T-1 ~> s-1] + real :: fp ! The peak wave frequency [T-1 ~> s-1] + real :: kphil ! A peak wavenumber in the Phillips spectrum [Z-1 ~> m-1] + real :: kstar ! A rescaled wavenumber? [Z-1 ~> m-1] + real :: vstokes ! The total Stokes transport [Z L T-1 ~> m2 s-1] + real :: z0 ! The boundary layer depth [Z ~> m] + real :: z0i ! The inverse of theboundary layer depth [Z-1 ~> m-1] + real :: r1, r2, r3, r4 ! Nondimensional ratios [nondim] + real :: u10 ! The 10 m wind speed [L T-1 ~> m s-1] UStokes_sl = 0.0 - LA=1.e8 + LA = 1.e8 if (ustar > 0.0) then ! Computing u10 based on u_star and COARE 3.5 relationships - call ust_2_u10_coare3p5(US%Z_to_m*US%s_to_T*ustar*sqrt(US%R_to_kg_m3*GV%Rho0/1.225), u10, GV, US) + call ust_2_u10_coare3p5(ustar*sqrt(GV%Rho0/(1.225*US%kg_m3_to_R)), u10, GV, US, CS) ! surface Stokes drift UStokes = us_to_u10*u10 ! - ! significant wave height from Pierson-Moskowitz - ! spectrum (Bouws, 1998) - hm0 = 0.0246 *u10**2 + ! significant wave height from Pierson-Moskowitz spectrum (Bouws, 1998) + hm0 = 0.0246*US%m_to_Z*US%L_T_to_m_s**2 * u10**2 ! ! peak frequency (PM, Bouws, 1998) - tmp = 2.0 * PI * u19p5_to_u10 * u10 - fp = 0.877 * US%L_T_to_m_s**2*US%m_to_Z * GV%g_Earth / tmp + fp = 0.877 * US%Z_to_L*CS%g_Earth / (2.0 * PI * u19p5_to_u10 * u10) ! ! mean frequency fm = fm_into_fp * fp @@ -1059,19 +1084,19 @@ subroutine get_StokesSL_LiFoxKemper(ustar, hbl, GV, US, UStokes_SL, LA) ! for the effect of directional spreading, multidirectional waves ! and the use of PM peak frequency and PM significant wave height ! on estimating the Stokes transport) - vstokes = 0.125 * PI * r_loss * fm * hm0**2 + vstokes = 0.125 * PI * r_loss * US%Z_to_L * fm * hm0**2 ! ! the general peak wavenumber for Phillips' spectrum ! (Breivik et al., 2016) with correction of directional spreading kphil = 0.176 * UStokes / vstokes ! - ! surface layer averaged Stokes dirft with Stokes drift profile + ! surface layer averaged Stokes drift with Stokes drift profile ! estimated from Phillips' spectrum (Breivik et al., 2016) ! the directional spreading effect from Webb and Fox-Kemper, 2015 ! is also included kstar = kphil * 2.56 ! surface layer - z0 = abs(US%Z_to_m*hbl) + z0 = abs(hbl) z0i = 1.0 / z0 ! term 1 to 4 r1 = ( 0.151 / kphil * z0i -0.84 ) * & @@ -1082,10 +1107,10 @@ subroutine get_StokesSL_LiFoxKemper(ustar, hbl, GV, US, UStokes_SL, LA) r3 = ( 0.0632 / kstar * z0i + 0.125 ) * & (1.0 - exp(-2.0 * kstar * z0) ) r4 = ( 0.125 + 0.0946 / kstar * z0i ) * & - sqrt( 2.0 * PI *kstar * z0) * & + sqrt( 2.0 * PI * kstar * z0) * & erfc( sqrt( 2.0 * kstar * z0 ) ) UStokes_sl = UStokes * (0.715 + r1 + r2 + r3 + r4) - if(UStokes_sl .ne. 0.0)LA = sqrt(US%Z_to_m*US%s_to_T*ustar / UStokes_sl) + if (UStokes_sl /= 0.0) LA = sqrt(US%Z_to_L*ustar / UStokes_sl) endif end subroutine Get_StokesSL_LiFoxKemper @@ -1146,8 +1171,8 @@ subroutine Get_SL_Average_Band( GV, AvgDepth, NB, WaveNumbers, SurfStokes, Avera real, dimension(NB), & intent(in) :: WaveNumbers !< Wavenumber corresponding to each band [Z-1 ~> m-1] real, dimension(NB), & - intent(in) :: SurfStokes !< Surface Stokes drift for each band [m s-1] - real, intent(out) :: Average !< Output average Stokes drift over depth AvgDepth [m s-1] + intent(in) :: SurfStokes !< Surface Stokes drift for each band [L T-1 ~> m s-1] + real, intent(out) :: Average !< Output average Stokes drift over depth AvgDepth [L T-1 ~> m s-1] ! Local variables integer :: bb @@ -1171,42 +1196,47 @@ end subroutine Get_SL_Average_Band !! use for comparing MOM6 simulation to his LES !! computed at z mid point (I think) and not depth averaged. !! Should be fine to integrate in frequency from 0.1 to sqrt(-0.2*grav*2pi/dz -subroutine DHH85_mid(GV, US, zpt, UStokes) +subroutine DHH85_mid(GV, US, CS, zpt, UStokes) type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(wave_parameters_CS), pointer :: CS !< Wave parameter Control structure real, intent(in) :: zpt !< Depth to get Stokes drift [Z ~> m]. - real, intent(out) :: UStokes !< Stokes drift [m s-1] + real, intent(out) :: UStokes !< Stokes drift [L T-1 ~> m s-1] ! - real :: ann, Bnn, Snn, Cnn, Dnn - real :: omega_peak, omega, u10, WA, domega - real :: omega_min, omega_max, wavespec, Stokes - real :: g_Earth ! Gravitational acceleration [m s-2] - integer :: Nomega, OI - - WA = WaveAge - u10 = WaveWind - g_Earth = US%L_T_to_m_s**2*US%m_to_Z * GV%g_Earth + real :: ann, Bnn, Snn, Cnn, Dnn ! Nondimensional factors [nondim] + real :: omega_peak ! The peak wave frequency [T-1 ~> s-1] + real :: omega ! The average frequency in the band [T-1 ~> s-1] + real :: domega ! The width in frequency of the band [T-1 ~> s-1] + real :: omega_min ! The minimum wave frequency [T-1 ~> s-1] + real :: omega_max ! The maximum wave frequency [T-1 ~> s-1] + real :: u10 ! The wind speed for this spectrum [Z T-1 ~> m s-1] + real :: wavespec ! The wave spectrum [L Z T ~> m2 s] + real :: Stokes ! The Stokes displacement per cycle [L ~> m] + integer :: Nomega ! The number of wavenumber bands + integer :: OI + + u10 = WaveWind*US%L_to_Z !/ - omega_min = 0.1 ! Hz + omega_min = 0.1*US%T_to_s ! Hz ! Cut off at 30cm for now... - omega_max = 10. ! ~sqrt(0.2*g_Earth*2*pi/0.3) + omega_max = 10.*US%T_to_s ! ~sqrt(0.2*g_Earth*2*pi/0.3) NOmega = 1000 domega = (omega_max-omega_min)/real(NOmega) ! if (WaveAgePeakFreq) then - omega_peak = g_Earth / (WA * u10) + omega_peak = CS%g_Earth / (WaveAge * u10) else - omega_peak = 2. * pi * 0.13 * g_Earth / U10 + omega_peak = 2. * pi * 0.13 * CS%g_Earth / u10 endif !/ Ann = 0.006 * WaveAge**(-0.55) Bnn = 1.0 Snn = 0.08 * (1.0 + 4.0 * WaveAge**3) Cnn = 1.7 - if (WA < 1.) then - Cnn = Cnn - 6.0*log10(WA) + if (WaveAge < 1.) then + Cnn = Cnn - 6.0*log10(WaveAge) endif !/ UStokes = 0.0 @@ -1214,11 +1244,11 @@ subroutine DHH85_mid(GV, US, zpt, UStokes) do oi = 1,nomega-1 Dnn = exp ( -0.5 * (omega-omega_peak)**2 / (Snn**2 * omega_peak**2) ) ! wavespec units = m2s - wavespec = (Ann * g_Earth**2 / (omega_peak*omega**4 ) ) * & + wavespec = US%Z_to_L * (Ann * CS%g_Earth**2 / (omega_peak*omega**4 ) ) * & exp(-bnn*(omega_peak/omega)**4)*Cnn**Dnn ! Stokes units m (multiply by frequency range for units of m/s) Stokes = 2.0 * wavespec * omega**3 * & - exp( 2.0 * omega**2 * US%Z_to_m*zpt / g_Earth) / g_Earth + exp( 2.0 * omega**2 * zpt / CS%g_Earth) / CS%g_Earth UStokes = UStokes + Stokes*domega omega = omega + domega enddo @@ -1237,13 +1267,13 @@ subroutine StokesMixing(G, GV, dt, h, u, v, Waves ) real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & - intent(inout) :: u !< Velocity i-component [m s-1] + intent(inout) :: u !< Velocity i-component [L T-1 ~> m s-1] real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & - intent(inout) :: v !< Velocity j-component [m s-1] + intent(inout) :: v !< Velocity j-component [L T-1 ~> m s-1] type(Wave_parameters_CS), & pointer :: Waves !< Surface wave related control structure. ! Local variables - real :: dTauUp, dTauDn ! Vertical momentum fluxes [Z T-1 m s-1] + real :: dTauUp, dTauDn ! Vertical momentum fluxes [Z L T-2 ~> m2 s-2] real :: h_Lay ! The layer thickness at a velocity point [Z ~> m]. integer :: i,j,k @@ -1296,23 +1326,23 @@ end subroutine StokesMixing !! CHECK THAT RIGHT TIMESTEP IS PASSED IF YOU USE THIS** !! !! Not accessed in the standard code. -subroutine CoriolisStokes(G, GV, DT, h, u, v, WAVES, US) +subroutine CoriolisStokes(G, GV, dt, h, u, v, WAVES, US) type(ocean_grid_type), & intent(in) :: G !< Ocean grid type(verticalGrid_type), & intent(in) :: GV !< Ocean vertical grid - real, intent(in) :: Dt !< Time step of MOM6 [s] CHECK IF PASSING RIGHT TIMESTEP + real, intent(in) :: dt !< Time step of MOM6 [T ~> s] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & - intent(inout) :: u !< Velocity i-component [m s-1] + intent(inout) :: u !< Velocity i-component [L T-1 ~> m s-1] real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & - intent(inout) :: v !< Velocity j-component [m s-1] + intent(inout) :: v !< Velocity j-component [L T-1 ~> m s-1] type(Wave_parameters_CS), & pointer :: Waves !< Surface wave related control structure. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type ! Local variables - real :: DVel ! A rescaled velocity change [m s-1 T-1 ~> m s-2] + real :: DVel ! A rescaled velocity change [L T-2 ~> m s-2] integer :: i,j,k do k = 1, GV%ke @@ -1320,7 +1350,7 @@ subroutine CoriolisStokes(G, GV, DT, h, u, v, WAVES, US) do I = G%iscB, G%iecB DVel = 0.25*(WAVES%us_y(i,j+1,k)+WAVES%us_y(i-1,j+1,k))*G%CoriolisBu(i,j+1) + & 0.25*(WAVES%us_y(i,j,k)+WAVES%us_y(i-1,j,k))*G%CoriolisBu(i,j) - u(I,j,k) = u(I,j,k) + DVEL*US%s_to_T*DT + u(I,j,k) = u(I,j,k) + DVEL*dt enddo enddo enddo @@ -1330,7 +1360,7 @@ subroutine CoriolisStokes(G, GV, DT, h, u, v, WAVES, US) do i = G%isc, G%iec DVel = 0.25*(WAVES%us_x(i+1,j,k)+WAVES%us_x(i+1,j-1,k))*G%CoriolisBu(i+1,j) + & 0.25*(WAVES%us_x(i,j,k)+WAVES%us_x(i,j-1,k))*G%CoriolisBu(i,j) - v(i,J,k) = v(i,j,k) - DVEL*US%s_to_T*DT + v(i,J,k) = v(i,j,k) - DVEL*dt enddo enddo enddo @@ -1340,16 +1370,20 @@ end subroutine CoriolisStokes !! Probably doesn't belong in this module, but it is used here to estimate !! wind speed for wind-wave relationships. Should be a fine way to estimate !! the neutral wind-speed as written here. -subroutine ust_2_u10_coare3p5(USTair, U10, GV, US) - real, intent(in) :: USTair !< Wind friction velocity [m s-1] - real, intent(out) :: U10 !< 10-m neutral wind speed [m s-1] +subroutine ust_2_u10_coare3p5(USTair, U10, GV, US, CS) + real, intent(in) :: USTair !< Wind friction velocity [Z T-1 ~> m s-1] + real, intent(out) :: U10 !< 10-m neutral wind speed [L T-1 ~> m s-1] type(verticalGrid_type), intent(in) :: GV !< vertical grid type type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(wave_parameters_CS), pointer :: CS !< Wave parameter Control structure ! Local variables real, parameter :: vonkar = 0.4 ! Should access a get_param von karman - real, parameter :: nu=1e-6 ! Should access a get_param air-viscosity - real :: z0sm, z0, z0rough, u10a, alpha, CD + real :: nu ! The viscosity of air [Z2 T-1 ~> m2 s-1] + real :: z0sm, z0, z0rough ! Roughness lengths [Z ~> m] + real :: u10a ! The previous guess for u10 [L T-1 ~> m s-1] + real :: alpha ! A nondimensional factor in a parameterization [nondim] + real :: CD ! The drag coefficient [nondim] integer :: CT ! Uses empirical formula for z0 to convert ustar_air to u10 based on the @@ -1358,26 +1392,29 @@ subroutine ust_2_u10_coare3p5(USTair, U10, GV, US) ! Note in Edson et al. 2013, eq. 13 m is given as 0.017. However, ! m=0.0017 reproduces the curve in their figure 6. - z0sm = 0.11 * nu * US%m_to_Z / USTair !Compute z0smooth from ustar guess - u10 = USTair/sqrt(0.001) !Guess for u10 - u10a = 1000 + nu = 1.0e-6*US%m2_s_to_Z2_T ! Should access a get_param for air-viscosity + + z0sm = 0.11 * nu / USTair ! Compute z0smooth from ustar guess + u10 = US%Z_to_L*USTair / sqrt(0.001) ! Guess for u10 + ! For efficiency change the line above to USTair * sqrt(1000.0) or USTair * 31.6227766 . + u10a = 1000.0*US%m_s_to_L_T ! An insanely large upper bound for u10. CT=0 - do while (abs(u10a/u10-1.) > 0.001) + do while (abs(u10a/u10 - 1.) > 0.001) ! Change this to (abs(u10a - u10) > 0.001*u10) for efficiency. CT=CT+1 u10a = u10 - alpha = min(0.028, 0.0017 * u10 - 0.005) - z0rough = alpha * (US%m_s_to_L_T*USTair)**2 / GV%g_Earth ! Compute z0rough from ustar guess + alpha = min(0.028, 0.0017*US%L_T_to_m_s * u10 - 0.005) + z0rough = alpha * USTair**2 / CS%g_Earth ! Compute z0rough from ustar guess z0 = z0sm + z0rough CD = ( vonkar / log(10.*US%m_to_Z / z0) )**2 ! Compute CD from derived roughness - u10 = USTair/sqrt(CD) ! Compute new u10 from derived CD, while loop + u10 = US%Z_to_L*USTair/sqrt(CD) ! Compute new u10 from derived CD, while loop ! ends and checks for convergence...CT counter ! makes sure loop doesn't run away if function ! doesn't converge. This code was produced offline ! and converged rapidly (e.g. 2 cycles) ! for ustar=0.0001:0.0001:10. if (CT>20) then - u10 = USTair/sqrt(0.0015) ! I don't expect to get here, but just + u10 = US%Z_to_L*USTair/sqrt(0.0015) ! I don't expect to get here, but just ! in case it will output a reasonable value. exit endif From 79296b8eed46e5c687a258ceaa1e85ef748d6ece Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Wed, 5 May 2021 11:31:30 -0400 Subject: [PATCH 065/112] infra, FMS_cap: stdout_if_root() This patch adds `stdout_if_root` to the MOM_io API, and points to the FMS `stdout()` function in the FMS infra implementations. This change was required because calls to `coupler_type_write_chksums` handles both its own checksums across ranks and its own IO to `outunit`. Typically only the root PE will write the result. The FMS `stdout()` function would return the designated stdout unit for the root PE, and the internal `etc_unit` for other PEs, usually set to `/dev/null`. When MOM_io switched from using the FMS `stdout()` function to the `stdout` unit as defined in `iso_fortran_env`, this functionality was lost and every PE would write the same result to stdout. Normally this was controlled with `if (root)`-like tests, but this cannot be used in functions like `coupler_type_write_checksums`, which require participation of all PEs. We decided the only resolution here was to introduce a new function, `stdout_if_root` which replicates the original behavior of `stdout()`. Additional comments: * The `if (root)` checks were retained, since it is presumably still a good idea to avoid the `write()` calls when possible, even to `/dev/null`. * This patch only updates the FMS coulper driver, but I would recommend that the other driver maintainers review their own calls to this function. --- config_src/drivers/FMS_cap/MOM_surface_forcing_gfdl.F90 | 5 +++-- config_src/drivers/FMS_cap/ocean_model_MOM.F90 | 4 ++-- config_src/infra/FMS1/MOM_io_infra.F90 | 2 ++ config_src/infra/FMS2/MOM_io_infra.F90 | 2 ++ src/framework/MOM_io.F90 | 2 ++ 5 files changed, 11 insertions(+), 4 deletions(-) diff --git a/config_src/drivers/FMS_cap/MOM_surface_forcing_gfdl.F90 b/config_src/drivers/FMS_cap/MOM_surface_forcing_gfdl.F90 index 871368fc73..162b7f5f8d 100644 --- a/config_src/drivers/FMS_cap/MOM_surface_forcing_gfdl.F90 +++ b/config_src/drivers/FMS_cap/MOM_surface_forcing_gfdl.F90 @@ -27,7 +27,8 @@ module MOM_surface_forcing_gfdl use MOM_grid, only : ocean_grid_type use MOM_interpolate, only : init_external_field, time_interp_external use MOM_interpolate, only : time_interp_external_init -use MOM_io, only : slasher, write_version_number, MOM_read_data, stdout +use MOM_io, only : slasher, write_version_number, MOM_read_data +use MOM_io, only : stdout_if_root use MOM_restart, only : register_restart_field, restart_init, MOM_restart_CS use MOM_restart, only : restart_init_end, save_restart, restore_state use MOM_string_functions, only : uppercase @@ -1628,8 +1629,8 @@ subroutine ice_ocn_bnd_type_chksum(id, timestep, iobt) logical :: root ! True only on the root PE integer :: outunit ! The output unit to write to - outunit = stdout root = is_root_pe() + outunit = stdout_if_root() if (root) write(outunit,*) "BEGIN CHECKSUM(ice_ocean_boundary_type):: ", id, timestep chks = field_chksum( iobt%u_flux ) ; if (root) write(outunit,100) 'iobt%u_flux ', chks diff --git a/config_src/drivers/FMS_cap/ocean_model_MOM.F90 b/config_src/drivers/FMS_cap/ocean_model_MOM.F90 index c430623591..2deeb40742 100644 --- a/config_src/drivers/FMS_cap/ocean_model_MOM.F90 +++ b/config_src/drivers/FMS_cap/ocean_model_MOM.F90 @@ -35,7 +35,7 @@ module ocean_model_mod use MOM_forcing_type, only : forcing_diagnostics, mech_forcing_diags use MOM_get_input, only : Get_MOM_Input, directories use MOM_grid, only : ocean_grid_type -use MOM_io, only : write_version_number, stdout +use MOM_io, only : write_version_number, stdout_if_root use MOM_marine_ice, only : iceberg_forces, iceberg_fluxes, marine_ice_init, marine_ice_CS use MOM_restart, only : MOM_restart_CS, save_restart use MOM_string_functions, only : uppercase @@ -1107,8 +1107,8 @@ subroutine ocean_public_type_chksum(id, timestep, ocn) logical :: root ! True only on the root PE integer :: outunit ! The output unit to write to - outunit = stdout root = is_root_pe() + outunit = stdout_if_root() if (root) write(outunit,*) "BEGIN CHECKSUM(ocean_type):: ", id, timestep chks = field_chksum(ocn%t_surf ) ; if (root) write(outunit,100) 'ocean%t_surf ', chks diff --git a/config_src/infra/FMS1/MOM_io_infra.F90 b/config_src/infra/FMS1/MOM_io_infra.F90 index ea3dbd15b7..dcbd80e723 100644 --- a/config_src/infra/FMS1/MOM_io_infra.F90 +++ b/config_src/infra/FMS1/MOM_io_infra.F90 @@ -17,6 +17,7 @@ module MOM_io_infra use mpp_io_mod, only : mpp_get_fields, fieldtype use mpp_io_mod, only : mpp_get_info, mpp_get_times use mpp_io_mod, only : mpp_io_init +use mpp_mod, only : stdout_if_root=>stdout ! These are encoding constants. use mpp_io_mod, only : APPEND_FILE=>MPP_APPEND, WRITEONLY_FILE=>MPP_WRONLY use mpp_io_mod, only : OVERWRITE_FILE=>MPP_OVERWR, READONLY_FILE=>MPP_RDONLY @@ -33,6 +34,7 @@ module MOM_io_infra public :: MOM_read_data, MOM_read_vector, write_metadata, write_field public :: field_exists, get_field_atts, get_field_size, get_axis_data, read_field_chksum public :: io_infra_init, io_infra_end, MOM_namelist_file, check_namelist_error, write_version +public :: stdout_if_root ! These types are inherited from underlying infrastructure code, to act as containers for ! information about fields and axes, respectively, and are opaque to this module. public :: fieldtype, axistype diff --git a/config_src/infra/FMS2/MOM_io_infra.F90 b/config_src/infra/FMS2/MOM_io_infra.F90 index 9f03d8fd12..1f2e949f0c 100644 --- a/config_src/infra/FMS2/MOM_io_infra.F90 +++ b/config_src/infra/FMS2/MOM_io_infra.F90 @@ -29,6 +29,7 @@ module MOM_io_infra use mpp_io_mod, only : mpp_get_fields, mpp_fieldtype=>fieldtype use mpp_io_mod, only : mpp_get_info, mpp_get_times use mpp_io_mod, only : mpp_io_init +use mpp_mod, only : stdout_if_root=>stdout ! These are encoding constants. use mpp_io_mod, only : APPEND_FILE=>MPP_APPEND, WRITEONLY_FILE=>MPP_WRONLY use mpp_io_mod, only : OVERWRITE_FILE=>MPP_OVERWR, READONLY_FILE=>MPP_RDONLY @@ -44,6 +45,7 @@ module MOM_io_infra public :: MOM_read_data, MOM_read_vector, write_metadata, write_field public :: field_exists, get_field_atts, get_field_size, get_axis_data, read_field_chksum public :: io_infra_init, io_infra_end, MOM_namelist_file, check_namelist_error, write_version +public :: stdout_if_root ! These types act as containers for information about files, fields and axes, respectively, ! and may also wrap opaque types from the underlying infrastructure. public :: file_type, fieldtype, axistype diff --git a/src/framework/MOM_io.F90 b/src/framework/MOM_io.F90 index 029689285e..e493f2cf38 100644 --- a/src/framework/MOM_io.F90 +++ b/src/framework/MOM_io.F90 @@ -19,6 +19,7 @@ module MOM_io use MOM_io_infra, only : get_file_times, axistype, get_axis_data, get_filename_suffix use MOM_io_infra, only : write_field, write_metadata, write_version use MOM_io_infra, only : MOM_namelist_file, check_namelist_error, io_infra_init, io_infra_end +use MOM_io_infra, only : stdout_if_root use MOM_io_infra, only : APPEND_FILE, ASCII_FILE, MULTIPLE, NETCDF_FILE, OVERWRITE_FILE use MOM_io_infra, only : READONLY_FILE, SINGLE_FILE, WRITEONLY_FILE use MOM_io_infra, only : CENTER, CORNER, NORTH_FACE, EAST_FACE @@ -47,6 +48,7 @@ module MOM_io public :: MOM_read_data, MOM_read_vector, read_field_chksum public :: slasher, write_field, write_version_number public :: io_infra_init, io_infra_end +public :: stdout_if_root ! This is used to set up information descibing non-domain-decomposed axes. public :: axis_info, set_axis_info, delete_axis_info ! This is used to set up global file attributes From f8854e7b0260447560629737b1e7cf843fde86db Mon Sep 17 00:00:00 2001 From: Hemant Khatri Date: Tue, 11 May 2021 10:45:09 -0400 Subject: [PATCH 066/112] 3D thickness x momentum diagnostics --- src/core/MOM_CoriolisAdv.F90 | 76 +++++++++++++++ src/core/MOM_dynamics_split_RK2.F90 | 95 ++++++++++++++++++- src/diagnostics/MOM_diagnostics.F90 | 43 +++++++++ .../lateral/MOM_hor_visc.F90 | 37 ++++++++ .../vertical/MOM_vert_friction.F90 | 39 ++++++++ 5 files changed, 289 insertions(+), 1 deletion(-) diff --git a/src/core/MOM_CoriolisAdv.F90 b/src/core/MOM_CoriolisAdv.F90 index b12d3e37e7..7ba9453a3f 100644 --- a/src/core/MOM_CoriolisAdv.F90 +++ b/src/core/MOM_CoriolisAdv.F90 @@ -79,6 +79,8 @@ module MOM_CoriolisAdv integer :: id_intz_gKEu_2d = -1, id_intz_gKEv_2d = -1 ! integer :: id_hf_rvxu = -1, id_hf_rvxv = -1 integer :: id_hf_rvxu_2d = -1, id_hf_rvxv_2d = -1 + integer :: id_h_gKEu = -1, id_h_gKEv = -1 + integer :: id_h_rvxu = -1, id_h_rvxv = -1 integer :: id_intz_rvxu_2d = -1, id_intz_rvxv_2d = -1 !>@} end type CoriolisAdv_CS @@ -230,6 +232,10 @@ subroutine CorAdCalc(u, v, h, uh, vh, CAu, CAv, OBC, AD, G, GV, US, CS) ! 3D diagnostics hf_gKEu etc. are commented because there is no clarity on proper remapping grid option. ! The code is retained for degugging purposes in the future. +! Diagnostics for thickness multiplied momentum budget terms + real, allocatable, dimension(:,:,:) :: h_gKEu, h_rvxv ! [L2 T-2 ~> m2 s-2]. + real, allocatable, dimension(:,:,:) :: h_gKEv, h_rvxu ! [L2 T-2 ~> m2 s-2]. + ! Diagnostics for depth-integrated momentum budget terms real, dimension(SZIB_(G),SZJ_(G)) :: intz_gKEu_2d, intz_rvxv_2d ! [L2 T-2 ~> m2 s-2]. real, dimension(SZI_(G),SZJB_(G)) :: intz_gKEv_2d, intz_rvxu_2d ! [L2 T-2 ~> m2 s-2]. @@ -955,6 +961,44 @@ subroutine CorAdCalc(u, v, h, uh, vh, CAu, CAv, OBC, AD, G, GV, US, CS) deallocate(hf_rvxu_2d) endif + if (CS%id_h_gKEu > 0) then + allocate(h_gKEu(G%IsdB:G%IedB,G%jsd:G%jed,GV%ke)) + h_gKEu(:,:,:) = 0.0 + do k=1,nz ; do j=js,je ; do I=Isq,Ieq + h_gKEu(I,j,k) = AD%gradKEu(I,j,k) * AD%diag_hu(I,j,k) + enddo ; enddo ; enddo + call post_data(CS%id_h_gKEu, h_gKEu, CS%diag) + deallocate(h_gKEu) + endif + if (CS%id_h_gKEv > 0) then + allocate(h_gKEv(G%isd:G%ied,G%JsdB:G%JedB,GV%ke)) + h_gKEv(:,:,:) = 0.0 + do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie + h_gKEv(i,J,k) = AD%gradKEv(i,J,k) * AD%diag_hv(i,J,k) + enddo ; enddo ; enddo + call post_data(CS%id_h_gKEv, h_gKEv, CS%diag) + deallocate(h_gKEv) + endif + + if (CS%id_h_rvxv > 0) then + allocate(h_rvxv(G%IsdB:G%IedB,G%jsd:G%jed,GV%ke)) + h_rvxv(:,:,:) = 0.0 + do k=1,nz ; do j=js,je ; do I=Isq,Ieq + h_rvxv(I,j,k) = AD%rv_x_v(I,j,k) * AD%diag_hu(I,j,k) + enddo ; enddo ; enddo + call post_data(CS%id_h_rvxv, h_rvxv, CS%diag) + deallocate(h_rvxv) + endif + if (CS%id_h_rvxu > 0) then + allocate(h_rvxu(G%isd:G%ied,G%JsdB:G%JedB,GV%ke)) + h_rvxu(:,:,:) = 0.0 + do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie + h_rvxu(i,J,k) = AD%rv_x_u(i,J,k) * AD%diag_hv(i,J,k) + enddo ; enddo ; enddo + call post_data(CS%id_h_rvxu, h_rvxu, CS%diag) + deallocate(h_rvxu) + endif + if (CS%id_intz_rvxv_2d > 0) then intz_rvxv_2d(:,:) = 0.0 do k=1,nz ; do j=js,je ; do I=Isq,Ieq @@ -1262,6 +1306,14 @@ subroutine CoriolisAdv_init(Time, G, GV, US, param_file, diag, AD, CS) call safe_alloc_ptr(AD%diag_hfrac_v,isd,ied,JsdB,JedB,nz) endif + CS%id_h_gKEu = register_diag_field('ocean_model', 'h_gKEu', diag%axesCuL, Time, & + 'Thickness Multiplied Zonal Acceleration from Grad. Kinetic Energy', & + 'm2 s-2', conversion=GV%H_to_m*US%L_T2_to_m_s2) + if (CS%id_h_gKEu > 0) then + call safe_alloc_ptr(AD%gradKEu,IsdB,IedB,jsd,jed,nz) + call safe_alloc_ptr(AD%diag_hu,IsdB,IedB,jsd,jed,nz) + endif + CS%id_intz_gKEu_2d = register_diag_field('ocean_model', 'intz_gKEu_2d', diag%axesCu1, Time, & 'Depth-integral of Zonal Acceleration from Grad. Kinetic Energy', & 'm2 s-2', conversion=GV%H_to_m*US%L_T2_to_m_s2) @@ -1270,6 +1322,14 @@ subroutine CoriolisAdv_init(Time, G, GV, US, param_file, diag, AD, CS) call safe_alloc_ptr(AD%diag_hu,IsdB,IedB,jsd,jed,nz) endif + CS%id_h_gKEv = register_diag_field('ocean_model', 'h_gKEv', diag%axesCvL, Time, & + 'Thickness Multiplied Meridional Acceleration from Grad. Kinetic Energy', & + 'm2 s-2', conversion=GV%H_to_m*US%L_T2_to_m_s2) + if (CS%id_h_gKEv > 0) then + call safe_alloc_ptr(AD%gradKEv,isd,ied,JsdB,JedB,nz) + call safe_alloc_ptr(AD%diag_hv,isd,ied,JsdB,JedB,nz) + endif + CS%id_intz_gKEv_2d = register_diag_field('ocean_model', 'intz_gKEv_2d', diag%axesCv1, Time, & 'Depth-integral of Meridional Acceleration from Grad. Kinetic Energy', & 'm2 s-2', conversion=GV%H_to_m*US%L_T2_to_m_s2) @@ -1310,6 +1370,14 @@ subroutine CoriolisAdv_init(Time, G, GV, US, param_file, diag, AD, CS) call safe_alloc_ptr(AD%diag_hfrac_u,IsdB,IedB,jsd,jed,nz) endif + CS%id_h_rvxu = register_diag_field('ocean_model', 'h_rvxu', diag%axesCvL, Time, & + 'Thickness Multiplied Meridional Acceleration from Relative Vorticity', & + 'm2 s-2', conversion=GV%H_to_m*US%L_T2_to_m_s2) + if (CS%id_h_rvxu > 0) then + call safe_alloc_ptr(AD%rv_x_u,isd,ied,JsdB,JedB,nz) + call safe_alloc_ptr(AD%diag_hv,isd,ied,JsdB,JedB,nz) + endif + CS%id_intz_rvxu_2d = register_diag_field('ocean_model', 'intz_rvxu_2d', diag%axesCv1, Time, & 'Depth-integral of Meridional Acceleration from Relative Vorticity', & 'm2 s-2', conversion=GV%H_to_m*US%L_T2_to_m_s2) @@ -1318,6 +1386,14 @@ subroutine CoriolisAdv_init(Time, G, GV, US, param_file, diag, AD, CS) call safe_alloc_ptr(AD%diag_hv,isd,ied,JsdB,JedB,nz) endif + CS%id_h_rvxv = register_diag_field('ocean_model', 'h_rvxv', diag%axesCuL, Time, & + 'Thickness Multiplied Zonal Acceleration from Relative Vorticity', & + 'm2 s-2', conversion=GV%H_to_m*US%L_T2_to_m_s2) + if (CS%id_h_rvxv > 0) then + call safe_alloc_ptr(AD%rv_x_v,IsdB,IedB,jsd,jed,nz) + call safe_alloc_ptr(AD%diag_hu,IsdB,IedB,jsd,jed,nz) + endif + CS%id_intz_rvxv_2d = register_diag_field('ocean_model', 'intz_rvxv_2d', diag%axesCu1, Time, & 'Depth-integral of Fractional Thickness-weighted Zonal Acceleration from Relative Vorticity', & 'm2 s-2', conversion=GV%H_to_m*US%L_T2_to_m_s2) diff --git a/src/core/MOM_dynamics_split_RK2.F90 b/src/core/MOM_dynamics_split_RK2.F90 index ef7da5c291..014ac76e0c 100644 --- a/src/core/MOM_dynamics_split_RK2.F90 +++ b/src/core/MOM_dynamics_split_RK2.F90 @@ -160,9 +160,11 @@ module MOM_dynamics_split_RK2 integer :: id_PFu = -1, id_PFv = -1 integer :: id_CAu = -1, id_CAv = -1 ! integer :: id_hf_PFu = -1, id_hf_PFv = -1 + integer :: id_h_PFu = -1, id_h_PFv = -1 integer :: id_hf_PFu_2d = -1, id_hf_PFv_2d = -1 integer :: id_intz_PFu_2d = -1, id_intz_PFv_2d = -1 ! integer :: id_hf_CAu = -1, id_hf_CAv = -1 + integer :: id_h_CAu = -1, id_h_CAv = -1 integer :: id_hf_CAu_2d = -1, id_hf_CAv_2d = -1 integer :: id_intz_CAu_2d = -1, id_intz_CAv_2d = -1 @@ -170,6 +172,7 @@ module MOM_dynamics_split_RK2 integer :: id_uav = -1, id_vav = -1 integer :: id_u_BT_accel = -1, id_v_BT_accel = -1 ! integer :: id_hf_u_BT_accel = -1, id_hf_v_BT_accel = -1 + integer :: id_h_u_BT_accel = -1, id_h_v_BT_accel = -1 integer :: id_hf_u_BT_accel_2d = -1, id_hf_v_BT_accel_2d = -1 integer :: id_intz_u_BT_accel_2d = -1, id_intz_v_BT_accel_2d = -1 !>@} @@ -339,12 +342,15 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, Time_local, dt, forces, p_s hf_CAu_2d, hf_CAv_2d, & ! Depth integeral of hf_CAu, hf_CAv [L T-2 ~> m s-2]. hf_u_BT_accel_2d, hf_v_BT_accel_2d ! Depth integeral of hf_u_BT_accel, hf_v_BT_accel + real, allocatable, dimension(:,:,:) :: h_PFu, h_CAu, h_u_BT_accel ! [L2 T-2 ~> m2 s-2]. + real, allocatable, dimension(:,:,:) :: h_PFv, h_CAv, h_v_BT_accel ! [L2 T-2 ~> m2 s-2]. + real, dimension(SZIB_(G),SZJ_(G)) :: & intz_PFu_2d, intz_CAu_2d, intz_u_BT_accel_2d ! [L2 T-2 ~> m2 s-2]. - real, dimension(SZI_(G),SZJB_(G)) :: & intz_PFv_2d, intz_CAv_2d, intz_v_BT_accel_2d ! [L2 T-2 ~> m2 s-2]. + real :: dt_pred ! The time step for the predictor part of the baroclinic time stepping [T ~> s]. logical :: dyn_p_surf @@ -940,6 +946,25 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, Time_local, dt, forces, p_s deallocate(hf_PFv_2d) endif + if (CS%id_h_PFu > 0) then + allocate(h_PFu(G%IsdB:G%IedB,G%jsd:G%jed,GV%ke)) + h_PFu(:,:,:) = 0.0 + do k=1,nz ; do j=js,je ; do I=Isq,Ieq + h_PFu(I,j,k) = CS%PFu(I,j,k) * CS%ADp%diag_hu(I,j,k) + enddo ; enddo ; enddo + call post_data(CS%id_h_PFu, h_PFu, CS%diag) + deallocate(h_PFu) + endif + if (CS%id_h_PFv > 0) then + allocate(h_PFv(G%isd:G%ied,G%JsdB:G%JedB,GV%ke)) + h_PFv(:,:,:) = 0.0 + do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie + h_PFv(i,J,k) = CS%PFv(i,J,k) * CS%ADp%diag_hv(i,J,k) + enddo ; enddo ; enddo + call post_data(CS%id_h_PFv, h_PFv, CS%diag) + deallocate(h_PFv) + endif + !if (CS%id_hf_CAu > 0) then ! allocate(hf_CAu(G%IsdB:G%IedB,G%jsd:G%jed,GV%ke)) ! do k=1,nz ; do j=js,je ; do I=Isq,Ieq @@ -988,6 +1013,25 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, Time_local, dt, forces, p_s deallocate(hf_CAv_2d) endif + if (CS%id_h_CAu > 0) then + allocate(h_CAu(G%IsdB:G%IedB,G%jsd:G%jed,GV%ke)) + h_CAu(:,:,:) = 0.0 + do k=1,nz ; do j=js,je ; do I=Isq,Ieq + h_CAu(I,j,k) = CS%CAu(I,j,k) * CS%ADp%diag_hu(I,j,k) + enddo ; enddo ; enddo + call post_data(CS%id_h_CAu, h_CAu, CS%diag) + deallocate(h_CAu) + endif + if (CS%id_h_CAv > 0) then + allocate(h_CAv(G%isd:G%ied,G%JsdB:G%JedB,GV%ke)) + h_CAv(:,:,:) = 0.0 + do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie + h_CAv(i,J,k) = CS%CAv(i,J,k) * CS%ADp%diag_hv(i,J,k) + enddo ; enddo ; enddo + call post_data(CS%id_h_CAv, h_CAv, CS%diag) + deallocate(h_CAv) + endif + !if (CS%id_hf_u_BT_accel > 0) then ! allocate(hf_u_BT_accel(G%IsdB:G%IedB,G%jsd:G%jed,GV%ke)) ! do k=1,nz ; do j=js,je ; do I=Isq,Ieq @@ -1036,6 +1080,25 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, Time_local, dt, forces, p_s deallocate(hf_v_BT_accel_2d) endif + if (CS%id_h_u_BT_accel > 0) then + allocate(h_u_BT_accel(G%IsdB:G%IedB,G%jsd:G%jed,GV%ke)) + h_u_BT_accel(:,:,:) = 0.0 + do k=1,nz ; do j=js,je ; do I=Isq,Ieq + h_u_BT_accel(I,j,k) = CS%u_accel_bt(I,j,k) * CS%ADp%diag_hu(I,j,k) + enddo ; enddo ; enddo + call post_data(CS%id_h_u_BT_accel, h_u_BT_accel, CS%diag) + deallocate(h_u_BT_accel) + endif + if (CS%id_h_v_BT_accel > 0) then + allocate(h_v_BT_accel(G%isd:G%ied,G%JsdB:G%JedB,GV%ke)) + h_v_BT_accel(:,:,:) = 0.0 + do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie + h_v_BT_accel(i,J,k) = CS%v_accel_bt(i,J,k) * CS%ADp%diag_hv(i,J,k) + enddo ; enddo ; enddo + call post_data(CS%id_h_v_BT_accel, h_v_BT_accel, CS%diag) + deallocate(h_v_BT_accel) + endif + if (CS%debug) then 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) @@ -1442,6 +1505,16 @@ subroutine initialize_dyn_split_RK2(u, v, h, uh, vh, eta, Time, G, GV, US, param conversion=US%L_T2_to_m_s2) if(CS%id_hf_PFv_2d > 0) call safe_alloc_ptr(CS%ADp%diag_hfrac_v,isd,ied,JsdB,JedB,nz) + CS%id_h_PFu = register_diag_field('ocean_model', 'h_PFu', diag%axesCuL, Time, & + 'Thickness Multiplied Zonal Pressure Force Acceleration', 'm2 s-2', & + conversion=GV%H_to_m*US%L_T2_to_m_s2) + if(CS%id_h_PFu > 0) call safe_alloc_ptr(CS%ADp%diag_hu,IsdB,IedB,jsd,jed,nz) + + CS%id_h_PFv = register_diag_field('ocean_model', 'h_PFv', diag%axesCvL, Time, & + 'Thickness Multiplied Meridional Pressure Force Acceleration', 'm2 s-2', & + conversion=GV%H_to_m*US%L_T2_to_m_s2) + if(CS%id_h_PFv > 0) call safe_alloc_ptr(CS%ADp%diag_hv,isd,ied,JsdB,JedB,nz) + CS%id_intz_PFu_2d = register_diag_field('ocean_model', 'intz_PFu_2d', diag%axesCu1, Time, & 'Depth-integral of Zonal Pressure Force Acceleration', 'm2 s-2', & conversion=GV%H_to_m*US%L_T2_to_m_s2) @@ -1462,6 +1535,16 @@ subroutine initialize_dyn_split_RK2(u, v, h, uh, vh, eta, Time, G, GV, US, param conversion=US%L_T2_to_m_s2) if(CS%id_hf_CAv_2d > 0) call safe_alloc_ptr(CS%ADp%diag_hfrac_v,isd,ied,JsdB,JedB,nz) + CS%id_h_CAu = register_diag_field('ocean_model', 'h_CAu', diag%axesCuL, Time, & + 'Thickness Multiplied Zonal Coriolis and Advective Acceleration', 'm2 s-2', & + conversion=GV%H_to_m*US%L_T2_to_m_s2) + if(CS%id_h_CAu > 0) call safe_alloc_ptr(CS%ADp%diag_hu,IsdB,IedB,jsd,jed,nz) + + CS%id_h_CAv = register_diag_field('ocean_model', 'h_CAv', diag%axesCvL, Time, & + 'Thickness Multiplied Meridional Coriolis and Advective Acceleration', 'm2 s-2', & + conversion=GV%H_to_m*US%L_T2_to_m_s2) + if(CS%id_h_CAv > 0) call safe_alloc_ptr(CS%ADp%diag_hv,isd,ied,JsdB,JedB,nz) + CS%id_intz_CAu_2d = register_diag_field('ocean_model', 'intz_CAu_2d', diag%axesCu1, Time, & 'Depth-integral of Zonal Coriolis and Advective Acceleration', 'm2 s-2', & conversion=GV%H_to_m*US%L_T2_to_m_s2) @@ -1502,6 +1585,16 @@ subroutine initialize_dyn_split_RK2(u, v, h, uh, vh, eta, Time, G, GV, US, param conversion=US%L_T2_to_m_s2) if(CS%id_hf_v_BT_accel_2d > 0) call safe_alloc_ptr(CS%ADp%diag_hfrac_v,isd,ied,JsdB,JedB,nz) + CS%id_h_u_BT_accel = register_diag_field('ocean_model', 'h_u_BT_accel', diag%axesCuL, Time, & + 'Thickness Multiplied Barotropic Anomaly Zonal Acceleration', 'm2 s-2', & + conversion=GV%H_to_m*US%L_T2_to_m_s2) + if(CS%id_h_u_BT_accel > 0) call safe_alloc_ptr(CS%ADp%diag_hu,IsdB,IedB,jsd,jed,nz) + + CS%id_h_v_BT_accel = register_diag_field('ocean_model', 'h_v_BT_accel', diag%axesCvL, Time, & + 'Thickness Multiplied Barotropic Anomaly Meridional Acceleration', 'm2 s-2', & + conversion=GV%H_to_m*US%L_T2_to_m_s2) + if(CS%id_h_v_BT_accel > 0) call safe_alloc_ptr(CS%ADp%diag_hv,isd,ied,JsdB,JedB,nz) + CS%id_intz_u_BT_accel_2d = register_diag_field('ocean_model', 'intz_u_BT_accel_2d', diag%axesCu1, Time, & 'Depth-integral of Barotropic Anomaly Zonal Acceleration', 'm2 s-2', & conversion=GV%H_to_m*US%L_T2_to_m_s2) diff --git a/src/diagnostics/MOM_diagnostics.F90 b/src/diagnostics/MOM_diagnostics.F90 index 5ac8777a19..7f88b1d448 100644 --- a/src/diagnostics/MOM_diagnostics.F90 +++ b/src/diagnostics/MOM_diagnostics.F90 @@ -116,6 +116,7 @@ module MOM_diagnostics integer :: id_e = -1, id_e_D = -1 integer :: id_du_dt = -1, id_dv_dt = -1 ! integer :: id_hf_du_dt = -1, id_hf_dv_dt = -1 + integer :: id_h_du_dt = -1, id_h_dv_dt = -1 integer :: id_hf_du_dt_2d = -1, id_hf_dv_dt_2d = -1 integer :: id_col_ht = -1, id_dh_dt = -1 integer :: id_KE = -1, id_dKEdt = -1 @@ -248,6 +249,9 @@ subroutine calculate_diagnostic_fields(u, v, h, uh, vh, tv, ADp, CDp, p_surf, & real, allocatable, dimension(:,:) :: & hf_du_dt_2d, hf_dv_dt_2d ! z integeral of hf_du_dt, hf_dv_dt [L T-2 ~> m s-2]. + real, allocatable, dimension(:,:,:) :: h_du_dt ! h x dudt [L2 T-2 ~> m2 s-2] + real, allocatable, dimension(:,:,:) :: h_dv_dt ! h x dvdt [L2 T-2 ~> m2 s-2] + ! tmp array for surface properties real :: surface_field(SZI_(G),SZJ_(G)) real :: pressure_1d(SZI_(G)) ! Temporary array for pressure when calling EOS [R L2 T-2 ~> Pa] @@ -325,6 +329,25 @@ subroutine calculate_diagnostic_fields(u, v, h, uh, vh, tv, ADp, CDp, p_surf, & deallocate(hf_dv_dt_2d) endif + if (CS%id_h_du_dt > 0) then + allocate(h_du_dt(G%IsdB:G%IedB,G%jsd:G%jed,GV%ke)) + h_du_dt(:,:,:) = 0.0 + do k=1,nz ; do j=js,je ; do I=Isq,Ieq + h_du_dt(I,j,k) = CS%du_dt(I,j,k) * ADp%diag_hu(I,j,k) + enddo ; enddo ; enddo + call post_data(CS%id_h_du_dt, h_du_dt, CS%diag) + deallocate(h_du_dt) + endif + if (CS%id_h_dv_dt > 0) then + allocate(h_dv_dt(G%isd:G%ied,G%JsdB:G%JedB,GV%ke)) + h_dv_dt(:,:,:) = 0.0 + do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie + h_dv_dt(i,J,k) = CS%dv_dt(i,J,k) * ADp%diag_hv(i,J,k) + enddo ; enddo ; enddo + call post_data(CS%id_h_dv_dt, h_dv_dt, CS%diag) + deallocate(h_dv_dt) + endif + call diag_restore_grids(CS%diag) call calculate_energy_diagnostics(u, v, h, uh, vh, ADp, CDp, G, GV, US, CS) @@ -1789,6 +1812,26 @@ subroutine MOM_diagnostics_init(MIS, ADp, CDp, Time, G, GV, US, param_file, diag call safe_alloc_ptr(ADp%diag_hfrac_v,isd,ied,JsdB,JedB,nz) endif + CS%id_h_du_dt = register_diag_field('ocean_model', 'h_du_dt', diag%axesCuL, Time, & + 'Thickness Multiplied Zonal Acceleration', 'm2 s-2', conversion=GV%H_to_m*US%L_T2_to_m_s2) + if (CS%id_h_du_dt > 0) then + if (.not.associated(CS%du_dt)) then + call safe_alloc_ptr(CS%du_dt,IsdB,IedB,jsd,jed,nz) + call register_time_deriv(lbound(MIS%u), MIS%u, CS%du_dt, CS) + endif + call safe_alloc_ptr(ADp%diag_hu,IsdB,IedB,jsd,jed,nz) + endif + + CS%id_h_dv_dt = register_diag_field('ocean_model', 'h_dv_dt', diag%axesCvL, Time, & + 'Thickness Multiplied Meridional Acceleration', 'm2 s-2', conversion=GV%H_to_m*US%L_T2_to_m_s2) + if (CS%id_h_dv_dt > 0) then + if (.not.associated(CS%dv_dt)) then + call safe_alloc_ptr(CS%dv_dt,isd,ied,JsdB,JedB,nz) + call register_time_deriv(lbound(MIS%v), MIS%v, CS%dv_dt, CS) + endif + call safe_alloc_ptr(ADp%diag_hv,isd,ied,JsdB,JedB,nz) + endif + ! layer thickness variables !if (GV%nk_rho_varies > 0) then CS%id_h_Rlay = register_diag_field('ocean_model', 'h_rho', diag%axesTL, Time, & diff --git a/src/parameterizations/lateral/MOM_hor_visc.F90 b/src/parameterizations/lateral/MOM_hor_visc.F90 index 661fb715e7..f8a966ceb6 100644 --- a/src/parameterizations/lateral/MOM_hor_visc.F90 +++ b/src/parameterizations/lateral/MOM_hor_visc.F90 @@ -187,6 +187,7 @@ module MOM_hor_visc integer :: id_grid_Re_Ah = -1, id_grid_Re_Kh = -1 integer :: id_diffu = -1, id_diffv = -1 ! integer :: id_hf_diffu = -1, id_hf_diffv = -1 + integer :: id_h_diffu = -1, id_h_diffv = -1 integer :: id_hf_diffu_2d = -1, id_hf_diffv_2d = -1 integer :: id_intz_diffu_2d = -1, id_intz_diffv_2d = -1 integer :: id_Ah_h = -1, id_Ah_q = -1 @@ -277,6 +278,9 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, grad_d2vel_mag_h, & ! Magnitude of the Laplacian of the velocity vector, squared [L-2 T-2 ~> m-2 s-2] boundary_mask_h ! A mask that zeroes out cells with at least one land edge [nondim] + real, allocatable, dimension(:,:,:) :: h_diffu ! h x diffu [L2 T-2 ~> m2 s-2] + real, allocatable, dimension(:,:,:) :: h_diffv ! h x diffv [L2 T-2 ~> m2 s-2] + real, dimension(SZIB_(G),SZJB_(G)) :: & dvdx, dudy, & ! components in the shearing strain [T-1 ~> s-1] dDel2vdx, dDel2udy, & ! Components in the biharmonic equivalent of the shearing strain [L-2 T-1 ~> m-2 s-1] @@ -1681,6 +1685,25 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, endif endif + if (present(ADp) .and. (CS%id_h_diffu > 0)) then + allocate(h_diffu(G%IsdB:G%IedB,G%jsd:G%jed,GV%ke)) + h_diffu(:,:,:) = 0.0 + do k=1,nz ; do j=js,je ; do I=Isq,Ieq + h_diffu(I,j,k) = diffu(I,j,k) * ADp%diag_hu(I,j,k) + enddo ; enddo ; enddo + call post_data(CS%id_h_diffu, h_diffu, CS%diag) + deallocate(h_diffu) + endif + if (present(ADp) .and. (CS%id_h_diffv > 0)) then + allocate(h_diffv(G%isd:G%ied,G%JsdB:G%JedB,GV%ke)) + h_diffv(:,:,:) = 0.0 + do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie + h_diffv(i,J,k) = diffv(i,J,k) * ADp%diag_hv(i,J,k) + enddo ; enddo ; enddo + call post_data(CS%id_h_diffv, h_diffv, CS%diag) + deallocate(h_diffv) + endif + end subroutine horizontal_viscosity !> Allocates space for and calculates static variables used by horizontal_viscosity(). @@ -2397,6 +2420,20 @@ subroutine hor_visc_init(Time, G, GV, US, param_file, diag, CS, MEKE, ADp) call safe_alloc_ptr(ADp%diag_hfrac_v,G%isd,G%ied,G%JsdB,G%JedB,GV%ke) endif + CS%id_h_diffu = register_diag_field('ocean_model', 'h_diffu', diag%axesCuL, Time, & + 'Thickness Multiplied Zonal Acceleration from Horizontal Viscosity', 'm2 s-2', & + conversion=GV%H_to_m*US%L_T2_to_m_s2) + if ((CS%id_h_diffu > 0) .and. (present(ADp))) then + call safe_alloc_ptr(ADp%diag_hu,G%IsdB,G%IedB,G%jsd,G%jed,GV%ke) + endif + + CS%id_h_diffv = register_diag_field('ocean_model', 'h_diffv', diag%axesCvL, Time, & + 'Thickness Multiplied Meridional Acceleration from Horizontal Viscosity', 'm2 s-2', & + conversion=GV%H_to_m*US%L_T2_to_m_s2) + if ((CS%id_h_diffv > 0) .and. (present(ADp))) then + call safe_alloc_ptr(ADp%diag_hv,G%isd,G%ied,G%JsdB,G%JedB,GV%ke) + endif + CS%id_intz_diffu_2d = register_diag_field('ocean_model', 'intz_diffu_2d', diag%axesCu1, Time, & 'Depth-integral of Zonal Acceleration from Horizontal Viscosity', 'm2 s-2', & conversion=GV%H_to_m*US%L_T2_to_m_s2) diff --git a/src/parameterizations/vertical/MOM_vert_friction.F90 b/src/parameterizations/vertical/MOM_vert_friction.F90 index d448751137..5845e3c727 100644 --- a/src/parameterizations/vertical/MOM_vert_friction.F90 +++ b/src/parameterizations/vertical/MOM_vert_friction.F90 @@ -125,6 +125,7 @@ module MOM_vert_friction integer :: id_taux_bot = -1, id_tauy_bot = -1 integer :: id_Kv_slow = -1, id_Kv_u = -1, id_Kv_v = -1 ! integer :: id_hf_du_dt_visc = -1, id_hf_dv_dt_visc = -1 + integer :: id_h_du_dt_visc = -1, id_h_dv_dt_visc = -1 integer :: id_hf_du_dt_visc_2d = -1, id_hf_dv_dt_visc_2d = -1 !>@} @@ -213,6 +214,9 @@ subroutine vertvisc(u, v, h, forces, visc, dt, OBC, ADp, CDp, G, GV, US, CS, & real, allocatable, dimension(:,:) :: hf_du_dt_visc_2d ! Depth sum of hf_du_dt_visc [L T-2 ~> m s-2] real, allocatable, dimension(:,:) :: hf_dv_dt_visc_2d ! Depth sum of hf_dv_dt_visc [L T-2 ~> m s-2] + real, allocatable, dimension(:,:,:) :: h_du_dt_visc ! h x du_dt_visc [L2 T-2 ~> m2 s-2] + real, allocatable, dimension(:,:,:) :: h_dv_dt_visc ! h x h_dv_dt_visc [L2 T-2 ~> m2 s-2] + logical :: do_i(SZIB_(G)) logical :: DoStokesMixing @@ -499,6 +503,25 @@ subroutine vertvisc(u, v, h, forces, visc, dt, OBC, ADp, CDp, G, GV, US, CS, & deallocate(hf_dv_dt_visc_2d) endif + if (CS%id_h_du_dt_visc > 0) then + allocate(h_du_dt_visc(G%IsdB:G%IedB,G%jsd:G%jed,GV%ke)) + h_du_dt_visc(:,:,:) = 0.0 + do k=1,nz ; do j=js,je ; do I=Isq,Ieq + h_du_dt_visc(I,j,k) = ADp%du_dt_visc(I,j,k) * ADp%diag_hu(I,j,k) + enddo ; enddo ; enddo + call post_data(CS%id_h_du_dt_visc, h_du_dt_visc, CS%diag) + deallocate(h_du_dt_visc) + endif + if (CS%id_h_dv_dt_visc > 0) then + allocate(h_dv_dt_visc(G%isd:G%ied,G%JsdB:G%JedB,GV%ke)) + h_dv_dt_visc(:,:,:) = 0.0 + do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie + h_dv_dt_visc(i,J,k) = ADp%dv_dt_visc(i,J,k) * ADp%diag_hv(i,J,k) + enddo ; enddo ; enddo + call post_data(CS%id_h_dv_dt_visc, h_dv_dt_visc, CS%diag) + deallocate(h_dv_dt_visc) + endif + end subroutine vertvisc !> Calculate the fraction of momentum originally in a layer that remains @@ -1838,6 +1861,22 @@ subroutine vertvisc_init(MIS, Time, G, GV, US, param_file, diag, ADp, dirs, & call safe_alloc_ptr(ADp%diag_hfrac_v,isd,ied,JsdB,JedB,nz) endif + CS%id_h_du_dt_visc = register_diag_field('ocean_model', 'h_du_dt_visc', diag%axesCuL, Time, & + 'Thickness Multiplied Zonal Acceleration from Horizontal Viscosity', 'm2 s-2', & + conversion=GV%H_to_m*US%L_T2_to_m_s2) + if (CS%id_h_du_dt_visc > 0) then + call safe_alloc_ptr(ADp%du_dt_visc,IsdB,IedB,jsd,jed,nz) + call safe_alloc_ptr(ADp%diag_hu,IsdB,IedB,jsd,jed,nz) + endif + + CS%id_h_dv_dt_visc = register_diag_field('ocean_model', 'h_dv_dt_visc', diag%axesCvL, Time, & + 'Thickness Multiplied Meridional Acceleration from Horizontal Viscosity', 'm2 s-2', & + conversion=GV%H_to_m*US%L_T2_to_m_s2) + if (CS%id_h_dv_dt_visc > 0) then + call safe_alloc_ptr(ADp%dv_dt_visc,isd,ied,JsdB,JedB,nz) + call safe_alloc_ptr(ADp%diag_hv,isd,ied,JsdB,JedB,nz) + endif + if ((len_trim(CS%u_trunc_file) > 0) .or. (len_trim(CS%v_trunc_file) > 0)) & call PointAccel_init(MIS, Time, G, param_file, diag, dirs, CS%PointAccel_CSp) From dd345af2ca3ef34a990ca5b853aa61e4c472d675 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Tue, 11 May 2021 17:27:30 -0400 Subject: [PATCH 067/112] Avoids issue with unassociated axes in d-sample code - Cell methods were being passed an nullified pointer for the axes because the axes variable was re-used where it was meant to be pointing to the parent variable axes. Adding a copy, paxes, to save from prior to the d-sample block seems to avoid the problem. --- src/framework/MOM_diag_mediator.F90 | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/src/framework/MOM_diag_mediator.F90 b/src/framework/MOM_diag_mediator.F90 index e9ad88c17e..357ea5ef8d 100644 --- a/src/framework/MOM_diag_mediator.F90 +++ b/src/framework/MOM_diag_mediator.F90 @@ -1971,6 +1971,7 @@ integer function register_diag_field(module_name, field_name, axes_in, init_time type(diag_ctrl), pointer :: diag_cs => NULL() type(axes_grp), pointer :: remap_axes => null() type(axes_grp), pointer :: axes => null() + type(axes_grp), pointer :: paxes => null() integer :: dm_id, i, dl character(len=256) :: msg, cm_string character(len=256) :: new_module_name @@ -2002,6 +2003,7 @@ integer function register_diag_field(module_name, field_name, axes_in, init_time elseif (axes_in%id == diag_cs%axesCvi%id) then axes => diag_cs%axesCvi endif + paxes => axes module_list = "{"//trim(module_name) num_modnm = 1 @@ -2191,12 +2193,12 @@ integer function register_diag_field(module_name, field_name, axes_in, init_time if (is_root_pe() .and. (diag_CS%available_diag_doc_unit > 0)) then msg = '' if (present(cmor_field_name)) msg = 'CMOR equivalent is "'//trim(cmor_field_name)//'"' - call attach_cell_methods(-1, axes, cm_string, cell_methods, & + call attach_cell_methods(-1, paxes, cm_string, cell_methods, & x_cell_method, y_cell_method, v_cell_method, & v_extensive=v_extensive) module_list = trim(module_list)//"}" if (num_modnm <= 1) module_list = module_name - if (num_varnm <= 1) var_list = "" + if (num_varnm <= 1) var_list = '' call log_available_diag(dm_id>0, module_list, field_name, cm_string, msg, diag_CS, & long_name, units, standard_name, variants=var_list) From 3a99fb5cbc358b559264d60318e6fa63c6459a6d Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Wed, 12 May 2021 10:57:31 -0400 Subject: [PATCH 068/112] Diag_mediator: Fix non-standard axis support When a diagnostic is registered, its axis group is compared to a standard set of groups along the model grid. If it matches one of them, the diagnostic is associated with this axis group. When it does not match any of the axes, the intention was to retain the pointer to the input axis group. However, there was a bug where the axis group was pointed to the input stack value within the function, rather than the original axis group. This caused the diagnostic to be associated with an axis group which was largely nonsense. This patch fixes this bug by allocating the new axis group inside the function to heap, and then copying the contents of the input axis group to the new allocated group. This ensures a permanent reference to the new axis group. It also probably creates a minor memory leak, but we can sort that out as part of the overall memory cleanup PR (currently in preparation). There was literally only one instance of a new axis, namely the use of angles axes in the internal tide diagnostics. This patch fixes any runs which use these diagnostics. --- src/framework/MOM_diag_mediator.F90 | 60 ++++++++++++++++------------- 1 file changed, 33 insertions(+), 27 deletions(-) diff --git a/src/framework/MOM_diag_mediator.F90 b/src/framework/MOM_diag_mediator.F90 index 357ea5ef8d..afbc833483 100644 --- a/src/framework/MOM_diag_mediator.F90 +++ b/src/framework/MOM_diag_mediator.F90 @@ -1051,6 +1051,7 @@ subroutine define_axes_group(diag_cs, handles, axes, nz, vertical_coordinate_num else axes%v_cell_method = '' endif + if (present(nz)) axes%nz = nz if (present(vertical_coordinate_number)) axes%vertical_coordinate_number = vertical_coordinate_number if (present(is_h_point)) axes%is_h_point = is_h_point @@ -1971,7 +1972,7 @@ integer function register_diag_field(module_name, field_name, axes_in, init_time type(diag_ctrl), pointer :: diag_cs => NULL() type(axes_grp), pointer :: remap_axes => null() type(axes_grp), pointer :: axes => null() - type(axes_grp), pointer :: paxes => null() + type(axes_grp), pointer :: axes_d2 => null() integer :: dm_id, i, dl character(len=256) :: msg, cm_string character(len=256) :: new_module_name @@ -1979,18 +1980,15 @@ integer function register_diag_field(module_name, field_name, axes_in, init_time integer :: num_modnm, num_varnm logical :: active - axes => axes_in - MOM_missing_value = axes%diag_cs%missing_value - if (present(missing_value)) MOM_missing_value = missing_value - - diag_cs => axes%diag_cs - dm_id = -1 + diag_cs => axes_in%diag_cs + ! Check if the axes match a standard grid axis. + ! If not, allocate the new axis and copy the contents. if (axes_in%id == diag_cs%axesTL%id) then axes => diag_cs%axesTL elseif (axes_in%id == diag_cs%axesBL%id) then axes => diag_cs%axesBL - elseif (axes_in%id == diag_cs%axesCuL%id ) then + elseif (axes_in%id == diag_cs%axesCuL%id) then axes => diag_cs%axesCuL elseif (axes_in%id == diag_cs%axesCvL%id) then axes => diag_cs%axesCvL @@ -1998,12 +1996,20 @@ integer function register_diag_field(module_name, field_name, axes_in, init_time axes => diag_cs%axesTi elseif (axes_in%id == diag_cs%axesBi%id) then axes => diag_cs%axesBi - elseif (axes_in%id == diag_cs%axesCui%id ) then + elseif (axes_in%id == diag_cs%axesCui%id) then axes => diag_cs%axesCui elseif (axes_in%id == diag_cs%axesCvi%id) then axes => diag_cs%axesCvi + else + allocate(axes) + axes = axes_in endif - paxes => axes + + MOM_missing_value = axes%diag_cs%missing_value + if (present(missing_value)) MOM_missing_value = missing_value + + diag_cs => axes%diag_cs + dm_id = -1 module_list = "{"//trim(module_name) num_modnm = 1 @@ -2092,31 +2098,31 @@ integer function register_diag_field(module_name, field_name, axes_in, init_time new_module_name = trim(module_name)//'_d2' if (axes_in%rank == 3 .or. axes_in%rank == 2 ) then - axes => null() + axes_d2 => null() if (axes_in%id == diag_cs%axesTL%id) then - axes => diag_cs%dsamp(dl)%axesTL + axes_d2 => diag_cs%dsamp(dl)%axesTL elseif (axes_in%id == diag_cs%axesBL%id) then - axes => diag_cs%dsamp(dl)%axesBL + axes_d2 => diag_cs%dsamp(dl)%axesBL elseif (axes_in%id == diag_cs%axesCuL%id ) then - axes => diag_cs%dsamp(dl)%axesCuL + axes_d2 => diag_cs%dsamp(dl)%axesCuL elseif (axes_in%id == diag_cs%axesCvL%id) then - axes => diag_cs%dsamp(dl)%axesCvL + axes_d2 => diag_cs%dsamp(dl)%axesCvL elseif (axes_in%id == diag_cs%axesTi%id) then - axes => diag_cs%dsamp(dl)%axesTi + axes_d2 => diag_cs%dsamp(dl)%axesTi elseif (axes_in%id == diag_cs%axesBi%id) then - axes => diag_cs%dsamp(dl)%axesBi + axes_d2 => diag_cs%dsamp(dl)%axesBi elseif (axes_in%id == diag_cs%axesCui%id ) then - axes => diag_cs%dsamp(dl)%axesCui + axes_d2 => diag_cs%dsamp(dl)%axesCui elseif (axes_in%id == diag_cs%axesCvi%id) then - axes => diag_cs%dsamp(dl)%axesCvi + axes_d2 => diag_cs%dsamp(dl)%axesCvi elseif (axes_in%id == diag_cs%axesT1%id) then - axes => diag_cs%dsamp(dl)%axesT1 + axes_d2 => diag_cs%dsamp(dl)%axesT1 elseif (axes_in%id == diag_cs%axesB1%id) then - axes => diag_cs%dsamp(dl)%axesB1 + axes_d2 => diag_cs%dsamp(dl)%axesB1 elseif (axes_in%id == diag_cs%axesCu1%id ) then - axes => diag_cs%dsamp(dl)%axesCu1 + axes_d2 => diag_cs%dsamp(dl)%axesCu1 elseif (axes_in%id == diag_cs%axesCv1%id) then - axes => diag_cs%dsamp(dl)%axesCv1 + axes_d2 => diag_cs%dsamp(dl)%axesCv1 else !Niki: Should we worry about these, e.g., diag_to_Z_CS? call MOM_error(WARNING,"register_diag_field: Could not find a proper axes for " & @@ -2124,8 +2130,8 @@ integer function register_diag_field(module_name, field_name, axes_in, init_time endif endif ! Register the native diagnostic - if (associated(axes)) then - active = register_diag_field_expand_cmor(dm_id, new_module_name, field_name, axes, & + if (associated(axes_d2)) then + active = register_diag_field_expand_cmor(dm_id, new_module_name, field_name, axes_d2, & init_time, long_name=long_name, units=units, missing_value=MOM_missing_value, & range=range, mask_variant=mask_variant, standard_name=standard_name, & verbose=verbose, do_not_log=do_not_log, err_msg=err_msg, & @@ -2193,7 +2199,7 @@ integer function register_diag_field(module_name, field_name, axes_in, init_time if (is_root_pe() .and. (diag_CS%available_diag_doc_unit > 0)) then msg = '' if (present(cmor_field_name)) msg = 'CMOR equivalent is "'//trim(cmor_field_name)//'"' - call attach_cell_methods(-1, paxes, cm_string, cell_methods, & + call attach_cell_methods(-1, axes, cm_string, cell_methods, & x_cell_method, y_cell_method, v_cell_method, & v_extensive=v_extensive) module_list = trim(module_list)//"}" @@ -2218,7 +2224,7 @@ logical function register_diag_field_expand_cmor(dm_id, module_name, field_name, integer, intent(inout) :: dm_id !< The diag_mediator ID for this diagnostic group character(len=*), intent(in) :: module_name !< Name of this module, usually "ocean_model" or "ice_shelf_model" character(len=*), intent(in) :: field_name !< Name of the diagnostic field - type(axes_grp), target, intent(in) :: axes !< Container w/ up to 3 integer handles that indicates axes + type(axes_grp), intent(in) :: axes !< Container w/ up to 3 integer handles that indicates axes !! for this field type(time_type), intent(in) :: init_time !< Time at which a field is first available? character(len=*), optional, intent(in) :: long_name !< Long name of a field. From 03fad478cfb3a67234f100e6768d9ce721b674ac Mon Sep 17 00:00:00 2001 From: Olga Sergienko Date: Thu, 13 May 2021 13:45:41 -0400 Subject: [PATCH 069/112] Corrected MOM_ice_shelf_dynamics.F90 to work with symmetric memory a new subroutine (initialize_ice_shelf_boundary_from_file) in MOM_ice_shelf_initialize.F90 to read b.c.s from file --- src/ice_shelf/MOM_ice_shelf_dynamics.F90 | 406 ++++++++++----------- src/ice_shelf/MOM_ice_shelf_initialize.F90 | 86 ++--- 2 files changed, 230 insertions(+), 262 deletions(-) diff --git a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 index d4d8c67d3c..58ab020dc0 100644 --- a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 +++ b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 @@ -11,7 +11,7 @@ module MOM_ice_shelf_dynamics !use MOM_IS_diag_mediator, only : MOM_IS_diag_mediator_init, set_IS_diag_mediator_grid use MOM_IS_diag_mediator, only : diag_ctrl, time_type, enable_averages, disable_averaging use MOM_domains, only : MOM_domains_init, clone_MOM_domain -use MOM_domains, only : pass_var, pass_vector, TO_ALL, CGRID_NE, BGRID_NE, CORNER +use MOM_domains, only : pass_var, pass_vector, TO_ALL, CGRID_NE, BGRID_NE, CORNER, CENTER use MOM_error_handler, only : MOM_error, MOM_mesg, FATAL, WARNING, is_root_pe use MOM_file_parser, only : read_param, get_param, log_param, log_version, param_file_type use MOM_grid, only : MOM_grid_init, ocean_grid_type @@ -42,13 +42,13 @@ module MOM_ice_shelf_dynamics !> The control structure for the ice shelf dynamics. type, public :: ice_shelf_dyn_CS ; private real, pointer, dimension(:,:) :: u_shelf => NULL() !< the zonal velocity of the ice shelf/sheet - !! on (C grid) [L T-1 ~> m s-1] + !! on q-points (B grid) [L T-1 ~> m s-1] real, pointer, dimension(:,:) :: v_shelf => NULL() !< the meridional velocity of the ice shelf/sheet - !! on (C grid) [L T-1 ~> m s-1] + !! on q-points (B grid) [L T-1 ~> m s-1] real, pointer, dimension(:,:) :: taudx_shelf => NULL() !< the driving stress of the ice shelf/sheet - !! on (C grid) [Pa ~> Pa] + !! on q-points (C grid) [Pa ~> Pa] real, pointer, dimension(:,:) :: taudy_shelf => NULL() !< the meridional stress of the ice shelf/sheet - !! on (C grid) [Pa ~> Pa] + !! on q-points (C grid) [Pa ~> Pa] real, pointer, dimension(:,:) :: u_face_mask => NULL() !< mask for velocity boundary conditions on the C-grid !! u-face - this is because the FEM cares about FACES THAT GET INTEGRATED OVER, !! not vertices. Will represent boundary conditions on computational boundary @@ -66,16 +66,16 @@ module MOM_ice_shelf_dynamics real, pointer, dimension(:,:) :: v_flux_bdry_val => NULL() !< The ice volume flux per unit face length into the cell !! through open boundary v-faces (where v_face_mask=4) [Z L T-1 ~> m2 s-1]?? ! needed where u_face_mask is equal to 4, similarly for v_face_mask - real, pointer, dimension(:,:) :: umask => NULL() !< u-mask on the actual degrees of freedom (C grid) + real, pointer, dimension(:,:) :: umask => NULL() !< u-mask on the actual degrees of freedom (B grid) !! 1=normal node, 3=inhomogeneous boundary node, !! 0 - no flow node (will also get ice-free nodes) - real, pointer, dimension(:,:) :: vmask => NULL() !< v-mask on the actual degrees of freedom (C grid) + real, pointer, dimension(:,:) :: vmask => NULL() !< v-mask on the actual degrees of freedom (B grid) !! 1=normal node, 3=inhomogeneous boundary node, !! 0 - no flow node (will also get ice-free nodes) real, pointer, dimension(:,:) :: calve_mask => NULL() !< a mask to prevent the ice shelf front from !! advancing past its initial position (but it may retreat) real, pointer, dimension(:,:) :: t_shelf => NULL() !< Vertically integrated temperature in the ice shelf/stream, - !! on corner-points (C grid) [degC] + !! on corner-points (B grid) [degC] real, pointer, dimension(:,:) :: tmask => NULL() !< A mask on tracer points that is 1 where there is ice. real, pointer, dimension(:,:) :: ice_visc => NULL() !< Glen's law ice viscosity, often in [R L4 Z T-1 ~> kg m2 s-1]. real, pointer, dimension(:,:) :: thickness_bdry_val => NULL() !< The ice thickness at an inflowing boundary [Z ~> m]. @@ -87,7 +87,7 @@ module MOM_ice_shelf_dynamics real, pointer, dimension(:,:) :: t_bdry_val => NULL() !< The ice temperature at inflowing boundaries [degC]. real, pointer, dimension(:,:) :: bed_elev => NULL() !< The bed elevation used for ice dynamics [Z ~> m]. - !! the same as bathyT, when below sea-level (C_grid). + !! the same as bathyT, when below sea-level. !!Sign convention: positive below sea-level, negative above. real, pointer, dimension(:,:) :: basal_traction => NULL() !< The area integrated nonlinear part of "linearized" @@ -162,11 +162,12 @@ module MOM_ice_shelf_dynamics integer :: id_u_shelf = -1, id_v_shelf = -1, id_t_shelf = -1, & id_taudx_shelf = -1, id_taudy_shelf = -1, id_bed_elev = -1, & id_ground_frac = -1, id_col_thick = -1, id_OD_av = -1, & - id_u_mask = -1, id_v_mask = -1, id_ufb_mask =-1, id_vfb_mask = -1,id_t_mask = -1 + id_u_mask = -1, id_v_mask = -1, id_ufb_mask =-1, id_vfb_mask = -1, id_t_mask = -1 !>@} ! ids for outputting intermediate thickness in advection subroutine (debugging) !>@{ Diagnostic handles for debugging - integer :: id_h_after_uflux = -1, id_h_after_vflux = -1, id_h_after_adv = -1, id_visc_shelf = -1 + integer :: id_h_after_uflux = -1, id_h_after_vflux = -1, id_h_after_adv = -1, & + id_visc_shelf = -1, id_taub = -1 !>@} type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to control diagnostic output. @@ -232,7 +233,8 @@ subroutine register_ice_shelf_dyn_restarts(G, param_file, CS, restart_CS) integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed - IsdB = G%Isd ; IedB = G%Ied ; JsdB = G%Jsd ; JedB = G%Jed + IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB + if (associated(CS)) then call MOM_error(FATAL, "MOM_ice_shelf_dyn.F90, register_ice_shelf_dyn_restarts: "// & "called with an associated control structure.") @@ -252,35 +254,25 @@ subroutine register_ice_shelf_dyn_restarts(G, param_file, CS, restart_CS) endif if (active_shelf_dynamics) then - allocate( CS%u_shelf(Isd:Ied,Jsd:Jed) ) ; CS%u_shelf(:,:) = 0.0 - allocate( CS%v_shelf(Isd:Ied,Jsd:Jed) ) ; CS%v_shelf(:,:) = 0.0 + allocate( CS%u_shelf(IsdB:IedB,JsdB:JedB) ) ; CS%u_shelf(:,:) = 0.0 + allocate( CS%v_shelf(IsdB:IedB,JsdB:JedB) ) ; CS%v_shelf(:,:) = 0.0 allocate( CS%t_shelf(isd:ied,jsd:jed) ) ; CS%t_shelf(:,:) = -10.0 allocate( CS%ice_visc(isd:ied,jsd:jed) ) ; CS%ice_visc(:,:) = 0.0 allocate( CS%basal_traction(isd:ied,jsd:jed) ) ; CS%basal_traction(:,:) = 0.0 allocate( CS%OD_av(isd:ied,jsd:jed) ) ; CS%OD_av(:,:) = 0.0 allocate( CS%ground_frac(isd:ied,jsd:jed) ) ; CS%ground_frac(:,:) = 0.0 - allocate( CS%taudx_shelf(Isd:Ied,Jsd:Jed) ) ; CS%taudx_shelf(:,:) = 0.0 - allocate( CS%taudy_shelf(Isd:Ied,Jsd:Jed) ) ; CS%taudy_shelf(:,:) = 0.0 + allocate( CS%taudx_shelf(IsdB:IedB,JsdB:JedB) ) ; CS%taudx_shelf(:,:) = 0.0 + allocate( CS%taudy_shelf(IsdB:IedB,JsdB:JedB) ) ; CS%taudy_shelf(:,:) = 0.0 allocate( CS%bed_elev(isd:ied,jsd:jed) ) ; CS%bed_elev(:,:)=G%bathyT(:,:)!CS%bed_elev(:,:) = 0.0 ! additional restarts for ice shelf state call register_restart_field(CS%u_shelf, "u_shelf", .false., restart_CS, & - "ice sheet/shelf u-velocity", "m s-1")!, hor_grid='Bu') + "ice sheet/shelf u-velocity", "m s-1", hor_grid='Bu') call register_restart_field(CS%v_shelf, "v_shelf", .false., restart_CS, & - "ice sheet/shelf v-velocity", "m s-1")!, hor_grid='Bu') - call register_restart_field(CS%t_shelf, "t_shelf", .true., restart_CS, & - "ice sheet/shelf vertically averaged temperature", "deg C") - call register_restart_field(CS%taudx_shelf, "taudx_shelf", .true., restart_CS, & - "ice sheet/shelf taudx-driving stress", "kPa") - call register_restart_field(CS%taudy_shelf, "taudy_shelf", .true., restart_CS, & - "ice sheet/shelf taudy-driving stress", "kPa") + "ice sheet/shelf v-velocity", "m s-1", hor_grid='Bu') call register_restart_field(CS%OD_av, "OD_av", .true., restart_CS, & "Average open ocean depth in a cell","m") call register_restart_field(CS%ground_frac, "ground_frac", .true., restart_CS, & "fractional degree of grounding", "nondim") - call register_restart_field(CS%ice_visc, "viscosity", .true., restart_CS, & - "Volume integrated Glens law ice viscosity", "kg m2 s-1") - call register_restart_field(CS%basal_traction, "tau_b_beta", .true., restart_CS, & - "The area integrated basal traction coefficient", "kg s-1") endif end subroutine register_ice_shelf_dyn_restarts @@ -316,7 +308,7 @@ subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_ logical :: debug integer :: i, j, is, ie, js, je, isd, ied, jsd, jed, Isdq, Iedq, Jsdq, Jedq, iters - Isdq = G%isd ; Iedq = G%ied ; Jsdq = G%jsd ; Jedq = G%jed + Isdq = G%isdB ; Iedq = G%iedB ; Jsdq = G%jsdB ; Jedq = G%jedB isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed if (.not.associated(CS)) then @@ -429,19 +421,19 @@ subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_ ! previously allocated for registration for restarts. if (active_shelf_dynamics) then - allocate( CS%u_bdry_val(Isd:Ied,Jsd:Jed) ) ; CS%u_bdry_val(:,:) = 0.0 - allocate( CS%v_bdry_val(Isd:Ied,Jsd:Jed) ) ; CS%v_bdry_val(:,:) = 0.0 + allocate( CS%u_bdry_val(Isdq:Iedq,Jsdq:Jedq) ) ; CS%u_bdry_val(:,:) = 0.0 + allocate( CS%v_bdry_val(Isdq:Iedq,Jsdq:Jedq) ) ; CS%v_bdry_val(:,:) = 0.0 allocate( CS%t_bdry_val(isd:ied,jsd:jed) ) ; CS%t_bdry_val(:,:) = -15.0 allocate( CS%h_bdry_val(isd:ied,jsd:jed) ) ; CS%h_bdry_val(:,:) = 0.0 allocate( CS%thickness_bdry_val(isd:ied,jsd:jed) ) ; CS%thickness_bdry_val(:,:) = 0.0 - allocate( CS%u_face_mask(Isd:Ied,jsd:jed) ) ; CS%u_face_mask(:,:) = 0.0 - allocate( CS%v_face_mask(isd:ied,Jsd:Jed) ) ; CS%v_face_mask(:,:) = 0.0 - allocate( CS%u_face_mask_bdry(Isdq:Iedq,jsd:jed) ) ; CS%u_face_mask_bdry(:,:) = -2.0 - allocate( CS%v_face_mask_bdry(isd:ied,Jsd:Jed) ) ; CS%v_face_mask_bdry(:,:) = -2.0 - allocate( CS%u_flux_bdry_val(Isd:Ied,jsd:jed) ) ; CS%u_flux_bdry_val(:,:) = 0.0 + allocate( CS%u_face_mask(Isdq:Iedq,Jsdq:Jedq) ) ; CS%u_face_mask(:,:) = 0.0 + allocate( CS%v_face_mask(Isdq:Iedq,Jsdq:Jedq) ) ; CS%v_face_mask(:,:) = 0.0 + allocate( CS%u_face_mask_bdry(Isdq:Iedq,Jsdq:Jedq) ) ; CS%u_face_mask_bdry(:,:) = -2.0 + allocate( CS%v_face_mask_bdry(Isdq:iedq,Jsdq:Jedq) ) ; CS%v_face_mask_bdry(:,:) = -2.0 + allocate( CS%u_flux_bdry_val(Isdq:Iedq,jsd:jed) ) ; CS%u_flux_bdry_val(:,:) = 0.0 allocate( CS%v_flux_bdry_val(isd:ied,Jsdq:Jedq) ) ; CS%v_flux_bdry_val(:,:) = 0.0 - allocate( CS%umask(Isd:Ied,Jsd:Jed) ) ; CS%umask(:,:) = -1.0 - allocate( CS%vmask(Isd:Ied,Jsd:Jed) ) ; CS%vmask(:,:) = -1.0 + allocate( CS%umask(Isdq:Iedq,Jsdq:Jedq) ) ; CS%umask(:,:) = -1.0 + allocate( CS%vmask(Isdq:Iedq,Jsdq:Jedq) ) ; CS%vmask(:,:) = -1.0 allocate( CS%tmask(Isdq:Iedq,Jsdq:Jedq) ) ; CS%tmask(:,:) = -1.0 CS%OD_rt_counter = 0 @@ -480,7 +472,7 @@ subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_ ! viscosity is not calculated correctly. ! This has to occur after init_boundary_values or some of the arrays on the ! right hand side have not been set up yet. -! if (.not. G%symmetric) then + if (.not. G%symmetric) then do j=G%jsd,G%jed ; do i=G%isd,G%ied if (((i+G%idg_offset) == (G%domain%nihalo+1)).and.(CS%u_face_mask(I-1,j) == 3)) then CS%u_shelf(I-1,J-1) = CS%u_bdry_val(I-1,J-1) @@ -495,14 +487,13 @@ subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_ CS%v_shelf(I,J-1) = CS%v_bdry_val(I,J-1) endif enddo ; enddo -! endif + endif call pass_var(CS%OD_av,G%domain) call pass_var(CS%ground_frac,G%domain) call pass_var(CS%ice_visc,G%domain) call pass_var(CS%basal_traction, G%domain) - call pass_var(CS%u_shelf, G%domain) - call pass_var(CS%v_shelf, G%domain) + call pass_vector(CS%u_shelf, CS%v_shelf, G%domain, TO_ALL, BGRID_NE) endif if (active_shelf_dynamics) then @@ -530,74 +521,48 @@ subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_ enddo ; enddo call pass_var(CS%calve_mask,G%domain) endif - call initialize_ice_shelf_boundary_from_file(CS%u_face_mask_bdry, CS%v_face_mask_bdry, & + call initialize_ice_shelf_boundary_from_file(CS%u_face_mask_bdry, CS%v_face_mask_bdry, & CS%u_bdry_val, CS%v_bdry_val, CS%umask, CS%vmask, CS%h_bdry_val, & CS%thickness_bdry_val, ISS%hmask, ISS%h_shelf, G, US, param_file ) call pass_var(ISS%hmask, G%domain) call pass_var(CS%h_bdry_val, G%domain) call pass_var(CS%thickness_bdry_val, G%domain) - call pass_var(CS%u_bdry_val, G%domain) - call pass_var(CS%v_bdry_val, G%domain) - call pass_var(CS%u_face_mask_bdry, G%domain) - call pass_var(CS%v_face_mask_bdry, G%domain) - call pass_var(CS%bed_elev, G%domain) - call pass_var(CS%umask, G%domain) - call pass_var(CS%vmask, G%domain) - !call init_boundary_values(CS, G, time, ISS%hmask, CS%input_flux, CS%input_thickness, new_sim) - call initialize_ice_flow_from_file(CS%bed_elev,CS%u_shelf, CS%v_shelf,CS%ice_visc,& - CS%ground_frac, ISS%hmask,ISS%h_shelf, G, US, param_file) - call pass_var(CS%ice_visc, G%domain) - call pass_var(CS%u_shelf, G%domain) - call pass_var(CS%v_shelf, G%domain) - call pass_var(CS%bed_elev, G%domain) - call pass_var(CS%ice_visc, G%domain) + call pass_vector(CS%u_bdry_val, CS%v_bdry_val, G%domain, TO_ALL, BGRID_NE) + call pass_vector(CS%u_face_mask_bdry, CS%v_face_mask_bdry, G%domain, TO_ALL, BGRID_NE) + call initialize_ice_flow_from_file(CS%bed_elev,CS%u_shelf, CS%v_shelf,CS%ground_frac, ISS%hmask,ISS%h_shelf, & + G, US, param_file) + call pass_vector(CS%u_shelf, CS%v_shelf, G%domain, TO_ALL, BGRID_NE) + call pass_var(CS%bed_elev, G%domain,CENTER) call update_velocity_masks(CS, G, ISS%hmask, CS%umask, CS%vmask, CS%u_face_mask, CS%v_face_mask) ! Register diagnostics. - CS%id_u_shelf = register_diag_field('ice_shelf_model','u_shelf',CS%diag%axesCu1, Time, & + CS%id_u_shelf = register_diag_field('ice_shelf_model','u_shelf',CS%diag%axesB1, Time, & 'x-velocity of ice', 'm yr-1', conversion=365.0*86400.0*US%L_T_to_m_s) - CS%id_v_shelf = register_diag_field('ice_shelf_model','v_shelf',CS%diag%axesCv1, Time, & + CS%id_v_shelf = register_diag_field('ice_shelf_model','v_shelf',CS%diag%axesB1, Time, & 'y-velocity of ice', 'm yr-1', conversion=365.0*86400.0*US%L_T_to_m_s) - CS%id_taudx_shelf = register_diag_field('ice_shelf_model','taudx_shelf',CS%diag%axesT1, Time, & + CS%id_taudx_shelf = register_diag_field('ice_shelf_model','taudx_shelf',CS%diag%axesB1, Time, & 'x-driving stress of ice', 'kPa', conversion=1.e-9*US%L_T_to_m_s) - CS%id_taudy_shelf = register_diag_field('ice_shelf_model','taudy_shelf',CS%diag%axesT1, Time, & + CS%id_taudy_shelf = register_diag_field('ice_shelf_model','taudy_shelf',CS%diag%axesB1, Time, & 'x-driving stress of ice', 'kPa', conversion=1.e-9*US%L_T_to_m_s) - CS%id_u_mask = register_diag_field('ice_shelf_model','u_mask',CS%diag%axesCu1, Time, & + CS%id_u_mask = register_diag_field('ice_shelf_model','u_mask',CS%diag%axesB1, Time, & 'mask for u-nodes', 'none') - CS%id_v_mask = register_diag_field('ice_shelf_model','v_mask',CS%diag%axesCv1, Time, & + CS%id_v_mask = register_diag_field('ice_shelf_model','v_mask',CS%diag%axesB1, Time, & 'mask for v-nodes', 'none') CS%id_ground_frac = register_diag_field('ice_shelf_model','ice_ground_frac',CS%diag%axesT1, Time, & 'fraction of cell that is grounded', 'none') - +! CS%id_col_thick = register_diag_field('ice_shelf_model','col_thick',CS%diag%axesT1, Time, & 'ocean column thickness passed to ice model', 'm', conversion=US%Z_to_m) CS%id_visc_shelf = register_diag_field('ice_shelf_model','ice_visc',CS%diag%axesT1, Time, & 'viscosity', 'm', conversion=1e-6*US%Z_to_m) + CS%id_taub = register_diag_field('ice_shelf_model','taub_beta',CS%diag%axesT1, Time, & + 'taub', 'Pa yr m-1', conversion=1e-6*US%Z_to_m) CS%id_OD_av = register_diag_field('ice_shelf_model','OD_av',CS%diag%axesT1, Time, & 'intermediate ocean column thickness passed to ice model', 'm', conversion=US%Z_to_m) - CS%id_h_after_uflux = register_diag_field('ice_shelf_model','h_after_uflux',CS%diag%axesT1, Time, & - 'thickness after u flux ', 'none') - CS%id_h_after_vflux = register_diag_field('ice_shelf_model','h_after_vflux',CS%diag%axesT1, Time, & - 'thickness after v flux ', 'none') - CS%id_h_after_adv = register_diag_field('ice_shelf_model','h_after_adv',CS%diag%axesT1, Time, & - 'thickness after front adv ', 'none') - CS%id_ufb_mask = register_diag_field('ice_shelf_model','u_fb_mask',CS%diag%axesCu1, Time, & - 'mask for u-nodes', 'none') - CS%id_vfb_mask = register_diag_field('ice_shelf_model','v_fb_mask',CS%diag%axesCv1, Time, & - 'mask for v-nodes', 'none') if (new_sim) then call MOM_mesg("MOM_ice_shelf.F90, initialize_ice_shelf: initialize ice velocity.") call update_OD_ffrac_uncoupled(CS, G, ISS%h_shelf(:,:)) call ice_shelf_solve_outer(CS, ISS, G, US, CS%u_shelf, CS%v_shelf,CS%taudx_shelf,CS%taudy_shelf, iters, Time) - if (CS%id_u_shelf > 0) call post_data(CS%id_u_shelf, CS%u_shelf, CS%diag) - if (CS%id_v_shelf > 0) call post_data(CS%id_v_shelf, CS%v_shelf,CS%diag) - if (CS%id_taudx_shelf > 0) call post_data(CS%id_taudx_shelf, CS%taudx_shelf,CS%diag) - if (CS%id_taudy_shelf > 0) call post_data(CS%id_taudy_shelf, CS%taudy_shelf,CS%diag) - if (CS%id_visc_shelf > 0) call post_data(CS%id_visc_shelf, CS%ice_visc,CS%diag) -! CS%id_t_shelf = register_diag_field('ocean_model','t_shelf',CS%diag%axesT1, Time, & -! 'T of ice', 'oC') -! CS%id_t_mask = register_diag_field('ocean_model','tmask',CS%diag%axesT1, Time, & -! 'mask for T-nodes', 'none') endif endif @@ -616,7 +581,7 @@ subroutine initialize_diagnostic_fields(CS, ISS, G, US, Time) real :: rhoi_rhow real :: OD ! Depth of open water below the ice shelf [Z ~> m] type(time_type) :: dummy_time - +! rhoi_rhow = CS%density_ice / CS%density_ocean_avg dummy_time = set_time(0,0) isd=G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed @@ -710,25 +675,26 @@ subroutine update_ice_shelf(CS, ISS, G, US, time_step, Time, ocean_mass, coupled call ice_shelf_solve_outer(CS, ISS, G, US, CS%u_shelf, CS%v_shelf,CS%taudx_shelf,CS%taudy_shelf, iters, Time) endif - call ice_shelf_temp(CS, ISS, G, US, time_step, ISS%water_flux, Time) +! call ice_shelf_temp(CS, ISS, G, US, time_step, ISS%water_flux, Time) if (update_ice_vel) then call enable_averages(CS%elapsed_velocity_time, Time, CS%diag) if (CS%id_col_thick > 0) call post_data(CS%id_col_thick, CS%OD_av, CS%diag) if (CS%id_u_shelf > 0) call post_data(CS%id_u_shelf, CS%u_shelf, CS%diag) if (CS%id_v_shelf > 0) call post_data(CS%id_v_shelf, CS%v_shelf, CS%diag) - if (CS%id_t_shelf > 0) call post_data(CS%id_t_shelf,CS%t_shelf,CS%diag) +! if (CS%id_t_shelf > 0) call post_data(CS%id_t_shelf,CS%t_shelf,CS%diag) if (CS%id_taudx_shelf > 0) call post_data(CS%id_taudx_shelf, CS%taudx_shelf, CS%diag) if (CS%id_taudy_shelf > 0) call post_data(CS%id_taudy_shelf, CS%taudy_shelf, CS%diag) if (CS%id_ground_frac > 0) call post_data(CS%id_ground_frac, CS%ground_frac,CS%diag) if (CS%id_OD_av >0) call post_data(CS%id_OD_av, CS%OD_av,CS%diag) if (CS%id_visc_shelf > 0) call post_data(CS%id_visc_shelf, CS%ice_visc,CS%diag) - - if (CS%id_ufb_mask > 0) call post_data(CS%id_ufb_mask,CS%u_face_mask_bdry,CS%diag) - if (CS%id_vfb_mask > 0) call post_data(CS%id_vfb_mask,CS%v_face_mask_bdry,CS%diag) - if (CS%id_t_mask > 0) call post_data(CS%id_t_mask,CS%tmask,CS%diag) + if (CS%id_taub > 0) call post_data(CS%id_taub, CS%basal_traction,CS%diag) +!! if (CS%id_u_mask > 0) call post_data(CS%id_u_mask,CS%umask,CS%diag) if (CS%id_v_mask > 0) call post_data(CS%id_v_mask,CS%vmask,CS%diag) + if (CS%id_ufb_mask > 0) call post_data(CS%id_ufb_mask,CS%u_face_mask_bdry,CS%diag) + if (CS%id_vfb_mask > 0) call post_data(CS%id_vfb_mask,CS%v_face_mask_bdry,CS%diag) +! if (CS%id_t_mask > 0) call post_data(CS%id_t_mask,CS%tmask,CS%diag) call disable_averaging(CS%diag) @@ -759,8 +725,8 @@ subroutine ice_shelf_advect(CS, ISS, G, time_step, Time) ! into partial cells real, dimension(SZDI_(G),SZDJ_(G)) :: h_after_uflux, h_after_vflux ! Ice thicknesses [Z ~> m]. - real, dimension(SZDI_(G),SZDJ_(G)) :: uh_ice ! The accumulated zonal ice volume flux [Z L2 ~> m3] - real, dimension(SZDI_(G),SZDJ_(G)) :: vh_ice ! The accumulated meridional ice volume flux [Z L2 ~> m3] + real, dimension(SZDIB_(G),SZDJ_(G)) :: uh_ice ! The accumulated zonal ice volume flux [Z L2 ~> m3] + real, dimension(SZDI_(G),SZDJB_(G)) :: vh_ice ! The accumulated meridional ice volume flux [Z L2 ~> m3] type(loop_bounds_type) :: LB integer :: isd, ied, jsd, jed, i, j, isc, iec, jsc, jec, stencil @@ -787,7 +753,7 @@ subroutine ice_shelf_advect(CS, ISS, G, time_step, Time) ! call enable_averages(time_step, Time, CS%diag) call pass_var(h_after_uflux, G%domain) - if (CS%id_h_after_uflux > 0) call post_data(CS%id_h_after_uflux, h_after_uflux, CS%diag) +! if (CS%id_h_after_uflux > 0) call post_data(CS%id_h_after_uflux, h_after_uflux, CS%diag) ! call disable_averaging(CS%diag) LB%ish = G%isc ; LB%ieh = G%iec ; LB%jsh = G%jsc ; LB%jeh = G%jec @@ -795,7 +761,7 @@ subroutine ice_shelf_advect(CS, ISS, G, time_step, Time) ! call enable_averages(time_step, Time, CS%diag) call pass_var(h_after_vflux, G%domain) - if (CS%id_h_after_vflux > 0) call post_data(CS%id_h_after_vflux, h_after_vflux, CS%diag) +! if (CS%id_h_after_vflux > 0) call post_data(CS%id_h_after_vflux, h_after_vflux, CS%diag) ! call disable_averaging(CS%diag) do j=jsd,jed @@ -833,24 +799,23 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf,taudx,taudy, ite !! the ice-shelf state type(ocean_grid_type), intent(inout) :: G !< The grid structure used by the ice shelf. type(unit_scale_type), intent(in) :: US !< A structure containing unit conversion factors - real, dimension(SZDI_(G),SZDJ_(G)), & + real, dimension(SZDIB_(G),SZDJB_(G)), & intent(inout) :: u_shlf !< The zonal ice shelf velocity at vertices [L T-1 ~> m s-1] - real, dimension(SZDI_(G),SZDJ_(G)), & + real, dimension(SZDIB_(G),SZDJB_(G)), & intent(inout) :: v_shlf !< The meridional ice shelf velocity at vertices [L T-1 ~> m s-1] integer, intent(out) :: iters !< The number of iterations used in the solver. type(time_type), intent(in) :: Time !< The current model time - real, dimension(SZDI_(G),SZDJ_(G)), & + real, dimension(SZDIB_(G),SZDJB_(G)), & intent(out) :: taudx !< Driving x-stress at q-points [R L3 Z T-2 ~> kg m s-2] - real, dimension(SZDI_(G),SZDJ_(G)), & + real, dimension(SZDIB_(G),SZDJB_(G)), & intent(out) :: taudy !< Driving y-stress at q-points [R L3 Z T-2 ~> kg m s-2] - ![R L3 Z T-2 ~> kg m s-2]ness at corners [Z ~> m]. - real, dimension(SZDI_(G),SZDJ_(G)) :: u_bdry_cont ! Boundary u-stress contribution [R L3 Z T-2 ~> kg m s-2] - real, dimension(SZDI_(G),SZDJ_(G)) :: v_bdry_cont ! Boundary v-stress contribution [R L3 Z T-2 ~> kg m s-2] - real, dimension(SZDI_(G),SZDJ_(G)) :: Au, Av ! The retarding lateral stress contributions [R L3 Z T-2 ~> kg m s-2] - real, dimension(SZDI_(G),SZDJ_(G)) :: err_u, err_v - real, dimension(SZDI_(G),SZDJ_(G)) :: u_last, v_last ! Previous velocities [L T-1 ~> m s-1] - real, dimension(SZDI_(G),SZDJ_(G)) :: H_node ! Ice shelf thick)), & + real, dimension(SZDIB_(G),SZDJB_(G)) :: u_bdry_cont ! Boundary u-stress contribution [R L3 Z T-2 ~> kg m s-2] + real, dimension(SZDIB_(G),SZDJB_(G)) :: v_bdry_cont ! Boundary v-stress contribution [R L3 Z T-2 ~> kg m s-2] + real, dimension(SZDIB_(G),SZDJB_(G)) :: Au, Av ! The retarding lateral stress contributions [R L3 Z T-2 ~> kg m s-2] + real, dimension(SZDIB_(G),SZDJB_(G)) :: err_u, err_v + real, dimension(SZDIB_(G),SZDJB_(G)) :: u_last, v_last ! Previous velocities [L T-1 ~> m s-1] + real, dimension(SZDIB_(G),SZDJB_(G)) :: H_node ! Ice shelf thickness at corners [Z ~> m]. real, dimension(SZDI_(G),SZDJ_(G)) :: float_cond ! An array indicating where the ice ! shelf is floating: 0 if floating, 1 if not. character(len=160) :: mesg ! The text of an error message @@ -868,8 +833,7 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf,taudx,taudy, ite ! for GL interpolation nsub = CS%n_sub_regularize -! isdq = G%isdB ; iedq = G%iedB ; jsdq = G%jsdB ; jedq = G%jedB - isdq = G%isd ; iedq = G%ied ; jsd = G%jsd ; jed = G%jed + isdq = G%isdB ; iedq = G%iedB ; jsdq = G%jsdB ; jedq = G%jedB isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed rhoi_rhow = CS%density_ice / CS%density_ocean_avg @@ -892,9 +856,7 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf,taudx,taudy, ite enddo call calc_shelf_driving_stress(CS, ISS, G, US, taudx, taudy, CS%OD_av) -! call pass_var(taudx, G%domain) -! call pass_var(taudy, G%domain) - +! call pass_vector(taudx, taudy, G%domain, TO_ALL, BGRID_NE) ! This is to determine which cells contain the grounding line, the criterion being that the cell ! is ice-covered, with some nodes floating and some grounded flotation condition is estimated by ! assuming topography is cellwise constant and H is bilinear in a cell; floating where @@ -936,12 +898,13 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf,taudx,taudy, ite call calc_shelf_visc(CS, ISS, G, US, u_shlf, v_shlf) call pass_var(CS%ice_visc, G%domain) - call calc_shelf_taub(CS, ISS, G, US, u_shlf, v_shlf) call pass_var(CS%basal_traction, G%domain) + ! This makes sure basal stress is only applied when it is supposed to be do j=G%jsd,G%jed ; do i=G%isd,G%ied - CS%basal_traction(i,j) = CS%basal_traction(i,j) * CS%ground_frac(i,j) +! CS%basal_traction(i,j) = CS%basal_traction(i,j) * CS%ground_frac(i,j) + CS%basal_traction(i,j) = CS%basal_traction(i,j) * float_cond(i,j) enddo ; enddo call apply_boundary_values(CS, ISS, G, US, time, Phisub, H_node, CS%ice_visc, & @@ -952,8 +915,8 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf,taudx,taudy, ite call CG_action(Au, Av, u_shlf, v_shlf, Phi, Phisub, CS%umask, CS%vmask, ISS%hmask, H_node, & CS%ice_visc, float_cond, G%bathyT, CS%basal_traction, & G, US, G%isc-1, G%iec+1, G%jsc-1, G%jec+1, rhoi_rhow) - call pass_var(Au,G%domain) - call pass_var(Av,G%domain) + call pass_vector(Au,Av,G%domain,TO_ALL,BGRID_NE) + if (CS%nonlin_solve_err_mode == 1) then err_init = 0 ; err_tempu = 0 ; err_tempv = 0 do J=G%IscB,G%JecB ; do I=G%IscB,G%IecB @@ -991,10 +954,11 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf,taudx,taudy, ite call pass_var(CS%ice_visc, G%domain) call calc_shelf_taub(CS, ISS, G, US, u_shlf, v_shlf) call pass_var(CS%basal_traction, G%domain) - ! makes sure basal stress is only applied when it is supposed to be + do j=G%jsd,G%jed ; do i=G%isd,G%ied - CS%basal_traction(i,j) = CS%basal_traction(i,j) * CS%ground_frac(i,j) +! CS%basal_traction(i,j) = CS%basal_traction(i,j) * CS%ground_frac(i,j) + CS%basal_traction(i,j) = CS%basal_traction(i,j) * float_cond(i,j) enddo ; enddo u_bdry_cont(:,:) = 0 ; v_bdry_cont(:,:) = 0 @@ -1012,8 +976,7 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf,taudx,taudy, ite if (CS%nonlin_solve_err_mode == 1) then -! do J=G%jscB,G%jecB ; do I=G%jscB,G%iecB - do J=G%jsc,G%jec ; do I=G%jsc,G%iec + do J=G%jscB,G%jecB ; do I=G%jscB,G%iecB if (CS%umask(I,J) == 1) then err_tempu = ABS(Au(I,J) + u_bdry_cont(I,J) - taudx(I,J)) if (err_tempu >= err_max) err_max = err_tempu @@ -1029,7 +992,7 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf,taudx,taudy, ite elseif (CS%nonlin_solve_err_mode == 2) then max_vel = 0 ; tempu = 0 ; tempv = 0 - do J=G%jsc,G%jec ; do I=G%isc,G%iec + do J=G%jscB,G%jecB ; do I=G%iscB,G%iecB if (CS%umask(I,J) == 1) then err_tempu = ABS(u_last(I,J)-u_shlf(I,J)) if (err_tempu >= err_max) err_max = err_tempu @@ -1079,18 +1042,17 @@ subroutine ice_shelf_solve_inner(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, H !! the ice-shelf state type(ocean_grid_type), intent(inout) :: G !< The grid structure used by the ice shelf. type(unit_scale_type), intent(in) :: US !< A structure containing unit conversion factors - real, dimension(SZDI_(G),SZDJ_(G)), & + real, dimension(SZDIB_(G),SZDJB_(G)), & intent(inout) :: u_shlf !< The zonal ice shelf velocity at vertices [L T-1 ~> m s-1] - real, dimension(SZDI_(G),SZDJ_(G)), & + real, dimension(SZDIB_(G),SZDJB_(G)), & intent(inout) :: v_shlf !< The meridional ice shelf velocity at vertices [L T-1 ~> m s-1] - real, dimension(SZDI_(G),SZDJ_(G)), & + real, dimension(SZDIB_(G),SZDJB_(G)), & intent(in) :: taudx !< The x-direction driving stress [R L3 Z T-2 ~> kg m s-2] - real, dimension(SZDI_(G),SZDJ_(G)), & + real, dimension(SZDIB_(G),SZDJB_(G)), & intent(in) :: taudy !< The y-direction driving stress [R L3 Z T-2 ~> kg m s-2] - real, dimension(SZDI_(G),SZDJ_(G)), & + real, dimension(SZDIB_(G),SZDJB_(G)), & intent(in) :: H_node !< The ice shelf thickness at nodal (corner) !! points [Z ~> m]. - real, dimension(SZDI_(G),SZDJ_(G)), & intent(in) :: float_cond !< An array indicating where the ice !! shelf is floating: 0 if floating, 1 if not. @@ -1116,7 +1078,7 @@ subroutine ice_shelf_solve_inner(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, H ! assumed - u, v, taud, visc, basal_traction are valid on the halo - real, dimension(SZDI_(G),SZDJ_(G)) :: & + real, dimension(SZDIB_(G),SZDJB_(G)) :: & Ru, Rv, & ! Residuals in the stress calculations [R L3 Z T-2 ~> m kg s-2] Ru_old, Rv_old, & ! Previous values of Ru and Rv [R L3 Z T-2 ~> m kg s-2] Zu, Zv, & ! Contributions to velocity changes [L T-1 ~> m s-1] @@ -1139,8 +1101,8 @@ subroutine ice_shelf_solve_inner(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, H integer :: Is_sum, Js_sum, Ie_sum, Je_sum ! Loop bounds for global sums or arrays starting at 1. integer :: isdq, iedq, jsdq, jedq, iscq, iecq, jscq, jecq, nx_halo, ny_halo - isdq = G%isd ; iedq = G%ied ; jsdq = G%jsd ; jedq = G%jed - iscq = G%isc ; iecq = G%iec ; jscq = G%jsc ; jecq = G%jec + isdq = G%isdB ; iedq = G%iedB ; jsdq = G%jsdB ; jedq = G%jedB + iscq = G%iscB ; iecq = G%iecB ; jscq = G%jscB ; jecq = G%jecB ny_halo = G%domain%njhalo ; nx_halo = G%domain%nihalo isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed isc = G%isc ; iec = G%iec ; jsc = G%jsc ; jec = G%jec @@ -1153,37 +1115,37 @@ subroutine ice_shelf_solve_inner(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, H dot_p1 = 0 ! Determine the loop limits for sums, bearing in mind that the arrays will be starting at 1. - Is_sum = G%isc + (1-G%Isd) - Ie_sum = G%iec + (1-G%Isd) - ! Include the edge if tile is at the western bdry; Should add a test to avoid this if reentrant. - if (G%isc+G%idg_offset==G%isg) Is_sum = G%Isc + (1-G%Isd) - Js_sum = G%jsc + (1-G%Jsd) - Je_sum = G%jec + (1-G%Jsd) + Is_sum = G%isc + (1-G%IsdB) + Ie_sum = G%iecB + (1-G%IsdB) + ! Include the edge if tile is at the western bdry; Should add a test to avoid this if reentrant. + if (G%isc+G%idg_offset==G%isg) Is_sum = G%IscB + (1-G%IsdB) + + Js_sum = G%jsc + (1-G%JsdB) + Je_sum = G%jecB + (1-G%JsdB) ! Include the edge if tile is at the southern bdry; Should add a test to avoid this if reentrant. - if (G%jsc+G%jdg_offset==G%jsg) Js_sum = G%Jsc + (1-G%Jsd) + if (G%jsc+G%jdg_offset==G%jsg) Js_sum = G%JscB + (1-G%JsdB) + call apply_boundary_values(CS, ISS, G, US, time, Phisub, H_node, CS%ice_visc, & CS%basal_traction, float_cond, rhoi_rhow, ubd, vbd) RHSu(:,:) = taudx(:,:) - ubd(:,:) RHSv(:,:) = taudy(:,:) - vbd(:,:) - call pass_var(RHSu,G%domain) - call pass_var(RHSv, G%domain) + call pass_vector(RHSu, RHSv, G%domain, TO_ALL, BGRID_NE) - call matrix_diagonal(CS, G, US, float_cond, H_node, CS%ice_visc, CS%basal_traction, & + call matrix_diagonal(CS, G, US, float_cond, H_node, CS%ice_visc, CS%basal_traction, & hmask, rhoi_rhow, Phisub, DIAGu, DIAGv) - call pass_var(DIAGu, G%domain) - call pass_var(DIAGv, G%domain) + call pass_vector(DIAGu, DIAGv, G%domain, TO_ALL, BGRID_NE) - call CG_action(Au, Av, u_shlf, v_shlf, Phi, Phisub, CS%umask, CS%vmask, hmask, & + call CG_action(Au, Av, u_shlf, v_shlf, Phi, Phisub, CS%umask, CS%vmask, hmask, & H_node, CS%ice_visc, float_cond, G%bathyT, CS%basal_traction, & G, US, isc-1, iec+1, jsc-1, jec+1, rhoi_rhow) - call pass_var(Au, G%domain) - call pass_var(Av, G%domain) - Ru(:,:) = (RHSu(:,:) - Au(:,:)) - Rv(:,:) = (RHSv(:,:) - Av(:,:)) + call pass_vector(Au, Av, G%domain, TO_ALL, BGRID_NE) + + Ru(:,:) = (RHSu(:,:) - Au(:,:)) + Rv(:,:) = (RHSv(:,:) - Av(:,:)) resid_scale = US%L_to_m**2*US%s_to_T*US%RZ_to_kg_m2*US%L_T_to_m_s**2 resid2_scale = (US%RZ_to_kg_m2*US%L_to_m*US%L_T_to_m_s**2)**2 @@ -1236,8 +1198,8 @@ subroutine ice_shelf_solve_inner(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, H ! Au, Av valid region moves in by 1 - call pass_var(Au,G%domain) - call pass_var(Av,G%domain) + call pass_vector(Au,Av,G%domain, TO_ALL, BGRID_NE) + sum_vec(:,:) = 0.0 ; sum_vec_2(:,:) = 0.0 do j=jscq,jecq ; do i=iscq,iecq @@ -1340,12 +1302,9 @@ subroutine ice_shelf_solve_inner(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, H if (cg_halo == 0) then ! pass vectors - call pass_var(Du, G%domain) - call pass_var(Dv, G%domain) - call pass_var(u_shlf, G%domain) - call pass_var(v_shlf, G%domain) - call pass_var(Ru, G%domain) - call pass_var(Rv, G%domain) + call pass_vector(Du, Dv, G%domain, TO_ALL, BGRID_NE) + call pass_vector(u_shlf, v_shlf, G%domain, TO_ALL, BGRID_NE) + call pass_vector(Ru, Rv, G%domain, TO_ALL, BGRID_NE) cg_halo = 3 endif @@ -1367,9 +1326,8 @@ subroutine ice_shelf_solve_inner(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, H enddo enddo - call pass_var(u_shlf, G%domain) - call pass_var(v_shlf, G%domain) - if (conv_flag == 0) then + call pass_vector(u_shlf, v_shlf, G%domain, TO_ALL, BGRID_NE) + if (conv_flag == 0) then iters = CS%cg_max_iterations endif @@ -1388,7 +1346,7 @@ subroutine ice_shelf_advect_thickness_x(CS, G, LB, time_step, hmask, h0, h_after real, dimension(SZDI_(G),SZDJ_(G)), & intent(inout) :: h_after_uflux !< The ice shelf thicknesses after !! the zonal mass fluxes [Z ~> m]. - real, dimension(SZDI_(G),SZDJ_(G)), & + real, dimension(SZDIB_(G),SZDJ_(G)), & intent(inout) :: uh_ice !< The accumulated zonal ice volume flux [Z L2 ~> m3] ! use will be made of ISS%hmask here - its value at the boundary will be zero, just like uncovered cells @@ -1471,7 +1429,7 @@ subroutine ice_shelf_advect_thickness_y(CS, G, LB, time_step, hmask, h0, h_after real, dimension(SZDI_(G),SZDJ_(G)), & intent(inout) :: h_after_vflux !< The ice shelf thicknesses after !! the meridional mass fluxes [Z ~> m]. - real, dimension(SZDI_(G),SZDJ_(G)), & + real, dimension(SZDI_(G),SZDJB_(G)), & intent(inout) :: vh_ice !< The accumulated meridional ice volume flux [Z L2 ~> m3] ! use will be made of ISS%hmask here - its value at the boundary will be zero, just like uncovered cells @@ -1546,10 +1504,11 @@ subroutine shelf_advance_front(CS, ISS, G, hmask, uh_ice, vh_ice) real, dimension(SZDI_(G),SZDJ_(G)), & intent(inout) :: hmask !< A mask indicating which tracer points are !! partly or fully covered by an ice-shelf - real, dimension(SZDI_(G),SZDJ_(G)), & + real, dimension(SZDIB_(G),SZDJ_(G)), & intent(inout) :: uh_ice !< The accumulated zonal ice volume flux [Z L2 ~> m3] - real, dimension(SZDI_(G),SZDJ_(G)), & + real, dimension(SZDI_(G),SZDJB_(G)), & intent(inout) :: vh_ice !< The accumulated meridional ice volume flux [Z L2 ~> m3] + ! in this subroutine we go through the computational cells only and, if they are empty or partial cells, ! we find the reference thickness and update the shelf mass and partial area fraction and the hmask if necessary @@ -1789,9 +1748,9 @@ subroutine calc_shelf_driving_stress(CS, ISS, G, US, taudx, taudy, OD) type(unit_scale_type), intent(in) :: US !< A structure containing unit conversion factors real, dimension(SZDI_(G),SZDJ_(G)), & intent(in) :: OD !< ocean floor depth at tracer points [Z ~> m]. - real, dimension(SZDI_(G),SZDJ_(G)), & + real, dimension(SZDIB_(G),SZDJB_(G)), & intent(inout) :: taudx !< X-direction driving stress at q-points [kg L s-2 ~> kg m s-2] - real, dimension(SZDI_(G),SZDJ_(G)), & + real, dimension(SZDIB_(G),SZDJB_(G)), & intent(inout) :: taudy !< Y-direction driving stress at q-points [kg L s-2 ~> kg m s-2] ! This will become [R L3 Z T-2 ~> kg m s-2] @@ -1821,10 +1780,12 @@ subroutine calc_shelf_driving_stress(CS, ISS, G, US, taudx, taudy, OD) integer :: i_off, j_off isc = G%isc ; jsc = G%jsc ; iec = G%iec ; jec = G%jec - iscq = G%isc ; iecq = G%iec ; jscq = G%jsc ; jecq = G%jec + iscq = G%iscB ; iecq = G%iecB ; jscq = G%jscB ; jecq = G%jecB isd = G%isd ; jsd = G%jsd - iegq = G%ieg ; jegq = G%jeg + iegq = G%iegB ; jegq = G%jegB +! gisc = G%domain%nihalo+1 ; gjsc = G%domain%njhalo+1 gisc = 1 ; gjsc = 1 +! giec = G%domain%niglobal+G%domain%nihalo ; gjec = G%domain%njglobal+G%domain%njhalo giec = G%domain%niglobal ; gjec = G%domain%njglobal is = iscq - 1; js = jscq - 1 i_off = G%idg_offset ; j_off = G%jdg_offset @@ -1836,6 +1797,7 @@ subroutine calc_shelf_driving_stress(CS, ISS, G, US, taudx, taudy, OD) ! prelim - go through and calculate S ! or is this faster? + !BASE(:,:) = -G%bathyT(:,:) + OD(:,:) BASE(:,:) = -CS%bed_elev(:,:) + OD(:,:) S(:,:) = BASE(:,:) + ISS%h_shelf(:,:) @@ -2042,7 +2004,7 @@ subroutine init_boundary_values(CS, G, time, hmask, input_flux, input_thick, new endif if (.not.(new_sim)) then -! if (.not. G%symmetric) then + if (.not. G%symmetric) then if (((i+i_off) == (G%domain%nihalo+1)).and.(CS%u_face_mask(I-1,j) == 3)) then CS%u_shelf(I-1,J-1) = CS%u_bdry_val(I-1,J-1) CS%u_shelf(I-1,J) = CS%u_bdry_val(I-1,J) @@ -2055,7 +2017,7 @@ subroutine init_boundary_values(CS, G, time, hmask, input_flux, input_thick, new CS%v_shelf(I-1,J-1) = CS%v_bdry_val(I-1,J-1) CS%v_shelf(I,J-1) = CS%v_bdry_val(I,J-1) endif - ! endif + endif endif enddo enddo @@ -2067,9 +2029,9 @@ subroutine CG_action(uret, vret, u_shlf, v_shlf, Phi, Phisub, umask, vmask, hmas ice_visc, float_cond, bathyT, basal_trac, G, US, is, ie, js, je, dens_ratio) type(ocean_grid_type), intent(in) :: G !< The grid structure used by the ice shelf. - real, dimension(SZDI_(G),SZDJ_(G)), & + real, dimension(G%IsdB:G%IedB,G%JsdB:G%JedB), & intent(inout) :: uret !< The retarding stresses working at u-points [R L3 Z T-2 ~> kg m s-2]. - real, dimension(SZDI_(G),SZDJ_(G)), & + real, dimension(G%IsdB:G%IedB,G%JsdB:G%JedB), & intent(inout) :: vret !< The retarding stresses working at v-points [R L3 Z T-2 ~> kg m s-2]. real, dimension(8,4,SZDI_(G),SZDJ_(G)), & intent(in) :: Phi !< The gradients of bilinear basis elements at Gaussian @@ -2077,23 +2039,22 @@ subroutine CG_action(uret, vret, u_shlf, v_shlf, Phi, Phisub, umask, vmask, hmas real, dimension(:,:,:,:,:,:), & intent(in) :: Phisub !< Quadrature structure weights at subgridscale !! locations for finite element calculations [nondim] - real, dimension(SZDI_(G),SZDJ_(G)), & - intent(in) :: hmask !< A mask indicating which tracer points are - real, dimension(SZDI_(G),SZDJ_(G)), & + real, dimension(SZDIB_(G),SZDJB_(G)), & intent(in) :: u_shlf !< The zonal ice shelf velocity at vertices [L T-1 ~> m s-1] - real, dimension(SZDI_(G),SZDJ_(G)), & - intent(in) :: v_shlf !< The meridional ice shelf velocity - !at vertices [L T-1 ~> m s-1] - real, dimension(SZDI_(G),SZDJ_(G)), & + real, dimension(SZDIB_(G),SZDJB_(G)), & + intent(in) :: v_shlf !< The meridional ice shelf velocity at vertices [L T-1 ~> m s-1] + real, dimension(SZDIB_(G),SZDJB_(G)), & intent(in) :: umask !< A coded mask indicating the nature of the !! zonal flow at the corner point - real, dimension(SZDI_(G),SZDJ_(G)), & + real, dimension(SZDIB_(G),SZDJB_(G)), & intent(in) :: vmask !< A coded mask indicating the nature of the !! meridional flow at the corner point - real, dimension(SZDI_(G),SZDJ_(G)), & + real, dimension(SZDIB_(G),SZDJB_(G)), & intent(in) :: H_node !< The ice shelf thickness at nodal (corner) !! points [Z ~> m]. - !! partly or fully covered by an ice-shelf + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(in) :: hmask !< A mask indicating which tracer points are + !! partly or fully covered by an ice-shelf real, dimension(SZDI_(G),SZDJ_(G)), & intent(in) :: ice_visc !< A field related to the ice viscosity from Glen's !! flow law [R L4 Z T-1 ~> kg m2 s-1]. The exact form @@ -2103,10 +2064,10 @@ subroutine CG_action(uret, vret, u_shlf, v_shlf, Phi, Phisub, umask, vmask, hmas !! shelf is floating: 0 if floating, 1 if not. real, dimension(SZDI_(G),SZDJ_(G)), & intent(in) :: bathyT !< The depth of ocean bathymetry at tracer points [Z ~> m]. - real, dimension(SZDI_(G),SZDJ_(G)), & + real, dimension(SZDI_(G),SZDJ_(G)), & intent(in) :: basal_trac !< A field related to the nonlinear part of the !! "linearized" basal stress [R Z T-1 ~> kg m-2 s-1]. - ! and/or whether flow is "hybridized" + real, intent(in) :: dens_ratio !< The density of ice divided by the density !! of seawater, nondimensional type(unit_scale_type), intent(in) :: US !< A structure containing unit conversion factors @@ -2265,7 +2226,7 @@ subroutine matrix_diagonal(CS, G, US, float_cond, H_node, ice_visc, basal_trac, real, dimension(SZDI_(G),SZDJ_(G)), & intent(in) :: float_cond !< An array indicating where the ice !! shelf is floating: 0 if floating, 1 if not. - real, dimension(SZDI_(G),SZDJ_(G)), & + real, dimension(SZDIB_(G),SZDJB_(G)), & intent(in) :: H_node !< The ice shelf thickness at nodal !! (corner) points [Z ~> m]. real, dimension(SZDI_(G),SZDJ_(G)), & @@ -2273,8 +2234,9 @@ subroutine matrix_diagonal(CS, G, US, float_cond, H_node, ice_visc, basal_trac, !! flow law [R L4 Z T-1 ~> kg m2 s-1]. The exact form !! and units depend on the basal law exponent. real, dimension(SZDI_(G),SZDJ_(G)), & - intent(in) :: basal_trac !< A field related to the nonlinear part of the + intent(in) :: basal_trac !< A field related to the nonlinear part of the !! "linearized" basal stress [R Z T-1 ~> kg m-2 s-1]. + real, dimension(SZDI_(G),SZDJ_(G)), & intent(in) :: hmask !< A mask indicating which tracer points are !! partly or fully covered by an ice-shelf @@ -2282,14 +2244,14 @@ subroutine matrix_diagonal(CS, G, US, float_cond, H_node, ice_visc, basal_trac, !! of seawater [nondim] real, dimension(:,:,:,:,:,:), intent(in) :: Phisub !< Quadrature structure weights at subgridscale !! locations for finite element calculations [nondim] - !! matrix from the left-hand side of the solver [R L2 Z T-1 ~> kg s-1] - real, dimension(SZDI_(G),SZDJ_(G)), & + real, dimension(SZDIB_(G),SZDJB_(G)), & intent(inout) :: u_diagonal !< The diagonal elements of the u-velocity !! matrix from the left-hand side of the solver [R L2 Z T-1 ~> kg s-1] - real, dimension(SZDI_(G),SZDJ_(G)), & + real, dimension(SZDIB_(G),SZDJB_(G)), & intent(inout) :: v_diagonal !< The diagonal elements of the v-velocity !! matrix from the left-hand side of the solver [R L2 Z T-1 ~> kg s-1] + ! returns the diagonal entries of the matrix for a Jacobi preconditioning real :: ux, uy, vx, vy ! Interpolated weight gradients [L-1 ~> m-1] @@ -2323,7 +2285,7 @@ subroutine matrix_diagonal(CS, G, US, float_cond, H_node, ice_visc, basal_trac, u_diagonal(Itgt,Jtgt) = u_diagonal(Itgt,Jtgt) + & 0.25 * ice_visc(i,j) * ((4*ux+2*vy) * Phi(2*(2*(jphi-1)+iphi)-1,2*(jq-1)+iq) + & - (uy+vx) * Phi(2*(2*(jphi-1)+iphi),2*(jq-1)+iq)) + (uy+vy) * Phi(2*(2*(jphi-1)+iphi),2*(jq-1)+iq)) if (float_cond(i,j) == 0) then uq = xquad(ilq) * xquad(jlq) @@ -2413,7 +2375,7 @@ subroutine apply_boundary_values(CS, ISS, G, US, time, Phisub, H_node, ice_visc, real, dimension(:,:,:,:,:,:), & intent(in) :: Phisub !< Quadrature structure weights at subgridscale !! locations for finite element calculations [nondim] - real, dimension(SZDI_(G),SZDJ_(G)), & + real, dimension(SZDIB_(G),SZDJB_(G)), & intent(in) :: H_node !< The ice shelf thickness at nodal !! (corner) points [Z ~> m]. real, dimension(SZDI_(G),SZDJ_(G)), & @@ -2423,17 +2385,19 @@ subroutine apply_boundary_values(CS, ISS, G, US, time, Phisub, H_node, ice_visc, real, dimension(SZDI_(G),SZDJ_(G)), & intent(in) :: basal_trac !< A field related to the nonlinear part of the !! "linearized" basal stress [R Z T-1 ~> kg m-2 s-1]. + real, dimension(SZDI_(G),SZDJ_(G)), & intent(in) :: float_cond !< An array indicating where the ice !! shelf is floating: 0 if floating, 1 if not. real, intent(in) :: dens_ratio !< The density of ice divided by the density !! of seawater, nondimensional - real, dimension(SZDI_(G),SZDJ_(G)), & + real, dimension(SZDIB_(G),SZDJB_(G)), & intent(inout) :: u_bdry_contr !< Zonal force contributions due to the !! open boundaries [R L3 Z T-2 ~> kg m s-2] - real, dimension(SZDI_(G),SZDJ_(G)), & + real, dimension(SZDIB_(G),SZDJB_(G)), & intent(inout) :: v_bdry_contr !< Meridional force contributions due to the !! open boundaries [R L3 Z T-2 ~> kg m s-2] + ! this will be a per-setup function. the boundary values of thickness and velocity ! (and possibly other variables) will be updated in this function @@ -2541,8 +2505,7 @@ subroutine apply_boundary_values(CS, ISS, G, US, time, Phisub, H_node, ice_visc, endif endif ; enddo ; enddo - call pass_var(u_bdry_contr, G%domain) - call pass_var(v_bdry_contr, G%domain) + call pass_vector(u_bdry_contr, v_bdry_contr, G%domain, TO_ALL, BGRID_NE) end subroutine apply_boundary_values !> Update depth integrated viscosity, based on horizontal strain rates, and also update the @@ -2553,10 +2516,9 @@ subroutine calc_shelf_visc(CS, ISS, G, US, u_shlf, v_shlf) !! the ice-shelf state type(ocean_grid_type), intent(in) :: G !< The grid structure used by the ice shelf. type(unit_scale_type), intent(in) :: US !< A structure containing unit conversion factors - - real, dimension(G%Isd:G%Ied,G%Jsd:G%Jed), & + real, dimension(G%IsdB:G%IedB,G%JsdB:G%JedB), & intent(inout) :: u_shlf !< The zonal ice shelf velocity [L T-1 ~> m s-1]. - real, dimension(G%Isd:G%Ied,G%Jsd:G%Jed), & + real, dimension(G%IsdB:G%IedB,G%JsdB:G%JedB), & intent(inout) :: v_shlf !< The meridional ice shelf velocity [L T-1 ~> m s-1]. ! update DEPTH_INTEGRATED viscosity, based on horizontal strain rates - this is for bilinear FEM solve @@ -2565,6 +2527,7 @@ subroutine calc_shelf_visc(CS, ISS, G, US, u_shlf, v_shlf) ! also this subroutine updates the nonlinear part of the basal traction ! this may be subject to change later... to make it "hybrid" +! real, dimension(SZDIB_(G),SZDJB_(G)) :: eII, ux, uy, vx, vy integer :: i, j, iscq, iecq, jscq, jecq, isd, jsd, ied, jed, iegq, jegq, iq, jq integer :: giec, gjec, gisc, gjsc, cnt, isc, jsc, iec, jec, is, js, i_off, j_off real :: Visc_coef, n_g @@ -2572,18 +2535,19 @@ subroutine calc_shelf_visc(CS, ISS, G, US, u_shlf, v_shlf) real :: eps_min, dxh, dyh ! Velocity shears [T-1 ~> s-1] real, dimension(8,4) :: Phi real, dimension(2) :: xquad +! real :: umid, vmid, unorm ! Velocities [L T-1 ~> m s-1] isc = G%isc ; jsc = G%jsc ; iec = G%iec ; jec = G%jec - iscq = G%isc ; iecq = G%iec ; jscq = G%jsc ; jecq = G%jec + iscq = G%iscB ; iecq = G%iecB ; jscq = G%jscB ; jecq = G%jecB isd = G%isd ; jsd = G%jsd ; ied = G%ied ; jed = G%jed - iegq = G%ieg ; jegq = G%jeg + iegq = G%iegB ; jegq = G%jegB gisc = G%domain%nihalo+1 ; gjsc = G%domain%njhalo+1 giec = G%domain%niglobal+gisc ; gjec = G%domain%njglobal+gjsc is = iscq - 1; js = jscq - 1 i_off = G%idg_offset ; j_off = G%jdg_offset n_g = CS%n_glen; eps_min = CS%eps_glen_min - + CS%ice_visc(:,:)=1e22 Visc_coef = US%kg_m2s_to_RZ_T*US%m_to_L*US%Z_to_L*(CS%A_glen_isothermal)**(-1./CS%n_glen) do j=jsc,jec do i=isc,iec @@ -2612,10 +2576,9 @@ subroutine calc_shelf_taub(CS, ISS, G, US, u_shlf, v_shlf) !! the ice-shelf state type(ocean_grid_type), intent(in) :: G !< The grid structure used by the ice shelf. type(unit_scale_type), intent(in) :: US !< A structure containing unit conversion factors - - real, dimension(G%Isd:G%Ied,G%Jsd:G%Jed), & + real, dimension(G%IsdB:G%IedB,G%JsdB:G%JedB), & intent(inout) :: u_shlf !< The zonal ice shelf velocity [L T-1 ~> m s-1]. - real, dimension(G%Isd:G%Ied,G%Jsd:G%Jed), & + real, dimension(G%IsdB:G%IedB,G%JsdB:G%JedB), & intent(inout) :: v_shlf !< The meridional ice shelf velocity [L T-1 ~> m s-1]. ! also this subroutine updates the nonlinear part of the basal traction @@ -2627,9 +2590,9 @@ subroutine calc_shelf_taub(CS, ISS, G, US, u_shlf, v_shlf) real :: umid, vmid, unorm, eps_min ! Velocities [L T-1 ~> m s-1] isc = G%isc ; jsc = G%jsc ; iec = G%iec ; jec = G%jec - iscq = G%isc ; iecq = G%iec ; jscq = G%jsc ; jecq = G%jec + iscq = G%iscB ; iecq = G%iecB ; jscq = G%jscB ; jecq = G%jecB isd = G%isd ; jsd = G%jsd ; ied = G%ied ; jed = G%jed - iegq = G%ieg ; jegq = G%jeg + iegq = G%iegB ; jegq = G%jegB gisc = G%domain%nihalo+1 ; gjsc = G%domain%njhalo+1 giec = G%domain%niglobal+gisc ; gjec = G%domain%njglobal+gjsc is = iscq - 1; js = jscq - 1 @@ -2639,7 +2602,6 @@ subroutine calc_shelf_taub(CS, ISS, G, US, u_shlf, v_shlf) do j=jsd+1,jed do i=isd+1,ied - if ((ISS%hmask(i,j) == 1) .OR. (ISS%hmask(i,j) == 3)) then umid = ((u_shlf(I,J) + u_shlf(I-1,J-1)) + (u_shlf(I,J-1) + u_shlf(I-1,J))) * 0.25 vmid = ((v_shlf(I,J) + v_shlf(I-1,J-1)) + (v_shlf(I,J-1) + v_shlf(I-1,J))) * 0.25 @@ -2911,15 +2873,15 @@ subroutine update_velocity_masks(CS, G, hmask, umask, vmask, u_face_mask, v_face real, dimension(SZDI_(G),SZDJ_(G)), & intent(in) :: hmask !< A mask indicating which tracer points are !! partly or fully covered by an ice-shelf - real, dimension(SZDI_(G),SZDJ_(G)), & + real, dimension(SZDIB_(G),SZDJB_(G)), & intent(out) :: umask !< A coded mask indicating the nature of the !! zonal flow at the corner point - real, dimension(SZDI_(G),SZDJ_(G)), & + real, dimension(SZDIB_(G),SZDJB_(G)), & intent(out) :: vmask !< A coded mask indicating the nature of the !! meridional flow at the corner point - real, dimension(SZDI_(G),SZDJ_(G)), & +real, dimension(SZDIB_(G),SZDJB_(G)), & intent(out) :: u_face_mask !< A coded mask for velocities at the C-grid u-face - real, dimension(SZDI_(G),SZDJ_(G)), & + real, dimension(SZDIB_(G),SZDJB_(G)), & intent(out) :: v_face_mask !< A coded mask for velocities at the C-grid v-face ! sets masks for velocity solve ! ignores the fact that their might be ice-free cells - this only considers the computational boundary @@ -2931,21 +2893,21 @@ subroutine update_velocity_masks(CS, G, hmask, umask, vmask, u_face_mask, v_face integer :: i_off, j_off isc = G%isc ; jsc = G%jsc ; iec = G%iec ; jec = G%jec - iscq = G%isc ; iecq = G%iec ; jscq = G%jsc ; jecq = G%jec + iscq = G%iscB ; iecq = G%iecB ; jscq = G%jscB ; jecq = G%jecB i_off = G%idg_offset ; j_off = G%jdg_offset isd = G%isd ; jsd = G%jsd - iegq = G%ieg ; jegq = G%jeg + iegq = G%iegB ; jegq = G%jegB gisc = G%Domain%nihalo ; gjsc = G%Domain%njhalo giec = G%Domain%niglobal+gisc ; gjec = G%Domain%njglobal+gjsc umask(:,:) = 0 ; vmask(:,:) = 0 u_face_mask(:,:) = 0 ; v_face_mask(:,:) = 0 - ! if (G%symmetric) then - ! is = isd ; js = jsd - ! else + if (G%symmetric) then + is = isd ; js = jsd + else is = isd+1 ; js = jsd+1 - ! endif + endif do j=js,G%jed do i=is,G%ied @@ -3043,10 +3005,9 @@ subroutine update_velocity_masks(CS, G, hmask, umask, vmask, u_face_mask, v_face ! note: if the grid is nonsymmetric, there is a part that will not be transferred with a halo update ! so this subroutine must update its own symmetric part of the halo - call pass_var(u_face_mask, G%domain) - call pass_var(v_face_mask, G%domain) - call pass_var(umask, G%domain) - call pass_var(vmask, G%domain) + call pass_vector(u_face_mask, v_face_mask, G%domain, TO_ALL, CGRID_NE) + call pass_vector(umask, vmask, G%domain, TO_ALL, BGRID_NE) + end subroutine update_velocity_masks !> Interpolate the ice shelf thickness from tracer point to nodal points, @@ -3058,9 +3019,10 @@ subroutine interpolate_H_to_B(G, h_shelf, hmask, H_node) real, dimension(SZDI_(G),SZDJ_(G)), & intent(in) :: hmask !< A mask indicating which tracer points are !! partly or fully covered by an ice-shelf - real, dimension(SZDI_(G),SZDJ_(G)), & + real, dimension(SZDIB_(G),SZDJB_(G)), & intent(inout) :: H_node !< The ice shelf thickness at nodal (corner) !! points [Z ~> m]. + integer :: i, j, isc, iec, jsc, jec, num_h, k, l real :: summ @@ -3089,7 +3051,7 @@ subroutine interpolate_H_to_B(G, h_shelf, hmask, H_node) enddo enddo - call pass_var(H_node, G%domain)!, position=CORNER) + call pass_var(H_node, G%domain,position=CORNER) end subroutine interpolate_H_to_B @@ -3100,13 +3062,15 @@ subroutine ice_shelf_dyn_end(CS) if (.not.associated(CS)) return deallocate(CS%u_shelf, CS%v_shelf) + deallocate(CS%taudx_shelf, CS%taudy_shelf) deallocate(CS%t_shelf, CS%tmask) - deallocate(CS%u_bdry_val, CS%v_bdry_val, CS%t_bdry_val) + deallocate(CS%u_bdry_val, CS%v_bdry_val) deallocate(CS%u_face_mask, CS%v_face_mask) deallocate(CS%umask, CS%vmask) deallocate(CS%ice_visc, CS%basal_traction) deallocate(CS%OD_rt, CS%OD_av) + deallocate(CS%t_bdry_val, CS%bed_elev) deallocate(CS%ground_frac, CS%ground_frac_rt) deallocate(CS) diff --git a/src/ice_shelf/MOM_ice_shelf_initialize.F90 b/src/ice_shelf/MOM_ice_shelf_initialize.F90 index 4c76c3364b..c77864f114 100644 --- a/src/ice_shelf/MOM_ice_shelf_initialize.F90 +++ b/src/ice_shelf/MOM_ice_shelf_initialize.F90 @@ -7,7 +7,7 @@ module MOM_ice_shelf_initialize use MOM_array_transform, only : rotate_array use MOM_hor_index, only : hor_index_type use MOM_file_parser, only : get_param, read_param, log_param, param_file_type -use MOM_io, only: MOM_read_data, file_exists, slasher +use MOM_io, only: MOM_read_data, file_exists, slasher, CORNER use MOM_error_handler, only : MOM_error, MOM_mesg, FATAL, WARNING, is_root_pe use MOM_unit_scaling, only : unit_scale_type use user_shelf_init, only: USER_init_ice_thickness @@ -262,28 +262,31 @@ subroutine initialize_ice_shelf_boundary_channel(u_face_mask_bdry, v_face_mask_b US, PF ) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - real, dimension(SZDI_(G),SZDJ_(G)), & + real, dimension(SZIB_(G),SZJB_(G)), & intent(inout) :: u_face_mask_bdry !< A boundary-type mask at C-grid u faces - real, dimension(SZDI_(G),SZDJ_(G)), & + + real, dimension(SZIB_(G),SZJ_(G)), & intent(inout) :: u_flux_bdry_val !< The boundary thickness flux through !! C-grid u faces [L Z T-1 ~> m2 s-1]. - real, dimension(SZDI_(G),SZDJ_(G)), & + real, dimension(SZIB_(G),SZJB_(G)), & intent(inout) :: v_face_mask_bdry !< A boundary-type mask at C-grid v faces - real, dimension(SZDI_(G),SZDJ_(G)), & + + real, dimension(SZI_(G),SZJB_(G)), & intent(inout) :: v_flux_bdry_val !< The boundary thickness flux through !! C-grid v faces [L Z T-1 ~> m2 s-1]. - real, dimension(SZDI_(G),SZDJ_(G)), & + real, dimension(SZIB_(G),SZJB_(G)), & intent(inout) :: u_bdry_val !< The zonal ice shelf velocity at open !! boundary vertices [L T-1 ~> m s-1]. - real, dimension(SZDI_(G),SZDJ_(G)), & + real, dimension(SZIB_(G),SZJB_(G)), & intent(inout) :: v_bdry_val !< The meridional ice shelf velocity at open - real, dimension(SZDI_(G),SZDJ_(G)), & + real, dimension(SZIB_(G),SZJB_(G)), & intent(inout) :: u_shelf !< The zonal ice shelf velocity [L T-1 ~> m s-1]. - real, dimension(SZDI_(G),SZDJ_(G)), & + real, dimension(SZIB_(G),SZJB_(G)), & intent(inout) :: v_shelf !< The meridional ice shelf velocity [L T-1 ~> m s-1]. real, dimension(SZDI_(G),SZDJ_(G)), & intent(inout) :: thickness_bdry_val !< The ice shelf thickness at open boundaries [Z ~> m] !! boundary vertices [L T-1 ~> m s-1]. + real, dimension(SZDI_(G),SZDJ_(G)), & intent(inout) :: h_bdry_val !< The ice shelf thickness at open boundaries [Z ~> m] real, dimension(SZDI_(G),SZDJ_(G)), & @@ -376,17 +379,18 @@ end subroutine initialize_ice_shelf_boundary_channel !> Initialize ice shelf flow from file -subroutine initialize_ice_flow_from_file(bed_elev,u_shelf, v_shelf,ice_visc,float_cond,& +subroutine initialize_ice_flow_from_file(bed_elev,u_shelf, v_shelf,float_cond,& hmask,h_shelf, G, US, PF) +!subroutine initialize_ice_flow_from_file(bed_elev,u_shelf, v_shelf,ice_visc,float_cond,& +! hmask,h_shelf, G, US, PF) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure real, dimension(SZDI_(G),SZDJ_(G)), & intent(inout) :: bed_elev !< The ice shelf u velocity [Z ~> m]. - real, dimension(SZDI_(G),SZDJ_(G)), & - intent(inout) :: u_shelf !< The ice shelf u velocity [Z ~> m T ~>s]. - real, dimension(SZDI_(G),SZDJ_(G)), & - intent(inout) :: v_shelf !< The ice shelf v velocity [Z ~> m T ~> s]. - real, dimension(SZDI_(G),SZDJ_(G)), & - intent(inout) :: ice_visc !< The ice shelf viscosity [Pa ~> m T ~> s]. + real, dimension(SZIB_(G),SZJB_(G)), & + intent(inout) :: u_shelf !< The zonal ice shelf velocity [L T-1 ~> m s-1]. + real, dimension(SZIB_(G),SZJB_(G)), & + intent(inout) :: v_shelf !< The meridional ice shelf velocity [L T-1 ~> m s-1]. + real, dimension(SZDI_(G),SZDJ_(G)), & intent(inout) :: float_cond !< An array indicating where the ice !! shelf is floating: 0 if floating, 1 if not. @@ -441,22 +445,22 @@ subroutine initialize_ice_flow_from_file(bed_elev,u_shelf, v_shelf,ice_visc,floa floatfr_varname = "float_frac" - call MOM_read_data(filename, trim(ushelf_varname), u_shelf, G%Domain, scale=1.0) - call MOM_read_data(filename,trim(vshelf_varname), v_shelf, G%Domain, scale=1.0) - call MOM_read_data(filename,trim(ice_visc_varname), ice_visc, G%Domain, scale=1.0) + call MOM_read_data(filename, trim(ushelf_varname), u_shelf, G%Domain, position=CORNER,scale=1.0) + call MOM_read_data(filename,trim(vshelf_varname), v_shelf, G%Domain, position=CORNER,scale=1.0) +! call MOM_read_data(filename,trim(ice_visc_varname), ice_visc, G%Domain,position=CORNER,scale=1.0) call MOM_read_data(filename,trim(floatfr_varname), float_cond, G%Domain, scale=1.) filename = trim(inputdir)//trim(bed_topo_file) call MOM_read_data(filename,trim(bed_varname), bed_elev, G%Domain, scale=1.) isc = G%isc ; jsc = G%jsc ; iec = G%iec ; jec = G%jec - do j=jsc,jec - do i=isc,iec - if (hmask(i,j) == 1.) then - ice_visc(i,j) = ice_visc(i,j) * (G%areaT(i,j) * h_shelf(i,j)) - endif - enddo - enddo +! do j=jsc,jec +! do i=isc,iec +! if (hmask(i,j) == 1.) then +! ice_visc(i,j) = ice_visc(i,j) * (G%areaT(i,j) * h_shelf(i,j)) +! endif +! enddo +! enddo end subroutine initialize_ice_flow_from_file @@ -466,18 +470,18 @@ subroutine initialize_ice_shelf_boundary_from_file(u_face_mask_bdry, v_face_mask hmask, h_shelf, G, US, PF ) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - real, dimension(SZDI_(G),SZDJ_(G)), & - intent(inout) :: u_face_mask_bdry !< A boundary-type mask at C-grid u faces - real, dimension(SZDI_(G),SZDJ_(G)), & - intent(inout) :: v_face_mask_bdry !< A boundary-type mask at C-grid v faces - real, dimension(SZDI_(G),SZDJ_(G)), & + real, dimension(SZIB_(G),SZJB_(G)), & + intent(inout) :: u_face_mask_bdry !< A boundary-type mask at B-grid u faces + real, dimension(SZIB_(G),SZJB_(G)), & + intent(inout) :: v_face_mask_bdry !< A boundary-type mask at B-grid v faces + real, dimension(SZIB_(G),SZJB_(G)), & intent(inout) :: u_bdry_val !< The zonal ice shelf velocity at open !! boundary vertices [L T-1 ~> m s-1]. - real, dimension(SZDI_(G),SZDJ_(G)), & + real, dimension(SZIB_(G),SZJB_(G)), & intent(inout) :: v_bdry_val !< The meridional ice shelf velocity at open - real, dimension(SZDI_(G),SZDJ_(G)), & + real, dimension(SZDIB_(G),SZDJB_(G)), & intent(inout) :: umask !< A mask foor ice shelf velocity - real, dimension(SZDI_(G),SZDJ_(G)), & + real, dimension(SZDIB_(G),SZDJB_(G)), & intent(inout) :: vmask !< A mask foor ice shelf velocity real, dimension(SZDI_(G),SZDJ_(G)), & intent(inout) :: thickness_bdry_val !< The ice shelf thickness at open boundaries [Z ~> m] @@ -503,7 +507,7 @@ subroutine initialize_ice_shelf_boundary_from_file(u_face_mask_bdry, v_face_mask h_bdry_val(:,:) = 0. thickness_bdry_val(:,:) = 0. - call MOM_mesg(" MOM_ice_shelf_init_profile.F90, initialize_velocity_from_file: reading velocity") + call MOM_mesg(" MOM_ice_shelf_init_profile.F90, initialize_b_c_s_from_file: reading b.c.s") call get_param(PF, mdl, "INPUTDIR", inputdir, default=".") inputdir = slasher(inputdir) @@ -544,12 +548,12 @@ subroutine initialize_ice_shelf_boundary_from_file(u_face_mask_bdry, v_face_mask " initialize_ice_shelf_velocity_from_file: Unable to open "//trim(filename)) - call MOM_read_data(filename, trim(ufcmskbdry_varname),u_face_mask_bdry, G%Domain, scale=1.0) - call MOM_read_data(filename,trim(vfcmskbdry_varname), v_face_mask_bdry, G%Domain, scale=1.0) - call MOM_read_data(filename,trim(ubdryv_varname), u_bdry_val, G%Domain, scale=1.0) - call MOM_read_data(filename,trim(vbdryv_varname), v_bdry_val, G%Domain, scale=1.) - call MOM_read_data(filename,trim(umask_varname), umask, G%Domain, scale=1.) - call MOM_read_data(filename,trim(vmask_varname), vmask, G%Domain, scale=1.) + call MOM_read_data(filename, trim(ufcmskbdry_varname),u_face_mask_bdry, G%Domain,position=CORNER,scale=1.0) + call MOM_read_data(filename,trim(vfcmskbdry_varname), v_face_mask_bdry, G%Domain, position=CORNER,scale=1.0) + call MOM_read_data(filename,trim(ubdryv_varname), u_bdry_val, G%Domain, position=CORNER,scale=1.0) + call MOM_read_data(filename,trim(vbdryv_varname), v_bdry_val, G%Domain, position=CORNER,scale=1.) + call MOM_read_data(filename,trim(umask_varname), umask, G%Domain, position=CORNER,scale=1.) + call MOM_read_data(filename,trim(vmask_varname), vmask, G%Domain, position=CORNER,scale=1.) filename = trim(inputdir)//trim(icethick_file) call MOM_read_data(filename, trim(h_varname), h_shelf, G%Domain, scale=US%m_to_Z) From b2af54d8afe9623a97947e71ac756c5951226b3f Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 7 May 2021 21:09:51 -0400 Subject: [PATCH 070/112] +Move wave module variables into control structure Moved 15 module variables into wave_parameters_CS, to follow the coding style and conventions in the rest of the code. Also added comments describing 8 enumeration parameters in this same module, and added comments suggesting ways that the accuracy of the calculations could be improved. Also incorporated a factor of 2*PI into the definition of Freq_Cen in this module. In addition, the initialization procedure for this module was altered in some more commonly used cases, so that use MOM_wave_interface_init to set wave parameters, even with a statistical wave model, and eliminated MOM_wave_interface_init_lite. I believe that all solutions should be bitwise identical, but this module is not yet well tested in the MOM6 regression tests. --- .../drivers/FMS_cap/ocean_model_MOM.F90 | 12 +- .../drivers/mct_cap/mom_ocean_model_mct.F90 | 12 +- .../nuopc_cap/mom_ocean_model_nuopc.F90 | 21 +- config_src/drivers/solo_driver/MOM_driver.F90 | 10 +- src/user/MOM_wave_interface.F90 | 472 ++++++++++-------- 5 files changed, 283 insertions(+), 244 deletions(-) diff --git a/config_src/drivers/FMS_cap/ocean_model_MOM.F90 b/config_src/drivers/FMS_cap/ocean_model_MOM.F90 index c430623591..62c00fd86a 100644 --- a/config_src/drivers/FMS_cap/ocean_model_MOM.F90 +++ b/config_src/drivers/FMS_cap/ocean_model_MOM.F90 @@ -55,7 +55,7 @@ module ocean_model_mod use MOM_ice_shelf, only : initialize_ice_shelf, shelf_calc_flux, ice_shelf_CS use MOM_ice_shelf, only : add_shelf_forces, ice_shelf_end, ice_shelf_save_restart use MOM_wave_interface, only: wave_parameters_CS, MOM_wave_interface_init -use MOM_wave_interface, only: MOM_wave_interface_init_lite, Update_Surface_Waves +use MOM_wave_interface, only: Update_Surface_Waves use iso_fortran_env, only : int64 #include @@ -205,7 +205,7 @@ module ocean_model_mod marine_ice_CSp => NULL() !< A pointer to the control structure for the !! marine ice effects module. type(wave_parameters_cs), pointer :: & - Waves !< A structure containing pointers to the surface wave fields + Waves => NULL() !< A pointer to the surface wave control structure type(surface_forcing_CS), pointer :: & forcing_CSp => NULL() !< A pointer to the MOM forcing control structure type(MOM_restart_CS), pointer :: & @@ -382,11 +382,9 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, wind_stagger, gas call get_param(param_file, mdl, "USE_WAVES", OS%Use_Waves, & "If true, enables surface wave modules.", default=.false.) - if (OS%use_waves) then - call MOM_wave_interface_init(OS%Time, OS%grid, OS%GV, OS%US, param_file, OS%Waves, OS%diag) - else - call MOM_wave_interface_init_lite(param_file) - endif + ! MOM_wave_interface_init is called regardless of the value of USE_WAVES because + ! it also initCSializes statistical waves. + call MOM_wave_interface_init(OS%Time, OS%grid, OS%GV, OS%US, param_file, OS%Waves, OS%diag) call initialize_ocean_public_type(OS%grid%Domain, Ocean_sfc, OS%diag, & gas_fields_ocn=gas_fields_ocn) diff --git a/config_src/drivers/mct_cap/mom_ocean_model_mct.F90 b/config_src/drivers/mct_cap/mom_ocean_model_mct.F90 index bd6c7fe66e..9b40a9e7b4 100644 --- a/config_src/drivers/mct_cap/mom_ocean_model_mct.F90 +++ b/config_src/drivers/mct_cap/mom_ocean_model_mct.F90 @@ -61,7 +61,7 @@ module MOM_ocean_model_mct use mpp_mod, only : mpp_chksum use MOM_EOS, only : gsw_sp_from_sr, gsw_pt_from_ct use MOM_wave_interface, only : wave_parameters_CS, MOM_wave_interface_init -use MOM_wave_interface, only : MOM_wave_interface_init_lite, Update_Surface_Waves +use MOM_wave_interface, only : Update_Surface_Waves use time_interp_external_mod, only : time_interp_external_init ! MCT specfic routines @@ -205,7 +205,7 @@ module MOM_ocean_model_mct marine_ice_CSp => NULL() !< A pointer to the control structure for the !! marine ice effects module. type(wave_parameters_cs), pointer :: & - Waves !< A structure containing pointers to the surface wave fields + Waves => NULL() !< A pointer to the surface wave control structure type(surface_forcing_CS), pointer :: & forcing_CSp => NULL() !< A pointer to the MOM forcing control structure type(MOM_restart_CS), pointer :: & @@ -383,11 +383,9 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, gas_fields_ocn, i call get_param(param_file, mdl, "USE_WAVES", OS%Use_Waves, & "If true, enables surface wave modules.", default=.false.) - if (OS%use_waves) then - call MOM_wave_interface_init(OS%Time, OS%grid, OS%GV, OS%US, param_file, OS%Waves, OS%diag) - else - call MOM_wave_interface_init_lite(param_file) - endif + ! MOM_wave_interface_init is called regardless of the value of USE_WAVES because + ! it also initializes statistical waves. + call MOM_wave_interface_init(OS%Time, OS%grid, OS%GV, OS%US, param_file, OS%Waves, OS%diag) if (associated(OS%grid%Domain%maskmap)) then call initialize_ocean_public_type(OS%grid%Domain%mpp_domain, Ocean_sfc, & diff --git a/config_src/drivers/nuopc_cap/mom_ocean_model_nuopc.F90 b/config_src/drivers/nuopc_cap/mom_ocean_model_nuopc.F90 index b8bcf8ff87..1d5de0dd3e 100644 --- a/config_src/drivers/nuopc_cap/mom_ocean_model_nuopc.F90 +++ b/config_src/drivers/nuopc_cap/mom_ocean_model_nuopc.F90 @@ -57,8 +57,8 @@ module MOM_ocean_model_nuopc use fms_mod, only : stdout use mpp_mod, only : mpp_chksum use MOM_EOS, only : gsw_sp_from_sr, gsw_pt_from_ct -use MOM_wave_interface, only: wave_parameters_CS, MOM_wave_interface_init -use MOM_wave_interface, only: MOM_wave_interface_init_lite, Update_Surface_Waves +use MOM_wave_interface, only : wave_parameters_CS, MOM_wave_interface_init +use MOM_wave_interface, only : Update_Surface_Waves use MOM_surface_forcing_nuopc, only : surface_forcing_init, convert_IOB_to_fluxes use MOM_surface_forcing_nuopc, only : convert_IOB_to_forces, ice_ocn_bnd_type_chksum use MOM_surface_forcing_nuopc, only : ice_ocean_boundary_type, surface_forcing_CS @@ -206,8 +206,8 @@ module MOM_ocean_model_nuopc type(marine_ice_CS), pointer :: & marine_ice_CSp => NULL() !< A pointer to the control structure for the !! marine ice effects module. - type(wave_parameters_cs), pointer, public :: & - Waves !< A structure containing pointers to the surface wave fields + type(wave_parameters_CS), pointer, public :: & + Waves => NULL() !< A pointer to the surface wave control structure type(surface_forcing_CS), pointer :: & forcing_CSp => NULL() !< A pointer to the MOM forcing control structure type(MOM_restart_CS), pointer :: & @@ -388,13 +388,14 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, gas_fields_ocn, i call get_param(param_file, mdl, "USE_WAVES", OS%Use_Waves, & "If true, enables surface wave modules.", default=.false.) + ! MOM_wave_interface_init is called regardless of the value of USE_WAVES because + ! it also initializes statistical waves. + call MOM_wave_interface_init(OS%Time, OS%grid, OS%GV, OS%US, param_file, OS%Waves, OS%diag) if (OS%use_waves) then - call MOM_wave_interface_init(OS%Time, OS%grid, OS%GV, OS%US, param_file, OS%Waves, OS%diag) - call get_param(param_file,mdl,"SURFBAND_WAVENUMBERS",OS%Waves%WaveNum_Cen, & - "Central wavenumbers for surface Stokes drift bands.",units='rad/m', & - default=0.12566) - else - call MOM_wave_interface_init_lite(param_file) + ! I do not know why this is being set here. It seems out of place. -RWH + call get_param(param_file,mdl,"SURFBAND_WAVENUMBERS", OS%Waves%WaveNum_Cen, & + "Central wavenumbers for surface Stokes drift bands.", & + units='rad/m', default=0.12566, scale=OS%US%Z_to_m) endif if (associated(OS%grid%Domain%maskmap)) then diff --git a/config_src/drivers/solo_driver/MOM_driver.F90 b/config_src/drivers/solo_driver/MOM_driver.F90 index 8edad7fa05..7c14820e31 100644 --- a/config_src/drivers/solo_driver/MOM_driver.F90 +++ b/config_src/drivers/solo_driver/MOM_driver.F90 @@ -65,7 +65,7 @@ program MOM_main use MOM_variables, only : surface use MOM_verticalGrid, only : verticalGrid_type use MOM_wave_interface, only : wave_parameters_CS, MOM_wave_interface_init - use MOM_wave_interface, only : MOM_wave_interface_init_lite, Update_Surface_Waves + use MOM_wave_interface, only : Update_Surface_Waves use MOM_write_cputime, only : write_cputime, MOM_write_cputime_init use MOM_write_cputime, only : write_cputime_start_clock, write_cputime_CS @@ -331,11 +331,9 @@ program MOM_main call get_param(param_file,mod_name, "USE_WAVES", Use_Waves, & "If true, enables surface wave modules.",default=.false.) - if (use_waves) then - call MOM_wave_interface_init(Time, grid, GV, US, param_file, Waves_CSp, diag) - else - call MOM_wave_interface_init_lite(param_file) - endif + ! MOM_wave_interface_init is called regardless of the value of USE_WAVES because + ! it also initCSializes statistical waves. + call MOM_wave_interface_init(Time, grid, GV, US, param_file, Waves_CSp, diag) segment_start_time = Time elapsed_time = 0.0 diff --git a/src/user/MOM_wave_interface.F90 b/src/user/MOM_wave_interface.F90 index c2a162c162..5fe48d3ebb 100644 --- a/src/user/MOM_wave_interface.F90 +++ b/src/user/MOM_wave_interface.F90 @@ -24,7 +24,6 @@ module MOM_wave_interface #include public MOM_wave_interface_init ! Public interface to fully initialize the wave routines. -public MOM_wave_interface_init_lite ! Public interface to quick initialize this module. public Update_Surface_Waves ! Public interface to update wave information at the ! coupler/driver level. public Update_Stokes_Drift ! Public interface to update the Stokes drift profiles @@ -62,6 +61,13 @@ module MOM_wave_interface KvS !< Viscosity for Stokes Drift shear [Z2 T-1 ~> m2 s-1] ! The remainder of this control structure is private + integer :: WaveMethod = -99 !< Options for including wave information + !! Valid (tested) choices are: + !! 0 - Test Profile + !! 1 - Surface Stokes Drift Bands + !! 2 - DHH85 + !! 3 - LF17 + !! -99 - No waves computed, but empirical Langmuir number used. logical :: LagrangianMixing !< This feature is in development and not ready !! True if Stokes drift is present and mixing !! should be applied to Lagrangian current @@ -80,18 +86,35 @@ module MOM_wave_interface !! 1 if average value of Stokes drift over level. !! If advecting with Stokes transport, 1 is the correct !! approach. + ! Options if WaveMethod is Surface Stokes Drift Bands (1) + integer :: PartitionMode !< Method for partition mode (meant to check input) + !! 0 - wavenumbers + !! 1 - frequencies + integer :: DataSource !< Integer that specifies where the model Looks for data + !! Valid choices are: + !! 1 - FMS DataOverride Routine + !! 2 - Reserved For Coupler + !! 3 - User input (fixed values, useful for 1d testing) + + ! Options if using FMS DataOverride Routine + character(len=40) :: SurfBandFileName !< Filename if using DataOverride + logical :: DataOver_initialized !< Flag for DataOverride Initialization + + ! Options for computing Langmuir number + real :: LA_FracHBL !< Fraction of OSBL for averaging Langmuir number + logical :: LA_Misalignment = .false. !< Flag to use misalignment in Langmuir number - ! Surface Wave Dependent 1d/2d/3d vars integer :: NumBands = 0 !< Number of wavenumber/frequency partitions to receive !! This needs to match the number of bands provided !! via either coupling or file. real :: g_Earth !< The gravitational acceleration, equivalent to GV%g_Earth but with !! different dimensional rescaling appropriate for deep-water gravity !! waves [Z T-2 ~> m s-2] + ! Surface Wave Dependent 1d/2d/3d vars real, allocatable, dimension(:) :: & WaveNum_Cen !< Wavenumber bands for read/coupled [Z-1 ~> m-1] real, allocatable, dimension(:) :: & - Freq_Cen !< Frequency bands for read/coupled [T-1 ~> s-1] + Freq_Cen !< Central frequency for wave bands, including a factor of 2*pi [T-1 ~> s-1] real, allocatable, dimension(:) :: & PrescribedSurfStkX !< Surface Stokes drift if prescribed [L T-1 ~> m s-1] real, allocatable, dimension(:) :: & @@ -116,11 +139,6 @@ module MOM_wave_interface !! Horizontal -> V points !! 3rd dimension -> Freq/Wavenumber - ! Pointers to auxiliary fields - type(time_type), pointer :: Time !< A pointer to the ocean model's clock. - type(diag_ctrl), pointer :: diag !< A structure that is used to regulate the - !! timing of diagnostic output. - !> An arbitrary lower-bound on the Langmuir number. Run-time parameter. !! Langmuir number is sqrt(u_star/u_stokes). When both are small !! but u_star is orders of magnitude smaller the Langmuir number could @@ -128,6 +146,22 @@ module MOM_wave_interface !! to avoid such consequences. real :: La_min = 0.05 + ! Options used with the test profile + real :: TP_STKX0 !< Test profile x-stokes drift amplitude [L T-1 ~> m s-1] + real :: TP_STKY0 !< Test profile y-stokes drift amplitude [L T-1 ~> m s-1] + real :: TP_WVL !< Test profile wavelength [Z ~> m] + + ! Options for use with the Donelan et al., 1985 (DHH85) spectrum + logical :: WaveAgePeakFreq ! Flag to use wave age to determine the peak frequency with DHH85 + logical :: StaticWaves !< Flag to disable updating DHH85 Stokes drift + logical :: DHH85_is_set !< The if the wave properties have been set when WaveMethod = DHH85. + real :: WaveAge !< The fixed wave age used with the DHH85 spectrum [nondim] + real :: WaveWind !< Wind speed for the DHH85 spectrum [L T-1 ~> m s-1] + + type(time_type), pointer :: Time !< A pointer to the ocean model's clock. + type(diag_ctrl), pointer :: diag !< A structure that is used to regulate the + !! timing of diagnostic output. + !>@{ Diagnostic handles integer :: id_surfacestokes_x = -1 , id_surfacestokes_y = -1 integer :: id_3dstokes_x = -1 , id_3dstokes_y = -1 @@ -136,63 +170,12 @@ module MOM_wave_interface end type wave_parameters_CS -! Options not needed outside of this module - -integer :: WaveMethod=-99 !< Options for including wave information - !! Valid (tested) choices are: - !! 0 - Test Profile - !! 1 - Surface Stokes Drift Bands - !! 2 - DHH85 - !! 3 - LF17 - !! -99 - No waves computed, but empirical Langmuir number used. - !! \todo Module variable! Move into a control structure. - -! Options if WaveMethod is Surface Stokes Drift Bands (1) -integer :: PartitionMode !< Method for partition mode (meant to check input) - !! 0 - wavenumbers - !! 1 - frequencies - !! \todo Module variable! Move into a control structure. -integer :: DataSource !< Integer that specifies where the Model Looks for Data - !! Valid choices are: - !! 1 - FMS DataOverride Routine - !! 2 - Reserved For Coupler - !! 3 - User input (fixed values, useful for 1d testing) - !! \todo Module variable! Move into a control structure. - -! Options if using FMS DataOverride Routine -character(len=40) :: SurfBandFileName !< Filename if using DataOverride - !! \todo Module variable! Move into a control structure. -logical :: dataoverrideisinitialized !< Flag for DataOverride Initialization - !! \todo Module variable! Move into a control structure. - -! Options for computing Langmuir number -real :: LA_FracHBL !< Fraction of OSBL for averaging Langmuir number - !! \todo Module variable! Move into a control structure. -logical :: LA_Misalignment = .false. !< Flag to use misalignment in Langmuir number - !! \todo Module variable! Move into a control structure. - -! This include declares and sets the variable "version". -#include "version_variable.h" - -character(len=40) :: mdl = "MOM_wave_interface" !< This module's name. - -!>@{ Undocumented parameters. -!! \todo These module variables need to be documented as static/private variables or moved -!! into a control structure. ! Switches needed in import_stokes_drift -integer, parameter :: TESTPROF = 0, SURFBANDS = 1, & - DHH85 = 2, LF17 = 3, NULL_WaveMethod=-99, & - DATAOVR = 1, COUPLER = 2, INPUT = 3 - -! Options For Test Prof -real :: TP_STKX0 ! Test profile x-stokes drift amplitude [L T-1 ~> m s-1] -real :: TP_STKY0 ! Test profile y-stokes drift amplitude [L T-1 ~> m s-1] -real :: TP_WVL ! Test profile wavelength [Z ~> m] -logical :: WaveAgePeakFreq ! Flag to use W -logical :: StaticWaves, DHH85_Is_Set -real :: WaveAge -real :: WaveWind ! Wind speed for the test profile [L T-1 ~> m s-1] -real :: PI +!>@{ Enumeration values for the wave method +integer, parameter :: TESTPROF = 0, SURFBANDS = 1, DHH85 = 2, LF17 = 3, NULL_WaveMethod = -99 +!>@} +!>@{ Enumeration values for the wave data source +integer, parameter :: DATAOVR = 1, COUPLER = 2, INPUT = 3 !>@} contains @@ -206,9 +189,12 @@ subroutine MOM_wave_interface_init(time, G, GV, US, param_file, CS, diag ) type(param_file_type), intent(in) :: param_file !< Input parameter structure type(wave_parameters_CS), pointer :: CS !< Wave parameter control structure type(diag_ctrl), target, intent(inout) :: diag !< Diagnostic Pointer + ! Local variables - ! I/O - character*(13) :: TMPSTRING1,TMPSTRING2 + character(len=40) :: mdl = "MOM_wave_interface" !< This module's name. + ! This include declares and sets the variable "version". +# include "version_variable.h" + character*(13) :: TMPSTRING1, TMPSTRING2 character*(5), parameter :: NULL_STRING = "EMPTY" character*(12), parameter :: TESTPROF_STRING = "TEST_PROFILE" character*(13), parameter :: SURFBANDS_STRING = "SURFACE_BANDS" @@ -217,6 +203,8 @@ subroutine MOM_wave_interface_init(time, G, GV, US, param_file, CS, diag ) character*(12), parameter :: DATAOVR_STRING = "DATAOVERRIDE" character*(7), parameter :: COUPLER_STRING = "COUPLER" character*(5), parameter :: INPUT_STRING = "INPUT" + logical :: use_waves + logical :: StatisticalWaves ! Dummy Check if (associated(CS)) then @@ -224,46 +212,65 @@ subroutine MOM_wave_interface_init(time, G, GV, US, param_file, CS, diag ) return endif - PI=4.0*atan(1.0) + call get_param(param_file, mdl, "USE_WAVES", use_waves, & + "If true, enables surface wave modules.", default=.false.) + + ! Check if using LA_LI2016 + call get_param(param_file,mdl,"USE_LA_LI2016",StatisticalWaves, & + do_not_log=.true.,default=.false.) + + if (.not.(use_waves .or. StatisticalWaves)) return ! Allocate CS and set pointers allocate(CS) + CS%UseWaves = use_waves CS%diag => diag CS%Time => Time - ! Add any initializations needed here - dataOverrideIsInitialized = .false. + CS%g_Earth = US%L_to_Z**2*GV%g_Earth - ! The only way to get here is with UseWaves enabled. - CS%UseWaves = .true. + ! Add any initializations needed here + CS%DataOver_initialized = .false. call log_version(param_file, mdl, version) + ! Langmuir number Options + call get_param(param_file, mdl, "LA_DEPTH_RATIO", CS%LA_FracHBL, & + "The depth (normalized by BLD) to average Stokes drift over in "//& + "Langmuir number calculation, where La = sqrt(ust/Stokes).", & + units="nondim", default=0.04) + + if (StatisticalWaves) then + CS%WaveMethod = LF17 + if (.not.use_waves) return + else + CS%WaveMethod = NULL_WaveMethod + end if + ! Wave modified physics ! Presently these are all in research mode call get_param(param_file, mdl, "LAGRANGIAN_MIXING", CS%LagrangianMixing, & "Flag to use Lagrangian Mixing of momentum", units="", & - Default=.false.) + Default=.false., do_not_log=.not.use_waves) if (CS%LagrangianMixing) then ! Force Code Intervention call MOM_error(FATAL,"Should you be enabling Lagrangian Mixing? Code not ready.") endif call get_param(param_file, mdl, "STOKES_MIXING", CS%StokesMixing, & "Flag to use Stokes Mixing of momentum", units="", & - Default=.false.) + Default=.false., do_not_log=.not.use_waves) if (CS%StokesMixing) then ! Force Code Intervention call MOM_error(FATAL,"Should you be enabling Stokes Mixing? Code not ready.") endif call get_param(param_file, mdl, "CORIOLIS_STOKES", CS%CoriolisStokes, & "Flag to use Coriolis Stokes acceleration", units="", & - Default=.false.) + Default=.false., do_not_log=.not.use_waves) if (CS%CoriolisStokes) then ! Force Code Intervention call MOM_error(FATAL,"Should you be enabling Coriolis-Stokes? Code not ready.") endif - CS%g_Earth = US%L_to_Z**2*GV%g_Earth ! Get Wave Method and write to integer WaveMethod call get_param(param_file,mdl,"WAVE_METHOD",TMPSTRING1, & @@ -282,19 +289,19 @@ subroutine MOM_wave_interface_init(time, G, GV, US, param_file, CS, diag ) call MOM_error(FATAL, "wave_interface_init called with no specified "//& "WAVE_METHOD.") case (TESTPROF_STRING)! Test Profile - WaveMethod = TESTPROF - call get_param(param_file, mdl, "TP_STKX_SURF", TP_STKX0,& - 'Surface Stokes (x) for test profile',& + CS%WaveMethod = TESTPROF + call get_param(param_file, mdl, "TP_STKX_SURF", CS%TP_STKX0, & + 'Surface Stokes (x) for test profile', & units='m/s', default=0.1, scale=US%m_s_to_L_T) - call get_param(param_file, mdl, "TP_STKY_SURF", TP_STKY0,& - 'Surface Stokes (y) for test profile',& + call get_param(param_file, mdl, "TP_STKY_SURF", CS%TP_STKY0, & + 'Surface Stokes (y) for test profile', & units='m/s', default=0.0, scale=US%m_s_to_L_T) - call get_param(param_file,mdl, "TP_WVL", TP_WVL, & + call get_param(param_file,mdl, "TP_WVL", CS%TP_WVL, & 'Wavelength for test profile', & units='m', default=50.0, scale=US%m_to_Z) case (SURFBANDS_STRING)! Surface Stokes Drift Bands - WaveMethod = SURFBANDS - call get_param(param_file, mdl, "SURFBAND_SOURCE",TMPSTRING2, & + CS%WaveMethod = SURFBANDS + call get_param(param_file, mdl, "SURFBAND_SOURCE", TMPSTRING2, & "Choice of SURFACE_BANDS data mode, valid options include: \n"// & " DATAOVERRIDE - Read from NetCDF using FMS DataOverride. \n"// & " COUPLER - Look for variables from coupler pass \n"// & @@ -305,11 +312,11 @@ subroutine MOM_wave_interface_init(time, G, GV, US, param_file, CS, diag ) call MOM_error(FATAL, "wave_interface_init called with SURFACE_BANDS"//& " but no SURFBAND_SOURCE.") case (DATAOVR_STRING)! Using Data Override - DataSource = DATAOVR - call get_param(param_file, mdl, "SURFBAND_FILENAME", SurfBandFileName, & + CS%DataSource = DATAOVR + call get_param(param_file, mdl, "SURFBAND_FILENAME", CS%SurfBandFileName, & "Filename of surface Stokes drift input band data.", default="StkSpec.nc") case (COUPLER_STRING)! Reserved for coupling - DataSource = Coupler + CS%DataSource = COUPLER ! This is just to make something work, but it needs to be read from the wavemodel. call get_param(param_file,mdl,"STK_BAND_COUPLER",CS%NumBands, & "STK_BAND_COUPLER is the number of Stokes drift bands in the coupler. "// & @@ -321,9 +328,9 @@ subroutine MOM_wave_interface_init(time, G, GV, US, param_file, CS, diag ) CS%WaveNum_Cen(:) = 0.0 CS%STKx0(:,:,:) = 0.0 CS%STKy0(:,:,:) = 0.0 - partitionmode = 0 + CS%PartitionMode = 0 case (INPUT_STRING)! A method to input the Stokes band (globally uniform) - DataSource = Input + CS%DataSource = INPUT call get_param(param_file,mdl,"SURFBAND_NB",CS%NumBands, & "Prescribe number of wavenumber bands for Stokes drift. "// & "Make sure this is consistnet w/ WAVENUMBERS, STOKES_X, and "// & @@ -339,7 +346,7 @@ subroutine MOM_wave_interface_init(time, G, GV, US, param_file, CS, diag ) CS%STKx0(:,:,:) = 0.0 allocate( CS%STKy0(G%isd:G%ied,G%jsdB:G%jedB,1:CS%NumBands)) CS%STKy0(:,:,:) = 0.0 - partitionmode=0 + CS%PartitionMode = 0 call get_param(param_file, mdl, "SURFBAND_WAVENUMBERS", CS%WaveNum_Cen, & "Central wavenumbers for surface Stokes drift bands.", & units='rad/m', default=0.12566, scale=US%Z_to_m) @@ -353,40 +360,40 @@ subroutine MOM_wave_interface_init(time, G, GV, US, param_file, CS, diag ) call MOM_error(FATAL,'Check WAVE_METHOD.') end select - case (DHH85_STRING)!Donelan et al., 1985 spectrum - WaveMethod = DHH85 + case (DHH85_STRING) !Donelan et al., 1985 spectrum + CS%WaveMethod = DHH85 call MOM_error(WARNING,"DHH85 only ever set-up for uniform cases w/"//& " Stokes drift in x-direction.") - call get_param(param_file,mdl,"DHH85_AGE_FP",WaveAgePeakFreq, & + call get_param(param_file, mdl, "DHH85_AGE_FP", CS%WaveAgePeakFreq, & "Choose true to use waveage in peak frequency.", & units='', default=.false.) - call get_param(param_file,mdl,"DHH85_AGE",WaveAge, & + call get_param(param_file, mdl, "DHH85_AGE", CS%WaveAge, & "Wave Age for DHH85 spectrum.", & units='', default=1.2) - call get_param(param_file,mdl,"DHH85_WIND", WaveWind, & + call get_param(param_file,mdl,"DHH85_WIND", CS%WaveWind, & "Wind speed for DHH85 spectrum.", & units='m s-1', default=10.0, scale=US%m_s_to_L_T) - call get_param(param_file,mdl,"STATIC_DHH85",StaticWaves, & + call get_param(param_file,mdl,"STATIC_DHH85", CS%StaticWaves, & "Flag to disable updating DHH85 Stokes drift.", & default=.false.) case (LF17_STRING)!Li and Fox-Kemper 17 wind-sea Langmuir number - WaveMethod = LF17 + CS%WaveMethod = LF17 case default call MOM_error(FATAL,'Check WAVE_METHOD.') end select ! Langmuir number Options - call get_param(param_file, mdl, "LA_DEPTH_RATIO", LA_FracHBL, & - "The depth (normalized by BLD) to average Stokes drift over in "//& - "Langmuir number calculation, where La = sqrt(ust/Stokes).", & - units="nondim",default=0.04) - call get_param(param_file, mdl, "LA_MISALIGNMENT", LA_Misalignment, & +! call get_param(param_file, mdl, "LA_DEPTH_RATIO", CS%LA_FracHBL, & +! "The depth (normalized by BLD) to average Stokes drift over in "//& +! "Langmuir number calculation, where La = sqrt(ust/Stokes).", & +! units="nondim",default=0.04) + call get_param(param_file, mdl, "LA_MISALIGNMENT", CS%LA_Misalignment, & "Flag (logical) if using misalignment bt shear and waves in LA",& default=.false.) call get_param(param_file, mdl, "MIN_LANGMUIR", CS%La_min, & "A minimum value for all Langmuir numbers that is not physical, "//& "but is likely only encountered when the wind is very small and "//& - "therefore its effects should be mostly benign.",units="nondim",& + "therefore its effects should be mostly benign.", units="nondim", & default=0.05) ! Allocate and initialize @@ -423,37 +430,8 @@ subroutine MOM_wave_interface_init(time, G, GV, US, param_file, CS, diag ) CS%id_La_turb = register_diag_field('ocean_model','La_turbulent',& CS%diag%axesT1,Time,'Surface (turbulent) Langmuir number','nondim') - return end subroutine MOM_wave_interface_init -!> A 'lite' init subroutine to initialize a few inputs needed if using wave information -!! with the wind-speed dependent Stokes drift formulation of LF17 -subroutine MOM_wave_interface_init_lite(param_file) - type(param_file_type), intent(in) :: param_file !< Input parameter structure - character*(5), parameter :: NULL_STRING = "EMPTY" - character*(4), parameter :: LF17_STRING = "LF17" - character*(13) :: TMPSTRING1 - logical :: StatisticalWaves - - ! Langmuir number Options - call get_param(param_file, mdl, "LA_DEPTH_RATIO", LA_FracHBL, & - "The depth (normalized by BLD) to average Stokes drift over in "//& - "Langmuir number calculation, where La = sqrt(ust/Stokes).", & - units="nondim",default=0.04) - - ! Check if using LA_LI2016 - call get_param(param_file,mdl,"USE_LA_LI2016",StatisticalWaves, & - do_not_log=.true.,default=.false.) - if (StatisticalWaves) then - WaveMethod = LF17 - PI=4.0*atan(1.0) - else - WaveMethod = NULL_WaveMethod - end if - - return -end subroutine MOM_wave_interface_init_lite - !> Subroutine that handles updating of surface wave/Stokes drift related properties subroutine Update_Surface_Waves(G, GV, US, Day, dt, CS, forces) type(wave_parameters_CS), pointer :: CS !< Wave parameter Control structure @@ -470,12 +448,12 @@ subroutine Update_Surface_Waves(G, GV, US, Day, dt, CS, forces) ! Computing central time of time step Day_Center = Day + DT/2 - if (WaveMethod == TESTPROF) then + if (CS%WaveMethod == TESTPROF) then ! Do nothing - elseif (WaveMethod==SURFBANDS) then - if (DataSource==DATAOVR) then + elseif (CS%WaveMethod == SURFBANDS) then + if (CS%DataSource == DATAOVR) then call Surface_Bands_by_data_override(day_center, G, GV, US, CS) - elseif (DataSource==Coupler) then + elseif (CS%DataSource == COUPLER) then if (.not.present(FORCES)) then call MOM_error(FATAL,"The option SURFBAND = COUPLER can not be used with "//& "this driver. If you are using a coupled driver with a wave model then "//& @@ -503,7 +481,7 @@ subroutine Update_Surface_Waves(G, GV, US, Day, dt, CS, forces) enddo call pass_vector(CS%STKx0(:,:,b),CS%STKy0(:,:,b), G%Domain) enddo - elseif (DataSource==Input) then + elseif (CS%DataSource == INPUT) then do b=1,CS%NumBands do jj=G%jsd,G%jed do II=G%isdB,G%iedB @@ -519,7 +497,6 @@ subroutine Update_Surface_Waves(G, GV, US, Day, dt, CS, forces) endif endif - return end subroutine Update_Surface_Waves !> Constructs the Stokes Drift profile on the model grid based on @@ -542,6 +519,7 @@ subroutine Update_Stokes_Drift(G, GV, US, CS, h, ustar) real :: CMN_FAC ! A nondimensional factor [nondim] real :: WN ! Model wavenumber [Z-1 ~> m-1] real :: UStokes ! A Stokes drift velocity [L T-1 ~> m s-1] + real :: PI ! 3.1415926535... real :: La ! The local Langmuir number [nondim] integer :: ii, jj, kk, b, iim1, jjm1 @@ -550,8 +528,9 @@ subroutine Update_Stokes_Drift(G, GV, US, CS, h, ustar) ! 1. If Test Profile Option is chosen ! Computing mid-point value from surface value and decay wavelength - if (WaveMethod==TESTPROF) then - DecayScale = 4.*PI / TP_WVL !4pi + if (CS%WaveMethod==TESTPROF) then + PI = 4.0*atan(1.0) + DecayScale = 4.*PI / CS%TP_WVL !4pi do jj = G%jsd,G%jed do II = G%isdB,G%iedB IIm1 = max(1,II-1) @@ -561,7 +540,7 @@ subroutine Update_Stokes_Drift(G, GV, US, CS, h, ustar) Top = Bottom MidPoint = Bottom - GV%H_to_Z*0.25*(h(II,jj,kk)+h(IIm1,jj,kk)) Bottom = Bottom - GV%H_to_Z*0.5*(h(II,jj,kk)+h(IIm1,jj,kk)) - CS%Us_x(II,jj,kk) = TP_STKX0*exp(MidPoint*DecayScale) + CS%Us_x(II,jj,kk) = CS%TP_STKX0*exp(MidPoint*DecayScale) enddo enddo enddo @@ -574,14 +553,14 @@ subroutine Update_Stokes_Drift(G, GV, US, CS, h, ustar) Top = Bottom MidPoint = Bottom - GV%H_to_Z*0.25*(h(ii,JJ,kk)+h(ii,JJm1,kk)) Bottom = Bottom - GV%H_to_Z*0.5*(h(ii,JJ,kk)+h(ii,JJm1,kk)) - CS%Us_y(ii,JJ,kk) = TP_STKY0*exp(MidPoint*DecayScale) + CS%Us_y(ii,JJ,kk) = CS%TP_STKY0*exp(MidPoint*DecayScale) enddo enddo enddo ! 2. If Surface Bands is chosen ! In wavenumber mode compute integral for layer averaged Stokes drift. ! In frequency mode compuate value at midpoint. - elseif (WaveMethod==SURFBANDS) then + elseif (CS%WaveMethod==SURFBANDS) then CS%Us_x(:,:,:) = 0.0 CS%Us_y(:,:,:) = 0.0 CS%Us0_x(:,:) = 0.0 @@ -590,13 +569,16 @@ subroutine Update_Stokes_Drift(G, GV, US, CS, h, ustar) do jj = G%jsd,G%jed do II = G%isdB,G%iedB ! 1. First compute the surface Stokes drift - ! by integrating over the partitionas. + ! by integrating over the partitions. do b = 1,CS%NumBands - if (PartitionMode==0) then + if (CS%PartitionMode==0) then ! In wavenumber we are averaging over (small) level CMN_FAC = (1.0-exp(-one_cm*2.*CS%WaveNum_Cen(b))) / & (one_cm*2.*CS%WaveNum_Cen(b)) - elseif (PartitionMode==1) then + !### For accuracy and numerical stability rewrite this as: + ! CMN_FAC = one_minus_exp_x(2.*CS%WaveNum_Cen(b)*one_cm) + ! or maybe just take the limit of vanishing thickness, CMN_FAC = 1.0 + elseif (CS%PartitionMode==1) then ! In frequency we are not averaging over level and taking top CMN_FAC = 1.0 endif @@ -608,24 +590,27 @@ subroutine Update_Stokes_Drift(G, GV, US, CS, h, ustar) Top = Bottom IIm1 = max(II-1,1) level_thick = 0.5*GV%H_to_Z*(h(II,jj,kk)+h(IIm1,jj,kk)) - MidPoint = Bottom - 0.5*level_thick - Bottom = Bottom - level_thick + MidPoint = Top - 0.5*level_thick + Bottom = Top - level_thick ! -> Stokes drift in thin layers not averaged. if (level_thick>min_level_thick_avg) then do b = 1,CS%NumBands - if (PartitionMode==0) then - ! In wavenumber we are averaging over level + if (CS%PartitionMode==0) then + ! In wavenumber we are averaging over level CMN_FAC = (exp(Top*2.*CS%WaveNum_Cen(b))-exp(Bottom*2.*CS%WaveNum_Cen(b)))& / ((Top-Bottom)*(2.*CS%WaveNum_Cen(b))) - elseif (PartitionMode==1) then + !### For accuracy and numerical stability rewrite this as: + ! CMN_FAC = exp(2.*CS%WaveNum_Cen(b)*Top) * one_minus_exp_x(2.*CS%WaveNum_Cen(b)*level_thick) + elseif (CS%PartitionMode==1) then if (CS%StkLevelMode==0) then ! Take the value at the midpoint - CMN_FAC = exp(MidPoint*2.*(2.*PI*CS%Freq_Cen(b))**2 / CS%g_Earth) + CMN_FAC = exp(MidPoint * 2. * CS%Freq_Cen(b)**2 / CS%g_Earth) elseif (CS%StkLevelMode==1) then - ! Use a numerical integration and then - ! divide by layer thickness - WN = (2.*PI*CS%Freq_Cen(b))**2 / CS%g_Earth !bgr bug-fix missing g + ! Use a numerical integration and then divide by layer thickness + WN = CS%Freq_Cen(b)**2 / CS%g_Earth !bgr bug-fix missing g CMN_FAC = (exp(2.*WN*Top)-exp(2.*WN*Bottom)) / (2.*WN*(Top-Bottom)) + !### For accuracy and numerical stability rewrite this as: + ! CMN_FAC = exp(2.*WN*Top) * one_minus_exp_x(2.*WN*level_thick) endif endif CS%US_x(II,jj,kk) = CS%US_x(II,jj,kk) + CS%STKx0(II,jj,b)*CMN_FAC @@ -633,10 +618,10 @@ subroutine Update_Stokes_Drift(G, GV, US, CS, h, ustar) else ! Take the value at the midpoint do b = 1,CS%NumBands - if (PartitionMode==0) then - CMN_FAC = exp(MidPoint*2.*CS%WaveNum_Cen(b)) - elseif (PartitionMode==1) then - CMN_FAC = exp(MidPoint*2.*(2.*PI*CS%Freq_Cen(b))**2 / CS%g_Earth) + if (CS%PartitionMode==0) then + CMN_FAC = exp(MidPoint * 2. * CS%WaveNum_Cen(b)) + elseif (CS%PartitionMode==1) then + CMN_FAC = exp(MidPoint * 2. * CS%Freq_Cen(b)**2 / CS%g_Earth) endif CS%US_x(II,jj,kk) = CS%US_x(II,jj,kk) + CS%STKx0(II,jj,b)*CMN_FAC enddo @@ -649,11 +634,14 @@ subroutine Update_Stokes_Drift(G, GV, US, CS, h, ustar) do ii = G%isd,G%ied ! Compute the surface values. do b = 1,CS%NumBands - if (PartitionMode==0) then + if (CS%PartitionMode==0) then ! In wavenumber we are averaging over (small) level CMN_FAC = (1.0-exp(-one_cm*2.*CS%WaveNum_Cen(b))) / & (one_cm*2.*CS%WaveNum_Cen(b)) - elseif (PartitionMode==1) then + !### For accuracy and numerical stability rewrite this as: + ! CMN_FAC = one_minus_exp_x(2.*CS%WaveNum_Cen(b)*one_cm) + ! or maybe just take the limit of vanishing thickness, CMN_FAC = 1.0 + elseif (CS%PartitionMode==1) then ! In frequency we are not averaging over level and taking top CMN_FAC = 1.0 endif @@ -665,24 +653,27 @@ subroutine Update_Stokes_Drift(G, GV, US, CS, h, ustar) Top = Bottom JJm1 = max(JJ-1,1) level_thick = 0.5*GV%H_to_Z*(h(ii,JJ,kk)+h(ii,JJm1,kk)) - MidPoint = Bottom - 0.5*level_thick - Bottom = Bottom - level_thick + MidPoint = Top - 0.5*level_thick + Bottom = Top - level_thick ! -> Stokes drift in thin layers not averaged. if (level_thick>min_level_thick_avg) then do b = 1,CS%NumBands - if (PartitionMode==0) then + if (CS%PartitionMode==0) then ! In wavenumber we are averaging over level CMN_FAC = (exp(Top*2.*CS%WaveNum_Cen(b))-exp(Bottom*2.*CS%WaveNum_Cen(b)))& / ((Top-Bottom)*(2.*CS%WaveNum_Cen(b))) - elseif (PartitionMode==1) then + !### For accuracy and numerical stability rewrite this as: + ! CMN_FAC = exp(2.*CS%WaveNum_Cen(b)*Top) * one_minus_exp_x(2.*CS%WaveNum_Cen(b)*level_thick) + elseif (CS%PartitionMode==1) then if (CS%StkLevelMode==0) then ! Take the value at the midpoint - CMN_FAC = exp(MidPoint*2.*(2.*PI*CS%Freq_Cen(b))**2 / CS%g_Earth) + CMN_FAC = exp(MidPoint * 2. * CS%Freq_Cen(b)**2 / CS%g_Earth) elseif (CS%StkLevelMode==1) then - ! Use a numerical integration and then - ! divide by layer thickness - WN = (2.*PI*CS%Freq_Cen(b))**2 / CS%g_Earth !bgr bug-fix missing g + ! Use a numerical integration and then divide by layer thickness + WN = CS%Freq_Cen(b)**2 / CS%g_Earth !bgr bug-fix missing g CMN_FAC = (exp(2.*WN*Top)-exp(2.*WN*Bottom)) / (2.*WN*(Top-Bottom)) + !### For accuracy and numerical stability rewrite this as: + ! CMN_FAC = exp(2.*WN*Top) * one_minus_exp_x(2.*WN*level_thick) endif endif CS%US_y(ii,JJ,kk) = CS%US_y(ii,JJ,kk) + CS%STKy0(ii,JJ,b)*CMN_FAC @@ -690,10 +681,10 @@ subroutine Update_Stokes_Drift(G, GV, US, CS, h, ustar) else ! Take the value at the midpoint do b = 1,CS%NumBands - if (PartitionMode==0) then + if (CS%PartitionMode==0) then CMN_FAC = exp(MidPoint*2.*CS%WaveNum_Cen(b)) - elseif (PartitionMode==1) then - CMN_FAC = exp(MidPoint*2.*(2.*PI*CS%Freq_Cen(b))**2 / CS%g_Earth) + elseif (CS%PartitionMode==1) then + CMN_FAC = exp(MidPoint * 2. * CS%Freq_Cen(b)**2 / CS%g_Earth) endif CS%US_y(ii,JJ,kk) = CS%US_y(ii,JJ,kk) + CS%STKy0(ii,JJ,b)*CMN_FAC enddo @@ -701,16 +692,16 @@ subroutine Update_Stokes_Drift(G, GV, US, CS, h, ustar) enddo enddo enddo - elseif (WaveMethod==DHH85) then - if (.not.(StaticWaves .and. DHH85_is_set)) then + elseif (CS%WaveMethod == DHH85) then + if (.not.(CS%StaticWaves .and. CS%DHH85_is_set)) then do jj = G%jsd,G%jed do II = G%isdB,G%iedB bottom = 0.0 do kk = 1,GV%ke Top = Bottom IIm1 = max(II-1,1) - MidPoint = Bottom - GV%H_to_Z*0.25*(h(II,jj,kk)+h(IIm1,jj,kk)) - Bottom = Bottom - GV%H_to_Z*0.5*(h(II,jj,kk)+h(IIm1,jj,kk)) + MidPoint = Top - GV%H_to_Z*0.25*(h(II,jj,kk)+h(IIm1,jj,kk)) + Bottom = Top - GV%H_to_Z*0.5*(h(II,jj,kk)+h(IIm1,jj,kk)) !bgr note that this is using a u-point ii on h-point ustar ! this code has only been previous used for uniform ! grid cases. This needs fixed if DHH85 is used for non @@ -743,7 +734,7 @@ subroutine Update_Stokes_Drift(G, GV, US, CS, h, ustar) enddo enddo enddo - DHH85_is_set = .true. + CS%DHH85_is_set = .true. endif else! Keep this else, fallback to 0 Stokes drift do kk= 1,GV%ke @@ -786,6 +777,18 @@ subroutine Update_Stokes_Drift(G, GV, US, CS, h, ustar) end subroutine Update_Stokes_Drift +!> Return the value of (1 - exp(-x))/x, using an accurate expression for small values of x. +real function one_minus_exp_x(x) + real, intent(in) :: x !< The argument of the function ((1 - exp(-x))/x) [nondim] + real, parameter :: C1_6 = 1.0/6.0 + if (abs(x) <= 2.0e-5) then + ! The Taylor series expression for exp(-x) gives a more accurate expression for 64-bit reals. + one_minus_exp_x = 1.0 - x * (0.5 - C1_6*x) + else + one_minus_exp_x = (1.0 - exp(-x)) / x + endif +end function one_minus_exp_x + !> A subroutine to fill the Stokes drift from a NetCDF file !! using the data_override procedures. subroutine Surface_Bands_by_data_override(day_center, G, GV, US, CS) @@ -801,34 +804,35 @@ subroutine Surface_Bands_by_data_override(day_center, G, GV, US, CS) integer, dimension(4) :: sizes ! The sizes of the various dimensions of the variable. character(len=48) :: dim_name(4) ! The names of the dimensions of the variable. character(len=20) :: varname ! The name of an input variable for data override. + real :: PI ! 3.1415926535... integer :: ndims, b, i, j - if (.not.dataOverrideIsInitialized) then + if (.not.CS%DataOver_initialized) then call data_override_init(G%Domain) - dataOverrideIsInitialized = .true. + CS%DataOver_initialized = .true. - if (.not.file_exists(SurfBandFileName)) & - call MOM_error(FATAL, "MOM_wave_interface is unable to find file "//trim(SurfBandFileName)) + if (.not.file_exists(CS%SurfBandFileName)) & + call MOM_error(FATAL, "MOM_wave_interface is unable to find file "//trim(CS%SurfBandFileName)) ! Check if input has wavenumber or frequency variables. - if (field_exists(SurfBandFileName, 'wavenumber')) then + if (field_exists(CS%SurfBandFileName, 'wavenumber')) then ! Wavenumbers found, so this file uses the old method: - PartitionMode = 0 + CS%PartitionMode = 0 ! Read in number of wavenumber bands in file to set number to be read in - call get_var_sizes(SurfBandFileName, 'wavenumber', ndims, sizes, dim_names=dim_name) + call get_var_sizes(CS%SurfBandFileName, 'wavenumber', ndims, sizes, dim_names=dim_name) ! Allocating size of wavenumber bins CS%NUMBANDS = sizes(1) allocate( CS%WaveNum_Cen(CS%NUMBANDS) ) ; CS%WaveNum_Cen(:) = 0.0 ! Reading wavenumber bins - call read_variable(SurfBandFileName, dim_name(1), CS%WaveNum_Cen, scale=US%Z_to_m) + call read_variable(CS%SurfBandFileName, dim_name(1), CS%WaveNum_Cen, scale=US%Z_to_m) - elseif (field_exists(SurfBandFileName, 'frequency')) then + elseif (field_exists(CS%SurfBandFileName, 'frequency')) then ! Frequencies found, so this file uses the newer method: - PartitionMode = 1 + CS%PartitionMode = 1 ! Read in number of frequency bands in file to set number to be read in - call get_var_sizes(SurfBandFileName, 'frequency', ndims, sizes, dim_names=dim_name) + call get_var_sizes(CS%SurfBandFileName, 'frequency', ndims, sizes, dim_names=dim_name) ! Allocating size of frequency bins CS%NUMBANDS = sizes(1) @@ -837,15 +841,16 @@ subroutine Surface_Bands_by_data_override(day_center, G, GV, US, CS) allocate( CS%WaveNum_Cen(CS%NUMBANDS) ) ; CS%WaveNum_Cen(:) = 0.0 ! Reading frequencies - call read_variable(SurfBandFileName, dim_name(1), CS%Freq_Cen, scale=US%T_to_s) + PI = 4.0*atan(1.0) + call read_variable(CS%SurfBandFileName, dim_name(1), CS%Freq_Cen, scale=2.*PI*US%T_to_s) do B = 1,CS%NumBands - CS%WaveNum_Cen(b) = (2.*PI*CS%Freq_Cen(b))**2 / CS%g_Earth + CS%WaveNum_Cen(b) = CS%Freq_Cen(b)**2 / CS%g_Earth enddo else call MOM_error(FATAL, "error finding variable 'wavenumber' or 'frequency' in file "//& - trim(SurfBandFileName)//" in MOM_wave_interface.") + trim(CS%SurfBandFileName)//" in MOM_wave_interface.") endif if (.not.allocated(CS%STKx0)) then @@ -938,9 +943,9 @@ subroutine get_Langmuir_Number( LA, G, GV, US, HBL, ustar, i, j, & ! Compute averaging depth for Stokes drift (negative) - Dpt_LASL = min(-0.1*US%m_to_Z, -LA_FracHBL*HBL) + Dpt_LASL = min(-0.1*US%m_to_Z, -Waves%LA_FracHBL*HBL) - USE_MA = LA_Misalignment + USE_MA = Waves%LA_Misalignment if (present(Override_MA)) USE_MA = Override_MA ! If requesting to use misalignment in the Langmuir number compute the Shear Direction @@ -961,7 +966,7 @@ subroutine get_Langmuir_Number( LA, G, GV, US, HBL, ustar, i, j, & enddo endif - if (WaveMethod==TESTPROF) then + if (Waves%WaveMethod==TESTPROF) then do kk = 1,GV%ke US_H(kk) = 0.5*(WAVES%US_X(I,j,kk)+WAVES%US_X(I-1,j,kk)) VS_H(kk) = 0.5*(WAVES%US_Y(i,J,kk)+WAVES%US_Y(i,J-1,kk)) @@ -969,7 +974,7 @@ subroutine get_Langmuir_Number( LA, G, GV, US, HBL, ustar, i, j, & call Get_SL_Average_Prof( GV, Dpt_LASL, H, US_H, LA_STKx) call Get_SL_Average_Prof( GV, Dpt_LASL, H, VS_H, LA_STKy) LA_STK = sqrt(LA_STKX*LA_STKX+LA_STKY*LA_STKY) - elseif (WaveMethod==SURFBANDS) then + elseif (Waves%WaveMethod==SURFBANDS) then allocate(StkBand_X(WAVES%NumBands), StkBand_Y(WAVES%NumBands)) do bb = 1,WAVES%NumBands StkBand_X(bb) = 0.5*(WAVES%STKx0(I,j,bb)+WAVES%STKx0(I-1,j,bb)) @@ -979,7 +984,7 @@ subroutine get_Langmuir_Number( LA, G, GV, US, HBL, ustar, i, j, & call Get_SL_Average_Band(GV, Dpt_LASL, WAVES%NumBands, WAVES%WaveNum_Cen, StkBand_Y, LA_STKy ) LA_STK = sqrt(LA_STKX**2 + LA_STKY**2) deallocate(StkBand_X, StkBand_Y) - elseif (WaveMethod==DHH85) then + elseif (Waves%WaveMethod==DHH85) then ! Temporarily integrating profile rather than spectrum for simplicity do kk = 1,GV%ke US_H(kk) = 0.5*(WAVES%US_X(I,j,kk)+WAVES%US_X(I-1,j,kk)) @@ -988,16 +993,16 @@ subroutine get_Langmuir_Number( LA, G, GV, US, HBL, ustar, i, j, & call Get_SL_Average_Prof( GV, Dpt_LASL, H, US_H, LA_STKx) call Get_SL_Average_Prof( GV, Dpt_LASL, H, VS_H, LA_STKy) LA_STK = sqrt(LA_STKX**2 + LA_STKY**2) - elseif (WaveMethod==LF17) then - call get_StokesSL_LiFoxKemper(ustar, hbl*LA_FracHBL, GV, US, Waves, LA_STK, LA) - elseif (WaveMethod==Null_WaveMethod) then + elseif (Waves%WaveMethod==LF17) then + call get_StokesSL_LiFoxKemper(ustar, hbl*Waves%LA_FracHBL, GV, US, Waves, LA_STK, LA) + elseif (Waves%WaveMethod==Null_WaveMethod) then call MOM_error(FATAL, "Get_Langmuir_number called without defining a WaveMethod. "//& "Suggest to make sure USE_LT is set/overridden to False or "//& "choose a wave method (or set USE_LA_LI2016 to use statistical "//& "waves.") endif - if (.not.(WaveMethod==LF17)) then + if (.not.(Waves%WaveMethod==LF17)) then ! This is an arbitrary lower bound on Langmuir number. ! We shouldn't expect values lower than this, but ! there is also no good reason to cap it here other then @@ -1012,7 +1017,6 @@ subroutine get_Langmuir_Number( LA, G, GV, US, HBL, ustar, i, j, & LA = LA / sqrt(max(1.e-8, cos( WaveDirection - ShearDirection))) endif - return end subroutine get_Langmuir_Number !> Get SL averaged Stokes drift from Li/FK 17 method @@ -1061,11 +1065,18 @@ subroutine get_StokesSL_LiFoxKemper(ustar, hbl, GV, US, CS, UStokes_SL, LA) real :: z0 ! The boundary layer depth [Z ~> m] real :: z0i ! The inverse of theboundary layer depth [Z-1 ~> m-1] real :: r1, r2, r3, r4 ! Nondimensional ratios [nondim] + real :: r5 ! A single expression that combines r3 and r4 [nondim] + real :: root_2kz ! The square root of twice the peak wavenumber times the + ! boundary layer depth [nondim] real :: u10 ! The 10 m wind speed [L T-1 ~> m s-1] + real :: PI ! 3.1415926535... + PI = 4.0*atan(1.0) UStokes_sl = 0.0 LA = 1.e8 if (ustar > 0.0) then + ! This code should be revised to minimize the number of divisions and cancel out common factors. + ! Computing u10 based on u_star and COARE 3.5 relationships call ust_2_u10_coare3p5(ustar*sqrt(GV%Rho0/(1.225*US%kg_m3_to_R)), u10, GV, US, CS) ! surface Stokes drift @@ -1098,8 +1109,15 @@ subroutine get_StokesSL_LiFoxKemper(ustar, hbl, GV, US, CS, UStokes_SL, LA) ! surface layer z0 = abs(hbl) z0i = 1.0 / z0 - ! term 1 to 4 - r1 = ( 0.151 / kphil * z0i -0.84 ) * & + + ! Combining all of the expressions above gives kPhil as the following + ! where the first two lines are just a constant: + ! kPhil = ((0.176 * us_to_u10 * u19p5_to_u10) / & + ! (0.5*0.125 * r_loss * fm_into_fp * 0.877 * 0.0246**2)) * & + ! (US%T_to_s*US%m_s_to_L_T)**2 / (CS%g_Earth * u10**2) + + ! Terms 1 to 4, as written in the appendix of Li et al. (2017) + r1 = ( 0.151 / kphil * z0i - 0.84 ) * & ( 1.0 - exp(-2.0 * kphil * z0) ) r2 = -( 0.84 + 0.0591 / kphil * z0i ) * & sqrt( 2.0 * PI * kphil * z0 ) * & @@ -1110,6 +1128,30 @@ subroutine get_StokesSL_LiFoxKemper(ustar, hbl, GV, US, CS, UStokes_SL, LA) sqrt( 2.0 * PI * kstar * z0) * & erfc( sqrt( 2.0 * kstar * z0 ) ) UStokes_sl = UStokes * (0.715 + r1 + r2 + r3 + r4) + + ! The following is equivalent to the code above, but avoids singularities +! r1 = ( 0.302 - 1.68*kphil*z0 ) * one_minus_exp_x(2.0*kphil * z0) +! r3 = ( 0.1264 + 0.64*kphil*z0 ) * one_minus_exp_x(5.12*kphil * z0) +! root_2kz = sqrt(2.0 * kphil * z0) +! ! r2 = -( 0.84 + 0.0591*2.0 / (root_2kz**2) ) * sqrt(PI) * root_2kz * erfc( root_2kz ) +! ! r4 = ( 0.2 + 0.059125*2.0 / (root_2kz**2) ) * sqrt(PI)* root_2kz * erfc( 1.6 * root_2kz ) +! +! ! r5 = r2 + r4 (with a small correction to one coefficient to avoid a singularity when z0 = 0): +! ! The correction leads to <1% relative differences in (r2+r4) for root_2kz > 0.05, but without +! ! it the values of r2 + r4 are qualitatively wrong (>50% errors) for root_2kz < 0.0015 . +! ! It has been verified that these two expressions for r5 are the same to 6 decimal places for +! ! root_2kz between 1e-10 and 1e-3, but that the first one degrades for smaller values. +! if (root_2kz > 1e-3) then +! r5 = sqrt(PI) * (root_2kz * (-0.84 * erfc(root_2kz) + 0.2 * erfc(1.6*root_2kz)) + & +! 0.1182 * (erfc(1.6*root_2kz) - erfc(root_2kz)) / root_2kz) +! else +! ! It is more accurate to replace erf with the first two terms of its Taylor series +! ! erf(z) = (2/sqrt(pi)) * z * (1. - (1/3)*z**2 + (1/10)*z**4 - (1/42)*z**6 + ...) +! ! and then cancel or combine common terms and drop negligibly small terms. +! r5 = -0.64*sqrt(PI)*root_2kz + (-0.14184 + 1.0839648 * root_2kz**2) +! endif +! UStokes_sl = UStokes * (0.715 + ((r1 + r2) + r5)) + if (UStokes_sl /= 0.0) LA = sqrt(US%Z_to_L*ustar / UStokes_sl) endif @@ -1185,9 +1227,11 @@ subroutine Get_SL_Average_Band( GV, AvgDepth, NB, WaveNumbers, SurfStokes, Avera Average = Average + SurfStokes(BB) * & (1.-EXP(-abs(AvgDepth * 2.0 * WaveNumbers(BB)))) / & abs(AvgDepth * 2.0 * WaveNumbers(BB)) + + ! For accuracy when AvgDepth is small change the above to: + ! Average = Average + SurfStokes(BB) * one_minus_exp_x(abs(AvgDepth * 2.0 * WaveNumbers(BB))) enddo - return end subroutine Get_SL_Average_Band !> Compute the Stokes drift at a given depth @@ -1212,10 +1256,11 @@ subroutine DHH85_mid(GV, US, CS, zpt, UStokes) real :: u10 ! The wind speed for this spectrum [Z T-1 ~> m s-1] real :: wavespec ! The wave spectrum [L Z T ~> m2 s] real :: Stokes ! The Stokes displacement per cycle [L ~> m] + real :: PI ! 3.1415926535... integer :: Nomega ! The number of wavenumber bands integer :: OI - u10 = WaveWind*US%L_to_Z + u10 = CS%WaveWind*US%L_to_Z !/ omega_min = 0.1*US%T_to_s ! Hz @@ -1225,18 +1270,19 @@ subroutine DHH85_mid(GV, US, CS, zpt, UStokes) domega = (omega_max-omega_min)/real(NOmega) ! - if (WaveAgePeakFreq) then - omega_peak = CS%g_Earth / (WaveAge * u10) + if (CS%WaveAgePeakFreq) then + omega_peak = CS%g_Earth / (CS%WaveAge * u10) else - omega_peak = 2. * pi * 0.13 * CS%g_Earth / u10 + PI = 4.0*atan(1.0) + omega_peak = 2. * PI * 0.13 * CS%g_Earth / u10 endif !/ - Ann = 0.006 * WaveAge**(-0.55) + Ann = 0.006 * CS%WaveAge**(-0.55) Bnn = 1.0 - Snn = 0.08 * (1.0 + 4.0 * WaveAge**3) + Snn = 0.08 * (1.0 + 4.0 * CS%WaveAge**3) Cnn = 1.7 - if (WaveAge < 1.) then - Cnn = Cnn - 6.0*log10(WaveAge) + if (CS%WaveAge < 1.) then + Cnn = Cnn - 6.0*log10(CS%WaveAge) endif !/ UStokes = 0.0 @@ -1253,7 +1299,6 @@ subroutine DHH85_mid(GV, US, CS, zpt, UStokes) omega = omega + domega enddo - return end subroutine DHH85_mid !> Explicit solver for Stokes mixing. @@ -1419,7 +1464,7 @@ subroutine ust_2_u10_coare3p5(USTair, U10, GV, US, CS) exit endif enddo - return + end subroutine ust_2_u10_coare3p5 !> Clear pointers, deallocate memory @@ -1440,7 +1485,6 @@ subroutine Waves_end(CS) deallocate( CS ) - return end subroutine Waves_end !> \namespace mom_wave_interface From c29c0ca8b0cf3805fc549b209a0b1378ec680fdf Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 13 May 2021 15:08:51 -0400 Subject: [PATCH 071/112] Add variable and file names to an error message Made an error message in horiz_interp_and_extrap_tracer_record more informative and less cryptic by adding the variable and file names being sought. Also corrected or clarified other error messages in the same routine. All answers are bitwise identical, and no interface change. --- src/framework/MOM_horizontal_regridding.F90 | 17 +++++++++-------- 1 file changed, 9 insertions(+), 8 deletions(-) diff --git a/src/framework/MOM_horizontal_regridding.F90 b/src/framework/MOM_horizontal_regridding.F90 index 73fb1f0a41..d1a4b7f45d 100644 --- a/src/framework/MOM_horizontal_regridding.F90 +++ b/src/framework/MOM_horizontal_regridding.F90 @@ -259,7 +259,7 @@ subroutine horiz_interp_and_extrap_tracer_record(filename, varnam, conversion, character(len=*), intent(in) :: filename !< Path to file containing tracer to be !! interpolated. - character(len=*), intent(in) :: varnam !< Name of tracer in filee. + character(len=*), intent(in) :: varnam !< Name of tracer in file. real, intent(in) :: conversion !< Conversion factor for tracer. integer, intent(in) :: recnum !< Record number of tracer to be read. type(ocean_grid_type), intent(inout) :: G !< Grid object @@ -348,9 +348,10 @@ subroutine horiz_interp_and_extrap_tracer_record(filename, varnam, conversion, " in file "//trim(filename)//" in hinterp_extrap") rcode = NF90_INQUIRE_VARIABLE(ncid, varid, ndims=ndims, dimids=dims) - if (rcode /= 0) call MOM_error(FATAL,'error inquiring dimensions hinterp_extrap') - if (ndims < 3) call MOM_error(FATAL,"Variable "//trim(varnam)//" in file "// & - trim(filename)//" has too few dimensions.") + if (rcode /= 0) call MOM_error(FATAL, "Error inquiring about the dimensions of "//trim(varnam)//& + " in file "//trim(filename)//" in hinterp_extrap") + if (ndims < 3) call MOM_error(FATAL,"Variable "//trim(varnam)//" in file "//trim(filename)// & + " has too few dimensions to be read as a 3-d array.") rcode = NF90_INQUIRE_DIMENSION(ncid, dims(1), dim_name(1), len=id) if (rcode /= 0) call MOM_error(FATAL,"error reading dimension 1 data for "// & @@ -373,8 +374,8 @@ subroutine horiz_interp_and_extrap_tracer_record(filename, varnam, conversion, missing_value=0.0 rcode = NF90_GET_ATT(ncid, varid, "_FillValue", missing_value) - if (rcode /= 0) call MOM_error(FATAL,"error finding missing value for "//& - trim(varnam)//" in file "// trim(filename)//" in hinterp_extrap") + if (rcode /= 0) call MOM_error(FATAL,"error finding missing value for "//trim(varnam)//& + " in file "// trim(filename)//" in hinterp_extrap") rcode = NF90_GET_ATT(ncid, varid, "add_offset", add_offset) if (rcode /= 0) add_offset = 0.0 @@ -465,7 +466,7 @@ subroutine horiz_interp_and_extrap_tracer_record(filename, varnam, conversion, start(1) = is+G%HI%idg_offset ; start(2) = js+G%HI%jdg_offset ; start(3) = k count(1) = ie-is+1 ; count(2) = je-js+1; count(3) = 1 rcode = NF90_GET_VAR(ncid,varid, tr_in, start, count) - if (rcode /= 0) call MOM_error(FATAL,"hinterp_and_extract_from_Fie: "//& + if (rcode /= 0) call MOM_error(FATAL,"horiz_interp_and_extrap_tracer_record: "//& "error reading level "//trim(laynum)//" of variable "//& trim(varnam)//" in file "// trim(filename)) @@ -484,7 +485,7 @@ subroutine horiz_interp_and_extrap_tracer_record(filename, varnam, conversion, if (is_root_pe()) then start = 1 ; start(3) = k ; count(:) = 1 ; count(1) = id ; count(2) = jd rcode = NF90_GET_VAR(ncid,varid, tr_in, start, count) - if (rcode /= 0) call MOM_error(FATAL,"hinterp_and_extract_from_Fie: "//& + if (rcode /= 0) call MOM_error(FATAL,"horiz_interp_and_extrap_tracer_record: "//& "error reading level "//trim(laynum)//" of variable "//& trim(varnam)//" in file "// trim(filename)) From 2e221ebcdb12336f4d62f50e3198eea976494896 Mon Sep 17 00:00:00 2001 From: Olga Sergienko Date: Thu, 13 May 2021 15:25:53 -0400 Subject: [PATCH 072/112] corrected the momentum balance matrix --- src/ice_shelf/MOM_ice_shelf_dynamics.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 index 58ab020dc0..91c21237b4 100644 --- a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 +++ b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 @@ -2285,7 +2285,7 @@ subroutine matrix_diagonal(CS, G, US, float_cond, H_node, ice_visc, basal_trac, u_diagonal(Itgt,Jtgt) = u_diagonal(Itgt,Jtgt) + & 0.25 * ice_visc(i,j) * ((4*ux+2*vy) * Phi(2*(2*(jphi-1)+iphi)-1,2*(jq-1)+iq) + & - (uy+vy) * Phi(2*(2*(jphi-1)+iphi),2*(jq-1)+iq)) + (uy+vx) * Phi(2*(2*(jphi-1)+iphi),2*(jq-1)+iq)) if (float_cond(i,j) == 0) then uq = xquad(ilq) * xquad(jlq) From c5a45c65bdb411b764e479a3f3dbb9316190ec88 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 14 May 2021 14:27:41 -0400 Subject: [PATCH 073/112] +Avoid using field_exists in MOM_wave_interface Modified get_var_sizes so it does return ndims = -1 when querying for a variable that does not exist in a file (which was the intended behavior) and made use of this new and proper functionality to avoid using the function field_exists() in Surface_Bands_by_data_override(), because the fms_io implementation of field_exists incorrectly returns false when the variable being sought is also the name of a coordinate. Three minor bugs in wave diagnostics that Brandon Reichl had identified were also fixed, as was a test controlling an allocate statement. All answers are bitwise identical in cases that worked before, and the waves code is now working correctly with all IO calls going via MOM_io, rather than calling netCDF routines directly. --- src/framework/MOM_io.F90 | 11 ++++---- src/user/MOM_wave_interface.F90 | 49 +++++++++++++++++---------------- 2 files changed, 32 insertions(+), 28 deletions(-) diff --git a/src/framework/MOM_io.F90 b/src/framework/MOM_io.F90 index 029689285e..e9f2517efb 100644 --- a/src/framework/MOM_io.F90 +++ b/src/framework/MOM_io.F90 @@ -647,7 +647,7 @@ subroutine get_var_sizes(filename, varname, ndims, sizes, match_case, caller, al do n=2,nval ; sizes(n-1) = size_msg(n) ; enddo deallocate(size_msg) - if (present(dim_names)) then + if (present(dim_names) .and. (ndims > 0)) then nval = min(ndims, size(dim_names)) call broadcast(dim_names(1:nval), len(dim_names(1)), blocking=.true.) endif @@ -655,7 +655,8 @@ subroutine get_var_sizes(filename, varname, ndims, sizes, match_case, caller, al end subroutine get_var_sizes -!> read_var_sizes returns the number and size of dimensions associate with a variable in a file. +!> read_var_sizes returns the number and size of dimensions associated with a variable in a file. +!! If the variable is not in the file the returned sizes are all 0 and ndims is -1. !! Every processor for which this is called does the reading. subroutine read_var_sizes(filename, varname, ndims, sizes, match_case, caller, dim_names, ncid_in) character(len=*), intent(in) :: filename !< Name of the file to read, used here in messages @@ -675,7 +676,7 @@ subroutine read_var_sizes(filename, varname, ndims, sizes, match_case, caller, d character(len=256) :: hdr, dimname integer, allocatable :: dimids(:) integer :: varid, ncid, n, status - logical :: success + logical :: success, found hdr = "get_var_size: " ; if (present(caller)) hdr = trim(hdr)//": " sizes(:) = 0 ; ndims = -1 @@ -687,8 +688,8 @@ subroutine read_var_sizes(filename, varname, ndims, sizes, match_case, caller, d endif ! Get the dimension sizes of the variable varname. - call get_varid(varname, ncid, filename, varid, match_case=match_case) - if (varid < 0) return + call get_varid(varname, ncid, filename, varid, match_case=match_case, found=found) + if (.not.found) return status = NF90_inquire_variable(ncid, varid, ndims=ndims) if (status /= NF90_NOERR) then diff --git a/src/user/MOM_wave_interface.F90 b/src/user/MOM_wave_interface.F90 index 082625f65e..46cfd86299 100644 --- a/src/user/MOM_wave_interface.F90 +++ b/src/user/MOM_wave_interface.F90 @@ -12,7 +12,7 @@ module MOM_wave_interface use MOM_file_parser, only : get_param, log_version, param_file_type use MOM_forcing_type, only : mech_forcing use MOM_grid, only : ocean_grid_type -use MOM_io, only : file_exists, field_exists, get_var_sizes, read_variable +use MOM_io, only : file_exists, get_var_sizes, read_variable use MOM_safe_alloc, only : safe_alloc_ptr use MOM_time_manager, only : time_type, operator(+), operator(/) use MOM_unit_scaling, only : unit_scale_type @@ -403,13 +403,13 @@ subroutine MOM_wave_interface_init(time, G, GV, US, param_file, CS, diag ) ! Initialize Wave related outputs CS%id_surfacestokes_y = register_diag_field('ocean_model','surface_stokes_y', & - CS%diag%axesCu1,Time,'Surface Stokes drift (y)','m s-1') + CS%diag%axesCv1,Time,'Surface Stokes drift (y)','m s-1') CS%id_surfacestokes_x = register_diag_field('ocean_model','surface_stokes_x', & - CS%diag%axesCv1,Time,'Surface Stokes drift (x)','m s-1') + CS%diag%axesCu1,Time,'Surface Stokes drift (x)','m s-1') CS%id_3dstokes_y = register_diag_field('ocean_model','3d_stokes_y', & CS%diag%axesCvL,Time,'3d Stokes drift (y)','m s-1') CS%id_3dstokes_x = register_diag_field('ocean_model','3d_stokes_x', & - CS%diag%axesCuL,Time,'3d Stokes drift (y)','m s-1') + CS%diag%axesCuL,Time,'3d Stokes drift (x)','m s-1') CS%id_La_turb = register_diag_field('ocean_model','La_turbulent',& CS%diag%axesT1,Time,'Surface (turbulent) Langmuir number','nondim') @@ -786,6 +786,7 @@ subroutine Surface_Bands_by_data_override(day_center, G, GV, US, CS) integer, dimension(4) :: sizes ! The sizes of the various dimensions of the variable. character(len=48) :: dim_name(4) ! The names of the dimensions of the variable. character(len=20) :: varname ! The name of an input variable for data override. + logical :: wavenumber_exists integer :: ndims, b, i, j if (.not.dataOverrideIsInitialized) then @@ -796,30 +797,36 @@ subroutine Surface_Bands_by_data_override(day_center, G, GV, US, CS) call MOM_error(FATAL, "MOM_wave_interface is unable to find file "//trim(SurfBandFileName)) ! Check if input has wavenumber or frequency variables. - if (field_exists(SurfBandFileName, 'wavenumber')) then + + ! Read the number of wavenumber bands in the file, if the variable 'wavenumber' exists. + call get_var_sizes(SurfBandFileName, 'wavenumber', ndims, sizes, dim_names=dim_name) + wavenumber_exists = (ndims > -1) + + if (.not.wavenumber_exists) then + ! Read the number of frequency bands in the file, if the variable 'frequency' exists. + call get_var_sizes(SurfBandFileName, 'frequency', ndims, sizes, dim_names=dim_name) + if (ndims < 0) & + call MOM_error(FATAL, "error finding variable 'wavenumber' or 'frequency' in file "//& + trim(SurfBandFileName)//" in MOM_wave_interface.") + endif + + CS%NUMBANDS = sizes(1) + ! Allocate the wavenumber bins + allocate( CS%WaveNum_Cen(CS%NUMBANDS) ) ; CS%WaveNum_Cen(:) = 0.0 + + if (wavenumber_exists) then ! Wavenumbers found, so this file uses the old method: PartitionMode = 0 - ! Read in number of wavenumber bands in file to set number to be read in - call get_var_sizes(SurfBandFileName, 'wavenumber', ndims, sizes, dim_names=dim_name) - - ! Allocating size of wavenumber bins - CS%NUMBANDS = sizes(1) - allocate( CS%WaveNum_Cen(CS%NUMBANDS) ) ; CS%WaveNum_Cen(:) = 0.0 ! Reading wavenumber bins call read_variable(SurfBandFileName, dim_name(1), CS%WaveNum_Cen, scale=US%Z_to_m) - elseif (field_exists(SurfBandFileName, 'frequency')) then + else ! Frequencies found, so this file uses the newer method: PartitionMode = 1 - ! Read in number of frequency bands in file to set number to be read in - call get_var_sizes(SurfBandFileName, 'frequency', ndims, sizes, dim_names=dim_name) - ! Allocating size of frequency bins - CS%NUMBANDS = sizes(1) + ! Allocate the frequency bins allocate( CS%Freq_Cen(CS%NUMBANDS) ) ; CS%Freq_Cen(:) = 0.0 - ! Allocating size of wavenumber bins - allocate( CS%WaveNum_Cen(CS%NUMBANDS) ) ; CS%WaveNum_Cen(:) = 0.0 ! Reading frequencies call read_variable(SurfBandFileName, dim_name(1), CS%Freq_Cen) !, scale=US%T_to_s) @@ -827,16 +834,12 @@ subroutine Surface_Bands_by_data_override(day_center, G, GV, US, CS) do B = 1,CS%NumBands CS%WaveNum_Cen(b) = (2.*PI*CS%Freq_Cen(b)*US%T_to_s)**2 / (US%L_to_Z**2*GV%g_Earth) enddo - - else - call MOM_error(FATAL, "error finding variable 'wavenumber' or 'frequency' in file "//& - trim(SurfBandFileName)//" in MOM_wave_interface.") endif if (.not.allocated(CS%STKx0)) then allocate( CS%STKx0(G%isdB:G%iedB,G%jsd:G%jed,CS%NUMBANDS) ) ; CS%STKx0(:,:,:) = 0.0 endif - if (.not.allocated(CS%STKx0)) then + if (.not.allocated(CS%STKy0)) then allocate( CS%STKy0(G%isd:G%ied,G%jsdB:G%jedB,CS%NUMBANDS) ) ; CS%STKy0(:,:,:) = 0.0 endif endif From f1b2320131bc17886abcddd07ae4507867b39210 Mon Sep 17 00:00:00 2001 From: Hemant Khatri Date: Mon, 17 May 2021 18:32:02 -0400 Subject: [PATCH 074/112] Added description of diagnostics arrays and corrected units in comments --- src/core/MOM_CoriolisAdv.F90 | 4 ++-- src/core/MOM_dynamics_split_RK2.F90 | 13 ++++++++----- src/diagnostics/MOM_diagnostics.F90 | 4 ++-- src/parameterizations/lateral/MOM_hor_visc.F90 | 8 ++++---- .../vertical/MOM_vert_friction.F90 | 4 ++-- 5 files changed, 18 insertions(+), 15 deletions(-) diff --git a/src/core/MOM_CoriolisAdv.F90 b/src/core/MOM_CoriolisAdv.F90 index 7ba9453a3f..23a2a98325 100644 --- a/src/core/MOM_CoriolisAdv.F90 +++ b/src/core/MOM_CoriolisAdv.F90 @@ -233,8 +233,8 @@ subroutine CorAdCalc(u, v, h, uh, vh, CAu, CAv, OBC, AD, G, GV, US, CS) ! The code is retained for degugging purposes in the future. ! Diagnostics for thickness multiplied momentum budget terms - real, allocatable, dimension(:,:,:) :: h_gKEu, h_rvxv ! [L2 T-2 ~> m2 s-2]. - real, allocatable, dimension(:,:,:) :: h_gKEv, h_rvxu ! [L2 T-2 ~> m2 s-2]. + real, allocatable, dimension(:,:,:) :: h_gKEu, h_rvxv ! [H L T-2 ~> m2 s-2]. + real, allocatable, dimension(:,:,:) :: h_gKEv, h_rvxu ! [H L T-2 ~> m2 s-2]. ! Diagnostics for depth-integrated momentum budget terms real, dimension(SZIB_(G),SZJ_(G)) :: intz_gKEu_2d, intz_rvxv_2d ! [L2 T-2 ~> m2 s-2]. diff --git a/src/core/MOM_dynamics_split_RK2.F90 b/src/core/MOM_dynamics_split_RK2.F90 index 014ac76e0c..5a62523949 100644 --- a/src/core/MOM_dynamics_split_RK2.F90 +++ b/src/core/MOM_dynamics_split_RK2.F90 @@ -342,14 +342,17 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, Time_local, dt, forces, p_s hf_CAu_2d, hf_CAv_2d, & ! Depth integeral of hf_CAu, hf_CAv [L T-2 ~> m s-2]. hf_u_BT_accel_2d, hf_v_BT_accel_2d ! Depth integeral of hf_u_BT_accel, hf_v_BT_accel - real, allocatable, dimension(:,:,:) :: h_PFu, h_CAu, h_u_BT_accel ! [L2 T-2 ~> m2 s-2]. - real, allocatable, dimension(:,:,:) :: h_PFv, h_CAv, h_v_BT_accel ! [L2 T-2 ~> m2 s-2]. + ! Diagnostics for thickness x momentum budget terms + real, allocatable, dimension(:,:,:) :: & + h_PFu, h_PFv, & ! Pressure force accel. x thickness [H L T-2 ~> m2 s-2]. + h_CAu, h_CAv, & ! Coriolis force accel. x thickness [H L T-2 ~> m2 s-2]. + h_u_BT_accel, h_v_BT_accel ! barotropic correction accel. x thickness [H L T-2 ~> m2 s-2]. + ! Dignostics for layer-sum of thickness x momentum budget terms real, dimension(SZIB_(G),SZJ_(G)) :: & - intz_PFu_2d, intz_CAu_2d, intz_u_BT_accel_2d ! [L2 T-2 ~> m2 s-2]. + intz_PFu_2d, intz_CAu_2d, intz_u_BT_accel_2d ! [H L T-2 ~> m2 s-2]. real, dimension(SZI_(G),SZJB_(G)) :: & - intz_PFv_2d, intz_CAv_2d, intz_v_BT_accel_2d ! [L2 T-2 ~> m2 s-2]. - + intz_PFv_2d, intz_CAv_2d, intz_v_BT_accel_2d ! [H L T-2 ~> m2 s-2]. real :: dt_pred ! The time step for the predictor part of the baroclinic time stepping [T ~> s]. diff --git a/src/diagnostics/MOM_diagnostics.F90 b/src/diagnostics/MOM_diagnostics.F90 index 7f88b1d448..2f954625e6 100644 --- a/src/diagnostics/MOM_diagnostics.F90 +++ b/src/diagnostics/MOM_diagnostics.F90 @@ -249,8 +249,8 @@ subroutine calculate_diagnostic_fields(u, v, h, uh, vh, tv, ADp, CDp, p_surf, & real, allocatable, dimension(:,:) :: & hf_du_dt_2d, hf_dv_dt_2d ! z integeral of hf_du_dt, hf_dv_dt [L T-2 ~> m s-2]. - real, allocatable, dimension(:,:,:) :: h_du_dt ! h x dudt [L2 T-2 ~> m2 s-2] - real, allocatable, dimension(:,:,:) :: h_dv_dt ! h x dvdt [L2 T-2 ~> m2 s-2] + real, allocatable, dimension(:,:,:) :: h_du_dt ! h x dudt [H L T-2 ~> m2 s-2] + real, allocatable, dimension(:,:,:) :: h_dv_dt ! h x dvdt [H L T-2 ~> m2 s-2] ! tmp array for surface properties real :: surface_field(SZI_(G),SZJ_(G)) diff --git a/src/parameterizations/lateral/MOM_hor_visc.F90 b/src/parameterizations/lateral/MOM_hor_visc.F90 index f8a966ceb6..eef2cd028b 100644 --- a/src/parameterizations/lateral/MOM_hor_visc.F90 +++ b/src/parameterizations/lateral/MOM_hor_visc.F90 @@ -278,8 +278,8 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, grad_d2vel_mag_h, & ! Magnitude of the Laplacian of the velocity vector, squared [L-2 T-2 ~> m-2 s-2] boundary_mask_h ! A mask that zeroes out cells with at least one land edge [nondim] - real, allocatable, dimension(:,:,:) :: h_diffu ! h x diffu [L2 T-2 ~> m2 s-2] - real, allocatable, dimension(:,:,:) :: h_diffv ! h x diffv [L2 T-2 ~> m2 s-2] + real, allocatable, dimension(:,:,:) :: h_diffu ! h x diffu [H L T-2 ~> m2 s-2] + real, allocatable, dimension(:,:,:) :: h_diffv ! h x diffv [H L T-2 ~> m2 s-2] real, dimension(SZIB_(G),SZJB_(G)) :: & dvdx, dudy, & ! components in the shearing strain [T-1 ~> s-1] @@ -389,11 +389,11 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, real, dimension(SZIB_(G),SZJ_(G)) :: & hf_diffu_2d, & ! Depth sum of hf_diffu, hf_diffv [L T-2 ~> m s-2] - intz_diffu_2d ! Depth-integral of diffu [L2 T-2 ~> m2 s-2] + intz_diffu_2d ! Depth-integral of diffu [H L T-2 ~> m2 s-2] real, dimension(SZI_(G),SZJB_(G)) :: & hf_diffv_2d, & ! Depth sum of hf_diffu, hf_diffv [L T-2 ~> m s-2] - intz_diffv_2d ! Depth-integral of diffv [L2 T-2 ~> m2 s-2] + intz_diffv_2d ! Depth-integral of diffv [H L T-2 ~> m2 s-2] is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB diff --git a/src/parameterizations/vertical/MOM_vert_friction.F90 b/src/parameterizations/vertical/MOM_vert_friction.F90 index 5845e3c727..8f541a9538 100644 --- a/src/parameterizations/vertical/MOM_vert_friction.F90 +++ b/src/parameterizations/vertical/MOM_vert_friction.F90 @@ -214,8 +214,8 @@ subroutine vertvisc(u, v, h, forces, visc, dt, OBC, ADp, CDp, G, GV, US, CS, & real, allocatable, dimension(:,:) :: hf_du_dt_visc_2d ! Depth sum of hf_du_dt_visc [L T-2 ~> m s-2] real, allocatable, dimension(:,:) :: hf_dv_dt_visc_2d ! Depth sum of hf_dv_dt_visc [L T-2 ~> m s-2] - real, allocatable, dimension(:,:,:) :: h_du_dt_visc ! h x du_dt_visc [L2 T-2 ~> m2 s-2] - real, allocatable, dimension(:,:,:) :: h_dv_dt_visc ! h x h_dv_dt_visc [L2 T-2 ~> m2 s-2] + real, allocatable, dimension(:,:,:) :: h_du_dt_visc ! h x du_dt_visc [H L T-2 ~> m2 s-2] + real, allocatable, dimension(:,:,:) :: h_dv_dt_visc ! h x dv_dt_visc [H L T-2 ~> m2 s-2] logical :: do_i(SZIB_(G)) logical :: DoStokesMixing From aa32127311e6893a118f1ec01e240e9cdc97a6fc Mon Sep 17 00:00:00 2001 From: Hemant Khatri Date: Mon, 17 May 2021 18:50:38 -0400 Subject: [PATCH 075/112] Comments about new diagnostics --- src/core/MOM_CoriolisAdv.F90 | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/core/MOM_CoriolisAdv.F90 b/src/core/MOM_CoriolisAdv.F90 index 23a2a98325..231b6ed058 100644 --- a/src/core/MOM_CoriolisAdv.F90 +++ b/src/core/MOM_CoriolisAdv.F90 @@ -233,12 +233,12 @@ subroutine CorAdCalc(u, v, h, uh, vh, CAu, CAv, OBC, AD, G, GV, US, CS) ! The code is retained for degugging purposes in the future. ! Diagnostics for thickness multiplied momentum budget terms - real, allocatable, dimension(:,:,:) :: h_gKEu, h_rvxv ! [H L T-2 ~> m2 s-2]. - real, allocatable, dimension(:,:,:) :: h_gKEv, h_rvxu ! [H L T-2 ~> m2 s-2]. + real, allocatable, dimension(:,:,:) :: h_gKEu, h_gKEv ! h x gKEu, h x gKEv [H L T-2 ~> m2 s-2]. + real, allocatable, dimension(:,:,:) :: h_rvxv, h_rvxu ! h x rvxv, h x rvxu [H L T-2 ~> m2 s-2]. ! Diagnostics for depth-integrated momentum budget terms - real, dimension(SZIB_(G),SZJ_(G)) :: intz_gKEu_2d, intz_rvxv_2d ! [L2 T-2 ~> m2 s-2]. - real, dimension(SZI_(G),SZJB_(G)) :: intz_gKEv_2d, intz_rvxu_2d ! [L2 T-2 ~> m2 s-2]. + real, dimension(SZIB_(G),SZJ_(G)) :: intz_gKEu_2d, intz_rvxv_2d ! [H L T-2 ~> m2 s-2]. + real, dimension(SZI_(G),SZJB_(G)) :: intz_gKEv_2d, intz_rvxu_2d ! [H L T-2 ~> m2 s-2]. ! To work, the following fields must be set outside of the usual ! is to ie range before this subroutine is called: From bc7266621863c1c687a264d089002024fdbb1a43 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 19 May 2021 10:22:14 -0400 Subject: [PATCH 076/112] Corrected the syntax of a Doxygen comment --- src/user/MOM_wave_interface.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/user/MOM_wave_interface.F90 b/src/user/MOM_wave_interface.F90 index 336c7d3bde..913b26d14b 100644 --- a/src/user/MOM_wave_interface.F90 +++ b/src/user/MOM_wave_interface.F90 @@ -152,7 +152,7 @@ module MOM_wave_interface real :: TP_WVL !< Test profile wavelength [Z ~> m] ! Options for use with the Donelan et al., 1985 (DHH85) spectrum - logical :: WaveAgePeakFreq ! Flag to use wave age to determine the peak frequency with DHH85 + logical :: WaveAgePeakFreq !< Flag to use wave age to determine the peak frequency with DHH85 logical :: StaticWaves !< Flag to disable updating DHH85 Stokes drift logical :: DHH85_is_set !< The if the wave properties have been set when WaveMethod = DHH85. real :: WaveAge !< The fixed wave age used with the DHH85 spectrum [nondim] From e01bb9f6377a228d12b836e81fd11539c15bd931 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 19 May 2021 14:11:22 -0400 Subject: [PATCH 077/112] Call variable_att_exists before get_variable_att Added variable_att_exists calls before two calls to get_variable_attribute in the FMS2 version of get_file_fields so that runs do not crash if there are variables being read that do not have a long_name or units attribute. All answers are bitwise identical in cases that did not crash. --- config_src/infra/FMS2/MOM_io_infra.F90 | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/config_src/infra/FMS2/MOM_io_infra.F90 b/config_src/infra/FMS2/MOM_io_infra.F90 index 1f2e949f0c..6f08065f57 100644 --- a/config_src/infra/FMS2/MOM_io_infra.F90 +++ b/config_src/infra/FMS2/MOM_io_infra.F90 @@ -498,10 +498,12 @@ subroutine get_file_fields(IO_handle, fields) do i=1,nvar fields(i)%name = trim(var_names(i)) longname = "" - call get_variable_attribute(IO_handle%fileobj, var_names(i), 'long_name', longname) + if (variable_att_exists(IO_handle%fileobj, var_names(i), "long_name")) & + call get_variable_attribute(IO_handle%fileobj, var_names(i), "long_name", longname) fields(i)%longname = trim(longname) units = "" - call get_variable_attribute(IO_handle%fileobj, var_names(i), 'units', units) + if (variable_att_exists(IO_handle%fileobj, var_names(i), "units")) & + call get_variable_attribute(IO_handle%fileobj, var_names(i), "units", units) fields(i)%units = trim(units) fields(i)%valid_chksum = variable_att_exists(IO_handle%fileobj, var_names(i), "checksum") From 6581b2f5907552aabcb637f5d9774be55d6533a0 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 20 May 2021 14:55:23 -0400 Subject: [PATCH 078/112] Response to reviews of MOM6 PR #1404 Corrected typos in comments, and removed unnecessary commented out code as noted by Brandon Reichl in his review of MOM6 dev/gfdl PR# 1404. All answers are bitwise identical. --- config_src/drivers/FMS_cap/ocean_model_MOM.F90 | 2 +- config_src/drivers/solo_driver/MOM_driver.F90 | 2 +- src/user/MOM_wave_interface.F90 | 16 ++++++---------- 3 files changed, 8 insertions(+), 12 deletions(-) diff --git a/config_src/drivers/FMS_cap/ocean_model_MOM.F90 b/config_src/drivers/FMS_cap/ocean_model_MOM.F90 index fec3bbf1d3..c3e13329f2 100644 --- a/config_src/drivers/FMS_cap/ocean_model_MOM.F90 +++ b/config_src/drivers/FMS_cap/ocean_model_MOM.F90 @@ -383,7 +383,7 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, wind_stagger, gas call get_param(param_file, mdl, "USE_WAVES", OS%Use_Waves, & "If true, enables surface wave modules.", default=.false.) ! MOM_wave_interface_init is called regardless of the value of USE_WAVES because - ! it also initCSializes statistical waves. + ! it also initializes statistical waves. call MOM_wave_interface_init(OS%Time, OS%grid, OS%GV, OS%US, param_file, OS%Waves, OS%diag) call initialize_ocean_public_type(OS%grid%Domain, Ocean_sfc, OS%diag, & diff --git a/config_src/drivers/solo_driver/MOM_driver.F90 b/config_src/drivers/solo_driver/MOM_driver.F90 index 7c14820e31..ebb953be93 100644 --- a/config_src/drivers/solo_driver/MOM_driver.F90 +++ b/config_src/drivers/solo_driver/MOM_driver.F90 @@ -332,7 +332,7 @@ program MOM_main call get_param(param_file,mod_name, "USE_WAVES", Use_Waves, & "If true, enables surface wave modules.",default=.false.) ! MOM_wave_interface_init is called regardless of the value of USE_WAVES because - ! it also initCSializes statistical waves. + ! it also initializes statistical waves. call MOM_wave_interface_init(Time, grid, GV, US, param_file, Waves_CSp, diag) segment_start_time = Time diff --git a/src/user/MOM_wave_interface.F90 b/src/user/MOM_wave_interface.F90 index 913b26d14b..e1e4ab0f77 100644 --- a/src/user/MOM_wave_interface.F90 +++ b/src/user/MOM_wave_interface.F90 @@ -120,7 +120,7 @@ module MOM_wave_interface real, allocatable, dimension(:) :: & PrescribedSurfStkY !< Surface Stokes drift if prescribed [L T-1 ~> m s-1] real, allocatable, dimension(:,:) :: & - La_SL,& !< SL Langmuir number (directionality factored later) + La_SL, & !< SL Langmuir number (directionality factored later) !! Horizontal -> H points La_Turb !< Aligned Turbulent Langmuir number [nondim] !! Horizontal -> H points @@ -382,13 +382,9 @@ subroutine MOM_wave_interface_init(time, G, GV, US, param_file, CS, diag ) call MOM_error(FATAL,'Check WAVE_METHOD.') end select - ! Langmuir number Options -! call get_param(param_file, mdl, "LA_DEPTH_RATIO", CS%LA_FracHBL, & -! "The depth (normalized by BLD) to average Stokes drift over in "//& -! "Langmuir number calculation, where La = sqrt(ust/Stokes).", & -! units="nondim",default=0.04) - call get_param(param_file, mdl, "LA_MISALIGNMENT", CS%LA_Misalignment, & - "Flag (logical) if using misalignment bt shear and waves in LA",& + ! Langmuir number Options (Note that CS%LA_FracHBL is set above.) + call get_param(param_file, mdl, "LA_MISALIGNMENT", CS%LA_Misalignment, & + "Flag (logical) if using misalignment bt shear and waves in LA", & default=.false.) call get_param(param_file, mdl, "MIN_LANGMUIR", CS%La_min, & "A minimum value for all Langmuir numbers that is not physical, "//& @@ -427,7 +423,7 @@ subroutine MOM_wave_interface_init(time, G, GV, US, param_file, CS, diag ) CS%diag%axesCvL,Time,'3d Stokes drift (y)', 'm s-1', conversion=US%L_T_to_m_s) CS%id_3dstokes_x = register_diag_field('ocean_model','3d_stokes_x', & CS%diag%axesCuL,Time,'3d Stokes drift (x)', 'm s-1', conversion=US%L_T_to_m_s) - CS%id_La_turb = register_diag_field('ocean_model','La_turbulent',& + CS%id_La_turb = register_diag_field('ocean_model','La_turbulent', & CS%diag%axesT1,Time,'Surface (turbulent) Langmuir number','nondim') end subroutine MOM_wave_interface_init @@ -437,7 +433,7 @@ subroutine Update_Surface_Waves(G, GV, US, Day, dt, CS, forces) type(wave_parameters_CS), pointer :: CS !< Wave parameter Control structure type(ocean_grid_type), intent(inout) :: G !< Grid structure type(verticalGrid_type), intent(in) :: GV !< 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 type(time_type), intent(in) :: Day !< Current model time type(time_type), intent(in) :: dt !< Timestep as a time-type type(mech_forcing), intent(in), optional :: forces !< MOM_forcing_type From 5106dd2a8a3956f3e05678f6b50e8e596018cd3d Mon Sep 17 00:00:00 2001 From: Kate Hedstrom Date: Thu, 20 May 2021 20:59:55 -0800 Subject: [PATCH 079/112] Trying to fix Kelvin wave boundary condition. - Better, but doesn't quite pass RESCALE tests. --- src/user/Kelvin_initialization.F90 | 13 ++++--------- 1 file changed, 4 insertions(+), 9 deletions(-) diff --git a/src/user/Kelvin_initialization.F90 b/src/user/Kelvin_initialization.F90 index b93007647d..d7cee50c99 100644 --- a/src/user/Kelvin_initialization.F90 +++ b/src/user/Kelvin_initialization.F90 @@ -209,15 +209,10 @@ subroutine Kelvin_set_OBC_data(OBC, CS, G, GV, US, h, Time) omega = 2.0 * PI / (12.42 * 3600.0) ! M2 Tide period val1 = US%m_to_Z * sin(omega * time_sec) else - N0 = US%L_to_m*US%s_to_T * sqrt((CS%rho_range / CS%rho_0) * GV%g_Earth * (US%m_to_Z * CS%H0)) + N0 = US%L_to_m*US%s_to_T * sqrt((CS%rho_range / CS%rho_0) * (GV%g_Earth / CS%H0)) + lambda = PI * CS%mode * CS%F_0 / (CS%H0 * N0) ! Two wavelengths in domain - plx = 4.0 * PI / G%len_lon - pmz = PI * CS%mode / CS%H0 - lambda = pmz * CS%F_0 / N0 - omega = CS%F_0 * plx / lambda - - ! lambda = PI * CS%mode * CS%F_0 / (CS%H0 * N0) - ! omega = (4.0 * CS%H0 * N0) / (CS%mode * G%len_lon) + omega = (4.0 * CS%H0 * N0) / (CS%mode * G%len_lon) endif sina = sin(CS%coast_angle) @@ -261,7 +256,7 @@ subroutine Kelvin_set_OBC_data(OBC, CS, G, GV, US, h, Time) enddo endif else - ! Not rotated yet + ! Baroclinic, not rotated yet segment%eta(I,j) = 0.0 segment%normal_vel_bt(I,j) = 0.0 if (segment%nudged) then From e8415bd97f755e514f65b9a42a51ade945ac544f Mon Sep 17 00:00:00 2001 From: Raphael Dussin Date: Fri, 21 May 2021 11:32:21 -0400 Subject: [PATCH 080/112] add reference lat + fix scale --- src/initialization/MOM_shared_initialization.F90 | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/src/initialization/MOM_shared_initialization.F90 b/src/initialization/MOM_shared_initialization.F90 index f12a388897..301db0bbed 100644 --- a/src/initialization/MOM_shared_initialization.F90 +++ b/src/initialization/MOM_shared_initialization.F90 @@ -478,6 +478,7 @@ subroutine set_rotation_beta_plane(f, G, param_file, US) integer :: I, J real :: f_0 ! The reference value of the Coriolis parameter [T-1 ~> s-1] real :: beta ! The meridional gradient of the Coriolis parameter [T-1 m-1 ~> s-1 m-1] + real :: lat_0 ! The reference latitude for the beta plane [degrees] real :: y_scl, Rad_Earth real :: T_to_s ! A time unit conversion factor real :: PI @@ -494,6 +495,9 @@ subroutine set_rotation_beta_plane(f, G, param_file, US) call get_param(param_file, mdl, "BETA", beta, & "The northward gradient of the Coriolis parameter with "//& "the betaplane option.", units="m-1 s-1", default=0.0, scale=T_to_s) + call get_param(param_file, mdl, "LAT_0", lat_0, & + "The reference latitude (origin) of the beta-plane", & + units="degrees", default=0.0) call get_param(param_file, mdl, "AXIS_UNITS", axis_units, default="degrees") PI = 4.0*atan(1.0) @@ -501,7 +505,7 @@ subroutine set_rotation_beta_plane(f, G, param_file, US) case ("d") call get_param(param_file, mdl, "RAD_EARTH", Rad_Earth, & "The radius of the Earth.", units="m", default=6.378e6) - y_scl = Rad_Earth/PI + y_scl = PI * Rad_Earth/ 180. case ("k"); y_scl = 1.E3 case ("m"); y_scl = 1. case ("c"); y_scl = 1.E-2 @@ -510,7 +514,7 @@ subroutine set_rotation_beta_plane(f, G, param_file, US) end select do I=G%IsdB,G%IedB ; do J=G%JsdB,G%JedB - f(I,J) = f_0 + beta * ( G%geoLatBu(I,J) * y_scl ) + f(I,J) = f_0 + beta * ( (G%geoLatBu(I,J) - lat_0) * y_scl ) enddo ; enddo call callTree_leave(trim(mdl)//'()') From 29061de6a1323d734f003ace9bf76c542549ee76 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sun, 23 May 2021 07:21:31 -0400 Subject: [PATCH 081/112] +Dimensional rescaling of user OBC test cases Add dimensional rescaling of user OBC test cases, including documentation of the units of variables in the Kelvin, shelfwave, tidal_bay and dyed_channel initialization and rescaling parameters parameters via optional scale arguments to get_param calls. These changes also incorporate the answer-changing correction to the Kelvin wave OBC test case in PR #1406, with a comment noting what seems like an additional bug in this test case. This commit includes adding a unit_scale_type argument to call_OBC_register, register_file_OBC, register_tidal_bay_OBC, register_Kelvin_OBC, register_shelfwave_OBC and register_dyed_channel_OBC. These Kelvin wave OBC configuration from ESMG-configs now passes the dimensional rescaling tests. All answers are bitwise identical in the MOM6_examples test cases, but there are interface changes. --- src/core/MOM.F90 | 2 +- src/core/MOM_boundary_update.F90 | 15 +-- src/core/MOM_open_boundary.F90 | 6 +- src/user/Kelvin_initialization.F90 | 130 ++++++++++++----------- src/user/dyed_channel_initialization.F90 | 26 +++-- src/user/shelfwave_initialization.F90 | 49 +++++---- src/user/tidal_bay_initialization.F90 | 33 ++++-- 7 files changed, 145 insertions(+), 116 deletions(-) diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index 4659b685e5..4d16260f7c 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -2168,7 +2168,7 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & call MOM_timing_init(CS) - if (associated(CS%OBC)) call call_OBC_register(param_file, CS%update_OBC_CSp, CS%OBC) + if (associated(CS%OBC)) call call_OBC_register(param_file, CS%update_OBC_CSp, US, CS%OBC) call tracer_registry_init(param_file, CS%tracer_Reg) diff --git a/src/core/MOM_boundary_update.F90 b/src/core/MOM_boundary_update.F90 index 17712491c4..2e25af2460 100644 --- a/src/core/MOM_boundary_update.F90 +++ b/src/core/MOM_boundary_update.F90 @@ -58,9 +58,10 @@ module MOM_boundary_update !> The following subroutines and associated definitions provide the !! machinery to register and call the subroutines that initialize !! open boundary conditions. -subroutine call_OBC_register(param_file, CS, OBC) +subroutine call_OBC_register(param_file, CS, US, OBC) type(param_file_type), intent(in) :: param_file !< Parameter file to parse type(update_OBC_CS), pointer :: CS !< Control structure for OBCs + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(ocean_OBC_type), pointer :: OBC !< Open boundary structure ! Local variables @@ -92,19 +93,19 @@ subroutine call_OBC_register(param_file, CS, OBC) default=.false.) if (CS%use_files) CS%use_files = & - register_file_OBC(param_file, CS%file_OBC_CSp, & + register_file_OBC(param_file, CS%file_OBC_CSp, US, & OBC%OBC_Reg) if (CS%use_tidal_bay) CS%use_tidal_bay = & - register_tidal_bay_OBC(param_file, CS%tidal_bay_OBC_CSp, & + register_tidal_bay_OBC(param_file, CS%tidal_bay_OBC_CSp, US, & OBC%OBC_Reg) if (CS%use_Kelvin) CS%use_Kelvin = & - register_Kelvin_OBC(param_file, CS%Kelvin_OBC_CSp, & + register_Kelvin_OBC(param_file, CS%Kelvin_OBC_CSp, US, & OBC%OBC_Reg) if (CS%use_shelfwave) CS%use_shelfwave = & - register_shelfwave_OBC(param_file, CS%shelfwave_OBC_CSp, & + register_shelfwave_OBC(param_file, CS%shelfwave_OBC_CSp, US, & OBC%OBC_Reg) if (CS%use_dyed_channel) CS%use_dyed_channel = & - register_dyed_channel_OBC(param_file, CS%dyed_channel_OBC_CSp, & + register_dyed_channel_OBC(param_file, CS%dyed_channel_OBC_CSp, US, & OBC%OBC_Reg) end subroutine call_OBC_register @@ -128,7 +129,7 @@ subroutine update_OBC_data(OBC, G, GV, US, tv, h, CS, Time) if (CS%use_Kelvin) & call Kelvin_set_OBC_data(OBC, CS%Kelvin_OBC_CSp, G, GV, US, h, Time) if (CS%use_shelfwave) & - call shelfwave_set_OBC_data(OBC, CS%shelfwave_OBC_CSp, G, GV, h, Time) + call shelfwave_set_OBC_data(OBC, CS%shelfwave_OBC_CSp, G, GV, US, h, Time) if (CS%use_dyed_channel) & call dyed_channel_update_flow(OBC, CS%dyed_channel_OBC_CSp, G, GV, Time) if (OBC%needs_IO_for_data .or. OBC%add_tide_constituents) & diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index 0cb81e9978..bd76f5a9aa 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -177,7 +177,8 @@ module MOM_open_boundary !! segment [H L2 T-1 ~> m3 s-1]. real, pointer, dimension(:,:) :: normal_vel_bt=>NULL() !< The barotropic velocity normal to !! 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(:,:) :: eta=>NULL() !< The sea-surface elevation along the + !! segment [H ~> m or kg m-2]. real, pointer, dimension(:,:,:) :: grad_normal=>NULL() !< The gradient of the normal flow along the !! 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 @@ -4464,9 +4465,10 @@ subroutine OBC_registry_init(param_file, Reg) end subroutine OBC_registry_init !> Add file to OBC registry. -function register_file_OBC(param_file, CS, OBC_Reg) +function register_file_OBC(param_file, CS, US, OBC_Reg) type(param_file_type), intent(in) :: param_file !< parameter file. type(file_OBC_CS), pointer :: CS !< file control structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(OBC_registry_type), pointer :: OBC_Reg !< OBC registry. logical :: register_file_OBC character(len=32) :: casename = "OBC file" !< This case's name. diff --git a/src/user/Kelvin_initialization.F90 b/src/user/Kelvin_initialization.F90 index b93007647d..650c2c0c32 100644 --- a/src/user/Kelvin_initialization.F90 +++ b/src/user/Kelvin_initialization.F90 @@ -35,13 +35,13 @@ module Kelvin_initialization !> Control structure for Kelvin wave open boundaries. type, public :: Kelvin_OBC_CS ; private integer :: mode = 0 !< Vertical mode - real :: coast_angle = 0 !< Angle of coastline - real :: coast_offset1 = 0 !< Longshore distance to coastal angle - real :: coast_offset2 = 0 !< Longshore distance to coastal angle - real :: H0 = 0 !< Bottom depth - real :: F_0 !< Coriolis parameter - real :: rho_range !< Density range - real :: rho_0 !< Mean density + real :: coast_angle = 0 !< Angle of coastline [rad] + real :: coast_offset1 = 0 !< Longshore distance to coastal angle [L ~> m] + real :: coast_offset2 = 0 !< Longshore distance to coastal angle [L ~> m] + real :: H0 = 0 !< Bottom depth [Z ~> m]f + real :: F_0 !< Coriolis parameter [T-1 ~> s-1] + real :: rho_range !< Density range [R ~> kg m-3] + real :: rho_0 !< Mean density [R ~> kg m-3] end type Kelvin_OBC_CS ! This include declares and sets the variable "version". @@ -50,9 +50,10 @@ module Kelvin_initialization contains !> Add Kelvin wave to OBC registry. -function register_Kelvin_OBC(param_file, CS, OBC_Reg) +function register_Kelvin_OBC(param_file, CS, US, OBC_Reg) type(param_file_type), intent(in) :: param_file !< parameter file. type(Kelvin_OBC_CS), pointer :: CS !< Kelvin wave control structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(OBC_registry_type), pointer :: OBC_Reg !< OBC registry. ! Local variables @@ -73,31 +74,29 @@ function register_Kelvin_OBC(param_file, CS, OBC_Reg) "Vertical Kelvin wave mode imposed at upstream open boundary.", & default=0) call get_param(param_file, mdl, "F_0", CS%F_0, & - default=0.0, do_not_log=.true.) + default=0.0, units="s-1", scale=US%T_to_s, do_not_log=.true.) call get_param(param_file, mdl, "TOPO_CONFIG", config, do_not_log=.true.) if (trim(config) == "Kelvin") then call get_param(param_file, mdl, "ROTATED_COAST_OFFSET_1", CS%coast_offset1, & "The distance along the southern and northern boundaries "//& "at which the coasts angle in.", & - units="km", default=100.0) + units="km", default=100.0, scale=1.0e3*US%m_to_L) call get_param(param_file, mdl, "ROTATED_COAST_OFFSET_2", CS%coast_offset2, & "The distance from the southern and northern boundaries "//& "at which the coasts angle in.", & - units="km", default=10.0) + units="km", default=10.0, scale=1.0e3*US%m_to_L) call get_param(param_file, mdl, "ROTATED_COAST_ANGLE", CS%coast_angle, & "The angle of the southern bondary beyond X=ROTATED_COAST_OFFSET.", & units="degrees", default=11.3) CS%coast_angle = CS%coast_angle * (atan(1.0)/45.) ! Convert to radians - CS%coast_offset1 = CS%coast_offset1 * 1.e3 ! Convert to m - CS%coast_offset2 = CS%coast_offset2 * 1.e3 ! Convert to m endif if (CS%mode /= 0) then call get_param(param_file, mdl, "DENSITY_RANGE", CS%rho_range, & - default=2.0, do_not_log=.true.) + default=2.0, do_not_log=.true., scale=US%kg_m3_to_R) call get_param(param_file, mdl, "RHO_0", CS%rho_0, & - default=1035.0, do_not_log=.true.) + default=1035.0, do_not_log=.true., scale=US%kg_m3_to_R) call get_param(param_file, mdl, "MAXIMUM_DEPTH", CS%H0, & - default=1000.0, do_not_log=.true.) + default=1000.0, do_not_log=.true., scale=US%m_to_Z) endif ! Register the Kelvin open boundary. @@ -122,7 +121,7 @@ subroutine Kelvin_initialize_topography(D, G, param_file, max_depth, US) real, dimension(G%isd:G%ied,G%jsd:G%jed), & intent(out) :: D !< Ocean bottom depth in m or Z if US is present type(param_file_type), intent(in) :: param_file !< Parameter file structure - real, intent(in) :: max_depth !< Maximum model depth in the units of D + real, intent(in) :: max_depth !< Maximum model depth in the units of D [Z ~> m or m] type(unit_scale_type), optional, intent(in) :: US !< A dimensional unit scaling type ! Local variables @@ -176,22 +175,27 @@ subroutine Kelvin_set_OBC_data(OBC, CS, G, GV, US, h, Time) type(Kelvin_OBC_CS), pointer :: CS !< Kelvin wave control structure. 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 real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< layer thickness [H ~> m or kg m-2]. type(time_type), intent(in) :: Time !< model time. ! The following variables are used to set up the transport in the Kelvin example. - real :: time_sec, cff - real :: N0 ! Brunt-Vaisala frequency [s-1] - real :: plx !< Longshore wave parameter - real :: pmz !< Vertical wave parameter - real :: lambda !< Offshore decay scale - real :: omega !< Wave frequency [s-1] + real :: time_sec ! The time in the run [T ~> s] + real :: cff ! The wave speed [L T-1 ~> m s-1] + real :: N0 ! Brunt-Vaisala frequency times a rescaling of slopes [L Z-1 T-1 ~> s-1] + real :: lambda ! Offshore decay scale [L-1 ~> m-1] + real :: omega ! Wave frequency [T-1 ~> s-1] real :: PI integer :: i, j, k, n, is, ie, js, je, isd, ied, jsd, jed, nz integer :: IsdB, IedB, JsdB, JedB - real :: fac, x, y, x1, y1 - real :: val1, val2, sina, cosa + real :: mag_SSH ! An overall magnitude of the external wave sea surface height at the coastline [Z ~> m] + real :: mag_int ! An overall magnitude of the internal wave at the coastline [L2 T-2 ~> m2 s-2] + real :: x1, y1 ! Various positions [L ~> m] + real :: x, y ! Various positions [L ~> m] + real :: val1 ! The periodicity factor [nondim] + real :: val2 ! The local wave amplitude [Z ~> m] + real :: km_to_L_scale ! A scaling factor from longitudes in km to L [L km-1 ~> 1e3] + real :: sina, cosa ! The sine and cosine of the coast angle [nondim] type(OBC_segment_type), pointer :: segment => NULL() is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke @@ -201,23 +205,20 @@ subroutine Kelvin_set_OBC_data(OBC, CS, G, GV, US, h, Time) if (.not.associated(OBC)) call MOM_error(FATAL, 'Kelvin_initialization.F90: '// & 'Kelvin_set_OBC_data() was called but OBC type was not initialized!') - time_sec = time_type_to_real(Time) + time_sec = US%s_to_T*time_type_to_real(Time) PI = 4.0*atan(1.0) - fac = 1.0 + km_to_L_scale = 1000.0*US%m_to_L if (CS%mode == 0) then - omega = 2.0 * PI / (12.42 * 3600.0) ! M2 Tide period - val1 = US%m_to_Z * sin(omega * time_sec) + mag_SSH = 1.0*US%m_to_Z + omega = 2.0 * PI / (12.42 * 3600.0*US%s_to_T) ! M2 Tide period + val1 = sin(omega * time_sec) else - N0 = US%L_to_m*US%s_to_T * sqrt((CS%rho_range / CS%rho_0) * GV%g_Earth * (US%m_to_Z * CS%H0)) + mag_int = 1.0*US%m_s_to_L_T**2 + N0 = sqrt((CS%rho_range / CS%rho_0) * GV%g_Earth / CS%H0) + lambda = PI * CS%mode * CS%F_0 / (CS%H0 * N0) ! Two wavelengths in domain - plx = 4.0 * PI / G%len_lon - pmz = PI * CS%mode / CS%H0 - lambda = pmz * CS%F_0 / N0 - omega = CS%F_0 * plx / lambda - - ! lambda = PI * CS%mode * CS%F_0 / (CS%H0 * N0) - ! omega = (4.0 * CS%H0 * N0) / (CS%mode * G%len_lon) + omega = (4.0 * CS%H0 * N0) / (CS%mode * US%m_to_L*G%len_lon) endif sina = sin(CS%coast_angle) @@ -230,22 +231,23 @@ subroutine Kelvin_set_OBC_data(OBC, CS, G, GV, US, h, Time) if (segment%direction == OBC_DIRECTION_N) cycle ! This should be somewhere else... - segment%Velocity_nudging_timescale_in = 1.0/(0.3*86400) + !### This is supposed to be a timescale [T ~> s] but appears to be a rate in [s-1]. + segment%Velocity_nudging_timescale_in = US%s_to_T * 1.0/(0.3*86400) if (segment%direction == OBC_DIRECTION_W) then IsdB = segment%HI%IsdB ; IedB = segment%HI%IedB jsd = segment%HI%jsd ; jed = segment%HI%jed JsdB = segment%HI%JsdB ; JedB = segment%HI%JedB do j=jsd,jed ; do I=IsdB,IedB - x1 = 1000. * G%geoLonCu(I,j) - y1 = 1000. * G%geoLatCu(I,j) + x1 = km_to_L_scale * G%geoLonCu(I,j) + y1 = km_to_L_scale * G%geoLatCu(I,j) x = (x1 - CS%coast_offset1) * cosa + y1 * sina - y = - (x1 - CS%coast_offset1) * sina + y1 * cosa + y = -(x1 - CS%coast_offset1) * sina + y1 * cosa if (CS%mode == 0) then ! Use inside bathymetry cff = sqrt(GV%g_Earth * G%bathyT(i+1,j) ) - val2 = fac * exp(- US%T_to_s*CS%F_0 * US%m_to_L*y / cff) - segment%eta(I,j) = val2 * cos(omega * time_sec) + val2 = mag_SSH * exp(- CS%F_0 * y / cff) + segment%eta(I,j) = GV%Z_to_H*val2 * cos(omega * time_sec) segment%normal_vel_bt(I,j) = (val2 * (val1 * cff * cosa / & (G%bathyT(i+1,j) )) ) if (segment%nudged) then @@ -266,14 +268,14 @@ subroutine Kelvin_set_OBC_data(OBC, CS, G, GV, US, h, Time) segment%normal_vel_bt(I,j) = 0.0 if (segment%nudged) then do k=1,nz - segment%nudged_normal_vel(I,j,k) = US%m_s_to_L_T * fac * lambda / CS%F_0 * & - exp(- lambda * y) * cos(PI * CS%mode * (k - 0.5) / nz) * & + segment%nudged_normal_vel(I,j,k) = mag_int * lambda / CS%F_0 * & + exp(-lambda * y) * cos(PI * CS%mode * (k - 0.5) / nz) * & cos(omega * time_sec) enddo elseif (segment%specified) then do k=1,nz - segment%normal_vel(I,j,k) = US%m_s_to_L_T * fac * lambda / CS%F_0 * & - exp(- lambda * y) * cos(PI * CS%mode * (k - 0.5) / nz) * & + segment%normal_vel(I,j,k) = mag_int * lambda / CS%F_0 * & + exp(-lambda * y) * cos(PI * CS%mode * (k - 0.5) / nz) * & cos(omega * time_sec) segment%normal_trans(I,j,k) = segment%normal_vel(I,j,k) * h(i+1,j,k) * G%dyCu(I,j) enddo @@ -282,12 +284,12 @@ subroutine Kelvin_set_OBC_data(OBC, CS, G, GV, US, h, Time) enddo ; enddo if (associated(segment%tangential_vel)) then do J=JsdB+1,JedB-1 ; do I=IsdB,IedB - x1 = 1000. * G%geoLonBu(I,J) - y1 = 1000. * G%geoLatBu(I,J) + x1 = km_to_L_scale * G%geoLonBu(I,J) + y1 = km_to_L_scale * G%geoLatBu(I,J) x = (x1 - CS%coast_offset1) * cosa + y1 * sina y = - (x1 - CS%coast_offset1) * sina + y1 * cosa - cff =sqrt(GV%g_Earth * G%bathyT(i+1,j) ) - val2 = fac * exp(- US%T_to_s*CS%F_0 * US%m_to_L*y / cff) + cff = sqrt(GV%g_Earth * G%bathyT(i+1,j) ) + val2 = mag_SSH * exp(- CS%F_0 * y / cff) if (CS%mode == 0) then ; do k=1,nz segment%tangential_vel(I,J,k) = (val1 * val2 * cff * sina) / & ( 0.5*(G%bathyT(i+1,j+1) + G%bathyT(i+1,j) ) ) @@ -299,24 +301,24 @@ subroutine Kelvin_set_OBC_data(OBC, CS, G, GV, US, h, Time) isd = segment%HI%isd ; ied = segment%HI%ied JsdB = segment%HI%JsdB ; JedB = segment%HI%JedB do J=JsdB,JedB ; do i=isd,ied - x1 = 1000. * G%geoLonCv(i,J) - y1 = 1000. * G%geoLatCv(i,J) + x1 = km_to_L_scale * G%geoLonCv(i,J) + y1 = km_to_L_scale * G%geoLatCv(i,J) x = (x1 - CS%coast_offset1) * cosa + y1 * sina y = - (x1 - CS%coast_offset1) * sina + y1 * cosa if (CS%mode == 0) then cff = sqrt(GV%g_Earth * G%bathyT(i,j+1) ) - val2 = fac * exp(- 0.5 * (G%CoriolisBu(I,J) + G%CoriolisBu(I-1,J)) * US%m_to_L*y / cff) - segment%eta(I,j) = val2 * cos(omega * time_sec) - segment%normal_vel_bt(I,j) = US%L_T_to_m_s * (val1 * cff * sina / & + val2 = mag_SSH * exp(- 0.5 * (G%CoriolisBu(I,J) + G%CoriolisBu(I-1,J)) * y / cff) + segment%eta(I,j) = GV%Z_to_H*val2 * cos(omega * time_sec) + segment%normal_vel_bt(I,j) = (val1 * cff * sina / & (G%bathyT(i,j+1) )) * val2 if (segment%nudged) then do k=1,nz - segment%nudged_normal_vel(I,j,k) = US%L_T_to_m_s * (val1 * cff * sina / & + segment%nudged_normal_vel(I,j,k) = (val1 * cff * sina / & (G%bathyT(i,j+1) )) * val2 enddo elseif (segment%specified) then do k=1,nz - segment%normal_vel(I,j,k) = US%L_T_to_m_s * (val1 * cff * sina / & + segment%normal_vel(I,j,k) = (val1 * cff * sina / & (G%bathyT(i,j+1) )) * val2 segment%normal_trans(i,J,k) = segment%normal_vel(i,J,k) * h(i,j+1,k) * G%dxCv(i,J) enddo @@ -327,12 +329,12 @@ subroutine Kelvin_set_OBC_data(OBC, CS, G, GV, US, h, Time) segment%normal_vel_bt(i,J) = 0.0 if (segment%nudged) then do k=1,nz - segment%nudged_normal_vel(i,J,k) = US%m_s_to_L_T*fac * lambda / CS%F_0 * & + segment%nudged_normal_vel(i,J,k) = mag_int * lambda / CS%F_0 * & exp(- lambda * y) * cos(PI * CS%mode * (k - 0.5) / nz) * cosa enddo elseif (segment%specified) then do k=1,nz - segment%normal_vel(i,J,k) = US%m_s_to_L_T*fac * lambda / CS%F_0 * & + segment%normal_vel(i,J,k) = mag_int * lambda / CS%F_0 * & exp(- lambda * y) * cos(PI * CS%mode * (k - 0.5) / nz) * cosa segment%normal_trans(i,J,k) = segment%normal_vel(i,J,k) * h(i,j+1,k) * G%dxCv(i,J) enddo @@ -341,12 +343,12 @@ subroutine Kelvin_set_OBC_data(OBC, CS, G, GV, US, h, Time) enddo ; enddo if (associated(segment%tangential_vel)) then do J=JsdB,JedB ; do I=IsdB+1,IedB-1 - x1 = 1000. * G%geoLonBu(I,J) - y1 = 1000. * G%geoLatBu(I,J) + x1 = km_to_L_scale * G%geoLonBu(I,J) + y1 = km_to_L_scale * G%geoLatBu(I,J) x = (x1 - CS%coast_offset1) * cosa + y1 * sina y = - (x1 - CS%coast_offset1) * sina + y1 * cosa cff = sqrt(GV%g_Earth * G%bathyT(i,j+1) ) - val2 = fac * exp(- 0.5 * (G%CoriolisBu(I,J) + G%CoriolisBu(I-1,J)) * US%m_to_L*y / cff) + val2 = mag_SSH * exp(- 0.5 * (G%CoriolisBu(I,J) + G%CoriolisBu(I-1,J)) * y / cff) if (CS%mode == 0) then ; do k=1,nz segment%tangential_vel(I,J,k) = ((val1 * val2 * cff * sina) / & ( 0.5*((G%bathyT(i+1,j+1)) + G%bathyT(i,j+1))) ) diff --git a/src/user/dyed_channel_initialization.F90 b/src/user/dyed_channel_initialization.F90 index 4c633ebdc9..317ed4ac21 100644 --- a/src/user/dyed_channel_initialization.F90 +++ b/src/user/dyed_channel_initialization.F90 @@ -14,6 +14,7 @@ module dyed_channel_initialization use MOM_time_manager, only : time_type, time_type_to_real use MOM_tracer_registry, only : tracer_registry_type, tracer_name_lookup use MOM_tracer_registry, only : tracer_type +use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : thermo_var_ptrs use MOM_verticalGrid, only : verticalGrid_type @@ -26,9 +27,9 @@ module dyed_channel_initialization !> Control structure for dyed-channel open boundaries. type, public :: dyed_channel_OBC_CS ; private - real :: zonal_flow = 8.57 !< Mean inflow - real :: tidal_amp = 0.0 !< Sloshing amplitude - real :: frequency = 0.0 !< Sloshing frequency + real :: zonal_flow = 8.57 !< Mean inflow [L T-1 ~> m s-1] + real :: tidal_amp = 0.0 !< Sloshing amplitude [L T-1 ~> m s-1] + real :: frequency = 0.0 !< Sloshing frequency [T-1 ~> s-1] end type dyed_channel_OBC_CS integer :: ntr = 0 !< Number of dye tracers @@ -37,9 +38,10 @@ module dyed_channel_initialization contains !> Add dyed channel to OBC registry. -function register_dyed_channel_OBC(param_file, CS, OBC_Reg) +function register_dyed_channel_OBC(param_file, CS, US, OBC_Reg) type(param_file_type), intent(in) :: param_file !< parameter file. type(dyed_channel_OBC_CS), pointer :: CS !< Dyed channel control structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(OBC_registry_type), pointer :: OBC_Reg !< OBC registry. ! Local variables logical :: register_dyed_channel_OBC @@ -55,13 +57,13 @@ function register_dyed_channel_OBC(param_file, CS, OBC_Reg) call get_param(param_file, mdl, "CHANNEL_MEAN_FLOW", CS%zonal_flow, & "Mean zonal flow imposed at upstream open boundary.", & - units="m/s", default=8.57) + units="m/s", default=8.57, scale=US%m_s_to_L_T) call get_param(param_file, mdl, "CHANNEL_TIDAL_AMP", CS%tidal_amp, & "Sloshing amplitude imposed at upstream open boundary.", & - units="m/s", default=0.0) + units="m/s", default=0.0, scale=US%m_s_to_L_T) call get_param(param_file, mdl, "CHANNEL_FLOW_FREQUENCY", CS%frequency, & "Frequency of oscillating zonal flow.", & - units="s-1", default=0.0) + units="s-1", default=0.0, scale=US%T_to_s) ! Register the open boundaries. call register_OBC(casename, param_file, OBC_Reg) @@ -142,7 +144,9 @@ subroutine dyed_channel_update_flow(OBC, CS, G, GV, Time) ! Local variables character(len=40) :: mdl = "dyed_channel_update_flow" ! This subroutine's name. character(len=80) :: name - real :: flow, time_sec, PI + real :: flow ! The OBC velocity [L T-1 ~> m s-1] + real :: PI ! 3.1415926535... + real :: time_sec ! The elapsed time since the start of the calendar [T ~> s] integer :: i, j, k, l, itt, isd, ied, jsd, jed, m, n integer :: IsdB, IedB, JsdB, JedB type(OBC_segment_type), pointer :: segment => NULL() @@ -150,7 +154,7 @@ subroutine dyed_channel_update_flow(OBC, CS, G, GV, Time) if (.not.associated(OBC)) call MOM_error(FATAL, 'dyed_channel_initialization.F90: '// & 'dyed_channel_update_flow() was called but OBC type was not initialized!') - time_sec = time_type_to_real(Time) + time_sec = G%US%s_to_T * time_type_to_real(Time) PI = 4.0*atan(1.0) do l=1, OBC%number_of_segments @@ -163,9 +167,9 @@ subroutine dyed_channel_update_flow(OBC, CS, G, GV, Time) jsd = segment%HI%jsd ; jed = segment%HI%jed IsdB = segment%HI%IsdB ; IedB = segment%HI%IedB if (CS%frequency == 0.0) then - flow = G%US%m_s_to_L_T*CS%zonal_flow + flow = CS%zonal_flow else - flow = G%US%m_s_to_L_T*CS%zonal_flow + CS%tidal_amp * cos(2 * PI * CS%frequency * time_sec) + flow = CS%zonal_flow + CS%tidal_amp * cos(2 * PI * CS%frequency * time_sec) endif do k=1,GV%ke do j=jsd,jed ; do I=IsdB,IedB diff --git a/src/user/shelfwave_initialization.F90 b/src/user/shelfwave_initialization.F90 index 7bf6aebf59..041d77d9f9 100644 --- a/src/user/shelfwave_initialization.F90 +++ b/src/user/shelfwave_initialization.F90 @@ -30,20 +30,21 @@ module shelfwave_initialization type, public :: shelfwave_OBC_CS ; private real :: Lx = 100.0 !< Long-shore length scale of bathymetry. real :: Ly = 50.0 !< Cross-shore length scale. - real :: f0 = 1.e-4 !< Coriolis parameter. + real :: f0 = 1.e-4 !< Coriolis parameter [T-1 ~> s-1] real :: jj = 1 !< Cross-shore wave mode. real :: kk !< Parameter. real :: ll !< Longshore wavenumber. real :: alpha !< 1/Ly. - real :: omega !< Frequency. + real :: omega !< Frequency of the shelf wave [T-1 ~> s-1] end type shelfwave_OBC_CS contains !> Add shelfwave to OBC registry. -function register_shelfwave_OBC(param_file, CS, OBC_Reg) +function register_shelfwave_OBC(param_file, CS, US, OBC_Reg) type(param_file_type), intent(in) :: param_file !< parameter file. type(shelfwave_OBC_CS), pointer :: CS !< shelfwave control structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(OBC_registry_type), pointer :: OBC_Reg !< OBC registry. logical :: register_shelfwave_OBC ! Local variables @@ -62,18 +63,20 @@ function register_shelfwave_OBC(param_file, CS, OBC_Reg) ! Register the tracer for horizontal advection & diffusion. call register_OBC(casename, param_file, OBC_Reg) - call get_param(param_file, mdl,"F_0",CS%f0, & - do_not_log=.true.) - call get_param(param_file, mdl,"LENLAT",len_lat, & + call get_param(param_file, mdl, "F_0", CS%f0, & + default=0.0, units="s-1", scale=US%T_to_s, do_not_log=.true.) + call get_param(param_file, mdl, "LENLAT", len_lat, & do_not_log=.true.) call get_param(param_file, mdl,"SHELFWAVE_X_WAVELENGTH",CS%Lx, & "Length scale of shelfwave in x-direction.",& units="Same as x,y", default=100.) - call get_param(param_file, mdl,"SHELFWAVE_Y_LENGTH_SCALE",CS%Ly, & +! units="km", default=100.0, scale=1.0e3*US%m_to_L) + call get_param(param_file, mdl, "SHELFWAVE_Y_LENGTH_SCALE", CS%Ly, & "Length scale of exponential dropoff of topography "//& "in the y-direction.", & units="Same as x,y", default=50.) - call get_param(param_file, mdl,"SHELFWAVE_Y_MODE",CS%jj, & +! units="km", default=50.0, scale=1.0e3*US%m_to_L) + call get_param(param_file, mdl, "SHELFWAVE_Y_MODE", CS%jj, & "Cross-shore wave mode.", & units="nondim", default=1.) CS%alpha = 1. / CS%Ly @@ -126,19 +129,23 @@ subroutine shelfwave_initialize_topography( D, G, param_file, max_depth, US ) end subroutine shelfwave_initialize_topography !> This subroutine sets the properties of flow at open boundary conditions. -subroutine shelfwave_set_OBC_data(OBC, CS, G, GV, h, Time) - type(ocean_OBC_type), pointer :: OBC !< This open boundary condition type specifies - !! whether, where, and what open boundary - !! conditions are used. - type(shelfwave_OBC_CS), pointer :: CS !< tidal bay control structure. - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. - type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure +subroutine shelfwave_set_OBC_data(OBC, CS, G, GV, US, h, Time) + type(ocean_OBC_type), pointer :: OBC !< This open boundary condition type specifies + !! whether, where, and what open boundary + !! conditions are used. + type(shelfwave_OBC_CS), pointer :: CS !< tidal bay control structure. + 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 real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< layer thickness. type(time_type), intent(in) :: Time !< model time. ! The following variables are used to set up the transport in the shelfwave example. - real :: my_amp, time_sec - real :: cos_wt, cos_ky, sin_wt, sin_ky, omega, alpha + real :: my_amp ! Amplitude of the open boundary current inflows [L T-1 ~> m s-1] + real :: time_sec ! The time in the run [T ~> s] + real :: cos_wt, cos_ky, sin_wt, sin_ky + real :: omega ! Frequency of the shelf wave [T-1 ~> s-1] + real :: alpha real :: x, y, jj, kk, ll character(len=40) :: mdl = "shelfwave_set_OBC_data" ! This subroutine's name. integer :: i, j, k, is, ie, js, je, isd, ied, jsd, jed, n @@ -151,10 +158,10 @@ subroutine shelfwave_set_OBC_data(OBC, CS, G, GV, h, Time) if (.not.associated(OBC)) return - time_sec = time_type_to_real(Time) + time_sec = US%s_to_T*time_type_to_real(Time) omega = CS%omega alpha = CS%alpha - my_amp = 1.0 + my_amp = 1.0*G%US%m_s_to_L_T jj = CS%jj kk = CS%kk ll = CS%ll @@ -172,9 +179,9 @@ subroutine shelfwave_set_OBC_data(OBC, CS, G, GV, h, Time) cos_wt = cos(ll*x - omega*time_sec) sin_ky = sin(kk * y) cos_ky = cos(kk * y) - segment%normal_vel_bt(I,j) = G%US%m_s_to_L_T*my_amp * exp(- alpha * y) * cos_wt * & + segment%normal_vel_bt(I,j) = my_amp * exp(- alpha * y) * cos_wt * & (alpha * sin_ky + kk * cos_ky) -! segment%tangential_vel_bt(I,j) = G%US%m_s_to_L_T*my_amp * ll * exp(- alpha * y) * sin_wt * sin_ky +! segment%tangential_vel_bt(I,j) = my_amp * ll * exp(- alpha * y) * sin_wt * sin_ky ! segment%vorticity_bt(I,j) = my_amp * exp(- alpha * y) * cos_wt * sin_ky& ! (ll*ll + kk*kk + alpha*alpha) enddo ; enddo diff --git a/src/user/tidal_bay_initialization.F90 b/src/user/tidal_bay_initialization.F90 index e6db433f60..b3c8f45843 100644 --- a/src/user/tidal_bay_initialization.F90 +++ b/src/user/tidal_bay_initialization.F90 @@ -12,6 +12,7 @@ module tidal_bay_initialization use MOM_open_boundary, only : ocean_OBC_type, OBC_NONE use MOM_open_boundary, only : OBC_segment_type, register_OBC use MOM_open_boundary, only : OBC_registry_type +use MOM_unit_scaling, only : unit_scale_type use MOM_verticalGrid, only : verticalGrid_type use MOM_time_manager, only : time_type, time_type_to_real @@ -24,18 +25,20 @@ module tidal_bay_initialization !> Control structure for tidal bay open boundaries. type, public :: tidal_bay_OBC_CS ; private - real :: tide_flow = 3.0e6 !< Maximum tidal flux. + real :: tide_flow = 3.0e6 !< Maximum tidal flux [L2 Z T-1 ~> m3 s-1] end type tidal_bay_OBC_CS contains !> Add tidal bay to OBC registry. -function register_tidal_bay_OBC(param_file, CS, OBC_Reg) +function register_tidal_bay_OBC(param_file, CS, US, OBC_Reg) type(param_file_type), intent(in) :: param_file !< parameter file. type(tidal_bay_OBC_CS), pointer :: CS !< tidal bay control structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(OBC_registry_type), pointer :: OBC_Reg !< OBC registry. logical :: register_tidal_bay_OBC character(len=32) :: casename = "tidal bay" !< This case's name. + character(len=40) :: mdl = "tidal_bay_initialization" ! This module's name. if (associated(CS)) then call MOM_error(WARNING, "register_tidal_bay_OBC called with an "// & @@ -44,6 +47,10 @@ function register_tidal_bay_OBC(param_file, CS, OBC_Reg) endif allocate(CS) + call get_param(param_file, mdl, "TIDAL_BAY_FLOW", CS%tide_flow, & + "Maximum total tidal volume flux.", & + units="m3 s-1", default=3.0d6, scale=US%m_s_to_L_T*US%m_to_L*US%m_to_Z) + ! Register the open boundaries. call register_OBC(casename, param_file, OBC_Reg) register_tidal_bay_OBC = .true. @@ -67,14 +74,17 @@ subroutine tidal_bay_set_OBC_data(OBC, CS, G, GV, h, Time) type(tidal_bay_OBC_CS), pointer :: CS !< tidal bay control structure. 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_(GV)), intent(in) :: h !< layer thickness. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< layer thickness [H ~> m or kg m-2] type(time_type), intent(in) :: Time !< model time. ! The following variables are used to set up the transport in the tidal_bay example. - real :: time_sec, cff - real :: my_flux, total_area + real :: time_sec + real :: cff_eta ! The total column thickness anomalies associated with the inflow [H ~> m or kg m-2] + real :: my_flux ! The vlume flux through the face [L2 Z T-1 ~> m3 s-1] + real :: total_area ! The total face area of the OBCs [L Z ~> m2] real :: PI - real, allocatable :: my_area(:,:) + real :: flux_scale ! A scaling factor for the areas [m2 H-1 L-1 ~> nondim or m3 kg-1] + real, allocatable :: my_area(:,:) ! The total OBC inflow area [m2] character(len=40) :: mdl = "tidal_bay_set_OBC_data" ! This subroutine's name. integer :: i, j, k, itt, is, ie, js, je, isd, ied, jsd, jed, nz, n integer :: IsdB, IedB, JsdB, JedB @@ -90,8 +100,10 @@ subroutine tidal_bay_set_OBC_data(OBC, CS, G, GV, h, Time) allocate(my_area(1:1,js:je)) + flux_scale = GV%H_to_m*G%US%L_to_m + time_sec = time_type_to_real(Time) - cff = 0.1*sin(2.0*PI*time_sec/(12.0*3600.0)) + cff_eta = 0.1*GV%m_to_H * sin(2.0*PI*time_sec/(12.0*3600.0)) my_area=0.0 my_flux=0.0 segment => OBC%segment(1) @@ -99,7 +111,8 @@ subroutine tidal_bay_set_OBC_data(OBC, CS, G, GV, h, Time) do j=segment%HI%jsc,segment%HI%jec ; do I=segment%HI%IscB,segment%HI%IecB if (OBC%segnum_u(I,j) /= OBC_NONE) then do k=1,nz - my_area(1,j) = my_area(1,j) + h(I,j,k)*G%US%L_to_m*G%dyCu(I,j) + ! This area has to be in MKS units to work with reproducing_sum. + my_area(1,j) = my_area(1,j) + h(I,j,k)*flux_scale*G%dyCu(I,j) enddo endif enddo ; enddo @@ -111,8 +124,8 @@ subroutine tidal_bay_set_OBC_data(OBC, CS, G, GV, h, Time) if (.not. segment%on_pe) cycle - segment%normal_vel_bt(:,:) = G%US%m_s_to_L_T*my_flux/total_area - segment%eta(:,:) = cff + segment%normal_vel_bt(:,:) = my_flux / (G%US%m_to_Z*G%US%m_to_L*total_area) + segment%eta(:,:) = cff_eta enddo ! end segment loop From 56e983bff3bfeba8b026c885817606baea71c57a Mon Sep 17 00:00:00 2001 From: Angus Gibson Date: Mon, 24 May 2021 10:18:27 +1000 Subject: [PATCH 082/112] Remove duplicated solvers between regrid modules In the removal of regrid_edge_slopes, a couple of the solvers became duplicated between regrid_edge_values and regrid_solvers. Here, they're simply made consistent by removing the solvers from regrid_edge_values, and bringing over the zero-pivot check for the linear solver that was in one variation but not the other. --- src/ALE/regrid_edge_values.F90 | 114 +------------------------ src/ALE/regrid_solvers.F90 | 5 ++ src/diagnostics/MOM_wave_structure.F90 | 2 +- 3 files changed, 8 insertions(+), 113 deletions(-) diff --git a/src/ALE/regrid_edge_values.F90 b/src/ALE/regrid_edge_values.F90 index d9c25d8cd1..2baac56599 100644 --- a/src/ALE/regrid_edge_values.F90 +++ b/src/ALE/regrid_edge_values.F90 @@ -4,7 +4,8 @@ module regrid_edge_values ! This file is part of MOM6. See LICENSE.md for the license. use MOM_error_handler, only : MOM_error, FATAL -use regrid_solvers, only : solve_linear_system, solve_tridiagonal_system +use regrid_solvers, only : solve_linear_system, linear_solver +use regrid_solvers, only : solve_tridiagonal_system, solve_diag_dominant_tridiag use polynomial_functions, only : evaluation_polynomial implicit none ; private @@ -16,8 +17,6 @@ module regrid_edge_values public edge_values_explicit_h2, edge_values_explicit_h4 public edge_values_implicit_h4, edge_values_implicit_h6 public edge_slopes_implicit_h3, edge_slopes_implicit_h5 -public solve_diag_dominant_tridiag -! public solve_diag_dominant_tridiag, linear_solver ! The following parameters are used to avoid singular matrices for boundary ! extrapolation. The are needed only in the case where thicknesses vanish @@ -1332,115 +1331,6 @@ subroutine edge_values_implicit_h6( N, h, u, edge_val, h_neglect, answers_2018 ) end subroutine edge_values_implicit_h6 -!> Solve the tridiagonal system AX = R -!! -!! This routine uses a variant of Thomas's algorithm to solve the tridiagonal system AX = R, in -!! a form that is guaranteed to avoid dividing by a zero pivot. The matrix A is made up of -!! lower (Al) and upper diagonals (Au) and a central diagonal Ad = Ac+Al+Au, where -!! Al, Au, and Ac are all positive (or negative) definite. However when Ac is smaller than -!! roundoff compared with (Al+Au), the answers are prone to inaccuracy. -subroutine solve_diag_dominant_tridiag( Al, Ac, Au, R, X, N ) - integer, intent(in) :: N !< The size of the system - real, dimension(N), intent(in) :: Ac !< Matrix center diagonal offset from Al + Au - real, dimension(N), intent(in) :: Al !< Matrix lower diagonal - real, dimension(N), intent(in) :: Au !< Matrix upper diagonal - real, dimension(N), intent(in) :: R !< system right-hand side - real, dimension(N), intent(out) :: X !< solution vector - ! Local variables - real, dimension(N) :: c1 ! Au / pivot for the backward sweep - real :: d1 ! The next value of 1.0 - c1 - real :: I_pivot ! The inverse of the most recent pivot - real :: denom_t1 ! The first term in the denominator of the inverse of the pivot. - integer :: k ! Loop index - - ! Factorization and forward sweep, in a form that will never give a division by a - ! zero pivot for positive definite Ac, Al, and Au. - I_pivot = 1.0 / (Ac(1) + Au(1)) - d1 = Ac(1) * I_pivot - c1(1) = Au(1) * I_pivot - X(1) = R(1) * I_pivot - do k=2,N-1 - denom_t1 = Ac(k) + d1 * Al(k) - I_pivot = 1.0 / (denom_t1 + Au(k)) - d1 = denom_t1 * I_pivot - c1(k) = Au(k) * I_pivot - X(k) = (R(k) - Al(k) * X(k-1)) * I_pivot - enddo - I_pivot = 1.0 / (Ac(N) + d1 * Al(N)) - X(N) = (R(N) - Al(N) * X(N-1)) * I_pivot - ! Backward sweep - do k=N-1,1,-1 - X(k) = X(k) - c1(k) * X(k+1) - enddo - -end subroutine solve_diag_dominant_tridiag - - -!> Solve the linear system AX = R by Gaussian elimination -!! -!! This routine uses Gauss's algorithm to transform the system's original -!! matrix into an upper triangular matrix. Back substitution then yields the answer. -!! The matrix A must be square, with the first index varing along the row. -subroutine linear_solver( N, A, R, X ) - integer, intent(in) :: N !< The size of the system - real, dimension(N,N), intent(inout) :: A !< The matrix being inverted [nondim] - real, dimension(N), intent(inout) :: R !< system right-hand side [A] - real, dimension(N), intent(inout) :: X !< solution vector [A] - - ! Local variables - real :: factor ! The factor that eliminates the leading nonzero element in a row. - real :: I_pivot ! The reciprocal of the pivot value [inverse of the input units of a row of A] - real :: swap - integer :: i, j, k - - ! Loop on rows to transform the problem into multiplication by an upper-right matrix. - do i=1,N-1 - ! Seek a pivot for column i starting in row i, and continuing into the remaining rows. If the - ! pivot is in a row other than i, swap them. If no valid pivot is found, i = N+1 after this loop. - do k=i,N ; if ( abs(A(i,k)) > 0.0 ) exit ; enddo ! end loop to find pivot - if ( k > N ) then ! No pivot could be found and the system is singular. - write(0,*) ' A=',A - call MOM_error( FATAL, 'The linear system sent to linear_solver is singular.' ) - endif - - ! If the pivot is in a row that is different than row i, swap those two rows, noting that both - ! rows start with i-1 zero values. - if ( k /= i ) then - do j=i,N ; swap = A(j,i) ; A(j,i) = A(j,k) ; A(j,k) = swap ; enddo - swap = R(i) ; R(i) = R(k) ; R(k) = swap - endif - - ! Transform the pivot to 1 by dividing the entire row (right-hand side included) by the pivot - I_pivot = 1.0 / A(i,i) - A(i,i) = 1.0 - do j=i+1,N ; A(j,i) = A(j,i) * I_pivot ; enddo - R(i) = R(i) * I_pivot - - ! Put zeros in column for all rows below that contain the pivot (which is row i) - do k=i+1,N ! k is the row index - factor = A(i,k) - ! A(i,k) = 0.0 ! These elements are not used again, so this line can be skipped for speed. - do j=i+1,N ; A(j,k) = A(j,k) - factor * A(j,i) ; enddo - R(k) = R(k) - factor * R(i) - enddo - - enddo ! end loop on i - - ! Solve the system by back substituting into what is now an upper-right matrix. - if (A(N,N) == 0.0) then ! No pivot could be found and the system is singular. - ! write(0,*) ' A=',A - call MOM_error( FATAL, 'The final pivot in linear_solver is zero.' ) - endif - X(N) = R(N) / A(N,N) ! The last row can now be solved trivially. - do i=N-1,1,-1 ! loop on rows, starting from second to last row - X(i) = R(i) - do j=i+1,N ; X(i) = X(i) - A(j,i) * X(j) ; enddo - enddo - -end subroutine linear_solver - - - !> Test that A*C = R to within a tolerance, issuing a fatal error with an explanatory message if they do not. subroutine test_line(msg, N, A, C, R, mag, tol) real, intent(in) :: mag !< The magnitude of leading order terms in this line diff --git a/src/ALE/regrid_solvers.F90 b/src/ALE/regrid_solvers.F90 index 82b23832f4..50bd7f984d 100644 --- a/src/ALE/regrid_solvers.F90 +++ b/src/ALE/regrid_solvers.F90 @@ -155,6 +155,11 @@ subroutine linear_solver( N, A, R, X ) enddo ! end loop on i + if (A(N,N) == 0.0) then + ! no pivot could be found, and the sytem is singular + call MOM_error(FATAL, 'The final pivot in linear_solver is zero.') + end if + ! Solve the system by back substituting into what is now an upper-right matrix. X(N) = R(N) / A(N,N) ! The last row is now trivially solved. do i=N-1,1,-1 ! loop on rows, starting from second to last row diff --git a/src/diagnostics/MOM_wave_structure.F90 b/src/diagnostics/MOM_wave_structure.F90 index a3e60cf584..678c48bd03 100644 --- a/src/diagnostics/MOM_wave_structure.F90 +++ b/src/diagnostics/MOM_wave_structure.F90 @@ -21,7 +21,7 @@ module MOM_wave_structure use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : thermo_var_ptrs use MOM_verticalGrid, only : verticalGrid_type -use regrid_edge_values, only : solve_diag_dominant_tridiag +use regrid_solvers, only : solve_diag_dominant_tridiag implicit none ; private From 10eb7cecc8ffa0b1b90e99ba68925a075f64f749 Mon Sep 17 00:00:00 2001 From: Matthew Harrison Date: Mon, 24 May 2021 14:26:53 -0400 Subject: [PATCH 083/112] reorder code to address restart issue for ice shelf/ --- src/ice_shelf/MOM_ice_shelf.F90 | 89 +++++++++++++++++---------------- 1 file changed, 46 insertions(+), 43 deletions(-) diff --git a/src/ice_shelf/MOM_ice_shelf.F90 b/src/ice_shelf/MOM_ice_shelf.F90 index 488269e974..f223f00f46 100644 --- a/src/ice_shelf/MOM_ice_shelf.F90 +++ b/src/ice_shelf/MOM_ice_shelf.F90 @@ -1632,6 +1632,52 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces_in, endif + ! Set up the restarts. + + call restart_init(param_file, CS%restart_CSp, "Shelf.res") + call register_restart_field(ISS%mass_shelf, "shelf_mass", .true., CS%restart_CSp, & + "Ice shelf mass", "kg m-2") + call register_restart_field(ISS%area_shelf_h, "shelf_area", .true., CS%restart_CSp, & + "Ice shelf area in cell", "m2") + call register_restart_field(ISS%h_shelf, "h_shelf", .true., CS%restart_CSp, & + "ice sheet/shelf thickness", "m") + if (PRESENT(sfc_state_in)) then + if (allocated(sfc_state%taux_shelf) .and. allocated(sfc_state%tauy_shelf)) then + u_desc = var_desc("taux_shelf", "Pa", "the zonal stress on the ocean under ice shelves", & + hor_grid='Cu',z_grid='1') + v_desc = var_desc("tauy_shelf", "Pa", "the meridional stress on the ocean under ice shelves", & + hor_grid='Cv',z_grid='1') + call register_restart_pair(sfc_state%taux_shelf, sfc_state%tauy_shelf, u_desc, v_desc, & + .false., CS%restart_CSp) + endif + endif + + call register_restart_field(US%m_to_Z_restart, "m_to_Z", .false., CS%restart_CSp, & + "Height unit conversion factor", "Z meter-1") + call register_restart_field(US%m_to_L_restart, "m_to_L", .false., CS%restart_CSp, & + "Length unit conversion factor", "L meter-1") + call register_restart_field(US%kg_m3_to_R_restart, "kg_m3_to_R", .false., CS%restart_CSp, & + "Density unit conversion factor", "R m3 kg-1") + if (CS%active_shelf_dynamics) then + call register_restart_field(ISS%hmask, "h_mask", .true., CS%restart_CSp, & + "ice sheet/shelf thickness mask" ,"none") + endif + + if (CS%active_shelf_dynamics) then + ! Allocate CS%dCS and specify additional restarts for ice shelf dynamics + call register_ice_shelf_dyn_restarts(CS%Grid_in, param_file, CS%dCS, CS%restart_CSp) + endif + + !GMM - I think we do not need to save ustar_shelf and iceshelf_melt in the restart file + !if (.not. CS%solo_ice_sheet) then + ! call register_restart_field(fluxes%ustar_shelf, "ustar_shelf", .false., CS%restart_CSp, & + ! "Friction velocity under ice shelves", "m s-1") + !endif + + CS%restart_output_dir = dirs%restart_output_dir + + + if (new_sim .and. (.not. (CS%override_shelf_movement .and. CS%mass_from_file))) then ! This model is initialized internally or from a file. call initialize_ice_thickness(ISS%h_shelf, ISS%area_shelf_h, ISS%hmask, CS%Grid, CS%Grid_in, US, param_file,& @@ -1705,49 +1751,6 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces_in, endif - ! Set up the restarts. - - call restart_init(param_file, CS%restart_CSp, "Shelf.res") - call register_restart_field(ISS%mass_shelf, "shelf_mass", .true., CS%restart_CSp, & - "Ice shelf mass", "kg m-2") - call register_restart_field(ISS%area_shelf_h, "shelf_area", .true., CS%restart_CSp, & - "Ice shelf area in cell", "m2") - call register_restart_field(ISS%h_shelf, "h_shelf", .true., CS%restart_CSp, & - "ice sheet/shelf thickness", "m") - if (PRESENT(sfc_state_in)) then - if (allocated(sfc_state%taux_shelf) .and. allocated(sfc_state%tauy_shelf)) then - u_desc = var_desc("taux_shelf", "Pa", "the zonal stress on the ocean under ice shelves", & - hor_grid='Cu',z_grid='1') - v_desc = var_desc("tauy_shelf", "Pa", "the meridional stress on the ocean under ice shelves", & - hor_grid='Cv',z_grid='1') - call register_restart_pair(sfc_state%taux_shelf, sfc_state%tauy_shelf, u_desc, v_desc, & - .false., CS%restart_CSp) - endif - endif - - call register_restart_field(US%m_to_Z_restart, "m_to_Z", .false., CS%restart_CSp, & - "Height unit conversion factor", "Z meter-1") - call register_restart_field(US%m_to_L_restart, "m_to_L", .false., CS%restart_CSp, & - "Length unit conversion factor", "L meter-1") - call register_restart_field(US%kg_m3_to_R_restart, "kg_m3_to_R", .false., CS%restart_CSp, & - "Density unit conversion factor", "R m3 kg-1") - if (CS%active_shelf_dynamics) then - call register_restart_field(ISS%hmask, "h_mask", .true., CS%restart_CSp, & - "ice sheet/shelf thickness mask" ,"none") - endif - - if (CS%active_shelf_dynamics) then - ! Allocate CS%dCS and specify additional restarts for ice shelf dynamics - call register_ice_shelf_dyn_restarts(CS%Grid_in, param_file, CS%dCS, CS%restart_CSp) - endif - - !GMM - I think we do not need to save ustar_shelf and iceshelf_melt in the restart file - !if (.not. CS%solo_ice_sheet) then - ! call register_restart_field(fluxes%ustar_shelf, "ustar_shelf", .false., CS%restart_CSp, & - ! "Friction velocity under ice shelves", "m s-1") - !endif - - CS%restart_output_dir = dirs%restart_output_dir CS%Time = Time From ee8420ae0ecb56c2e1401724ced8ffa785da0dbf Mon Sep 17 00:00:00 2001 From: Raphael Dussin Date: Tue, 25 May 2021 08:56:25 -0400 Subject: [PATCH 084/112] rename into more explicit, make units correspond --- .../MOM_shared_initialization.F90 | 25 +++++++++++++------ 1 file changed, 17 insertions(+), 8 deletions(-) diff --git a/src/initialization/MOM_shared_initialization.F90 b/src/initialization/MOM_shared_initialization.F90 index 301db0bbed..a56458145d 100644 --- a/src/initialization/MOM_shared_initialization.F90 +++ b/src/initialization/MOM_shared_initialization.F90 @@ -478,12 +478,13 @@ subroutine set_rotation_beta_plane(f, G, param_file, US) integer :: I, J real :: f_0 ! The reference value of the Coriolis parameter [T-1 ~> s-1] real :: beta ! The meridional gradient of the Coriolis parameter [T-1 m-1 ~> s-1 m-1] - real :: lat_0 ! The reference latitude for the beta plane [degrees] + real :: beta_lat_ref ! The reference latitude for the beta plane [degrees/km/m/cm] real :: y_scl, Rad_Earth real :: T_to_s ! A time unit conversion factor real :: PI character(len=40) :: mdl = "set_rotation_beta_plane" ! This subroutine's name. character(len=200) :: axis_units + character(len=40) :: beta_lat_ref_units call callTree_enter(trim(mdl)//"(), MOM_shared_initialization.F90") @@ -495,9 +496,6 @@ subroutine set_rotation_beta_plane(f, G, param_file, US) call get_param(param_file, mdl, "BETA", beta, & "The northward gradient of the Coriolis parameter with "//& "the betaplane option.", units="m-1 s-1", default=0.0, scale=T_to_s) - call get_param(param_file, mdl, "LAT_0", lat_0, & - "The reference latitude (origin) of the beta-plane", & - units="degrees", default=0.0) call get_param(param_file, mdl, "AXIS_UNITS", axis_units, default="degrees") PI = 4.0*atan(1.0) @@ -505,16 +503,27 @@ subroutine set_rotation_beta_plane(f, G, param_file, US) case ("d") call get_param(param_file, mdl, "RAD_EARTH", Rad_Earth, & "The radius of the Earth.", units="m", default=6.378e6) + beta_lat_ref_units = "degrees" y_scl = PI * Rad_Earth/ 180. - case ("k"); y_scl = 1.E3 - case ("m"); y_scl = 1. - case ("c"); y_scl = 1.E-2 + case ("k") + beta_lat_ref_units = "kilometers" + y_scl = 1.E3 + case ("m") + beta_lat_ref_units = "meters" + y_scl = 1. + case ("c") + beta_lat_ref_units = "centimeters" + y_scl = 1.E-2 case default ; call MOM_error(FATAL, & " set_rotation_beta_plane: unknown AXIS_UNITS = "//trim(axis_units)) end select + call get_param(param_file, mdl, "BETA_LAT_REF", beta_lat_ref, & + "The reference latitude (origin) of the beta-plane", & + units=trim(beta_lat_ref_units), default=0.0) + do I=G%IsdB,G%IedB ; do J=G%JsdB,G%JedB - f(I,J) = f_0 + beta * ( (G%geoLatBu(I,J) - lat_0) * y_scl ) + f(I,J) = f_0 + beta * ( (G%geoLatBu(I,J) - beta_lat_ref) * y_scl ) enddo ; enddo call callTree_leave(trim(mdl)//'()') From 2fc25fbf3c0044dd10cf362c4db0022f0366e8b2 Mon Sep 17 00:00:00 2001 From: Raphael Dussin Date: Tue, 25 May 2021 12:19:44 -0400 Subject: [PATCH 085/112] cm not supported by AXIS_UNITS, removed case --- src/initialization/MOM_shared_initialization.F90 | 3 --- 1 file changed, 3 deletions(-) diff --git a/src/initialization/MOM_shared_initialization.F90 b/src/initialization/MOM_shared_initialization.F90 index a56458145d..daaefd4b98 100644 --- a/src/initialization/MOM_shared_initialization.F90 +++ b/src/initialization/MOM_shared_initialization.F90 @@ -511,9 +511,6 @@ subroutine set_rotation_beta_plane(f, G, param_file, US) case ("m") beta_lat_ref_units = "meters" y_scl = 1. - case ("c") - beta_lat_ref_units = "centimeters" - y_scl = 1.E-2 case default ; call MOM_error(FATAL, & " set_rotation_beta_plane: unknown AXIS_UNITS = "//trim(axis_units)) end select From 1d8e9098043bcfec5dc02f2f2479fdba6d948e5e Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Tue, 25 May 2021 23:20:16 -0400 Subject: [PATCH 086/112] Autoconf: FMS 2019.01.02 test; framework flag The autoconf build was updated to verify that calls to diag_axis_init support the domain_position argument. This was introduced in FMS 2019.01.02, so this acts as an implicit minimum FMS version test. This test is done indirectly by confirming that the valid domain_position values (NORTH, EAST, CENTER) are in diag_axis_mod. A `--with-framework=` flag was also added to select either the FMS1 or FMS2 backend. --- ac/configure.ac | 37 ++++++++++++++++++++++++++++++++++--- 1 file changed, 34 insertions(+), 3 deletions(-) diff --git a/ac/configure.ac b/ac/configure.ac index 6ff4ae5e8b..9cb7147846 100644 --- a/ac/configure.ac +++ b/ac/configure.ac @@ -59,6 +59,18 @@ AS_IF([test "x$with_driver" != "x"], # used to configure a header based on a template. #AC_CONFIG_HEADERS(["$MEM_LAYOUT/MOM_memory.h"]) +# Select the model framework (default: FMS1) +# NOTE: We can phase this out after the FMS1 I/O has been removed from FMS and +# replace with a detection test. For now, it is a user-defined switch. +MODEL_FRAMEWORK=${srcdir}/config_src/infra/FMS1 +AC_ARG_WITH([framework], + AS_HELP_STRING([--with-framework=fms1|fms2], [Select the model framework])) +AS_CASE([with_framework], + [fms1], [MODEL_FRAMEWORK=${srcdir}/config_src/infra/FMS1], + [fms2], [MODEL_FRAMEWORK=${srcdir}/config_src/infra/FMS2], + [MODEL_FRAMEWORK=${srcdir}/config_src/infra/FMS1] +) + # Explicitly assume free-form Fortran AC_LANG(Fortran) @@ -192,6 +204,22 @@ AX_FC_CHECK_LIB([FMS], [fms_init], [fms_mod], ) +# Verify that FMS is at least 2019.01.02 +# NOTE: 2019.01.02 introduced two changes: +# - diag_axis_init supports an optional domain_position argument +# - position values NORTH, EAST, CENTER were added to diag_axis_mod +# For our versioning test, we check the second feature. +AC_MSG_CHECKING([if diag_axis_mod supports domain positions]) +AC_COMPILE_IFELSE( + [AC_LANG_PROGRAM([], [use diag_axis_mod, only: NORTH, EAST, CENTER])], + [AC_MSG_RESULT([yes])], + [ + AC_MSG_RESULT([no]) + AC_MSG_ERROR([diag_axis_mod in MOM6 requires FMS 2019.01.02 or newer.]) + ] +) + + # Search for mkmf build tools AC_PATH_PROG([LIST_PATHS], [list_paths]) AS_IF([test -z "$LIST_PATHS"], [ @@ -216,11 +244,14 @@ AS_IF([test -z "$MKMF"], [ AC_CONFIG_COMMANDS([path_names], [list_paths -l \ ${srcdir}/src \ - ${srcdir}/config_src/infra/FMS1 \ + ${MODEL_FRAMEWORK} \ ${srcdir}/config_src/ext* \ ${DRIVER_DIR} \ - ${MEM_LAYOUT} -], [MEM_LAYOUT=$MEM_LAYOUT DRIVER_DIR=$DRIVER_DIR]) + ${MEM_LAYOUT}], + [MODEL_FRAMEWORK=$MODEL_FRAMEWORK + MEM_LAYOUT=$MEM_LAYOUT + DRIVER_DIR=$DRIVER_DIR] +) AC_CONFIG_COMMANDS([Makefile.mkmf], From 627ae3f5d91ded5695cd62f36e7bcc8b46604e7f Mon Sep 17 00:00:00 2001 From: Kate Hedstrom Date: Thu, 27 May 2021 10:48:23 -0800 Subject: [PATCH 087/112] Tiny cleaning up edits. --- src/parameterizations/vertical/MOM_internal_tide_input.F90 | 2 +- src/user/Kelvin_initialization.F90 | 5 +++-- 2 files changed, 4 insertions(+), 3 deletions(-) diff --git a/src/parameterizations/vertical/MOM_internal_tide_input.F90 b/src/parameterizations/vertical/MOM_internal_tide_input.F90 index 0ede511eb7..4cfb184a1e 100644 --- a/src/parameterizations/vertical/MOM_internal_tide_input.F90 +++ b/src/parameterizations/vertical/MOM_internal_tide_input.F90 @@ -352,7 +352,7 @@ subroutine int_tide_input_init(Time, G, GV, US, param_file, diag, CS, itide) units="m-1", default=8.e-4*atan(1.0), scale=US%L_to_m) call get_param(param_file, mdl, "KAPPA_H2_FACTOR", kappa_h2_factor, & - "A scaling factor for the roughness amplitude with n"//& + "A scaling factor for the roughness amplitude with n "//& "INT_TIDE_DISSIPATION.", units="nondim", default=1.0) call get_param(param_file, mdl, "TKE_ITIDE_MAX", CS%TKE_itide_max, & "The maximum internal tide energy source available to mix "//& diff --git a/src/user/Kelvin_initialization.F90 b/src/user/Kelvin_initialization.F90 index 19297e829d..194704fe53 100644 --- a/src/user/Kelvin_initialization.F90 +++ b/src/user/Kelvin_initialization.F90 @@ -38,7 +38,7 @@ module Kelvin_initialization real :: coast_angle = 0 !< Angle of coastline [rad] real :: coast_offset1 = 0 !< Longshore distance to coastal angle [L ~> m] real :: coast_offset2 = 0 !< Longshore distance to coastal angle [L ~> m] - real :: H0 = 0 !< Bottom depth [Z ~> m]f + real :: H0 = 0 !< Bottom depth [Z ~> m] real :: F_0 !< Coriolis parameter [T-1 ~> s-1] real :: rho_range !< Density range [R ~> kg m-3] real :: rho_0 !< Mean density [R ~> kg m-3] @@ -121,7 +121,8 @@ subroutine Kelvin_initialize_topography(D, G, param_file, max_depth, US) real, dimension(G%isd:G%ied,G%jsd:G%jed), & intent(out) :: D !< Ocean bottom depth in m or Z if US is present type(param_file_type), intent(in) :: param_file !< Parameter file structure - real, intent(in) :: max_depth !< Maximum model depth in the units of D [Z ~> m or m] + real, intent(in) :: max_depth !< Maximum model depth in the units of D + ! [Z ~> m or m] type(unit_scale_type), optional, intent(in) :: US !< A dimensional unit scaling type ! Local variables From 1b957bd547008d7a56573f0a1d3c71f8dd214415 Mon Sep 17 00:00:00 2001 From: Olga Sergienko Date: Thu, 27 May 2021 17:13:10 -0400 Subject: [PATCH 088/112] The ice-shelf friction parameter is changed to a field to allow for its spatial variability. A subroutine initialize_ice_C_basal_friction() is added to initialize this parameter either with a constant value or reading from a file. --- src/ice_shelf/MOM_ice_shelf_dynamics.F90 | 31 ++++++++----- src/ice_shelf/MOM_ice_shelf_initialize.F90 | 52 +++++++++++++++++++++- 2 files changed, 72 insertions(+), 11 deletions(-) diff --git a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 index 91c21237b4..171fbdfc79 100644 --- a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 +++ b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 @@ -25,7 +25,7 @@ module MOM_ice_shelf_dynamics use MOM_coms, only : reproducing_sum, sum_across_PEs, max_across_PEs, min_across_PEs use MOM_checksums, only : hchksum, qchksum use MOM_ice_shelf_initialize, only : initialize_ice_shelf_boundary_channel,initialize_ice_flow_from_file -use MOM_ice_shelf_initialize, only : initialize_ice_shelf_boundary_from_file +use MOM_ice_shelf_initialize, only : initialize_ice_shelf_boundary_from_file,initialize_ice_C_basal_friction implicit none ; private #include @@ -93,7 +93,8 @@ module MOM_ice_shelf_dynamics real, pointer, dimension(:,:) :: basal_traction => NULL() !< The area integrated nonlinear part of "linearized" !! basal stress [R Z L2 T-1 ~> kg s-1]. !! The exact form depends on basal law exponent and/or whether flow is "hybridized" a la Goldberg 2011 - + real, pointer, dimension(:,:) :: C_basal_friction => NULL()!< Coefficient in sliding law tau_b = C u^(n_basal_fric), + !! units= Pa (m yr-1)-(n_basal_fric) real, pointer, dimension(:,:) :: OD_rt => NULL() !< A running total for calculating OD_av. real, pointer, dimension(:,:) :: ground_frac_rt => NULL() !< A running total for calculating ground_frac. real, pointer, dimension(:,:) :: OD_av => NULL() !< The time average open ocean depth [Z ~> m]. @@ -131,8 +132,8 @@ module MOM_ice_shelf_dynamics real :: A_glen_isothermal !< Ice viscosity parameter in Glen's Law, [Pa-3 s-1]. real :: n_glen !< Nonlinearity exponent in Glen's Law real :: eps_glen_min !< Min. strain rate to avoid infinite Glen's law viscosity, [year-1]. - real :: C_basal_friction !< Coefficient in sliding law tau_b = C u^(n_basal_fric), in - !! units= Pa (m yr-1)-(n_basal_fric) +! real :: C_basal_friction !< Coefficient in sliding law tau_b = C u^(n_basal_fric), in +! !! units= Pa (m yr-1)-(n_basal_fric) real :: n_basal_fric !< Exponent in sliding law tau_b = C u^(m_slide) real :: density_ocean_avg !< A typical ocean density [R ~> kg m-3]. This does not affect ocean !! circulation or thermodynamics. It is used to estimate the @@ -259,6 +260,7 @@ subroutine register_ice_shelf_dyn_restarts(G, param_file, CS, restart_CS) allocate( CS%t_shelf(isd:ied,jsd:jed) ) ; CS%t_shelf(:,:) = -10.0 allocate( CS%ice_visc(isd:ied,jsd:jed) ) ; CS%ice_visc(:,:) = 0.0 allocate( CS%basal_traction(isd:ied,jsd:jed) ) ; CS%basal_traction(:,:) = 0.0 + allocate( CS%C_basal_friction(isd:ied,jsd:jed) ) ; CS%C_basal_friction(:,:) = 5.0e10 allocate( CS%OD_av(isd:ied,jsd:jed) ) ; CS%OD_av(:,:) = 0.0 allocate( CS%ground_frac(isd:ied,jsd:jed) ) ; CS%ground_frac(:,:) = 0.0 allocate( CS%taudx_shelf(IsdB:IedB,JsdB:JedB) ) ; CS%taudx_shelf(:,:) = 0.0 @@ -385,10 +387,10 @@ subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_ call get_param(param_file, mdl, "BASAL_FRICTION_EXP", CS%n_basal_fric, & "Exponent in sliding law \tau_b = C u^(n_basal_fric)", & units="none", fail_if_missing=.true.) - call get_param(param_file, mdl, "BASAL_FRICTION_COEFF", CS%C_basal_friction, & - "Coefficient in sliding law \tau_b = C u^(n_basal_fric)", & - units="Pa (m s-1)^(n_basal_fric)", scale=US%kg_m2s_to_RZ_T**CS%n_basal_fric, & - fail_if_missing=.true.) +! call get_param(param_file, mdl, "BASAL_FRICTION_COEFF", CS%C_basal_friction, & +! "Coefficient in sliding law \tau_b = C u^(n_basal_fric)", & +! units="Pa (m s-1)^(n_basal_fric)", scale=US%kg_m2s_to_RZ_T**CS%n_basal_fric, & +! fail_if_missing=.true.) call get_param(param_file, mdl, "DENSITY_ICE", CS%density_ice, & "A typical density of ice.", units="kg m-3", default=917.0, scale=US%kg_m3_to_R) call get_param(param_file, mdl, "CONJUGATE_GRADIENT_TOLERANCE", CS%cg_tolerance, & @@ -521,6 +523,12 @@ subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_ enddo ; enddo call pass_var(CS%calve_mask,G%domain) endif + + ! initialize basal friction coefficients + call initialize_ice_C_basal_friction(CS%C_basal_friction, G, US, param_file) + call pass_var(CS%C_basal_friction, G%domain) + + !initialize boundary conditions call initialize_ice_shelf_boundary_from_file(CS%u_face_mask_bdry, CS%v_face_mask_bdry, & CS%u_bdry_val, CS%v_bdry_val, CS%umask, CS%vmask, CS%h_bdry_val, & CS%thickness_bdry_val, ISS%hmask, ISS%h_shelf, G, US, param_file ) @@ -529,6 +537,8 @@ subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_ call pass_var(CS%thickness_bdry_val, G%domain) call pass_vector(CS%u_bdry_val, CS%v_bdry_val, G%domain, TO_ALL, BGRID_NE) call pass_vector(CS%u_face_mask_bdry, CS%v_face_mask_bdry, G%domain, TO_ALL, BGRID_NE) + + !initialize ice flow velocities from file call initialize_ice_flow_from_file(CS%bed_elev,CS%u_shelf, CS%v_shelf,CS%ground_frac, ISS%hmask,ISS%h_shelf, & G, US, param_file) call pass_vector(CS%u_shelf, CS%v_shelf, G%domain, TO_ALL, BGRID_NE) @@ -2606,7 +2616,8 @@ subroutine calc_shelf_taub(CS, ISS, G, US, u_shlf, v_shlf) umid = ((u_shlf(I,J) + u_shlf(I-1,J-1)) + (u_shlf(I,J-1) + u_shlf(I-1,J))) * 0.25 vmid = ((v_shlf(I,J) + v_shlf(I-1,J-1)) + (v_shlf(I,J-1) + v_shlf(I-1,J))) * 0.25 unorm = sqrt(umid**2 + vmid**2 + eps_min**2*(G%dxT(i,j)**2 + G%dyT(i,j)**2)) - CS%basal_traction(i,j) = G%areaT(i,j) * CS%C_basal_friction * (US%L_T_to_m_s*unorm)**(CS%n_basal_fric-1) +! CS%basal_traction(i,j) = G%areaT(i,j) * CS%C_basal_friction * (US%L_T_to_m_s*unorm)**(CS%n_basal_fric-1) + CS%basal_traction(i,j) = G%areaT(i,j) * CS%C_basal_friction(i,j) * (US%L_T_to_m_s*unorm)**(CS%n_basal_fric-1) endif enddo enddo @@ -3068,7 +3079,7 @@ subroutine ice_shelf_dyn_end(CS) deallocate(CS%u_face_mask, CS%v_face_mask) deallocate(CS%umask, CS%vmask) - deallocate(CS%ice_visc, CS%basal_traction) + deallocate(CS%ice_visc, CS%basal_traction,CS%C_basal_friction) deallocate(CS%OD_rt, CS%OD_av) deallocate(CS%t_bdry_val, CS%bed_elev) deallocate(CS%ground_frac, CS%ground_frac_rt) diff --git a/src/ice_shelf/MOM_ice_shelf_initialize.F90 b/src/ice_shelf/MOM_ice_shelf_initialize.F90 index c77864f114..19f34f293e 100644 --- a/src/ice_shelf/MOM_ice_shelf_initialize.F90 +++ b/src/ice_shelf/MOM_ice_shelf_initialize.F90 @@ -20,7 +20,7 @@ module MOM_ice_shelf_initialize public initialize_ice_shelf_boundary_channel public initialize_ice_flow_from_file public initialize_ice_shelf_boundary_from_file - +public initialize_ice_C_basal_friction ! A note on unit descriptions in comments: MOM6 uses units that can be rescaled for dimensional ! consistency testing. These are noted in comments with units like Z, H, L, and T, along with ! their mks counterparts with notation like "a velocity [Z T-1 ~> m s-1]". If the units @@ -570,4 +570,54 @@ subroutine initialize_ice_shelf_boundary_from_file(u_face_mask_bdry, v_face_mask enddo end subroutine initialize_ice_shelf_boundary_from_file + +!> Initialize ice basal friction +subroutine initialize_ice_C_basal_friction(C_basal_friction, G, US, PF) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(inout) :: C_basal_friction !< Ice-shelf thickness + type(unit_scale_type), intent(in) :: US !< A structure containing unit conversion factors + type(param_file_type), intent(in) :: PF !< A structure to parse for run-time parameters + +! integer :: i, j + real :: C_friction + character(len=40) :: mdl = "initialize_ice_basal_friction" ! This subroutine's name. + character(len=200) :: config + character(len=200) :: varname + character(len=200) :: inputdir, filename, C_friction_file + + call get_param(PF, mdl, "ICE_BASAL_FRICTION_CONFIG", config, & + "This specifies how the initial ice profile is specified. "//& + "Valid values are: CONSTANT and FILE.", & + fail_if_missing=.true.) + + if (trim(config)=="CONSTANT") then + call get_param(PF, mdl, "BASAL_FRICTION_COEFF", C_friction, & + "Coefficient in sliding law.", units="Pa (m s-1)^(n_basal_fric)", default=5.e10) + + C_basal_friction(:,:) = C_friction + elseif (trim(config)=="FILE") then + call MOM_mesg(" MOM_ice_shelf.F90, initialize_ice_shelf: reading friction coefficients") + call get_param(PF, mdl, "INPUTDIR", inputdir, default=".") + inputdir = slasher(inputdir) + + call get_param(PF, mdl, "BASAL_FRICTION_FILE", C_friction_file, & + "The file from which the boundary condiions are read.", & + default="ice_basal_friction.nc") + filename = trim(inputdir)//trim(C_friction_file) + call log_param(PF, mdl, "INPUTDIR/BASAL_FRICTIOM_FILE", filename) + + call get_param(PF, mdl, "BASAL_FRICTION_VARNAME", varname, & + "The variable to use in basal traction.", & + default="tau_b_beta") + + if (.not.file_exists(filename, G%Domain)) call MOM_error(FATAL, & + " initialize_ice_basal_friction_from_file: Unable to open "//trim(filename)) + + call MOM_read_data(filename,trim(varname),C_basal_friction,G%Domain) + + endif +end subroutine + + end module MOM_ice_shelf_initialize From b583c00d88d73601038a352a6d79f62959536c7c Mon Sep 17 00:00:00 2001 From: Kate Hedstrom Date: Thu, 27 May 2021 15:14:55 -0800 Subject: [PATCH 089/112] Change to masking of u,v sponges. - Before, u,v sponges were masking using the tracer mask and generating weirdness at the tile boundaries for u and v. --- .../vertical/MOM_ALE_sponge.F90 | 25 ++++++++++++------- 1 file changed, 16 insertions(+), 9 deletions(-) diff --git a/src/parameterizations/vertical/MOM_ALE_sponge.F90 b/src/parameterizations/vertical/MOM_ALE_sponge.F90 index ce6dab906f..5d9af389c9 100644 --- a/src/parameterizations/vertical/MOM_ALE_sponge.F90 +++ b/src/parameterizations/vertical/MOM_ALE_sponge.F90 @@ -872,6 +872,8 @@ subroutine apply_ALE_sponge(h, dt, G, GV, US, CS, Time) real, allocatable, dimension(:,:,:) :: sp_val_u ! A temporary array for fields real, allocatable, dimension(:,:,:) :: sp_val_v ! A temporary array for fields real, allocatable, dimension(:,:,:) :: mask_z ! A temporary array for field mask at h pts + real, allocatable, dimension(:,:,:) :: mask_u ! A temporary array for field mask at u pts + real, allocatable, dimension(:,:,:) :: mask_v ! A temporary array for field mask at v pts real, allocatable, dimension(:,:,:) :: tmp !< A temporary array for thermodynamic sponge tendency diagnostics, real, allocatable, dimension(:,:,:) :: tmp_u !< A temporary array for u sponge acceleration diagnostics real, allocatable, dimension(:,:,:) :: tmp_v !< A temporary array for v sponge acceleration diagnostics @@ -994,9 +996,11 @@ subroutine apply_ALE_sponge(h, dt, G, GV, US, CS, Time) nz_data = CS%Ref_val_u%nz_data allocate(sp_val(G%isd:G%ied,G%jsd:G%jed,1:nz_data)) allocate(sp_val_u(G%isdB:G%iedB,G%jsd:G%jed,1:nz_data)) - allocate(mask_z(G%isdB:G%iedB,G%jsd:G%jed,1:nz_data)) + allocate(mask_u(G%isdB:G%iedB,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 sp_val_u(:,:,:) = 0.0 + mask_u(:,:,:) = 0.0 mask_z(:,:,:) = 0.0 ! 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, & @@ -1006,7 +1010,8 @@ subroutine apply_ALE_sponge(h, dt, G, GV, US, CS, Time) call pass_var(sp_val,G%Domain) do j=CS%jsc,CS%jec; do I=CS%iscB,CS%iecB - sp_val_u(I,j,1:nz_data) = 0.5*(sp_val(i,j,1:nz_data)+sp_val(i+1,j,1:nz_data)) + sp_val_u(I,j,1:nz_data) = 0.5*(sp_val(i,j,1:nz_data)+sp_val(i+1,j,1:nz_data)) + mask_u(I,j,1:nz_data) = max(mask_z(i,j,1:nz_data),mask_z(i+1,j,1:nz_data)) enddo ; enddo allocate( hsrc(nz_data) ) @@ -1019,7 +1024,7 @@ subroutine apply_ALE_sponge(h, dt, G, GV, US, CS, Time) ! Build the source grid zTopOfCell = 0. ; zBottomOfCell = 0. ; nPoints = 0; hsrc(:) = 0.0; tmpT1d(:) = -99.9 do k=1,nz_data - if (mask_z(i,j,k) == 1.0) then + if (mask_u(i,j,k) == 1.0) then zBottomOfCell = -min( z_edges_in(k+1), G%bathyT(i,j) ) tmpT1d(k) = sp_val_u(i,j,k) elseif (k>1) then @@ -1030,17 +1035,18 @@ subroutine apply_ALE_sponge(h, dt, G, GV, US, CS, Time) endif hsrc(k) = zTopOfCell - zBottomOfCell if (hsrc(k)>0.) nPoints = nPoints + 1 - zTopOfCell = zBottomOfCell ! Bottom becomes top for next value of k + 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(i,j) ) CS%Ref_val_u%h(1:nz_data,c) = GV%Z_to_H*hsrc(1:nz_data) enddo - deallocate(sp_val, sp_val_u, mask_z, hsrc, tmpT1d) + deallocate(sp_val, sp_val_u, mask_u, mask_z, hsrc, tmpT1d) nz_data = CS%Ref_val_v%nz_data allocate(sp_val( G%isd:G%ied,G%jsd:G%jed,1:nz_data)) allocate(sp_val_v(G%isd:G%ied,G%jsdB:G%jedB,1:nz_data)) - allocate(mask_z(G%isd:G%ied,G%jsdB:G%jedB,1:nz_data)) + allocate(mask_v(G%isd:G%ied,G%jsdB:G%jedB,1:nz_data)) + allocate(mask_z(G%isd:G%ied,G%jsd:G%jed,1:nz_data)) sp_val(:,:,:) = 0.0 sp_val_v(:,:,:) = 0.0 mask_z(:,:,:) = 0.0 @@ -1052,6 +1058,7 @@ subroutine apply_ALE_sponge(h, dt, G, GV, US, CS, Time) call pass_var(sp_val,G%Domain) do J=CS%jscB,CS%jecB; do i=CS%isc,CS%iec sp_val_v(i,J,1:nz_data) = 0.5*(sp_val(i,j,1:nz_data)+sp_val(i,j+1,1:nz_data)) + mask_v(i,J,1:nz_data) = max(mask_z(i,j,1:nz_data),mask_z(i,j+1,1:nz_data)) enddo ; enddo !call pass_var(mask_z,G%Domain) allocate( hsrc(nz_data) ) @@ -1064,7 +1071,7 @@ subroutine apply_ALE_sponge(h, dt, G, GV, US, CS, Time) ! Build the source grid zTopOfCell = 0. ; zBottomOfCell = 0. ; nPoints = 0; hsrc(:) = 0.0; tmpT1d(:) = -99.9 do k=1,nz_data - if (mask_z(i,j,k) == 1.0) then + if (mask_v(i,j,k) == 1.0) then zBottomOfCell = -min( z_edges_in(k+1), G%bathyT(i,j) ) tmpT1d(k) = sp_val_v(i,j,k) elseif (k>1) then @@ -1081,7 +1088,7 @@ subroutine apply_ALE_sponge(h, dt, G, GV, US, CS, Time) hsrc(nz_data) = hsrc(nz_data) + ( zTopOfCell + G%bathyT(i,j) ) CS%Ref_val_v%h(1:nz_data,c) = GV%Z_to_H*hsrc(1:nz_data) enddo - deallocate(sp_val, sp_val_v, mask_z, hsrc, tmpT1d) + deallocate(sp_val, sp_val_v, mask_v, mask_z, hsrc, tmpT1d) endif nz_data = CS%Ref_val_u%nz_data @@ -1282,7 +1289,7 @@ subroutine rotate_ALE_sponge(sponge_in, G_in, sponge, G, GV, turns, param_file) endif enddo - ! TODO: var_u and var_v sponge dampling is not yet supported. + ! TODO: var_u and var_v sponge damping is not yet supported. if (associated(sponge_in%var_u%p) .or. associated(sponge_in%var_v%p)) & call MOM_error(FATAL, "Rotation of ALE sponge velocities is not yet " & // "implemented.") From 616413a586d0595508c1305db09f64d64acad357 Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Fri, 30 Apr 2021 18:19:22 -0400 Subject: [PATCH 090/112] Memory management cleanup and initialization fixes This patch fixes up and enables several of the derived type destructor functions (`_end()`) used to handle memory management of the model. - Two uninitialized logical flags which would cause errors in optimized builds have also been fixed. * `Visbeck_S_max` in thickness diffusion is now initialized to zero, which acts to disable it in subsequent operations. * `remap_answers_2018` is now unset when `NDIFF_CONTINUOUS` is false. - Several of the destructor functions were restructured so that they do not explicitly deallocate their pointer inputs. This will allow us to stage the functions as formal destructors for the derived types via the `final` keyword in a later patch. It also allows us to pass the inputs on stack rather than as pointers. * `barotropic_end` * `continuity_end` * `CoriolisAdv_end` * `deallocate_MOM_domain` * `diabatic_driver_end` * `geothermal_end` * `hor_visc_end` * `MEKE_end` * `MOM_CVMix_conv_end` * `MOM_CVMix_ddiff_end` * `MOM_CVMix_shear_end` * `MOM_diagnostics_end` * `MOM_regridding_end` * `MOM_sum_output_end` * `PressureForce_end` * `set_diffusivity_end` * `thickness_diffuse_end` * `tidal_forcing_end` * `VarMix_end` * `vertvisc_end` - In a few cases, the deallocations were re-ordered to match the reversed order of allocation. * `MOM_CVMix_conv_mod` * `MOM_CVMix_ddiff_mod` * `MOM_CVMix_shear_mod` - A few constructors always initialized their control structures, even when disabled. In some of these cases, the allocation is now skipped if the corresponding feature is disabled. - `diag_mediator_end` now includes the following changes: * `axes_grp_end` was introduced to deallocate axes_grp types. The `remap_axes*` are now deallocated. * We now cycles through the diagnostic list and deallocate the supplemental diagnostics. * Downsampled diagnostic masks and remaps are now deallocated - The initialized `blockName` of the param file parser are now dellocated before reinitializing them. Although the existing value is still lost, it is at least now deallocated from heap. - A bug was fixed in `hor_visc_end`; Smag_Ah and Leith_Ah areas were incorrectly swapped. The principal motivation for this work is to eliminate any errors detected by valgrind, and to integrated automated memcheck testing to the verification test suite. --- src/core/MOM.F90 | 90 ++++++++++++--- src/core/MOM_CoriolisAdv.F90 | 3 +- src/core/MOM_PressureForce.F90 | 4 +- src/core/MOM_barotropic.F90 | 24 ++-- src/core/MOM_continuity.F90 | 5 +- src/core/MOM_dynamics_split_RK2.F90 | 40 ++++++- src/core/MOM_grid.F90 | 12 +- src/diagnostics/MOM_diagnostics.F90 | 20 ++-- src/diagnostics/MOM_sum_output.F90 | 3 +- src/framework/MOM_diag_mediator.F90 | 104 +++++++++++++++--- src/framework/MOM_diag_remap.F90 | 3 + src/framework/MOM_dyn_horgrid.F90 | 8 +- src/framework/MOM_file_parser.F90 | 3 + src/parameterizations/lateral/MOM_MEKE.F90 | 29 +++-- .../lateral/MOM_hor_visc.F90 | 4 +- .../lateral/MOM_lateral_mixing_coeffs.F90 | 77 +++++++++++-- .../lateral/MOM_thickness_diffuse.F90 | 19 +++- .../lateral/MOM_tidal_forcing.F90 | 7 +- .../vertical/MOM_CVMix_conv.F90 | 8 +- .../vertical/MOM_CVMix_ddiff.F90 | 6 +- .../vertical/MOM_CVMix_shear.F90 | 45 ++++---- .../vertical/MOM_diabatic_driver.F90 | 54 +++++---- .../vertical/MOM_geothermal.F90 | 8 +- .../vertical/MOM_opacity.F90 | 6 +- .../vertical/MOM_set_diffusivity.F90 | 29 +++-- .../vertical/MOM_tidal_mixing.F90 | 51 +++++---- .../vertical/MOM_vert_friction.F90 | 8 +- src/tracer/MOM_neutral_diffusion.F90 | 26 +++-- 28 files changed, 482 insertions(+), 214 deletions(-) diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index 9ccb8eb8c6..e24eb36623 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -24,7 +24,8 @@ module MOM use MOM_diag_mediator, only : diag_save_grids, diag_restore_grids use MOM_diag_mediator, only : diag_copy_storage_to_diag, diag_copy_diag_to_storage use MOM_domains, only : MOM_domains_init -use MOM_domains, only : sum_across_PEs, pass_var, pass_vector, clone_MOM_domain +use MOM_domains, only : sum_across_PEs, pass_var, pass_vector +use MOM_domains, only : clone_MOM_domain, deallocate_MOM_domain use MOM_domains, only : To_North, To_East, To_South, To_West use MOM_domains, only : To_All, Omit_corners, CGRID_NE, SCALAR_PAIR use MOM_domains, only : create_group_pass, do_group_pass, group_pass_type @@ -63,6 +64,7 @@ module MOM use MOM_diagnostics, only : register_surface_diags, write_static_fields use MOM_diagnostics, only : post_surface_dyn_diags, post_surface_thermo_diags use MOM_diagnostics, only : diagnostics_CS, surface_diag_IDs, transport_diag_IDs +use MOM_diagnostics, only : MOM_diagnostics_end use MOM_dynamics_unsplit, only : step_MOM_dyn_unsplit, register_restarts_dyn_unsplit use MOM_dynamics_unsplit, only : initialize_dyn_unsplit, end_dyn_unsplit use MOM_dynamics_unsplit, only : MOM_dyn_unsplit_CS @@ -83,9 +85,10 @@ module MOM use MOM_hor_index, only : hor_index_type, hor_index_init use MOM_hor_index, only : rotate_hor_index use MOM_interface_heights, only : find_eta -use MOM_lateral_mixing_coeffs, only : calc_slope_functions, VarMix_init +use MOM_lateral_mixing_coeffs, only : calc_slope_functions, VarMix_init, VarMix_end use MOM_lateral_mixing_coeffs, only : calc_resoln_function, calc_depth_function, VarMix_CS -use MOM_MEKE, only : MEKE_init, MEKE_alloc_register_restart, step_forward_MEKE, MEKE_CS +use MOM_MEKE, only : MEKE_alloc_register_restart, step_forward_MEKE +use MOM_MEKE, only : MEKE_CS, MEKE_init, MEKE_end use MOM_MEKE_types, only : MEKE_type use MOM_mixed_layer_restrat, only : mixedlayer_restrat, mixedlayer_restrat_init, mixedlayer_restrat_CS use MOM_mixed_layer_restrat, only : mixedlayer_restrat_register_restarts @@ -95,15 +98,18 @@ module MOM use MOM_open_boundary, only : open_boundary_register_restarts use MOM_open_boundary, only : update_segment_tracer_reservoirs use MOM_open_boundary, only : rotate_OBC_config, rotate_OBC_init -use MOM_set_visc, only : set_viscous_BBL, set_viscous_ML, set_visc_init +use MOM_set_visc, only : set_viscous_BBL, set_viscous_ML use MOM_set_visc, only : set_visc_register_restarts, set_visc_CS +use MOM_set_visc, only : set_visc_init, set_visc_end use MOM_shared_initialization, only : write_ocean_geometry_file use MOM_sponge, only : init_sponge_diags, sponge_CS use MOM_state_initialization, only : MOM_initialize_state use MOM_sum_output, only : write_energy, accumulate_net_input -use MOM_sum_output, only : MOM_sum_output_init, sum_output_CS +use MOM_sum_output, only : MOM_sum_output_init, MOM_sum_output_end +use MOM_sum_output, only : sum_output_CS use MOM_ALE_sponge, only : init_ALE_sponge_diags, ALE_sponge_CS -use MOM_thickness_diffuse, only : thickness_diffuse, thickness_diffuse_init, thickness_diffuse_CS +use MOM_thickness_diffuse, only : thickness_diffuse, thickness_diffuse_init +use MOM_thickness_diffuse, only : thickness_diffuse_end, thickness_diffuse_CS use MOM_tracer_advect, only : advect_tracer, tracer_advect_init use MOM_tracer_advect, only : tracer_advect_end, tracer_advect_CS use MOM_tracer_hor_diff, only : tracer_hordiff, tracer_hor_diff_init @@ -3530,28 +3536,28 @@ end subroutine get_ocean_stocks subroutine MOM_end(CS) type(MOM_control_struct), pointer :: CS !< MOM control structure + call MOM_sum_output_end(CS%sum_output_CSp) + if (CS%use_ALE_algorithm) call ALE_end(CS%ALE_CSp) - DEALLOC_(CS%u) ; DEALLOC_(CS%v) ; DEALLOC_(CS%h) - DEALLOC_(CS%uh) ; DEALLOC_(CS%vh) - - if (associated(CS%tv%T)) then - DEALLOC_(CS%T) ; CS%tv%T => NULL() ; DEALLOC_(CS%S) ; CS%tv%S => NULL() - endif - if (associated(CS%tv%frazil)) deallocate(CS%tv%frazil) - if (associated(CS%tv%salt_deficit)) deallocate(CS%tv%salt_deficit) - if (associated(CS%Hml)) deallocate(CS%Hml) + ! NOTE: Allocated in PressureForce_FV_Bouss + if (associated(CS%tv%varT)) deallocate(CS%tv%varT) call tracer_advect_end(CS%tracer_adv_CSp) call tracer_hor_diff_end(CS%tracer_diff_CSp) call tracer_registry_end(CS%tracer_Reg) call tracer_flow_control_end(CS%tracer_flow_CSp) - call diabatic_driver_end(CS%diabatic_CSp) + if (.not. CS%adiabatic) then + call diabatic_driver_end(CS%diabatic_CSp) + deallocate(CS%diabatic_CSp) + endif + + call MOM_diagnostics_end(CS%diagnostics_CSp, CS%ADp, CS%CDp) + deallocate(CS%diagnostics_CSp) if (CS%offline_tracer_mode) call offline_transport_end(CS%offline_CSp) - DEALLOC_(CS%uhtr) ; DEALLOC_(CS%vhtr) if (CS%split) then call end_dyn_split_RK2(CS%dyn_split_RK2_CSp) elseif (CS%use_RK2) then @@ -3559,15 +3565,63 @@ subroutine MOM_end(CS) else call end_dyn_unsplit(CS%dyn_unsplit_CSp) endif + + call thickness_diffuse_end(CS%thickness_diffuse_CSp, CS%CDp) + deallocate(CS%thickness_diffuse_CSp) + + if (associated(CS%VarMix)) then + call VarMix_end(CS%VarMix) + deallocate(CS%VarMix) + endif + + if (associated(CS%mixedlayer_restrat_CSp)) & + deallocate(CS%mixedlayer_restrat_CSp) + + if (associated(CS%set_visc_CSp)) & + call set_visc_end(CS%visc, CS%set_visc_CSp) + + if (associated(CS%MEKE_CSp)) deallocate(CS%MEKE_CSp) + + if (associated(CS%MEKE)) then + call MEKE_end(CS%MEKE) + deallocate(CS%MEKE) + endif + + if (associated(CS%tv%internal_heat)) deallocate(CS%tv%internal_heat) + if (associated(CS%tv%TempxPmE)) deallocate(CS%tv%TempxPmE) + DEALLOC_(CS%ave_ssh_ibc) ; DEALLOC_(CS%ssh_rint) + + ! TODO: debug_truncations deallocation + + DEALLOC_(CS%uhtr) ; DEALLOC_(CS%vhtr) + + if (associated(CS%Hml)) deallocate(CS%Hml) + if (associated(CS%tv%salt_deficit)) deallocate(CS%tv%salt_deficit) + if (associated(CS%tv%frazil)) deallocate(CS%tv%frazil) + + if (associated(CS%tv%T)) then + DEALLOC_(CS%T) ; CS%tv%T => NULL() ; DEALLOC_(CS%S) ; CS%tv%S => NULL() + endif + + DEALLOC_(CS%u) ; DEALLOC_(CS%v) ; DEALLOC_(CS%h) + DEALLOC_(CS%uh) ; DEALLOC_(CS%vh) + if (associated(CS%update_OBC_CSp)) call OBC_register_end(CS%update_OBC_CSp) call verticalGridEnd(CS%GV) call unit_scaling_end(CS%US) call MOM_grid_end(CS%G) - deallocate(CS) + if (CS%debug .or. CS%G%symmetric) & + call deallocate_MOM_domain(CS%G%Domain_aux) + + if (CS%rotate_index) & + call deallocate_MOM_domain(CS%G%Domain) + call deallocate_MOM_domain(CS%G_in%domain) + + deallocate(CS) end subroutine MOM_end !> \namespace mom diff --git a/src/core/MOM_CoriolisAdv.F90 b/src/core/MOM_CoriolisAdv.F90 index b12d3e37e7..fed58562b4 100644 --- a/src/core/MOM_CoriolisAdv.F90 +++ b/src/core/MOM_CoriolisAdv.F90 @@ -1330,8 +1330,7 @@ end subroutine CoriolisAdv_init !> Destructor for coriolisadv_cs subroutine CoriolisAdv_end(CS) - type(CoriolisAdv_CS), pointer :: CS !< Control structure fro MOM_CoriolisAdv - deallocate(CS) + type(CoriolisAdv_CS), intent(inout) :: CS !< Control structure fro MOM_CoriolisAdv end subroutine CoriolisAdv_end !> \namespace mom_coriolisadv diff --git a/src/core/MOM_PressureForce.F90 b/src/core/MOM_PressureForce.F90 index b4da255ddb..2316bb9725 100644 --- a/src/core/MOM_PressureForce.F90 +++ b/src/core/MOM_PressureForce.F90 @@ -120,15 +120,13 @@ end subroutine PressureForce_init !> Deallocate the pressure force control structure subroutine PressureForce_end(CS) - type(PressureForce_CS), pointer :: CS !< Pressure force control structure + type(PressureForce_CS), intent(inout) :: CS !< Pressure force control structure if (CS%Analytic_FV_PGF) then call PressureForce_FV_end(CS%PressureForce_FV_CSp) else call PressureForce_Mont_end(CS%PressureForce_Mont_CSp) endif - - if (associated(CS)) deallocate(CS) end subroutine PressureForce_end !> \namespace mom_pressureforce diff --git a/src/core/MOM_barotropic.F90 b/src/core/MOM_barotropic.F90 index 590366f32f..f8a4a89db1 100644 --- a/src/core/MOM_barotropic.F90 +++ b/src/core/MOM_barotropic.F90 @@ -7,10 +7,10 @@ module MOM_barotropic use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end, CLOCK_ROUTINE use MOM_diag_mediator, only : post_data, query_averaging_enabled, register_diag_field use MOM_diag_mediator, only : safe_alloc_ptr, diag_ctrl, enable_averaging -use MOM_domains, only : min_across_PEs, clone_MOM_domain, pass_vector +use MOM_domains, only : min_across_PEs, clone_MOM_domain, deallocate_MOM_domain use MOM_domains, only : To_All, Scalar_Pair, AGRID, CORNER, MOM_domain_type use MOM_domains, only : create_group_pass, do_group_pass, group_pass_type -use MOM_domains, only : start_group_pass, complete_group_pass, pass_var +use MOM_domains, only : start_group_pass, complete_group_pass, pass_var, pass_vector use MOM_error_handler, only : MOM_error, MOM_mesg, FATAL, WARNING, is_root_pe use MOM_file_parser, only : get_param, log_param, log_version, param_file_type use MOM_forcing_type, only : mech_forcing @@ -4998,19 +4998,25 @@ end subroutine barotropic_get_tav !> Clean up the barotropic control structure. subroutine barotropic_end(CS) - type(barotropic_CS), pointer :: CS !< Control structure to clear out. - DEALLOC_(CS%frhatu) ; DEALLOC_(CS%frhatv) - DEALLOC_(CS%IDatu) ; DEALLOC_(CS%IDatv) - DEALLOC_(CS%ubtav) ; DEALLOC_(CS%vbtav) - DEALLOC_(CS%eta_cor) + type(barotropic_CS), intent(inout) :: CS !< Control structure to clear out. + + call destroy_BT_OBC(CS%BT_OBC) + + ! Allocated in barotropic_init, called in timestep initialization DEALLOC_(CS%ua_polarity) ; DEALLOC_(CS%va_polarity) + DEALLOC_(CS%IDatu) ; DEALLOC_(CS%IDatv) if (CS%bound_BT_corr) then DEALLOC_(CS%eta_cor_bound) endif + DEALLOC_(CS%eta_cor) + DEALLOC_(CS%frhatu) ; DEALLOC_(CS%frhatv) - call destroy_BT_OBC(CS%BT_OBC) + if (associated(CS%frhatu1)) deallocate(CS%frhatu1) + if (associated(CS%frhatv1)) deallocate(CS%frhatv1) + call deallocate_MOM_domain(CS%BT_domain) - deallocate(CS) + ! Allocated in restart registration, prior to timestep initialization + DEALLOC_(CS%ubtav) ; DEALLOC_(CS%vbtav) end subroutine barotropic_end !> This subroutine is used to register any fields from MOM_barotropic.F90 diff --git a/src/core/MOM_continuity.F90 b/src/core/MOM_continuity.F90 index 1ad37a82b8..480568c545 100644 --- a/src/core/MOM_continuity.F90 +++ b/src/core/MOM_continuity.F90 @@ -167,14 +167,11 @@ end function continuity_stencil !> Destructor for continuity_cs. subroutine continuity_end(CS) - type(continuity_CS), pointer :: CS !< Control structure for mom_continuity. + type(continuity_CS), intent(inout) :: CS !< Control structure for mom_continuity. if (CS%continuity_scheme == PPM_SCHEME) then call continuity_PPM_end(CS%PPM_CSp) endif - - deallocate(CS) - end subroutine continuity_end end module MOM_continuity diff --git a/src/core/MOM_dynamics_split_RK2.F90 b/src/core/MOM_dynamics_split_RK2.F90 index ef7da5c291..29a1f44d68 100644 --- a/src/core/MOM_dynamics_split_RK2.F90 +++ b/src/core/MOM_dynamics_split_RK2.F90 @@ -36,27 +36,33 @@ module MOM_dynamics_split_RK2 use MOM_ALE, only : ALE_CS use MOM_barotropic, only : barotropic_init, btstep, btcalc, bt_mass_source use MOM_barotropic, only : register_barotropic_restarts, set_dtbt, barotropic_CS +use MOM_barotropic, only : barotropic_end use MOM_boundary_update, only : update_OBC_data, update_OBC_CS -use MOM_continuity, only : continuity, continuity_init, continuity_CS +use MOM_continuity, only : continuity, continuity_CS +use MOM_continuity, only : continuity_init, continuity_end use MOM_continuity, only : continuity_stencil -use MOM_CoriolisAdv, only : CorAdCalc, CoriolisAdv_init, CoriolisAdv_CS +use MOM_CoriolisAdv, only : CorAdCalc, CoriolisAdv_CS +use MOM_CoriolisAdv, only : CoriolisAdv_init, CoriolisAdv_end use MOM_debugging, only : check_redundant use MOM_grid, only : ocean_grid_type use MOM_hor_index, only : hor_index_type -use MOM_hor_visc, only : horizontal_viscosity, hor_visc_init, hor_visc_CS +use MOM_hor_visc, only : horizontal_viscosity, hor_visc_CS +use MOM_hor_visc, only : hor_visc_init, hor_visc_end use MOM_interface_heights, only : find_eta use MOM_lateral_mixing_coeffs, only : VarMix_CS use MOM_MEKE_types, only : MEKE_type use MOM_open_boundary, only : ocean_OBC_type, radiation_open_bdry_conds use MOM_open_boundary, only : open_boundary_zero_normal_flow use MOM_open_boundary, only : open_boundary_test_extern_h, update_OBC_ramp -use MOM_PressureForce, only : PressureForce, PressureForce_init, PressureForce_CS +use MOM_PressureForce, only : PressureForce, PressureForce_CS +use MOM_PressureForce, only : PressureForce_init, PressureForce_end use MOM_set_visc, only : set_viscous_ML, set_visc_CS use MOM_thickness_diffuse, only : thickness_diffuse_CS -use MOM_tidal_forcing, only : tidal_forcing_init, tidal_forcing_CS +use MOM_tidal_forcing, only : tidal_forcing_CS +use MOM_tidal_forcing, only : tidal_forcing_init, tidal_forcing_end use MOM_unit_scaling, only : unit_scale_type use MOM_vert_friction, only : vertvisc, vertvisc_coef, vertvisc_remnant -use MOM_vert_friction, only : vertvisc_init, vertvisc_CS +use MOM_vert_friction, only : vertvisc_init, vertvisc_end, vertvisc_CS use MOM_vert_friction, only : updateCFLtruncationValue use MOM_verticalGrid, only : verticalGrid_type, get_thickness_units use MOM_verticalGrid, only : get_flux_units, get_tr_flux_units @@ -1530,6 +1536,28 @@ end subroutine initialize_dyn_split_RK2 subroutine end_dyn_split_RK2(CS) type(MOM_dyn_split_RK2_CS), pointer :: CS !< module control structure + call barotropic_end(CS%barotropic_CSp) + deallocate(CS%barotropic_CSp) + + call vertvisc_end(CS%vertvisc_CSp) + deallocate(CS%vertvisc_CSp) + + call hor_visc_end(CS%hor_visc_CSp) + + call PressureForce_end(CS%PressureForce_CSp) + deallocate(CS%PressureForce_CSp) + + if (associated(CS%tides_CSp)) then + call tidal_forcing_end(CS%tides_CSp) + deallocate(CS%tides_CSp) + endif + + call CoriolisAdv_end(CS%CoriolisAdv_Csp) + deallocate(CS%CoriolisAdv_CSp) + + call continuity_end(CS%continuity_CSp) + deallocate(CS%continuity_CSp) + DEALLOC_(CS%diffu) ; DEALLOC_(CS%diffv) DEALLOC_(CS%CAu) ; DEALLOC_(CS%CAv) DEALLOC_(CS%PFu) ; DEALLOC_(CS%PFv) diff --git a/src/core/MOM_grid.F90 b/src/core/MOM_grid.F90 index 60219c1c68..1ac5e39dd5 100644 --- a/src/core/MOM_grid.F90 +++ b/src/core/MOM_grid.F90 @@ -597,6 +597,13 @@ end subroutine allocate_metrics subroutine MOM_grid_end(G) type(ocean_grid_type), intent(inout) :: G !< The horizontal grid type + deallocate(G%Block) + + if (G%bathymetry_at_vel) then + DEALLOC_(G%Dblock_u) ; DEALLOC_(G%Dopen_u) + DEALLOC_(G%Dblock_v) ; DEALLOC_(G%Dopen_v) + endif + DEALLOC_(G%dxT) ; DEALLOC_(G%dxCu) ; DEALLOC_(G%dxCv) ; DEALLOC_(G%dxBu) DEALLOC_(G%IdxT) ; DEALLOC_(G%IdxCu) ; DEALLOC_(G%IdxCv) ; DEALLOC_(G%IdxBu) @@ -622,11 +629,6 @@ subroutine MOM_grid_end(G) DEALLOC_(G%dF_dx) ; DEALLOC_(G%dF_dy) DEALLOC_(G%sin_rot) ; DEALLOC_(G%cos_rot) - if (G%bathymetry_at_vel) then - DEALLOC_(G%Dblock_u) ; DEALLOC_(G%Dopen_u) - DEALLOC_(G%Dblock_v) ; DEALLOC_(G%Dopen_v) - endif - deallocate(G%gridLonT) ; deallocate(G%gridLatT) deallocate(G%gridLonB) ; deallocate(G%gridLatB) diff --git a/src/diagnostics/MOM_diagnostics.F90 b/src/diagnostics/MOM_diagnostics.F90 index 5ac8777a19..0bcf1a9c94 100644 --- a/src/diagnostics/MOM_diagnostics.F90 +++ b/src/diagnostics/MOM_diagnostics.F90 @@ -2297,11 +2297,13 @@ subroutine set_dependent_diagnostics(MIS, ADp, CDp, G, GV, CS) end subroutine set_dependent_diagnostics !> Deallocate memory associated with the diagnostics module -subroutine MOM_diagnostics_end(CS, ADp) - type(diagnostics_CS), pointer :: CS !< Control structure returned by a - !! previous call to diagnostics_init. - type(accel_diag_ptrs), intent(inout) :: ADp !< structure with pointers to - !! accelerations in momentum equation. +subroutine MOM_diagnostics_end(CS, ADp, CDp) + type(diagnostics_CS), intent(inout) :: CS !< Control structure returned by a + !! previous call to diagnostics_init. + type(accel_diag_ptrs), intent(inout) :: ADp !< structure with pointers to + !! accelerations in momentum equation. + type(cont_diag_ptrs), intent(inout) :: CDp !< Structure pointing to terms in continuity + !! equation. integer :: m if (associated(CS%e)) deallocate(CS%e) @@ -2336,10 +2338,12 @@ subroutine MOM_diagnostics_end(CS, ADp) if (associated(ADp%diag_hfrac_u)) deallocate(ADp%diag_hfrac_u) if (associated(ADp%diag_hfrac_v)) deallocate(ADp%diag_hfrac_v) - do m=1,CS%num_time_deriv ; deallocate(CS%prev_val(m)%p) ; enddo - - deallocate(CS) + ! NOTE: [uv]hGM may be allocated either here or the thickness diffuse module + if (associated(CDp%uhGM)) deallocate(CDp%uhGM) + if (associated(CDp%vhGM)) deallocate(CDp%vhGM) + if (associated(CDp%diapyc_vel)) deallocate(CDp%diapyc_vel) + do m=1,CS%num_time_deriv ; deallocate(CS%prev_val(m)%p) ; enddo end subroutine MOM_diagnostics_end end module MOM_diagnostics diff --git a/src/diagnostics/MOM_sum_output.F90 b/src/diagnostics/MOM_sum_output.F90 index b2e0275ea8..dd5dfcd80c 100644 --- a/src/diagnostics/MOM_sum_output.F90 +++ b/src/diagnostics/MOM_sum_output.F90 @@ -34,7 +34,8 @@ module MOM_sum_output #include -public write_energy, accumulate_net_input, MOM_sum_output_init +public write_energy, accumulate_net_input +public MOM_sum_output_init, MOM_sum_output_end ! A note on unit descriptions in comments: MOM6 uses units that can be rescaled for dimensional ! consistency testing. These are noted in comments with units like Z, H, L, and T, along with diff --git a/src/framework/MOM_diag_mediator.F90 b/src/framework/MOM_diag_mediator.F90 index e9ad88c17e..6f724370e2 100644 --- a/src/framework/MOM_diag_mediator.F90 +++ b/src/framework/MOM_diag_mediator.F90 @@ -3375,13 +3375,22 @@ subroutine diag_mediator_close_registration(diag_CS) end subroutine diag_mediator_close_registration +subroutine axes_grp_end(axes) + type(axes_grp), intent(inout) :: axes !< Axes group to be destroyed + + deallocate(axes%handles) + if (associated(axes%mask2d)) deallocate(axes%mask2d) + if (associated(axes%mask3d)) deallocate(axes%mask3d) +end subroutine axes_grp_end + subroutine diag_mediator_end(time, diag_CS, end_diag_manager) type(time_type), intent(in) :: time !< The current model time type(diag_ctrl), intent(inout) :: diag_CS !< Structure used to regulate diagnostic output logical, optional, intent(in) :: end_diag_manager !< If true, call diag_manager_end() ! Local variables - integer :: i + type(diag_type), pointer :: diag, next_diag + integer :: i, dl if (diag_CS%available_diag_doc_unit > -1) then close(diag_CS%available_diag_doc_unit) ; diag_CS%available_diag_doc_unit = -3 @@ -3390,6 +3399,17 @@ subroutine diag_mediator_end(time, diag_CS, end_diag_manager) close(diag_CS%chksum_iounit) ; diag_CS%chksum_iounit = -3 endif + do i=1, diag_cs%next_free_diag_id - 1 + if (associated(diag_cs%diags(i)%next)) then + next_diag => diag_cs%diags(i)%next + do while (associated(next_diag)) + diag => next_diag + next_diag => diag%next + deallocate(diag) + enddo + endif + enddo + deallocate(diag_cs%diags) do i=1, diag_cs%num_diag_coords @@ -3405,21 +3425,77 @@ subroutine diag_mediator_end(time, diag_CS, end_diag_manager) deallocate(diag_cs%mask3dBi) deallocate(diag_cs%mask3dCui) deallocate(diag_cs%mask3dCvi) - do i=2,MAX_DSAMP_LEV - deallocate(diag_cs%dsamp(i)%mask2dT) - deallocate(diag_cs%dsamp(i)%mask2dBu) - deallocate(diag_cs%dsamp(i)%mask2dCu) - deallocate(diag_cs%dsamp(i)%mask2dCv) - deallocate(diag_cs%dsamp(i)%mask3dTL) - deallocate(diag_cs%dsamp(i)%mask3dBL) - deallocate(diag_cs%dsamp(i)%mask3dCuL) - deallocate(diag_cs%dsamp(i)%mask3dCvL) - deallocate(diag_cs%dsamp(i)%mask3dTi) - deallocate(diag_cs%dsamp(i)%mask3dBi) - deallocate(diag_cs%dsamp(i)%mask3dCui) - deallocate(diag_cs%dsamp(i)%mask3dCvi) + do dl=2,MAX_DSAMP_LEV + deallocate(diag_cs%dsamp(dl)%mask2dT) + deallocate(diag_cs%dsamp(dl)%mask2dBu) + deallocate(diag_cs%dsamp(dl)%mask2dCu) + deallocate(diag_cs%dsamp(dl)%mask2dCv) + deallocate(diag_cs%dsamp(dl)%mask3dTL) + deallocate(diag_cs%dsamp(dl)%mask3dBL) + deallocate(diag_cs%dsamp(dl)%mask3dCuL) + deallocate(diag_cs%dsamp(dl)%mask3dCvL) + deallocate(diag_cs%dsamp(dl)%mask3dTi) + deallocate(diag_cs%dsamp(dl)%mask3dBi) + deallocate(diag_cs%dsamp(dl)%mask3dCui) + deallocate(diag_cs%dsamp(dl)%mask3dCvi) + + do i=1,diag_cs%num_diag_coords + deallocate(diag_cs%dsamp(dl)%remap_axesTL(i)%dsamp(dl)%mask3d) + deallocate(diag_cs%dsamp(dl)%remap_axesCuL(i)%dsamp(dl)%mask3d) + deallocate(diag_cs%dsamp(dl)%remap_axesCvL(i)%dsamp(dl)%mask3d) + deallocate(diag_cs%dsamp(dl)%remap_axesBL(i)%dsamp(dl)%mask3d) + deallocate(diag_cs%dsamp(dl)%remap_axesTi(i)%dsamp(dl)%mask3d) + deallocate(diag_cs%dsamp(dl)%remap_axesCui(i)%dsamp(dl)%mask3d) + deallocate(diag_cs%dsamp(dl)%remap_axesCvi(i)%dsamp(dl)%mask3d) + deallocate(diag_cs%dsamp(dl)%remap_axesBi(i)%dsamp(dl)%mask3d) + enddo enddo + ! axes_grp masks may point to diag_cs masks, so do these after mask dealloc + do i=1, diag_cs%num_diag_coords + call axes_grp_end(diag_cs%remap_axesZL(i)) + call axes_grp_end(diag_cs%remap_axesZi(i)) + call axes_grp_end(diag_cs%remap_axesTL(i)) + call axes_grp_end(diag_cs%remap_axesTi(i)) + call axes_grp_end(diag_cs%remap_axesBL(i)) + call axes_grp_end(diag_cs%remap_axesBi(i)) + call axes_grp_end(diag_cs%remap_axesCuL(i)) + call axes_grp_end(diag_cs%remap_axesCui(i)) + call axes_grp_end(diag_cs%remap_axesCvL(i)) + call axes_grp_end(diag_cs%remap_axesCvi(i)) + enddo + + deallocate(diag_cs%remap_axesZL) + deallocate(diag_cs%remap_axesZi) + deallocate(diag_cs%remap_axesTL) + deallocate(diag_cs%remap_axesTi) + deallocate(diag_cs%remap_axesBL) + deallocate(diag_cs%remap_axesBi) + deallocate(diag_cs%remap_axesCuL) + deallocate(diag_cs%remap_axesCui) + deallocate(diag_cs%remap_axesCvL) + deallocate(diag_cs%remap_axesCvi) + + do dl=2,MAX_DSAMP_LEV + if (allocated(diag_cs%dsamp(dl)%remap_axesTL)) & + deallocate(diag_cs%dsamp(dl)%remap_axesTL) + if (allocated(diag_cs%dsamp(dl)%remap_axesTi)) & + deallocate(diag_cs%dsamp(dl)%remap_axesTi) + if (allocated(diag_cs%dsamp(dl)%remap_axesBL)) & + deallocate(diag_cs%dsamp(dl)%remap_axesBL) + if (allocated(diag_cs%dsamp(dl)%remap_axesBi)) & + deallocate(diag_cs%dsamp(dl)%remap_axesBi) + if (allocated(diag_cs%dsamp(dl)%remap_axesCuL)) & + deallocate(diag_cs%dsamp(dl)%remap_axesCuL) + if (allocated(diag_cs%dsamp(dl)%remap_axesCui)) & + deallocate(diag_cs%dsamp(dl)%remap_axesCui) + if (allocated(diag_cs%dsamp(dl)%remap_axesCvL)) & + deallocate(diag_cs%dsamp(dl)%remap_axesCvL) + if (allocated(diag_cs%dsamp(dl)%remap_axesCvi)) & + deallocate(diag_cs%dsamp(dl)%remap_axesCvi) + enddo + + #if defined(DEBUG) || defined(__DO_SAFETY_CHECKS__) deallocate(diag_cs%h_old) #endif diff --git a/src/framework/MOM_diag_remap.F90 b/src/framework/MOM_diag_remap.F90 index d8a098d12c..d3eb21dcbe 100644 --- a/src/framework/MOM_diag_remap.F90 +++ b/src/framework/MOM_diag_remap.F90 @@ -72,6 +72,7 @@ module MOM_diag_remap use MOM_remapping, only : remapping_CS, initialize_remapping use MOM_remapping, only : remapping_core_h use MOM_regridding, only : regridding_CS, initialize_regridding +use MOM_regridding, only : end_regridding use MOM_regridding, only : set_regrid_params, get_regrid_size use MOM_regridding, only : getCoordinateInterfaces use MOM_regridding, only : get_zlike_CS, get_sigma_CS, get_rho_CS @@ -148,6 +149,7 @@ subroutine diag_remap_end(remap_cs) type(diag_remap_ctrl), intent(inout) :: remap_cs !< Diag remapping control structure if (allocated(remap_cs%h)) deallocate(remap_cs%h) + remap_cs%configured = .false. remap_cs%initialized = .false. remap_cs%used = .false. @@ -165,6 +167,7 @@ subroutine diag_remap_diag_registration_closed(remap_cs) if (.not. remap_cs%used) then call diag_remap_end(remap_cs) + call end_regridding(remap_cs%regrid_cs) endif end subroutine diag_remap_diag_registration_closed diff --git a/src/framework/MOM_dyn_horgrid.F90 b/src/framework/MOM_dyn_horgrid.F90 index 141340047d..2a9a381caa 100644 --- a/src/framework/MOM_dyn_horgrid.F90 +++ b/src/framework/MOM_dyn_horgrid.F90 @@ -5,7 +5,7 @@ module MOM_dyn_horgrid ! This file is part of MOM6. See LICENSE.md for the license. use MOM_hor_index, only : hor_index_type -use MOM_domains, only : MOM_domain_type +use MOM_domains, only : MOM_domain_type, deallocate_MOM_domain use MOM_error_handler, only : MOM_error, MOM_mesg, FATAL, WARNING use MOM_unit_scaling, only : unit_scale_type @@ -413,8 +413,10 @@ subroutine destroy_dyn_horgrid(G) deallocate(G%gridLonT) ; deallocate(G%gridLatT) deallocate(G%gridLonB) ; deallocate(G%gridLatB) - deallocate(G%Domain%mpp_domain) - deallocate(G%Domain) + ! CS%debug is required to validate Domain_aux, so use allocation test + if (associated(G%Domain_aux)) call deallocate_MOM_domain(G%Domain_aux) + + call deallocate_MOM_domain(G%Domain) deallocate(G) diff --git a/src/framework/MOM_file_parser.F90 b/src/framework/MOM_file_parser.F90 index 3e7a2f9e84..07e9138594 100644 --- a/src/framework/MOM_file_parser.F90 +++ b/src/framework/MOM_file_parser.F90 @@ -196,6 +196,8 @@ subroutine open_param_file(filename, CS, checkable, component, doc_file_dir) CS%iounit(i) = iounit CS%filename(i) = filename CS%NetCDF_file(i) = Netcdf_file + + if (associated(CS%blockName)) deallocate(CS%blockName) allocate(block) ; block%name = '' ; CS%blockName => block call MOM_mesg("open_param_file: "// trim(filename)// & @@ -332,6 +334,7 @@ subroutine close_param_file(CS, quiet_close, component) deallocate (CS%param_data(i)%line) deallocate (CS%param_data(i)%line_used) enddo + deallocate(CS%blockName) if (is_root_pe() .and. (num_unused>0) .and. CS%unused_params_fatal) & call MOM_error(FATAL, "Run stopped because of unused parameter lines.") diff --git a/src/parameterizations/lateral/MOM_MEKE.F90 b/src/parameterizations/lateral/MOM_MEKE.F90 index 850f94cff2..762b2edaea 100644 --- a/src/parameterizations/lateral/MOM_MEKE.F90 +++ b/src/parameterizations/lateral/MOM_MEKE.F90 @@ -1421,26 +1421,23 @@ subroutine MEKE_alloc_register_restart(HI, param_file, MEKE, restart_CS) end subroutine MEKE_alloc_register_restart -!> Deallocates any variables allocated in MEKE_init or -!! MEKE_alloc_register_restart. -subroutine MEKE_end(MEKE, CS) - type(MEKE_type), pointer :: MEKE !< A structure with MEKE-related fields. - type(MEKE_CS), pointer :: CS !< The control structure for MOM_MEKE. +!> Deallocates any variables allocated in MEKE_alloc_register_restart. +subroutine MEKE_end(MEKE) + type(MEKE_type), intent(inout) :: MEKE !< A structure with MEKE-related fields. - if (associated(CS)) deallocate(CS) + ! NOTE: MEKE will always be allocated by MEKE_init, even if MEKE is disabled. + ! So these must all be conditional, even though MEKE%MEKE and MEKE%Rd_dx_h + ! are always allocated (when MEKE is enabled) - if (.not.associated(MEKE)) return - - if (associated(MEKE%MEKE)) deallocate(MEKE%MEKE) - if (associated(MEKE%GM_src)) deallocate(MEKE%GM_src) - if (associated(MEKE%mom_src)) deallocate(MEKE%mom_src) - if (associated(MEKE%GME_snk)) deallocate(MEKE%GME_snk) - if (associated(MEKE%Kh)) deallocate(MEKE%Kh) + if (associated(MEKE%Au)) deallocate(MEKE%Au) if (associated(MEKE%Kh_diff)) deallocate(MEKE%Kh_diff) if (associated(MEKE%Ku)) deallocate(MEKE%Ku) - if (associated(MEKE%Au)) deallocate(MEKE%Au) - deallocate(MEKE) - + if (associated(MEKE%Rd_dx_h)) deallocate(MEKE%Rd_dx_h) + if (associated(MEKE%Kh)) deallocate(MEKE%Kh) + if (associated(MEKE%GME_snk)) deallocate(MEKE%GME_snk) + if (associated(MEKE%mom_src)) deallocate(MEKE%mom_src) + if (associated(MEKE%GM_src)) deallocate(MEKE%GM_src) + if (associated(MEKE%MEKE)) deallocate(MEKE%MEKE) end subroutine MEKE_end !> \namespace mom_meke diff --git a/src/parameterizations/lateral/MOM_hor_visc.F90 b/src/parameterizations/lateral/MOM_hor_visc.F90 index 661fb715e7..4604d4da26 100644 --- a/src/parameterizations/lateral/MOM_hor_visc.F90 +++ b/src/parameterizations/lateral/MOM_hor_visc.F90 @@ -2583,10 +2583,10 @@ subroutine hor_visc_end(CS) DEALLOC_(CS%Ah_Max_xx) ; DEALLOC_(CS%Ah_Max_xy) endif if (CS%Smagorinsky_Ah) then - DEALLOC_(CS%Biharm6_const_xx) ; DEALLOC_(CS%Biharm6_const_xy) + DEALLOC_(CS%Biharm_const_xx) ; DEALLOC_(CS%Biharm_const_xy) endif if (CS%Leith_Ah) then - DEALLOC_(CS%Biharm_const_xx) ; DEALLOC_(CS%Biharm_const_xy) + DEALLOC_(CS%Biharm6_const_xx) ; DEALLOC_(CS%Biharm6_const_xy) endif if (CS%Re_Ah > 0.0) then DEALLOC_(CS%Re_Ah_const_xx) ; DEALLOC_(CS%Re_Ah_const_xy) diff --git a/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 b/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 index 729e961974..fb70f5d679 100644 --- a/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 +++ b/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 @@ -154,7 +154,7 @@ module MOM_lateral_mixing_coeffs logical :: debug !< If true, write out checksums of data for debugging end type VarMix_CS -public VarMix_init, calc_slope_functions, calc_resoln_function +public VarMix_init, VarMix_end, calc_slope_functions, calc_resoln_function public calc_QG_Leith_viscosity, calc_depth_function contains @@ -1268,12 +1268,16 @@ subroutine VarMix_init(Time, G, GV, US, param_file, diag, CS) allocate(CS%ebt_struct(isd:ied,jsd:jed,GV%ke)) ; CS%ebt_struct(:,:,:) = 0.0 endif - if (KhTr_Slope_Cff>0. .or. KhTh_Slope_Cff>0.) then - call get_param(param_file, mdl, "VISBECK_MAX_SLOPE", CS%Visbeck_S_max, & - "If non-zero, is an upper bound on slopes used in the "//& - "Visbeck formula for diffusivity. This does not affect the "//& - "isopycnal slope calculation used within thickness diffusion.", & - units="nondim", default=0.0) + if (CS%use_stored_slopes) then + if (KhTr_Slope_Cff>0. .or. KhTh_Slope_Cff>0.) then + call get_param(param_file, mdl, "VISBECK_MAX_SLOPE", CS%Visbeck_S_max, & + "If non-zero, is an upper bound on slopes used in the "//& + "Visbeck formula for diffusivity. This does not affect the "//& + "isopycnal slope calculation used within thickness diffusion.", & + units="nondim", default=0.0) + else + CS%Visbeck_S_max = 0. + endif endif if (CS%use_stored_slopes) then @@ -1588,6 +1592,65 @@ subroutine VarMix_init(Time, G, GV, US, param_file, diag, CS) end subroutine VarMix_init +!> Destructor for VarMix control structure +subroutine VarMix_end(CS) + type(VarMix_CS), intent(inout) :: CS + + if (CS%Resoln_use_ebt .or. CS%khth_use_ebt_struct) & + deallocate(CS%ebt_struct) + + if (CS%use_stored_slopes) then + deallocate(CS%slope_x) + deallocate(CS%slope_y) + endif + + if (CS%calculate_Eady_growth_rate) then + deallocate(CS%SN_u) + deallocate(CS%SN_v) + endif + + if (associated(CS%L2u)) deallocate(CS%L2u) + if (associated(CS%L2v)) deallocate(CS%L2v) + + if (CS%Resoln_scaled_Kh .or. CS%Resoln_scaled_KhTh .or. CS%Resoln_scaled_KhTr) then + deallocate(CS%Res_fn_h) + deallocate(CS%Res_fn_q) + deallocate(CS%Res_fn_u) + deallocate(CS%Res_fn_v) + deallocate(CS%beta_dx2_q) + deallocate(CS%beta_dx2_u) + deallocate(CS%beta_dx2_v) + deallocate(CS%f2_dx2_q) + deallocate(CS%f2_dx2_u) + deallocate(CS%f2_dx2_v) + endif + + if (CS%Depth_scaled_KhTh) then + deallocate(CS%Depth_fn_u) + deallocate(CS%Depth_fn_v) + endif + + if (CS%calculate_Rd_dx) then + deallocate(CS%Rd_dx_h) + deallocate(CS%beta_dx2_h) + deallocate(CS%f2_dx2_h) + endif + + if (CS%calculate_cg1) then + deallocate(CS%cg1) + endif + + if (CS%Use_QG_Leith_GM) then + DEALLOC_(CS%Laplac3_const_u) + DEALLOC_(CS%Laplac3_const_v) + DEALLOC_(CS%KH_u_QG) + DEALLOC_(CS%KH_v_QG) + endif + + if (CS%calculate_cg1) deallocate(CS%wave_speed_CSp) + +end subroutine VarMix_end + !> \namespace mom_lateral_mixing_coeffs !! !! This module provides a container for various factors used in prescribing diffusivities, that are diff --git a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 index 02a49a2a1a..da62ffc6b7 100644 --- a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 +++ b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 @@ -2116,10 +2116,23 @@ subroutine thickness_diffuse_get_KH(CS, KH_u_GME, KH_v_GME, G, GV) end subroutine thickness_diffuse_get_KH !> Deallocate the thickness diffusion control structure -subroutine thickness_diffuse_end(CS) - type(thickness_diffuse_CS), pointer :: CS !< Control structure for thickness diffusion +subroutine thickness_diffuse_end(CS, CDp) + type(thickness_diffuse_CS), intent(inout) :: CS !< Control structure for thickness diffusion + type(cont_diag_ptrs), intent(inout) :: CDp !< Continuity diagnostic control structure - if (associated(CS)) deallocate(CS) + if (CS%id_slope_x > 0) deallocate(CS%diagSlopeX) + if (CS%id_slope_y > 0) deallocate(CS%diagSlopeY) + + if (CS%id_GMwork > 0) deallocate(CS%GMwork) + + ! NOTE: [uv]hGM may be allocated either here or the diagnostic module + if (associated(CDp%uhGM)) deallocate(CDp%uhGM) + if (associated(CDp%vhGM)) deallocate(CDp%vhGM) + + if (CS%use_GME_thickness_diffuse) then + deallocate(CS%KH_u_GME) + deallocate(CS%KH_v_GME) + endif end subroutine thickness_diffuse_end !> \namespace mom_thickness_diffuse diff --git a/src/parameterizations/lateral/MOM_tidal_forcing.F90 b/src/parameterizations/lateral/MOM_tidal_forcing.F90 index 1f95cb5162..307fbbe3ef 100644 --- a/src/parameterizations/lateral/MOM_tidal_forcing.F90 +++ b/src/parameterizations/lateral/MOM_tidal_forcing.F90 @@ -667,8 +667,8 @@ end subroutine calc_tidal_forcing !> This subroutine deallocates memory associated with the tidal forcing module. subroutine tidal_forcing_end(CS) - type(tidal_forcing_CS), pointer :: CS !< The control structure returned by a previous call - !! to tidal_forcing_init; it is deallocated here. + type(tidal_forcing_CS), intent(inout) :: CS !< The control structure returned by a previous call + !! to tidal_forcing_init; it is deallocated here. if (associated(CS%sin_struct)) deallocate(CS%sin_struct) if (associated(CS%cos_struct)) deallocate(CS%cos_struct) @@ -680,9 +680,6 @@ subroutine tidal_forcing_end(CS) if (associated(CS%cosphase_prev)) deallocate(CS%cosphase_prev) if (associated(CS%sinphase_prev)) deallocate(CS%sinphase_prev) if (associated(CS%amp_prev)) deallocate(CS%amp_prev) - - if (associated(CS)) deallocate(CS) - end subroutine tidal_forcing_end !> \namespace tidal_forcing diff --git a/src/parameterizations/vertical/MOM_CVMix_conv.F90 b/src/parameterizations/vertical/MOM_CVMix_conv.F90 index 89c0bf8377..8b007a0b11 100644 --- a/src/parameterizations/vertical/MOM_CVMix_conv.F90 +++ b/src/parameterizations/vertical/MOM_CVMix_conv.F90 @@ -68,7 +68,6 @@ logical function CVMix_conv_init(Time, G, GV, US, param_file, diag, CS) "control structure.") return endif - allocate(CS) ! Read parameters call get_param(param_file, mdl, "USE_CVMix_CONVECTION", CVMix_conv_init, default=.false., do_not_log=.true.) @@ -83,6 +82,7 @@ logical function CVMix_conv_init(Time, G, GV, US, param_file, diag, CS) default=.false.) if (.not. CVMix_conv_init) return + allocate(CS) call get_param(param_file, mdl, "ENERGETICS_SFC_PBL", useEPBL, default=.false., & do_not_log=.true.) @@ -310,14 +310,10 @@ logical function CVMix_conv_is_used(param_file) end function CVMix_conv_is_used !> Clear pointers and dealocate memory +! NOTE: Placeholder destructor subroutine CVMix_conv_end(CS) type(CVMix_conv_cs), pointer :: CS !< Control structure for this module that !! will be deallocated in this subroutine - - if (.not. associated(CS)) return - - deallocate(CS) - end subroutine CVMix_conv_end end module MOM_CVMix_conv diff --git a/src/parameterizations/vertical/MOM_CVMix_ddiff.F90 b/src/parameterizations/vertical/MOM_CVMix_ddiff.F90 index e487e616af..f1ac4c926a 100644 --- a/src/parameterizations/vertical/MOM_CVMix_ddiff.F90 +++ b/src/parameterizations/vertical/MOM_CVMix_ddiff.F90 @@ -65,7 +65,6 @@ logical function CVMix_ddiff_init(Time, G, GV, US, param_file, diag, CS) "control structure.") return endif - allocate(CS) ! Read parameters call get_param(param_file, mdl, "USE_CVMIX_DDIFF", CVMix_ddiff_init, default=.false., do_not_log=.true.) @@ -79,6 +78,7 @@ logical function CVMix_ddiff_init(Time, G, GV, US, param_file, diag, CS) default=.false.) if (.not. CVMix_ddiff_init) return + allocate(CS) call get_param(param_file, mdl, 'DEBUG', CS%debug, default=.False., do_not_log=.True.) @@ -279,12 +279,10 @@ logical function CVMix_ddiff_is_used(param_file) end function CVMix_ddiff_is_used !> Clear pointers and dealocate memory +! NOTE: Placeholder destructor subroutine CVMix_ddiff_end(CS) type(CVMix_ddiff_cs), pointer :: CS !< Control structure for this module that !! will be deallocated in this subroutine - - deallocate(CS) - end subroutine CVMix_ddiff_end end module MOM_CVMix_ddiff diff --git a/src/parameterizations/vertical/MOM_CVMix_shear.F90 b/src/parameterizations/vertical/MOM_CVMix_shear.F90 index 85d9c63a39..35e5352a9f 100644 --- a/src/parameterizations/vertical/MOM_CVMix_shear.F90 +++ b/src/parameterizations/vertical/MOM_CVMix_shear.F90 @@ -211,6 +211,9 @@ logical function CVMix_shear_init(Time, G, GV, US, param_file, diag, CS) ! Local variables integer :: NumberTrue=0 logical :: use_JHL + logical :: use_LMD94 + logical :: use_PP81 + ! This include declares and sets the variable "version". #include "version_variable.h" @@ -219,28 +222,23 @@ logical function CVMix_shear_init(Time, G, GV, US, param_file, diag, CS) "control structure.") return endif - allocate(CS) ! Set default, read and log parameters - call get_param(param_file, mdl, "USE_LMD94", CS%use_LMD94, default=.false., do_not_log=.true.) - call get_param(param_file, mdl, "USE_PP81", CS%use_PP81, default=.false., do_not_log=.true.) + call get_param(param_file, mdl, "USE_LMD94", use_LMD94, default=.false., do_not_log=.true.) + call get_param(param_file, mdl, "USE_PP81", use_PP81, default=.false., do_not_log=.true.) call log_version(param_file, mdl, version, & "Parameterization of shear-driven turbulence via CVMix (various options)", & - all_default=.not.(CS%use_PP81.or.CS%use_LMD94)) - call get_param(param_file, mdl, "USE_LMD94", CS%use_LMD94, & + all_default=.not.(use_PP81.or.use_LMD94)) + call get_param(param_file, mdl, "USE_LMD94", use_LMD94, & "If true, use the Large-McWilliams-Doney (JGR 1994) "//& "shear mixing parameterization.", default=.false.) - if (CS%use_LMD94) then + if (use_LMD94) & NumberTrue=NumberTrue + 1 - CS%Mix_Scheme='KPP' - endif - call get_param(param_file, mdl, "USE_PP81", CS%use_PP81, & + call get_param(param_file, mdl, "USE_PP81", use_PP81, & "If true, use the Pacanowski and Philander (JPO 1981) "//& "shear mixing parameterization.", default=.false.) - if (CS%use_PP81) then + if (use_PP81) & NumberTrue = NumberTrue + 1 - CS%Mix_Scheme='PP' - endif use_JHL=kappa_shear_is_used(param_file) if (use_JHL) NumberTrue = NumberTrue + 1 ! After testing for interior schemes, make sure only 0 or 1 are enabled. @@ -250,10 +248,20 @@ logical function CVMix_shear_init(Time, G, GV, US, param_file, diag, CS) 'Multiple shear driven internal mixing schemes selected,'//& ' please disable all but one scheme to proceed.') endif - CVMix_shear_init=(CS%use_PP81.or.CS%use_LMD94) -! Forego remainder of initialization if not using this scheme + CVMix_shear_init = use_PP81 .or. use_LMD94 + + ! Forego remainder of initialization if not using this scheme if (.not. CVMix_shear_init) return + + allocate(CS) + CS%use_LMD94 = use_LMD94 + CS%use_PP81 = use_PP81 + if (use_LMD94) & + CS%Mix_Scheme = 'KPP' + if (use_PP81) & + CS%Mix_Scheme = 'PP' + call get_param(param_file, mdl, "NU_ZERO", CS%Nu_Zero, & "Leading coefficient in KPP shear mixing.", & units="nondim", default=5.e-3) @@ -326,16 +334,11 @@ end function CVMix_shear_is_used !> Clear pointers and dealocate memory subroutine CVMix_shear_end(CS) - type(CVMix_shear_cs), pointer :: CS !< Control structure for this module that - !! will be deallocated in this subroutine - - if (.not. associated(CS)) return - + type(CVMix_shear_cs), intent(inout) :: CS !< Control structure for this module that + !! will be deallocated in this subroutine if (CS%id_N2 > 0) deallocate(CS%N2) if (CS%id_S2 > 0) deallocate(CS%S2) if (CS%id_ri_grad > 0) deallocate(CS%ri_grad) - deallocate(CS) - end subroutine CVMix_shear_end end module MOM_CVMix_shear diff --git a/src/parameterizations/vertical/MOM_diabatic_driver.F90 b/src/parameterizations/vertical/MOM_diabatic_driver.F90 index 1b27bc6904..7b6a1c848f 100644 --- a/src/parameterizations/vertical/MOM_diabatic_driver.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_driver.F90 @@ -231,7 +231,7 @@ module MOM_diabatic_driver type(tracer_flow_control_CS), pointer :: tracer_flow_CSp => NULL() !< Control structure for a child module type(optics_type), pointer :: optics => NULL() !< Control structure for a child module type(KPP_CS), pointer :: KPP_CSp => NULL() !< Control structure for a child module - type(CVMix_conv_cs), pointer :: CVMix_conv_csp => NULL() !< Control structure for a child module + type(CVMix_conv_cs), pointer :: CVMix_conv_CSp => NULL() !< Control structure for a child module type(diapyc_energy_req_CS), pointer :: diapyc_en_rec_CSp => NULL() !< Control structure for a child module type(group_pass_type) :: pass_hold_eb_ea !< For group halo pass @@ -706,7 +706,7 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim ! Calculate vertical mixing due to convection (computed via CVMix) if (CS%use_CVMix_conv) then ! Increment vertical diffusion and viscosity due to convection - call calculate_CVMix_conv(h, tv, G, GV, US, CS%CVMix_conv_csp, Hml, Kd=Kd_int, Kv=visc%Kv_slow) + call calculate_CVMix_conv(h, tv, G, GV, US, CS%CVMix_conv_CSp, Hml, Kd=Kd_int, Kv=visc%Kv_slow) endif ! This block sets ent_t and ent_s from h and Kd_int. @@ -1236,9 +1236,9 @@ subroutine diabatic_ALE(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, if (CS%use_CVMix_conv) then ! Increment vertical diffusion and viscosity due to convection if (CS%useKPP) then - call calculate_CVMix_conv(h, tv, G, GV, US, CS%CVMix_conv_csp, Hml, Kd=Kd_heat, Kv=visc%Kv_shear, Kd_aux=Kd_salt) + call calculate_CVMix_conv(h, tv, G, GV, US, CS%CVMix_conv_CSp, Hml, Kd=Kd_heat, Kv=visc%Kv_shear, Kd_aux=Kd_salt) else - call calculate_CVMix_conv(h, tv, G, GV, US, CS%CVMix_conv_csp, Hml, Kd=Kd_heat, Kv=visc%Kv_slow, Kd_aux=Kd_salt) + call calculate_CVMix_conv(h, tv, G, GV, US, CS%CVMix_conv_CSp, Hml, Kd=Kd_heat, Kv=visc%Kv_slow, Kd_aux=Kd_salt) endif endif @@ -1804,7 +1804,7 @@ subroutine layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_e ! Add vertical diff./visc. due to convection (computed via CVMix) if (CS%use_CVMix_conv) then - call calculate_CVMix_conv(h, tv, G, GV, US, CS%CVMix_conv_csp, Hml, Kd=Kd_int, Kv=visc%Kv_slow) + call calculate_CVMix_conv(h, tv, G, GV, US, CS%CVMix_conv_CSp, Hml, Kd=Kd_int, Kv=visc%Kv_slow) endif if (CS%useKPP) then @@ -3286,7 +3286,7 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di endif ! CS%use_CVMix_conv is set to True if CVMix convection will be used, otherwise it is False. - CS%use_CVMix_conv = CVMix_conv_init(Time, G, GV, US, param_file, diag, CS%CVMix_conv_csp) + CS%use_CVMix_conv = CVMix_conv_init(Time, G, GV, US, param_file, diag, CS%CVMix_conv_CSp) call entrain_diffusive_init(Time, G, GV, US, param_file, diag, CS%entrain_diffusive_CSp, & just_read_params=CS%useALEalgorithm) @@ -3359,15 +3359,36 @@ end subroutine diabatic_driver_init !> Routine to close the diabatic driver module subroutine diabatic_driver_end(CS) - type(diabatic_CS), pointer :: CS !< module control structure + type(diabatic_CS), intent(inout) :: CS !< module control structure - if (.not.associated(CS)) return + if (associated(CS%optics)) then + call opacity_end(CS%opacity_CSp, CS%optics) + deallocate(CS%optics) + endif + + if (CS%debug_energy_req) & + call diapyc_energy_req_end(CS%diapyc_en_rec_CSp) + + deallocate(CS%regularize_layers_CSp) + + if (CS%use_energetic_PBL) & + call energetic_PBL_end(CS%energetic_PBL_CSp) call diabatic_aux_end(CS%diabatic_aux_CSp) - call entrain_diffusive_end(CS%entrain_diffusive_CSp) call set_diffusivity_end(CS%set_diff_CSp) + deallocate(CS%set_diff_CSp) + + if (CS%use_geothermal) then + call geothermal_end(CS%geothermal_CSp) + deallocate(CS%geothermal_CSp) + endif + + call entrain_diffusive_end(CS%entrain_diffusive_CSp) + + if (CS%use_CVMix_conv) deallocate(CS%CVMix_conv_CSp) + if (CS%useKPP) then deallocate( CS%KPP_buoy_flux ) deallocate( CS%KPP_temp_flux ) @@ -3377,26 +3398,11 @@ subroutine diabatic_driver_end(CS) call KPP_end(CS%KPP_CSp) endif - if (CS%use_CVMix_conv) call CVMix_conv_end(CS%CVMix_conv_csp) - - if (CS%use_energetic_PBL) & - call energetic_PBL_end(CS%energetic_PBL_CSp) - if (CS%debug_energy_req) & - call diapyc_energy_req_end(CS%diapyc_en_rec_CSp) - - if (associated(CS%optics)) then - call opacity_end(CS%opacity_CSp, CS%optics) - deallocate(CS%optics) - endif - ! GMM, the following is commented out because arrays in ! CS%diag_grids_prev are neither pointers or allocatables ! and, therefore, cannot be deallocated. !call diag_grid_storage_end(CS%diag_grids_prev) - - deallocate(CS) - end subroutine diabatic_driver_end diff --git a/src/parameterizations/vertical/MOM_geothermal.F90 b/src/parameterizations/vertical/MOM_geothermal.F90 index 9e8161441f..2195363101 100644 --- a/src/parameterizations/vertical/MOM_geothermal.F90 +++ b/src/parameterizations/vertical/MOM_geothermal.F90 @@ -599,11 +599,9 @@ end subroutine geothermal_init !> Clean up and deallocate memory associated with the geothermal heating module. subroutine geothermal_end(CS) - type(geothermal_CS), pointer :: CS !< Geothermal heating control structure that - !! will be deallocated in this subroutine. - - if (associated(CS%geo_heat)) deallocate(CS%geo_heat) - if (associated(CS)) deallocate(CS) + type(geothermal_CS), intent(inout) :: CS !< Geothermal heating control structure that + !! will be deallocated in this subroutine. + deallocate(CS%geo_heat) end subroutine geothermal_end !> \namespace mom_geothermal diff --git a/src/parameterizations/vertical/MOM_opacity.F90 b/src/parameterizations/vertical/MOM_opacity.F90 index 83d70c7ae3..0b6a3cf76c 100644 --- a/src/parameterizations/vertical/MOM_opacity.F90 +++ b/src/parameterizations/vertical/MOM_opacity.F90 @@ -1123,8 +1123,12 @@ subroutine opacity_end(CS, optics) if (associated(CS)) deallocate(CS) if (present(optics)) then ; if (associated(optics)) then - if (associated(optics%opacity_band)) deallocate(optics%opacity_band) if (associated(optics%sw_pen_band)) deallocate(optics%sw_pen_band) + if (associated(optics%opacity_band)) deallocate(optics%opacity_band) + if (associated(optics%max_wavelength_band)) & + deallocate(optics%max_wavelength_band) + if (associated(optics%min_wavelength_band)) & + deallocate(optics%min_wavelength_band) endif ; endif end subroutine opacity_end diff --git a/src/parameterizations/vertical/MOM_set_diffusivity.F90 b/src/parameterizations/vertical/MOM_set_diffusivity.F90 index 99dee11b9a..98f582601b 100644 --- a/src/parameterizations/vertical/MOM_set_diffusivity.F90 +++ b/src/parameterizations/vertical/MOM_set_diffusivity.F90 @@ -355,7 +355,8 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, & endif ! set up arrays for tidal mixing diagnostics - call setup_tidal_diagnostics(G, GV, CS%tidal_mixing_CSp) + if (CS%use_tidal_mixing) & + call setup_tidal_diagnostics(G, GV, CS%tidal_mixing_CSp) if (CS%useKappaShear) then if (CS%debug) then @@ -665,7 +666,9 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, & if (CS%id_Kv_bkgnd > 0) call post_data(CS%id_Kv_bkgnd, dd%Kv_bkgnd, CS%diag) ! tidal mixing - call post_tidal_diagnostics(G, GV, h, CS%tidal_mixing_CSp) + if (CS%use_tidal_mixing) & + call post_tidal_diagnostics(G, GV, h, CS%tidal_mixing_CSp) + if (CS%id_N2 > 0) call post_data(CS%id_N2, dd%N2_3d, CS%diag) if (CS%id_Kd_Work > 0) call post_data(CS%id_Kd_Work, dd%Kd_Work, CS%diag) if (CS%id_maxTKE > 0) call post_data(CS%id_maxTKE, dd%maxTKE, CS%diag) @@ -693,6 +696,8 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, & if (associated(dd%KS_extra)) deallocate(dd%KS_extra) if (associated(dd%drho_rat)) deallocate(dd%drho_rat) if (associated(dd%Kd_BBL)) deallocate(dd%Kd_BBL) + if (associated(dd%Kd_bkgnd)) deallocate(dd%Kd_bkgnd) + if (associated(dd%Kv_bkgnd)) deallocate(dd%Kv_bkgnd) if (showCallTree) call callTree_leave("set_diffusivity()") @@ -2344,22 +2349,26 @@ end subroutine set_diffusivity_init !> Clear pointers and dealocate memory subroutine set_diffusivity_end(CS) - type(set_diffusivity_CS), pointer :: CS !< Control structure for this module - - if (.not.associated(CS)) return + type(set_diffusivity_CS), intent(inout) :: CS !< Control structure for this module call bkgnd_mixing_end(CS%bkgnd_mixing_csp) - if (CS%use_tidal_mixing) call tidal_mixing_end(CS%tidal_mixing_CSp) + if (CS%use_tidal_mixing) then + call tidal_mixing_end(CS%tidal_mixing_CSp) + deallocate(CS%tidal_mixing_CSp) + endif if (CS%user_change_diff) call user_change_diff_end(CS%user_change_diff_CSp) - if (CS%use_CVMix_shear) call CVMix_shear_end(CS%CVMix_shear_csp) - - if (CS%use_CVMix_ddiff) call CVMix_ddiff_end(CS%CVMix_ddiff_csp) + if (associated(CS%CVMix_ddiff_CSp)) deallocate(CS%CVMix_ddiff_CSp) - if (associated(CS)) deallocate(CS) + if (CS%use_CVMix_shear) then + call CVMix_shear_end(CS%CVMix_shear_CSp) + deallocate(CS%CVMix_shear_CSp) + endif + ! NOTE: CS%kappaShear_CSp is always allocated, even if unused + deallocate(CS%kappaShear_CSp) end subroutine set_diffusivity_end end module MOM_set_diffusivity diff --git a/src/parameterizations/vertical/MOM_tidal_mixing.F90 b/src/parameterizations/vertical/MOM_tidal_mixing.F90 index 21eb52ebe9..21562817c0 100644 --- a/src/parameterizations/vertical/MOM_tidal_mixing.F90 +++ b/src/parameterizations/vertical/MOM_tidal_mixing.F90 @@ -219,6 +219,8 @@ logical function tidal_mixing_init(Time, G, GV, US, param_file, diag, CS) type(tidal_mixing_cs), pointer :: CS !< This module's control structure. ! Local variables + logical :: use_CVMix_tidal + logical :: int_tide_dissipation logical :: read_tideamp logical :: default_2018_answers character(len=20) :: tmpstr, int_tide_profile_str @@ -229,6 +231,7 @@ logical function tidal_mixing_init(Time, G, GV, US, param_file, diag, CS) real :: Niku_scale ! local variable for scaling the Nikurashin TKE flux data integer :: i, j, is, ie, js, je integer :: isd, ied, jsd, jed + ! This include declares and sets the variable "version". # include "version_variable.h" character(len=40) :: mdl = "MOM_tidal_mixing" !< This module's name. @@ -238,39 +241,43 @@ logical function tidal_mixing_init(Time, G, GV, US, param_file, diag, CS) "is already associated.") return endif - allocate(CS) - allocate(CS%dd) - - CS%debug = CS%debug.and.is_root_pe() is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed - CS%diag => diag - ! Read parameters - call get_param(param_file, mdl, "USE_CVMix_TIDAL", CS%use_CVMix_tidal, & + ! NOTE: These are read twice because logfile output is streamed and we want + ! to preserve the ordering of module header before parameters. + call get_param(param_file, mdl, "USE_CVMix_TIDAL", use_CVMix_tidal, & default=.false., do_not_log=.true.) - call get_param(param_file, mdl, "INT_TIDE_DISSIPATION", CS%int_tide_dissipation, & - default=CS%use_CVMix_tidal, do_not_log=.true.) + call get_param(param_file, mdl, "INT_TIDE_DISSIPATION", int_tide_dissipation, & + default=use_CVMix_tidal, do_not_log=.true.) call log_version(param_file, mdl, version, & "Vertical Tidal Mixing Parameterization", & - all_default=.not.(CS%use_CVMix_tidal .or. CS%int_tide_dissipation)) - call get_param(param_file, mdl, "USE_CVMix_TIDAL", CS%use_CVMix_tidal, & + all_default=.not.(use_CVMix_tidal .or. int_tide_dissipation)) + + call get_param(param_file, mdl, "USE_CVMix_TIDAL", use_CVMix_tidal, & "If true, turns on tidal mixing via CVMix", & default=.false.) - - call get_param(param_file, mdl, "INPUTDIR", CS%inputdir, default=".",do_not_log=.true.) - CS%inputdir = slasher(CS%inputdir) - call get_param(param_file, mdl, "INT_TIDE_DISSIPATION", CS%int_tide_dissipation, & + call get_param(param_file, mdl, "INT_TIDE_DISSIPATION", int_tide_dissipation, & "If true, use an internal tidal dissipation scheme to "//& "drive diapycnal mixing, along the lines of St. Laurent "//& - "et al. (2002) and Simmons et al. (2004).", default=CS%use_CVMix_tidal) + "et al. (2002) and Simmons et al. (2004).", default=use_CVMix_tidal) ! return if tidal mixing is inactive - tidal_mixing_init = CS%int_tide_dissipation + tidal_mixing_init = int_tide_dissipation if (.not. tidal_mixing_init) return + allocate(CS) + allocate(CS%dd) + CS%debug = CS%debug.and.is_root_pe() + CS%diag => diag + CS%use_CVmix_tidal = use_CVmix_tidal + CS%int_tide_dissipation = int_tide_dissipation + + call get_param(param_file, mdl, "INPUTDIR", CS%inputdir, default=".",do_not_log=.true.) + CS%inputdir = slasher(CS%inputdir) + call get_param(param_file, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & "This sets the default value for the various _2018_ANSWERS parameters.", & default=.false.) @@ -1720,18 +1727,14 @@ end subroutine read_tidal_constituents !> Clear pointers and deallocate memory subroutine tidal_mixing_end(CS) - type(tidal_mixing_cs), pointer :: CS !< This module's control structure, which - !! will be deallocated in this routine. + type(tidal_mixing_cs), intent(inout) :: CS !< This module's control structure, which + !! will be deallocated in this routine. - if (.not.associated(CS)) return - - !TODO deallocate all the dynamically allocated members here ... + ! TODO: deallocate all the dynamically allocated members here ... if (allocated(CS%tidal_qe_2d)) deallocate(CS%tidal_qe_2d) if (allocated(CS%tidal_qe_3d_in)) deallocate(CS%tidal_qe_3d_in) if (allocated(CS%h_src)) deallocate(CS%h_src) deallocate(CS%dd) - deallocate(CS) - end subroutine tidal_mixing_end end module MOM_tidal_mixing diff --git a/src/parameterizations/vertical/MOM_vert_friction.F90 b/src/parameterizations/vertical/MOM_vert_friction.F90 index d448751137..76eca2a2a9 100644 --- a/src/parameterizations/vertical/MOM_vert_friction.F90 +++ b/src/parameterizations/vertical/MOM_vert_friction.F90 @@ -1885,14 +1885,16 @@ end subroutine updateCFLtruncationValue !> Clean up and deallocate the vertical friction module subroutine vertvisc_end(CS) - type(vertvisc_CS), pointer :: CS !< Vertical viscosity control structure that - !! will be deallocated in this subroutine. + type(vertvisc_CS), intent(inout) :: CS !< Vertical viscosity control structure that + !! will be deallocated in this subroutine. + + if ((len_trim(CS%u_trunc_file) > 0) .or. (len_trim(CS%v_trunc_file) > 0)) & + deallocate(CS%PointAccel_CSp) DEALLOC_(CS%a_u) ; DEALLOC_(CS%h_u) DEALLOC_(CS%a_v) ; DEALLOC_(CS%h_v) if (associated(CS%a1_shelf_u)) deallocate(CS%a1_shelf_u) if (associated(CS%a1_shelf_v)) deallocate(CS%a1_shelf_v) - deallocate(CS) end subroutine vertvisc_end !> \namespace mom_vert_friction diff --git a/src/tracer/MOM_neutral_diffusion.F90 b/src/tracer/MOM_neutral_diffusion.F90 index d8edff3751..244d1d5c5f 100644 --- a/src/tracer/MOM_neutral_diffusion.F90 +++ b/src/tracer/MOM_neutral_diffusion.F90 @@ -332,12 +332,16 @@ subroutine neutral_diffusion_calc_coeffs(G, GV, US, h, T, S, CS, p_surf) ! TODO: add similar code for BOTTOM boundary layer endif - if (.not.CS%remap_answers_2018) then - h_neglect = GV%H_subroundoff ; h_neglect_edge = GV%H_subroundoff - elseif (GV%Boussinesq) then - h_neglect = GV%m_to_H*1.0e-30 ; h_neglect_edge = GV%m_to_H*1.0e-10 - else - h_neglect = GV%kg_m2_to_H*1.0e-30 ; h_neglect_edge = GV%kg_m2_to_H*1.0e-10 + h_neglect = GV%H_subroundoff ; h_neglect_edge = GV%H_subroundoff + + if (.not. CS%continuous_reconstruction) then + if (CS%remap_answers_2018) then + if (GV%Boussinesq) then + h_neglect = GV%m_to_H*1.0e-30 ; h_neglect_edge = GV%m_to_H*1.0e-10 + else + h_neglect = GV%kg_m2_to_H*1.0e-30 ; h_neglect_edge = GV%kg_m2_to_H*1.0e-10 + endif + endif endif ! If doing along isopycnal diffusion (as opposed to neutral diffusion, set the reference pressure) @@ -572,10 +576,12 @@ subroutine neutral_diffusion(G, GV, h, Coef_x, Coef_y, dt, Reg, US, CS) real :: Idt ! The inverse of the time step [T-1 ~> s-1] real :: h_neglect, h_neglect_edge - if (.not.CS%remap_answers_2018) then - h_neglect = GV%H_subroundoff ; h_neglect_edge = GV%H_subroundoff - else - h_neglect = GV%m_to_H*1.0e-30 ; h_neglect_edge = GV%m_to_H*1.0e-10 + h_neglect = GV%H_subroundoff ; h_neglect_edge = GV%H_subroundoff + + if (.not. CS%continuous_reconstruction) then + if (CS%remap_answers_2018) then + h_neglect = GV%m_to_H*1.0e-30 ; h_neglect_edge = GV%m_to_H*1.0e-10 + endif endif nk = GV%ke From 1379af4a0182abcd872b8a24fdcf9dd23c5f8173 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 28 May 2021 15:25:28 -0400 Subject: [PATCH 091/112] Standardize dimensional rescaling in tracer stocks Revised the dimensional rescaling of the various tracer_stock routines to occur in a single line and be standardized across the tracer packages. Also added units to the descriptions of some some arguments in the tracer registry routines. All answers are bitwise identical. --- src/tracer/MOM_OCMIP2_CFC.F90 | 14 ++++++----- src/tracer/MOM_generic_tracer.F90 | 9 ++++--- src/tracer/MOM_tracer_registry.F90 | 17 +++++++------ src/tracer/advection_test_tracer.F90 | 8 +++--- src/tracer/boundary_impulse_tracer.F90 | 10 +++++--- src/tracer/dye_example.F90 | 9 ++++--- src/tracer/ideal_age_example.F90 | 11 ++++----- src/tracer/oil_tracer.F90 | 34 +++++++++++--------------- src/tracer/pseudo_salt_tracer.F90 | 12 ++++----- src/tracer/tracer_example.F90 | 9 ++++--- 10 files changed, 69 insertions(+), 64 deletions(-) diff --git a/src/tracer/MOM_OCMIP2_CFC.F90 b/src/tracer/MOM_OCMIP2_CFC.F90 index 4e5813e42a..a1039fd1b7 100644 --- a/src/tracer/MOM_OCMIP2_CFC.F90 +++ b/src/tracer/MOM_OCMIP2_CFC.F90 @@ -458,9 +458,9 @@ subroutine OCMIP2_CFC_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, US ! 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 T-1]. call extract_coupler_type_data(fluxes%tr_fluxes, CS%ind_cfc_11_flux, CFC11_flux, & - scale_factor=-G%US%R_to_kg_m3*GV%Rho0*US%T_to_s, idim=idim, jdim=jdim) + scale_factor=-GV%Rho0*US%R_to_kg_m3*US%T_to_s, idim=idim, jdim=jdim) call extract_coupler_type_data(fluxes%tr_fluxes, CS%ind_cfc_12_flux, CFC12_flux, & - scale_factor=-G%US%R_to_kg_m3*GV%Rho0*US%T_to_s, idim=idim, jdim=jdim) + scale_factor=-GV%Rho0*US%R_to_kg_m3*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. @@ -506,7 +506,8 @@ function OCMIP2_CFC_stock(h, stocks, G, GV, CS, names, units, stock_index) integer :: OCMIP2_CFC_stock !< The number of stocks calculated here. ! Local variables - real :: mass + real :: stock_scale ! The dimensional scaling factor to convert stocks to kg [kg H-1 L-2 ~> kg m-3 or nondim] + real :: mass ! The cell volume or mass [H L2 ~> m3 or kg] integer :: i, j, k, is, ie, js, je, nz is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke @@ -524,14 +525,15 @@ function OCMIP2_CFC_stock(h, stocks, G, GV, CS, names, units, stock_index) call query_vardesc(CS%CFC12_desc, name=names(2), units=units(2), caller="OCMIP2_CFC_stock") units(1) = trim(units(1))//" kg" ; units(2) = trim(units(2))//" kg" + stock_scale = G%US%L_to_m**2 * GV%H_to_kg_m2 stocks(1) = 0.0 ; stocks(2) = 0.0 do k=1,nz ; do j=js,je ; do i=is,ie - mass = G%mask2dT(i,j) * G%US%L_to_m**2*G%areaT(i,j) * h(i,j,k) + mass = G%mask2dT(i,j) * G%areaT(i,j) * h(i,j,k) stocks(1) = stocks(1) + CS%CFC11(i,j,k) * mass stocks(2) = stocks(2) + CS%CFC12(i,j,k) * mass enddo ; enddo ; enddo - stocks(1) = GV%H_to_kg_m2 * stocks(1) - stocks(2) = GV%H_to_kg_m2 * stocks(2) + stocks(1) = stock_scale * stocks(1) + stocks(2) = stock_scale * stocks(2) OCMIP2_CFC_stock = 2 diff --git a/src/tracer/MOM_generic_tracer.F90 b/src/tracer/MOM_generic_tracer.F90 index 9f39237211..f4120155b2 100644 --- a/src/tracer/MOM_generic_tracer.F90 +++ b/src/tracer/MOM_generic_tracer.F90 @@ -582,7 +582,8 @@ function MOM_generic_tracer_stock(h, stocks, G, GV, CS, names, units, stock_inde integer :: MOM_generic_tracer_stock !< Return value, the !! number of stocks calculated here. -! Local variables + ! Local variables + real :: stock_scale ! The dimensional scaling factor to convert stocks to kg [kg H-1 L-2 ~> kg m-3 or nondim] type(g_tracer_type), pointer :: g_tracer, g_tracer_next real, dimension(:,:,:,:), pointer :: tr_field real, dimension(:,:,:), pointer :: tr_ptr @@ -603,6 +604,7 @@ function MOM_generic_tracer_stock(h, stocks, G, GV, CS, names, units, stock_inde if (.NOT. associated(CS%g_tracer_list)) return ! No stocks. + stock_scale = G%US%L_to_m**2 * GV%H_to_kg_m2 m=1 ; g_tracer=>CS%g_tracer_list do call g_tracer_get_alias(g_tracer,names(m)) @@ -613,10 +615,9 @@ function MOM_generic_tracer_stock(h, stocks, G, GV, CS, names, units, stock_inde stocks(m) = 0.0 tr_ptr => tr_field(:,:,:,1) do k=1,nz ; do j=js,je ; do i=is,ie - stocks(m) = stocks(m) + tr_ptr(i,j,k) * & - (G%mask2dT(i,j) * G%US%L_to_m**2*G%areaT(i,j) * h(i,j,k)) + stocks(m) = stocks(m) + tr_ptr(i,j,k) * (G%mask2dT(i,j) * G%areaT(i,j) * h(i,j,k)) enddo ; enddo ; enddo - stocks(m) = GV%H_to_kg_m2 * stocks(m) + stocks(m) = stock_scale * stocks(m) !traverse the linked list till hit NULL call g_tracer_get_next(g_tracer, g_tracer_next) diff --git a/src/tracer/MOM_tracer_registry.F90 b/src/tracer/MOM_tracer_registry.F90 index 9977c26016..766d6ae7c8 100644 --- a/src/tracer/MOM_tracer_registry.F90 +++ b/src/tracer/MOM_tracer_registry.F90 @@ -348,7 +348,7 @@ subroutine register_tracer_diagnostics(Reg, h, Time, diag, G, GV, US, use_ALE) type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(tracer_registry_type), pointer :: Reg !< pointer to the tracer registry real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - intent(in) :: h !< Layer thicknesses + intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] type(time_type), intent(in) :: Time !< current model time type(diag_ctrl), intent(in) :: diag !< structure to regulate diagnostic output logical, intent(in) :: use_ALE !< If true active diagnostics that only @@ -719,7 +719,7 @@ subroutine post_tracer_diagnostics_at_sync(Reg, h, diag_prev, diag, G, GV, dt) type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure type(tracer_registry_type), pointer :: Reg !< pointer to the tracer registry real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - intent(in) :: h !< Layer thicknesses + intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] 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 [T ~> s] @@ -772,7 +772,7 @@ subroutine post_tracer_transport_diagnostics(G, GV, Reg, h_diag, diag) type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure type(tracer_registry_type), pointer :: Reg !< pointer to the tracer registry real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - intent(in) :: h_diag !< Layer thicknesses on which to post fields + intent(in) :: h_diag !< Layer thicknesses on which to post fields [H ~> m or kg m-2] type(diag_ctrl), intent(in) :: diag !< structure to regulate diagnostic output integer :: i, j, k, is, ie, js, je, nz, m @@ -825,18 +825,21 @@ subroutine MOM_tracer_chkinv(mesg, G, GV, h, Tr, ntr) type(ocean_grid_type), intent(in) :: G !< ocean grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure type(tracer_type), dimension(:), intent(in) :: Tr !< array of all of registered tracers - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thicknesses + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] integer, intent(in) :: ntr !< number of registered tracers - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: tr_inv !< Tracer inventory - real :: total_inv + ! Local variables + real :: vol_scale ! The dimensional scaling factor to convert volumes to m3 [m3 H-1 L-2 ~> nondim or m3 kg-1] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: tr_inv ! Volumetric tracer inventory in each cell [conc m3] + real :: total_inv ! The total amount of tracer [conc m3] integer :: is, ie, js, je, nz integer :: i, j, k, m is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + vol_scale = GV%H_to_m*G%US%L_to_m**2 do m=1,ntr do k=1,nz ; do j=js,je ; do i=is,ie - tr_inv(i,j,k) = Tr(m)%t(i,j,k)*h(i,j,k)*G%US%L_to_m**2*G%areaT(i,j)*G%mask2dT(i,j) + tr_inv(i,j,k) = Tr(m)%t(i,j,k) * (vol_scale * h(i,j,k) * G%areaT(i,j)*G%mask2dT(i,j)) enddo ; enddo ; enddo total_inv = reproducing_sum(tr_inv, is+(1-G%isd), ie+(1-G%isd), js+(1-G%jsd), je+(1-G%jsd)) if (is_root_pe()) write(0,'(A,1X,A5,1X,ES25.16,1X,A)') "h-point: inventory", Tr(m)%name, total_inv, mesg diff --git a/src/tracer/advection_test_tracer.F90 b/src/tracer/advection_test_tracer.F90 index a051fe3da9..9d328e7a8f 100644 --- a/src/tracer/advection_test_tracer.F90 +++ b/src/tracer/advection_test_tracer.F90 @@ -357,6 +357,8 @@ function advection_test_stock(h, stocks, G, GV, CS, names, units, stock_index) integer, optional, intent(in) :: stock_index !< the coded index of a specific stock being sought. integer :: advection_test_stock !< the number of stocks calculated here. + ! Local variables + real :: stock_scale ! The dimensional scaling factor to convert stocks to kg [kg H-1 L-2 ~> kg m-3 or nondim] 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 @@ -371,14 +373,14 @@ function advection_test_stock(h, stocks, G, GV, CS, names, units, stock_index) return endif ; endif + stock_scale = G%US%L_to_m**2 * GV%H_to_kg_m2 do m=1,CS%ntr call query_vardesc(CS%tr_desc(m), name=names(m), units=units(m), caller="advection_test_stock") stocks(m) = 0.0 do k=1,nz ; do j=js,je ; do i=is,ie - stocks(m) = stocks(m) + CS%tr(i,j,k,m) * & - (G%mask2dT(i,j) * G%US%L_to_m**2*G%areaT(i,j) * h(i,j,k)) + stocks(m) = stocks(m) + CS%tr(i,j,k,m) * (G%mask2dT(i,j) * G%areaT(i,j) * h(i,j,k)) enddo ; enddo ; enddo - stocks(m) = GV%H_to_kg_m2 * stocks(m) + stocks(m) = stock_scale * stocks(m) enddo advection_test_stock = CS%ntr diff --git a/src/tracer/boundary_impulse_tracer.F90 b/src/tracer/boundary_impulse_tracer.F90 index 55f061da20..4856abaefd 100644 --- a/src/tracer/boundary_impulse_tracer.F90 +++ b/src/tracer/boundary_impulse_tracer.F90 @@ -280,6 +280,9 @@ subroutine boundary_impulse_tracer_column_physics(h_old, h_new, ea, eb, fluxes, end subroutine boundary_impulse_tracer_column_physics !> Calculate total inventory of tracer +!> This function calculates the mass-weighted integral of the boundary impulse, +!! tracer stocks returning the number of stocks it has calculated. If the stock_index +!! is present, only the stock corresponding to that coded index is returned. function boundary_impulse_stock(h, stocks, G, GV, CS, names, units, stock_index) 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,6 +302,7 @@ function boundary_impulse_stock(h, stocks, G, GV, CS, names, units, stock_index) ! is present, only the stock corresponding to that coded index is returned. ! Local variables + real :: stock_scale ! The dimensional scaling factor to convert stocks to kg [kg H-1 L-2 ~> kg m-3 or nondim] 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 @@ -313,15 +317,15 @@ function boundary_impulse_stock(h, stocks, G, GV, CS, names, units, stock_index) return endif ; endif + stock_scale = G%US%L_to_m**2 * GV%H_to_kg_m2 do m=1,1 call query_vardesc(CS%tr_desc(m), name=names(m), units=units(m), caller="boundary_impulse_stock") units(m) = trim(units(m))//" kg" stocks(m) = 0.0 do k=1,nz ; do j=js,je ; do i=is,ie - stocks(m) = stocks(m) + CS%tr(i,j,k,m) * & - (G%mask2dT(i,j) * G%US%L_to_m**2*G%areaT(i,j) * h(i,j,k)) + stocks(m) = stocks(m) + CS%tr(i,j,k,m) * (G%mask2dT(i,j) * G%areaT(i,j) * h(i,j,k)) enddo ; enddo ; enddo - stocks(m) = GV%H_to_kg_m2 * stocks(m) + stocks(m) = stock_scale * stocks(m) enddo boundary_impulse_stock = CS%ntr diff --git a/src/tracer/dye_example.F90 b/src/tracer/dye_example.F90 index ccb1a3635b..2919f2d95f 100644 --- a/src/tracer/dye_example.F90 +++ b/src/tracer/dye_example.F90 @@ -338,7 +338,8 @@ function dye_stock(h, stocks, G, GV, CS, names, units, stock_index) integer :: dye_stock !< Return value: the number of stocks !! calculated here. -! Local variables + ! Local variables + real :: stock_scale ! The dimensional scaling factor to convert stocks to kg [kg H-1 L-2 ~> kg m-3 or nondim] 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 @@ -353,15 +354,15 @@ function dye_stock(h, stocks, G, GV, CS, names, units, stock_index) return endif ; endif + stock_scale = G%US%L_to_m**2 * GV%H_to_kg_m2 do m=1,CS%ntr call query_vardesc(CS%tr_desc(m), name=names(m), units=units(m), caller="dye_stock") units(m) = trim(units(m))//" kg" stocks(m) = 0.0 do k=1,nz ; do j=js,je ; do i=is,ie - stocks(m) = stocks(m) + CS%tr(i,j,k,m) * & - (G%mask2dT(i,j) * G%US%L_to_m**2*G%areaT(i,j) * h(i,j,k)) + stocks(m) = stocks(m) + CS%tr(i,j,k,m) * (G%mask2dT(i,j) * G%areaT(i,j) * h(i,j,k)) enddo ; enddo ; enddo - stocks(m) = GV%H_to_kg_m2 * stocks(m) + stocks(m) = stock_scale * stocks(m) enddo dye_stock = CS%ntr diff --git a/src/tracer/ideal_age_example.F90 b/src/tracer/ideal_age_example.F90 index 31d13c811e..19e1df59dc 100644 --- a/src/tracer/ideal_age_example.F90 +++ b/src/tracer/ideal_age_example.F90 @@ -383,10 +383,9 @@ function ideal_age_stock(h, stocks, G, GV, CS, names, units, stock_index) integer, optional, intent(in) :: stock_index !< the coded index of a specific stock !! being sought. integer :: ideal_age_stock !< The number of stocks calculated here. -! This function calculates the mass-weighted integral of all tracer stocks, -! returning the number of stocks it has calculated. If the stock_index -! is present, only the stock corresponding to that coded index is returned. + ! Local variables + real :: stock_scale ! The dimensional scaling factor to convert stocks to kg [kg H-1 L-2 ~> kg m-3 or nondim] 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 @@ -401,15 +400,15 @@ function ideal_age_stock(h, stocks, G, GV, CS, names, units, stock_index) return endif ; endif + stock_scale = G%US%L_to_m**2 * GV%H_to_kg_m2 do m=1,CS%ntr call query_vardesc(CS%tr_desc(m), name=names(m), units=units(m), caller="ideal_age_stock") units(m) = trim(units(m))//" kg" stocks(m) = 0.0 do k=1,nz ; do j=js,je ; do i=is,ie - stocks(m) = stocks(m) + CS%tr(i,j,k,m) * & - (G%mask2dT(i,j) * G%US%L_to_m**2*G%areaT(i,j) * h(i,j,k)) + stocks(m) = stocks(m) + CS%tr(i,j,k,m) * (G%mask2dT(i,j) * G%areaT(i,j) * h(i,j,k)) enddo ; enddo ; enddo - stocks(m) = GV%H_to_kg_m2 * stocks(m) + stocks(m) = stock_scale * stocks(m) enddo ideal_age_stock = CS%ntr diff --git a/src/tracer/oil_tracer.F90 b/src/tracer/oil_tracer.F90 index e73562dc1d..df96193181 100644 --- a/src/tracer/oil_tracer.F90 +++ b/src/tracer/oil_tracer.F90 @@ -38,23 +38,19 @@ module oil_tracer logical :: coupled_tracers = .false. !< These tracers are not offered to the coupler. character(len=200) :: IC_file !< The file in which the age-tracer initial values !! can be found, or an empty string for internal initialization. - logical :: Z_IC_file !< If true, the IC_file is in Z-space. The default is false. + logical :: Z_IC_file !< If true, the IC_file is in Z-space. The default is false. real :: oil_source_longitude !< Latitude of source location (geographic) 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 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 - !! surface value equals young_val, in years. + real :: oil_start_year !< The time at which the oil source starts [years] + real :: oil_end_year !< The time at which the oil source ends [years] type(time_type), pointer :: Time => NULL() !< A pointer to the ocean model's clock. type(tracer_registry_type), pointer :: tr_Reg => NULL() !< A pointer to the MOM tracer registry real, pointer :: tr(:,:,:,:) => NULL() !< The array of tracers used in this subroutine, in g m-3? real, dimension(NTR_MAX) :: IC_val = 0.0 !< The (uniform) initial condition value. - real, dimension(NTR_MAX) :: young_val = 0.0 !< The value assigned to tr at the surface. 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 [T-1 ~> s-1] calculated from oil_decay_days integer, dimension(NTR_MAX) :: oil_source_k !< Layer of source @@ -138,7 +134,8 @@ function register_oil_tracer(HI, GV, US, 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", scale=US%T_to_s, 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 "//& @@ -258,8 +255,7 @@ subroutine initialize_oil_tracer(restart, day, G, GV, US, h, diag, OBC, CS, & if (len_trim(CS%IC_file) > 0) then ! Read the tracer concentrations from a netcdf file. if (.not.file_exists(CS%IC_file, G%Domain)) & - call MOM_error(FATAL, "initialize_oil_tracer: "// & - "Unable to open "//CS%IC_file) + call MOM_error(FATAL, "initialize_oil_tracer: Unable to open "//CS%IC_file) if (CS%Z_IC_file) then OK = tracer_Z_init(CS%tr(:,:,:,m), h, CS%IC_file, name, & @@ -331,6 +327,7 @@ subroutine oil_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, US ! Local variables real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: h_work ! Used so that h can be modified [H ~> m or kg m-2] real :: Isecs_per_year = 1.0 / (365.0*86400.0) + real :: vol_scale ! A conversion factor for volumes into m3 [m3 H-1 L-2 ~> nondim or m3 kg-1] real :: year, h_total, ldecay integer :: i, j, k, is, ie, js, je, nz, m, k_max is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke @@ -375,6 +372,7 @@ subroutine oil_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, US CS%oil_source_i>-999 .and. CS%oil_source_j>-999) then i=CS%oil_source_i ; j=CS%oil_source_j k_max=nz ; h_total=0. + vol_scale = GV%H_to_m * US%L_to_m**2 do k=nz, 2, -1 h_total = h_total + h_new(i,j,k) if (h_total<10.) k_max=k-1 ! Find bottom most interface that is 10 m above bottom @@ -384,15 +382,14 @@ subroutine oil_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, US if (k>0) then k=min(k,k_max) ! Only insert k or first layer with interface 10 m above bottom CS%tr(i,j,k,m) = CS%tr(i,j,k,m) + CS%oil_source_rate*dt / & - ((h_new(i,j,k)+GV%H_subroundoff) * G%US%L_to_m**2*G%areaT(i,j) ) + (vol_scale * (h_new(i,j,k)+GV%H_subroundoff) * G%areaT(i,j) ) elseif (k<0) then h_total=GV%H_subroundoff do k=1, nz h_total = h_total + h_new(i,j,k) enddo do k=1, nz - CS%tr(i,j,k,m) = CS%tr(i,j,k,m) + CS%oil_source_rate*dt/(h_total & - * G%US%L_to_m**2*G%areaT(i,j) ) + CS%tr(i,j,k,m) = CS%tr(i,j,k,m) + CS%oil_source_rate*dt / (vol_scale * h_total * G%areaT(i,j) ) enddo endif enddo @@ -416,11 +413,8 @@ function oil_stock(h, stocks, G, GV, CS, names, units, stock_index) !! being sought. integer :: oil_stock !< The number of stocks calculated here. -! This function calculates the mass-weighted integral of all tracer stocks, -! returning the number of stocks it has calculated. If the stock_index -! is present, only the stock corresponding to that coded index is returned. - ! Local variables + real :: stock_scale ! The dimensional scaling factor to convert stocks to kg [kg H-1 L-2 ~> kg m-3 or nondim] 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 @@ -435,15 +429,15 @@ function oil_stock(h, stocks, G, GV, CS, names, units, stock_index) return endif ; endif + stock_scale = G%US%L_to_m**2 * GV%H_to_kg_m2 do m=1,CS%ntr call query_vardesc(CS%tr_desc(m), name=names(m), units=units(m), caller="oil_stock") units(m) = trim(units(m))//" kg" stocks(m) = 0.0 do k=1,nz ; do j=js,je ; do i=is,ie - stocks(m) = stocks(m) + CS%tr(i,j,k,m) * & - (G%mask2dT(i,j) * G%US%L_to_m**2*G%areaT(i,j) * h(i,j,k)) + stocks(m) = stocks(m) + CS%tr(i,j,k,m) * (G%mask2dT(i,j) * G%areaT(i,j) * h(i,j,k)) enddo ; enddo ; enddo - stocks(m) = GV%H_to_kg_m2 * stocks(m) + stocks(m) = stock_scale * stocks(m) enddo oil_stock = CS%ntr diff --git a/src/tracer/pseudo_salt_tracer.F90 b/src/tracer/pseudo_salt_tracer.F90 index 9cb94a3054..eb15c05580 100644 --- a/src/tracer/pseudo_salt_tracer.F90 +++ b/src/tracer/pseudo_salt_tracer.F90 @@ -261,10 +261,8 @@ function pseudo_salt_stock(h, stocks, G, GV, CS, names, units, stock_index) integer :: pseudo_salt_stock !< Return value: the number of !! stocks calculated here. -! This function calculates the mass-weighted integral of all tracer stocks, -! returning the number of stocks it has calculated. If the stock_index -! is present, only the stock corresponding to that coded index is returned. - + ! Local variables + real :: stock_scale ! The dimensional scaling factor to convert stocks to kg [kg H-1 L-2 ~> kg m-3 or nondim] integer :: i, j, k, is, ie, js, je, nz is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke @@ -279,14 +277,14 @@ function pseudo_salt_stock(h, stocks, G, GV, CS, names, units, stock_index) return endif ; endif + stock_scale = G%US%L_to_m**2 * GV%H_to_kg_m2 call query_vardesc(CS%tr_desc, name=names(1), units=units(1), caller="pseudo_salt_stock") units(1) = trim(units(1))//" kg" stocks(1) = 0.0 do k=1,nz ; do j=js,je ; do i=is,ie - stocks(1) = stocks(1) + CS%diff(i,j,k) * & - (G%mask2dT(i,j) * G%US%L_to_m**2*G%areaT(i,j) * h(i,j,k)) + stocks(1) = stocks(1) + CS%diff(i,j,k) * (G%mask2dT(i,j) * G%areaT(i,j) * h(i,j,k)) enddo ; enddo ; enddo - stocks(1) = GV%H_to_kg_m2 * stocks(1) + stocks(1) = stock_scale * stocks(1) pseudo_salt_stock = 1 diff --git a/src/tracer/tracer_example.F90 b/src/tracer/tracer_example.F90 index 395eec50c5..349720304b 100644 --- a/src/tracer/tracer_example.F90 +++ b/src/tracer/tracer_example.F90 @@ -373,7 +373,8 @@ function USER_tracer_stock(h, stocks, G, GV, CS, names, units, stock_index) integer :: USER_tracer_stock !< Return value: the number of !! stocks calculated here. -! Local variables + ! Local variables + real :: stock_scale ! The dimensional scaling factor to convert stocks to kg [kg H-1 L-2 ~> kg m-3 or nondim] 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 @@ -387,15 +388,15 @@ function USER_tracer_stock(h, stocks, G, GV, CS, names, units, stock_index) return endif ; endif + stock_scale = G%US%L_to_m**2 * GV%H_to_kg_m2 do m=1,NTR call query_vardesc(CS%tr_desc(m), name=names(m), units=units(m), caller="USER_tracer_stock") units(m) = trim(units(m))//" kg" stocks(m) = 0.0 do k=1,nz ; do j=js,je ; do i=is,ie - stocks(m) = stocks(m) + CS%tr(i,j,k,m) * & - (G%mask2dT(i,j) * G%US%L_to_m**2*G%areaT(i,j) * h(i,j,k)) + stocks(m) = stocks(m) + CS%tr(i,j,k,m) * (G%mask2dT(i,j) * G%areaT(i,j) * h(i,j,k)) enddo ; enddo ; enddo - stocks(m) = GV%H_to_kg_m2 * stocks(m) + stocks(m) = stock_scale * stocks(m) enddo USER_tracer_stock = NTR From e7d425416fe7e573356326b15330c74d00dc91d7 Mon Sep 17 00:00:00 2001 From: Olga Sergienko Date: Tue, 1 Jun 2021 15:08:29 -0400 Subject: [PATCH 092/112] In MOM_ice_dynamics.F90 the ice-stiffness parameter A_Glen is changed from a constant to a field to allow for its spatial variability; several parameters are added to a restart file. In MOM_ice_shelf_initialize.F90 a subroutine initialize_ice_AGlen is added; it initializes the ice-stiffness parameter A_Glen either by reading it from a file or assigning a constant value. --- src/ice_shelf/MOM_ice_shelf_dynamics.F90 | 53 ++++++++++++-------- src/ice_shelf/MOM_ice_shelf_initialize.F90 | 57 ++++++++++++++++++++-- 2 files changed, 86 insertions(+), 24 deletions(-) diff --git a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 index 171fbdfc79..e5a278912a 100644 --- a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 +++ b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 @@ -26,6 +26,7 @@ module MOM_ice_shelf_dynamics use MOM_checksums, only : hchksum, qchksum use MOM_ice_shelf_initialize, only : initialize_ice_shelf_boundary_channel,initialize_ice_flow_from_file use MOM_ice_shelf_initialize, only : initialize_ice_shelf_boundary_from_file,initialize_ice_C_basal_friction +use MOM_ice_shelf_initialize, only : initialize_ice_AGlen implicit none ; private #include @@ -78,6 +79,8 @@ module MOM_ice_shelf_dynamics !! on corner-points (B grid) [degC] real, pointer, dimension(:,:) :: tmask => NULL() !< A mask on tracer points that is 1 where there is ice. real, pointer, dimension(:,:) :: ice_visc => NULL() !< Glen's law ice viscosity, often in [R L4 Z T-1 ~> kg m2 s-1]. + real, pointer, dimension(:,:) :: AGlen_visc => NULL() !< Ice-stiffness parameter in Glen's law ice viscosity, + !!often in [R-1/3 L-2/3 Z-1/3 T-1 ~> kg-1/3 m-1/3 s-1]. real, pointer, dimension(:,:) :: thickness_bdry_val => NULL() !< The ice thickness at an inflowing boundary [Z ~> m]. real, pointer, dimension(:,:) :: u_bdry_val => NULL() !< The zonal ice velocity at inflowing boundaries !! [L yr-1 ~> m yr-1] @@ -129,11 +132,8 @@ module MOM_ice_shelf_dynamics real :: CFL_factor !< A factor used to limit subcycled advective timestep in uncoupled runs !! i.e. dt <= CFL_factor * min(dx / u) - real :: A_glen_isothermal !< Ice viscosity parameter in Glen's Law, [Pa-3 s-1]. real :: n_glen !< Nonlinearity exponent in Glen's Law real :: eps_glen_min !< Min. strain rate to avoid infinite Glen's law viscosity, [year-1]. -! real :: C_basal_friction !< Coefficient in sliding law tau_b = C u^(n_basal_fric), in -! !! units= Pa (m yr-1)-(n_basal_fric) real :: n_basal_fric !< Exponent in sliding law tau_b = C u^(m_slide) real :: density_ocean_avg !< A typical ocean density [R ~> kg m-3]. This does not affect ocean !! circulation or thermodynamics. It is used to estimate the @@ -259,6 +259,7 @@ subroutine register_ice_shelf_dyn_restarts(G, param_file, CS, restart_CS) allocate( CS%v_shelf(IsdB:IedB,JsdB:JedB) ) ; CS%v_shelf(:,:) = 0.0 allocate( CS%t_shelf(isd:ied,jsd:jed) ) ; CS%t_shelf(:,:) = -10.0 allocate( CS%ice_visc(isd:ied,jsd:jed) ) ; CS%ice_visc(:,:) = 0.0 + allocate( CS%AGlen_visc(isd:ied,jsd:jed) ) ; CS%AGlen_visc(:,:) = 2.261e-25 allocate( CS%basal_traction(isd:ied,jsd:jed) ) ; CS%basal_traction(:,:) = 0.0 allocate( CS%C_basal_friction(isd:ied,jsd:jed) ) ; CS%C_basal_friction(:,:) = 5.0e10 allocate( CS%OD_av(isd:ied,jsd:jed) ) ; CS%OD_av(:,:) = 0.0 @@ -266,15 +267,35 @@ subroutine register_ice_shelf_dyn_restarts(G, param_file, CS, restart_CS) allocate( CS%taudx_shelf(IsdB:IedB,JsdB:JedB) ) ; CS%taudx_shelf(:,:) = 0.0 allocate( CS%taudy_shelf(IsdB:IedB,JsdB:JedB) ) ; CS%taudy_shelf(:,:) = 0.0 allocate( CS%bed_elev(isd:ied,jsd:jed) ) ; CS%bed_elev(:,:)=G%bathyT(:,:)!CS%bed_elev(:,:) = 0.0 - ! additional restarts for ice shelf state + allocate( CS%u_bdry_val(IsdB:IedB,JsdB:JedB) ) ; CS%u_bdry_val(:,:) = 0.0 + allocate( CS%v_bdry_val(IsdB:IedB,JsdB:JedB) ) ; CS%v_bdry_val(:,:) = 0.0 + allocate( CS%u_face_mask_bdry(IsdB:IedB,JsdB:JedB) ) ; CS%u_face_mask_bdry(:,:) = -2.0 + allocate( CS%v_face_mask_bdry(IsdB:iedB,JsdB:JedB) ) ; CS%v_face_mask_bdry(:,:) = -2.0 + allocate( CS%h_bdry_val(isd:ied,jsd:jed) ) ; CS%h_bdry_val(:,:) = 0.0 + ! additional restarts for ice shelf state call register_restart_field(CS%u_shelf, "u_shelf", .false., restart_CS, & "ice sheet/shelf u-velocity", "m s-1", hor_grid='Bu') call register_restart_field(CS%v_shelf, "v_shelf", .false., restart_CS, & "ice sheet/shelf v-velocity", "m s-1", hor_grid='Bu') + call register_restart_field(CS%u_bdry_val, "u_bdry", .false., restart_CS, & + "ice sheet/shelf boundary u-velocity", "m s-1", hor_grid='Bu') + call register_restart_field(CS%v_bdry_val, "v_bdry", .false., restart_CS, & + "ice sheet/shelf boundary v-velocity", "m s-1", hor_grid='Bu') + call register_restart_field(CS%u_face_mask_bdry, "u_bdry_mask", .false., restart_CS, & + "ice sheet/shelf boundary u-mask", "nondim", hor_grid='Bu') + call register_restart_field(CS%v_face_mask_bdry, "v_bdry_mask", .false., restart_CS, & + "ice sheet/shelf boundary v-mask", "nondim", hor_grid='Bu') + call register_restart_field(CS%OD_av, "OD_av", .true., restart_CS, & "Average open ocean depth in a cell","m") call register_restart_field(CS%ground_frac, "ground_frac", .true., restart_CS, & "fractional degree of grounding", "nondim") + call register_restart_field(CS%C_basal_friction, "tau_b_beta", .true., restart_CS, & + "basal sliding coefficients", "Pa (m s-1)^n_sliding") + call register_restart_field(CS%AGlen_visc, "A_Glen", .true., restart_CS, & + "ice-stiffness parameter", "Pa-3 s-1") + call register_restart_field(CS%h_bdry_val, "h_bdry", .false., restart_CS, & + "ice thickness at the boundary","m") endif end subroutine register_ice_shelf_dyn_restarts @@ -374,10 +395,6 @@ subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_ "The gravitational acceleration of the Earth.", & units="m s-2", default = 9.80, scale=US%m_s_to_L_T**2*US%Z_to_m) - call get_param(param_file, mdl, "A_GLEN_ISOTHERM", CS%A_glen_isothermal, & - "Ice viscosity parameter in Glen's Law", & - units="Pa-3 s-1", default=2.2261e-25, scale=1.0) - ! This default is equivalent to 3.0001e-25 Pa-3 s-1, appropriate at about -10 C. call get_param(param_file, mdl, "GLEN_EXPONENT", CS%n_glen, & "nonlinearity exponent in Glen's Law", & units="none", default=3.) @@ -387,10 +404,6 @@ subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_ call get_param(param_file, mdl, "BASAL_FRICTION_EXP", CS%n_basal_fric, & "Exponent in sliding law \tau_b = C u^(n_basal_fric)", & units="none", fail_if_missing=.true.) -! call get_param(param_file, mdl, "BASAL_FRICTION_COEFF", CS%C_basal_friction, & -! "Coefficient in sliding law \tau_b = C u^(n_basal_fric)", & -! units="Pa (m s-1)^(n_basal_fric)", scale=US%kg_m2s_to_RZ_T**CS%n_basal_fric, & -! fail_if_missing=.true.) call get_param(param_file, mdl, "DENSITY_ICE", CS%density_ice, & "A typical density of ice.", units="kg m-3", default=917.0, scale=US%kg_m3_to_R) call get_param(param_file, mdl, "CONJUGATE_GRADIENT_TOLERANCE", CS%cg_tolerance, & @@ -423,15 +436,10 @@ subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_ ! previously allocated for registration for restarts. if (active_shelf_dynamics) then - allocate( CS%u_bdry_val(Isdq:Iedq,Jsdq:Jedq) ) ; CS%u_bdry_val(:,:) = 0.0 - allocate( CS%v_bdry_val(Isdq:Iedq,Jsdq:Jedq) ) ; CS%v_bdry_val(:,:) = 0.0 allocate( CS%t_bdry_val(isd:ied,jsd:jed) ) ; CS%t_bdry_val(:,:) = -15.0 - allocate( CS%h_bdry_val(isd:ied,jsd:jed) ) ; CS%h_bdry_val(:,:) = 0.0 allocate( CS%thickness_bdry_val(isd:ied,jsd:jed) ) ; CS%thickness_bdry_val(:,:) = 0.0 allocate( CS%u_face_mask(Isdq:Iedq,Jsdq:Jedq) ) ; CS%u_face_mask(:,:) = 0.0 allocate( CS%v_face_mask(Isdq:Iedq,Jsdq:Jedq) ) ; CS%v_face_mask(:,:) = 0.0 - allocate( CS%u_face_mask_bdry(Isdq:Iedq,Jsdq:Jedq) ) ; CS%u_face_mask_bdry(:,:) = -2.0 - allocate( CS%v_face_mask_bdry(Isdq:iedq,Jsdq:Jedq) ) ; CS%v_face_mask_bdry(:,:) = -2.0 allocate( CS%u_flux_bdry_val(Isdq:Iedq,jsd:jed) ) ; CS%u_flux_bdry_val(:,:) = 0.0 allocate( CS%v_flux_bdry_val(isd:ied,Jsdq:Jedq) ) ; CS%v_flux_bdry_val(:,:) = 0.0 allocate( CS%umask(Isdq:Iedq,Jsdq:Jedq) ) ; CS%umask(:,:) = -1.0 @@ -528,6 +536,10 @@ subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_ call initialize_ice_C_basal_friction(CS%C_basal_friction, G, US, param_file) call pass_var(CS%C_basal_friction, G%domain) + ! initialize ice-stiffness AGlen + call initialize_ice_AGlen(CS%AGlen_visc, G, US, param_file) + call pass_var(CS%AGlen_visc, G%domain) + !initialize boundary conditions call initialize_ice_shelf_boundary_from_file(CS%u_face_mask_bdry, CS%v_face_mask_bdry, & CS%u_bdry_val, CS%v_bdry_val, CS%umask, CS%vmask, CS%h_bdry_val, & @@ -2558,11 +2570,13 @@ subroutine calc_shelf_visc(CS, ISS, G, US, u_shlf, v_shlf) n_g = CS%n_glen; eps_min = CS%eps_glen_min CS%ice_visc(:,:)=1e22 - Visc_coef = US%kg_m2s_to_RZ_T*US%m_to_L*US%Z_to_L*(CS%A_glen_isothermal)**(-1./CS%n_glen) +! Visc_coef = US%kg_m2s_to_RZ_T*US%m_to_L*US%Z_to_L*(CS%A_glen_isothermal)**(-1./CS%n_glen) do j=jsc,jec do i=isc,iec if ((ISS%hmask(i,j) == 1) .OR. (ISS%hmask(i,j) == 3)) then + Visc_coef = US%kg_m2s_to_RZ_T*US%m_to_L*US%Z_to_L*(CS%AGlen_visc(i,j))**(-1./CS%n_glen) + ux = ((u_shlf(I,J) + (u_shlf(I,J-1) + u_shlf(I,J+1))) - & (u_shlf(I-1,J) + (u_shlf(I-1,J-1) + u_shlf(I-1,J+1)))) / (3*G%dxT(i,j)) vx = ((v_shlf(I,J) + v_shlf(I,J-1) + v_shlf(I,J+1)) - & @@ -3079,7 +3093,8 @@ subroutine ice_shelf_dyn_end(CS) deallocate(CS%u_face_mask, CS%v_face_mask) deallocate(CS%umask, CS%vmask) - deallocate(CS%ice_visc, CS%basal_traction,CS%C_basal_friction) + deallocate(CS%ice_visc, CS%AGlen_visc) + deallocate(CS%basal_traction,CS%C_basal_friction) deallocate(CS%OD_rt, CS%OD_av) deallocate(CS%t_bdry_val, CS%bed_elev) deallocate(CS%ground_frac, CS%ground_frac_rt) diff --git a/src/ice_shelf/MOM_ice_shelf_initialize.F90 b/src/ice_shelf/MOM_ice_shelf_initialize.F90 index 19f34f293e..f3a5f210fc 100644 --- a/src/ice_shelf/MOM_ice_shelf_initialize.F90 +++ b/src/ice_shelf/MOM_ice_shelf_initialize.F90 @@ -21,6 +21,7 @@ module MOM_ice_shelf_initialize public initialize_ice_flow_from_file public initialize_ice_shelf_boundary_from_file public initialize_ice_C_basal_friction +public initialize_ice_AGlen ! A note on unit descriptions in comments: MOM6 uses units that can be rescaled for dimensional ! consistency testing. These are noted in comments with units like Z, H, L, and T, along with ! their mks counterparts with notation like "a velocity [Z T-1 ~> m s-1]". If the units @@ -512,7 +513,7 @@ subroutine initialize_ice_shelf_boundary_from_file(u_face_mask_bdry, v_face_mask call get_param(PF, mdl, "INPUTDIR", inputdir, default=".") inputdir = slasher(inputdir) call get_param(PF, mdl, "ICE_SHELF_BC_FILE", bc_file, & - "The file from which the boundary condiions are read.", & + "The file from which the boundary conditions are read.", & default="ice_shelf_bc.nc") call get_param(PF, mdl, "ICE_THICKNESS_FILE", icethick_file, & "The file from which the ice-shelf thickness is read.", & @@ -575,7 +576,7 @@ end subroutine initialize_ice_shelf_boundary_from_file subroutine initialize_ice_C_basal_friction(C_basal_friction, G, US, PF) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure real, dimension(SZDI_(G),SZDJ_(G)), & - intent(inout) :: C_basal_friction !< Ice-shelf thickness + intent(inout) :: C_basal_friction !< Ice-stream basal friction type(unit_scale_type), intent(in) :: US !< A structure containing unit conversion factors type(param_file_type), intent(in) :: PF !< A structure to parse for run-time parameters @@ -587,7 +588,7 @@ subroutine initialize_ice_C_basal_friction(C_basal_friction, G, US, PF) character(len=200) :: inputdir, filename, C_friction_file call get_param(PF, mdl, "ICE_BASAL_FRICTION_CONFIG", config, & - "This specifies how the initial ice profile is specified. "//& + "This specifies how the initial basal friction profile is specified. "//& "Valid values are: CONSTANT and FILE.", & fail_if_missing=.true.) @@ -602,10 +603,10 @@ subroutine initialize_ice_C_basal_friction(C_basal_friction, G, US, PF) inputdir = slasher(inputdir) call get_param(PF, mdl, "BASAL_FRICTION_FILE", C_friction_file, & - "The file from which the boundary condiions are read.", & + "The file from which basal friction coefficients are read.", & default="ice_basal_friction.nc") filename = trim(inputdir)//trim(C_friction_file) - call log_param(PF, mdl, "INPUTDIR/BASAL_FRICTIOM_FILE", filename) + call log_param(PF, mdl, "INPUTDIR/BASAL_FRICTION_FILE", filename) call get_param(PF, mdl, "BASAL_FRICTION_VARNAME", varname, & "The variable to use in basal traction.", & @@ -620,4 +621,50 @@ subroutine initialize_ice_C_basal_friction(C_basal_friction, G, US, PF) end subroutine +!> Initialize ice basal friction +subroutine initialize_ice_AGlen(AGlen, G, US, PF) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(inout) :: AGlen !< The ice-stiffness parameter A_Glen + type(unit_scale_type), intent(in) :: US !< A structure containing unit conversion factors + type(param_file_type), intent(in) :: PF !< A structure to parse for run-time parameters + +! integer :: i, j + real :: A_Glen + character(len=40) :: mdl = "initialize_ice_stiffness" ! This subroutine's name. + character(len=200) :: config + character(len=200) :: varname + character(len=200) :: inputdir, filename, AGlen_file + + call get_param(PF, mdl, "ICE_A_GLEN_CONFIG", config, & + "This specifies how the initial ice-stiffness parameter is specified. "//& + "Valid values are: CONSTANT and FILE.", & + fail_if_missing=.true.) + + if (trim(config)=="CONSTANT") then + call get_param(PF, mdl, "A_GLEN", A_Glen, & + "Ice-stiffness parameter.", units="Pa-3 s-1", default=2.261e-25) + + AGlen(:,:) = A_Glen + + elseif (trim(config)=="FILE") then + call MOM_mesg(" MOM_ice_shelf.F90, initialize_ice_shelf: reading ice-stiffness parameter") + call get_param(PF, mdl, "INPUTDIR", inputdir, default=".") + inputdir = slasher(inputdir) + + call get_param(PF, mdl, "ICE_STIFFNESS_FILE", AGlen_file, & + "The file from which the ice-stiffness is read.", & + default="ice_AGlen.nc") + filename = trim(inputdir)//trim(AGlen_file) + call log_param(PF, mdl, "INPUTDIR/ICE_STIFFNESS_FILE", filename) + call get_param(PF, mdl, "A_GLEN_VARNAME", varname, & + "The variable to use as ice-stiffness.", & + default="A_GLEN") + + if (.not.file_exists(filename, G%Domain)) call MOM_error(FATAL, & + " initialize_ice_stiffness_from_file: Unable to open "//trim(filename)) + call MOM_read_data(filename,trim(varname),AGlen,G%Domain) + + endif +end subroutine end module MOM_ice_shelf_initialize From d9edec10754e6e3c3ec704b8c7f921356a8f0f79 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 4 Jun 2021 12:05:47 -0400 Subject: [PATCH 093/112] Update MOM_internal_tide_input.F90 --- src/parameterizations/vertical/MOM_internal_tide_input.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/parameterizations/vertical/MOM_internal_tide_input.F90 b/src/parameterizations/vertical/MOM_internal_tide_input.F90 index 4cfb184a1e..a1fe88d114 100644 --- a/src/parameterizations/vertical/MOM_internal_tide_input.F90 +++ b/src/parameterizations/vertical/MOM_internal_tide_input.F90 @@ -352,7 +352,7 @@ subroutine int_tide_input_init(Time, G, GV, US, param_file, diag, CS, itide) units="m-1", default=8.e-4*atan(1.0), scale=US%L_to_m) call get_param(param_file, mdl, "KAPPA_H2_FACTOR", kappa_h2_factor, & - "A scaling factor for the roughness amplitude with n "//& + "A scaling factor for the roughness amplitude with "//& "INT_TIDE_DISSIPATION.", units="nondim", default=1.0) call get_param(param_file, mdl, "TKE_ITIDE_MAX", CS%TKE_itide_max, & "The maximum internal tide energy source available to mix "//& From 6ce96b34bb37e91f66eee31a142753d73e9cc083 Mon Sep 17 00:00:00 2001 From: Matthew Harrison Date: Mon, 14 Jun 2021 15:34:42 -0400 Subject: [PATCH 094/112] Change the declaration of stack variable in apply_flux_adjustments to exclude halos. --- config_src/drivers/FMS_cap/MOM_surface_forcing_gfdl.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/config_src/drivers/FMS_cap/MOM_surface_forcing_gfdl.F90 b/config_src/drivers/FMS_cap/MOM_surface_forcing_gfdl.F90 index 162b7f5f8d..cec7a5d7c9 100644 --- a/config_src/drivers/FMS_cap/MOM_surface_forcing_gfdl.F90 +++ b/config_src/drivers/FMS_cap/MOM_surface_forcing_gfdl.F90 @@ -1112,7 +1112,7 @@ subroutine apply_flux_adjustments(G, US, CS, Time, fluxes) type(forcing), intent(inout) :: fluxes !< Surface fluxes structure ! Local variables - real, dimension(SZI_(G),SZJ_(G)) :: temp_at_h ! Various fluxes at h points [W m-2] or [kg m-2 s-1] + real, dimension(G%isc:G%iec,G%jsc:G%jec) :: temp_at_h ! Various fluxes at h points [W m-2] or [kg m-2 s-1] integer :: isc, iec, jsc, jec, i, j logical :: overrode_h From 2c871c5a00f1cbbca316c4f2bf1ee745af60c255 Mon Sep 17 00:00:00 2001 From: William Cooke Date: Mon, 14 Jun 2021 17:12:12 -0400 Subject: [PATCH 095/112] Updating flux_const for SALT and TEMP Updating for addition of FLUX_CONST_SALT and FLUX_CONST_TEMP with clean history. Unit_scaling has been added, but answers change for different values of T_RESCALE_POWER. --- .../FMS_cap/MOM_surface_forcing_gfdl.F90 | 41 +++++++++++-------- 1 file changed, 24 insertions(+), 17 deletions(-) diff --git a/config_src/drivers/FMS_cap/MOM_surface_forcing_gfdl.F90 b/config_src/drivers/FMS_cap/MOM_surface_forcing_gfdl.F90 index 162b7f5f8d..29bb627aba 100644 --- a/config_src/drivers/FMS_cap/MOM_surface_forcing_gfdl.F90 +++ b/config_src/drivers/FMS_cap/MOM_surface_forcing_gfdl.F90 @@ -111,6 +111,8 @@ module MOM_surface_forcing_gfdl logical :: restore_temp !< If true, the coupled MOM driver adds a term to restore sea !! surface temperature to a specified value. real :: Flux_const !< Piston velocity for surface restoring [Z T-1 ~> m s-1] + real :: Flux_const_salt !< Piston velocity for surface salt restoring [Z T-1 ~> m s-1] + real :: Flux_const_temp !< Piston velocity for surface temp restoring [Z T-1 ~> m s-1] logical :: salt_restore_as_sflux !< If true, SSS restore as salt flux instead of water flux logical :: adjust_net_srestore_to_zero !< Adjust srestore to zero (for both salt_flux or vprec) logical :: adjust_net_srestore_by_scaling !< Adjust srestore w/o moving zero contour @@ -296,17 +298,12 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, call safe_alloc_ptr(fluxes%TKE_tidal,isd,ied,jsd,jed) call safe_alloc_ptr(fluxes%ustar_tidal,isd,ied,jsd,jed) - if (CS%allow_flux_adjustments) then - call safe_alloc_ptr(fluxes%heat_added,isd,ied,jsd,jed) - call safe_alloc_ptr(fluxes%salt_flux_added,isd,ied,jsd,jed) - endif - do j=js-2,je+2 ; do i=is-2,ie+2 fluxes%TKE_tidal(i,j) = CS%TKE_tidal(i,j) fluxes%ustar_tidal(i,j) = CS%ustar_tidal(i,j) enddo ; enddo - if (CS%restore_temp) call safe_alloc_ptr(fluxes%heat_added,isd,ied,jsd,jed) + call safe_alloc_ptr(fluxes%heat_added,isd,ied,jsd,jed) endif ! endif for allocation and initialization @@ -336,10 +333,8 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, fluxes%fluxes_used = .false. fluxes%dt_buoy_accum = US%s_to_T*valid_time - if (CS%allow_flux_adjustments) then - fluxes%heat_added(:,:) = 0.0 - fluxes%salt_flux_added(:,:) = 0.0 - endif + fluxes%heat_added(:,:) = 0.0 + fluxes%salt_flux_added(:,:) = 0.0 do j=js,je ; do i=is,ie fluxes%salt_flux(i,j) = 0.0 @@ -360,7 +355,7 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, do j=js,je ; do i=is,ie delta_sss = data_restore(i,j)- sfc_state%SSS(i,j) delta_sss = sign(1.0,delta_sss)*min(abs(delta_sss),CS%max_delta_srestore) - fluxes%salt_flux(i,j) = 1.e-3*G%mask2dT(i,j) * (CS%Rho0*CS%Flux_const)* & + fluxes%salt_flux(i,j) = 1.e-3*G%mask2dT(i,j) * (CS%Rho0*CS%Flux_const_salt)* & (CS%basin_mask(i,j)*open_ocn_mask(i,j)*CS%srestore_mask(i,j)) *delta_sss ! R Z T-1 ~> kg Salt m-2 s-1 enddo ; enddo if (CS%adjust_net_srestore_to_zero) then @@ -370,9 +365,10 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, fluxes%saltFluxGlobalAdj = 0. else work_sum(is:ie,js:je) = US%L_to_m**2*US%RZ_T_to_kg_m2s * & - G%areaT(is:ie,js:je)*fluxes%salt_flux(is:ie,js:je) + G%areaT(is:ie,js:je)*fluxes%salt_flux(is:ie,js:je) * G%mask2dT(is:ie,js:je) fluxes%saltFluxGlobalAdj = reproducing_sum(work_sum(:,:), isr,ier, jsr,jer)/CS%area_surf - fluxes%salt_flux(is:ie,js:je) = fluxes%salt_flux(is:ie,js:je) - kg_m2_s_conversion * fluxes%saltFluxGlobalAdj + fluxes%salt_flux(is:ie,js:je) = fluxes%salt_flux(is:ie,js:je) - & + kg_m2_s_conversion * fluxes%saltFluxGlobalAdj * G%mask2dT(is:ie,js:je) endif endif fluxes%salt_flux_added(is:ie,js:je) = fluxes%salt_flux(is:ie,js:je) ! Diagnostic @@ -382,7 +378,7 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, delta_sss = sfc_state%SSS(i,j) - data_restore(i,j) delta_sss = sign(1.0,delta_sss)*min(abs(delta_sss),CS%max_delta_srestore) fluxes%vprec(i,j) = (CS%basin_mask(i,j)*open_ocn_mask(i,j)*CS%srestore_mask(i,j))* & - (CS%Rho0*CS%Flux_const) * & + (CS%Rho0*CS%Flux_const_salt) * & delta_sss / (0.5*(sfc_state%SSS(i,j) + data_restore(i,j))) endif enddo ; enddo @@ -410,7 +406,7 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, delta_sst = data_restore(i,j)- sfc_state%SST(i,j) delta_sst = sign(1.0,delta_sst)*min(abs(delta_sst),CS%max_delta_trestore) fluxes%heat_added(i,j) = G%mask2dT(i,j) * CS%trestore_mask(i,j) * & - rhoXcp * delta_sst * CS%Flux_const ! W m-2 + rhoXcp * delta_sst * CS%Flux_const_temp ! W m-2 enddo ; enddo endif @@ -1252,6 +1248,7 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, wind_stagger) character(len=48) :: flnam character(len=240) :: basin_file integer :: i, j, isd, ied, jsd, jed + real :: unscaled_fluxconst isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed @@ -1375,9 +1372,14 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, wind_stagger) call get_param(param_file, mdl, "FLUXCONST", CS%Flux_const, & "The constant that relates the restoring surface fluxes to the relative "//& "surface anomalies (akin to a piston velocity). Note the non-MKS units.", & - default=0.0, units="m day-1", scale=US%m_to_Z*US%T_to_s) + default=0.0, units="m day-1", scale=US%m_to_Z*US%T_to_s,unscaled=unscaled_fluxconst) + call get_param(param_file, mdl, "FLUXCONST_SALT", CS%Flux_const_salt, & + "The constant that relates the restoring surface salt fluxes to the relative "//& + "surface anomalies (akin to a piston velocity). Note the non-MKS units.", & + fail_if_missing=.false.,default=unscaled_fluxconst, units="m day-1", scale=US%m_to_Z*US%T_to_s) ! Convert CS%Flux_const from m day-1 to m s-1. CS%Flux_const = CS%Flux_const / 86400.0 + CS%Flux_const_salt = CS%Flux_const_salt / 86400.0 call get_param(param_file, mdl, "SALT_RESTORE_FILE", CS%salt_restore_file, & "A file in which to find the surface salinity to use for restoring.", & default="salt_restore.nc") @@ -1422,9 +1424,14 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, wind_stagger) call get_param(param_file, mdl, "FLUXCONST", CS%Flux_const, & "The constant that relates the restoring surface fluxes to the relative "//& "surface anomalies (akin to a piston velocity). Note the non-MKS units.", & - default=0.0, units="m day-1", scale=US%m_to_Z*US%T_to_s) + default=0.0, units="m day-1", scale=US%m_to_Z*US%T_to_s,unscaled=unscaled_fluxconst) + call get_param(param_file, mdl, "FLUXCONST_TEMP", CS%Flux_const_temp, & + "The constant that relates the restoring surface temperature fluxes to the relative "//& + "surface anomalies (akin to a piston velocity). Note the non-MKS units.", & + fail_if_missing=.false.,default=unscaled_fluxconst, units="m day-1", scale=US%m_to_Z*US%T_to_s) ! Convert CS%Flux_const from m day-1 to m s-1. CS%Flux_const = CS%Flux_const / 86400.0 + CS%Flux_const_temp = CS%Flux_const_temp / 86400.0 call get_param(param_file, mdl, "SST_RESTORE_FILE", CS%temp_restore_file, & "A file in which to find the surface temperature to use for restoring.", & default="temp_restore.nc") From ee2e484e97bfcad43dc6b7c35695a5963f320171 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 15 Jun 2021 09:56:01 -0400 Subject: [PATCH 096/112] (*)Correct multi-name handling by save_restart Corrected the code that adds a suffix to the restart file names created by save_restart when there are multiple restart files to satisfy the NetCDF requirement that all variables in a time record start within the first 4 Gb of the record in the case where the restart file name was provided with the ".nc" extension already included. The code that reads the restarts already handled this case properly, but save_restart had an extra ".nc" in the names. MOM6 usually provided the root for the restart file without the .nc extension, but SIS2 does not and was having trouble reading its own restart files in some very large (e.g., 1/12-degree global) cases; identical corrections were made separately to MOM_restart.F90 and SIS_restart.F90. All answers and filenames are bitwise identical in any cases that were correctly restarting before. --- src/framework/MOM_restart.F90 | 18 ++++++++++++++---- 1 file changed, 14 insertions(+), 4 deletions(-) diff --git a/src/framework/MOM_restart.F90 b/src/framework/MOM_restart.F90 index 129f52ad4c..74db4e0f95 100644 --- a/src/framework/MOM_restart.F90 +++ b/src/framework/MOM_restart.F90 @@ -847,13 +847,14 @@ subroutine save_restart(directory, time, G, CS, time_stamped, filename, GV, num_ integer :: start_var, next_var ! The starting variables of the ! current and next files. type(file_type) :: IO_handle ! The I/O handle of the open fileset - integer :: m, nz, num_files + integer :: m, nz + integer :: num_files ! The number of restart files that will be used. integer :: seconds, days, year, month, hour, minute character(len=8) :: hor_grid, z_grid, t_grid ! Variable grid info. character(len=64) :: var_name ! A variable's name. real :: restart_time character(len=32) :: filename_appendix = '' ! Appendix to filename for ensemble runs - integer :: length + integer :: length ! The length of a text string. integer(kind=8) :: check_val(CS%max_fields,1) integer :: isL, ieL, jsL, jeL, pos integer :: turns @@ -923,7 +924,7 @@ subroutine save_restart(directory, time, G, CS, time_stamped, filename, GV, num_ endif endif - restartpath = trim(directory)// trim(restartname) + restartpath = trim(directory) // trim(restartname) if (num_files < 10) then write(suffix,'("_",I1)') num_files @@ -931,7 +932,16 @@ subroutine save_restart(directory, time, G, CS, time_stamped, filename, GV, num_ write(suffix,'("_",I2)') num_files endif - if (num_files > 0) restartpath = trim(restartpath) // trim(suffix) + length = len_trim(restartpath) + if (length < 3) then ! This case is very uncommon but this test avoids segmentation-faults. + if (num_files > 0) restartpath = trim(restartpath) // suffix + restartpath = trim(restartpath)//".nc" + elseif (restartpath(length-2:length) == ".nc") then + if (num_files > 0) restartpath = restartpath(1:length-3)//trim(suffix)//".nc" + else + if (num_files > 0) restartpath = trim(restartpath) // suffix + restartpath = trim(restartpath)//".nc" + endif do m=start_var,next_var-1 vars(m-start_var+1) = CS%restart_field(m)%vars From e624254b974dbbccdbb78f1d7f838e021f1503d1 Mon Sep 17 00:00:00 2001 From: William Cooke Date: Tue, 15 Jun 2021 15:30:19 -0400 Subject: [PATCH 097/112] Allocate arrays only if needed. Reinstated check on allow_flux_adjustments and restore_temp before allocating the heat_added and salt_flux_added arrays. Initialized arrays within flag construct too. Removed previous allocation of salt_flux_added. --- .../drivers/FMS_cap/MOM_surface_forcing_gfdl.F90 | 13 +++++++++---- 1 file changed, 9 insertions(+), 4 deletions(-) diff --git a/config_src/drivers/FMS_cap/MOM_surface_forcing_gfdl.F90 b/config_src/drivers/FMS_cap/MOM_surface_forcing_gfdl.F90 index 29bb627aba..380acc0495 100644 --- a/config_src/drivers/FMS_cap/MOM_surface_forcing_gfdl.F90 +++ b/config_src/drivers/FMS_cap/MOM_surface_forcing_gfdl.F90 @@ -293,17 +293,20 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, call safe_alloc_ptr(fluxes%salt_flux,isd,ied,jsd,jed) call safe_alloc_ptr(fluxes%salt_flux_in,isd,ied,jsd,jed) - call safe_alloc_ptr(fluxes%salt_flux_added,isd,ied,jsd,jed) call safe_alloc_ptr(fluxes%TKE_tidal,isd,ied,jsd,jed) call safe_alloc_ptr(fluxes%ustar_tidal,isd,ied,jsd,jed) + if (CS%allow_flux_adjustments .or. CS%restore_temp) then + call safe_alloc_ptr(fluxes%heat_added,isd,ied,jsd,jed) + call safe_alloc_ptr(fluxes%salt_flux_added,isd,ied,jsd,jed) + endif + do j=js-2,je+2 ; do i=is-2,ie+2 fluxes%TKE_tidal(i,j) = CS%TKE_tidal(i,j) fluxes%ustar_tidal(i,j) = CS%ustar_tidal(i,j) enddo ; enddo - call safe_alloc_ptr(fluxes%heat_added,isd,ied,jsd,jed) endif ! endif for allocation and initialization @@ -333,8 +336,10 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, fluxes%fluxes_used = .false. fluxes%dt_buoy_accum = US%s_to_T*valid_time - fluxes%heat_added(:,:) = 0.0 - fluxes%salt_flux_added(:,:) = 0.0 + if (CS%allow_flux_adjustments .or. CS%restore_temp) then + fluxes%heat_added(:,:) = 0.0 + fluxes%salt_flux_added(:,:) = 0.0 + endif do j=js,je ; do i=is,ie fluxes%salt_flux(i,j) = 0.0 From 7da83db8b366182d125899c6542d3763beff30e6 Mon Sep 17 00:00:00 2001 From: Raphael Dussin Date: Fri, 11 Jun 2021 17:06:09 -0400 Subject: [PATCH 098/112] fix reflect for internal tides * En array defined with wrong size leading to energy leakage * clean initialization for local arrays --- .../lateral/MOM_internal_tides.F90 | 15 +++++++++++---- 1 file changed, 11 insertions(+), 4 deletions(-) diff --git a/src/parameterizations/lateral/MOM_internal_tides.F90 b/src/parameterizations/lateral/MOM_internal_tides.F90 index a862dd373d..2f9181f7a5 100644 --- a/src/parameterizations/lateral/MOM_internal_tides.F90 +++ b/src/parameterizations/lateral/MOM_internal_tides.F90 @@ -1610,7 +1610,7 @@ subroutine reflect(En, NAngle, CS, G, LB) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure integer, intent(in) :: NAngle !< The number of wave orientations in the !! discretized wave energy spectrum. - real, dimension(G%isd:G%ied,G%jsd:G%jed,NAngle), & + real, dimension(SZI_(G),SZJB_(G),Nangle), & intent(inout) :: En !< The internal gravity wave energy density as a !! function of space and angular resolution !! [R Z3 T-2 ~> J m-2]. @@ -1653,9 +1653,16 @@ subroutine reflect(En, NAngle, CS, G, LB) angle_i(a) = Angle_size * real(a - 1) ! for a=1 aligned with x-axis enddo - angle_c = CS%refl_angle - part_refl = CS%refl_pref - ridge = CS%refl_dbl + ! init local arrays + angle_c(:,:) = CS%nullangle + part_refl(:,:) = 0. + ridge(:,:) = .false. + + do j=jsh,jeh ; do i=ish,ieh + angle_c(i,j) = CS%refl_angle(i,j) + part_refl(i,j) = CS%refl_pref(i,j) + ridge(i,j) = CS%refl_dbl(i,j) + enddo ; enddo En_reflected(:) = 0.0 do j=jsh,jeh ; do i=ish,ieh From 0f76e34d793c96e0bd69b134a0ecc5640c82ff64 Mon Sep 17 00:00:00 2001 From: Raphael Dussin Date: Thu, 17 Jun 2021 21:28:10 -0400 Subject: [PATCH 099/112] corrected indexing --- src/parameterizations/lateral/MOM_internal_tides.F90 | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/parameterizations/lateral/MOM_internal_tides.F90 b/src/parameterizations/lateral/MOM_internal_tides.F90 index 2f9181f7a5..8c08691675 100644 --- a/src/parameterizations/lateral/MOM_internal_tides.F90 +++ b/src/parameterizations/lateral/MOM_internal_tides.F90 @@ -1389,7 +1389,7 @@ subroutine propagate_x(En, speed_x, Cgx_av, dCgx, dt, G, US, Nangle, CS, LB) real, dimension(SZIB_(G)) :: & cg_p, cg_m, flux1, flux2 !real, dimension(SZI_(G),SZJB_(G),Nangle) :: En_m, En_p - real, dimension(SZI_(G),SZJB_(G),Nangle) :: & + real, dimension(G%isd:G%ied,G%jsd:G%jed,Nangle) :: & Fdt_m, Fdt_p! Left and right energy fluxes [J] integer :: i, j, k, ish, ieh, jsh, jeh, a @@ -1464,7 +1464,7 @@ subroutine propagate_y(En, speed_y, Cgy_av, dCgy, dt, G, US, Nangle, CS, LB) real, dimension(SZI_(G)) :: & cg_p, cg_m, flux1, flux2 !real, dimension(SZI_(G),SZJB_(G),Nangle) :: En_m, En_p - real, dimension(SZI_(G),SZJB_(G),Nangle) :: & + real, dimension(G%isd:G%ied,G%jsd:G%jed,Nangle) :: & Fdt_m, Fdt_p! South and north energy fluxes [J] character(len=160) :: mesg ! The text of an error message integer :: i, j, k, ish, ieh, jsh, jeh, a @@ -1610,7 +1610,7 @@ subroutine reflect(En, NAngle, CS, G, LB) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure integer, intent(in) :: NAngle !< The number of wave orientations in the !! discretized wave energy spectrum. - real, dimension(SZI_(G),SZJB_(G),Nangle), & + real, dimension(G%isd:G%ied,G%jsd:G%jed,NAngle), & intent(inout) :: En !< The internal gravity wave energy density as a !! function of space and angular resolution !! [R Z3 T-2 ~> J m-2]. From 0f0afbeddd626a09e0bf9a6bc4f826b5f8bd0b8e Mon Sep 17 00:00:00 2001 From: abozec Date: Fri, 18 Jun 2021 08:38:07 -0400 Subject: [PATCH 100/112] update halo and allow sponge_uv to not be on grid - update Iresttime, data_h and h halos for sponge_uv reproducibility - add condition to not be on grid for sponge_uv --- .../vertical/MOM_ALE_sponge.F90 | 22 ++++++++++++++----- 1 file changed, 17 insertions(+), 5 deletions(-) diff --git a/src/parameterizations/vertical/MOM_ALE_sponge.F90 b/src/parameterizations/vertical/MOM_ALE_sponge.F90 index 5d9af389c9..45b0cd97aa 100644 --- a/src/parameterizations/vertical/MOM_ALE_sponge.F90 +++ b/src/parameterizations/vertical/MOM_ALE_sponge.F90 @@ -167,12 +167,12 @@ subroutine initialize_ALE_sponge_fixed(Iresttime, G, GV, param_file, CS, data_h, type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure integer, intent(in) :: nz_data !< The total number of sponge input layers. - real, dimension(SZI_(G),SZJ_(G)), intent(in) :: Iresttime !< The inverse of the restoring time [T-1 ~> s-1]. + real, dimension(SZI_(G),SZJ_(G)), intent(inout) :: Iresttime !< The inverse of the restoring time [T-1 ~> s-1]. type(param_file_type), intent(in) :: param_file !< A structure indicating the open file !! to parse for model parameter values. type(ALE_sponge_CS), pointer :: CS !< A pointer that is set to point to the control !! structure for this module (in/out). - real, dimension(SZI_(G),SZJ_(G),nz_data), intent(in) :: data_h !< The thicknesses of the sponge + real, dimension(SZI_(G),SZJ_(G),nz_data), intent(inout) :: data_h !< The thicknesses of the sponge !! input layers [H ~> m or kg m-2]. real, dimension(SZIB_(G),SZJ_(G)), intent(in), optional :: Iresttime_u_in !< The inverse of the restoring !! time at U-points [T-1 ~> s-1]. @@ -287,6 +287,9 @@ subroutine initialize_ALE_sponge_fixed(Iresttime, G, GV, param_file, CS, data_h, 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 + call pass_var(Iresttime,G%Domain) + call pass_var(data_h,G%Domain) + ! u points CS%num_col_u = 0 ; if (present(Iresttime_u_in)) then @@ -823,14 +826,22 @@ subroutine set_up_ALE_sponge_vel_field_varying(filename_u, fieldname_u, filename ! 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, domain=G%Domain%mpp_domain) + if (CS%spongeDataOngrid) then + CS%Ref_val_u%id = init_external_field(filename_u, fieldname_u, domain=G%Domain%mpp_domain) + else + CS%Ref_val_u%id = init_external_field(filename_u, fieldname_u) + endif fld_sz(1:4)=-1 call get_external_field_info(CS%Ref_val_u%id, size=fld_sz) 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, domain=G%Domain%mpp_domain) - fld_sz(1:4)=-1 + if (CS%spongeDataOngrid) then + CS%Ref_val_v%id = init_external_field(filename_v, fieldname_v, domain=G%Domain%mpp_domain) + else + CS%Ref_val_v%id = init_external_field(filename_v, fieldname_v) + endif + fld_sz(1:4)=-1 fld_sz(1:4)=-1 call get_external_field_info(CS%Ref_val_v%id, size=fld_sz) CS%Ref_val_v%nz_data = fld_sz(3) CS%Ref_val_v%num_tlevs = fld_sz(4) @@ -1091,6 +1102,7 @@ subroutine apply_ALE_sponge(h, dt, G, GV, US, CS, Time) deallocate(sp_val, sp_val_v, mask_v, mask_z, hsrc, tmpT1d) endif + call pass_var(h,G%Domain) nz_data = CS%Ref_val_u%nz_data allocate(tmp_val2(nz_data)) if (CS%id_sp_u_tendency > 0) then From 35409ced4337142c2cf95179381cccb72ca0967f Mon Sep 17 00:00:00 2001 From: Raphael Dussin Date: Fri, 11 Jun 2021 17:06:09 -0400 Subject: [PATCH 101/112] fix reflect for internal tides * En array defined with wrong size leading to energy leakage * clean initialization for local arrays --- src/parameterizations/lateral/MOM_internal_tides.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/parameterizations/lateral/MOM_internal_tides.F90 b/src/parameterizations/lateral/MOM_internal_tides.F90 index 8c08691675..491e361508 100644 --- a/src/parameterizations/lateral/MOM_internal_tides.F90 +++ b/src/parameterizations/lateral/MOM_internal_tides.F90 @@ -1610,7 +1610,7 @@ subroutine reflect(En, NAngle, CS, G, LB) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure integer, intent(in) :: NAngle !< The number of wave orientations in the !! discretized wave energy spectrum. - real, dimension(G%isd:G%ied,G%jsd:G%jed,NAngle), & + real, dimension(SZI_(G),SZJB_(G),Nangle), & intent(inout) :: En !< The internal gravity wave energy density as a !! function of space and angular resolution !! [R Z3 T-2 ~> J m-2]. From 540c3750ff00730a5bcb473f85658ffa58d92c11 Mon Sep 17 00:00:00 2001 From: Raphael Dussin Date: Thu, 17 Jun 2021 21:28:10 -0400 Subject: [PATCH 102/112] corrected indexing --- src/parameterizations/lateral/MOM_internal_tides.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/parameterizations/lateral/MOM_internal_tides.F90 b/src/parameterizations/lateral/MOM_internal_tides.F90 index 491e361508..8c08691675 100644 --- a/src/parameterizations/lateral/MOM_internal_tides.F90 +++ b/src/parameterizations/lateral/MOM_internal_tides.F90 @@ -1610,7 +1610,7 @@ subroutine reflect(En, NAngle, CS, G, LB) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure integer, intent(in) :: NAngle !< The number of wave orientations in the !! discretized wave energy spectrum. - real, dimension(SZI_(G),SZJB_(G),Nangle), & + real, dimension(G%isd:G%ied,G%jsd:G%jed,NAngle), & intent(inout) :: En !< The internal gravity wave energy density as a !! function of space and angular resolution !! [R Z3 T-2 ~> J m-2]. From 62749374d224f251080a1531d89ce4bdabf126c9 Mon Sep 17 00:00:00 2001 From: "William.Cooke" Date: Tue, 22 Jun 2021 07:45:08 -0400 Subject: [PATCH 103/112] Updating conditionals for array allocation Tests with intel and gnu compilers (repro and debug) passed. --- .../drivers/FMS_cap/MOM_surface_forcing_gfdl.F90 | 12 ++++-------- 1 file changed, 4 insertions(+), 8 deletions(-) diff --git a/config_src/drivers/FMS_cap/MOM_surface_forcing_gfdl.F90 b/config_src/drivers/FMS_cap/MOM_surface_forcing_gfdl.F90 index c41884d899..6479549eb7 100644 --- a/config_src/drivers/FMS_cap/MOM_surface_forcing_gfdl.F90 +++ b/config_src/drivers/FMS_cap/MOM_surface_forcing_gfdl.F90 @@ -297,10 +297,8 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, call safe_alloc_ptr(fluxes%TKE_tidal,isd,ied,jsd,jed) call safe_alloc_ptr(fluxes%ustar_tidal,isd,ied,jsd,jed) - if (CS%allow_flux_adjustments .or. CS%restore_temp) then - call safe_alloc_ptr(fluxes%heat_added,isd,ied,jsd,jed) - call safe_alloc_ptr(fluxes%salt_flux_added,isd,ied,jsd,jed) - endif + call safe_alloc_ptr(fluxes%heat_added,isd,ied,jsd,jed) + call safe_alloc_ptr(fluxes%salt_flux_added,isd,ied,jsd,jed) do j=js-2,je+2 ; do i=is-2,ie+2 fluxes%TKE_tidal(i,j) = CS%TKE_tidal(i,j) @@ -336,10 +334,8 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, fluxes%fluxes_used = .false. fluxes%dt_buoy_accum = US%s_to_T*valid_time - if (CS%allow_flux_adjustments .or. CS%restore_temp) then - fluxes%heat_added(:,:) = 0.0 - fluxes%salt_flux_added(:,:) = 0.0 - endif + fluxes%heat_added(:,:) = 0.0 + fluxes%salt_flux_added(:,:) = 0.0 do j=js,je ; do i=is,ie fluxes%salt_flux(i,j) = 0.0 From faa2c3659ae4c79ee099e200d9f5f66e62b7c417 Mon Sep 17 00:00:00 2001 From: abozec Date: Wed, 23 Jun 2021 10:17:50 -0400 Subject: [PATCH 104/112] correction to a typo --- src/parameterizations/vertical/MOM_ALE_sponge.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/parameterizations/vertical/MOM_ALE_sponge.F90 b/src/parameterizations/vertical/MOM_ALE_sponge.F90 index 45b0cd97aa..31d2ab5a76 100644 --- a/src/parameterizations/vertical/MOM_ALE_sponge.F90 +++ b/src/parameterizations/vertical/MOM_ALE_sponge.F90 @@ -841,7 +841,7 @@ subroutine set_up_ALE_sponge_vel_field_varying(filename_u, fieldname_u, filename else CS%Ref_val_v%id = init_external_field(filename_v, fieldname_v) endif - fld_sz(1:4)=-1 fld_sz(1:4)=-1 + fld_sz(1:4)=-1 call get_external_field_info(CS%Ref_val_v%id, size=fld_sz) CS%Ref_val_v%nz_data = fld_sz(3) CS%Ref_val_v%num_tlevs = fld_sz(4) From 5da1b8fb8e6d3efc0a6200d3786988ee0ed01e25 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 25 Jun 2021 18:02:47 -0400 Subject: [PATCH 105/112] (+)Modified some optional arguments Modified optional arguments in 4 modules to reflect their actual usage. 1. Eliminated the optional argument full_prec to zonal_flux_adjust and meridional_flux_adjust, which were always called with the hard-coded value "true", and made the optional arguments monotonic and simple_2nd to PPM_reconstruction_[xy] mandatory. 2. Eliminated the optional argument eta_bt to calculate_diagnostic_fields, which was never present. 3. Made the two optional arguments to unit_scaling_init mandatory. 4. Eliminated the optional do_i argument to F_to_ent, which was never present in calls, and made the parameter just_read_params to entrain_diffusive_init mandatory. All answers are bitwise identical. --- src/core/MOM_continuity_PPM.F90 | 157 +++++++----------- src/diagnostics/MOM_diagnostics.F90 | 13 +- src/framework/MOM_unit_scaling.F90 | 54 +++--- .../lateral/MOM_hor_visc.F90 | 3 + .../vertical/MOM_diabatic_driver.F90 | 2 - .../vertical/MOM_entrain_diffusive.F90 | 72 +++----- .../vertical/MOM_vert_friction.F90 | 2 +- 7 files changed, 117 insertions(+), 186 deletions(-) diff --git a/src/core/MOM_continuity_PPM.F90 b/src/core/MOM_continuity_PPM.F90 index 7b90297c64..d8b6cddaaa 100644 --- a/src/core/MOM_continuity_PPM.F90 +++ b/src/core/MOM_continuity_PPM.F90 @@ -430,7 +430,7 @@ subroutine zonal_mass_flux(u, h_in, uh, dt, G, GV, US, CS, LB, uhbt, OBC, & if (present(uhbt)) then call zonal_flux_adjust(u, h_in, h_L, h_R, uhbt(:,j), uh_tot_0, duhdu_tot_0, du, & du_max_CFL, du_min_CFL, dt, G, GV, US, CS, visc_rem, & - j, ish, ieh, do_I, .true., uh, OBC=OBC) + j, ish, ieh, do_I, uh, OBC=OBC) if (present(u_cor)) then ; do k=1,nz do I=ish-1,ieh ; u_cor(I,j,k) = u(I,j,k) + du(I) * visc_rem(I,k) ; enddo @@ -710,7 +710,7 @@ end subroutine zonal_face_thickness !! desired barotropic (layer-summed) transport. subroutine zonal_flux_adjust(u, h_in, h_L, h_R, uhbt, uh_tot_0, duhdu_tot_0, & du, du_max_CFL, du_min_CFL, dt, G, GV, US, CS, visc_rem, & - j, ish, ieh, do_I_in, full_precision, uh_3d, OBC) + j, ish, ieh, do_I_in, uh_3d, OBC) type(ocean_grid_type), intent(inout) :: G !< Ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< Ocean's vertical grid structure. real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), intent(in) :: u !< Zonal velocity [L T-1 ~> m s-1]. @@ -746,9 +746,6 @@ subroutine zonal_flux_adjust(u, h_in, h_L, h_R, uhbt, uh_tot_0, duhdu_tot_0, & integer, intent(in) :: ieh !< End of index range. logical, dimension(SZIB_(G)), intent(in) :: do_I_in !< !! A logical flag indicating which I values to work on. - logical, optional, intent(in) :: full_precision !< - !! A flag indicating how carefully to iterate. The - !! default is .true. (more accurate). real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), optional, intent(inout) :: uh_3d !< !! Volume flux through zonal faces = u*h*dy [H L2 T-1 ~> m3 s-1 or kg s-1]. type(ocean_OBC_type), optional, pointer :: OBC !< Open boundaries control structure. @@ -768,10 +765,9 @@ subroutine zonal_flux_adjust(u, h_in, h_L, h_R, uhbt, uh_tot_0, duhdu_tot_0, & real :: tol_eta ! The tolerance for the current iteration [H ~> m or kg m-2]. real :: tol_vel ! The tolerance for velocity in the current iteration [L T-1 ~> m s-1]. integer :: i, k, nz, itt, max_itts = 20 - logical :: full_prec, domore, do_I(SZIB_(G)) + logical :: domore, do_I(SZIB_(G)) nz = GV%ke - full_prec = .true. ; if (present(full_precision)) full_prec = full_precision uh_aux(:,:) = 0.0 ; duhdu(:,:) = 0.0 @@ -787,16 +783,12 @@ subroutine zonal_flux_adjust(u, h_in, h_L, h_R, uhbt, uh_tot_0, duhdu_tot_0, & enddo do itt=1,max_itts - if (full_prec) then - select case (itt) - case (:1) ; tol_eta = 1e-6 * CS%tol_eta - case (2) ; tol_eta = 1e-4 * CS%tol_eta - case (3) ; tol_eta = 1e-2 * CS%tol_eta - case default ; tol_eta = CS%tol_eta - end select - else - tol_eta = CS%tol_eta_aux ; if (itt<=1) tol_eta = 1e-6 * CS%tol_eta_aux - endif + select case (itt) + case (:1) ; tol_eta = 1e-6 * CS%tol_eta + case (2) ; tol_eta = 1e-4 * CS%tol_eta + case (3) ; tol_eta = 1e-2 * CS%tol_eta + case default ; tol_eta = CS%tol_eta + end select tol_vel = CS%tol_vel do I=ish-1,ieh @@ -809,30 +801,23 @@ subroutine zonal_flux_adjust(u, h_in, h_L, h_R, uhbt, uh_tot_0, duhdu_tot_0, & if ((dt * min(G%IareaT(i,j),G%IareaT(i+1,j))*abs(uh_err(I)) > tol_eta) .or. & (CS%better_iter .and. ((abs(uh_err(I)) > tol_vel * duhdu_tot(I)) .or. & (abs(uh_err(I)) > uh_err_best(I))) )) then - ! Use Newton's method, provided it stays bounded. Otherwise bisect - ! the value with the appropriate bound. - if (full_prec) then - ddu = -uh_err(I) / duhdu_tot(I) - du_prev = du(I) - du(I) = du(I) + ddu - if (abs(ddu) < 1.0e-15*abs(du(I))) then - do_I(I) = .false. ! ddu is small enough to quit. - elseif (ddu > 0.0) then - if (du(I) >= du_max(I)) then - du(I) = 0.5*(du_prev + du_max(I)) - if (du_max(I) - du_prev < 1.0e-15*abs(du(I))) do_I(I) = .false. - endif - else ! ddu < 0.0 - if (du(I) <= du_min(I)) then - du(I) = 0.5*(du_prev + du_min(I)) - if (du_prev - du_min(I) < 1.0e-15*abs(du(I))) do_I(I) = .false. - endif + ! Use Newton's method, provided it stays bounded. Otherwise bisect + ! the value with the appropriate bound. + ddu = -uh_err(I) / duhdu_tot(I) + du_prev = du(I) + du(I) = du(I) + ddu + if (abs(ddu) < 1.0e-15*abs(du(I))) then + do_I(I) = .false. ! ddu is small enough to quit. + elseif (ddu > 0.0) then + if (du(I) >= du_max(I)) then + du(I) = 0.5*(du_prev + du_max(I)) + if (du_max(I) - du_prev < 1.0e-15*abs(du(I))) do_I(I) = .false. + endif + else ! ddu < 0.0 + if (du(I) <= du_min(I)) then + du(I) = 0.5*(du_prev + du_min(I)) + if (du_prev - du_min(I) < 1.0e-15*abs(du(I))) do_I(I) = .false. endif - else - ! Use Newton's method, provided it stays bounded, just like above. - du(I) = du(I) - uh_err(I) / duhdu_tot(I) - if ((du(I) >= du_max(I)) .or. (du(I) <= du_min(I))) & - du(I) = 0.5*(du_max(I) + du_min(I)) endif if (do_I(I)) domore = .true. else @@ -950,7 +935,7 @@ subroutine set_zonal_BT_cont(u, h_in, h_L, h_R, BT_cont, uh_tot_0, duhdu_tot_0, do I=ish-1,ieh ; zeros(I) = 0.0 ; enddo call zonal_flux_adjust(u, h_in, h_L, h_R, zeros, uh_tot_0, duhdu_tot_0, du0, & du_max_CFL, du_min_CFL, dt, G, GV, US, CS, visc_rem, & - j, ish, ieh, do_I, .true.) + j, ish, ieh, do_I) ! Determine the westerly- and easterly- fluxes. Choose a sufficiently ! negative velocity correction for the easterly-flux, and a sufficiently @@ -1253,7 +1238,7 @@ subroutine meridional_mass_flux(v, h_in, vh, dt, G, GV, US, CS, LB, vhbt, OBC, & if (present(vhbt)) then call meridional_flux_adjust(v, h_in, h_L, h_R, vhbt(:,J), vh_tot_0, dvhdv_tot_0, dv, & dv_max_CFL, dv_min_CFL, dt, G, GV, US, CS, visc_rem, & - j, ish, ieh, do_I, .true., vh, OBC=OBC) + j, ish, ieh, do_I, vh, OBC=OBC) if (present(v_cor)) then ; do k=1,nz do i=ish,ieh ; v_cor(i,J,k) = v(i,J,k) + dv(i) * visc_rem(i,k) ; enddo @@ -1537,7 +1522,7 @@ end subroutine merid_face_thickness !> Returns the barotropic velocity adjustment that gives the desired barotropic (layer-summed) transport. subroutine meridional_flux_adjust(v, h_in, h_L, h_R, vhbt, vh_tot_0, dvhdv_tot_0, & dv, dv_max_CFL, dv_min_CFL, dt, G, GV, US, CS, visc_rem, & - j, ish, ieh, do_I_in, full_precision, vh_3d, OBC) + j, ish, ieh, do_I_in, vh_3d, OBC) type(ocean_grid_type), intent(inout) :: G !< Ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< Ocean's vertical grid structure. real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & @@ -1572,8 +1557,6 @@ subroutine meridional_flux_adjust(v, h_in, h_L, h_R, vhbt, vh_tot_0, dvhdv_tot_0 integer, intent(in) :: ieh !< End of index range. logical, dimension(SZI_(G)), & intent(in) :: do_I_in !< A flag indicating which I values to work on. - logical, optional, intent(in) :: full_precision !< A flag indicating how carefully to - !! iterate. The default is .true. (more accurate). real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & optional, intent(inout) :: vh_3d !< Volume flux through meridional !! faces = v*h*dx [H L2 T-1 ~> m3 s-1 or kg s-1]. @@ -1594,10 +1577,9 @@ subroutine meridional_flux_adjust(v, h_in, h_L, h_R, vhbt, vh_tot_0, dvhdv_tot_0 real :: tol_eta ! The tolerance for the current iteration [H ~> m or kg m-2]. real :: tol_vel ! The tolerance for velocity in the current iteration [L T-1 ~> m s-1]. integer :: i, k, nz, itt, max_itts = 20 - logical :: full_prec, domore, do_I(SZI_(G)) + logical :: domore, do_I(SZI_(G)) nz = GV%ke - full_prec = .true. ; if (present(full_precision)) full_prec = full_precision vh_aux(:,:) = 0.0 ; dvhdv(:,:) = 0.0 @@ -1613,16 +1595,12 @@ subroutine meridional_flux_adjust(v, h_in, h_L, h_R, vhbt, vh_tot_0, dvhdv_tot_0 enddo do itt=1,max_itts - if (full_prec) then - select case (itt) - case (:1) ; tol_eta = 1e-6 * CS%tol_eta - case (2) ; tol_eta = 1e-4 * CS%tol_eta - case (3) ; tol_eta = 1e-2 * CS%tol_eta - case default ; tol_eta = CS%tol_eta - end select - else - tol_eta = CS%tol_eta_aux ; if (itt<=1) tol_eta = 1e-6 * CS%tol_eta_aux - endif + select case (itt) + case (:1) ; tol_eta = 1e-6 * CS%tol_eta + case (2) ; tol_eta = 1e-4 * CS%tol_eta + case (3) ; tol_eta = 1e-2 * CS%tol_eta + case default ; tol_eta = CS%tol_eta + end select tol_vel = CS%tol_vel do i=ish,ieh @@ -1637,28 +1615,21 @@ subroutine meridional_flux_adjust(v, h_in, h_L, h_R, vhbt, vh_tot_0, dvhdv_tot_0 (abs(vh_err(i)) > vh_err_best(i))) )) then ! Use Newton's method, provided it stays bounded. Otherwise bisect ! the value with the appropriate bound. - if (full_prec) then - ddv = -vh_err(i) / dvhdv_tot(i) - dv_prev = dv(i) - dv(i) = dv(i) + ddv - if (abs(ddv) < 1.0e-15*abs(dv(i))) then - do_I(i) = .false. ! ddv is small enough to quit. - elseif (ddv > 0.0) then - if (dv(i) >= dv_max(i)) then - dv(i) = 0.5*(dv_prev + dv_max(i)) - if (dv_max(i) - dv_prev < 1.0e-15*abs(dv(i))) do_I(i) = .false. - endif - else ! dvv(i) < 0.0 - if (dv(i) <= dv_min(i)) then - dv(i) = 0.5*(dv_prev + dv_min(i)) - if (dv_prev - dv_min(i) < 1.0e-15*abs(dv(i))) do_I(i) = .false. - endif + ddv = -vh_err(i) / dvhdv_tot(i) + dv_prev = dv(i) + dv(i) = dv(i) + ddv + if (abs(ddv) < 1.0e-15*abs(dv(i))) then + do_I(i) = .false. ! ddv is small enough to quit. + elseif (ddv > 0.0) then + if (dv(i) >= dv_max(i)) then + dv(i) = 0.5*(dv_prev + dv_max(i)) + if (dv_max(i) - dv_prev < 1.0e-15*abs(dv(i))) do_I(i) = .false. + endif + else ! dvv(i) < 0.0 + if (dv(i) <= dv_min(i)) then + dv(i) = 0.5*(dv_prev + dv_min(i)) + if (dv_prev - dv_min(i) < 1.0e-15*abs(dv(i))) do_I(i) = .false. endif - else - ! Use Newton's method, provided it stays bounded, just like above. - dv(i) = dv(i) - vh_err(i) / dvhdv_tot(i) - if ((dv(i) >= dv_max(i)) .or. (dv(i) <= dv_min(i))) & - dv(i) = 0.5*(dv_max(i) + dv_min(i)) endif if (do_I(i)) domore = .true. else @@ -1776,7 +1747,7 @@ subroutine set_merid_BT_cont(v, h_in, h_L, h_R, BT_cont, vh_tot_0, dvhdv_tot_0, do i=ish,ieh ; zeros(i) = 0.0 ; enddo call meridional_flux_adjust(v, h_in, h_L, h_R, zeros, vh_tot_0, dvhdv_tot_0, dv0, & dv_max_CFL, dv_min_CFL, dt, G, GV, US, CS, visc_rem, & - j, ish, ieh, do_I, .true.) + j, ish, ieh, do_I) ! Determine the southerly- and northerly- fluxes. Choose a sufficiently ! negative velocity correction for the northerly-flux, and a sufficiently @@ -1871,10 +1842,10 @@ subroutine PPM_reconstruction_x(h_in, h_L, h_R, G, LB, h_min, monotonic, simple_ type(loop_bounds_type), intent(in) :: LB !< Active loop bounds structure. real, intent(in) :: h_min !< The minimum thickness !! that can be obtained by a concave parabolic fit. - logical, optional, intent(in) :: monotonic !< If true, use the + logical, intent(in) :: monotonic !< If true, use the !! Colella & Woodward monotonic limiter. !! Otherwise use a simple positive-definite limiter. - logical, optional, intent(in) :: simple_2nd !< If true, use the + logical, intent(in) :: simple_2nd !< If true, use the !! arithmetic mean thicknesses as the default edge values !! for a simple 2nd order scheme. type(ocean_OBC_type), optional, pointer :: OBC !< Open boundaries control structure. @@ -1884,15 +1855,11 @@ subroutine PPM_reconstruction_x(h_in, h_L, h_R, G, LB, h_min, monotonic, simple_ real, parameter :: oneSixth = 1./6. real :: h_ip1, h_im1 real :: dMx, dMn - logical :: use_CW84, use_2nd character(len=256) :: mesg integer :: i, j, isl, iel, jsl, jel, n, stencil logical :: local_open_BC type(OBC_segment_type), pointer :: segment => NULL() - use_CW84 = .false. ; if (present(monotonic)) use_CW84 = monotonic - use_2nd = .false. ; if (present(simple_2nd)) use_2nd = simple_2nd - local_open_BC = .false. if (present(OBC)) then ; if (associated(OBC)) then local_open_BC = OBC%open_u_BCs_exist_globally @@ -1901,7 +1868,7 @@ subroutine PPM_reconstruction_x(h_in, h_L, h_R, G, LB, h_min, monotonic, simple_ isl = LB%ish-1 ; iel = LB%ieh+1 ; jsl = LB%jsh ; jel = LB%jeh ! This is the stencil of the reconstruction, not the scheme overall. - stencil = 2 ; if (use_2nd) stencil = 1 + stencil = 2 ; if (simple_2nd) stencil = 1 if ((isl-stencil < G%isd) .or. (iel+stencil > G%ied)) then write(mesg,'("In MOM_continuity_PPM, PPM_reconstruction_x called with a ", & @@ -1916,7 +1883,7 @@ subroutine PPM_reconstruction_x(h_in, h_L, h_R, G, LB, h_min, monotonic, simple_ call MOM_error(FATAL,mesg) endif - if (use_2nd) then + if (simple_2nd) then do j=jsl,jel ; do i=isl,iel h_im1 = G%mask2dT(i-1,j) * h_in(i-1,j) + (1.0-G%mask2dT(i-1,j)) * h_in(i,j) h_ip1 = G%mask2dT(i+1,j) * h_in(i+1,j) + (1.0-G%mask2dT(i+1,j)) * h_in(i,j) @@ -1990,7 +1957,7 @@ subroutine PPM_reconstruction_x(h_in, h_L, h_R, G, LB, h_min, monotonic, simple_ enddo endif - if (use_CW84) then + if (monotonic) then call PPM_limit_CW84(h_in, h_L, h_R, G, isl, iel, jsl, jel) else call PPM_limit_pos(h_in, h_L, h_R, h_min, G, isl, iel, jsl, jel) @@ -2010,10 +1977,10 @@ subroutine PPM_reconstruction_y(h_in, h_L, h_R, G, LB, h_min, monotonic, simple_ type(loop_bounds_type), intent(in) :: LB !< Active loop bounds structure. real, intent(in) :: h_min !< The minimum thickness !! that can be obtained by a concave parabolic fit. - logical, optional, intent(in) :: monotonic !< If true, use the + logical, intent(in) :: monotonic !< If true, use the !! Colella & Woodward monotonic limiter. !! Otherwise use a simple positive-definite limiter. - logical, optional, intent(in) :: simple_2nd !< If true, use the + logical, intent(in) :: simple_2nd !< If true, use the !! arithmetic mean thicknesses as the default edge values !! for a simple 2nd order scheme. type(ocean_OBC_type), optional, pointer :: OBC !< Open boundaries control structure. @@ -2023,15 +1990,11 @@ subroutine PPM_reconstruction_y(h_in, h_L, h_R, G, LB, h_min, monotonic, simple_ real, parameter :: oneSixth = 1./6. real :: h_jp1, h_jm1 real :: dMx, dMn - logical :: use_CW84, use_2nd character(len=256) :: mesg integer :: i, j, isl, iel, jsl, jel, n, stencil logical :: local_open_BC type(OBC_segment_type), pointer :: segment => NULL() - use_CW84 = .false. ; if (present(monotonic)) use_CW84 = monotonic - use_2nd = .false. ; if (present(simple_2nd)) use_2nd = simple_2nd - local_open_BC = .false. if (present(OBC)) then ; if (associated(OBC)) then local_open_BC = OBC%open_v_BCs_exist_globally @@ -2040,7 +2003,7 @@ subroutine PPM_reconstruction_y(h_in, h_L, h_R, G, LB, h_min, monotonic, simple_ isl = LB%ish ; iel = LB%ieh ; jsl = LB%jsh-1 ; jel = LB%jeh+1 ! This is the stencil of the reconstruction, not the scheme overall. - stencil = 2 ; if (use_2nd) stencil = 1 + stencil = 2 ; if (simple_2nd) stencil = 1 if ((isl < G%isd) .or. (iel > G%ied)) then write(mesg,'("In MOM_continuity_PPM, PPM_reconstruction_y called with a ", & @@ -2055,7 +2018,7 @@ subroutine PPM_reconstruction_y(h_in, h_L, h_R, G, LB, h_min, monotonic, simple_ call MOM_error(FATAL,mesg) endif - if (use_2nd) then + if (simple_2nd) then do j=jsl,jel ; do i=isl,iel h_jm1 = G%mask2dT(i,j-1) * h_in(i,j-1) + (1.0-G%mask2dT(i,j-1)) * h_in(i,j) h_jp1 = G%mask2dT(i,j+1) * h_in(i,j+1) + (1.0-G%mask2dT(i,j+1)) * h_in(i,j) @@ -2127,7 +2090,7 @@ subroutine PPM_reconstruction_y(h_in, h_L, h_R, G, LB, h_min, monotonic, simple_ enddo endif - if (use_CW84) then + if (monotonic) then call PPM_limit_CW84(h_in, h_L, h_R, G, isl, iel, jsl, jel) else call PPM_limit_pos(h_in, h_L, h_R, h_min, G, isl, iel, jsl, jel) diff --git a/src/diagnostics/MOM_diagnostics.F90 b/src/diagnostics/MOM_diagnostics.F90 index 0fbec91bc0..e6b01af33d 100644 --- a/src/diagnostics/MOM_diagnostics.F90 +++ b/src/diagnostics/MOM_diagnostics.F90 @@ -197,7 +197,7 @@ module MOM_diagnostics contains !> Diagnostics not more naturally calculated elsewhere are computed here. subroutine calculate_diagnostic_fields(u, v, h, uh, vh, tv, ADp, CDp, p_surf, & - dt, diag_pre_sync, G, GV, US, CS, eta_bt) + dt, diag_pre_sync, G, GV, US, CS) type(ocean_grid_type), intent(inout) :: 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 @@ -227,11 +227,6 @@ subroutine calculate_diagnostic_fields(u, v, h, uh, vh, tv, ADp, CDp, p_surf, & type(diag_grid_storage), intent(in) :: diag_pre_sync !< Target grids from previous timestep type(diagnostics_CS), intent(inout) :: CS !< Control structure returned by a !! previous call to diagnostics_init. - real, dimension(SZI_(G),SZJ_(G)), & - optional, intent(in) :: eta_bt !< An optional barotropic - !! 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 real, dimension(SZIB_(G),SZJ_(G),SZK_(G)) :: usq ! squared eastward velocity [L2 T-2 ~> m2 s-2] @@ -390,7 +385,7 @@ subroutine calculate_diagnostic_fields(u, v, h, uh, vh, tv, ADp, CDp, p_surf, & endif if (associated(CS%e)) then - call find_eta(h, tv, G, GV, US, CS%e, eta_bt) + call find_eta(h, tv, G, GV, US, CS%e) if (CS%id_e > 0) call post_data(CS%id_e, CS%e, CS%diag) endif @@ -400,7 +395,7 @@ subroutine calculate_diagnostic_fields(u, v, h, uh, vh, tv, ADp, CDp, p_surf, & CS%e_D(i,j,k) = CS%e(i,j,k) + G%bathyT(i,j) enddo ; enddo ; enddo else - call find_eta(h, tv, G, GV, US, CS%e_D, eta_bt) + call find_eta(h, tv, G, GV, US, CS%e_D) do k=1,nz+1 ; do j=js,je ; do i=is,ie CS%e_D(i,j,k) = CS%e_D(i,j,k) + G%bathyT(i,j) enddo ; enddo ; enddo @@ -1935,7 +1930,7 @@ subroutine MOM_diagnostics_init(MIS, ADp, CDp, Time, G, GV, US, param_file, diag call wave_speed_init(CS%wave_speed_CSp, remap_answers_2018=remap_answers_2018, & better_speed_est=better_speed_est, min_speed=wave_speed_min, & wave_speed_tol=wave_speed_tol) - call wave_speed_init(CS%wave_speed_CSp, remap_answers_2018=remap_answers_2018) +!### call wave_speed_init(CS%wave_speed_CSp, remap_answers_2018=remap_answers_2018) call safe_alloc_ptr(CS%cg1,isd,ied,jsd,jed) if (CS%id_Rd1>0) call safe_alloc_ptr(CS%Rd1,isd,ied,jsd,jed) if (CS%id_Rd_ebt>0) call safe_alloc_ptr(CS%Rd1,isd,ied,jsd,jed) diff --git a/src/framework/MOM_unit_scaling.F90 b/src/framework/MOM_unit_scaling.F90 index fea1ac4910..dbcd2405ec 100644 --- a/src/framework/MOM_unit_scaling.F90 +++ b/src/framework/MOM_unit_scaling.F90 @@ -54,8 +54,8 @@ module MOM_unit_scaling !> Allocates and initializes the ocean model unit scaling type subroutine unit_scaling_init( param_file, US ) - type(param_file_type), optional, intent(in) :: param_file !< Parameter file handle/type - type(unit_scale_type), optional, pointer :: US !< A dimensional unit scaling type + type(param_file_type), intent(in) :: param_file !< Parameter file handle/type + type(unit_scale_type), pointer :: US !< A dimensional unit scaling type ! This routine initializes a unit_scale_type structure (US). @@ -66,39 +66,33 @@ subroutine unit_scaling_init( param_file, US ) # include "version_variable.h" character(len=16) :: mdl = "MOM_unit_scaling" - if (.not.present(US)) return - if (associated(US)) call MOM_error(FATAL, & 'unit_scaling_init: called with an associated US pointer.') allocate(US) - if (present(param_file)) then - ! Read all relevant parameters and write them to the model log. - call log_version(param_file, mdl, version, & - "Parameters for doing unit scaling of variables.", debugging=.true.) - call get_param(param_file, mdl, "Z_RESCALE_POWER", Z_power, & - "An integer power of 2 that is used to rescale the model's "//& - "internal units of depths and heights. Valid values range from -300 to 300.", & - units="nondim", default=0, debuggingParam=.true.) - call get_param(param_file, mdl, "L_RESCALE_POWER", L_power, & - "An integer power of 2 that is used to rescale the model's "//& - "internal units of lateral distances. Valid values range from -300 to 300.", & - units="nondim", default=0, debuggingParam=.true.) - call get_param(param_file, mdl, "T_RESCALE_POWER", T_power, & - "An integer power of 2 that is used to rescale the model's "//& - "internal units of time. Valid values range from -300 to 300.", & - units="nondim", default=0, debuggingParam=.true.) - call get_param(param_file, mdl, "R_RESCALE_POWER", R_power, & - "An integer power of 2 that is used to rescale the model's "//& - "internal units of density. Valid values range from -300 to 300.", & + ! Read all relevant parameters and write them to the model log. + call log_version(param_file, mdl, version, & + "Parameters for doing unit scaling of variables.", debugging=.true.) + call get_param(param_file, mdl, "Z_RESCALE_POWER", Z_power, & + "An integer power of 2 that is used to rescale the model's "//& + "internal units of depths and heights. Valid values range from -300 to 300.", & + units="nondim", default=0, debuggingParam=.true.) + call get_param(param_file, mdl, "L_RESCALE_POWER", L_power, & + "An integer power of 2 that is used to rescale the model's "//& + "internal units of lateral distances. Valid values range from -300 to 300.", & + units="nondim", default=0, debuggingParam=.true.) + call get_param(param_file, mdl, "T_RESCALE_POWER", T_power, & + "An integer power of 2 that is used to rescale the model's "//& + "internal units of time. Valid values range from -300 to 300.", & + units="nondim", default=0, debuggingParam=.true.) + call get_param(param_file, mdl, "R_RESCALE_POWER", R_power, & + "An integer power of 2 that is used to rescale the model's "//& + "internal units of density. Valid values range from -300 to 300.", & + units="nondim", default=0, debuggingParam=.true.) + call get_param(param_file, mdl, "Q_RESCALE_POWER", Q_power, & + "An integer power of 2 that is used to rescale the model's "//& + "internal units of heat content. Valid values range from -300 to 300.", & units="nondim", default=0, debuggingParam=.true.) - call get_param(param_file, mdl, "Q_RESCALE_POWER", Q_power, & - "An integer power of 2 that is used to rescale the model's "//& - "internal units of heat content. Valid values range from -300 to 300.", & - units="nondim", default=0, debuggingParam=.true.) - else - Z_power = 0 ; L_power = 0 ; T_power = 0 ; R_power = 0 ; Q_power = 0 - endif if (abs(Z_power) > 300) call MOM_error(FATAL, "unit_scaling_init: "//& "Z_RESCALE_POWER is outside of the valid range of -300 to 300.") diff --git a/src/parameterizations/lateral/MOM_hor_visc.F90 b/src/parameterizations/lateral/MOM_hor_visc.F90 index 24afcf8cd8..c588a1faa4 100644 --- a/src/parameterizations/lateral/MOM_hor_visc.F90 +++ b/src/parameterizations/lateral/MOM_hor_visc.F90 @@ -2509,6 +2509,7 @@ subroutine hor_visc_init(Time, G, GV, US, param_file, diag, CS, MEKE, ADp) if (CS%Laplacian .or. get_all) then endif end subroutine hor_visc_init + !> Calculates factors in the anisotropic orientation tensor to be align with the grid. !! With n1=1 and n2=0, this recovers the approach of Large et al, 2001. subroutine align_aniso_tensor_to_grid(CS, n1, n2) @@ -2525,6 +2526,7 @@ subroutine align_aniso_tensor_to_grid(CS, n1, n2) CS%n1n1_m_n2n2_h(:,:) = ( n1 * n1 - n2 * n2 ) * recip_n2_norm CS%n1n1_m_n2n2_q(:,:) = ( n1 * n1 - n2 * n2 ) * recip_n2_norm end subroutine align_aniso_tensor_to_grid + !> Apply a 1-1-4-1-1 Laplacian filter one time on GME diffusive flux to reduce any !! horizontal two-grid-point noise subroutine smooth_GME(CS,G,GME_flux_h,GME_flux_q) @@ -2589,6 +2591,7 @@ subroutine smooth_GME(CS,G,GME_flux_h,GME_flux_q) endif enddo ! s-loop end subroutine smooth_GME + !> Deallocates any variables allocated in hor_visc_init. subroutine hor_visc_end(CS) type(hor_visc_CS), pointer :: CS !< The control structure returned by a diff --git a/src/parameterizations/vertical/MOM_diabatic_driver.F90 b/src/parameterizations/vertical/MOM_diabatic_driver.F90 index e579661f47..7a75802a84 100644 --- a/src/parameterizations/vertical/MOM_diabatic_driver.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_driver.F90 @@ -3084,8 +3084,6 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di 'Salinity', 'PSU') endif - - !call set_diffusivity_init(Time, G, param_file, diag, CS%set_diff_CSp, CS%int_tide_CSp) CS%id_Kd_int = register_diag_field('ocean_model', 'Kd_interface', diag%axesTi, Time, & 'Total diapycnal diffusivity at interfaces', 'm2 s-1', conversion=US%Z2_T_to_m2_s) if (CS%use_energetic_PBL) then diff --git a/src/parameterizations/vertical/MOM_entrain_diffusive.F90 b/src/parameterizations/vertical/MOM_entrain_diffusive.F90 index a558f9dd2b..32cdce4d2a 100644 --- a/src/parameterizations/vertical/MOM_entrain_diffusive.F90 +++ b/src/parameterizations/vertical/MOM_entrain_diffusive.F90 @@ -352,7 +352,7 @@ subroutine entrainment_diffusive(h, tv, fluxes, dt, G, GV, US, CS, ea, eb, & ! what maxF(kb+1) should be. do i=is,ie ; min_eakb(i) = MIN(htot(i), max_eakb(i)) ; enddo call find_maxF_kb(h_bl, Sref, Ent_bl, I_dSkbp1, min_eakb, max_eakb, & - kmb, is, ie, G, GV, CS, F_kb_maxEnt, do_i_in = do_i) + kmb, is, ie, G, GV, CS, F_kb_maxEnt, do_i_in=do_i) do i=is,ie do_entrain_eakb = .false. @@ -891,7 +891,7 @@ end subroutine entrainment_diffusive !> This subroutine calculates the actual entrainments (ea and eb) and the !! amount of surface forcing that is applied to each layer if there is no bulk !! mixed layer. -subroutine F_to_ent(F, h, kb, kmb, j, G, GV, CS, dsp1_ds, eakb, Ent_bl, ea, eb, do_i_in) +subroutine F_to_ent(F, h, kb, kmb, j, G, GV, CS, dsp1_ds, eakb, Ent_bl, ea, eb) 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),SZK_(GV)), intent(in) :: F !< The density flux through a layer within @@ -920,31 +920,13 @@ subroutine F_to_ent(F, h, kb, kmb, j, G, GV, CS, dsp1_ds, eakb, Ent_bl, ea, eb, real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(inout) :: eb !< The amount of fluid entrained from the layer !! below within this time step [H ~> m or kg m-2]. - logical, dimension(SZI_(G)), & - optional, intent(in) :: do_i_in !< Indicates which i-points to work on. -! This subroutine calculates the actual entrainments (ea and eb) and the -! amount of surface forcing that is applied to each layer if there is no bulk -! mixed layer. real :: h1 ! The thickness in excess of the minimum that will remain ! after exchange with the layer below [H ~> m or kg m-2]. - logical :: do_i(SZI_(G)) integer :: i, k, is, ie, nz is = G%isc ; ie = G%iec ; nz = GV%ke - if (present(do_i_in)) then - do i=is,ie ; do_i(i) = do_i_in(i) ; enddo - do i=G%isc,G%iec ; if (do_i(i)) then - is = i ; exit - endif ; enddo - do i=G%iec,G%isc,-1 ; if (do_i(i)) then - ie = i ; exit - endif ; enddo - else - do i=is,ie ; do_i(i) = .true. ; enddo - endif - do i=is,ie ea(i,j,nz) = 0.0 ; eb(i,j,nz) = 0.0 enddo @@ -952,7 +934,7 @@ subroutine F_to_ent(F, h, kb, kmb, j, G, GV, CS, dsp1_ds, eakb, Ent_bl, ea, eb, do i=is,ie eb(i,j,kmb) = max(2.0*Ent_bl(i,Kmb+1) - eakb(i), 0.0) enddo - do k=nz-1,kmb+1,-1 ; do i=is,ie ; if (do_i(i)) then + do k=nz-1,kmb+1,-1 ; do i=is,ie if (k > kb(i)) then ! With a bulk mixed layer, surface buoyancy fluxes are applied ! elsewhere, so F should always be nonnegative. @@ -970,9 +952,9 @@ subroutine F_to_ent(F, h, kb, kmb, j, G, GV, CS, dsp1_ds, eakb, Ent_bl, ea, eb, ! up into the buffer layer. eb(i,j,k) = eb(i,j,k+1) + max(0.0, h(i,j,k+1) - GV%Angstrom_H) endif - endif ; enddo ; enddo + enddo ; enddo k = kmb - do i=is,ie ; if (do_i(i)) then + do i=is,ie ! Adjust the previously calculated entrainment from below by the deepest ! buffer layer to account for entrainment of thin interior layers . if (kb(i) > kmb+1) & @@ -981,8 +963,8 @@ subroutine F_to_ent(F, h, kb, kmb, j, G, GV, CS, dsp1_ds, eakb, Ent_bl, ea, eb, ! Determine the entrainment from above for each buffer layer. h1 = (h(i,j,k) - GV%Angstrom_H) + (eb(i,j,k) - ea(i,j,k+1)) ea(i,j,k) = MAX(Ent_bl(i,K), Ent_bl(i,K)-0.5*h1, -h1) - endif ; enddo - do k=kmb-1,2,-1 ; do i=is,ie ; if (do_i(i)) then + enddo + do k=kmb-1,2,-1 ; do i=is,ie ! Determine the entrainment from below for each buffer layer. eb(i,j,k) = max(2.0*Ent_bl(i,K+1) - ea(i,j,k+1), 0.0) @@ -992,11 +974,11 @@ subroutine F_to_ent(F, h, kb, kmb, j, G, GV, CS, dsp1_ds, eakb, Ent_bl, ea, eb, ! if (h1 >= 0.0) then ; ea(i,j,k) = Ent_bl(i,K) ! elseif (Ent_bl(i,K)+0.5*h1 >= 0.0) then ; ea(i,j,k) = Ent_bl(i,K)-0.5*h1 ! else ; ea(i,j,k) = -h1 ; endif - endif ; enddo ; enddo - do i=is,ie ; if (do_i(i)) then + enddo ; enddo + do i=is,ie eb(i,j,1) = max(2.0*Ent_bl(i,2) - ea(i,j,2), 0.0) ea(i,j,1) = 0.0 - endif ; enddo + enddo else ! not BULKMIXEDLAYER ! Calculate the entrainment by each layer from above and below. ! Entrainment is always positive, but F may be negative due to @@ -1511,7 +1493,7 @@ subroutine F_kb_to_ea_kb(h_bl, Sref, Ent_bl, I_dSkbp1, F_kb, kmb, i, & ! the maximum. zeros(i) = 0.0 call find_maxF_kb(h_bl, Sref, Ent_bl, I_dSkbp1, zeros, ea_kb, & - kmb, i, i, G, GV, CS, maxF, ent_maxF, F_thresh = F_kb) + kmb, i, i, G, GV, CS, maxF, ent_maxF, F_thresh=F_kb) err_max = dS_kbp1 * maxF(i) - val ! If err_max is negative, there is no good solution, so use the maximum ! value of F in the valid range. @@ -1693,7 +1675,7 @@ subroutine determine_Ea_kb(h_bl, dtKd_kb, Sref, I_dSkbp1, Ent_bl, ea_kbp1, & do_any = .false. ; do i=is,ie ; if (redo_i(i)) do_any = .true. ; enddo if (.not.do_any) exit call determine_dSkb(h_bl, Sref, Ent_bl, Ent, is, ie, kmb, G, GV, .true., dS_kb, & - ddSkb_dE, dS_lay, ddSlay_dE, do_i_in = redo_i) + ddSkb_dE, dS_lay, ddSlay_dE, do_i_in=redo_i) do i=is,ie ; if (redo_i(i)) then ! The correct root is bracketed between E_min and E_max. ! Note the following limits: Ent >= 0 ; fa > 1 ; fk > 0 @@ -1757,7 +1739,7 @@ subroutine determine_Ea_kb(h_bl, dtKd_kb, Sref, I_dSkbp1, Ent_bl, ea_kbp1, & ! Update the value of dS_kb for consistency with Ent. if (present(F_kb) .or. present(dFdfm_kb)) & call determine_dSkb(h_bl, Sref, Ent_bl, Ent, is, ie, kmb, G, GV, .true., & - dS_kb, do_i_in = do_i) + dS_kb, do_i_in=do_i) if (present(F_kb)) then ; do i=is,ie ; if (do_i(i)) then F_kb(i) = Ent(i) * (dS_kb(i) * I_dSkbp1(i)) @@ -1878,7 +1860,7 @@ subroutine find_maxF_kb(h_bl, Sref, Ent_bl, I_dSkbp1, min_ent_in, max_ent_in, & do i=ie1,is,-1 ; if (do_i(i)) is1 = i ; enddo ! Find the value of F and its derivative at min_ent. call determine_dSkb(h_bl, Sref, Ent_bl, minent, is1, ie1, kmb, G, GV, .false., & - dS_kb, ddSkb_dE, do_i_in = do_i) + dS_kb, ddSkb_dE, do_i_in=do_i) do i=is1,ie1 ; if (do_i(i)) then F_minent(i) = minent(i) * dS_kb(i) * I_dSkbp1(i) dF_dE_min(i) = (dS_kb(i) + minent(i)*ddSkb_dE(i)) * I_dSkbp1(i) @@ -1958,7 +1940,7 @@ subroutine find_maxF_kb(h_bl, Sref, Ent_bl, I_dSkbp1, min_ent_in, max_ent_in, & endif call determine_dSkb(h_bl, Sref, Ent_bl, ent, is1, ie1, kmb, G, GV, .false., & - dS_kb, ddSkb_dE, do_i_in = do_i) + dS_kb, ddSkb_dE, do_i_in=do_i) do i=is1,ie1 ; if (do_i(i)) then F(i) = ent(i)*dS_kb(i)*I_dSkbp1(i) dF_dent(i) = (dS_kb(i) + ent(i)*ddSkb_dE(i)) * I_dSkbp1(i) @@ -2050,8 +2032,7 @@ subroutine find_maxF_kb(h_bl, Sref, Ent_bl, I_dSkbp1, min_ent_in, max_ent_in, & enddo if (doany) then ! For efficiency, could save previous value of dS_anom_lim_best? - call determine_dSkb(h_bl, Sref, Ent_bl, ent_best, is, ie, kmb, G, GV, .true., & - dS_kb_lim) + call determine_dSkb(h_bl, Sref, Ent_bl, ent_best, is, ie, kmb, G, GV, .true., dS_kb_lim) do i=is,ie F_best(i) = ent_best(i)*dS_kb_lim(i)*I_dSkbp1(i) ! The second test seems necessary because of roundoff differences that @@ -2088,14 +2069,13 @@ subroutine entrain_diffusive_init(Time, G, GV, US, param_file, diag, CS, just_re !! output. type(entrain_diffusive_CS), pointer :: CS !< A pointer that is set to point to the control !! structure. - logical, optional, intent(in) :: just_read_params !< If present and true, this call will - !! only read parameters logging them or registering + logical, intent(in) :: just_read_params !< If true, this call will only read + !! and log parameters without registering !! any diagnostics ! Local variables real :: dt ! The dynamics timestep, used here in the default for TOLERANCE_ENT, in MKS units [s] real :: Kd ! A diffusivity used in the default for TOLERANCE_ENT, in MKS units [m2 s-1] - logical :: just_read ! If true, just read parameters but do nothing else. ! This include declares and sets the variable "version". # include "version_variable.h" character(len=40) :: mdl = "MOM_entrain_diffusive" ! This module's name. @@ -2107,30 +2087,28 @@ subroutine entrain_diffusive_init(Time, G, GV, US, param_file, diag, CS, just_re endif allocate(CS) - just_read = .false. ; if (present(just_read_params)) just_read = just_read_params - CS%diag => diag CS%bulkmixedlayer = (GV%nkml > 0) -! Set default, read and log parameters - if (.not.just_read) call log_version(param_file, mdl, version, "") + ! Set default, read and log parameters + if (.not.just_read_params) call log_version(param_file, mdl, version, "") call get_param(param_file, mdl, "MAX_ENT_IT", CS%max_ent_it, & "The maximum number of iterations that may be used to "//& - "calculate the interior diapycnal entrainment.", default=5, do_not_log=just_read) + "calculate the interior diapycnal entrainment.", default=5, do_not_log=just_read_params) ! In this module, KD is only used to set the default for TOLERANCE_ENT. [m2 s-1] call get_param(param_file, mdl, "KD", Kd, default=0.0) call get_param(param_file, mdl, "DT", dt, & "The (baroclinic) dynamics time step.", units = "s", & - fail_if_missing=.true., do_not_log=just_read) + fail_if_missing=.true., do_not_log=just_read_params) call get_param(param_file, mdl, "TOLERANCE_ENT", CS%Tolerance_Ent, & "The tolerance with which to solve for entrainment values.", & units="m", default=MAX(100.0*GV%Angstrom_m,1.0e-4*sqrt(dt*Kd)), scale=GV%m_to_H, & - do_not_log=just_read) + do_not_log=just_read_params) CS%Rho_sig_off = 1000.0*US%kg_m3_to_R - if (.not.just_read) then + if (.not.just_read_params) then CS%id_Kd = register_diag_field('ocean_model', 'Kd_effective', diag%axesTL, Time, & 'Diapycnal diffusivity as applied', 'm2 s-1', conversion=US%Z2_T_to_m2_s) CS%id_diff_work = register_diag_field('ocean_model', 'diff_work', diag%axesTi, Time, & @@ -2138,7 +2116,7 @@ subroutine entrain_diffusive_init(Time, G, GV, US, param_file, diag, CS, just_re 'W m-2', conversion=US%RZ3_T3_to_W_m2) endif - if (just_read) deallocate(CS) + if (just_read_params) deallocate(CS) end subroutine entrain_diffusive_init diff --git a/src/parameterizations/vertical/MOM_vert_friction.F90 b/src/parameterizations/vertical/MOM_vert_friction.F90 index 6465df1d4e..5b85c5f5f6 100644 --- a/src/parameterizations/vertical/MOM_vert_friction.F90 +++ b/src/parameterizations/vertical/MOM_vert_friction.F90 @@ -1888,7 +1888,7 @@ end subroutine vertvisc_init subroutine updateCFLtruncationValue(Time, CS, activate) type(time_type), target, intent(in) :: Time !< Current model time type(vertvisc_CS), pointer :: CS !< Vertical viscosity control structure - logical, optional, intent(in) :: activate !< Specifiy whether to record the value of + logical, optional, intent(in) :: activate !< Specify whether to record the value of !! Time as the beginning of the ramp period ! Local variables From 52fe57631f4aa33251a024fe8718fa0959befc02 Mon Sep 17 00:00:00 2001 From: He Wang <35150900+herrwang0@users.noreply.github.com> Date: Tue, 29 Jun 2021 14:59:45 -0400 Subject: [PATCH 106/112] Bugfix: Minor changes on clipping topography from file (#1428) * Minor changes to topography initialized from files This is intended to extend the compatibility with negative topography. 1. A bug that occurs when clipping topography with a negative MINIMUM_DEPTH is fixed. 2. MASKING_DEPTH can now be negative. 3. A warning will be given if MASKING_DEPTH is set to be smaller than MINIMUM_DEPTH. * Adding an exception to avoid answer changes To keep answer unchnaged in the test cases (at land points), D is clipped at 0.5*min_depth when min_depth > 0. * Change the if-statement on whether MASK_DEPTH is default to a simple comparison * Change the if-statement on whether MASK_DEPTH is default * Change the if-statement comparison on MASK_DEPTH Reverted back to a simple comparison. A mistake in a previous commit in MOM_grid_initialize.F90 is corrected. Co-authored-by: Robert Hallberg --- src/initialization/MOM_grid_initialize.F90 | 12 ++++++--- .../MOM_shared_initialization.F90 | 26 +++++++++++++------ 2 files changed, 27 insertions(+), 11 deletions(-) diff --git a/src/initialization/MOM_grid_initialize.F90 b/src/initialization/MOM_grid_initialize.F90 index 0fac3e15b4..fbee77d130 100644 --- a/src/initialization/MOM_grid_initialize.F90 +++ b/src/initialization/MOM_grid_initialize.F90 @@ -9,7 +9,7 @@ module MOM_grid_initialize use MOM_domains, only : To_North, To_South, To_East, To_West use MOM_domains, only : MOM_domain_type, clone_MOM_domain, deallocate_MOM_domain use MOM_dyn_horgrid, only : dyn_horgrid_type, set_derived_dyn_horgrid -use MOM_error_handler, only : MOM_error, MOM_mesg, FATAL, is_root_pe +use MOM_error_handler, only : MOM_error, MOM_mesg, FATAL, WARNING, is_root_pe use MOM_error_handler, only : callTree_enter, callTree_leave use MOM_file_parser, only : get_param, log_param, log_version, param_file_type use MOM_io, only : MOM_read_data, slasher, file_exists, stdout @@ -1217,11 +1217,17 @@ subroutine initialize_masks(G, PF, US) units="m", default=0.0, scale=m_to_Z_scale) call get_param(PF, mdl, "MASKING_DEPTH", mask_depth, & "The depth below which to mask points as land points, for which all "//& - "fluxes are zeroed out. MASKING_DEPTH is ignored if negative.", & + "fluxes are zeroed out. MASKING_DEPTH needs to be smaller than MINIMUM_DEPTH", & units="m", default=-9999.0, scale=m_to_Z_scale) + if (mask_depth > min_depth) then + mask_depth = -9999.0*m_to_Z_scale + call MOM_error(WARNING, "MOM_grid_init: initialize_masks "//& + 'MASKING_DEPTH is larger than MINIMUM_DEPTH and therefore ignored.') + endif + Dmin = min_depth - if (mask_depth>=0.) Dmin = mask_depth + if (mask_depth /= -9999.*m_to_Z_scale) Dmin = mask_depth G%mask2dCu(:,:) = 0.0 ; G%mask2dCv(:,:) = 0.0 ; G%mask2dBu(:,:) = 0.0 diff --git a/src/initialization/MOM_shared_initialization.F90 b/src/initialization/MOM_shared_initialization.F90 index daaefd4b98..336a85d5bc 100644 --- a/src/initialization/MOM_shared_initialization.F90 +++ b/src/initialization/MOM_shared_initialization.F90 @@ -413,17 +413,27 @@ subroutine limit_topography(D, G, param_file, max_depth, US) "The depth below which to mask the ocean as land.", & units="m", default=-9999.0, scale=m_to_Z, do_not_log=.true.) -! Make sure that min_depth < D(x,y) < max_depth - if (mask_depth < -9990.*m_to_Z) then - do j=G%jsd,G%jed ; do i=G%isd,G%ied - D(i,j) = min( max( D(i,j), 0.5*min_depth ), max_depth ) - enddo ; enddo + if (mask_depth > min_depth) then + mask_depth = -9999.0*m_to_Z + call MOM_error(WARNING, "MOM_shared_initialization: limit_topography "//& + 'MASKING_DEPTH is larger than MINIMUM_DEPTH and therefore ignored.') + endif + + ! Make sure that min_depth < D(x,y) < max_depth for ocean points + if (mask_depth == -9999.*m_to_Z) then + if (min_depth > 0.0) then ! This is retained to avoid answer changes (over the land points) in the test cases. + do j=G%jsd,G%jed ; do i=G%isd,G%ied + D(i,j) = min( max( D(i,j), 0.5*min_depth ), max_depth ) + enddo ; enddo + else + do j=G%jsd,G%jed ; do i=G%isd,G%ied + D(i,j) = min( max( D(i,j), min_depth ), max_depth ) + enddo ; enddo + endif else do j=G%jsd,G%jed ; do i=G%isd,G%ied - if (D(i,j)>0.) then + if (D(i,j) > mask_depth) then D(i,j) = min( max( D(i,j), min_depth ), max_depth ) - else - D(i,j) = 0. endif enddo ; enddo endif From 4e3cc5d286bb5c6cfde9b6995b5c16610c67ff92 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Tue, 29 Jun 2021 23:00:08 -0400 Subject: [PATCH 107/112] Update gitlab pipeline to use scripts from MOM6-examples - Reduce entries in .gitlab-ci.yml to mostly just one line by invoking scripts in MOM6-examples - This undoes early direction of moving detailed control into the pipeline yaml - todo: define a library build process from within each child repository --- .gitlab-ci.yml | 183 +++++++++++++++++-------------------------------- 1 file changed, 64 insertions(+), 119 deletions(-) diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 5d84c0c176..5e1da1c1f9 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -1,113 +1,78 @@ stages: - - merge+setup - builds - run - tests - cleanup +variables: + CACHE_DIR: "/lustre/f2/scratch/oar.gfdl.ogrp-account/runner/cache/" + + # Merges MOM6 with dev/gfdl. Changes directory to test directory, if it exists. +# - set cache location +# - get MOM6-examples/tools/MRS scripts by cloning Gaea-stats and then MOM6-examples +# - set working directory to MOM6-examples +# - pull down latest of dev/gfdl (MOM6-examples might be ahead of Gaea-stats) before_script: - - MOM6_SRC=$CI_PROJECT_DIR - - echo Cache directory set to ${CACHE_DIR:=/lustre/f2/scratch/oar.gfdl.ogrp-account/runner/cache/} - - git pull --no-edit https://github.com/NOAA-GFDL/MOM6.git dev/gfdl && git submodule init && git submodule update - - pwd ; ls + - echo Cache directory set to $CACHE_DIR + - echo -e "\e[0Ksection_start:`date +%s`:before[collapsed=true]\r\e[0KPre-script" + - git clone https://gitlab.gfdl.noaa.gov/ogrp/Gaea-stats-MOM6-examples.git tests + - cd tests && git submodule init && git submodule update + - cd MOM6-examples && git checkout dev/gfdl && git pull + - echo -e "\e[0Ksection_end:`date +%s`:before\r\e[0K" # Tests that merge with dev/gfdl works. merge: - stage: merge+setup + stage: builds tags: - ncrc4 script: - - pwd ; ls + - cd $CI_PROJECT_DIR - git pull --no-edit https://github.com/NOAA-GFDL/MOM6.git dev/gfdl -# Clones regression repo, if necessary, pulls latest of everything, and sets up working space -setup: - stage: merge+setup - tags: - - ncrc4 - script: - - pwd ; ls - # Clone regressions directory - - git clone --recursive http://gitlab.gfdl.noaa.gov/ogrp/Gaea-stats-MOM6-examples.git tests && cd tests - # Install / update testing scripts - - git clone -b new-code-struct https://github.com/adcroft/MRS.git MRS - # Update MOM6-examples and submodules - - (cd MOM6-examples && git checkout . && git checkout dev/gfdl && git pull && git submodule init && git submodule update) - - (cd MOM6-examples/src/MOM6 && git submodule update) - - test -d MOM6-examples/src/LM3 || make -f MRS/Makefile.clone clone_gfdl -s - - make -f MRS/Makefile.clone MOM6-examples/.datasets -s - - env > gitlab_session.log - # Show hashes for final setup - - git show --oneline - - git submodule status - - (cd MOM6-examples && git submodule status --recursive src) - # Cache everything under tests to unpack for each subsequent stage - - cd ../ ; time tar zcf $CACHE_DIR/tests_$CI_PIPELINE_ID.tgz tests - # Compiles gnu:repro: stage: builds tags: - ncrc4 script: - - time tar zxf $CACHE_DIR/tests_$CI_PIPELINE_ID.tgz && cd tests - - time make -f MRS/Makefile.build MOM6_SRC=../ build_gnu -s -j - - time make -f MRS/Makefile.build MOM6_SRC=../ static_gnu -s -j - - time tar zvcf $CACHE_DIR/build-gnu-repro-$CI_PIPELINE_ID.tgz `find build/gnu -name MOM6` + - time make -f tools/MRS/Makefile MOM6_SRC=../.. pipeline-build-repro-gnu -s -j + - time make -f tools/MRS/Makefile MOM6_SRC=../.. pipeline-build-static-gnu -s -j gnu:ocean-only-nolibs: stage: builds tags: - ncrc4 script: - - time tar zxf $CACHE_DIR/tests_$CI_PIPELINE_ID.tgz && cd tests - - make -f MRS/Makefile.build build/gnu/env && cd build/gnu - # mkdir -p build/gnu/repro/symmetric_dynamic/ocean_only && cd build/gnu/repro/symmetric_dynamic/ocean_only - - ../../MOM6-examples/src/mkmf/bin/list_paths -l ../../../config_src/{drivers/solo_driver,memory/dynamic_symmetric,infra/FMS1,ext*} ../../../src ../../MOM6-examples/src/FMS - - sed -i '/FMS\/.*\/test_/d' path_names - - ../../MOM6-examples/src/mkmf/bin/mkmf -t ../../MOM6-examples/src/mkmf/templates/ncrc-gnu.mk -p MOM6 -c"-Duse_libMPI -Duse_netCDF" path_names - - time (source ./env ; make NETCDF=3 REPRO=1 MOM6 -s -j) + - make -f tools/MRS/Makefile pipeline-build-gnu-oceanonly-nolibs gnu:ice-ocean-nolibs: stage: builds tags: - ncrc4 script: - - time tar zxf $CACHE_DIR/tests_$CI_PIPELINE_ID.tgz && cd tests - - make -f MRS/Makefile.build build/gnu/env && cd build/gnu - # mkdir -p build/gnu/repro/symmetric_dynamic/ocean_only && cd build/gnu/repro/symmetric_dynamic/ocean_only - - ../../MOM6-examples/src/mkmf/bin/list_paths -l ../../../config_src/{drivers/FMS_cap,memory/dynamic_nonsymmetric,infra/FMS1,ext*} ../../../src ../../MOM6-examples/src/{FMS,coupler,SIS2,icebergs,ice_param,land_null,atmos_null} - - sed -i '/FMS\/.*\/test_/d' path_names - - ../../MOM6-examples/src/mkmf/bin/mkmf -t ../../MOM6-examples/src/mkmf/templates/ncrc-gnu.mk -p MOM6 -c"-Duse_libMPI -Duse_netCDF -D_USE_LEGACY_LAND_ -Duse_AM3_physics" path_names - - time (source ./env ; make NETCDF=3 REPRO=1 MOM6 -s -j) + - make -f tools/MRS/Makefile pipeline-build-gnu-iceocean-nolibs intel:repro: stage: builds tags: - ncrc4 script: - - time tar zxf $CACHE_DIR/tests_$CI_PIPELINE_ID.tgz && cd tests - - make -f MRS/Makefile.build MOM6_SRC=../ build_intel -s -j - - time tar zvcf $CACHE_DIR/build-intel-repro-$CI_PIPELINE_ID.tgz `find build/intel -name MOM6` + - time make -f tools/MRS/Makefile MOM6_SRC=../.. pipeline-build-repro-intel -s -j pgi:repro: stage: builds tags: - ncrc4 script: - - time tar zxf $CACHE_DIR/tests_$CI_PIPELINE_ID.tgz && cd tests - - make -f MRS/Makefile.build MOM6_SRC=../ build_pgi -s -j - - time tar zvcf $CACHE_DIR/build-pgi-repro-$CI_PIPELINE_ID.tgz `find build/pgi -name MOM6` + - time make -f tools/MRS/Makefile MOM6_SRC=../.. pipeline-build-repro-pgi -s -j gnu:debug: stage: builds tags: - ncrc4 script: - - time tar zxf $CACHE_DIR/tests_$CI_PIPELINE_ID.tgz && cd tests - - make -f MRS/Makefile.build MOM6_SRC=../ debug_gnu -s -j - - time tar zvcf $CACHE_DIR/build-gnu-debug-$CI_PIPELINE_ID.tgz `find build/gnu -name MOM6` + - time make -f tools/MRS/Makefile MOM6_SRC=../.. pipeline-build-debug-gnu -s -j # Runs run: @@ -115,41 +80,43 @@ run: tags: - ncrc4 script: - - time tar zxf $CACHE_DIR/tests_$CI_PIPELINE_ID.tgz && cd tests - - time tar zxf $CACHE_DIR/build-gnu-repro-$CI_PIPELINE_ID.tgz - - time tar zxf $CACHE_DIR/build-intel-repro-$CI_PIPELINE_ID.tgz - - time tar zxf $CACHE_DIR/build-pgi-repro-$CI_PIPELINE_ID.tgz - # time tar zxf $CACHE_DIR/build-gnu-debug-$CI_PIPELINE_ID.tgz - - (echo '#!/bin/tcsh';echo 'make -f MRS/Makefile.tests all') > job.sh - - sbatch --clusters=c3,c4 --nodes=29 --time=0:34:00 --account=gfdl_o --qos=debug --job-name=mom6_regressions --output=log.$CI_PIPELINE_ID --wait job.sh || MJOB_RETURN_STATE=Fail - - cat log.$CI_PIPELINE_ID - - test -z "$MJOB_RETURN_STATE" - - test -f restart_results_gnu.tar.gz - - time tar zvcf $CACHE_DIR/results-$CI_PIPELINE_ID.tgz *.tar.gz + - make -f tools/MRS/Makefile mom6-pipeline-run gnu.testing: stage: run tags: - ncrc4 + before_script: + - echo -e "\e[0Ksection_start:`date +%s`:submodules[collapsed=true]\r\e[0KCloning submodules" + - git submodule init ; git submodule update + - echo -e "\e[0Ksection_end:`date +%s`:submodules\r\e[0K" script: + - echo -e "\e[0Ksection_start:`date +%s`:compile[collapsed=true]\r\e[0KCompiling executables" - cd .testing - module unload PrgEnv-pgi PrgEnv-intel PrgEnv-gnu darshan ; module load PrgEnv-gnu ; module unload netcdf gcc ; module load gcc/7.3.0 cray-hdf5 cray-netcdf - make work/local-env - make -s -j + - echo -e "\e[0Ksection_end:`date +%s`:compile\r\e[0K" - (echo '#!/bin/bash';echo '. ./work/local-env/bin/activate';echo 'make MPIRUN="srun -mblock --exclusive" test -s -j') > job.sh - - sbatch --clusters=c3,c4 --nodes=5 --time=0:05:00 --account=gfdl_o --qos=debug --job-name=MOM6.gnu.testing --output=log.$CI_PIPELINE_ID --wait job.sh || cat log.$CI_PIPELINE_ID && make test + - sbatch --clusters=c3,c4 --nodes=5 --time=0:05:00 --account=gfdl_o --qos=debug --job-name=MOM6.gnu.testing --output=log.$CI_PIPELINE_ID --wait job.sh && make test || cat log.$CI_PIPELINE_ID intel.testing: stage: run tags: - ncrc4 + before_script: + - echo -e "\e[0Ksection_start:`date +%s`:submodules[collapsed=true]\r\e[0KCloning submodules" + - git submodule init ; git submodule update + - echo -e "\e[0Ksection_end:`date +%s`:submodules\r\e[0K" script: + - echo -e "\e[0Ksection_start:`date +%s`:compile[collapsed=true]\r\e[0KCompiling executables" - cd .testing - module unload PrgEnv-pgi PrgEnv-intel PrgEnv-gnu darshan; module load PrgEnv-intel; module unload netcdf intel; module load intel/18.0.6.288 cray-hdf5 cray-netcdf - make work/local-env - make -s -j + - echo -e "\e[0Ksection_end:`date +%s`:compile\r\e[0K" - (echo '#!/bin/bash';echo '. ./work/local-env/bin/activate';echo 'make MPIRUN="srun -mblock --exclusive" test -s -j') > job.sh - - sbatch --clusters=c3,c4 --nodes=5 --time=0:05:00 --account=gfdl_o --qos=debug --job-name=MOM6.gnu.testing --output=log.$CI_PIPELINE_ID --wait job.sh || cat log.$CI_PIPELINE_ID && make test + - sbatch --clusters=c3,c4 --nodes=5 --time=0:05:00 --account=gfdl_o --qos=debug --job-name=MOM6.gnu.testing --output=log.$CI_PIPELINE_ID --wait job.sh && make test || cat log.$CI_PIPELINE_ID # Tests gnu:non-symmetric: @@ -157,113 +124,91 @@ gnu:non-symmetric: tags: - ncrc4 script: - - time tar zxf $CACHE_DIR/tests_$CI_PIPELINE_ID.tgz && cd tests - - time tar zxf $CACHE_DIR/results-$CI_PIPELINE_ID.tgz - - make -f MRS/Makefile.tests gnu_non_symmetric + - make -f tools/MRS/Makefile mom6-pipeline-test-gnu_non_symmetric -intel:non-symmetric: +gnu:symmetric: stage: tests tags: - ncrc4 script: - - time tar zxf $CACHE_DIR/tests_$CI_PIPELINE_ID.tgz && cd tests - - time tar zxf $CACHE_DIR/results-$CI_PIPELINE_ID.tgz - - make -f MRS/Makefile.tests intel_non_symmetric + - make -f tools/MRS/Makefile mom6-pipeline-test-gnu_symmetric -pgi:non-symmetric: +gnu:memory: stage: tests tags: - ncrc4 script: - - time tar zxf $CACHE_DIR/tests_$CI_PIPELINE_ID.tgz && cd tests - - time tar zxf $CACHE_DIR/results-$CI_PIPELINE_ID.tgz - - make -f MRS/Makefile.tests pgi_non_symmetric + - make -f tools/MRS/Makefile mom6-pipeline-test-gnu_memory -gnu:symmetric: +gnu:static: stage: tests tags: - ncrc4 script: - - time tar zxf $CACHE_DIR/tests_$CI_PIPELINE_ID.tgz && cd tests - - time tar zxf $CACHE_DIR/results-$CI_PIPELINE_ID.tgz - - make -f MRS/Makefile.tests gnu_symmetric + - make -f tools/MRS/Makefile mom6-pipeline-test-gnu_static -intel:symmetric: +gnu:restart: stage: tests tags: - ncrc4 script: - - time tar zxf $CACHE_DIR/tests_$CI_PIPELINE_ID.tgz && cd tests - - time tar zxf $CACHE_DIR/results-$CI_PIPELINE_ID.tgz - - make -f MRS/Makefile.tests intel_symmetric + - make -f tools/MRS/Makefile mom6-pipeline-test-gnu_restarts -pgi:symmetric: +gnu:params: stage: tests tags: - ncrc4 script: - - time tar zxf $CACHE_DIR/tests_$CI_PIPELINE_ID.tgz && cd tests - - time tar zxf $CACHE_DIR/results-$CI_PIPELINE_ID.tgz - - make -f MRS/Makefile.tests pgi_symmetric + - make -f tools/MRS/Makefile mom6-pipeline-test-params_gnu_symmetric + allow_failure: true -gnu:layout: +intel:symmetric: stage: tests tags: - ncrc4 script: - - time tar zxf $CACHE_DIR/tests_$CI_PIPELINE_ID.tgz && cd tests - - time tar zxf $CACHE_DIR/results-$CI_PIPELINE_ID.tgz - - make -f MRS/Makefile.tests gnu_layout + - make -f tools/MRS/Makefile mom6-pipeline-test-intel_symmetric -intel:layout: +intel:non-symmetric: stage: tests tags: - ncrc4 script: - - time tar zxf $CACHE_DIR/tests_$CI_PIPELINE_ID.tgz && cd tests - - time tar zxf $CACHE_DIR/results-$CI_PIPELINE_ID.tgz - - make -f MRS/Makefile.tests intel_layout + - make -f tools/MRS/Makefile mom6-pipeline-test-intel_non_symmetric -pgi:layout: +intel:memory: stage: tests tags: - ncrc4 script: - - time tar zxf $CACHE_DIR/tests_$CI_PIPELINE_ID.tgz && cd tests - - time tar zxf $CACHE_DIR/results-$CI_PIPELINE_ID.tgz - - make -f MRS/Makefile.tests pgi_layout + - make -f tools/MRS/Makefile mom6-pipeline-test-intel_memory -gnu:static: +pgi:symmetric: stage: tests tags: - ncrc4 script: - - time tar zxf $CACHE_DIR/tests_$CI_PIPELINE_ID.tgz && cd tests - - time tar zxf $CACHE_DIR/results-$CI_PIPELINE_ID.tgz - - make -f MRS/Makefile.tests gnu_static + - make -f tools/MRS/Makefile mom6-pipeline-test-pgi_symmetric -gnu:restart: +pgi:non-symmetric: stage: tests tags: - ncrc4 script: - - time tar zxf $CACHE_DIR/tests_$CI_PIPELINE_ID.tgz && cd tests - - time tar zxf $CACHE_DIR/results-$CI_PIPELINE_ID.tgz - - make -f MRS/Makefile.tests gnu_check_restarts + - make -f tools/MRS/Makefile mom6-pipeline-test-pgi_non_symmetric -gnu:params: +pgi:memory: stage: tests tags: - ncrc4 script: - - time tar zxf $CACHE_DIR/tests_$CI_PIPELINE_ID.tgz && cd tests - - time tar zxf $CACHE_DIR/results-$CI_PIPELINE_ID.tgz - - make -f MRS/Makefile.tests params_gnu_symmetric - allow_failure: true + - make -f tools/MRS/Makefile mom6-pipeline-test-pgi_memory cleanup: stage: cleanup tags: - ncrc4 + before_script: + - echo Skipping submodule update script: - rm $CACHE_DIR/*$CI_PIPELINE_ID.tgz From d9bdbc3431abdc2fe36d75071fd9ef0ec43c2a06 Mon Sep 17 00:00:00 2001 From: Keith Lindsay Date: Fri, 9 Jul 2021 12:45:06 -0600 Subject: [PATCH 108/112] fix dim_names assignment in MOM_io:read_var_sizes fixes #1439 --- src/framework/MOM_io.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/framework/MOM_io.F90 b/src/framework/MOM_io.F90 index 3ad2c92f41..f8cfb09382 100644 --- a/src/framework/MOM_io.F90 +++ b/src/framework/MOM_io.F90 @@ -714,7 +714,7 @@ subroutine read_var_sizes(filename, varname, ndims, sizes, match_case, caller, d if (status /= NF90_NOERR) call MOM_error(WARNING, trim(hdr) // trim(NF90_STRERROR(status)) //& " Getting dimension length for "//trim(varname)//" in "//trim(filename)) if (present(dim_names)) then - if (n <= size(dim_names)) dim_names = trim(dimname) + if (n <= size(dim_names)) dim_names(n) = trim(dimname) endif enddo deallocate(dimids) From 7c27bfba2bf27c6d78bd13792906c4438731c186 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 9 Jul 2021 18:09:11 -0400 Subject: [PATCH 109/112] +Add query_wave_properties & fix NUOPC wave queries Added a new routine, query_wave_properties, that can be call to get information about the wave properties from the waves control structure, and added a get_param call for SURFBAND_WAVENUMBERS to MOM_wave_interface_init when it is using the options that are typical with NUOPC coupler. These changes should allow the NUOPC coupler to compile and work again, while still keeping the same level of opacity in the wave_parameters_CS. All answers should be bitwise identical, although the order of some entries in the MOM_parameter_doc files may change when coupled with waves is WAVE_METHOD=SURFACE_BANDS and SURFBAND_SOURCE=COUPLER. --- config_src/drivers/nuopc_cap/mom_cap.F90 | 8 ++++-- .../nuopc_cap/mom_ocean_model_nuopc.F90 | 6 ---- src/user/MOM_wave_interface.F90 | 28 +++++++++++++++++++ 3 files changed, 33 insertions(+), 9 deletions(-) diff --git a/config_src/drivers/nuopc_cap/mom_cap.F90 b/config_src/drivers/nuopc_cap/mom_cap.F90 index 2d79674606..6561f63fd1 100644 --- a/config_src/drivers/nuopc_cap/mom_cap.F90 +++ b/config_src/drivers/nuopc_cap/mom_cap.F90 @@ -28,8 +28,9 @@ module MOM_cap_mod use MOM_get_input, only: get_MOM_input, directories use MOM_domains, only: pass_var use MOM_error_handler, only: MOM_error, FATAL, is_root_pe -use MOM_ocean_model_nuopc, only: ice_ocean_boundary_type use MOM_grid, only: ocean_grid_type, get_global_grid_size +use MOM_wave_interface, only: query_wave_properties +use MOM_ocean_model_nuopc, only: ice_ocean_boundary_type use MOM_ocean_model_nuopc, only: ocean_model_restart, ocean_public_type, ocean_state_type use MOM_ocean_model_nuopc, only: ocean_model_init_sfc use MOM_ocean_model_nuopc, only: ocean_model_init, update_ocean_model, ocean_model_end @@ -696,7 +697,7 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) Ice_ocean_boundary%frunoff = 0.0 if (ocean_state%use_waves) then - Ice_ocean_boundary%num_stk_bands=ocean_state%Waves%NumBands + call query_wave_properties(ocean_state%Waves, NumBands=Ice_ocean_boundary%num_stk_bands) allocate ( Ice_ocean_boundary% ustk0 (isc:iec,jsc:jec), & Ice_ocean_boundary% vstk0 (isc:iec,jsc:jec), & Ice_ocean_boundary% ustkb (isc:iec,jsc:jec,Ice_ocean_boundary%num_stk_bands), & @@ -704,7 +705,8 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) Ice_ocean_boundary%stk_wavenumbers (Ice_ocean_boundary%num_stk_bands)) Ice_ocean_boundary%ustk0 = 0.0 Ice_ocean_boundary%vstk0 = 0.0 - Ice_ocean_boundary%stk_wavenumbers = ocean_state%Waves%WaveNum_Cen + call query_wave_properties(ocean_state%Waves, WaveNumbers=Ice_ocean_boundary%stk_wavenumbers, & + US=ocean_state%US) Ice_ocean_boundary%ustkb = 0.0 Ice_ocean_boundary%vstkb = 0.0 endif diff --git a/config_src/drivers/nuopc_cap/mom_ocean_model_nuopc.F90 b/config_src/drivers/nuopc_cap/mom_ocean_model_nuopc.F90 index 1d5de0dd3e..06fa905a23 100644 --- a/config_src/drivers/nuopc_cap/mom_ocean_model_nuopc.F90 +++ b/config_src/drivers/nuopc_cap/mom_ocean_model_nuopc.F90 @@ -391,12 +391,6 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, gas_fields_ocn, i ! MOM_wave_interface_init is called regardless of the value of USE_WAVES because ! it also initializes statistical waves. call MOM_wave_interface_init(OS%Time, OS%grid, OS%GV, OS%US, param_file, OS%Waves, OS%diag) - if (OS%use_waves) then - ! I do not know why this is being set here. It seems out of place. -RWH - call get_param(param_file,mdl,"SURFBAND_WAVENUMBERS", OS%Waves%WaveNum_Cen, & - "Central wavenumbers for surface Stokes drift bands.", & - units='rad/m', default=0.12566, scale=OS%US%Z_to_m) - endif if (associated(OS%grid%Domain%maskmap)) then call initialize_ocean_public_type(OS%grid%Domain%mpp_domain, Ocean_sfc, & diff --git a/src/user/MOM_wave_interface.F90 b/src/user/MOM_wave_interface.F90 index e1e4ab0f77..d51f6ae46a 100644 --- a/src/user/MOM_wave_interface.F90 +++ b/src/user/MOM_wave_interface.F90 @@ -24,6 +24,7 @@ module MOM_wave_interface #include public MOM_wave_interface_init ! Public interface to fully initialize the wave routines. +public query_wave_properties ! Public interface to obtain information from the waves control structure. public Update_Surface_Waves ! Public interface to update wave information at the ! coupler/driver level. public Update_Stokes_Drift ! Public interface to update the Stokes drift profiles @@ -322,6 +323,9 @@ subroutine MOM_wave_interface_init(time, G, GV, US, param_file, CS, diag ) "STK_BAND_COUPLER is the number of Stokes drift bands in the coupler. "// & "This has to be consistent with the number of Stokes drift bands in WW3, "//& "or the model will fail.",units='', default=1) + call get_param(param_file, mdl, "SURFBAND_WAVENUMBERS", CS%WaveNum_Cen, & + "Central wavenumbers for surface Stokes drift bands.", & + units='rad/m', default=0.12566, scale=US%Z_to_m) allocate( CS%WaveNum_Cen(CS%NumBands) ) allocate( CS%STKx0(G%isdB:G%iedB,G%jsd:G%jed,CS%NumBands)) allocate( CS%STKy0(G%isdB:G%iedB,G%jsd:G%jed,CS%NumBands)) @@ -428,6 +432,30 @@ subroutine MOM_wave_interface_init(time, G, GV, US, param_file, CS, diag ) end subroutine MOM_wave_interface_init +!> This interface provides the caller with information from the waves control structure. +subroutine query_wave_properties(CS, NumBands, WaveNumbers, US) + type(wave_parameters_CS), pointer :: CS !< Wave parameter Control structure + integer, optional, intent(out) :: NumBands !< If present, this returns the number of + !!< wavenumber partitions in the wave discretization + real, dimension(:), optional, intent(out) :: Wavenumbers !< If present this returns the characteristic + !! wavenumbers of the wave discretization [m-1 or Z-1 ~> m-1] + type(unit_scale_type), optional, intent(in) :: US !< A dimensional unit scaling type that is used to undo + !! the dimensional scaling of the output variables, if present + integer :: n + + if (present(NumBands)) NumBands = CS%NumBands + if (present(Wavenumbers)) then + if (size(Wavenumbers) < CS%NumBands) call MOM_error(FATAL, "query_wave_properties called "//& + "with a Wavenumbers array that is smaller than the number of bands.") + if (present(US)) then + do n=1,CS%NumBands ; Wavenumbers(n) = US%m_to_Z * CS%WaveNum_Cen(n) ; enddo + else + do n=1,CS%NumBands ; Wavenumbers(n) = CS%WaveNum_Cen(n) ; enddo + endif + endif + +end subroutine query_wave_properties + !> Subroutine that handles updating of surface wave/Stokes drift related properties subroutine Update_Surface_Waves(G, GV, US, Day, dt, CS, forces) type(wave_parameters_CS), pointer :: CS !< Wave parameter Control structure From f6c1fc73a700d26b4fc84014ad69b93f956524ec Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Mon, 12 Jul 2021 18:47:14 +0000 Subject: [PATCH 110/112] Allocate Waves%WaveNum_Cen before reading into it Moved the recently added call to read SURFBAND_WAVENUMBERS into an array when SURFBAND_SOURCE=COUPLER down by a line to follow the allocate call for that array. This change should avert a memory access problem that would otherwise arise when exercising this newly added code. All answers are bitwise identical in any case that ran with the previous version, and they should reproduce answers from before this PR as a whole, although obviously this code is not as well tested as would be ideal, based on the fact that this bug was in the last commit, which also passed testing. --- src/user/MOM_wave_interface.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/user/MOM_wave_interface.F90 b/src/user/MOM_wave_interface.F90 index d51f6ae46a..b612ef4270 100644 --- a/src/user/MOM_wave_interface.F90 +++ b/src/user/MOM_wave_interface.F90 @@ -323,10 +323,10 @@ subroutine MOM_wave_interface_init(time, G, GV, US, param_file, CS, diag ) "STK_BAND_COUPLER is the number of Stokes drift bands in the coupler. "// & "This has to be consistent with the number of Stokes drift bands in WW3, "//& "or the model will fail.",units='', default=1) + allocate( CS%WaveNum_Cen(CS%NumBands) ) call get_param(param_file, mdl, "SURFBAND_WAVENUMBERS", CS%WaveNum_Cen, & "Central wavenumbers for surface Stokes drift bands.", & units='rad/m', default=0.12566, scale=US%Z_to_m) - allocate( CS%WaveNum_Cen(CS%NumBands) ) allocate( CS%STKx0(G%isdB:G%iedB,G%jsd:G%jed,CS%NumBands)) allocate( CS%STKy0(G%isdB:G%iedB,G%jsd:G%jed,CS%NumBands)) CS%WaveNum_Cen(:) = 0.0 From 01b51e825a8312b0730394f565641f4e38189953 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 15 Jul 2021 10:23:37 -0400 Subject: [PATCH 111/112] +Add query_ocean_state Added the new routine query_ocean_state to mom_ocean_model_nuopc to allow for the wave properties to be obtained by the mom_cap without having to rely on the elements of an otherwise opaque type being public. I believe that all elements of the ocean_state_type could now be declared as private, and that the version of MOM6 with the NUOPC coupler should now work as intended. --- config_src/drivers/nuopc_cap/mom_cap.F90 | 16 +++++----- .../nuopc_cap/mom_ocean_model_nuopc.F90 | 29 +++++++++++++++++-- 2 files changed, 36 insertions(+), 9 deletions(-) diff --git a/config_src/drivers/nuopc_cap/mom_cap.F90 b/config_src/drivers/nuopc_cap/mom_cap.F90 index 6561f63fd1..394cf05285 100644 --- a/config_src/drivers/nuopc_cap/mom_cap.F90 +++ b/config_src/drivers/nuopc_cap/mom_cap.F90 @@ -29,12 +29,11 @@ module MOM_cap_mod use MOM_domains, only: pass_var use MOM_error_handler, only: MOM_error, FATAL, is_root_pe use MOM_grid, only: ocean_grid_type, get_global_grid_size -use MOM_wave_interface, only: query_wave_properties use MOM_ocean_model_nuopc, only: ice_ocean_boundary_type use MOM_ocean_model_nuopc, only: ocean_model_restart, ocean_public_type, ocean_state_type use MOM_ocean_model_nuopc, only: ocean_model_init_sfc use MOM_ocean_model_nuopc, only: ocean_model_init, update_ocean_model, ocean_model_end -use MOM_ocean_model_nuopc, only: get_ocean_grid, get_eps_omesh +use MOM_ocean_model_nuopc, only: get_ocean_grid, get_eps_omesh, query_ocean_state use MOM_cap_time, only: AlarmInit use MOM_cap_methods, only: mom_import, mom_export, mom_set_geomtype, mod2med_areacor use MOM_cap_methods, only: med2mod_areacor, state_diagnose @@ -422,6 +421,7 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) character(len=64) :: logmsg logical :: isPresent, isPresentDiro, isPresentLogfile, isSet logical :: existflag + logical :: use_waves ! If true, the wave modules are active. integer :: userRc integer :: localPet integer :: localPeCount @@ -696,8 +696,9 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) Ice_ocean_boundary%lrunoff = 0.0 Ice_ocean_boundary%frunoff = 0.0 - if (ocean_state%use_waves) then - call query_wave_properties(ocean_state%Waves, NumBands=Ice_ocean_boundary%num_stk_bands) + call query_ocean_state(ocean_state, use_waves=use_waves) + if (use_waves) then + call query_ocean_state(ocean_state, NumWaveBands=Ice_ocean_boundary%num_stk_bands) allocate ( Ice_ocean_boundary% ustk0 (isc:iec,jsc:jec), & Ice_ocean_boundary% vstk0 (isc:iec,jsc:jec), & Ice_ocean_boundary% ustkb (isc:iec,jsc:jec,Ice_ocean_boundary%num_stk_bands), & @@ -705,11 +706,12 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) Ice_ocean_boundary%stk_wavenumbers (Ice_ocean_boundary%num_stk_bands)) Ice_ocean_boundary%ustk0 = 0.0 Ice_ocean_boundary%vstk0 = 0.0 - call query_wave_properties(ocean_state%Waves, WaveNumbers=Ice_ocean_boundary%stk_wavenumbers, & - US=ocean_state%US) + call query_ocean_state(ocean_state, WaveNumbers=Ice_ocean_boundary%stk_wavenumbers, unscale=.true.) Ice_ocean_boundary%ustkb = 0.0 Ice_ocean_boundary%vstkb = 0.0 endif + ! Consider adding this: + ! if (.not.use_waves) Ice_ocean_boundary%num_stk_bands = 0 ocean_internalstate%ptr%ocean_state_type_ptr => ocean_state call ESMF_GridCompSetInternalState(gcomp, ocean_internalstate, rc) @@ -754,7 +756,7 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) !These are not currently used and changing requires a nuopc dictionary change !call fld_list_add(fldsToOcn_num, fldsToOcn, "mean_runoff_heat_flx" , "will provide") !call fld_list_add(fldsToOcn_num, fldsToOcn, "mean_calving_heat_flx" , "will provide") - if (ocean_state%use_waves) then + if (use_waves) then if (Ice_ocean_boundary%num_stk_bands > 3) then call MOM_error(FATAL, "Number of Stokes Bands > 3, NUOPC cap not set up for this") endif diff --git a/config_src/drivers/nuopc_cap/mom_ocean_model_nuopc.F90 b/config_src/drivers/nuopc_cap/mom_ocean_model_nuopc.F90 index 06fa905a23..03f2b1ed9d 100644 --- a/config_src/drivers/nuopc_cap/mom_ocean_model_nuopc.F90 +++ b/config_src/drivers/nuopc_cap/mom_ocean_model_nuopc.F90 @@ -58,7 +58,7 @@ module MOM_ocean_model_nuopc use mpp_mod, only : mpp_chksum use MOM_EOS, only : gsw_sp_from_sr, gsw_pt_from_ct use MOM_wave_interface, only : wave_parameters_CS, MOM_wave_interface_init -use MOM_wave_interface, only : Update_Surface_Waves +use MOM_wave_interface, only : Update_Surface_Waves, query_wave_properties use MOM_surface_forcing_nuopc, only : surface_forcing_init, convert_IOB_to_fluxes use MOM_surface_forcing_nuopc, only : convert_IOB_to_forces, ice_ocn_bnd_type_chksum use MOM_surface_forcing_nuopc, only : ice_ocean_boundary_type, surface_forcing_CS @@ -80,7 +80,7 @@ module MOM_ocean_model_nuopc public ocean_model_restart public ice_ocn_bnd_type_chksum public ocean_public_type_chksum -public get_ocean_grid +public get_ocean_grid, query_ocean_state public get_eps_omesh !> This type is used for communication with other components via the FMS coupler. @@ -1000,6 +1000,31 @@ subroutine ocean_model_flux_init(OS, verbosity) end subroutine ocean_model_flux_init +!> This interface allows certain properties that are stored in the ocean_state_type to be +!! obtained. +subroutine query_ocean_state(OS, use_waves, NumWaveBands, Wavenumbers, unscale) + type(ocean_state_type), intent(in) :: OS !< The structure with the complete ocean state + logical, optional, intent(out) :: use_waves !< Indicates whether surface waves are in use + integer, optional, intent(out) :: NumWaveBands !< If present, this gives the number of + !! wavenumber partitions in the wave discretization + real, dimension(:), optional, intent(out) :: Wavenumbers !< If present, this gives the characteristic + !! wavenumbers of the wave discretization [m-1 or Z-1 ~> m-1] + logical, optional, intent(in) :: unscale !< If present and true, undo any dimensional + !! rescaling and return dimensional values in MKS units + + logical :: undo_scaling + undo_scaling = .false. ; if (present(unscale)) undo_scaling = unscale + + if (present(use_waves)) use_waves = OS%use_waves + if (present(NumWaveBands)) call query_wave_properties(OS%Waves, NumBands=NumWaveBands) + if (present(Wavenumbers) .and. undo_scaling) then + call query_wave_properties(OS%Waves, WaveNumbers=WaveNumbers, US=OS%US) + elseif (present(Wavenumbers)) then + call query_wave_properties(OS%Waves, WaveNumbers=WaveNumbers) + endif + +end subroutine query_ocean_state + !> Ocean_stock_pe - returns the integrated stocks of heat, water, etc. for conservation checks. !! Because of the way FMS is coded, only the root PE has the integrated amount, !! while all other PEs get 0. From 2ff2419eb086a6eac8d02322ea2dabd734de556f Mon Sep 17 00:00:00 2001 From: jiandewang Date: Sun, 18 Jul 2021 13:03:38 -0400 Subject: [PATCH 112/112] initialize CS%WaveNum_Cen before read in this parameter --- src/user/MOM_wave_interface.F90 | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/user/MOM_wave_interface.F90 b/src/user/MOM_wave_interface.F90 index b612ef4270..38aa6b13a5 100644 --- a/src/user/MOM_wave_interface.F90 +++ b/src/user/MOM_wave_interface.F90 @@ -324,15 +324,15 @@ subroutine MOM_wave_interface_init(time, G, GV, US, param_file, CS, diag ) "This has to be consistent with the number of Stokes drift bands in WW3, "//& "or the model will fail.",units='', default=1) allocate( CS%WaveNum_Cen(CS%NumBands) ) - call get_param(param_file, mdl, "SURFBAND_WAVENUMBERS", CS%WaveNum_Cen, & - "Central wavenumbers for surface Stokes drift bands.", & - units='rad/m', default=0.12566, scale=US%Z_to_m) allocate( CS%STKx0(G%isdB:G%iedB,G%jsd:G%jed,CS%NumBands)) allocate( CS%STKy0(G%isdB:G%iedB,G%jsd:G%jed,CS%NumBands)) CS%WaveNum_Cen(:) = 0.0 CS%STKx0(:,:,:) = 0.0 CS%STKy0(:,:,:) = 0.0 CS%PartitionMode = 0 + call get_param(param_file, mdl, "SURFBAND_WAVENUMBERS", CS%WaveNum_Cen, & + "Central wavenumbers for surface Stokes drift bands.", & + units='rad/m', default=0.12566, scale=US%Z_to_m) case (INPUT_STRING)! A method to input the Stokes band (globally uniform) CS%DataSource = INPUT call get_param(param_file,mdl,"SURFBAND_NB",CS%NumBands, &